aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorAndrea Corallo2024-02-28 20:47:57 +0100
committerAndrea Corallo2024-02-28 20:47:57 +0100
commit1fbe56c32761efdc8d268df80a97a9102d00e109 (patch)
tree8d8e76c8ae43c79ef9d76b0f97c12607567664b9
parent6de60f33ed5cc438e20400aee83e1e2032773811 (diff)
parent05195e129fc933db32c9e08a155a94bfa4d75b54 (diff)
downloademacs-1fbe56c32761efdc8d268df80a97a9102d00e109.tar.gz
emacs-1fbe56c32761efdc8d268df80a97a9102d00e109.zip
Merge remote-tracking branch 'origin/master' into 'feature/type-hierarchy'
-rw-r--r--.dir-locals.el12
-rw-r--r--.mailmap6
-rw-r--r--BUGS4
-rw-r--r--CONTRIBUTE46
-rw-r--r--ChangeLog.34
-rw-r--r--GNUmakefile50
-rw-r--r--admin/CPP-DEFINES15
-rw-r--r--admin/authors.el3
-rw-r--r--admin/codespell/codespell.exclude2
-rw-r--r--admin/gitmerge.el8
-rwxr-xr-xadmin/merge-gnulib2
-rw-r--r--admin/notes/kind-communication21
-rwxr-xr-xadmin/notes/tree-sitter/build-module/build.sh2
-rw-r--r--configure.ac16
-rw-r--r--cross/verbose.mk.android13
-rw-r--r--doc/emacs/basic.texi17
-rw-r--r--doc/emacs/buffers.texi2
-rw-r--r--doc/emacs/display.texi8
-rw-r--r--doc/emacs/help.texi5
-rw-r--r--doc/emacs/text.texi6
-rw-r--r--doc/lispref/abbrevs.texi2
-rw-r--r--doc/lispref/compile.texi66
-rw-r--r--doc/lispref/control.texi10
-rw-r--r--doc/lispref/elisp.texi2
-rw-r--r--doc/lispref/intro.texi6
-rw-r--r--doc/lispref/minibuf.texi8
-rw-r--r--doc/lispref/modes.texi71
-rw-r--r--doc/lispref/objects.texi5
-rw-r--r--doc/lispref/package.texi48
-rw-r--r--doc/lispref/parsing.texi33
-rw-r--r--doc/lispref/sequences.texi40
-rw-r--r--doc/lispref/symbols.texi82
-rw-r--r--doc/misc/epa.texi9
-rw-r--r--doc/misc/erc.texi33
-rw-r--r--doc/misc/eshell.texi703
-rw-r--r--doc/misc/gnus.texi14
-rw-r--r--doc/misc/texinfo.tex37
-rw-r--r--doc/misc/tramp.texi34
-rw-r--r--doc/translations/README211
-rw-r--r--doc/translations/fr/misc/ses-fr.texi (renamed from doc/lang/fr/misc/ses-fr.texi)0
-rw-r--r--etc/ERC-NEWS30
-rw-r--r--etc/NEWS226
-rw-r--r--etc/NEWS.255
-rw-r--r--etc/PROBLEMS47
-rw-r--r--etc/emacs_lldb.py1
-rw-r--r--etc/images/README7
-rw-r--r--etc/images/conceal.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/conceal.svg4
-rw-r--r--etc/images/reveal.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/reveal.svg4
-rwxr-xr-xjava/debug.sh13
-rw-r--r--java/org/gnu/emacs/EmacsActivity.java36
-rw-r--r--java/org/gnu/emacs/EmacsContextMenu.java17
-rw-r--r--java/org/gnu/emacs/EmacsService.java90
-rw-r--r--java/org/gnu/emacs/EmacsWindow.java101
-rw-r--r--leim/Makefile.in6
-rw-r--r--lib-src/Makefile.in4
-rw-r--r--lib/cdefs.h4
-rw-r--r--lib/gnulib.mk.in9
-rw-r--r--lib/limits.in.h2
-rw-r--r--lib/nstrftime.c1501
-rw-r--r--lib/strftime.c2051
-rw-r--r--lib/strftime.h73
-rw-r--r--lib/string.in.h14
-rw-r--r--lib/time.in.h20
-rw-r--r--lib/time_r.c5
-rw-r--r--lib/warn-on-use.h4
-rw-r--r--lib/xalloc-oversized.h3
-rw-r--r--lisp/abbrev.el5
-rw-r--r--lisp/allout.el6
-rw-r--r--lisp/auth-source.el2
-rw-r--r--lisp/bind-key.el1
-rw-r--r--lisp/buff-menu.el41
-rw-r--r--lisp/cedet/mode-local.el4
-rw-r--r--lisp/cedet/semantic/lex-spp.el6
-rw-r--r--lisp/cedet/semantic/lex.el4
-rw-r--r--lisp/comint.el2
-rw-r--r--lisp/completion-preview.el24
-rw-r--r--lisp/completion.el8
-rw-r--r--lisp/cus-edit.el35
-rw-r--r--lisp/cus-face.el2
-rw-r--r--lisp/cus-start.el1
-rw-r--r--lisp/desktop.el17
-rw-r--r--lisp/dired.el5
-rw-r--r--lisp/emacs-lisp/bytecomp.el633
-rw-r--r--lisp/emacs-lisp/cconv.el12
-rw-r--r--lisp/emacs-lisp/check-declare.el116
-rw-r--r--lisp/emacs-lisp/checkdoc.el2
-rw-r--r--lisp/emacs-lisp/cl-generic.el74
-rw-r--r--lisp/emacs-lisp/cl-macs.el18
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el2
-rw-r--r--lisp/emacs-lisp/comp-common.el5
-rw-r--r--lisp/emacs-lisp/comp-cstr.el30
-rw-r--r--lisp/emacs-lisp/comp-run.el2
-rw-r--r--lisp/emacs-lisp/comp.el1076
-rw-r--r--lisp/emacs-lisp/compat.el92
-rw-r--r--lisp/emacs-lisp/derived.el131
-rw-r--r--lisp/emacs-lisp/disass.el2
-rw-r--r--lisp/emacs-lisp/easy-mmode.el2
-rw-r--r--lisp/emacs-lisp/edebug.el29
-rw-r--r--lisp/emacs-lisp/eieio.el4
-rw-r--r--lisp/emacs-lisp/eldoc.el4
-rw-r--r--lisp/emacs-lisp/elint.el1
-rw-r--r--lisp/emacs-lisp/find-func.el1
-rw-r--r--lisp/emacs-lisp/inline.el4
-rw-r--r--lisp/emacs-lisp/lisp-mode.el6
-rw-r--r--lisp/emacs-lisp/loaddefs-gen.el73
-rw-r--r--lisp/emacs-lisp/map.el28
-rw-r--r--lisp/emacs-lisp/package-vc.el19
-rw-r--r--lisp/emacs-lisp/package.el3
-rw-r--r--lisp/emacs-lisp/pcase.el57
-rw-r--r--lisp/emacs-lisp/seq.el4
-rw-r--r--lisp/emacs-lisp/shortdoc.el33
-rw-r--r--lisp/emacs-lisp/shorthands.el34
-rw-r--r--lisp/emacs-lisp/trace.el2
-rw-r--r--lisp/epa-ks.el3
-rw-r--r--lisp/epa.el34
-rw-r--r--lisp/erc/erc-backend.el24
-rw-r--r--lisp/erc/erc-common.el2
-rw-r--r--lisp/erc/erc-compat.el48
-rw-r--r--lisp/erc/erc-fill.el64
-rw-r--r--lisp/erc/erc-goodies.el2
-rw-r--r--lisp/erc/erc-networks.el25
-rw-r--r--lisp/erc/erc-speedbar.el5
-rw-r--r--lisp/erc/erc-stamp.el40
-rw-r--r--lisp/erc/erc.el165
-rw-r--r--lisp/eshell/em-unix.el14
-rw-r--r--lisp/eshell/esh-arg.el2
-rw-r--r--lisp/eshell/esh-ext.el6
-rw-r--r--lisp/eshell/esh-mode.el18
-rw-r--r--lisp/eshell/esh-opt.el62
-rw-r--r--lisp/eshell/esh-var.el2
-rw-r--r--lisp/faces.el4
-rw-r--r--lisp/ffap.el4
-rw-r--r--lisp/files.el25
-rw-r--r--lisp/filesets.el44
-rw-r--r--lisp/forms.el2
-rw-r--r--lisp/gnus/gnus-agent.el8
-rw-r--r--lisp/gnus/gnus-art.el2
-rw-r--r--lisp/gnus/gnus-dired.el9
-rw-r--r--lisp/gnus/gnus-msg.el4
-rw-r--r--lisp/gnus/gnus-score.el11
-rw-r--r--lisp/gnus/gnus-util.el3
-rw-r--r--lisp/gnus/gnus.el30
-rw-r--r--lisp/gnus/nnheader.el2
-rw-r--r--lisp/help-fns.el102
-rw-r--r--lisp/help-mode.el12
-rw-r--r--lisp/help.el33
-rw-r--r--lisp/ielm.el29
-rw-r--r--lisp/image.el26
-rw-r--r--lisp/info.el35
-rw-r--r--lisp/international/titdic-cnv.el119
-rw-r--r--lisp/loadup.el2
-rw-r--r--lisp/mail/mail-extr.el2
-rw-r--r--lisp/mail/mailabbrev.el12
-rw-r--r--lisp/mail/rmail.el182
-rw-r--r--lisp/mail/rmailkwd.el2
-rw-r--r--lisp/menu-bar.el9
-rw-r--r--lisp/minibuffer.el30
-rw-r--r--lisp/mpc.el13
-rw-r--r--lisp/net/browse-url.el8
-rw-r--r--lisp/net/dns.el2
-rw-r--r--lisp/net/eww.el2
-rw-r--r--lisp/net/imap.el8
-rw-r--r--lisp/net/shr.el76
-rw-r--r--lisp/net/tramp-adb.el32
-rw-r--r--lisp/net/tramp-androidsu.el577
-rw-r--r--lisp/net/tramp-archive.el4
-rw-r--r--lisp/net/tramp-cache.el105
-rw-r--r--lisp/net/tramp-compat.el4
-rw-r--r--lisp/net/tramp-container.el60
-rw-r--r--lisp/net/tramp-gvfs.el7
-rw-r--r--lisp/net/tramp-integration.el2
-rw-r--r--lisp/net/tramp-message.el4
-rw-r--r--lisp/net/tramp-sh.el67
-rw-r--r--lisp/net/tramp-sshfs.el4
-rw-r--r--lisp/net/tramp-sudoedit.el2
-rw-r--r--lisp/net/tramp.el87
-rw-r--r--lisp/obarray.el24
-rw-r--r--lisp/obsolete/iswitchb.el4
-rw-r--r--lisp/obsolete/longlines.el14
-rw-r--r--lisp/obsolete/pgg.el4
-rw-r--r--lisp/obsolete/rcompile.el14
-rw-r--r--lisp/org/org.el2
-rw-r--r--lisp/outline.el28
-rw-r--r--lisp/play/cookie1.el2
-rw-r--r--lisp/proced.el2
-rw-r--r--lisp/progmodes/c-ts-mode.el15
-rw-r--r--lisp/progmodes/cc-defs.el7
-rw-r--r--lisp/progmodes/cc-langs.el2
-rw-r--r--lisp/progmodes/cmake-ts-mode.el18
-rw-r--r--lisp/progmodes/compile.el16
-rw-r--r--lisp/progmodes/cperl-mode.el13
-rw-r--r--lisp/progmodes/eglot.el12
-rw-r--r--lisp/progmodes/elisp-mode.el44
-rw-r--r--lisp/progmodes/elixir-ts-mode.el56
-rw-r--r--lisp/progmodes/etags.el4
-rw-r--r--lisp/progmodes/flymake.el20
-rw-r--r--lisp/progmodes/gud.el2
-rw-r--r--lisp/progmodes/heex-ts-mode.el10
-rw-r--r--lisp/progmodes/hideif.el14
-rw-r--r--lisp/progmodes/idlw-shell.el4
-rw-r--r--lisp/progmodes/java-ts-mode.el13
-rw-r--r--lisp/progmodes/js.el27
-rw-r--r--lisp/progmodes/lua-ts-mode.el18
-rw-r--r--lisp/progmodes/modula2.el47
-rw-r--r--lisp/progmodes/opascal.el2
-rw-r--r--lisp/progmodes/project.el14
-rw-r--r--lisp/progmodes/python.el250
-rw-r--r--lisp/progmodes/ruby-ts-mode.el14
-rw-r--r--lisp/progmodes/typescript-ts-mode.el362
-rw-r--r--lisp/progmodes/vhdl-mode.el90
-rw-r--r--lisp/progmodes/which-func.el4
-rw-r--r--lisp/server.el6
-rw-r--r--lisp/simple.el83
-rw-r--r--lisp/sort.el21
-rw-r--r--lisp/speedbar.el2
-rw-r--r--lisp/startup.el24
-rw-r--r--lisp/subr.el65
-rw-r--r--lisp/term/android-win.el44
-rw-r--r--lisp/textmodes/html-ts-mode.el11
-rw-r--r--lisp/textmodes/pixel-fill.el68
-rw-r--r--lisp/textmodes/reftex-vars.el5
-rw-r--r--lisp/textmodes/rst.el8
-rw-r--r--lisp/textmodes/tex-mode.el43
-rw-r--r--lisp/textmodes/text-mode.el2
-rw-r--r--lisp/textmodes/yaml-ts-mode.el5
-rw-r--r--lisp/thingatpt.el44
-rw-r--r--lisp/touch-screen.el2
-rw-r--r--lisp/transient.el1
-rw-r--r--lisp/treesit.el156
-rw-r--r--lisp/url/url-cid.el11
-rw-r--r--lisp/url/url-http.el2
-rw-r--r--lisp/url/url-ldap.el10
-rw-r--r--lisp/url/url-mailto.el17
-rw-r--r--lisp/vc/diff-mode.el173
-rw-r--r--lisp/vc/vc-git.el11
-rw-r--r--lisp/vc/vc-hooks.el5
-rw-r--r--lisp/vc/vc.el15
-rw-r--r--lisp/vcursor.el2
-rw-r--r--lisp/visual-wrap.el10
-rw-r--r--lisp/winner.el3
-rw-r--r--lisp/woman.el3
-rw-r--r--m4/copy-file-range.m441
-rw-r--r--m4/gettime.m44
-rw-r--r--m4/gnulib-common.m476
-rw-r--r--m4/gnulib-comp.m46
-rw-r--r--m4/memset_explicit.m46
-rw-r--r--m4/nanosleep.m46
-rw-r--r--m4/nstrftime.m45
-rw-r--r--m4/string_h.m43
-rw-r--r--m4/time_h.m43
-rw-r--r--m4/utimens.m415
-rw-r--r--m4/utimensat.m45
-rw-r--r--nt/cmdproxy.c8
-rw-r--r--nt/gnulib-cfg.mk1
-rw-r--r--src/alloc.c48
-rw-r--r--src/android.c81
-rw-r--r--src/android.h9
-rw-r--r--src/androidfns.c106
-rw-r--r--src/androidselect.c20
-rw-r--r--src/androidterm.c4
-rw-r--r--src/androidvfs.c32
-rw-r--r--src/buffer.c64
-rw-r--r--src/buffer.h2
-rw-r--r--src/bytecode.c84
-rw-r--r--src/ccl.c7
-rw-r--r--src/comp.c6
-rw-r--r--src/conf_post.h4
-rw-r--r--src/data.c58
-rw-r--r--src/dispextern.h10
-rw-r--r--src/doc.c58
-rw-r--r--src/editfns.c85
-rw-r--r--src/emacs.c4
-rw-r--r--src/eval.c61
-rw-r--r--src/fileio.c10
-rw-r--r--src/fns.c207
-rw-r--r--src/inotify.c10
-rw-r--r--src/keyboard.c26
-rw-r--r--src/lisp.h311
-rw-r--r--src/lread.c498
-rw-r--r--src/macfont.m96
-rw-r--r--src/marker.c2
-rw-r--r--src/minibuf.c110
-rw-r--r--src/pdumper.c68
-rw-r--r--src/pgtkterm.c4
-rw-r--r--src/print.c29
-rw-r--r--src/process.c33
-rw-r--r--src/sfnt.c10
-rw-r--r--src/sfnt.h2
-rw-r--r--src/sfntfont.c6
-rw-r--r--src/term.c21
-rw-r--r--src/textconv.c10
-rw-r--r--src/thread.c39
-rw-r--r--src/thread.h11
-rw-r--r--src/timefns.c12
-rw-r--r--src/treesit.c4
-rw-r--r--src/verbose.mk.in29
-rw-r--r--src/window.c11
-rw-r--r--src/xdisp.c594
-rw-r--r--src/xfaces.c35
-rw-r--r--test/Makefile.in4
-rw-r--r--test/infra/Dockerfile.emba2
-rw-r--r--test/lisp/abbrev-tests.el4
-rw-r--r--test/lisp/auth-source-tests.el139
-rw-r--r--test/lisp/completion-preview-tests.el15
-rw-r--r--test/lisp/emacs-lisp/bytecomp-tests.el16
-rw-r--r--test/lisp/emacs-lisp/cl-generic-tests.el14
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el22
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-tests.el28
-rw-r--r--test/lisp/emacs-lisp/hierarchy-tests.el5
-rw-r--r--test/lisp/emacs-lisp/macroexp-resources/vk.el2
-rw-r--r--test/lisp/erc/erc-button-tests.el3
-rw-r--r--test/lisp/erc/erc-fill-tests.el5
-rw-r--r--test/lisp/erc/erc-goodies-tests.el4
-rw-r--r--test/lisp/erc/erc-networks-tests.el47
-rw-r--r--test/lisp/erc/erc-scenarios-base-renick.el8
-rw-r--r--test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el46
-rw-r--r--test/lisp/erc/erc-scenarios-misc-commands.el90
-rw-r--r--test/lisp/erc/erc-scenarios-misc.el2
-rw-r--r--test/lisp/erc/erc-stamp-tests.el10
-rw-r--r--test/lisp/erc/erc-tests.el81
-rw-r--r--test/lisp/erc/resources/base/upstream-reconnect/znc-severed.eld87
-rw-r--r--test/lisp/erc/resources/commands/amsg-barnet.eld54
-rw-r--r--test/lisp/erc/resources/commands/amsg-foonet.eld56
-rw-r--r--test/lisp/erc/resources/erc-scenarios-common.el5
-rw-r--r--test/lisp/erc/resources/erc-tests-common.el2
-rw-r--r--test/lisp/eshell/esh-opt-tests.el24
-rw-r--r--test/lisp/eshell/eshell-tests.el2
-rw-r--r--test/lisp/filenotify-tests.el53
-rw-r--r--test/lisp/files-tests.el51
-rw-r--r--test/lisp/info-tests.el16
-rw-r--r--test/lisp/international/mule-tests.el4
-rw-r--r--test/lisp/minibuffer-tests.el7
-rw-r--r--test/lisp/net/tramp-archive-tests.el4
-rw-r--r--test/lisp/net/tramp-tests.el120
-rw-r--r--test/lisp/obarray-tests.el31
-rw-r--r--test/lisp/progmodes/java-ts-mode-resources/indent.erts31
-rw-r--r--test/lisp/progmodes/python-tests.el146
-rw-r--r--test/lisp/thingatpt-tests.el9
-rw-r--r--test/src/comp-resources/comp-test-funcs.el4
-rw-r--r--test/src/comp-tests.el25
-rw-r--r--test/src/eval-tests.el37
-rw-r--r--test/src/fns-tests.el10
-rw-r--r--test/src/minibuf-tests.el14
-rw-r--r--test/src/treesit-tests.el2
346 files changed, 11139 insertions, 6254 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 @@
3 3
4((nil . ((tab-width . 8) 4((nil . ((tab-width . 8)
5 (sentence-end-double-space . t) 5 (sentence-end-double-space . t)
6 (fill-column . 70) 6 (fill-column . 72)
7 (emacs-lisp-docstring-fill-column . 65) 7 (emacs-lisp-docstring-fill-column . 72)
8 (vc-git-annotate-switches . "-w") 8 (vc-git-annotate-switches . "-w")
9 (bug-reference-url-format . "https://debbugs.gnu.org/%s") 9 (bug-reference-url-format . "https://debbugs.gnu.org/%s")
10 (diff-add-log-use-relative-names . t) 10 (diff-add-log-use-relative-names . t)
@@ -23,6 +23,11 @@
23 (electric-quote-string . nil) 23 (electric-quote-string . nil)
24 (indent-tabs-mode . t) 24 (indent-tabs-mode . t)
25 (mode . bug-reference-prog))) 25 (mode . bug-reference-prog)))
26 (java-mode . ((c-file-style . "GNU")
27 (electric-quote-comment . nil)
28 (electric-quote-string . nil)
29 (indent-tabs-mode . t)
30 (mode . bug-reference-prog)))
26 (objc-mode . ((c-file-style . "GNU") 31 (objc-mode . ((c-file-style . "GNU")
27 (electric-quote-comment . nil) 32 (electric-quote-comment . nil)
28 (electric-quote-string . nil) 33 (electric-quote-string . nil)
@@ -32,7 +37,8 @@
32 (mode . bug-reference-prog))) 37 (mode . bug-reference-prog)))
33 (log-edit-mode . ((log-edit-font-lock-gnu-style . t) 38 (log-edit-mode . ((log-edit-font-lock-gnu-style . t)
34 (log-edit-setup-add-author . t) 39 (log-edit-setup-add-author . t)
35 (vc-git-log-edit-summary-target-len . 50))) 40 (vc-git-log-edit-summary-target-len . 50)
41 (fill-column . 64)))
36 (change-log-mode . ((add-log-time-zone-rule . t) 42 (change-log-mode . ((add-log-time-zone-rule . t)
37 (fill-column . 74) 43 (fill-column . 74)
38 (mode . bug-reference))) 44 (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>
116Lars Ingebrigtsen <larsi@gnus.org> <larsi@stories.gnus.org> 116Lars Ingebrigtsen <larsi@gnus.org> <larsi@stories.gnus.org>
117Laurence Warne <laurencewarne@gmail.com> 117Laurence Warne <laurencewarne@gmail.com>
118Lin Sun <lin.sun@zoom.us> 118Lin Sun <lin.sun@zoom.us>
119Liu Hui <liuhui1610@gmail.com> <ilupin@users.noreply.github.com>
119Ludovic Courtès <ludo@gnu.org> 120Ludovic Courtès <ludo@gnu.org>
120Luke Lee <luke.yx.lee@gmail.com> 121Luke Lee <luke.yx.lee@gmail.com>
121Martin Rudalics <rudalics@gmx.at> 122Martin Rudalics <rudalics@gmx.at>
@@ -129,7 +130,7 @@ Maxim Nikulin <manikulin@gmail.com>
129Michael Albinus <michael.albinus@gmx.de> <albinus@detlef> 130Michael Albinus <michael.albinus@gmx.de> <albinus@detlef>
130Michalis V <mvar.40k@gmail.com> 131Michalis V <mvar.40k@gmail.com>
131Miha Rihtaršič <miha@kamnitnik.top> 132Miha Rihtaršič <miha@kamnitnik.top>
132Morgan J. Smith <Morgan.J.Smith@outlook.com> 133Morgan Smith <Morgan.J.Smith@outlook.com>
133Nick Drozd <nicholasdrozd@gmail.com> 134Nick Drozd <nicholasdrozd@gmail.com>
134Nicolas Petton <nicolas@petton.fr> <petton.nicolas@gmail.com> 135Nicolas Petton <nicolas@petton.fr> <petton.nicolas@gmail.com>
135Nitish Chandra <nitishchandrachinta@gmail.com> 136Nitish Chandra <nitishchandrachinta@gmail.com>
@@ -146,8 +147,7 @@ Philip Kaludercic <philipk@posteo.net>
146Philip Kaludercic <philipk@posteo.net> <philip.kaludercic@fau.de> 147Philip Kaludercic <philipk@posteo.net> <philip.kaludercic@fau.de>
147Philip Kaludercic <philipk@posteo.net> <philip@icterid> 148Philip Kaludercic <philipk@posteo.net> <philip@icterid>
148Philip Kaludercic <philipk@posteo.net> <philip@warpmail.net> 149Philip Kaludercic <philipk@posteo.net> <philip@warpmail.net>
149Philipp Stephani <phst@google.com> 150Philipp Stephani <p.stephani2@gmail.com>
150Philipp Stephani <phst@google.com> Philipp Stephani <p.stephani2@gmail.com>
151Phillip Lord <phillip.lord@russet.org.uk> <phillip.lord@newcastle.ac.uk> 151Phillip Lord <phillip.lord@russet.org.uk> <phillip.lord@newcastle.ac.uk>
152Pierre Lorenzon <devel@pollock-nageoire.net> 152Pierre Lorenzon <devel@pollock-nageoire.net>
153Pieter van Oostrum <pieter@vanoostrum.org> <pieter-l@vanoostrum.org> 153Pieter 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:
21 21
22 cat info/emacs* | more "+/^File: emacs.*, Node: Bugs," 22 cat info/emacs* | more "+/^File: emacs.*, Node: Bugs,"
23 23
24If you think you may have found a critical security issue that needs
25to be communicated privately, please contact the GNU Emacs maintainers
26directly. See admin/MAINTAINERS for their contact details.
27
24 28
25Please first check the file etc/PROBLEMS (e.g. with C-h C-p in Emacs) to 29Please first check the file etc/PROBLEMS (e.g. with C-h C-p in Emacs) to
26make sure it isn't a known issue. 30make 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.
115 115
116Doc-strings should be updated together with the code. 116Doc-strings should be updated together with the code.
117 117
118New defcustom's should always have a ':version' tag stating the first 118New defcustom's and defface's should always have a ':version' tag
119Emacs version in which they will appear. Likewise with defcustom's 119stating the first Emacs version in which they will appear. Likewise
120whose value is changed -- update their ':version' tag. 120with defcustom's or defface's whose value is changed -- update their
121':version' tag.
121 122
122Think about whether your change requires updating the manuals. If you 123Think about whether your change requires updating the manuals. If you
123know it does not, mark the NEWS entry with "---" before the entry. If 124know 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.:
170 171
171** Commit messages 172** Commit messages
172 173
173Ordinarily, a change you commit should contain a log entry in its 174Ordinarily, a changeset you commit should contain a description of the
174commit message and should not touch the repository's ChangeLog files. 175changes in its commit message and should not touch the repository's
175Here is an example commit message (indented): 176ChangeLog files. Here is an example commit message (indented):
176 177
177 Deactivate shifted region 178 Deactivate shifted region
178 179
@@ -184,8 +185,9 @@ Here is an example commit message (indented):
184 Deactivate the mark. 185 Deactivate the mark.
185 186
186Occasionally, commit messages are collected and prepended to a 187Occasionally, commit messages are collected and prepended to a
187ChangeLog file, where they can be corrected. It saves time to get 188generated ChangeLog file, where they can be corrected. It saves time
188them right the first time, so here are guidelines for formatting them: 189to get them right the first time, so here are guidelines for
190formatting them:
189 191
190- Start with a single unindented summary line explaining the change; 192- Start with a single unindented summary line explaining the change;
191 do not end this line with a period. If possible, try to keep the 193 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:
194 contexts. 196 contexts.
195 197
196 If the summary line starts with a semicolon and a space "; ", the 198 If the summary line starts with a semicolon and a space "; ", the
197 commit message will be ignored when generating the ChangeLog file. 199 commit message will be skipped and not added to the generated
198 Use this for minor commits that do not need separate ChangeLog 200 ChangeLog file. Use this for minor commits that do not need to be
199 entries, such as changes in etc/NEWS. 201 mentioned in the ChangeLog file, such as changes in etc/NEWS, typo
202 fixes, etc.
200 203
201- After the summary line, there should be an empty line. 204- After the summary line, there should be an empty line.
202 205
@@ -211,8 +214,9 @@ them right the first time, so here are guidelines for formatting them:
211 enforced by a commit hook. 214 enforced by a commit hook.
212 215
213- If only a single file is changed, the summary line can be the normal 216- If only a single file is changed, the summary line can be the normal
214 file first line (starting with the asterisk). Then there is no 217 first line of a ChangeLog entry (starting with the asterisk). Then
215 individual files section. 218 there will be no individual ChangeLog entries beyond the one in the
219 summary line.
216 220
217- If the commit has more than one author, the commit message should 221- If the commit has more than one author, the commit message should
218 contain separate lines to mention the other authors, like the 222 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:
243- Explaining the rationale for a design choice is best done in comments 247- Explaining the rationale for a design choice is best done in comments
244 in the source code. However, sometimes it is useful to describe just 248 in the source code. However, sometimes it is useful to describe just
245 the rationale for a change; that can be done in the commit message 249 the rationale for a change; that can be done in the commit message
246 between the summary line and the file entries. 250 between the summary line and the following ChangeLog entries.
247 251
248- Emacs generally follows the GNU coding standards for ChangeLogs: see 252- Emacs follows the GNU coding standards for ChangeLog entries: see
249 https://www.gnu.org/prep/standards/html_node/Change-Logs.html 253 https://www.gnu.org/prep/standards/html_node/Change-Logs.html or run
250 or run 'info "(standards)Change Logs"'. One exception is that 254 'info "(standards)Change Logs"'. One exception is that commits
251 commits still sometimes quote `like-this' (as the standards used to 255 still sometimes quote `like-this' (as the standards used to
252 recommend) rather than 'like-this' or ‘like this’ (as they do now), 256 recommend) rather than 'like-this' or ‘like this’ (as they do now),
253 as `...' is so widely used elsewhere in Emacs. 257 as `...' is so widely used elsewhere in Emacs.
254 258
@@ -261,9 +265,9 @@ them right the first time, so here are guidelines for formatting them:
261 in Emacs; that includes spelling and leaving 2 blanks between 265 in Emacs; that includes spelling and leaving 2 blanks between
262 sentences. 266 sentences.
263 267
264 They are preserved indefinitely, and have a reasonable chance of 268 The ChangeLog entries are preserved indefinitely, and have a
265 being read in the future, so it's better that they have good 269 reasonable chance of being read in the future, so it's better that
266 presentation. 270 they have good presentation.
267 271
268- Use the present tense; describe "what the change does", not "what 272- Use the present tense; describe "what the change does", not "what
269 the change did". 273 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 @@
137530 Bind `enable-local-variables' in `hack-connection-local-variables' 137530 Bind `enable-local-variables' in `hack-connection-local-variables'
137531 137531
137532 * lisp/files-x.el (hack-connection-local-variables): 137532 * lisp/files-x.el (hack-connection-local-variables):
137533 Bind `enable-local-variables', instead of re-declaring 137533 Bind `enable-local-variables', instead of redeclaring
137534 `safe-local-variable-p'. 137534 `safe-local-variable-p'.
137535 137535
1375362019-03-23 Eli Zaretskii <eliz@gnu.org> 1375362019-03-23 Eli Zaretskii <eliz@gnu.org>
@@ -163179,7 +163179,7 @@
163179 163179
163180 Quieten compilation of octave.el 163180 Quieten compilation of octave.el
163181 163181
163182 * lisp/progmodes/octave.el (compilation-forget-errors): Re-declare. 163182 * lisp/progmodes/octave.el (compilation-forget-errors): Redeclare.
163183 163183
1631842018-02-28 Glenn Morris <rgm@gnu.org> 1631842018-02-28 Glenn Morris <rgm@gnu.org>
163185 163185
diff --git a/GNUmakefile b/GNUmakefile
index 16064672c65..58c0281e895 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -27,6 +27,8 @@
27# newly-built Makefile. If the source tree is already configured, 27# newly-built Makefile. If the source tree is already configured,
28# this file defers to the existing Makefile. 28# this file defers to the existing Makefile.
29 29
30. :=
31
30# If you want non-default build options, or if you want to build in an 32# If you want non-default build options, or if you want to build in an
31# out-of-source tree, you should run 'configure' before running 'make'. 33# out-of-source tree, you should run 'configure' before running 'make'.
32# But run 'autogen.sh' first, if the source was checked out directly 34# But run 'autogen.sh' first, if the source was checked out directly
@@ -36,30 +38,30 @@
36 38
37ifeq (help,$(filter help,$(MAKECMDGOALS))) 39ifeq (help,$(filter help,$(MAKECMDGOALS)))
38help: 40help:
39 $(info $ NOTE: This is a brief summary of some common make targets.) 41 $(info $.NOTE: This is a brief summary of some common make targets.)
40 $(info $ For more detailed information, please read the files INSTALL,) 42 $(info $.For more detailed information, please read the files INSTALL,)
41 $(info $ INSTALL.REPO, Makefile or visit this URL:) 43 $(info $.INSTALL.REPO, Makefile or visit this URL:)
42 $(info $ https://www.gnu.org/prep/standards/html_node/Standard-Targets.html) 44 $(info $.https://www.gnu.org/prep/standards/html_node/Standard-Targets.html)
43 $(info $ ) 45 $(info $.)
44 $(info $ make all -- compile and build Emacs) 46 $(info $.make all -- compile and build Emacs)
45 $(info $ make install -- install Emacs) 47 $(info $.make install -- install Emacs)
46 $(info $ make TAGS -- update tags tables) 48 $(info $.make TAGS -- update tags tables)
47 $(info $ make clean -- delete built files but preserve configuration) 49 $(info $.make clean -- delete built files but preserve configuration)
48 $(info $ make mostlyclean -- like 'make clean', but leave those files that) 50 $(info $.make mostlyclean -- like 'make clean', but leave those files that)
49 $(info $ usually do not need to be recompiled) 51 $(info $. usually do not need to be recompiled)
50 $(info $ make distclean -- delete all build and configuration files,) 52 $(info $.make distclean -- delete all build and configuration files,)
51 $(info $ leave only files included in source distribution) 53 $(info $. leave only files included in source distribution)
52 $(info $ make maintainer-clean -- delete almost everything that can be regenerated) 54 $(info $.make maintainer-clean -- delete almost everything that can be regenerated)
53 $(info $ make extraclean -- like maintainer-clean, and also delete) 55 $(info $.make extraclean -- like maintainer-clean, and also delete)
54 $(info $ backup and autosave files) 56 $(info $. backup and autosave files)
55 $(info $ make bootstrap -- delete all compiled files to force a new bootstrap) 57 $(info $.make bootstrap -- delete all compiled files to force a new bootstrap)
56 $(info $ from a clean slate, then build in the normal way) 58 $(info $. from a clean slate, then build in the normal way)
57 $(info $ make uninstall -- remove files installed by 'make install') 59 $(info $.make uninstall -- remove files installed by 'make install')
58 $(info $ make check -- run the Emacs test suite) 60 $(info $.make check -- run the Emacs test suite)
59 $(info $ make docs -- generate Emacs documentation in info format) 61 $(info $.make docs -- generate Emacs documentation in info format)
60 $(info $ make html -- generate documentation in html format) 62 $(info $.make html -- generate documentation in html format)
61 $(info $ make ps -- generate documentation in ps format) 63 $(info $.make ps -- generate documentation in ps format)
62 $(info $ make pdf -- generate documentation in pdf format ) 64 $(info $.make pdf -- generate documentation in pdf format )
63 @: 65 @:
64 66
65.PHONY: help 67.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
25USG 25USG
26USG5_4 26USG5_4
27HAIKU Compiling on Haiku. 27HAIKU Compiling on Haiku.
28__ANDROID__ Compiling for the Android operating system.
29__ANDROID_API__ A numerical "API level" indicating the version of
30 Android being compiled for; see http://apilevels.com.
28 31
29** Distinguishing GUIs ** 32** Distinguishing GUIs **
30 33
@@ -35,10 +38,14 @@ NS_IMPL_COCOA Compile support for Cocoa (Apple) implementation of NS GUI API.
35HAVE_X11 Compile support for the X11 GUI. 38HAVE_X11 Compile support for the X11 GUI.
36HAVE_PGTK Compile support for using GTK itself without directly using X Windows APIs. 39HAVE_PGTK Compile support for using GTK itself without directly using X Windows APIs.
37HAVE_HAIKU Compile support for the Haiku window system. 40HAVE_HAIKU Compile support for the Haiku window system.
38HAVE_X_WINDOWS Compile support for X Window system 41HAVE_X_WINDOWS Compile support for X Window system. Equivalent to HAVE_X11.
39 (It looks like, nowadays, if HAVE_X11 is set, HAVE_X_WINDOWS must 42HAVE_ANDROID Compiling the Android GUI interface. Enough of this
40 be, and vice versa. At least, this is true for configure, and 43 code is compiled for the build machine cross-compiling
41 msdos; not sure about nt.) 44 the Android port to produce an Emacs binary that can
45 run Lisp code in batch mode, for the purpose of running
46 the byte-compiler.
47ANDROID_STUBIFY The Android GUI interface is being compiled for the build
48 machine, as above.
42 49
43** X Windows features ** 50** X Windows features **
44HAVE_X11R6 Whether or not the system has X11R6. (Always defined.) 51HAVE_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.")
175 ("Michalis V" "^mvar") 175 ("Michalis V" "^mvar")
176 ("Miha Rihtaršič" "Miha Rihtarsic") 176 ("Miha Rihtaršič" "Miha Rihtarsic")
177 ("Mikio Nakajima" "Nakajima Mikio") 177 ("Mikio Nakajima" "Nakajima Mikio")
178 (nil "montag451@laposte\\.net")
179 (nil "na@aisrntairetnraoitn")
180 ("Morgan Smith" "Morgan J\\. Smith")
178 ("Nelson Jose dos Santos Ferreira" "Nelson Ferreira") 181 ("Nelson Jose dos Santos Ferreira" "Nelson Ferreira")
179 ("Noah Peart" "noah\\.v\\.peart@gmail\\.com") 182 ("Noah Peart" "noah\\.v\\.peart@gmail\\.com")
180 ("Noorul Islam" "Noorul Islam K M") 183 ("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
1583 (ert-info ("Joined by bouncer to #chan@foonet, pal persent") 1583 (ert-info ("Joined by bouncer to #chan@foonet, pal persent")
1584 (ert-info ("Joined by bouncer to #chan@barnet, pal persent") 1584 (ert-info ("Joined by bouncer to #chan@barnet, pal persent")
1585.UE . 1585.UE .
1586 (0.03 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: See, by good hap, yonder's my lord; I have sweat to see his honour.")
1587 (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.")
111 111
112(defvar gitmerge-mode-font-lock-keywords 112(defvar gitmerge-mode-font-lock-keywords
113 `((,gitmerge-log-regexp 113 `((,gitmerge-log-regexp
114 (1 font-lock-warning-face) 114 (1 'font-lock-warning-face)
115 (2 font-lock-constant-face) 115 (2 'font-lock-constant-face)
116 (3 font-lock-builtin-face) 116 (3 'font-lock-builtin-face)
117 (4 font-lock-comment-face)))) 117 (4 'font-lock-comment-face))))
118 118
119(defvar gitmerge--commits nil) 119(defvar gitmerge--commits nil)
120(defvar gitmerge--from nil) 120(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='
53 53
54AVOIDED_MODULES=' 54AVOIDED_MODULES='
55 access btowc chmod close crypto/af_alg dup fchdir fstat 55 access btowc chmod close crypto/af_alg dup fchdir fstat
56 iswblank iswctype iswdigit iswxdigit langinfo lock 56 iswblank iswctype iswdigit iswxdigit langinfo localename-unsafe-limited lock
57 mbrtowc mbsinit memchr mkdir msvc-inval msvc-nothrow nl_langinfo 57 mbrtowc mbsinit memchr mkdir msvc-inval msvc-nothrow nl_langinfo
58 openat-die opendir pthread-h raise 58 openat-die opendir pthread-h raise
59 save-cwd select setenv sigprocmask stat stdarg 59 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 @@
1The GNU Project encourages contributions from anyone who wishes to
2advance the development of the GNU system, regardless of gender, race,
3ethnic group, physical appearance, religion, cultural background, and
4any other demographic characteristics, as well as personal political
5views.
6
7People are sometimes discouraged from participating in GNU development
8because of certain patterns of communication that strike them as
9unfriendly, unwelcoming, rejecting, or harsh. This discouragement
10particularly affects members of disprivileged demographics, but it is
11not limited to them. Therefore, we ask all contributors to make a
12conscious effort, in GNU Project discussions, to communicate in ways
13that avoid that outcome — to avoid practices that will predictably and
14unnecessarily risk putting some contributors off.
15
16The GNU Kind Communications Guidelines suggest specific ways to
17accomplish that goal. You can find the latest version at
18https://www.gnu.org/philosophy/kind-communication.html
19
20When sending messages to Emacs mailing lists, we ask you to read and
21respect 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
43 org="phoenixframework" 43 org="phoenixframework"
44 ;; 44 ;;
45 "lua") 45 "lua")
46 org="MunifTanjim" 46 org="tree-sitter-grammars"
47 ;; 47 ;;
48 "typescript") 48 "typescript")
49 sourcedir="tree-sitter-typescript/typescript/src" 49 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.])
1231 passthrough="$passthrough --with-mailutils=$with_mailutils" 1231 passthrough="$passthrough --with-mailutils=$with_mailutils"
1232 passthrough="$passthrough --with-pop=$with_pop" 1232 passthrough="$passthrough --with-pop=$with_pop"
1233 passthrough="$passthrough --with-harfbuzz=$with_harfbuzz" 1233 passthrough="$passthrough --with-harfbuzz=$with_harfbuzz"
1234 passthrough="$passthrough --with-threads=$with_threads"
1234 1235
1235 # Now pass through some checking options. 1236 # Now pass through some checking options.
1236 emacs_val="--enable-check-lisp-object-type=$enable_check_lisp_object_type" 1237 emacs_val="--enable-check-lisp-object-type=$enable_check_lisp_object_type"
@@ -1321,6 +1322,7 @@ if test "$ANDROID" = "yes"; then
1321 with_pop=no 1322 with_pop=no
1322 with_harfbuzz=no 1323 with_harfbuzz=no
1323 with_native_compilation=no 1324 with_native_compilation=no
1325 with_threads=no
1324 fi 1326 fi
1325 1327
1326 with_rsvg=no 1328 with_rsvg=no
@@ -1331,7 +1333,6 @@ if test "$ANDROID" = "yes"; then
1331 with_gpm=no 1333 with_gpm=no
1332 with_dbus=no 1334 with_dbus=no
1333 with_gsettings=no 1335 with_gsettings=no
1334 with_threads=no
1335 with_ns=no 1336 with_ns=no
1336 1337
1337 # zlib is available in android. 1338 # zlib is available in android.
@@ -2336,6 +2337,7 @@ fi
2336AC_DEFUN([AC_TYPE_SIZE_T]) 2337AC_DEFUN([AC_TYPE_SIZE_T])
2337# Likewise for obsolescent test for uid_t, gid_t; Emacs assumes them. 2338# Likewise for obsolescent test for uid_t, gid_t; Emacs assumes them.
2338AC_DEFUN([AC_TYPE_UID_T]) 2339AC_DEFUN([AC_TYPE_UID_T])
2340ac_cv_type_gid_t=yes # AC_TYPE_GETGROUPS needs this in Autoconf 2.72.
2339 2341
2340# Check for all math.h functions that Emacs uses; on some platforms, 2342# Check for all math.h functions that Emacs uses; on some platforms,
2341# -lm is needed for some of these functions. 2343# -lm is needed for some of these functions.
@@ -4086,16 +4088,16 @@ case $with_file_notification,$opsys in
4086 fi ;; 4088 fi ;;
4087esac 4089esac
4088 4090
4089dnl inotify is available only on GNU/Linux. 4091dnl inotify is available only on Linux-kernel based systems.
4090case $with_file_notification,$NOTIFY_OBJ in 4092case $with_file_notification,$NOTIFY_OBJ in
4091 inotify, | yes,) 4093 inotify, | yes,)
4092 AC_CHECK_HEADER([sys/inotify.h]) 4094 AC_CHECK_HEADER([sys/inotify.h])
4093 if test "$ac_cv_header_sys_inotify_h" = yes ; then 4095 if test "$ac_cv_header_sys_inotify_h" = yes ; then
4094 AC_CHECK_FUNC([inotify_init1]) 4096 AC_CHECK_FUNCS([inotify_init inotify_init1])
4095 if test "$ac_cv_func_inotify_init1" = yes; then 4097 if test "$ac_cv_func_inotify_init" = yes; then
4096 AC_DEFINE([HAVE_INOTIFY], [1], [Define to 1 to use inotify.]) 4098 AC_DEFINE([HAVE_INOTIFY], [1], [Define to 1 to use inotify.])
4097 NOTIFY_OBJ=inotify.o 4099 NOTIFY_OBJ=inotify.o
4098 NOTIFY_SUMMARY="yes -lglibc (inotify)" 4100 NOTIFY_SUMMARY="yes (inotify)"
4099 fi 4101 fi
4100 fi ;; 4102 fi ;;
4101esac 4103esac
@@ -5905,13 +5907,15 @@ pthread_sigmask strsignal setitimer \
5905sendto recvfrom getsockname getifaddrs freeifaddrs \ 5907sendto recvfrom getsockname getifaddrs freeifaddrs \
5906gai_strerror sync \ 5908gai_strerror sync \
5907endpwent getgrent endgrent \ 5909endpwent getgrent endgrent \
5908renameat2 \
5909cfmakeraw cfsetspeed __executable_start log2 pthread_setname_np \ 5910cfmakeraw cfsetspeed __executable_start log2 pthread_setname_np \
5910pthread_set_name_np]) 5911pthread_set_name_np])
5911 5912
5912# getpwent is not present in older versions of Android. (bug#65319) 5913# getpwent is not present in older versions of Android. (bug#65319)
5913gl_CHECK_FUNCS_ANDROID([getpwent], [[#include <pwd.h>]]) 5914gl_CHECK_FUNCS_ANDROID([getpwent], [[#include <pwd.h>]])
5914 5915
5916# renameat2 is not present in older versions of Android.
5917gl_CHECK_FUNCS_ANDROID([renameat2], [[#include <stdio.h>]])
5918
5915if test "$ac_cv_func_cfmakeraw" != "yes"; then 5919if test "$ac_cv_func_cfmakeraw" != "yes"; then
5916 # On some systems (Android), cfmakeraw is inline, so AC_CHECK_FUNCS 5920 # On some systems (Android), cfmakeraw is inline, so AC_CHECK_FUNCS
5917 # cannot find it. Check if some code including termios.h and using 5921 # 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))
44# The workaround is done only for AM_V_ELC and AM_V_ELN, 44# The workaround is done only for AM_V_ELC and AM_V_ELN,
45# since the bug is not annoying elsewhere. 45# since the bug is not annoying elsewhere.
46 46
47AM_V_AR = @$(info $ AR $@) 47. :=
48AM_V_AR = @$(info $. AR $@)
48AM_V_at = @ 49AM_V_at = @
49AM_V_CC = @$(info $ CC $@) 50AM_V_CC = @$(info $. CC $@)
50AM_V_CXX = @$(info $ CXX $@) 51AM_V_CXX = @$(info $. CXX $@)
51AM_V_CCLD = @$(info $ CCLD $@) 52AM_V_CCLD = @$(info $. CCLD $@)
52AM_V_CXXLD = @$(info $ CXXLD $@) 53AM_V_CXXLD = @$(info $. CXXLD $@)
53AM_V_GEN = @$(info $ GEN $@) 54AM_V_GEN = @$(info $. GEN $@)
54AM_V_NO_PD = --no-print-directory 55AM_V_NO_PD = --no-print-directory
55endif 56endif
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}.
632 632
633@cindex continuation lines, visual wrap prefix 633@cindex continuation lines, visual wrap prefix
634@findex visual-wrap-prefix-mode 634@findex visual-wrap-prefix-mode
635@findex global-visual-wrap-prefix-mode
635 Normally, the first character of each continuation line is 636 Normally, the first character of each continuation line is
636positioned at the beginning of the screen line where it is displayed. 637positioned at the beginning of the screen line where it is displayed.
637The minor mode @code{visual-wrap-prefix-mode} arranges that 638The minor mode @code{visual-wrap-prefix-mode} and its global
638continuation lines be prefixed by slightly adjusted versions of the 639(@pxref{Minor Modes}) counterpart
639fill prefixes (@pxref{Fill Prefix}) of their respective logical lines, 640@code{global-visual-wrap-prefix-mode} arranges that continuation lines
640so that indentation characters or the prefixes of source code comments 641be prefixed by slightly adjusted versions of the fill prefixes
641are replicated across every continuation line, and the appearance of 642(@pxref{Fill Prefix}) of their respective logical lines, so that
642such comments or indentation is not broken. These prefixes are only 643indentation characters or the prefixes of source code comments are
643shown on display, and does not change the buffer text in any way. 644replicated across every continuation line, and the appearance of such
645comments or indentation is not broken. These prefixes are only shown
646on display, and does not change the buffer text in any way.
644 647
645 Sometimes, you may need to edit files containing many long logical 648 Sometimes, you may need to edit files containing many long logical
646lines, and it may not be practical to break them all up by adding 649lines, 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:
205 205
206@smallexample 206@smallexample
207CRM Buffer Size Mode File 207CRM Buffer Size Mode File
208. * .emacs 3294 Emacs-Lisp ~/.emacs 208. * .emacs 3294 ELisp/l ~/.emacs
209 % *Help* 101 Help 209 % *Help* 101 Help
210 search.c 86055 C ~/cvs/emacs/src/search.c 210 search.c 86055 C ~/cvs/emacs/src/search.c
211 % src 20959 Dired by name ~/cvs/emacs/src/ 211 % 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
2210to start, or zero, meaning don't echo at all. The value takes effect when 2210to start, or zero, meaning don't echo at all. The value takes effect when
2211there is something to echo. @xref{Echo Area}. 2211there is something to echo. @xref{Echo Area}.
2212 2212
2213@vindex echo-keystrokes-help
2214 If the variable @code{echo-keystrokes-help} is non-@code{nil} (the
2215default), the multi-character key sequence echo shown according to
2216@code{echo-keystrokes} will include a short help text about keys which
2217will invoke @code{describe-prefix-bindings} (@pxref{Misc Help}) to show
2218the list of commands for the prefix you already typed. For a related
2219help facility, see @ref{which-key}.
2220
2213@cindex mouse pointer 2221@cindex mouse pointer
2214@cindex hourglass pointer display 2222@cindex hourglass pointer display
2215@vindex display-hourglass 2223@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
260@code{widget-describe} commands, that should be run with point over 260@code{widget-describe} commands, that should be run with point over
261the button. 261the button.
262 262
263@anchor{which-key}
264@kbd{M-x which-key} is a global minor mode which helps in discovering
265 keymaps. It displays keybindings following your currently entered
266 incomplete command (prefix), in a popup.
267
263@node Name Help 268@node Name Help
264@section Help by Command or Variable Name 269@section Help by Command or Variable Name
265 270
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
1097chapters. This works as long as no other command starts with 1097chapters. This works as long as no other command starts with
1098@samp{@@chap}. 1098@samp{@@chap}.
1099 1099
1100@vindex outline-search-function
1101 Instead of setting the variable @code{outline-regexp}, you can set
1102the variable @code{outline-search-function} to a function that
1103matches the current heading and searches for the next one
1104(@pxref{Outline Minor Mode,,,elisp, the Emacs Lisp Reference Manual}).
1105
1100@vindex outline-level 1106@vindex outline-level
1101 You can explicitly specify a rule for calculating the level of a 1107 You can explicitly specify a rule for calculating the level of a
1102heading line by setting the variable @code{outline-level}. The value 1108heading 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
65 65
66@defun make-abbrev-table &optional props 66@defun make-abbrev-table &optional props
67This function creates and returns a new, empty abbrev table---an 67This function creates and returns a new, empty abbrev table---an
68obarray containing no symbols. It is a vector filled with zeros. 68obarray containing no symbols.
69@var{props} is a property list that is applied to the new table 69@var{props} is a property list that is applied to the new table
70(@pxref{Abbrev Table Properties}). 70(@pxref{Abbrev Table Properties}).
71@end defun 71@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:
35* Speed of Byte-Code:: An example of speedup from byte compilation. 35* Speed of Byte-Code:: An example of speedup from byte compilation.
36* Compilation Functions:: Byte compilation functions. 36* Compilation Functions:: Byte compilation functions.
37* Docs and Compilation:: Dynamic loading of documentation strings. 37* Docs and Compilation:: Dynamic loading of documentation strings.
38* Dynamic Loading:: Dynamic loading of individual functions.
39* Eval During Compile:: Code to be evaluated when you compile. 38* Eval During Compile:: Code to be evaluated when you compile.
40* Compiler Errors:: Handling compiler error messages. 39* Compiler Errors:: Handling compiler error messages.
41* Byte-Code Objects:: The data type used for byte-compiled functions. 40* 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
289constructs in Lisp source files; they are not designed to be clear to 288constructs in Lisp source files; they are not designed to be clear to
290humans reading the file. 289humans reading the file.
291 290
292@node Dynamic Loading
293@section Dynamic Loading of Individual Functions
294
295@cindex dynamic loading of functions
296@cindex lazy loading
297 When you compile a file, you can optionally enable the @dfn{dynamic
298function loading} feature (also known as @dfn{lazy loading}). With
299dynamic function loading, loading the file doesn't fully read the
300function definitions in the file. Instead, each function definition
301contains a place-holder which refers to the file. The first time each
302function is called, it reads the full definition from the file, to
303replace the place-holder.
304
305 The advantage of dynamic function loading is that loading the file
306should become faster. This is a good thing for a file which contains
307many separate user-callable functions, if using one of them does not
308imply you will probably also use the rest. A specialized mode which
309provides many keyboard commands often has that usage pattern: a user may
310invoke the mode, but use only a few of the commands it provides.
311
312 The dynamic loading feature has certain disadvantages:
313
314@itemize @bullet
315@item
316If you delete or move the compiled file after loading it, Emacs can no
317longer load the remaining function definitions not already loaded.
318
319@item
320If you alter the compiled file (such as by compiling a new version),
321then trying to load any function not already loaded will usually yield
322nonsense results.
323@end itemize
324
325 These problems will never happen in normal circumstances with
326installed Emacs files. But they are quite likely to happen with Lisp
327files that you are changing. The easiest way to prevent these problems
328is to reload the new compiled file immediately after each recompilation.
329
330 @emph{Experience shows that using dynamic function loading provides
331benefits that are hardly measurable, so this feature is deprecated
332since Emacs 27.1.}
333
334 The byte compiler uses the dynamic function loading feature if the
335variable @code{byte-compile-dynamic} is non-@code{nil} at compilation
336time. Do not set this variable globally, since dynamic loading is
337desirable only for certain files. Instead, enable the feature for
338specific source files with file-local variable bindings. For example,
339you could do it by writing this text in the source file's first line:
340
341@example
342-*-byte-compile-dynamic: t;-*-
343@end example
344
345@defvar byte-compile-dynamic
346If this is non-@code{nil}, the byte compiler generates compiled files
347that are set up for dynamic function loading.
348@end defvar
349
350@defun fetch-bytecode function
351If @var{function} is a byte-code function object, this immediately
352finishes loading the byte code of @var{function} from its
353byte-compiled file, if it is not fully loaded already. Otherwise,
354it does nothing. It always returns @var{function}.
355@end defun
356
357@node Eval During Compile 291@node Eval During Compile
358@section Evaluation During Compilation 292@section Evaluation During Compilation
359@cindex eval during compilation 293@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
638Example: @code{(= 42)}@* 638Example: @code{(= 42)}@*
639In this example, the function is @code{=}, @var{n} is one, and 639In this example, the function is @code{=}, @var{n} is one, and
640the actual function call becomes: @w{@code{(= 42 @var{expval})}}. 640the actual function call becomes: @w{@code{(= 42 @var{expval})}}.
641
642@item function call with an @code{_} arg
643Call the function (the first element of the function call)
644with the specified arguments (the other elements) and replacing
645@code{_} with @var{expval}.
646
647Example: @code{(gethash _ memo-table)}
648In this example, the function is @code{gethash}, and
649the actual function call becomes: @w{@code{(gethash @var{expval}
650memo-table)}}.
641@end table 651@end table
642 652
643@item (app @var{function} @var{pattern}) 653@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
653* Speed of Byte-Code:: An example of speedup from byte compilation. 653* Speed of Byte-Code:: An example of speedup from byte compilation.
654* Compilation Functions:: Byte compilation functions. 654* Compilation Functions:: Byte compilation functions.
655* Docs and Compilation:: Dynamic loading of documentation strings. 655* Docs and Compilation:: Dynamic loading of documentation strings.
656* Dynamic Loading:: Dynamic loading of individual functions.
657* Eval During Compile:: Code to be evaluated when you compile. 656* Eval During Compile:: Code to be evaluated when you compile.
658* Compiler Errors:: Handling compiler error messages. 657* Compiler Errors:: Handling compiler error messages.
659* Byte-Code Objects:: The data type used for byte-compiled functions. 658* Byte-Code Objects:: The data type used for byte-compiled functions.
@@ -884,6 +883,7 @@ Major and Minor Modes
884* Minor Modes:: Defining minor modes. 883* Minor Modes:: Defining minor modes.
885* Mode Line Format:: Customizing the text that appears in the mode line. 884* Mode Line Format:: Customizing the text that appears in the mode line.
886* Imenu:: Providing a menu of definitions made in a buffer. 885* Imenu:: Providing a menu of definitions made in a buffer.
886* Outline Minor Mode:: Outline mode to use with other major modes.
887* Font Lock Mode:: How modes can highlight text according to syntax. 887* Font Lock Mode:: How modes can highlight text according to syntax.
888* Auto-Indentation:: How to teach Emacs to indent for a major mode. 888* Auto-Indentation:: How to teach Emacs to indent for a major mode.
889* Desktop Save Mode:: How modes can have buffer state saved between 889* 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.
89 89
90@cindex bugs 90@cindex bugs
91@cindex suggestions 91@cindex suggestions
92Please send comments and corrections using @kbd{M-x 92Please send comments and corrections using @kbd{M-x report-emacs-bug}.
93report-emacs-bug}. If you wish to contribute new code (or send a 93For more details, @xref{Bugs,, Reporting Bugs, emacs, The GNU Emacs
94patch to fix a problem), use @kbd{M-x submit-emacs-patch}. 94Manual}.
95 95
96@node Lisp History 96@node Lisp History
97@section Lisp History 97@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.
2562The optional argument @var{default} specifies the default password to 2562The optional argument @var{default} specifies the default password to
2563return if the user enters empty input. If @var{default} is @code{nil}, 2563return if the user enters empty input. If @var{default} is @code{nil},
2564then @code{read-passwd} returns the null string in that case. 2564then @code{read-passwd} returns the null string in that case.
2565
2566This function uses @code{read-passwd-mode}, a minor mode. It binds two
2567keys in the minbuffer: @kbd{C-u} (@code{delete-minibuffer-contents})
2568deletes the password, and @kbd{TAB}
2569(@code{read-passwd--toggle-visibility}) toggles the visibility of the
2570password. There is also an additional icon in the mode-line. Clicking
2571on this icon with @key{mouse-1} toggles the visibility of the password
2572as well.
2565@end defun 2573@end defun
2566 2574
2567@node Minibuffer Commands 2575@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
25* Minor Modes:: Defining minor modes. 25* Minor Modes:: Defining minor modes.
26* Mode Line Format:: Customizing the text that appears in the mode line. 26* Mode Line Format:: Customizing the text that appears in the mode line.
27* Imenu:: Providing a menu of definitions made in a buffer. 27* Imenu:: Providing a menu of definitions made in a buffer.
28* Outline Minor Mode:: Outline mode to use with other major modes.
28* Font Lock Mode:: How modes can highlight text according to syntax. 29* Font Lock Mode:: How modes can highlight text according to syntax.
29* Auto-Indentation:: How to teach Emacs to indent for a major mode. 30* Auto-Indentation:: How to teach Emacs to indent for a major mode.
30* Desktop Save Mode:: How modes can have buffer state saved between 31* Desktop Save Mode:: How modes can have buffer state saved between
@@ -508,6 +509,12 @@ variable @code{imenu-generic-expression}, for the two variables
508@code{imenu-create-index-function} (@pxref{Imenu}). 509@code{imenu-create-index-function} (@pxref{Imenu}).
509 510
510@item 511@item
512The mode should specify how Outline minor mode should find the
513heading lines, by setting up a buffer-local value for the variables
514@code{outline-regexp} or @code{outline-search-function}, and also
515for the variable @code{outline-level} (@pxref{Outline Minor Mode}).
516
517@item
511The mode can tell ElDoc mode how to retrieve different types of 518The mode can tell ElDoc mode how to retrieve different types of
512documentation for whatever is at point, by adding one or more 519documentation for whatever is at point, by adding one or more
513buffer-local entries to the special hook 520buffer-local entries to the special hook
@@ -1182,7 +1189,7 @@ column is sorted in the descending order.
1182This buffer-local variable specifies the format of the Tabulated List 1189This buffer-local variable specifies the format of the Tabulated List
1183data. Its value should be a vector. Each element of the vector 1190data. Its value should be a vector. Each element of the vector
1184represents a data column, and should be a list @code{(@var{name} 1191represents a data column, and should be a list @code{(@var{name}
1185@var{width} @var{sort})}, where 1192@var{width} @var{sort} . @var{props})}, where
1186 1193
1187@itemize 1194@itemize
1188@item 1195@item
@@ -1199,6 +1206,13 @@ sorted by comparing string values. Otherwise, this should be a
1199predicate function for @code{sort} (@pxref{Rearrangement}), which 1206predicate function for @code{sort} (@pxref{Rearrangement}), which
1200accepts two arguments with the same form as the elements of 1207accepts two arguments with the same form as the elements of
1201@code{tabulated-list-entries} (see below). 1208@code{tabulated-list-entries} (see below).
1209
1210@item
1211@var{props} is a plist (@pxref{Property Lists}) of additional column
1212properties. If the value of the property @code{:right-align} is
1213non-@code{nil} then the column should be right-aligned. And the
1214property @code{:pad-right} specifies the number of additional padding
1215spaces to the right of the column (by default 1 if omitted).
1202@end itemize 1216@end itemize
1203@end defvar 1217@end defvar
1204 1218
@@ -2994,6 +3008,61 @@ instead.
2994automatically sets up Imenu if this variable is non-@code{nil}. 3008automatically sets up Imenu if this variable is non-@code{nil}.
2995@end defvar 3009@end defvar
2996 3010
3011@node Outline Minor Mode
3012@section Outline Minor Mode
3013
3014@cindex Outline minor mode
3015 @dfn{Outline minor mode} is a buffer-local minor mode that hides
3016parts of the buffer and leaves only heading lines visible.
3017This minor mode can be used in conjunction with other major modes
3018(@pxref{Outline Minor Mode,, Outline Minor Mode, emacs, the Emacs Manual}).
3019
3020 There are two ways to define which lines are headings: with the
3021variable @code{outline-regexp} or @code{outline-search-function}.
3022
3023@defvar outline-regexp
3024This variable is a regular expression.
3025Any line whose beginning has a match for this regexp is considered a
3026heading line. Matches that start within a line (not at the left
3027margin) do not count.
3028@end defvar
3029
3030@defvar outline-search-function
3031Alternatively, when it's impossible to create a regexp that
3032matches heading lines, you can define a function that helps
3033Outline minor mode to find heading lines.
3034
3035The variable @code{outline-search-function} specifies the function with
3036four arguments: @var{bound}, @var{move}, @var{backward}, and
3037@var{looking-at}. The function completes two tasks: to match the
3038current heading line, and to find the next or the previous heading line.
3039If the argument @var{looking-at} is non-@code{nil}, it should return
3040non-@code{nil} when point is at the beginning of the outline header line.
3041If the argument @var{looking-at} is @code{nil}, the first three arguments
3042are used. The argument @var{bound} is a buffer position that bounds
3043the search. The match found must not end after that position. A
3044value of nil means search to the end of the accessible portion of
3045the buffer. If the argument @var{move} is non-@code{nil}, the
3046failed search should move to the limit of search and return nil.
3047If the argument @var{backward} is non-@code{nil}, this function
3048should search for the previous heading backward.
3049@end defvar
3050
3051@defvar outline-level
3052This variable is a function that takes no arguments
3053and should return the level of the current heading.
3054It's required in both cases: whether you define
3055@code{outline-regexp} or @code{outline-search-function}.
3056@end defvar
3057
3058If built with tree-sitter, Emacs can automatically use
3059Outline minor mode if the major mode sets the following variable.
3060
3061@defvar treesit-outline-predicate
3062This variable instructs Emacs how to find lines with outline headings.
3063It should be a predicate that matches the node on the heading line.
3064@end defvar
3065
2997@node Font Lock Mode 3066@node Font Lock Mode
2998@section Font Lock Mode 3067@section Font Lock Mode
2999@cindex Font Lock mode 3068@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.
2122@item numberp 2122@item numberp
2123@xref{Predicates on Numbers, numberp}. 2123@xref{Predicates on Numbers, numberp}.
2124 2124
2125@item obarrayp
2126@xref{Creating Symbols, obarrayp}.
2127
2125@item overlayp 2128@item overlayp
2126@xref{Overlays, overlayp}. 2129@xref{Overlays, overlayp}.
2127 2130
@@ -2182,7 +2185,7 @@ This function returns a symbol naming the primitive type of
2182@code{condition-variable}, @code{cons}, @code{finalizer}, 2185@code{condition-variable}, @code{cons}, @code{finalizer},
2183@code{float}, @code{font-entity}, @code{font-object}, 2186@code{float}, @code{font-entity}, @code{font-object},
2184@code{font-spec}, @code{frame}, @code{hash-table}, @code{integer}, 2187@code{font-spec}, @code{frame}, @code{hash-table}, @code{integer},
2185@code{marker}, @code{mutex}, @code{overlay}, @code{process}, 2188@code{marker}, @code{mutex}, @code{obarray}, @code{overlay}, @code{process},
2186@code{string}, @code{subr}, @code{symbol}, @code{thread}, 2189@code{string}, @code{subr}, @code{symbol}, @code{thread},
2187@code{vector}, @code{window}, or @code{window-configuration}. 2190@code{vector}, @code{window}, or @code{window-configuration}.
2188However, if @var{object} is a record, the type specified by its first 2191However, 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).
28* Multi-file Packages:: How to package multiple files. 28* Multi-file Packages:: How to package multiple files.
29* Package Archives:: Maintaining package archives. 29* Package Archives:: Maintaining package archives.
30* Archive Web Server:: Interfacing to an archive web server. 30* Archive Web Server:: Interfacing to an archive web server.
31* Forwards-Compatibility:: Supporting older versions of Emacs.
31@end menu 32@end menu
32 33
33@node Packaging Basics 34@node Packaging Basics
@@ -399,3 +400,50 @@ Return the file. This will be the tarball for a multi-file
399package, or the single file for a simple package. 400package, or the single file for a simple package.
400 401
401@end table 402@end table
403
404@node Forwards-Compatibility
405@section Supporting older versions of Emacs
406@cindex compatibility compat
407
408Packages that wish to support older releases of Emacs, without giving
409up on newer functionality from recent Emacs releases, one can make use
410of the Compat package on GNU ELPA. By depending on the package, Emacs
411can provide compatibility definitions for missing functionality.
412
413The versioning of Compat follows that of Emacs, so next to the oldest
414version that a package relies on (via the @code{emacs}-package), one
415can also indicate what the newest version of Emacs is, that a package
416wishes to use definitions from:
417
418@example
419;; Package-Requires: ((emacs "27.2") (compat "29.1"))
420@end example
421
422Note that Compat provides replacement functions with extended
423functionality for functions that are already defined (@code{sort},
424@code{assoc}, @dots{}). These functions may have changed their
425calling convention (additional optional arguments) or may have changed
426their behavior. These functions must be looked up explicitly with
427@code{compat-function} or called explicitly with @code{compat-call}.
428We call them @dfn{Extended Definitions}. In contrast, newly @dfn{Added
429Definitions} can be called as usual.
430
431@defmac compat-call fun &rest args
432This macro calls the compatibility function @var{fun} with @var{args}.
433Many functions provided by Compat can be called directly without this
434macro. However in the case where Compat provides an alternative
435version of an existing function, the function call has to go through
436@code{compat-call}.
437@end defmac
438
439@defmac compat-function fun
440This macro returns the compatibility function symbol for @var{fun}.
441See @code{compat-call} for a more convenient macro to directly call
442compatibility functions.
443@end defmac
444
445For further details on how to make use of the package, see
446@ref{Usage,, Usage, compat, "Compat" Manual}. In case you don't have
447the manual installed, you can also read the
448@url{https://elpa.gnu.org/packages/doc/compat.html#Usage, Online
449Compat 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
794start positions greater than the end position of @var{start}. 794start positions greater than the end position of @var{start}.
795 795
796In the tree shown above, @code{treesit-search-subtree} traverses node 796In the tree shown above, @code{treesit-search-subtree} traverses node
797@samp{S} (@var{start}) and nodes marked with @code{o}, where this 797@samp{S} (@var{start}) and nodes marked with @code{o}, whereas this
798function traverses the nodes marked with numbers. This function is 798function traverses the nodes marked with numbers. This function is
799useful for answering questions like ``what is the first node after 799useful for answering questions like ``what is the first node after
800@var{start} in the buffer that satisfies some condition?'' 800@var{start} in the buffer that satisfies some condition?''
@@ -916,32 +916,37 @@ nodes.
916 916
917@defun treesit-parent-until node predicate &optional include-node 917@defun treesit-parent-until node predicate &optional include-node
918This function repeatedly finds the parents of @var{node}, and returns 918This function repeatedly finds the parents of @var{node}, and returns
919the parent that satisfies @var{pred}, a function that takes a node as 919the parent that satisfies @var{predicate}. @var{predicate} can be
920argument and returns a boolean that indicates a match. If no parent 920either a function that takes a node as argument and returns @code{t}
921satisfies @var{pred}, this function returns @code{nil}. 921or @code{nil}, or a regexp matching node type names, or other valid
922predicates described in @var{treesit-thing-settings}. If no parent
923satisfies @var{predicates}, this function returns @code{nil}.
922 924
923Normally this function only looks at the parents of @var{node} but not 925Normally this function only looks at the parents of @var{node} but not
924@var{node} itself. But if @var{include-node} is non-@code{nil}, this 926@var{node} itself. But if @var{include-node} is non-@code{nil}, this
925function returns @var{node} if @var{node} satisfies @var{pred}. 927function returns @var{node} if @var{node} satisfies @var{predicate}.
926@end defun 928@end defun
927 929
928@defun treesit-parent-while node pred 930@defun treesit-parent-while node predicate
929This function goes up the tree starting from @var{node}, and keeps 931This function goes up the tree starting from @var{node}, and keeps
930doing so as long as the nodes satisfy @var{pred}, a function that 932doing so as long as the nodes satisfy @var{predicate}, a function that
931takes a node as argument. That is, this function returns the highest 933takes a node as argument. That is, this function returns the highest
932parent of @var{node} that still satisfies @var{pred}. Note that if 934parent of @var{node} that still satisfies @var{predicate}. Note that if
933@var{node} satisfies @var{pred} but its immediate parent doesn't, 935@var{node} satisfies @var{predicate} but its immediate parent doesn't,
934@var{node} itself is returned. 936@var{node} itself is returned.
935@end defun 937@end defun
936 938
937@defun treesit-node-top-level node &optional type 939@defun treesit-node-top-level node &optional predicate include-node
938This function returns the highest parent of @var{node} that has the 940This function returns the highest parent of @var{node} that has the
939same type as @var{node}. If no such parent exists, it returns 941same type as @var{node}. If no such parent exists, it returns
940@code{nil}. Therefore this function is also useful for testing 942@code{nil}. Therefore this function is also useful for testing
941whether @var{node} is top-level. 943whether @var{node} is top-level.
942 944
943If @var{type} is non-@code{nil}, this function matches each parent's 945If @var{predicate} is @code{nil}, this function uses @var{node}'s type
944type with @var{type} as a regexp, rather than using @var{node}'s type. 946to find the parent. If @var{predicate} is non-@code{nil}, this
947function searches the parent that satisfies @var{predicate}. If
948@var{include-node} is non-@code{nil}, this function returns @var{node}
949if @var{node} satisfies @var{predicate}.
945@end defun 950@end defun
946 951
947@node Accessing Node Information 952@node Accessing Node Information
@@ -1892,6 +1897,10 @@ add-log functions used by @code{add-log-current-defun}.
1892@item 1897@item
1893If @code{treesit-simple-imenu-settings} (@pxref{Imenu}) is 1898If @code{treesit-simple-imenu-settings} (@pxref{Imenu}) is
1894non-@code{nil}, it sets up Imenu. 1899non-@code{nil}, it sets up Imenu.
1900
1901@item
1902If @code{treesit-outline-predicate} (@pxref{Outline Minor Mode}) is
1903non-@code{nil}, it sets up Outline minor mode.
1895@end itemize 1904@end itemize
1896 1905
1897@c TODO: Add treesit-thing-settings stuff once we finalize it. 1906@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:
434 (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")] 434 (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")]
435@end group 435@end group
436@end example 436@end example
437
438@xref{Sorting}, for more functions that perform sorting.
439See @code{documentation} in @ref{Accessing Documentation}, for a
440useful example of @code{sort}.
441@end defun 437@end defun
442 438
439Sometimes, computation of sort keys of list or vector elements is
440expensive, and therefore it is important to perform it the minimum
441number of times. By contrast, computing the sort keys of elements
442inside the @var{predicate} function passed to @code{sort} will generally
443perform this computation each time @var{predicate} is called with some
444element. If you can separate the computation of the sort key of an
445element into a function of its own, you can use the following sorting
446function, which guarantees that the key will be computed for each list
447or vector element exactly once.
448
449@cindex decorate-sort-undecorate
450@cindex Schwartzian transform
451@defun sort-on sequence predicate accessor
452This function stably sorts @var{sequence}, which can be a list, a
453vector, a bool-vector, or a string. It sorts by comparing the sort
454keys of the elements using @var{predicate}. The comparison function
455@var{predicate} accepts two arguments, the sort keys to compare, and
456should return non-@code{nil} if the element corresponding to the first
457key should sort before the element corresponding to the second key. The
458function computes a sort key of each element by calling the
459@var{accessor} function on that element; it does so exactly once for
460each element of @var{sequence}. The @var{accessor} function is called
461with a single argument, an element of @var{sequence}.
462
463This function implements what is known as @dfn{decorate-sort-undecorate}
464paradigm, or the Schwartzian transform. It basically trades CPU for
465memory, creating a temporary list with the computed sort keys, then
466mapping @code{car} over the result of sorting that temporary list.
467Unlike with @code{sort}, the return value is always a new list; the
468original @var{sequence} is left intact.
469@end defun
470
471@xref{Sorting}, for more functions that perform sorting. See
472@code{documentation} in @ref{Accessing Documentation}, for a useful
473example of @code{sort}.
474
443@cindex sequence functions in seq 475@cindex sequence functions in seq
444@cindex seq library 476@cindex seq library
445@cindex sequences, generalized 477@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
177symbol every time it reads the same sequence of characters in the same 177symbol every time it reads the same sequence of characters in the same
178context. Failure to do so would cause complete confusion. 178context. Failure to do so would cause complete confusion.
179 179
180@cindex symbol name hashing
181@cindex hashing
182@cindex obarray 180@cindex obarray
183@cindex bucket (in obarray)
184 When the Lisp reader encounters a name that references a symbol in 181 When the Lisp reader encounters a name that references a symbol in
185the source code, it reads all the characters of that name. Then it 182the source code, it looks up that name in a table called an @dfn{obarray}
186looks up that name in a table called an @dfn{obarray} to find the 183to find the symbol that the programmer meant. An obarray is an unordered
187symbol that the programmer meant. The technique used in this lookup 184container of symbols, indexed by name.
188is called ``hashing'', an efficient method of looking something up by 185
189converting a sequence of characters to a number, known as a ``hash 186The Lisp reader also considers ``shorthands''.
190code''. For example, instead of searching a telephone book cover to
191cover when looking up Jan Jones, you start with the J's and go from
192there. That is a simple version of hashing. Each element of the
193obarray is a @dfn{bucket} which holds all the symbols with a given
194hash code; to look for a given name, it is sufficient to look through
195all the symbols in the bucket for that name's hash code. (The same
196idea is used for general Emacs hash tables, but they are a different
197data type; see @ref{Hash Tables}.)
198
199When looking up names, the Lisp reader also considers ``shorthands''.
200If the programmer supplied them, this allows the reader to find a 187If the programmer supplied them, this allows the reader to find a
201symbol even if its name isn't present in its full form in the source 188symbol even if its name isn't present in its full form in the source
202code. Of course, the reader needs to be aware of some pre-established 189code. @xref{Shorthands}.
203context about such shorthands, much as one needs context to be to able
204to refer uniquely to Jan Jones by just the name ``Jan'': it's probably
205fine when amongst the Joneses, or when Jan has been mentioned
206recently, but very ambiguous in any other situation.
207@xref{Shorthands}.
208 190
209@cindex interning 191@cindex interning
210 If a symbol with the desired name is found, the reader uses that 192 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
236value of a variable. Uninterned symbols are sometimes useful in 218value of a variable. Uninterned symbols are sometimes useful in
237generating Lisp code, see below. 219generating Lisp code, see below.
238 220
239 In Emacs Lisp, an obarray is actually a vector. Each element of the
240vector is a bucket; its value is either an interned symbol whose name
241hashes to that bucket, or 0 if the bucket is empty. Each interned
242symbol has an internal link (invisible to the user) to the next symbol
243in the bucket. Because these links are invisible, there is no way to
244find all the symbols in an obarray except using @code{mapatoms} (below).
245The order of symbols in a bucket is not significant.
246
247 In an empty obarray, every element is 0, so you can create an obarray
248with @code{(make-vector @var{length} 0)}. @strong{This is the only
249valid way to create an obarray.} Prime numbers as lengths tend
250to result in good hashing; lengths one less than a power of two are also
251good.
252
253 @strong{Do not try to put symbols in an obarray yourself.} This does
254not work---only @code{intern} can enter a symbol in an obarray properly.
255
256@cindex CL note---symbol in obarrays 221@cindex CL note---symbol in obarrays
257@quotation 222@quotation
258@b{Common Lisp note:} Unlike Common Lisp, Emacs Lisp does not provide 223@b{Common Lisp note:} Unlike Common Lisp, Emacs Lisp does not provide
@@ -262,9 +227,21 @@ Emacs Lisp provides a different namespacing system called
262``shorthands'' (@pxref{Shorthands}). 227``shorthands'' (@pxref{Shorthands}).
263@end quotation 228@end quotation
264 229
230@defun obarray-make &optional size
231This function creates and returns a new obarray.
232The optional @var{size} may be used to specify the number of symbols
233that it is expected to hold, but since obarrays grow automatically
234as needed, this rarely provide any benefit.
235@end defun
236
237@defun obarrayp object
238This function returns @code{t} if @var{object} is an obarray,
239@code{nil} otherwise.
240@end defun
241
265 Most of the functions below take a name and sometimes an obarray as 242 Most of the functions below take a name and sometimes an obarray as
266arguments. A @code{wrong-type-argument} error is signaled if the name 243arguments. A @code{wrong-type-argument} error is signaled if the name
267is not a string, or if the obarray is not a vector. 244is not a string, or if the obarray is not an obarray object.
268 245
269@defun symbol-name symbol 246@defun symbol-name symbol
270This function returns the string that is @var{symbol}'s name. For example: 247This 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
416it returns @code{nil}. 393it returns @code{nil}.
417@end defun 394@end defun
418 395
396@defun obarray-clear obarray
397This function removes all symbols from @var{obarray}.
398@end defun
399
419@node Symbol Properties 400@node Symbol Properties
420@section Symbol Properties 401@section Symbol Properties
421@cindex symbol property 402@cindex symbol property
@@ -761,6 +742,23 @@ instead of @code{snu-}.
761;; End: 742;; End:
762@end example 743@end example
763 744
745Note that if you have two shorthands in the same file where one is the
746prefix of the other, the longer shorthand will be attempted first.
747This happens regardless of the order you specify shorthands in the
748local variables section of your file.
749
750@example
751'(
752 t//foo ; reads to 'my-tricks--foo', not 'my-tricks-/foo'
753 t/foo ; reads to 'my-tricks-foo'
754 )
755
756;; Local Variables:
757;; read-symbol-shorthands: (("t/" . "my-tricks-")
758;; ("t//" . "my-tricks--")
759;; End:
760@end example
761
764@subsection Exceptions 762@subsection Exceptions
765 763
766There are two exceptions to rules governing Shorthand transformations: 764There 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
289you answered yes, it will let you select the signing keys. 289you answered yes, it will let you select the signing keys.
290@end deffn 290@end deffn
291 291
292@defvar epa-keys-select-method
293This variable controls the method used for key selection in
294@code{epa-select-keys}. The default value @code{buffer} pops up a
295special buffer where you can select the keys. If the value is
296@code{minibuffer}, @code{epa-select-keys} will instead prompt for the
297keys in the minibuffer, where you should type the keys separated by
298commas.
299@end defvar
300
292@node Cryptographic operations on files 301@node Cryptographic operations on files
293@section Cryptographic Operations on Files 302@section Cryptographic Operations on Files
294@cindex cryptographic operations on files 303@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
1230 1230
1231(defun my-erc-up (network) 1231(defun my-erc-up (network)
1232 (interactive "Snetwork: ") 1232 (interactive "Snetwork: ")
1233 1233 (require 'erc-sasl)
1234 (pcase network 1234 (or (let ((erc-modules (cons 'sasl erc-modules)))
1235 ('libera 1235 (pcase network
1236 (let ((erc-sasl-mechanism 'external)) 1236 ('libera
1237 (erc-tls :server "irc.libera.chat" :port 6697 1237 (let ((erc-sasl-mechanism 'external))
1238 :client-certificate t))) 1238 (erc-tls :server "irc.libera.chat"
1239 ('example 1239 :client-certificate t)))
1240 (let ((erc-sasl-auth-source-function 1240 ('example
1241 #'erc-sasl-auth-source-password-as-host)) 1241 (let ((erc-sasl-auth-source-function
1242 (erc-tls :server "irc.example.net" :port 6697 1242 #'erc-sasl-auth-source-password-as-host))
1243 :user "alyssa" 1243 (erc-tls :server "irc.example.net"
1244 :password "Example.Net"))))) 1244 :user "alyssa"
1245 :password "Example.Net")))))
1246 ;; Non-SASL
1247 (call-interactively #'erc-tls)))
1245@end lisp 1248@end lisp
1246 1249
1247You've started storing your credentials with auth-source and have 1250You've started storing your credentials with auth-source and have
1248decided to try SASL on another network as well. But there's a catch: 1251decided to try SASL on another network as well. But there's a catch:
1249this network doesn't support @samp{EXTERNAL}. You use 1252this network doesn't support @samp{EXTERNAL}. You use
1250@code{let}-binding to get around this and successfully authenticate to 1253@code{let}-binding to work around this and successfully authenticate
1251both networks. 1254to both networks. (Note that this example assumes you've removed
1255@code{sasl} from @code{erc-modules} globally and have instead opted to
1256add it locally when connecting to preconfigured networks.)
1252 1257
1253@end itemize 1258@end itemize
1254 1259
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 @@
3@setfilename ../../info/eshell.info 3@setfilename ../../info/eshell.info
4@settitle Eshell: The Emacs Shell 4@settitle Eshell: The Emacs Shell
5@include docstyle.texi 5@include docstyle.texi
6@defindex cm 6@defcodeindex cm
7@syncodeindex vr fn 7@syncodeindex vr fn
8@c %**end of header 8@c %**end of header
9 9
@@ -416,7 +416,7 @@ elisp, The Emacs Lisp Reference Manual}).
416@end table 416@end table
417 417
418@node Built-ins 418@node Built-ins
419@section Built-in commands 419@section Built-in Commands
420Eshell provides a number of built-in commands, many of them 420Eshell provides a number of built-in commands, many of them
421implementing common command-line utilities, but enhanced for Eshell. 421implementing common command-line utilities, but enhanced for Eshell.
422(These built-in commands are just ordinary Lisp functions whose names 422(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
477@command{ln} is the current directory. 477@command{ln} is the current directory.
478 478
479A few commands are wrappers for more niche Emacs features, and can be 479A few commands are wrappers for more niche Emacs features, and can be
480loaded as part of the eshell-xtra module. @xref{Extension modules}. 480loaded as part of the @code{eshell-xtra} module. @xref{Extra built-in
481commands}.
482
483@menu
484* List of Built-ins::
485* Defining New Built-ins::
486@end menu
487
488@node List of Built-ins
489@subsection List of Built-in Commands
481 490
482@table @code 491@table @code
483 492
484@item .
485@cmindex . 493@cmindex .
486Source an Eshell file in the current environment. This is not to be 494@item . @var{file} [@var{argument}]@dots{}
487confused with the command @command{source}, which sources a file in a 495Source an Eshell script named @var{file} in the current environment,
488subshell environment. 496passing any @var{arguments} to the script (@pxref{Scripts}). This is
497not to be confused with the command @command{source}, which sources a
498file in a subshell environment.
489 499
490@item addpath
491@cmindex addpath 500@cmindex addpath
492Adds a given path or set of paths to the PATH environment variable, or, 501@item addpath
493with no arguments, prints the current paths in this variable. 502@itemx addpath [-b] @var{directory}@dots{}
503Adds each specified @var{directory} to the @code{$PATH} environment
504variable. By default, this adds the directories to the end of
505@code{$PATH}, in the order they were passed on the command line; by
506passing @code{-b} or @code{--begin}, Eshell will instead add the
507directories to the beginning.
508
509With no directories, print the list of directories currently stored in
510@code{$PATH}.
494 511
495@item alias
496@cmindex alias 512@cmindex alias
497Define an alias (@pxref{Aliases}). This adds it to the aliases file. 513@item alias
514@itemx alias @var{name} [@var{command}]
515Define an alias named @var{name} and expanding to @var{command},
516adding it to the aliases file (@pxref{Aliases}). If @var{command} is
517omitted, delete the alias named @var{name}. With no arguments at all,
518list all the currently-defined aliases.
498 519
499@item basename
500@cmindex basename 520@cmindex basename
501Return a file name without its directory. 521@item basename @var{filename}
522Return @var{filename} without its directory.
502 523
503@item cat
504@cmindex cat 524@cmindex cat
505Concatenate file contents into standard output. If in a pipeline, or 525@item cat @var{file}@dots{}
506if the file is not a regular file, directory, or symlink, then this 526Concatenate the contents of @var{file}s to standard output. If in a
507command reverts to the system's definition of @command{cat}. 527pipeline, or if any of the files is not a regular file, directory, or
528symlink, then this command reverts to the system's definition of
529@command{cat}.
508 530
509@item cd
510@cmindex cd 531@cmindex cd
511This command changes the current working directory. Usually, it is 532@cindex directories, changing
512invoked as @kbd{cd @var{dir}} where @file{@var{dir}} is the new 533@item cd
513working directory. But @command{cd} knows about a few special 534@itemx cd @var{directory}
514arguments: 535@itemx cd -[@var{n}]
536@itemx cd =[@var{regexp}]
537Change the current working directory. This command can take several
538forms:
515 539
516@itemize @minus{} 540@table @code
517@item
518When it receives no argument at all, it changes to the home directory.
519 541
520@item 542@item cd
521Giving the command @kbd{cd -} changes back to the previous working 543Change to the user's home directory.
522directory (this is the same as @kbd{cd $-}).
523 544
524@item 545@item cd @var{directory}
525The command @kbd{cd =} shows the directory ring. Each line is 546Change to the specified @var{directory}.
526numbered.
527 547
528@item 548@item cd -
529With @kbd{cd =foo}, Eshell searches the directory ring for a directory 549Change back to the previous working directory (this is the same as
530matching the regular expression @samp{foo}, and changes to that 550@kbd{cd $-}).
531directory.
532 551
533@item 552@item cd -@var{n}
534With @kbd{cd -42}, you can access the directory stack slots by number. 553Change to the directory in the @var{nth} slot of the directory stack.
554
555@item cd =
556Show the directory ring. Each line is numbered.
557
558@item cd =@var{regexp}
559Search the directory ring for a directory matching the regular
560expression @var{regexp} and change to that directory.
561
562@end table
535 563
536@item
537@vindex eshell-cd-shows-directory 564@vindex eshell-cd-shows-directory
538@vindex eshell-list-files-after-cd 565@vindex eshell-list-files-after-cd
539If @code{eshell-cd-shows-directory} is non-@code{nil}, @command{cd} 566If @code{eshell-cd-shows-directory} is non-@code{nil}, @command{cd}
540will report the directory it changes to. If 567will report the directory it changes to. If
541@code{eshell-list-files-after-cd} is non-@code{nil}, then @command{ls} 568@code{eshell-list-files-after-cd} is non-@code{nil}, then @command{ls}
542is called with any remaining arguments after changing directories. 569is called with any remaining arguments after changing directories.
543@end itemize
544 570
545@item clear
546@cmindex clear 571@cmindex clear
572@item clear [@var{scrollback}]
547Scrolls the contents of the Eshell window out of sight, leaving a 573Scrolls the contents of the Eshell window out of sight, leaving a
548blank window. If provided with an optional non-@code{nil} argument, 574blank window. If @var{scrollback} is non-@code{nil}, the scrollback
549the scrollback contents are cleared instead. 575contents are cleared instead, as with @command{clear-scrollback}.
550 576
551@item clear-scrollback
552@cmindex clear-scrollback 577@cmindex clear-scrollback
578@item clear-scrollback
553Clear the scrollback contents of the Eshell window. Unlike the 579Clear the scrollback contents of the Eshell window. Unlike the
554command @command{clear}, this command deletes content in the Eshell 580command @command{clear}, this command deletes content in the Eshell
555buffer. 581buffer.
556 582
557@item compile
558@cmindex compile 583@cmindex compile
584@item compile [-p | -i] [-m @var{mode-name}] @var{command}@dots{}
559Run an external command, sending its output to a compilation buffer if 585Run an external command, sending its output to a compilation buffer if
560the command would output to the screen and is not part of a pipeline 586the command would output to the screen and is not part of a pipeline
561or subcommand. This is particularly useful when defining aliases, so 587or subcommand.
588
589With the @code{-p} or @code{--plain} options, always send the output
590to the Eshell buffer; similarly, with @code{-i} or
591@code{--interactive}, always send the output to a compilation buffer.
592You can also set the mode of the compilation buffer with @code{-m
593@var{mode-name}} or @code{--mode @var{mode-name}}.
594
595@command{compile} is particularly useful when defining aliases, so
562that interactively, the output shows up in a compilation buffer, but 596that interactively, the output shows up in a compilation buffer, but
563you can still pipe the output elsewhere if desired. For example, if 597you can still pipe the output elsewhere if desired. For example, if
564you have a grep-like command on your system, you might define an alias 598you have a grep-like command on your system, you might define an alias
565for it like so: @samp{alias mygrep 'compile --mode=grep-mode -- mygrep 599for it like so: @samp{alias mygrep 'compile --mode=grep-mode -- mygrep
566$*'}. 600$*'}.
567 601
568@item cp
569@cmindex cp 602@cmindex cp
570Copy a file to a new location or copy multiple files to the same 603@item cp [@var{option}@dots{}] @var{source} @var{dest}
571directory. 604@item cp [@var{option}@dots{}] @var{source}@dots{} @var{directory}
605Copy the file @var{source} to @var{dest} or @var{source} into
606@var{directory}.
572 607
573@vindex eshell-cp-overwrite-files 608@vindex eshell-cp-overwrite-files
574@vindex eshell-cp-interactive-query 609@vindex eshell-cp-interactive-query
@@ -577,61 +612,145 @@ If @code{eshell-cp-overwrite-files} is non-@code{nil}, then
577@code{eshell-cp-interactive-query} is non-@code{nil}, then 612@code{eshell-cp-interactive-query} is non-@code{nil}, then
578@command{cp} will ask before overwriting anything. 613@command{cp} will ask before overwriting anything.
579 614
580@item date 615@command{cp} accepts the following options:
616
617@table @asis
618
619@item @code{-a}, @code{--archive}
620Equivalent to @code{--no-dereference --preserve --recursive}.
621
622@item @code{-d}, @code{--no-dereference}
623Don't dereference symbolic links when copying; instead, copy the link
624itself.
625
626@item @code{-f}, @code{--force}
627Never prompt for confirmation before copying a file.
628
629@item @code{-i}, @code{--interactive}
630Prompt for confirmation before copying a file if the target already
631exists.
632
633@item @code{-n}, @code{--preview}
634Run the command, but don't copy anything. This is useful if you
635want to preview what would be removed when calling @command{cp}.
636
637@item @code{-p}, @code{--preserve}
638Attempt to preserve file attributes when copying.
639
640@item @code{-r}, @code{-R}, @code{--recursive}
641Copy any specified directories and their contents recursively.
642
643@item @code{-v}, @code{--verbose}
644Print the name of each file before copying it.
645
646@end table
647
581@cmindex date 648@cmindex date
649@item date [@var{specified-time} [@var{zone}]]
582Print the current local time as a human-readable string. This command 650Print the current local time as a human-readable string. This command
583is similar to, but slightly different from, the GNU Coreutils 651is an alias to the Emacs Lisp function @code{current-time-string}
584@command{date} command. 652(@pxref{Time of Day,,, elisp, GNU Emacs Lisp Reference Manual}).
585 653
586@item diff
587@cmindex diff 654@cmindex diff
588Compare files using Emacs's internal @code{diff} (not to be confused 655@item diff [@var{option}]@dots{} @var{old} @var{new}
589with @code{ediff}). @xref{Comparing Files, , , emacs, The GNU Emacs 656Compare the files @var{old} and @var{new} using Emacs's internal
590Manual}. 657@code{diff} (not to be confused with @code{ediff}). @xref{Comparing
658Files, , , emacs, The GNU Emacs Manual}.
591 659
592@vindex eshell-plain-diff-behavior 660@vindex eshell-plain-diff-behavior
593If @code{eshell-plain-diff-behavior} is non-@code{nil}, then this 661If @code{eshell-plain-diff-behavior} is non-@code{nil}, then this
594command does not use Emacs's internal @code{diff}. This is the same 662command does not use Emacs's internal @code{diff}. This is the same
595as using @samp{alias diff '*diff $@@*'}. 663as using @samp{alias diff '*diff $@@*'}.
596 664
597@item dirname
598@cmindex dirname 665@cmindex dirname
599Return the directory component of a file name. 666@item dirname @var{filename}
667Return the directory component of @var{filename}.
600 668
601@item dirs
602@cmindex dirs 669@cmindex dirs
670@cindex directory stack, listing
671@item dirs
603Prints the directory stack. Directories can be added or removed from 672Prints the directory stack. Directories can be added or removed from
604the stack using the commands @command{pushd} and @command{popd}, 673the stack using the commands @command{pushd} and @command{popd},
605respectively. 674respectively.
606 675
607@item du
608@cmindex du 676@cmindex du
609Summarize disk usage for each file. 677@item du [@var{option}]@dots{} @var{file}@dots{}
678Summarize disk usage for each file, recursing into directories.
679
680@command{du} accepts the following options:
681
682@table @asis
683
684@item @code{-a}, @code{--all}
685Print sizes for files, not just directories.
686
687@item @code{--block-size=@var{size}}
688Print sizes as number of blocks of size @var{size}.
689
690@item @code{-b}, @code{--bytes}
691Print file sizes in bytes.
692
693@item @code{-c}, @code{--total}
694Print a grand total of the sizes at the end.
695
696@item @code{-d}, @code{--max-depth=@var{depth}}
697Only print sizes for directories (or files with @code{--all}) that are
698@var{depth} or fewer levels below the command line arguments.
699
700@item @code{-h}, @code{--human-readable}
701Print sizes in human-readable format, with binary prefixes (so 1 KB is
7021024 bytes).
703
704@item @code{-H}, @code{--si}
705Print sizes in human-readable format, with decimal prefixes (so 1 KB
706is 1000 bytes).
707
708@item @code{-k}, @code{--kilobytes}
709Print file sizes in kilobytes (like @code{--block-size=1024}).
710
711@item @code{-L}, @code{--dereference}
712Follow symbolic links when traversing files.
713
714@item @code{-m}, @code{--megabytes}
715Print file sizes in megabytes (like @code{--block-size=1048576}).
716
717@item @code{-s}, @code{--summarize}
718Don't recurse into subdirectories (like @code{--max-depth=0}).
719
720@item @code{-x}, @code{--one-file-system}
721Skip any directories that reside on different filesystems.
722
723@end table
610 724
611@item echo
612@cmindex echo 725@cmindex echo
613Echoes its input. By default, this prints in a Lisp-friendly fashion 726@item echo [-n | -N] [@var{arg}]@dots{}
614(so that the value is useful to a Lisp command using the result of 727Prints the value of each @var{arg}. By default, this prints in a
615@command{echo} as an argument). If a single argument is passed, 728Lisp-friendly fashion (so that the value is useful to a Lisp command
616@command{echo} prints that; if multiple arguments are passed, it 729using the result of @command{echo} as an argument). If a single
617prints a list of all the arguments; otherwise, it prints the empty 730argument is passed, @command{echo} prints that; if multiple arguments
618string. 731are passed, it prints a list of all the arguments; otherwise, it
732prints the empty string.
619 733
620@vindex eshell-plain-echo-behavior 734@vindex eshell-plain-echo-behavior
621If @code{eshell-plain-echo-behavior} is non-@code{nil}, @command{echo} 735If @code{eshell-plain-echo-behavior} is non-@code{nil}, @command{echo}
622will try to behave more like a plain shell's @command{echo}, printing 736will try to behave more like a plain shell's @command{echo}, printing
623each argument as a string, separated by a space. 737each argument as a string, separated by a space.
624 738
625@item env 739You can control whether @command{echo} outputs a trailing newline
740using @code{-n} to disable the trailing newline (the default behavior)
741or @code{-N} to enable it (the default when
742@code{eshell-plain-echo-behavior} is non-@code{nil}).
743
626@cmindex env 744@cmindex env
745@item env [@var{var}=@var{value}]@dots{} [@var{command}]@dots{}
627With no arguments, print the current environment variables. If you 746With no arguments, print the current environment variables. If you
628pass arguments to this command, then @command{env} will execute the 747pass arguments to this command, then @command{env} will execute the
629arguments as a command. If you pass any initial arguments of the form 748arguments as a command. If you pass any initial arguments of the form
630@samp{@var{var}=@var{value}}, @command{env} will first set @var{var} 749@samp{@var{var}=@var{value}}, @command{env} will first set @var{var}
631to @var{value} before running the command. 750to @var{value} before running the command.
632 751
633@item eshell-debug
634@cmindex eshell-debug 752@cmindex eshell-debug
753@item eshell-debug [error | form | process]@dots{}
635Toggle debugging information for Eshell itself. You can pass this 754Toggle debugging information for Eshell itself. You can pass this
636command one or more of the following arguments: 755command one or more of the following arguments:
637 756
@@ -651,72 +770,95 @@ buffer @code{*eshell last cmd*}; or
651 770
652@end itemize 771@end itemize
653 772
654@item exit
655@cmindex exit 773@cmindex exit
774@item exit
656@vindex eshell-kill-on-exit 775@vindex eshell-kill-on-exit
657Exit Eshell and save the history. By default, this command kills the 776Exit Eshell and save the history. By default, this command kills the
658Eshell buffer, but if @code{eshell-kill-on-exit} is @code{nil}, then 777Eshell buffer, but if @code{eshell-kill-on-exit} is @code{nil}, then
659the buffer is merely buried instead. 778the buffer is merely buried instead.
660 779
661@item export
662@cmindex export 780@cmindex export
781@item export [@var{name}=@var{value}]@dots{}
663Set environment variables using input like Bash's @command{export}, as 782Set environment variables using input like Bash's @command{export}, as
664in @samp{export @var{var1}=@var{val1} @var{var2}=@var{val2} @dots{}}. 783in @samp{export @var{var1}=@var{val1} @var{var2}=@var{val2} @dots{}}.
665 784
666@item grep
667@cmindex grep 785@cmindex grep
668@itemx agrep 786@item grep [@var{arg}]@dots{}
669@cmindex agrep 787@cmindex agrep
670@itemx egrep 788@itemx agrep [@var{arg}]@dots{}
671@cmindex egrep 789@cmindex egrep
672@itemx fgrep 790@itemx egrep [@var{arg}]@dots{}
673@cmindex fgrep 791@cmindex fgrep
674@itemx rgrep 792@itemx fgrep [@var{arg}]@dots{}
675@cmindex rgrep 793@cmindex rgrep
676@itemx glimpse 794@itemx rgrep [@var{arg}]@dots{}
677@cmindex glimpse 795@cmindex glimpse
796@itemx glimpse [@var{arg}]@dots{}
678The @command{grep} commands are compatible with GNU @command{grep}, 797The @command{grep} commands are compatible with GNU @command{grep},
679but use Emacs's internal @code{grep} instead. 798but open a compilation buffer in @code{grep-mode} instead.
680@xref{Grep Searching, , , emacs, The GNU Emacs Manual}. 799@xref{Grep Searching, , , emacs, The GNU Emacs Manual}.
681 800
682@vindex eshell-plain-grep-behavior 801@vindex eshell-plain-grep-behavior
683If @code{eshell-plain-grep-behavior} is non-@code{nil}, then these 802If @code{eshell-plain-grep-behavior} is non-@code{nil}, then these
684commands do not use Emacs's internal @code{grep}. This is the same as 803commands do not use open a compilation buffer, instead printing output
685using @samp{alias grep '*grep $@@*'}, though this setting applies to 804to Eshell's buffer. This is the same as using @samp{alias grep '*grep
686all of the built-in commands for which you would need to create a 805$@@*'}, though this setting applies to all of the built-in commands
687separate alias. 806for which you would need to create a separate alias.
688 807
689@item history
690@cmindex history 808@cmindex history
691Prints Eshell's input history. With a numeric argument @var{N}, this 809@item history [@var{n}]
692command prints the @var{N} most recent items in the history. 810@itemx history [-arw] [@var{filename}]
811Prints Eshell's input history. With a numeric argument @var{n}, this
812command prints the @var{n} most recent items in the history.
813Alternately, you can specify the following options:
814
815@table @asis
816
817@item @code{-a}, @code{--append}
818Append new history items to the history file.
819
820@item @code{-r}, @code{--read}
821Read history items from the history file and append them to the
822current shell's history.
823
824@item @code{-w}, @code{--write}
825Write the current history list to the history file.
826
827@end table
693 828
694@item info
695@cmindex info 829@cmindex info
696Browse the available Info documentation. This command is the same as 830@item info [@var{manual} [@var{item}]@dots{}]
697the external @command{info} command, but uses Emacs's internal Info 831Browse the available Info documentation. With no arguments, browse
698reader. 832the top-level menu. Otherwise, show the manual for @var{manual},
699@xref{Misc Help, , , emacs, The GNU Emacs Manual}. 833selecting the menu entry for @var{item}.
834
835This command is the same as the external @command{info} command, but
836uses Emacs's internal Info reader. @xref{Misc Help, , , emacs, The
837GNU Emacs Manual}.
700 838
701@item jobs
702@cmindex jobs 839@cmindex jobs
840@cindex processes, listing
841@item jobs
703List subprocesses of the Emacs process, if any, using the function 842List subprocesses of the Emacs process, if any, using the function
704@code{list-processes}. 843@code{list-processes}.
705 844
706@item kill
707@cmindex kill 845@cmindex kill
846@cindex processes, signaling
847@item kill [-@var{signal}] [@var{pid} | @var{process}]
708Kill processes. Takes a PID or a process object and an optional 848Kill processes. Takes a PID or a process object and an optional
709signal specifier which can either be a number or a signal name. 849@var{signal} specifier which can either be a number or a signal name.
710 850
711@item listify
712@cmindex listify 851@cmindex listify
713Eshell version of @code{list}. Allows you to create a list using Eshell 852@item listify [@var{arg}]@dots{}
714syntax, rather than Elisp syntax. For example, @samp{listify foo bar} 853Return the arguments as a single list. With a single argument, return
715and @code{("foo" "bar")} both evaluate to @code{("foo" "bar")}. 854it as-is if it's already a list, or otherwise wrap it in a list. With
855multiple arguments, return a list of all of them.
716 856
717@item ln
718@cmindex ln 857@cmindex ln
719Create links to files. 858@item ln [@var{option}]@dots{} @var{target} [@var{link-name}]
859@itemx ln [@var{option}]@dots{} @var{target}@dots{} @var{directory}
860Create a link to the specified @var{target} named @var{link-name} or
861create links to multiple @var{targets} in @var{directory}.
720 862
721@vindex eshell-ln-overwrite-files 863@vindex eshell-ln-overwrite-files
722@vindex eshell-ln-interactive-query 864@vindex eshell-ln-interactive-query
@@ -725,8 +867,31 @@ will overwrite files without warning. If
725@code{eshell-ln-interactive-query} is non-@code{nil}, then 867@code{eshell-ln-interactive-query} is non-@code{nil}, then
726@command{ln} will ask before overwriting files. 868@command{ln} will ask before overwriting files.
727 869
728@item locate 870@command{ln} accepts the following options:
871
872@table @asis
873
874@item @code{-f}, @code{--force}
875Never prompt for confirmation before linking a target.
876
877@item @code{-i}, @code{--interactive}
878Prompt for confirmation before linking to an item if the source
879already exists.
880
881@item @code{-n}, @code{--preview}
882Run the command, but don't move anything. This is useful if you
883want to preview what would be linked when calling @command{ln}.
884
885@item @code{-s}, @code{--symbolic}
886Make symbolic links instead of hard links.
887
888@item @code{-v}, @code{--verbose}
889Print the name of each file before linking it.
890
891@end table
892
729@cmindex locate 893@cmindex locate
894@item locate @var{arg}@dots{}
730Alias to Emacs's @code{locate} function, which simply runs the external 895Alias to Emacs's @code{locate} function, which simply runs the external
731@command{locate} command and parses the results. 896@command{locate} command and parses the results.
732@xref{Dired and Find, , , emacs, The GNU Emacs Manual}. 897@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
736internal @code{locate} is not used. This is the same as using 901internal @code{locate} is not used. This is the same as using
737@samp{alias locate '*locate $@@*'}. 902@samp{alias locate '*locate $@@*'}.
738 903
739@item ls
740@cmindex ls 904@cmindex ls
741Lists the contents of directories. 905@item ls [@var{option}]@dots{} [@var{file}]@dots{}
906List information about each @var{file}, including the contents of any
907specified directories. If @var{file} is unspecified, list the
908contents of the current directory.
909
910@vindex eshell-ls-initial-args
911The user option @code{eshell-ls-initial-args} contains a list of
912arguments to include with any call to @command{ls}. For example, you
913can include the option @option{-h} to always use a more human-readable
914format.
742 915
743@vindex eshell-ls-use-colors 916@vindex eshell-ls-use-colors
744If @code{eshell-ls-use-colors} is non-@code{nil}, the contents of a 917If @code{eshell-ls-use-colors} is non-@code{nil}, the contents of a
745directory is color-coded according to file type and status. These 918directory is color-coded according to file type and status. These
746colors and the regexps used to identify their corresponding files can 919colors and the regexps used to identify their corresponding files can
747be customized via @w{@kbd{M-x customize-group @key{RET} eshell-ls @key{RET}}}. 920be customized via @w{@kbd{M-x customize-group @key{RET} eshell-ls
921@key{RET}}}.
922
923@command{ls} supports the following options:
924
925@table @asis
926
927@item @code{-a}, @code{--all}
928List all files, including ones starting with @samp{.}.
929
930@item @code{-A}, @code{--almost-all}
931Like @code{--all}, but don't list the current directory (@file{.}) or
932the parent directory (@file{..}).
933
934@item @code{-c}, @code{--by-ctime}
935Sort files by last status change time, with newest files first.
936
937@item @code{-C}
938List entries by columns.
939
940@item @code{-d}, @code{--directory}
941List directory entries instead of their contents.
942
943@item @code{-h}, @code{--human-readable}
944Print sizes in human-readable format, with binary prefixes (so 1 KB is
9451024 bytes).
946
947@item @code{-H}, @code{--si}
948Print sizes in human-readable format, with decimal prefixes (so 1 KB
949is 1000 bytes).
950
951@item @code{-I@var{pattern}}, @code{--ignore=@var{pattern}}
952Don't list directory entries matching @var{pattern}.
953
954@item @code{-k}, @code{--kilobytes}
955Print sizes as 1024-byte kilobytes.
748 956
749@vindex eshell-ls-date-format 957@vindex eshell-ls-date-format
750The user option @code{eshell-ls-date-format} determines how the date 958@item @code{-l}
751is displayed when using the @option{-l} option. The date is produced 959Use a long listing format showing details for each file. The user
752using the function @code{format-time-string} (@pxref{Time Parsing,,, 960option @code{eshell-ls-date-format} determines how the date is
753elisp, GNU Emacs Lisp Reference Manual}). 961displayed when using this option. The date is produced using the
962function @code{format-time-string} (@pxref{Time Parsing,,, elisp, GNU
963Emacs Lisp Reference Manual}).
754 964
755@vindex eshell-ls-initial-args 965@item @code{-L}, @code{--dereference}
756The user option @code{eshell-ls-initial-args} contains a list of 966Follow symbolic links when listing entries.
757arguments to include with any call to @command{ls}. For example, you 967
758can include the option @option{-h} to always use a more human-readable 968@item @code{-n}, @code{--numeric-uid-gid}
759format. 969Show UIDs and GIDs numerically, instead of using their names.
970
971@item @code{-r}, @code{--reverse}
972Reverse order when sorting.
973
974@item @code{-R}, @code{--recursive}
975List subdirectories recursively.
976
977@item @code{-s}, @code{--size}
978Show the size of each file in blocks.
760 979
761@vindex eshell-ls-default-blocksize 980@vindex eshell-ls-default-blocksize
762The user option @code{eshell-ls-default-blocksize} determines the 981@item @code{-S}
763default blocksize used when displaying file sizes with the option 982Sort by file size, with largest files first. The user option
764@option{-s}. 983@code{eshell-ls-default-blocksize} determines the default blocksize
984used when displaying file sizes with this option.
985
986@item @code{-t}
987Sort by modification time, with newest files first.
988
989@item @code{-u}
990Sort by last access time, with newest files first.
991
992@item @code{-U}
993Do not sort results. Instead, list entries in their directory order.
994
995@item @code{-x}
996List entries by lines instead of by columns.
997
998@item @code{-X}
999Sort alphabetically by file extension.
1000
1001@item @code{-1}
1002List one file per line.
1003
1004@end table
765 1005
766@item make
767@cmindex make 1006@cmindex make
1007@item make [@var{arg}]@dots{}
768Run @command{make} through @code{compile} when run asynchronously 1008Run @command{make} through @code{compile} when run asynchronously
769(e.g., @samp{make &}). @xref{Compilation, , , emacs, The GNU Emacs 1009(e.g., @samp{make &}). @xref{Compilation, , , emacs, The GNU Emacs
770Manual}. Otherwise call the external @command{make} command. 1010Manual}. Otherwise call the external @command{make} command.
771 1011
772@item man
773@cmindex man 1012@cmindex man
1013@item man [@var{arg}]@dots{}
774Display Man pages using the Emacs @code{man} command. 1014Display Man pages using the Emacs @code{man} command.
775@xref{Man Page, , , emacs, The GNU Emacs Manual}. 1015@xref{Man Page, , , emacs, The GNU Emacs Manual}.
776 1016
777@item mkdir
778@cmindex mkdir 1017@cmindex mkdir
779Make new directories. 1018@item mkdir [-p] @var{directory}@dots{}
1019Make new directories. With @code{-p} or @code{--parents},
1020automatically make any necessary parent directories as well.
780 1021
781@item mv
782@cmindex mv 1022@cmindex mv
783Move or rename files. 1023@item mv [@var{option}]@dots{} @var{source} @var{dest}
1024@itemx mv [@var{option}]@dots{} @var{source}@dots{} @var{directory}
1025Rename the file @var{source} to @var{dest} or move @var{source} into
1026@var{directory}.
784 1027
785@vindex eshell-mv-overwrite-files 1028@vindex eshell-mv-overwrite-files
786@vindex eshell-mv-interactive-query 1029@vindex eshell-mv-interactive-query
@@ -789,40 +1032,95 @@ will overwrite files without warning. If
789@code{eshell-mv-interactive-query} is non-@code{nil}, @command{mv} 1032@code{eshell-mv-interactive-query} is non-@code{nil}, @command{mv}
790will prompt before overwriting anything. 1033will prompt before overwriting anything.
791 1034
792@item occur 1035@command{mv} accepts the following options:
1036
1037@table @asis
1038
1039@item @code{-f}, @code{--force}
1040Never prompt for confirmation before moving an item.
1041
1042@item @code{-i}, @code{--interactive}
1043Prompt for confirmation before moving an item if the target already
1044exists.
1045
1046@item @code{-n}, @code{--preview}
1047Run the command, but don't move anything. This is useful if you
1048want to preview what would be moved when calling @command{mv}.
1049
1050@item @code{-v}, @code{--verbose}
1051Print the name of each item before moving it.
1052
1053@end table
1054
793@cmindex occur 1055@cmindex occur
1056@item occur @var{regexp} [@var{nlines}]
794Alias to Emacs's @code{occur}. 1057Alias to Emacs's @code{occur}.
795@xref{Other Repeating Search, , , emacs, The GNU Emacs Manual}. 1058@xref{Other Repeating Search, , , emacs, The GNU Emacs Manual}.
796 1059
797@item popd
798@cmindex popd 1060@cmindex popd
1061@cindex directory stack, removing from
1062@item popd
1063@item popd +@var{n}
799Pop a directory from the directory stack and switch to a another place 1064Pop a directory from the directory stack and switch to a another place
800in the stack. 1065in the stack. This command can take the following forms:
1066
1067@table @code
1068
1069@item popd
1070Remove the current directory from the directory stack and change to
1071the directory beneath it.
1072
1073@item popd +@var{n}
1074Remove the current directory from the directory stack and change to
1075the @var{nth} directory in the stack (counting from zero).
1076
1077@end table
801 1078
802@item printnl
803@cmindex printnl 1079@cmindex printnl
804Print the arguments separated by newlines. 1080@item printnl [@var{arg}]@dots{}
1081Print all the @var{arg}s separated by newlines.
805 1082
806@item pushd
807@cmindex pushd 1083@cmindex pushd
1084@cindex directory stack, adding to
1085@item pushd
1086@itemx pushd @var{directory}
1087@itemx pushd +@var{n}
808Push the current directory onto the directory stack, then change to 1088Push the current directory onto the directory stack, then change to
809another directory. 1089another directory. This command can take the following forms:
1090
1091@table @code
1092
1093@vindex eshell-pushd-tohome
1094@item pushd
1095Swap the current directory with the directory on the top of the stack.
1096If @code{eshell-pushd-tohome} is non-@code{nil}, push the current
1097directory onto the stack and change to the user's home directory (like
1098@samp{pushd ~}).
810 1099
811@vindex eshell-pushd-dunique 1100@vindex eshell-pushd-dunique
1101@item pushd @var{directory}
1102Push the current directory onto the stack and change to
1103@var{directory}. If @code{eshell-pushd-dunique} is non-@code{nil},
1104then only unique directories will be added to the stack.
1105
812@vindex eshell-pushd-dextract 1106@vindex eshell-pushd-dextract
813If @code{eshell-pushd-dunique} is non-@code{nil}, then only unique 1107@item pushd +@var{n}
814directories will be added to the stack. If 1108Change to the @var{nth} directory in the directory stack (counting
815@code{eshell-pushd-dextract} is non-@code{nil}, then @samp{pushd 1109from zero), and ``rotate'' the stack by moving any elements before the
816+@var{n}} will pop the @var{n}th directory to the top of the stack. 1110@var{nth} to the bottom. If @code{eshell-pushd-dextract} is
1111non-@code{nil}, then @samp{pushd +@var{n}} will instead pop the
1112@var{n}th directory to the top of the stack.
1113
1114@end table
817 1115
818@item pwd
819@cmindex pwd 1116@cmindex pwd
1117@item pwd
820Prints the current working directory. 1118Prints the current working directory.
821 1119
822@item rm
823@cmindex rm 1120@cmindex rm
1121@item rm [@var{option}]@dots{} @var{item}@dots{}
824Removes files, buffers, processes, or Emacs Lisp symbols, depending on 1122Removes files, buffers, processes, or Emacs Lisp symbols, depending on
825the argument. 1123the type of each @var{item}.
826 1124
827@vindex eshell-rm-interactive-query 1125@vindex eshell-rm-interactive-query
828@vindex eshell-rm-removes-directories 1126@vindex eshell-rm-removes-directories
@@ -832,59 +1130,89 @@ will prompt before removing anything. If
832@command{rm} can also remove directories. Otherwise, @command{rmdir} 1130@command{rm} can also remove directories. Otherwise, @command{rmdir}
833is required. 1131is required.
834 1132
835@item rmdir 1133@command{rm} accepts the following options:
1134
1135@table @asis
1136
1137@item @code{-f}, @code{--force}
1138Never prompt for confirmation before removing an item.
1139
1140@item @code{-i}, @code{--interactive}
1141Prompt for confirmation before removing each item.
1142
1143@item @code{-n}, @code{--preview}
1144Run the command, but don't remove anything. This is useful if you
1145want to preview what would be removed when calling @command{rm}.
1146
1147@item @code{-r}, @code{-R}, @code{--recursive}
1148Remove any specified directories and their contents recursively.
1149
1150@item @code{-v}, @code{--verbose}
1151Print the name of each item before removing it.
1152
1153@end table
1154
836@cmindex rmdir 1155@cmindex rmdir
1156@item rmdir @var{directory}@dots{}
837Removes directories if they are empty. 1157Removes directories if they are empty.
838 1158
839@item set
840@cmindex set 1159@cmindex set
1160@item set [@var{var} @var{value}]@dots{}
841Set variable values, using the function @code{set} like a command 1161Set variable values, using the function @code{set} like a command
842(@pxref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}). 1162(@pxref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}).
843A variable name can be a symbol, in which case it refers to a Lisp 1163The value of @var{var} can be a symbol, in which case it refers to a
844variable, or a string, referring to an environment variable 1164Lisp variable, or a string, referring to an environment variable
845(@pxref{Arguments}). 1165(@pxref{Arguments}).
846 1166
847@item setq
848@cmindex setq 1167@cmindex setq
1168@item setq [@var{symbol} @var{value}]@dots{}
849Set variable values, using the function @code{setq} like a command 1169Set variable values, using the function @code{setq} like a command
850(@pxref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}). 1170(@pxref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}).
851 1171
852@item source
853@cmindex source 1172@cmindex source
854Source an Eshell file in a subshell environment. This is not to be 1173@item source @var{file} [@var{argument}]@dots{}
855confused with the command @command{.}, which sources a file in the 1174Source an Eshell script named @var{file} in a subshell environment,
856current environment. 1175passing any @var{argument}s to the script (@pxref{Scripts}). This is
1176not to be confused with the command @command{.}, which sources a file
1177in the current environment.
857 1178
858@item time
859@cmindex time 1179@cmindex time
860Show the time elapsed during a command's execution. 1180@item time @var{command}@dots{}
1181Show the time elapsed during the execution of @var{command}.
861 1182
862@item umask
863@cmindex umask 1183@cmindex umask
864Set or view the default file permissions for newly created files and 1184@item umask [-S]
865directories. 1185@itemx umask @var{mode}
1186View the default file permissions for newly created files and
1187directories. If you pass @code{-S} or @code{--symbolic}, view the
1188mode symbolically. With @var{mode}, set the default permissions to
1189this value.
866 1190
867@item unset
868@cmindex unset 1191@cmindex unset
869Unset one or more variables. As with @command{set}, a variable name 1192@item unset [@var{var}]@dots{}
870can be a symbol, in which case it refers to a Lisp variable, or a 1193Unset one or more variables. As with @command{set}, the value of
871string, referring to an environment variable. 1194@var{var} can be a symbol, in which case it refers to a Lisp variable,
1195or a string, referring to an environment variable.
872 1196
873@item wait
874@cmindex wait 1197@cmindex wait
875Wait until a process has successfully completed. 1198@cindex processes, waiting for
1199@item wait [@var{process}]@dots{}
1200Wait until each specified @var{process} has exited.
876 1201
877@item which
878@cmindex which 1202@cmindex which
879Identify a command and its location. 1203@item which @var{command}@dots{}
1204For each @var{command}, identify what kind of command it is and its
1205location.
880 1206
881@item whoami
882@cmindex whoami 1207@cmindex whoami
883Print the current user. This Eshell version of @command{whoami} 1208@item whoami
884supports Tramp. 1209Print the current user. This Eshell version of @command{whoami} is
1210connection-aware, so for remote directories, it will print the user
1211associated with that connection.
885@end table 1212@end table
886 1213
887@subsection Defining new built-in commands 1214@node Defining New Built-ins
1215@subsection Defining New Built-in Commands
888While Eshell can run Lisp functions directly as commands, it may be 1216While Eshell can run Lisp functions directly as commands, it may be
889more convenient to provide a special built-in command for 1217more convenient to provide a special built-in command for
890Eshell. Built-in commands are just ordinary Lisp functions designed 1218Eshell. Built-in commands are just ordinary Lisp functions designed
@@ -1180,7 +1508,7 @@ create and switch to a directory called @samp{foo}.
1180 1508
1181@node Remote Access 1509@node Remote Access
1182@section Remote Access 1510@section Remote Access
1183@cmindex remote access 1511@cindex remote access
1184 1512
1185Since Eshell uses Emacs facilities for most of its functionality, you 1513Since Eshell uses Emacs facilities for most of its functionality, you
1186can access remote hosts transparently. To connect to a remote host, 1514can 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
1353are invoked from Eshell with @command{source}, or from anywhere in Emacs 1681are invoked from Eshell with @command{source}, or from anywhere in Emacs
1354with @code{eshell-source-file}. 1682with @code{eshell-source-file}.
1355 1683
1684Like with aliases (@pxref{Aliases}), Eshell scripts can accept any
1685number of arguments. Within the script, you can refer to these with
1686the special variables @code{$0}, @code{$1}, @dots{}, @code{$9}, and
1687@code{$*}.
1688
1356@cmindex . 1689@cmindex .
1357If you wish to load a script into your @emph{current} environment, 1690If you wish to load a script into your @emph{current} environment,
1358rather than in a subshell, use the @code{.} command. 1691rather than in a subshell, use the @code{.} command.
@@ -1452,7 +1785,7 @@ As with @samp{$@{@var{command}@}}, evaluates the Eshell command invocation
1452@command{@var{command}}, but writes the output to a temporary file and 1785@command{@var{command}}, but writes the output to a temporary file and
1453returns the file name. 1786returns the file name.
1454 1787
1455@item $@var{expr}[@var{i...}] 1788@item $@var{expr}[@var{i@dots{}}]
1456Expands to the @var{i}th element of the result of @var{expr}, an 1789Expands to the @var{i}th element of the result of @var{expr}, an
1457expression in one of the above forms listed here. If multiple indices 1790expression in one of the above forms listed here. If multiple indices
1458are supplied, this will return a list containing the elements for each 1791are 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
1501expand to @code{2}, i.e.@: the second element of the first list member 1834expand to @code{2}, i.e.@: the second element of the first list member
1502(all indices are zero-based). 1835(all indices are zero-based).
1503 1836
1504@item $@var{expr}[@var{regexp} @var{i...}] 1837@item $@var{expr}[@var{regexp} @var{i@dots{}}]
1505As above (when @var{expr} expands to a string), but use @var{regexp} 1838As above (when @var{expr} expands to a string), but use @var{regexp}
1506to split the string. @var{regexp} can be any form other than a 1839to split the string. @var{regexp} can be any form other than a
1507number. For example, @samp{$@var{var}[: 0]} will return the first 1840number. For example, @samp{$@var{var}[: 0]} will return the first
@@ -2275,15 +2608,23 @@ external commands. To enable it, add @code{eshell-tramp} to
2275 2608
2276@table @code 2609@table @code
2277 2610
2278@item su
2279@cmindex su 2611@cmindex su
2280@itemx sudo 2612@item su [- | -l] [@var{user}]
2613Uses TRAMP's @command{su} method (@pxref{Inline methods, , , tramp,
2614The Tramp Manual}) to change the current user to @var{user} (or root
2615if unspecified). With @code{-}, @code{-l}, or @code{--login}, provide
2616a login environment.
2617
2281@cmindex sudo 2618@cmindex sudo
2282@itemx doas 2619@item sudo [-u @var{user}] [-s | @var{command}@dots{}]
2283@cmindex doas 2620@cmindex doas
2284Uses TRAMP's @command{su}, @command{sudo}, or @command{doas} method 2621@itemx doas [-u @var{user}] [-s | @var{command}@dots{}]
2285(@pxref{Inline methods, , , tramp, The Tramp Manual}) to run a command 2622Uses TRAMP's @command{sudo} or @command{doas} method (@pxref{Inline
2286via @command{su}, @command{sudo}, or @command{doas}. 2623methods, , , tramp, The Tramp Manual}) to run @var{command} as root
2624via @command{sudo} or @command{doas}. When specifying @code{-u
2625@var{user}} or @code{--user @var{user}}, run the command as @var{user}
2626instead. With @code{-s} or @code{--shell}, start a shell instead of
2627running @var{command}.
2287 2628
2288@end table 2629@end table
2289 2630
@@ -2296,59 +2637,59 @@ add @code{eshell-xtra} to @code{eshell-modules-list}.
2296 2637
2297@table @code 2638@table @code
2298 2639
2299@item count
2300@cmindex count 2640@cmindex count
2641@item count @var{item} @var{seq} [@var{option}]@dots{}
2301A wrapper around the function @code{cl-count} (@pxref{Searching 2642A wrapper around the function @code{cl-count} (@pxref{Searching
2302Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can 2643Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can
2303be used for comparing lists of strings. 2644be used for comparing lists of strings.
2304 2645
2305@item expr
2306@cmindex expr 2646@cmindex expr
2647@item expr @var{str} [@var{separator}] [@var{arg}]@dots{}
2307An implementation of @command{expr} using the Calc package. 2648An implementation of @command{expr} using the Calc package.
2308@xref{Top,,, calc, The GNU Emacs Calculator}. 2649@xref{Top,,, calc, The GNU Emacs Calculator}.
2309 2650
2310@item ff
2311@cmindex ff 2651@cmindex ff
2652@item ff @var{directory} @var{pattern}
2312Shorthand for the the function @code{find-name-dired} (@pxref{Dired 2653Shorthand for the the function @code{find-name-dired} (@pxref{Dired
2313and Find, , , emacs, The Emacs Editor}). 2654and Find, , , emacs, The Emacs Editor}).
2314 2655
2315@item gf
2316@cmindex gf 2656@cmindex gf
2657@item gf @var{directory} @var{regexp}
2317Shorthand for the the function @code{find-grep-dired} (@pxref{Dired 2658Shorthand for the the function @code{find-grep-dired} (@pxref{Dired
2318and Find, , , emacs, The Emacs Editor}). 2659and Find, , , emacs, The Emacs Editor}).
2319 2660
2320@item intersection
2321@cmindex intersection 2661@cmindex intersection
2662@item intersection @var{list1} @var{list2} [@var{option}]@dots{}
2322A wrapper around the function @code{cl-intersection} (@pxref{Lists as 2663A wrapper around the function @code{cl-intersection} (@pxref{Lists as
2323Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command 2664Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command
2324can be used for comparing lists of strings. 2665can be used for comparing lists of strings.
2325 2666
2326@item mismatch
2327@cmindex mismatch 2667@cmindex mismatch
2668@item mismatch @var{seq1} @var{seq2} [@var{option}]@dots{}
2328A wrapper around the function @code{cl-mismatch} (@pxref{Searching 2669A wrapper around the function @code{cl-mismatch} (@pxref{Searching
2329Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can 2670Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can
2330be used for comparing lists of strings. 2671be used for comparing lists of strings.
2331 2672
2332@item set-difference
2333@cmindex set-difference 2673@cmindex set-difference
2674@item set-difference @var{list1} @var{list2} [@var{option}]@dots{}
2334A wrapper around the function @code{cl-set-difference} (@pxref{Lists 2675A wrapper around the function @code{cl-set-difference} (@pxref{Lists
2335as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be 2676as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be
2336used for comparing lists of strings. 2677used for comparing lists of strings.
2337 2678
2338@item set-exclusive-or
2339@cmindex set-exclusive-or 2679@cmindex set-exclusive-or
2680@item set-exclusive-or @var{list1} @var{list2} [@var{option}]@dots{}
2340A wrapper around the function @code{cl-set-exclusive-or} (@pxref{Lists 2681A wrapper around the function @code{cl-set-exclusive-or} (@pxref{Lists
2341as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be 2682as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be
2342used for comparing lists of strings. 2683used for comparing lists of strings.
2343 2684
2344@item substitute
2345@cmindex substitute 2685@cmindex substitute
2686@item substitute @var{new} @var{old} @var{seq} [@var{option}]@dots{}
2346A wrapper around the function @code{cl-substitute} (@pxref{Sequence 2687A wrapper around the function @code{cl-substitute} (@pxref{Sequence
2347Functions,,, cl, GNU Emacs Common Lisp Emulation}). This command can 2688Functions,,, cl, GNU Emacs Common Lisp Emulation}). This command can
2348be used for comparing lists of strings. 2689be used for comparing lists of strings.
2349 2690
2350@item union
2351@cmindex union 2691@cmindex union
2692@item union @var{list1} @var{list2} [@var{option}]@dots{}
2352A wrapper around the function @code{cl-union} (@pxref{Lists as Sets,,, 2693A wrapper around the function @code{cl-union} (@pxref{Lists as Sets,,,
2353cl, GNU Emacs Common Lisp Emulation}). This command can be used for 2694cl, GNU Emacs Common Lisp Emulation}). This command can be used for
2354comparing lists of strings. 2695comparing 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
5832@kindex S v @r{(Summary)} 5832@kindex S v @r{(Summary)}
5833@findex gnus-summary-very-wide-reply 5833@findex gnus-summary-very-wide-reply
5834Mail a very wide reply to the author of the current article 5834Mail a very wide reply to the author of the current article
5835(@code{gnus-summary-very-wide-reply}). A @dfn{very wide reply} is a reply 5835(@code{gnus-summary-very-wide-reply}). A @dfn{very wide reply} is a
5836that goes out to all people listed in the @code{To}, @code{From} (or 5836reply that goes out to all people listed in the @code{To}, @code{From}
5837@code{Reply-To}) and @code{Cc} headers in all the process/prefixed 5837(or @code{Reply-To}) and @code{Cc} headers in all the process/prefixed
5838articles. This command uses the process/prefix convention. 5838articles. This command uses the process/prefix convention. If given a
5839prefix argument, the body of the current article will also be yanked.
5839 5840
5840@item S V 5841@item S V
5841@kindex S V @r{(Summary)} 5842@kindex S V @r{(Summary)}
@@ -26694,9 +26695,12 @@ buffers. It is enabled with
26694@table @kbd 26695@table @kbd
26695@item C-c C-m C-a 26696@item C-c C-m C-a
26696@findex gnus-dired-attach 26697@findex gnus-dired-attach
26698@vindex gnus-dired-attach-at-end
26697@cindex attachments, selection via dired 26699@cindex attachments, selection via dired
26698Send dired's marked files as an attachment (@code{gnus-dired-attach}). 26700Send dired's marked files as an attachment (@code{gnus-dired-attach}).
26699You will be prompted for a message buffer. 26701The function prompts for a message buffer, and by default attaches files
26702to the end of that buffer; customize @code{gnus-dired-attach-at-end} to
26703place the attachments at point instead.
26700 26704
26701@item C-c C-m C-l 26705@item C-c C-m C-l
26702@findex gnus-dired-find-file-mailcap 26706@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 @@
3% Load plain if necessary, i.e., if running under initex. 3% Load plain if necessary, i.e., if running under initex.
4\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi 4\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
5% 5%
6\def\texinfoversion{2023-09-19.19} 6\def\texinfoversion{2024-02-10.22}
7% 7%
8% Copyright 1985, 1986, 1988, 1990-2023 Free Software Foundation, Inc. 8% Copyright 1985, 1986, 1988, 1990-2024 Free Software Foundation, Inc.
9% 9%
10% This texinfo.tex file is free software: you can redistribute it and/or 10% This texinfo.tex file is free software: you can redistribute it and/or
11% modify it under the terms of the GNU General Public License as 11% modify it under the terms of the GNU General Public License as
@@ -5238,14 +5238,14 @@ $$%
5238% the current value of \escapechar. 5238% the current value of \escapechar.
5239\def\escapeisbackslash{\escapechar=`\\} 5239\def\escapeisbackslash{\escapechar=`\\}
5240 5240
5241% Use \ in index files by default. texi2dvi didn't support @ as the escape 5241% Uncomment to use \ in index files by default. Old texi2dvi (before 2019)
5242% character (as it checked for "\entry" in the files, and not "@entry"). When 5242% didn't support @ as the escape character (as it checked for "\entry" in
5243% the new version of texi2dvi has had a chance to become more prevalent, then 5243% the files, and not "@entry").
5244% the escape character can change back to @ again. This should be an easy 5244% In the future we can remove this flag and simplify the code for
5245% change to make now because both @ and \ are only used as escape characters in 5245% index files and backslashes, once the support is no longer likely to be
5246% index files, never standing for themselves. 5246% useful.
5247% 5247%
5248\set txiindexescapeisbackslash 5248% \set txiindexescapeisbackslash
5249 5249
5250% Write the entry in \indextext to the index file. 5250% Write the entry in \indextext to the index file.
5251% 5251%
@@ -6137,8 +6137,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
6137% normally unnmhead0 calls unnumberedzzz: 6137% normally unnmhead0 calls unnumberedzzz:
6138\outer\parseargdef\unnumbered{\unnmhead0{#1}} 6138\outer\parseargdef\unnumbered{\unnmhead0{#1}}
6139\def\unnumberedzzz#1{% 6139\def\unnumberedzzz#1{%
6140 \global\secno=0 \global\subsecno=0 \global\subsubsecno=0 6140 \global\advance\unnumberedno by 1
6141 \global\advance\unnumberedno by 1
6142 % 6141 %
6143 % Since an unnumbered has no number, no prefix for figures. 6142 % Since an unnumbered has no number, no prefix for figures.
6144 \global\let\chaplevelprefix = \empty 6143 \global\let\chaplevelprefix = \empty
@@ -6194,8 +6193,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
6194% normally calls unnumberedseczzz: 6193% normally calls unnumberedseczzz:
6195\outer\parseargdef\unnumberedsec{\unnmhead1{#1}} 6194\outer\parseargdef\unnumberedsec{\unnmhead1{#1}}
6196\def\unnumberedseczzz#1{% 6195\def\unnumberedseczzz#1{%
6197 \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1 6196 \global\advance\unnumberedno by 1
6198 \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno.\the\secno}% 6197 \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno}%
6199} 6198}
6200 6199
6201% Subsections. 6200% Subsections.
@@ -6218,9 +6217,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
6218% normally calls unnumberedsubseczzz: 6217% normally calls unnumberedsubseczzz:
6219\outer\parseargdef\unnumberedsubsec{\unnmhead2{#1}} 6218\outer\parseargdef\unnumberedsubsec{\unnmhead2{#1}}
6220\def\unnumberedsubseczzz#1{% 6219\def\unnumberedsubseczzz#1{%
6221 \global\subsubsecno=0 \global\advance\subsecno by 1 6220 \global\advance\unnumberedno by 1
6222 \sectionheading{#1}{subsec}{Ynothing}% 6221 \sectionheading{#1}{subsec}{Ynothing}{\the\unnumberedno}%
6223 {\the\unnumberedno.\the\secno.\the\subsecno}%
6224} 6222}
6225 6223
6226% Subsubsections. 6224% Subsubsections.
@@ -6244,9 +6242,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
6244% normally unnumberedsubsubseczzz: 6242% normally unnumberedsubsubseczzz:
6245\outer\parseargdef\unnumberedsubsubsec{\unnmhead3{#1}} 6243\outer\parseargdef\unnumberedsubsubsec{\unnmhead3{#1}}
6246\def\unnumberedsubsubseczzz#1{% 6244\def\unnumberedsubsubseczzz#1{%
6247 \global\advance\subsubsecno by 1 6245 \global\advance\unnumberedno by 1
6248 \sectionheading{#1}{subsubsec}{Ynothing}% 6246 \sectionheading{#1}{subsubsec}{Ynothing}{\the\unnumberedno}%
6249 {\the\unnumberedno.\the\secno.\the\subsecno.\the\subsubsecno}%
6250} 6247}
6251 6248
6252% These macros control what the section commands do, according 6249% These macros control what the section commands do, according
@@ -8205,8 +8202,6 @@ might help (with 'rm \jobname.?? \jobname.??s')%
8205 \let\commondummyword\unmacrodo 8202 \let\commondummyword\unmacrodo
8206 \xdef\macrolist{\macrolist}% 8203 \xdef\macrolist{\macrolist}%
8207 \endgroup 8204 \endgroup
8208 \else
8209 \errmessage{Macro #1 not defined}%
8210 \fi 8205 \fi
8211} 8206}
8212 8207
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.
523@cindex @option{sudo} method 523@cindex @option{sudo} method
524@cindex method @option{doas} 524@cindex method @option{doas}
525@cindex @option{doas} method 525@cindex @option{doas} method
526@cindex method @option{androidsu}
527@cindex @option{androidsu} method
526 528
527If the @option{su}, @option{sudo} or @option{doas} option should be 529If the @option{su}, @option{sudo} or @option{doas} option should be
528performed on another host, it can be comnbined with a leading 530performed on another host, it can be combined with a leading
529@option{ssh} or @option{plink} option. That means that @value{tramp} 531@option{ssh} or @option{plink} option. That means that @value{tramp}
530connects first to the other host with non-administrative credentials, 532connects first to the other host with non-administrative credentials,
531and changes to administrative credentials on that host afterwards. In 533and changes to administrative credentials on that host afterwards. In
@@ -533,6 +535,11 @@ a simple case, the syntax looks like
533@file{@trampfn{ssh@value{postfixhop}user@@host|sudo,,/path/to/file}}. 535@file{@trampfn{ssh@value{postfixhop}user@@host|sudo,,/path/to/file}}.
534@xref{Ad-hoc multi-hops}. 536@xref{Ad-hoc multi-hops}.
535 537
538The @option{su} method and other shell-based methods conflict with
539non-standard @command{su} implementations popular among Android users
540and the restricted command-line utilities distributed with that system.
541The @option{androidsu} method enables accessing files through
542@command{su} on such systems, but multi-hops are not supported.
536 543
537@anchor{Quick Start Guide sudoedit method} 544@anchor{Quick Start Guide sudoedit method}
538@section Using @command{sudoedit} 545@section Using @command{sudoedit}
@@ -1059,6 +1066,20 @@ session.
1059 1066
1060These methods support the @samp{-P} argument. 1067These methods support the @samp{-P} argument.
1061 1068
1069@item @option{dockercp}
1070@item @option{podmancp}
1071@cindex method @option{dockercp}
1072@cindex @option{dockercp} method
1073@cindex method @option{podmancp}
1074@cindex @option{podmancp} method
1075
1076These methods are similar to @option{docker} or @option{podman}, but
1077they use the command @command{docker cp} or @command{podman cp} for
1078transferring large files.
1079
1080These copy commands do not support file globs, and they ignore a user
1081name.
1082
1062@item @option{fcp} 1083@item @option{fcp}
1063@cindex method @option{fcp} 1084@cindex method @option{fcp}
1064@cindex @option{fcp} method 1085@cindex @option{fcp} method
@@ -5238,9 +5259,14 @@ Does @value{tramp} support @acronym{SSH} security keys?
5238Yes. @command{OpenSSH} has added support for @acronym{FIDO} hardware 5259Yes. @command{OpenSSH} has added support for @acronym{FIDO} hardware
5239devices via special key types @option{*-sk}. @value{tramp} supports 5260devices via special key types @option{*-sk}. @value{tramp} supports
5240the additional handshaking messages for them. This requires at least 5261the additional handshaking messages for them. This requires at least
5241@command{OpenSSH} 8.2, and a @acronym{FIDO} @acronym{U2F} compatible 5262@command{OpenSSH} 8.2, and a @acronym{FIDO} @acronym{U2F} or
5242security key, like yubikey, solokey, nitrokey, or titankey. 5263@acronym{FIDO2} compatible security key, like yubikey, solokey,
5243 5264nitrokey, or titankey.
5265@c @uref{https://docs.fedoraproject.org/en-US/quick-docs/using-yubikeys/}
5266
5267@strong{Note} that there are reports on problems of handling FIDO2
5268(residential) keys by @command{ssh-agent}. As workaround, you might
5269disable @command{ssh-agent} for such keys.
5244 5270
5245@item 5271@item
5246@value{tramp} does not connect to Samba or MS Windows hosts running 5272@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 @@
1* Translating the Emacs manuals
2
3** Copyright assignment
4
5People who contribute translated documents should provide a copyright
6assignment to the Free Software Foundation. See the "Copyright
7Assignment" section in the Emacs manual.
8
9
10** Translated documents license
11
12The translated documents are distributed under the same license as the
13original documents: the GNU Free Documentation License, Version 1.3 or
14any later version published by the Free Software Foundation.
15
16See https://www.gnu.org/licenses/fdl-1.3.html for more information.
17
18If you have any questions regarding the use of the FDL license in your
19translation work that do not appear in the FAQ, feel free to contact the
20GNU project.
21
22See https://www.gnu.org/contact/ for more information.
23
24** Location of the translated files
25
26*** Texinfo source files
27
28The source files of the translated manuals are located in the
29doc/translations directory, under the sub-directory corresponding to the
30translated language.
31
32 E.g., French manual sources are found under doc/translations/fr.
33
34The structure of each language's folder should match that of the English
35manuals (i.e. include misc, man, lispref, lispintro, emacs).
36
37*** Built files
38
39Translated deliverables in Info format are built at release time and are
40made available for local installation.
41
42
43** Source files format
44
45The manuals and their translations are written in the Texinfo format
46(with the exception of the org-mode manual, which is written in Org, and
47illustrations for the Introduction to Emacs Lisp Programming, which are
48EPS files).
49
50See https://www.gnu.org/software/Texinfo/ for more information.
51
52You must install the Texinfo package in order to verify the translated
53files, and refer to the Texinfo manual for information on the various
54Texinfo features.
55
56Emacs has a Texinfo mode that highlights the parts of the Texinfo code
57to be translated for easy reference.
58
59
60*** Texinfo specific issues
61
62Until the Emacs/Texinfo projects provide better solutions, here are a
63few rules to follow:
64
65- Under each @node, add an @anchor that has the same content as the
66 original English @node.
67
68- Translate the @node content but leave the @anchor in English.
69
70- Most Emacs manuals are set to include the docstyle.Texi file. This
71 file adds the "@documentencoding UTF-8" directive to the targeted
72 manual. There is no need to add this directive in a manual that
73 includes docstyle.texi.
74
75- Add a @documentlanguage directive that includes your language.
76
77 E.g., @documentlanguage zh
78
79This directive currently has little effect but will be useful in the
80future.
81
82- The @author directive can be used for the translator's name.
83
84 E.g., @author traduit en français par Achile Talon
85
86
87** Fixing the original document
88
89During the course of the translation, you might encounter passages in
90the original document that need to be updated or otherwise corrected, or
91even run into a bug in Emacs. If you cannot immediately correct the
92problem, please file a bug report promptly.
93
94See the 'Bugs' section in the Emacs manual.
95
96** Sending your contributions
97
98Send your contributions (files or revisions) for review to the Emacs
99development list at emacs-devel@gnu.org. Subscribing to the list is not
100obligatory.
101
102Always send contributions in the format of the original document. Most
103of the content in the Emacs manuals is in Texinfo format, so please do
104not send contributions in derivative formats (e.g. info, html, docbook,
105plain text, etc.)
106
107Before sending files for review, please ensure that they have been
108thoroughly checked for spelling/grammar/typography by at least using the
109tools provided by Emacs.
110
111Please also make sure that the Texinfo files build properly on your
112system.
113
114Send your contributions as patches (git diff -p --stat), and prefer the
115git format-patch form, since that format allows for easier review and
116easier installation of the changes by the persons with write access to
117the repository.
118
119The Emacs project has a lot of coding, documentation and commenting
120conventions. Sending such patches allows the project managers to make
121sure that the contributions comply with the various conventions.
122
123
124** Discussing translation issues
125
126Translation-related discussions are welcome on the emacs development
127list. Discussions specific to your language do not have to be in
128English.
129
130
131** Translation teams
132
133The number of words in the Emacs manuals is over 2,000,000 words and
134growing. While one individual could theoretically translate all the
135files, it is more practical to work in language teams.
136
137If you have a small group of translators willing to help, please make
138sure that the files are properly reviewed before sending them to the
139Emacs development list (see above).
140
141Please refer to the translation-related documents maintained by the GNU
142Project, and contact your language translation team to learn the
143practices they have developed over the years.
144
145See https://www.gnu.org/server/standards/README.translations.html for
146more information.
147
148
149** Translation processes
150
151Emacs does not yet provide tools that significantly help the translation
152process. A few useful functions would be:
153
154- automatic lookup of a list of glossary items when starting to work on
155 a translation "unit" (paragraph or otherwise); such glossary terms
156 should be easily insertable at point,
157
158- automatic lookup of past translations to check for similarity and
159 improve homogeneity over the whole document set; such past translation
160 matches should be easily insertable at point, etc.
161
162
163*** Using the PO format as an intermediate translation format
164
165Although the PO format has not been developed with documentation in
166mind, it is well-known among free software translation teams, and you
167can easily use the po4a utility to convert Texinfo to PO for work in
168translation tools that support the PO format.
169
170See https://po4a.org for more information.
171
172However, regardless of the intermediate file format that you might use,
173you should only send files in the original format (Texinfo, org-mode,
174eps) for review and installation.
175
176
177*** Free tools that you can use in your processes
178
179A number of free software tools are available outside the Emacs project,
180to help translators (both amateur and professional) in the translation
181process.
182
183If they have any features that you think Emacs should implement, you are
184welcome to provide patches to the Emacs project.
185
186Such tools include:
187
188- the GNOME Translation Editor, https://wiki.gnome.org/Apps/Gtranslator/
189- KDE's Lokalize, https://apps.kde.org/lokalize/
190- OmegaT, https://omegat.org
191- the Okapi Framework, https://www.okapiframework.org
192- pootle, https://pootle.translatehouse.org
193
194etc.
195
196
197* Licence of this document
198
199Copyright (C) 2024 Free Software Foundation, Inc.
200
201Copying and distribution of this file, with or without modification, are
202permitted in any medium without royalty provided the copyright notice
203and this notice are preserved. This file is offered as-is, without any
204warranty.
205
206
207Local Variables:
208mode: outline
209paragraph-separate: "[ ]*$"
210coding: utf-8
211End:
diff --git a/doc/lang/fr/misc/ses-fr.texi b/doc/translations/fr/misc/ses-fr.texi
index e1b9cac5fc3..e1b9cac5fc3 100644
--- a/doc/lang/fr/misc/ses-fr.texi
+++ b/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
334automatically on your behalf, even if a change was made in a 334automatically on your behalf, even if a change was made in a
335'Custom-mode' buffer or via 'setopt'. 335'Custom-mode' buffer or via 'setopt'.
336 336
337** New broadcast-oriented slash commands /AME, /GME, and /GMSG.
338Also available as the library functions 'erc-cmd-AME', 'erc-cmd-GME',
339and 'erc-cmd-GMSG', these new slash commands can prove handy in test
340environments.
341
337** Miscellaneous UX changes. 342** Miscellaneous UX changes.
338Some minor quality-of-life niceties have finally made their way to 343Some minor quality-of-life niceties have finally made their way to
339ERC. For example, fool visibility has become togglable with the new 344ERC. For example, fool visibility has become togglable with the new
@@ -435,9 +440,12 @@ contains unique closures and thus no longer proves effective for
435traversing inserted messages. For now, ERC only provides an internal 440traversing inserted messages. For now, ERC only provides an internal
436means of visiting messages, but a public interface is forthcoming. 441means of visiting messages, but a public interface is forthcoming.
437Also affecting the 'stamp' module is the deprecation of the function 442Also affecting the 'stamp' module is the deprecation of the function
438'erc-insert-aligned' and its removal from client code. Additionally, 443'erc-insert-aligned' and its removal from the default client's code.
439the module now merges its 'invisible' property with existing ones and 444In the same library, the function 'erc-munge-invisibility-spec' has
440includes all white space around stamps when doing so. 445been renamed to 'erc-stamp--manage-local-options-state' to better
446reflect its purpose. Additionally, the module now merges its
447'invisible' property with existing ones and includes all white space
448around stamps when doing so.
441 449
442This "propertizing" of surrounding white space extends to all 450This "propertizing" of surrounding white space extends to all
443'stamp'-applied properties, like 'field', in all intervening space 451'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
499the provided feature of its containing library, if only for the usual 507the provided feature of its containing library, if only for the usual
500reasons of namespace hygiene and discoverability. 508reasons of namespace hygiene and discoverability.
501 509
510*** The function 'erc-open' no longer uses the 'TGT-LIST' parameter.
511ERC has always used the parameter to initialize the local variable
512'erc-default-recipients', which stores a list of routing targets with
513the topmost considered "active." However, since at least ERC 5.1, a
514buffer and its active target effectively mate for life, making
515'TGT-LIST', in practice, a read-only list of a single target. And
516because that target must also appear as the 'CHANNEL' parameter,
517'TGT-LIST' mainly serves to reinforce 'erc-open's reputation of being
518unruly.
519
502*** ERC supports arbitrary CHANTYPES. 520*** ERC supports arbitrary CHANTYPES.
503Specifically, channels can be prefixed with any predesignated 521Specifically, channels can be prefixed with any predesignated
504character, mainly to afford more flexibility to specialty services, 522character, mainly to afford more flexibility to specialty services,
@@ -681,8 +699,6 @@ by toggling a provided compatibility switch. See source code around
681the function 'erc-send-action' for details. 699the function 'erc-send-action' for details.
682 700
683*** Miscellaneous changes 701*** Miscellaneous changes
684Two helper macros from GNU ELPA's Compat library are now available to
685third-party modules as 'erc-compat-call' and 'erc-compat-function'.
686In 'erc-button-alist', 'Info-goto-node' has been supplanted by plain 702In 'erc-button-alist', 'Info-goto-node' has been supplanted by plain
687old 'info', and the "<URL:...>" entry has been removed because it was 703old 'info', and the "<URL:...>" entry has been removed because it was
688more or less redundant. In all ERC buffers, the "<TAB>" key is now 704more or less redundant. In all ERC buffers, the "<TAB>" key is now
@@ -1364,7 +1380,7 @@ reconnection attempts that ERC will make per server.
1364in seconds, that ERC will wait between successive reconnect attempts. 1380in seconds, that ERC will wait between successive reconnect attempts.
1365 1381
1366*** erc-server-send-ping-timeout: Determines when to consider a connection 1382*** erc-server-send-ping-timeout: Determines when to consider a connection
1367stalled and restart it. The default is after 120 seconds. 1383stalled and restart it. The default is after 120 seconds.
1368 1384
1369*** erc-system-name: Determines the system name to use when logging in. 1385*** erc-system-name: Determines the system name to use when logging in.
1370The default is to figure this out by calling `system-name'. 1386The default is to figure this out by calling `system-name'.
@@ -2325,7 +2341,7 @@ in XEmacs.
2325 Please use M-x customize-variable RET erc-modules RET to change the 2341 Please use M-x customize-variable RET erc-modules RET to change the
2326 default if it does not suite your needs. 2342 default if it does not suite your needs.
2327 2343
2328** THe symbol used in `erc-nickserv-passwords' for debian.org IRC servers 2344** The symbol used in `erc-nickserv-passwords' for debian.org IRC servers
2329 (formerly called OpenProjects, now FreeNode) has changed from 2345 (formerly called OpenProjects, now FreeNode) has changed from
2330 openprojects to freenode. You may need to update your configuration 2346 openprojects to freenode. You may need to update your configuration
2331 for a successful automatic nickserv identification. 2347 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'.
76 76
77+++ 77+++
78** 'completion-auto-help' now affects 'icomplete-in-buffer'. 78** 'completion-auto-help' now affects 'icomplete-in-buffer'.
79Previously, completion-auto-help mostly affected only minibuffer 79Previously, 'completion-auto-help' mostly affected only minibuffer
80completion. Now, if 'completion-auto-help' has the value 'lazy', then 80completion. Now, if 'completion-auto-help' has the value 'lazy', then
81Icomplete's in-buffer display of possible completions will only appear 81Icomplete's in-buffer display of possible completions will only appear
82after the 'completion-at-point' command has been invoked twice, and if 82after 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
85'completion-auto-help' is not customized to 'lazy' or nil. 85'completion-auto-help' is not customized to 'lazy' or nil.
86 86
87+++ 87+++
88** The *Completions* buffer now always accompanies 'icomplete-in-buffer'. 88** The "*Completions*" buffer now always accompanies 'icomplete-in-buffer'.
89Previously, it was not consistent when the *Completions* buffer would 89Previously, it was not consistent whether the "*Completions*" buffer would
90appear when using 'icomplete-in-buffer'. Now the *Completions* buffer 90appear when using 'icomplete-in-buffer'. Now the "*Completions*" buffer
91and Icomplete's in-buffer display of possible completions always 91and Icomplete's in-buffer display of possible completions always
92appear together. If you would prefer to see only Icomplete's 92appear together. If you would prefer to see only Icomplete's
93in-buffer display, and not the *Completions* buffer, you can add this 93in-buffer display, and not the "*Completions*" buffer, you can add this
94to your init: 94to your init:
95 95
96 (advice-add 'completion-at-point :after #'minibuffer-hide-completions) 96 (advice-add 'completion-at-point :after #'minibuffer-hide-completions)
@@ -130,6 +130,17 @@ the signature) the automatically inferred function type as well.
130This user option controls outline visibility in the output buffer of 130This user option controls outline visibility in the output buffer of
131'describe-bindings' when 'describe-bindings-outline' is non-nil. 131'describe-bindings' when 'describe-bindings-outline' is non-nil.
132 132
133---
134*** 'C-h m' ('describe-mode') uses outlining by default.
135Set 'describe-mode-outline' to nil to get back the old behavior.
136
137** Outline Mode
138
139+++
140*** 'outline-minor-mode' is supported in tree-sitter major modes.
141It can be used in all tree-sitter major modes that set either the
142variable 'treesit-simple-imenu-settings' or 'treesit-outline-predicate'.
143
133** X selection requests are now handled much faster and asynchronously. 144** X selection requests are now handled much faster and asynchronously.
134This means it should be less necessary to disable the likes of 145This means it should be less necessary to disable the likes of
135'select-active-regions' when Emacs is running over a slow network 146'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
258 269
259** Windows 270** Windows
260 271
261*** New action alist entry 'post-command-select-window' for display-buffer. 272*** New action alist entry 'post-command-select-window' for 'display-buffer'.
262It specifies whether the window of the displayed buffer should be 273It specifies whether the window of the displayed buffer should be
263selected or deselected at the end of executing the current command. 274selected or deselected at the end of executing the current command.
264 275
@@ -305,8 +316,17 @@ between the auto save file and the current file.
305 316
306--- 317---
307** 'ffap-lax-url' now defaults to nil. 318** 'ffap-lax-url' now defaults to nil.
308Previously, it was set to 'ffap-lax-url' to t but this broke remote file 319Previously, it was set to t but this broke remote file name detection.
309name detection. 320
321+++
322** Multi-character key echo now ends with a suggestion to use Help.
323Customize 'echo-keystrokes-help' to nil to prevent that.
324
325+++
326** 'read-passwd' can toggle the visibility of passwords.
327Use 'TAB' in the minibuffer to show or hide the password. Likewise,
328there is an icon on the mode-line, which toggles the visibility of the
329password when clicking with 'mouse-1'.
310 330
311 331
312* Editing Changes in Emacs 30.1 332* Editing Changes in Emacs 30.1
@@ -318,7 +338,9 @@ will receive a 'wrap-prefix' automatically computed from the line's
318surrounding context, such that continuation lines are indented on 338surrounding context, such that continuation lines are indented on
319display as if they were filled with 'M-q' or similar. Unlike 'M-q', 339display as if they were filled with 'M-q' or similar. Unlike 'M-q',
320the indentation only happens on display, and doesn't change the buffer 340the indentation only happens on display, and doesn't change the buffer
321text in any way. 341text in any way. The global minor mode
342'global-visual-wrap-prefix-mode' enables this minor mode in all
343buffers.
322 344
323(This minor mode is the 'adaptive-wrap' ELPA package renamed and 345(This minor mode is the 'adaptive-wrap' ELPA package renamed and
324lightly edited for inclusion in Emacs.) 346lightly edited for inclusion in Emacs.)
@@ -419,6 +441,11 @@ respectively, in addition to the existing translations 'C-x 8 / e' and
419* Changes in Specialized Modes and Packages in Emacs 30.1 441* Changes in Specialized Modes and Packages in Emacs 30.1
420 442
421--- 443---
444** Titdic-cnv
445Most of the variables and functions in the file have been renamed to
446make sure they all use a 'tit-' namespace prefix.
447
448---
422** Trace 449** Trace
423In batch mode, tracing now sends the trace to stdout. 450In batch mode, tracing now sends the trace to stdout.
424 451
@@ -431,7 +458,7 @@ configurations such as X11 when the X server does not support at least
431version 2.1 of the X Input Extension, and 'xterm-mouse-mode'. 458version 2.1 of the X Input Extension, and 'xterm-mouse-mode'.
432 459
433** 'xterm-mouse-mode' 460** 'xterm-mouse-mode'
434This mode now emits `wheel-up/down/right/left' events instead of 461This mode now emits 'wheel-up/down/right/left' events instead of
435'mouse-4/5/6/7' events for the mouse wheel. 462'mouse-4/5/6/7' events for the mouse wheel.
436It uses the 'mouse-wheel-up/down/left/right-event' 463It uses the 'mouse-wheel-up/down/left/right-event'
437variables to decide which button maps to which wheel event (if any). 464variables 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).
440 467
441--- 468---
442*** New user option 'Info-url-alist'. 469*** New user option 'Info-url-alist'.
443This user option associates manual-names with URLs. It affects the 470This user option associates manual names with URLs. It affects the
444'Info-goto-node-web' command. By default, associations for all 471'Info-goto-node-web' command. By default, associations for all
445Emacs-included manuals are set. Further associations can be added for 472Emacs-included manuals are set. Further associations can be added for
446arbitrary Info manuals. 473arbitrary Info manuals.
447 474
475*** Emacs can now display Info manuals compressed with 'lzip'.
476This requires the 'lzip' program to be installed on your system.
477
448+++ 478+++
449** New command 'lldb'. 479** New command 'lldb'.
450Run the LLDB debugger, analogous to the 'gud-gdb' command. 480Run the LLDB debugger, analogous to the 'gud-gdb' command.
@@ -572,6 +602,14 @@ It allows tweaking the thresholds for rename and copy detection.
572 602
573** Diff mode 603** Diff mode
574 604
605---
606*** New user option 'diff-refine-nonmodified'.
607When this is non-nil, 'diff-refine' will highlight lines that were added
608or removed in their entirety (as opposed to modified lines, where some
609parts of the line were modified), using the same faces as for
610highlighting the words added and removed within modified lines. The
611default value is nil.
612
575+++ 613+++
576*** 'diff-ignore-whitespace-hunk' can now be applied to all hunks. 614*** 'diff-ignore-whitespace-hunk' can now be applied to all hunks.
577When called with a non-nil prefix argument, 615When called with a non-nil prefix argument,
@@ -689,7 +727,7 @@ arguments of the form 'VAR=VALUE', 'env' will first set 'VAR' to
689Now, you can pass an argument like "u+w,o-r" to Eshell's 'umask' 727Now, you can pass an argument like "u+w,o-r" to Eshell's 'umask'
690command, which will give write permission for owners of newly-created 728command, which will give write permission for owners of newly-created
691files and deny read permission for users who are not members of the 729files and deny read permission for users who are not members of the
692file's group. See the Info node '(coreutils)File permissions' for 730file's group. See the Info node "(coreutils) File permissions" for
693more information on this notation. 731more information on this notation.
694 732
695+++ 733+++
@@ -808,14 +846,14 @@ in the minibuffer history, with more recent candidates appearing first.
808*** 'completion-category-overrides' supports more metadata. 846*** 'completion-category-overrides' supports more metadata.
809The new supported completion properties are 'cycle-sort-function', 847The new supported completion properties are 'cycle-sort-function',
810'display-sort-function', 'annotation-function', 'affixation-function', 848'display-sort-function', 'annotation-function', 'affixation-function',
811'group-function'. You can now customize them for any category in 849and 'group-function'. You can now customize them for any category in
812'completion-category-overrides' that will override the properties 850'completion-category-overrides' that will override the properties
813defined in completion metadata. 851defined in completion metadata.
814 852
815+++ 853+++
816*** 'completion-extra-properties' supports more metadata. 854*** 'completion-extra-properties' supports more metadata.
817The new supported completion properties are 'category', 855The new supported completion properties are 'category',
818'group-function', 'display-sort-function', 'cycle-sort-function'. 856'group-function', 'display-sort-function', and 'cycle-sort-function'.
819 857
820** Pcomplete 858** Pcomplete
821 859
@@ -865,6 +903,16 @@ mode line. 'header' will display in the header line;
865** Tramp 903** Tramp
866 904
867+++ 905+++
906*** New connection method "androidsu".
907This provides access to system files with elevated privileges granted by
908the idiosyncratic 'su' implementations and system utilities customary on
909Android.
910
911+++
912*** New connection methods "dockercp" and "podmancp".
913These are the external methods counterparts of "docker" and "podman".
914
915+++
868*** New connection methods "toolbox" and "flatpak". 916*** New connection methods "toolbox" and "flatpak".
869They allow accessing system containers provided by Toolbox or 917They allow accessing system containers provided by Toolbox or
870sandboxes provided by Flatpak. 918sandboxes provided by Flatpak.
@@ -1057,8 +1105,8 @@ which calls 'xref-find-definitions'. If the previous one worked
1057better for you, use 'define-key' in your init script to bind 1105better for you, use 'define-key' in your init script to bind
1058'js-find-symbol' to that combination again. 1106'js-find-symbol' to that combination again.
1059 1107
1060** Json mode 1108** Json mode.
1061`js-json-mode` does not derive from `js-mode` any more so as not 1109'js-json-mode' does not derive from 'js-mode' any more so as not
1062to confuse tools like Eglot or YASnippet into thinking that those 1110to confuse tools like Eglot or YASnippet into thinking that those
1063buffers contain Javascript code. 1111buffers contain Javascript code.
1064 1112
@@ -1097,6 +1145,12 @@ The gmane.org website is, sadly, down since a number of years with no
1097prospect of it coming back. Therefore, it is no longer valid to set 1145prospect of it coming back. Therefore, it is no longer valid to set
1098the user option 'nnweb-type' to 'gmane'. 1146the user option 'nnweb-type' to 'gmane'.
1099 1147
1148---
1149*** New user option 'gnus-mode-line-logo'.
1150This allows the user to either disable the display of any logo or
1151specify which logo will be displayed as part of the
1152buffer-identification in the mode-line of Gnus buffers.
1153
1100** Rmail 1154** Rmail
1101 1155
1102--- 1156---
@@ -1168,6 +1222,11 @@ Previously, the '@' character, which normally has 'symbol' syntax,
1168would combine with a following Lisp symbol and interfere with symbol 1222would combine with a following Lisp symbol and interfere with symbol
1169searching. 1223searching.
1170 1224
1225---
1226*** 'emacs-lisp-docstring-fill-column' now defaults to 72.
1227It was previously 65. The new default formats documentation strings to
1228fit on fewer lines without negatively impacting readability.
1229
1171** CPerl mode 1230** CPerl mode
1172 1231
1173--- 1232---
@@ -1188,8 +1247,8 @@ comment, like Perl mode does.
1188 1247
1189*** New command 'cperl-file-style'. 1248*** New command 'cperl-file-style'.
1190This command sets the indentation style for the current buffer. To 1249This command sets the indentation style for the current buffer. To
1191change the default style, either use the option with the same name or 1250change the default style, either use the user option with the same name
1192use the command cperl-set-style. 1251or use the command 'cperl-set-style'.
1193 1252
1194*** Commands using the Perl info page are obsolete. 1253*** Commands using the Perl info page are obsolete.
1195The Perl documentation in info format is no longer distributed with 1254The Perl documentation in info format is no longer distributed with
@@ -1297,21 +1356,51 @@ will return the URL for that bug.
1297This allows for rcirc logs to use a custom timestamp format, than the 1356This allows for rcirc logs to use a custom timestamp format, than the
1298chat buffers use by default. 1357chat buffers use by default.
1299 1358
1359---
1360*** New command 'Buffer-menu-toggle-internal'.
1361This command toggles the display of internal buffers in Buffer Menu mode;
1362that is, buffers not visiting a file and whose names start with a space.
1363Previously, such buffers were never shown. This command is bound to 'I'
1364in Buffer Menu mode.
1365
1300** Customize 1366** Customize
1301 1367
1302+++ 1368+++
1303*** New command 'customize-dirlocals'. 1369*** New command 'customize-dirlocals'.
1304This command pops up a buffer to edit the settings in ".dir-locals.el". 1370This command pops up a buffer to edit the settings in ".dir-locals.el".
1371
1372---
1373** New command 'customize-toggle-option'.
1374This command can toggle boolean options for the duration of a session.
1375
1305** Calc 1376** Calc
1377
1306+++ 1378+++
1307*** Calc parses fractions written using U+2044 FRACTION SLASH 1379*** Calc parses fractions written using U+2044 FRACTION SLASH.
1308Fractions of the form 123⁄456 are handled as if written 123:456. Note 1380Fractions of the form "123⁄456" are handled as if written "123:456".
1309in particular the difference in behavior from U+2215 DIVISION SLASH 1381Note in particular the difference in behavior from U+2215 DIVISION SLASH
1310and U+002F SOLIDUS, which result in division rather than a rational 1382and U+002F SOLIDUS, which result in division rather than a rational
1311fraction. You may also be interested to know that precomposed 1383fraction. You may also be interested to know that precomposed fraction
1312fraction characters, such as ½ (U+00BD VULGAR FRACTION ONE HALF), are 1384characters, such as ½ (U+00BD VULGAR FRACTION ONE HALF), are also
1313also recognized as rational fractions. They have been since 2004, but 1385recognized as rational fractions. They have been since 2004, but it
1314it looks like it was never mentioned in the NEWS, or even the manual. 1386looks like it was never mentioned in the NEWS, or even the manual.
1387
1388** IELM
1389
1390---
1391*** IELM now remembers input history between sessions.
1392The new user option 'ielm-history-file-name' is the name of the file
1393where IELM input history will be saved. Customize it to nil to revert
1394to the old behavior of not remembering input history between sessions.
1395
1396** EasyPG
1397
1398+++
1399*** New user option 'epa-keys-select-method'.
1400This allows the user to customize the key selection method, which can be
1401either by using a pop-up buffer or from the minibuffer. The pop-up
1402buffer method is the default, which preserves previous behavior.
1403
1315 1404
1316* New Modes and Packages in Emacs 30.1 1405* New Modes and Packages in Emacs 30.1
1317 1406
@@ -1367,13 +1456,30 @@ This minor mode generates the tags table automatically based on the
1367current project configuration, and later updates it as you edit the 1456current project configuration, and later updates it as you edit the
1368files and save the changes. 1457files and save the changes.
1369 1458
1459+++
1460** New package Compat.
1461Emacs now comes with a stub implementation of the
1462forwards-compatibility Compat package from GNU ELPA. This allows
1463built-in packages to use the library more effectively, and helps
1464preventing the installation of Compat if unnecessary.
1465
1370 1466
1371* Incompatible Lisp Changes in Emacs 30.1 1467* Incompatible Lisp Changes in Emacs 30.1
1372 1468
1469---
1470** Old derived.el functions removed.
1471The following functions have been deleted because they were only used
1472by code compiled with Emacs<21:
1473'derived-mode-init-mode-variables', 'derived-mode-merge-abbrev-tables',
1474'derived-mode-merge-keymaps', 'derived-mode-merge-syntax-tables',
1475'derived-mode-run-hooks', 'derived-mode-set-abbrev-table',
1476'derived-mode-set-keymap', 'derived-mode-set-syntax-table',
1477'derived-mode-setup-function-name'.
1478
1373+++ 1479+++
1374** 'M-TAB' now invokes 'completion-at-point' also in Text mode. 1480** 'M-TAB' now invokes 'completion-at-point' also in Text mode.
1375By default, Text mode no longer binds 'M-TAB' to 1481By default, Text mode no longer binds 'M-TAB' to
1376'ispell-complete-word'. Instead this mode arranges for 1482'ispell-complete-word'. Instead, this mode arranges for
1377'completion-at-point', globally bound to 'M-TAB', to perform word 1483'completion-at-point', globally bound to 'M-TAB', to perform word
1378completion as well. You can have Text mode bind 'M-TAB' to 1484completion as well. You can have Text mode bind 'M-TAB' to
1379'ispell-complete-word' as it did in previous Emacs versions, or 1485'ispell-complete-word' as it did in previous Emacs versions, or
@@ -1481,8 +1587,12 @@ values.
1481* Lisp Changes in Emacs 30.1 1587* Lisp Changes in Emacs 30.1
1482 1588
1483+++ 1589+++
1484** 'define-advice' now sets the new advice's 'name' property to NAME 1590** Pcase's functions (in 'pred' and 'app') can specify the argument position.
1485Named advice defined with 'define-advice' can now be removed with 1591For example, instead of '(pred (< 5))' you can write '(pred (> _ 5))'.
1592
1593+++
1594** 'define-advice' now sets the new advice's 'name' property to NAME.
1595Named advices defined with 'define-advice' can now be removed with
1486'(advice-remove SYMBOL NAME)' in addition to '(advice-remove SYMBOL 1596'(advice-remove SYMBOL NAME)' in addition to '(advice-remove SYMBOL
1487SYMBOL@NAME)'. 1597SYMBOL@NAME)'.
1488 1598
@@ -1499,10 +1609,10 @@ It puts a limit to the amount by which Emacs can temporarily increase
1499 1609
1500+++ 1610+++
1501** New special form 'handler-bind'. 1611** New special form 'handler-bind'.
1502Provides a functionality similar to `condition-case` except it runs the 1612It provides a functionality similar to 'condition-case' except it runs
1503handler code without unwinding the stack, such that we can record the 1613the handler code without unwinding the stack, such that we can record
1504backtrace and other dynamic state at the point of the error. 1614the backtrace and other dynamic state at the point of the error. See
1505See the Info node "(elisp) Handling Errors". 1615the Info node "(elisp) Handling Errors".
1506 1616
1507+++ 1617+++
1508** New 'pop-up-frames' action alist entry for 'display-buffer'. 1618** New 'pop-up-frames' action alist entry for 'display-buffer'.
@@ -1513,6 +1623,11 @@ precedence over the variable when present.
1513Mostly used internally to do a kind of topological sort of 1623Mostly used internally to do a kind of topological sort of
1514inheritance hierarchies. 1624inheritance hierarchies.
1515 1625
1626** New function 'sort-on'.
1627This function implements the Schwartzian transform, and is appropriate
1628for sorting lists when the computation of the sort key of a list
1629element can be expensive.
1630
1516** New API for 'derived-mode-p' and control of the graph of major modes. 1631** New API for 'derived-mode-p' and control of the graph of major modes.
1517 1632
1518*** 'derived-mode-p' now takes the list of modes as a single argument. 1633*** 'derived-mode-p' now takes the list of modes as a single argument.
@@ -1827,6 +1942,21 @@ The warning will only be issued for calls to functions declared
1827'important-return-value' or 'side-effect-free' (but not 'error-free'). 1942'important-return-value' or 'side-effect-free' (but not 'error-free').
1828 1943
1829--- 1944---
1945*** Warn about docstrings that contain control characters.
1946The compiler now warns about docstrings with control characters other
1947than newline and tab. This is often a result of improper escaping.
1948Example:
1949
1950 (defun my-fun ()
1951 "Uses c:\remote\dir\files and the key \C-x."
1952 ...)
1953
1954where the docstring contains four control characters 'CR', 'DEL', 'FF'
1955and 'C-x'.
1956
1957The warning name is 'docstrings-control-chars'.
1958
1959---
1830*** The warning about wide docstrings can now be disabled separately. 1960*** The warning about wide docstrings can now be disabled separately.
1831Its warning name is 'docstrings-wide'. 1961Its warning name is 'docstrings-wide'.
1832 1962
@@ -1836,6 +1966,13 @@ The declaration '(important-return-value t)' sets the
1836'important-return-value' property which indicates that the function 1966'important-return-value' property which indicates that the function
1837return value should probably not be thrown away implicitly. 1967return value should probably not be thrown away implicitly.
1838 1968
1969** Bytecode is now always loaded eagerly.
1970Bytecode compiled with older Emacs versions for lazy loading using
1971'byte-compile-dynamic' is now loaded all at once.
1972As a consequence, 'fetch-bytecode' has no use, does nothing, and is
1973now obsolete. The variable 'byte-compile-dynamic' has no effect any
1974more; compilation will always yield bytecode for eager loading.
1975
1839+++ 1976+++
1840** New functions 'file-user-uid' and 'file-group-gid'. 1977** New functions 'file-user-uid' and 'file-group-gid'.
1841These functions are like 'user-uid' and 'group-gid', respectively, but 1978These 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
1891'data' if empty. 'rehash-size', 'rehash-threshold' and 'size' are 2028'data' if empty. 'rehash-size', 'rehash-threshold' and 'size' are
1892always omitted, and ignored if present when the object is read back in. 2029always omitted, and ignored if present when the object is read back in.
1893 2030
2031** Obarrays
2032
2033+++
2034*** New obarray type.
2035Obarrays are now represented by an opaque type instead of using vectors.
2036They are created by 'obarray-make' and manage their internal storage
2037automatically, which means that the size parameter to 'obarray-make' can
2038safely be omitted. That is, they do not become slower as they fill up.
2039
2040The old vector representation is still accepted by functions operating
2041on obarrays, but 'obarrayp' only returns t for obarray objects.
2042'type-of' now returns 'obarray' for obarray objects.
2043
2044Old code which (incorrectly) created "obarrays" as Lisp vectors filled
2045with something other than 0, as in '(make-vector N nil)', will no longer
2046work, and should be rewritten to use 'obarray-make'. Alternatively, you
2047can fill the vector with 0.
2048
2049+++
2050*** New function 'obarray-clear' removes all symbols from an obarray.
2051
2052---
2053*** 'obarray-size' and 'obarray-default-size' are now obsolete.
2054They pertained to the internal storage size which is now irrelevant.
2055
1894+++ 2056+++
1895** 'treesit-install-language-grammar' can handle local directory instead of URL. 2057** 'treesit-install-language-grammar' can handle local directory instead of URL.
1896It is now possible to pass a directory of a local repository as URL 2058It 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.
1158 1158
1159* New Modes and Packages in Emacs 25.1 1159* New Modes and Packages in Emacs 25.1
1160 1160
1161** New preloaded package 'obarray'
1162
1163Provides obarray operations under the 'obarray-' prefix, such as
1164'obarray-make', 'obarrayp', and 'obarray-map'.
1165
1161** pinentry.el allows GnuPG passphrase to be prompted through the 1166** pinentry.el allows GnuPG passphrase to be prompted through the
1162minibuffer instead of a graphical dialog, depending on whether the gpg 1167minibuffer instead of a graphical dialog, depending on whether the gpg
1163command is called from Emacs (i.e., INSIDE_EMACS environment variable 1168command 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.
432Alternatively, if you set the option 'load-prefer-newer' non-nil, 432Alternatively, if you set the option 'load-prefer-newer' non-nil,
433Emacs will load whichever version of a file is the newest. 433Emacs will load whichever version of a file is the newest.
434 434
435*** Watch out for the EMACSLOADPATH environment variable 435*** Watch out for the EMACSLOADPATH environment variable.
436 436
437EMACSLOADPATH overrides which directories the function "load" will search. 437EMACSLOADPATH overrides which directories the function "load" will search.
438 438
@@ -441,7 +441,7 @@ environment.
441 441
442** Keyboard problems 442** Keyboard problems
443 443
444*** PGTK build of Emacs running on Wayland doesn't recognize Hyper modifier 444*** PGTK build of Emacs running on Wayland doesn't recognize Hyper modifier.
445 445
446If you arrange for the Wayland compositor to send the Hyper key 446If you arrange for the Wayland compositor to send the Hyper key
447modifier (e.g., via XKB customizations), the Hyper modifier will still 447modifier (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
452never be solved. And the Emacs PGTK build cannot yet support GTK4, 452never be solved. And the Emacs PGTK build cannot yet support GTK4,
453where this problem is reportedly solved. 453where this problem is reportedly solved.
454 454
455*** Emacs built with GTK lags in its response to keyboard input.
456This can happen when input methods are used. It happens because Emacs
457behaves in an unconventional way with respect to GTK input methods: it
458registers to receive keyboard input as unprocessed key events with
459metadata (as opposed to receiving them as text strings). Most GTK
460programs use the latter approach, so some modern input methods have
461bugs and misbehave when faced with the way Emacs does it.
462
463A workaround is to set GTK_IM_MODULE=none in the environment, or maybe
464find a different input method without these problems.
465
455*** Unable to enter the M-| key on some German keyboards. 466*** Unable to enter the M-| key on some German keyboards.
456Some users have reported that M-| suffers from "keyboard ghosting". 467Some users have reported that M-| suffers from "keyboard ghosting".
457This can't be fixed by Emacs, as the keypress never gets passed to it 468This 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
476though the system itself is capable of it. Either use a different shell, 487though the system itself is capable of it. Either use a different shell,
477or set the variable 'cannot-suspend' to a non-nil value. 488or set the variable 'cannot-suspend' to a non-nil value.
478 489
490*** Emacs running on WSL receives stray characters as input.
491
492For example, you could see Emacs inserting 'z' characters even though
493nothing is typed on the keyboard, and even if you unplug the keyboard.
494
495The reason is a bug in the WSL X server's handling of key-press and
496key-repeat events. A workaround is to use the Cygwin or native
497MS-Windows build of Emacs instead.
498
499*** On MS-Windows, the Windows key gets "stuck".
500When this problem happens, Windows behaves as if the Windows key were
501permanently pressed down. This could be a side effect of Emacs on
502MS-Windows hooking keyboard input on a low level, in order to support
503registering the Windows keys as hot keys. If that hook takes too much
504time for some reason, Windows can decide to remove the hook, which
505then has this effect.
506
507This is arguably a bug in Emacs, for which we don't yet have a
508solution. To work around, set the 'LowLevelHooksTimeout' value in the
509registry key "HKEY_CURRENT_USER\Control Panel\Desktop" to a number
510higher than 200 msec; the maximum allowed value is 1000 msec (create
511the value if it doesn't exist under that key).
512
479** Mailers and other helper programs 513** Mailers and other helper programs
480 514
481*** movemail compiled with POP support can't connect to the POP server. 515*** 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
545program like 'pinentry-gnome' or 'pinentry-qt5'. Alternatively, you 579program like 'pinentry-gnome' or 'pinentry-qt5'. Alternatively, you
546can use the 'pinentry' package from Emacs 25. 580can use the 'pinentry' package from Emacs 25.
547 581
548*** Emacs running on WSL receives stray characters as input.
549
550For example, you could see Emacs inserting 'z' characters even though
551nothing is typed on the keyboard, and even if you unplug the keyboard.
552
553The reason is a bug in the WSL X server's handling of key-press and
554key-repeat events. A workaround is to use the Cygwin or native
555MS-Windows build of Emacs instead.
556
557** Problems with hostname resolution 582** Problems with hostname resolution
558 583
559*** Emacs does not know your host's fully-qualified domain name. 584*** 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:
56 "PVEC_BOOL_VECTOR": "struct Lisp_Bool_Vector", 56 "PVEC_BOOL_VECTOR": "struct Lisp_Bool_Vector",
57 "PVEC_BUFFER": "struct buffer", 57 "PVEC_BUFFER": "struct buffer",
58 "PVEC_HASH_TABLE": "struct Lisp_Hash_Table", 58 "PVEC_HASH_TABLE": "struct Lisp_Hash_Table",
59 "PVEC_OBARRAY": "struct Lisp_Obarray",
59 "PVEC_TERMINAL": "struct terminal", 60 "PVEC_TERMINAL": "struct terminal",
60 "PVEC_WINDOW_CONFIGURATION": "struct save_window_data", 61 "PVEC_WINDOW_CONFIGURATION": "struct save_window_data",
61 "PVEC_SUBR": "struct Lisp_Subr", 62 "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:
125 125
126 https://gitlab.gnome.org/GNOME/adwaita-icon-theme 126 https://gitlab.gnome.org/GNOME/adwaita-icon-theme
127 127
128Emacs images and their source in the Adwaita/scalable directory: 128Emacs images and their source in the Adwaita/symbolic directory:
129 129
130 checked.svg ui/checkbox-checked-symbolic.svg 130 checked.svg ui/checkbox-checked-symbolic.svg
131 unchecked.svg ui/checkbox-symbolic.svg 131 unchecked.svg ui/checkbox-symbolic.svg
@@ -137,3 +137,8 @@ Emacs images and their source in the Adwaita/scalable directory:
137 left.svg ui/pan-start-symbolic.svg 137 left.svg ui/pan-start-symbolic.svg
138 right.svg ui/pan-end-symbolic.svg 138 right.svg ui/pan-end-symbolic.svg
139 up.svg ui/pan-up-symbolic.svg 139 up.svg ui/pan-up-symbolic.svg
140 conceal.svg actions/view-conceal-symbolic.svg
141 reveal.svg actions/view-reveal-symbolic.svg
142
143conceal.pbm and reveal.pbm are generated from the respective *.svg
144files, using the ImageMagick converter tool.
diff --git a/etc/images/conceal.pbm b/etc/images/conceal.pbm
new file mode 100644
index 00000000000..3df787d6fd6
--- /dev/null
+++ b/etc/images/conceal.pbm
Binary files 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 @@
1<?xml version="1.0" encoding="UTF-8"?>
2<svg height="16px" viewBox="0 0 16 16" width="16px" xmlns="http://www.w3.org/2000/svg">
3 <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 c -0.265625 0.003906 -0.527344 0.0625 -0.769531 0.167969 l -1.46875 -1.46875 c 0.660156 -0.453125 1.4375 -0.695313 2.238281 -0.699219 z m -6.144531 0.917969 c -0.753907 0.898437 -1.296875 1.957031 -1.59375 3.09375 c 0.914062 3.523437 4.097656 5.984375 7.738281 5.988281 c 0.855469 -0.007812 1.703125 -0.152344 2.511719 -0.425781 l -1.667969 -1.667969 c -0.277344 0.058594 -0.5625 0.089844 -0.84375 0.09375 c -2.210938 0 -4 -1.789062 -4 -4 c 0.003906 -0.28125 0.035156 -0.566406 0.09375 -0.84375 z m 0 0" fill="#2e3436"/>
4</svg>
diff --git a/etc/images/reveal.pbm b/etc/images/reveal.pbm
new file mode 100644
index 00000000000..79d2f1f3307
--- /dev/null
+++ b/etc/images/reveal.pbm
Binary files 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 @@
1<?xml version="1.0" encoding="UTF-8"?>
2<svg height="16px" viewBox="0 0 16 16" width="16px" xmlns="http://www.w3.org/2000/svg">
3 <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"/>
4</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
104 exit 1 104 exit 1
105fi 105fi
106 106
107if [ -z $device ]; then 107if [ `wc -w <<< "$devices"` -gt 1 ] && [ -z $device ]; then
108 device=$devices 108 echo "Multiple devices are available. Please specify one with"
109 echo "the option --device and try again."
110 exit 1
109fi 111fi
110 112
111if [ `wc -w <<< "$devices"` -gt 1 ] && [ -z device ]; then 113if [ -z $device ]; then
112 echo "Multiple devices are available. Please pick one using" 114 device=$devices
113 echo "--device and try again."
114fi 115fi
115 116
116echo "Looking for $package on device $device" 117echo "Looking for $package on device $device"
@@ -189,6 +190,8 @@ if [ "$attach_existing" != "yes" ]; then
189 package_pids=`awk -f tmp.awk <<< $package_pids` 190 package_pids=`awk -f tmp.awk <<< $package_pids`
190fi 191fi
191 192
193rm tmp.awk
194
192pid=$package_pids 195pid=$package_pids
193num_pids=`wc -w <<< "$package_pids"` 196num_pids=`wc -w <<< "$package_pids"`
194 197
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
97 } 97 }
98 98
99 public static void 99 public static void
100 invalidateFocus () 100 invalidateFocus (int whence)
101 { 101 {
102 EmacsWindow oldFocus; 102 EmacsWindow oldFocus;
103 103
@@ -144,7 +144,7 @@ public class EmacsActivity extends Activity
144 layout.removeView (window.view); 144 layout.removeView (window.view);
145 window = null; 145 window = null;
146 146
147 invalidateFocus (); 147 invalidateFocus (0);
148 } 148 }
149 } 149 }
150 150
@@ -172,8 +172,17 @@ public class EmacsActivity extends Activity
172 if (isPaused) 172 if (isPaused)
173 window.noticeIconified (); 173 window.noticeIconified ();
174 174
175 /* Invalidate the focus. */ 175 /* Invalidate the focus. Since attachWindow may be called from
176 invalidateFocus (); 176 either the main or the UI thread, post this to the UI thread. */
177
178 runOnUiThread (new Runnable () {
179 @Override
180 public void
181 run ()
182 {
183 invalidateFocus (1);
184 }
185 });
177 } 186 }
178 187
179 @Override 188 @Override
@@ -238,6 +247,10 @@ public class EmacsActivity extends Activity
238 } 247 }
239 248
240 super.onCreate (savedInstanceState); 249 super.onCreate (savedInstanceState);
250
251 /* Call `onWindowFocusChanged' to read the focus state, which fails
252 to be called after an activity is recreated. */
253 onWindowFocusChanged (false);
241 } 254 }
242 255
243 @Override 256 @Override
@@ -261,7 +274,7 @@ public class EmacsActivity extends Activity
261 isMultitask = this instanceof EmacsMultitaskActivity; 274 isMultitask = this instanceof EmacsMultitaskActivity;
262 manager.removeWindowConsumer (this, isMultitask || isFinishing ()); 275 manager.removeWindowConsumer (this, isMultitask || isFinishing ());
263 focusedActivities.remove (this); 276 focusedActivities.remove (this);
264 invalidateFocus (); 277 invalidateFocus (2);
265 278
266 /* Remove this activity from the static field, lest it leak. */ 279 /* Remove this activity from the static field, lest it leak. */
267 if (lastFocusedActivity == this) 280 if (lastFocusedActivity == this)
@@ -274,9 +287,16 @@ public class EmacsActivity extends Activity
274 public final void 287 public final void
275 onWindowFocusChanged (boolean isFocused) 288 onWindowFocusChanged (boolean isFocused)
276 { 289 {
277 if (isFocused && !focusedActivities.contains (this)) 290 /* At times and on certain versions of Android ISFOCUSED does not
291 reflect whether the window actually holds focus, so replace it
292 with the value of `hasWindowFocus'. */
293 isFocused = hasWindowFocus ();
294
295 if (isFocused)
278 { 296 {
279 focusedActivities.add (this); 297 if (!focusedActivities.contains (this))
298 focusedActivities.add (this);
299
280 lastFocusedActivity = this; 300 lastFocusedActivity = this;
281 301
282 /* Update the window insets as the focus change may have 302 /* Update the window insets as the focus change may have
@@ -291,7 +311,7 @@ public class EmacsActivity extends Activity
291 else 311 else
292 focusedActivities.remove (this); 312 focusedActivities.remove (this);
293 313
294 invalidateFocus (); 314 invalidateFocus (3);
295 } 315 }
296 316
297 @Override 317 @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
361 public Boolean 361 public Boolean
362 call () 362 call ()
363 { 363 {
364 boolean rc;
365
364 lastMenuEventSerial = serial; 366 lastMenuEventSerial = serial;
365 return display1 (window, xPosition, yPosition); 367 rc = display1 (window, xPosition, yPosition);
368
369 /* Android 3.0 to Android 7.0 perform duplicate calls to
370 onContextMenuClosed the second time a context menu is
371 dismissed. Since the second call after such a dismissal is
372 otherwise liable to prematurely cancel any context menu
373 displayed immediately afterwards, ignore calls received
374 within 150 milliseconds of this menu's being displayed. */
375
376 if (rc && Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB
377 && Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
378 wasSubmenuSelected = System.currentTimeMillis () - 150;
379
380 return rc;
366 } 381 }
367 }); 382 });
368 383
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;
60import android.content.pm.PackageManager; 60import android.content.pm.PackageManager;
61 61
62import android.content.res.AssetManager; 62import android.content.res.AssetManager;
63import android.content.res.Configuration;
63 64
64import android.hardware.input.InputManager; 65import android.hardware.input.InputManager;
65 66
@@ -135,6 +136,10 @@ public final class EmacsService extends Service
135 been created yet. */ 136 been created yet. */
136 private EmacsSafThread storageThread; 137 private EmacsSafThread storageThread;
137 138
139 /* The Thread object representing the Android user interface
140 thread. */
141 private Thread mainThread;
142
138 static 143 static
139 { 144 {
140 servicingQuery = new AtomicInteger (); 145 servicingQuery = new AtomicInteger ();
@@ -235,6 +240,7 @@ public final class EmacsService extends Service
235 / metrics.density) 240 / metrics.density)
236 * pixelDensityX); 241 * pixelDensityX);
237 resolver = getContentResolver (); 242 resolver = getContentResolver ();
243 mainThread = Thread.currentThread ();
238 244
239 /* If the density used to compute the text size is lesser than 245 /* If the density used to compute the text size is lesser than
240 160, there's likely a bug with display density computation. 246 160, there's likely a bug with display density computation.
@@ -383,7 +389,13 @@ public final class EmacsService extends Service
383 { 389 {
384 if (DEBUG_THREADS) 390 if (DEBUG_THREADS)
385 { 391 {
386 if (Thread.currentThread () instanceof EmacsThread) 392 /* When SERVICE is NULL, Emacs is being executed non-interactively. */
393 if (SERVICE == null
394 /* It was previously assumed that only instances of
395 `EmacsThread' were valid for graphics calls, but this is
396 no longer true now that Lisp threads can be attached to
397 the JVM. */
398 || (Thread.currentThread () != SERVICE.mainThread))
387 return; 399 return;
388 400
389 throw new RuntimeException ("Emacs thread function" 401 throw new RuntimeException ("Emacs thread function"
@@ -437,21 +449,6 @@ public final class EmacsService extends Service
437 EmacsDrawPoint.perform (drawable, gc, x, y); 449 EmacsDrawPoint.perform (drawable, gc, x, y);
438 } 450 }
439 451
440 public void
441 clearWindow (EmacsWindow window)
442 {
443 checkEmacsThread ();
444 window.clearWindow ();
445 }
446
447 public void
448 clearArea (EmacsWindow window, int x, int y, int width,
449 int height)
450 {
451 checkEmacsThread ();
452 window.clearArea (x, y, width, height);
453 }
454
455 @SuppressWarnings ("deprecation") 452 @SuppressWarnings ("deprecation")
456 public void 453 public void
457 ringBell (int duration) 454 ringBell (int duration)
@@ -581,6 +578,15 @@ public final class EmacsService extends Service
581 return false; 578 return false;
582 } 579 }
583 580
581 public boolean
582 detectKeyboard ()
583 {
584 Configuration configuration;
585
586 configuration = getResources ().getConfiguration ();
587 return configuration.keyboard != Configuration.KEYBOARD_NOKEYS;
588 }
589
584 public String 590 public String
585 nameKeysym (int keysym) 591 nameKeysym (int keysym)
586 { 592 {
@@ -905,48 +911,6 @@ public final class EmacsService extends Service
905 911
906 /* Content provider functions. */ 912 /* Content provider functions. */
907 913
908 /* Return a ContentResolver capable of accessing as many files as
909 possible, namely the content resolver of the last selected
910 activity if available: only they posses the rights to access drag
911 and drop files. */
912
913 public ContentResolver
914 getUsefulContentResolver ()
915 {
916 EmacsActivity activity;
917
918 if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
919 /* Since the system predates drag and drop, return this resolver
920 to avoid any unforeseen difficulties. */
921 return resolver;
922
923 activity = EmacsActivity.lastFocusedActivity;
924 if (activity == null)
925 return resolver;
926
927 return activity.getContentResolver ();
928 }
929
930 /* Return a context whose ContentResolver is granted access to most
931 files, as in `getUsefulContentResolver'. */
932
933 public Context
934 getContentResolverContext ()
935 {
936 EmacsActivity activity;
937
938 if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
939 /* Since the system predates drag and drop, return this resolver
940 to avoid any unforeseen difficulties. */
941 return this;
942
943 activity = EmacsActivity.lastFocusedActivity;
944 if (activity == null)
945 return this;
946
947 return activity;
948 }
949
950 /* Open a content URI described by the bytes BYTES, a non-terminated 914 /* Open a content URI described by the bytes BYTES, a non-terminated
951 string; make it writable if WRITABLE, and readable if READABLE. 915 string; make it writable if WRITABLE, and readable if READABLE.
952 Truncate the file if TRUNCATE. 916 Truncate the file if TRUNCATE.
@@ -960,9 +924,6 @@ public final class EmacsService extends Service
960 String name, mode; 924 String name, mode;
961 ParcelFileDescriptor fd; 925 ParcelFileDescriptor fd;
962 int i; 926 int i;
963 ContentResolver resolver;
964
965 resolver = getUsefulContentResolver ();
966 927
967 /* Figure out the file access mode. */ 928 /* Figure out the file access mode. */
968 929
@@ -1024,12 +985,8 @@ public final class EmacsService extends Service
1024 ParcelFileDescriptor fd; 985 ParcelFileDescriptor fd;
1025 Uri uri; 986 Uri uri;
1026 int rc, flags; 987 int rc, flags;
1027 Context context;
1028 ContentResolver resolver;
1029 ParcelFileDescriptor descriptor; 988 ParcelFileDescriptor descriptor;
1030 989
1031 context = getContentResolverContext ();
1032
1033 uri = Uri.parse (name); 990 uri = Uri.parse (name);
1034 flags = 0; 991 flags = 0;
1035 992
@@ -1039,7 +996,7 @@ public final class EmacsService extends Service
1039 if (writable) 996 if (writable)
1040 flags |= Intent.FLAG_GRANT_WRITE_URI_PERMISSION; 997 flags |= Intent.FLAG_GRANT_WRITE_URI_PERMISSION;
1041 998
1042 rc = context.checkCallingUriPermission (uri, flags); 999 rc = checkCallingUriPermission (uri, flags);
1043 1000
1044 if (rc == PackageManager.PERMISSION_GRANTED) 1001 if (rc == PackageManager.PERMISSION_GRANTED)
1045 return true; 1002 return true;
@@ -1053,7 +1010,6 @@ public final class EmacsService extends Service
1053 1010
1054 try 1011 try
1055 { 1012 {
1056 resolver = context.getContentResolver ();
1057 descriptor = resolver.openFileDescriptor (uri, "r"); 1013 descriptor = resolver.openFileDescriptor (uri, "r");
1058 return true; 1014 return true;
1059 } 1015 }
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;
27import java.util.LinkedHashMap; 27import java.util.LinkedHashMap;
28import java.util.Map; 28import java.util.Map;
29 29
30import android.app.Activity;
31
30import android.content.ClipData; 32import android.content.ClipData;
31import android.content.ClipDescription; 33import android.content.ClipDescription;
32import android.content.Context; 34import android.content.Context;
@@ -240,7 +242,7 @@ public final class EmacsWindow extends EmacsHandleObject
240 } 242 }
241 } 243 }
242 244
243 EmacsActivity.invalidateFocus (); 245 EmacsActivity.invalidateFocus (4);
244 246
245 if (!children.isEmpty ()) 247 if (!children.isEmpty ())
246 throw new IllegalStateException ("Trying to destroy window with " 248 throw new IllegalStateException ("Trying to destroy window with "
@@ -362,6 +364,9 @@ public final class EmacsWindow extends EmacsHandleObject
362 requestViewLayout (); 364 requestViewLayout ();
363 } 365 }
364 366
367 /* Return WM layout parameters for an override redirect window with
368 the geometry provided here. */
369
365 private WindowManager.LayoutParams 370 private WindowManager.LayoutParams
366 getWindowLayoutParams () 371 getWindowLayoutParams ()
367 { 372 {
@@ -384,15 +389,15 @@ public final class EmacsWindow extends EmacsHandleObject
384 return params; 389 return params;
385 } 390 }
386 391
387 private Context 392 private Activity
388 findSuitableActivityContext () 393 findSuitableActivityContext ()
389 { 394 {
390 /* Find a recently focused activity. */ 395 /* Find a recently focused activity. */
391 if (!EmacsActivity.focusedActivities.isEmpty ()) 396 if (!EmacsActivity.focusedActivities.isEmpty ())
392 return EmacsActivity.focusedActivities.get (0); 397 return EmacsActivity.focusedActivities.get (0);
393 398
394 /* Return the service context, which probably won't work. */ 399 /* Resort to the last activity to be focused. */
395 return EmacsService.SERVICE; 400 return EmacsActivity.lastFocusedActivity;
396 } 401 }
397 402
398 public synchronized void 403 public synchronized void
@@ -416,7 +421,7 @@ public final class EmacsWindow extends EmacsHandleObject
416 { 421 {
417 EmacsWindowAttachmentManager manager; 422 EmacsWindowAttachmentManager manager;
418 WindowManager windowManager; 423 WindowManager windowManager;
419 Context ctx; 424 Activity ctx;
420 Object tem; 425 Object tem;
421 WindowManager.LayoutParams params; 426 WindowManager.LayoutParams params;
422 427
@@ -447,11 +452,23 @@ public final class EmacsWindow extends EmacsHandleObject
447 activity using the system window manager. */ 452 activity using the system window manager. */
448 453
449 ctx = findSuitableActivityContext (); 454 ctx = findSuitableActivityContext ();
455
456 if (ctx == null)
457 {
458 Log.w (TAG, "failed to attach override-redirect window"
459 + " for want of activity");
460 return;
461 }
462
450 tem = ctx.getSystemService (Context.WINDOW_SERVICE); 463 tem = ctx.getSystemService (Context.WINDOW_SERVICE);
451 windowManager = (WindowManager) tem; 464 windowManager = (WindowManager) tem;
452 465
453 /* Calculate layout parameters. */ 466 /* Calculate layout parameters and propagate the
467 activity's token into it. */
468
454 params = getWindowLayoutParams (); 469 params = getWindowLayoutParams ();
470 params.token = (ctx.findViewById (android.R.id.content)
471 .getWindowToken ());
455 view.setLayoutParams (params); 472 view.setLayoutParams (params);
456 473
457 /* Attach the view. */ 474 /* Attach the view. */
@@ -644,7 +661,7 @@ public final class EmacsWindow extends EmacsHandleObject
644 public void 661 public void
645 onKeyDown (int keyCode, KeyEvent event) 662 onKeyDown (int keyCode, KeyEvent event)
646 { 663 {
647 int state, state_1, num_lock_flag; 664 int state, state_1, extra_ignored;
648 long serial; 665 long serial;
649 String characters; 666 String characters;
650 667
@@ -665,23 +682,37 @@ public final class EmacsWindow extends EmacsHandleObject
665 682
666 state = eventModifiers (event); 683 state = eventModifiers (event);
667 684
668 /* Num Lock and Scroll Lock aren't supported by systems older than 685 /* Num Lock, Scroll Lock and Meta aren't supported by systems older
669 Android 3.0. */ 686 than Android 3.0. */
670 687
671 if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) 688 if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
672 num_lock_flag = (KeyEvent.META_NUM_LOCK_ON 689 extra_ignored = (KeyEvent.META_NUM_LOCK_ON
673 | KeyEvent.META_SCROLL_LOCK_ON); 690 | KeyEvent.META_SCROLL_LOCK_ON
691 | KeyEvent.META_META_MASK);
674 else 692 else
675 num_lock_flag = 0; 693 extra_ignored = 0;
676 694
677 /* Ignore meta-state understood by Emacs for now, or key presses 695 /* Ignore meta-state understood by Emacs for now, or key presses
678 such as Ctrl+C and Meta+C will not be recognized as an ASCII 696 such as Ctrl+C and Meta+C will not be recognized as ASCII key
679 key press event. */ 697 press events. */
680 698
681 state_1 699 state_1
682 = state & ~(KeyEvent.META_ALT_MASK | KeyEvent.META_CTRL_MASK 700 = state & ~(KeyEvent.META_ALT_MASK | KeyEvent.META_CTRL_MASK
683 | KeyEvent.META_SYM_ON | KeyEvent.META_META_MASK 701 | KeyEvent.META_SYM_ON | extra_ignored);
684 | num_lock_flag); 702
703 /* There's no distinction between Right Alt and Alt Gr on Android,
704 so restore META_ALT_RIGHT_ON if set in state to enable composing
705 characters. (bug#69321) */
706
707 if ((state & KeyEvent.META_ALT_RIGHT_ON) != 0)
708 {
709 state_1 |= KeyEvent.META_ALT_ON | KeyEvent.META_ALT_RIGHT_ON;
710
711 /* If Alt is also not depressed, remove its bit from the mask
712 reported to Emacs. */
713 if ((state & KeyEvent.META_ALT_LEFT_ON) == 0)
714 state &= ~KeyEvent.META_ALT_MASK;
715 }
685 716
686 synchronized (eventStrings) 717 synchronized (eventStrings)
687 { 718 {
@@ -702,29 +733,43 @@ public final class EmacsWindow extends EmacsHandleObject
702 public void 733 public void
703 onKeyUp (int keyCode, KeyEvent event) 734 onKeyUp (int keyCode, KeyEvent event)
704 { 735 {
705 int state, state_1, unicode_char, num_lock_flag; 736 int state, state_1, unicode_char, extra_ignored;
706 long time; 737 long time;
707 738
708 /* Compute the event's modifier mask. */ 739 /* Compute the event's modifier mask. */
709 state = eventModifiers (event); 740 state = eventModifiers (event);
710 741
711 /* Num Lock and Scroll Lock aren't supported by systems older than 742 /* Num Lock, Scroll Lock and Meta aren't supported by systems older
712 Android 3.0. */ 743 than Android 3.0. */
713 744
714 if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) 745 if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
715 num_lock_flag = (KeyEvent.META_NUM_LOCK_ON 746 extra_ignored = (KeyEvent.META_NUM_LOCK_ON
716 | KeyEvent.META_SCROLL_LOCK_ON); 747 | KeyEvent.META_SCROLL_LOCK_ON
748 | KeyEvent.META_META_MASK);
717 else 749 else
718 num_lock_flag = 0; 750 extra_ignored = 0;
719 751
720 /* Ignore meta-state understood by Emacs for now, or key presses 752 /* Ignore meta-state understood by Emacs for now, or key presses
721 such as Ctrl+C and Meta+C will not be recognized as an ASCII 753 such as Ctrl+C and Meta+C will not be recognized as ASCII key
722 key press event. */ 754 press events. */
723 755
724 state_1 756 state_1
725 = state & ~(KeyEvent.META_ALT_MASK | KeyEvent.META_CTRL_MASK 757 = state & ~(KeyEvent.META_ALT_MASK | KeyEvent.META_CTRL_MASK
726 | KeyEvent.META_SYM_ON | KeyEvent.META_META_MASK 758 | KeyEvent.META_SYM_ON | extra_ignored);
727 | num_lock_flag); 759
760 /* There's no distinction between Right Alt and Alt Gr on Android,
761 so restore META_ALT_RIGHT_ON if set in state to enable composing
762 characters. */
763
764 if ((state & KeyEvent.META_ALT_RIGHT_ON) != 0)
765 {
766 state_1 |= KeyEvent.META_ALT_ON | KeyEvent.META_ALT_RIGHT_ON;
767
768 /* If Alt is also not depressed, remove its bit from the mask
769 reported to Emacs. */
770 if ((state & KeyEvent.META_ALT_LEFT_ON) == 0)
771 state &= ~KeyEvent.META_ALT_MASK;
772 }
728 773
729 unicode_char = getEventUnicodeChar (event, state_1); 774 unicode_char = getEventUnicodeChar (event, state_1);
730 775
@@ -760,7 +805,7 @@ public final class EmacsWindow extends EmacsHandleObject
760 public void 805 public void
761 onFocusChanged (boolean gainFocus) 806 onFocusChanged (boolean gainFocus)
762 { 807 {
763 EmacsActivity.invalidateFocus (); 808 EmacsActivity.invalidateFocus (gainFocus ? 6 : 5);
764 } 809 }
765 810
766 /* Notice that the activity has been detached or destroyed. 811 /* Notice that the activity has been detached or destroyed.
@@ -1746,7 +1791,7 @@ public final class EmacsWindow extends EmacsHandleObject
1746 1791
1747 /* Attempt to acquire permissions for this URI; 1792 /* Attempt to acquire permissions for this URI;
1748 failing which, insert it as text instead. */ 1793 failing which, insert it as text instead. */
1749 1794
1750 if (uri != null 1795 if (uri != null
1751 && uri.getScheme () != null 1796 && uri.getScheme () != null
1752 && uri.getScheme ().equals ("content") 1797 && 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:
101## All of TIT_GB and TIT_BIG5. 101## All of TIT_GB and TIT_BIG5.
102${leimdir}/quail/%.el: ${srcdir}/CXTERM-DIC/%.tit 102${leimdir}/quail/%.el: ${srcdir}/CXTERM-DIC/%.tit
103 $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv \ 103 $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv \
104 -f batch-titdic-convert -dir ${leimdir}/quail $< 104 -f batch-tit-dic-convert -dir ${leimdir}/quail $<
105 105
106 106
107misc_convert = $(AM_V_GEN)${RUN_EMACS} \ 107misc_convert = $(AM_V_GEN)${RUN_EMACS} \
108 -l titdic-cnv -f batch-miscdic-convert -dir ${leimdir}/quail 108 -l titdic-cnv -f batch-tit-miscdic-convert -dir ${leimdir}/quail
109 109
110## CTLau.el, CTLau-b5.el. 110## CTLau.el, CTLau-b5.el.
111${leimdir}/quail/CT%.el: ${srcdir}/MISC-DIC/CT%.html 111${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
148 -f batch-skkdic-convert -dir "$(leimdir)/ja-dic" $(JA_DIC_NO_REDUCTION_OPTION) "$<" 148 -f batch-skkdic-convert -dir "$(leimdir)/ja-dic" $(JA_DIC_NO_REDUCTION_OPTION) "$<"
149 149
150${srcdir}/../lisp/language/pinyin.el: ${srcdir}/MISC-DIC/pinyin.map 150${srcdir}/../lisp/language/pinyin.el: ${srcdir}/MISC-DIC/pinyin.map
151 $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv -f pinyin-convert $< $@ 151 $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv -f tit-pinyin-convert $< $@
152 152
153 153
154.PHONY: bootstrap-clean distclean maintainer-clean gen-clean 154.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)
319## up if chown or chgrp fails, as the package responsible for 319## up if chown or chgrp fails, as the package responsible for
320## installing Emacs can fix this problem later. 320## installing Emacs can fix this problem later.
321$(DESTDIR)${archlibdir}: all 321$(DESTDIR)${archlibdir}: all
322 $(info $ ) 322 $(info $.)
323 $(info Installing utilities run internally by Emacs.) 323 $(info Installing utilities run internally by Emacs.)
324 umask 022 && ${MKDIR_P} "$(DESTDIR)${archlibdir}" 324 umask 022 && ${MKDIR_P} "$(DESTDIR)${archlibdir}"
325 exp_archlibdir=`cd "$(DESTDIR)${archlibdir}" && pwd -P` && \ 325 exp_archlibdir=`cd "$(DESTDIR)${archlibdir}" && pwd -P` && \
@@ -361,7 +361,7 @@ $(DESTDIR)${archlibdir}: all
361.PHONY: bootstrap-clean check tags 361.PHONY: bootstrap-clean check tags
362 362
363install: $(DESTDIR)${archlibdir} 363install: $(DESTDIR)${archlibdir}
364 $(info $ ) 364 $(info $.)
365 $(info Installing utilities for users to run.) 365 $(info Installing utilities for users to run.)
366 umask 022 && ${MKDIR_P} "$(DESTDIR)${bindir}" 366 umask 022 && ${MKDIR_P} "$(DESTDIR)${bindir}"
367 for file in ${INSTALLABLES} ; do \ 367 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 @@
42#if (defined __has_attribute \ 42#if (defined __has_attribute \
43 && (!defined __clang_minor__ \ 43 && (!defined __clang_minor__ \
44 || (defined __apple_build_version__ \ 44 || (defined __apple_build_version__ \
45 ? 6000000 <= __apple_build_version__ \ 45 ? 7000000 <= __apple_build_version__ \
46 : 3 < __clang_major__ + (5 <= __clang_minor__)))) 46 : 5 <= __clang_major__)))
47# define __glibc_has_attribute(attr) __has_attribute (attr) 47# define __glibc_has_attribute(attr) __has_attribute (attr)
48#else 48#else
49# define __glibc_has_attribute(attr) 0 49# 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 @@
47# --avoid=iswdigit \ 47# --avoid=iswdigit \
48# --avoid=iswxdigit \ 48# --avoid=iswxdigit \
49# --avoid=langinfo \ 49# --avoid=langinfo \
50# --avoid=localename-unsafe-limited \
50# --avoid=lock \ 51# --avoid=lock \
51# --avoid=mbrtowc \ 52# --avoid=mbrtowc \
52# --avoid=mbsinit \ 53# --avoid=mbsinit \
@@ -1185,6 +1186,7 @@ REPLACE_MB_CUR_MAX = @REPLACE_MB_CUR_MAX@
1185REPLACE_MEMCHR = @REPLACE_MEMCHR@ 1186REPLACE_MEMCHR = @REPLACE_MEMCHR@
1186REPLACE_MEMMEM = @REPLACE_MEMMEM@ 1187REPLACE_MEMMEM = @REPLACE_MEMMEM@
1187REPLACE_MEMPCPY = @REPLACE_MEMPCPY@ 1188REPLACE_MEMPCPY = @REPLACE_MEMPCPY@
1189REPLACE_MEMSET_EXPLICIT = @REPLACE_MEMSET_EXPLICIT@
1188REPLACE_MKDIR = @REPLACE_MKDIR@ 1190REPLACE_MKDIR = @REPLACE_MKDIR@
1189REPLACE_MKFIFO = @REPLACE_MKFIFO@ 1191REPLACE_MKFIFO = @REPLACE_MKFIFO@
1190REPLACE_MKFIFOAT = @REPLACE_MKFIFOAT@ 1192REPLACE_MKFIFOAT = @REPLACE_MKFIFOAT@
@@ -1271,6 +1273,7 @@ REPLACE_SYMLINKAT = @REPLACE_SYMLINKAT@
1271REPLACE_TIME = @REPLACE_TIME@ 1273REPLACE_TIME = @REPLACE_TIME@
1272REPLACE_TIMEGM = @REPLACE_TIMEGM@ 1274REPLACE_TIMEGM = @REPLACE_TIMEGM@
1273REPLACE_TIMESPEC_GET = @REPLACE_TIMESPEC_GET@ 1275REPLACE_TIMESPEC_GET = @REPLACE_TIMESPEC_GET@
1276REPLACE_TIMESPEC_GETRES = @REPLACE_TIMESPEC_GETRES@
1274REPLACE_TMPFILE = @REPLACE_TMPFILE@ 1277REPLACE_TMPFILE = @REPLACE_TMPFILE@
1275REPLACE_TRUNCATE = @REPLACE_TRUNCATE@ 1278REPLACE_TRUNCATE = @REPLACE_TRUNCATE@
1276REPLACE_TTYNAME_R = @REPLACE_TTYNAME_R@ 1279REPLACE_TTYNAME_R = @REPLACE_TTYNAME_R@
@@ -2743,7 +2746,9 @@ ifeq (,$(OMIT_GNULIB_MODULE_nstrftime))
2743 2746
2744libgnu_a_SOURCES += nstrftime.c 2747libgnu_a_SOURCES += nstrftime.c
2745 2748
2746EXTRA_DIST += strftime.h 2749EXTRA_DIST += strftime.c strftime.h
2750
2751EXTRA_libgnu_a_SOURCES += strftime.c
2747 2752
2748endif 2753endif
2749## end gnulib module nstrftime 2754## end gnulib module nstrftime
@@ -3560,6 +3565,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
3560 -e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \ 3565 -e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \
3561 -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \ 3566 -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \
3562 -e 's|@''REPLACE_MEMPCPY''@|$(REPLACE_MEMPCPY)|g' \ 3567 -e 's|@''REPLACE_MEMPCPY''@|$(REPLACE_MEMPCPY)|g' \
3568 -e 's|@''REPLACE_MEMSET_EXPLICIT''@|$(REPLACE_MEMSET_EXPLICIT)|g' \
3563 -e 's|@''REPLACE_FREE''@|$(REPLACE_FREE)|g' \ 3569 -e 's|@''REPLACE_FREE''@|$(REPLACE_FREE)|g' \
3564 -e 's|@''REPLACE_STPCPY''@|$(REPLACE_STPCPY)|g' \ 3570 -e 's|@''REPLACE_STPCPY''@|$(REPLACE_STPCPY)|g' \
3565 -e 's|@''REPLACE_STPNCPY''@|$(REPLACE_STPNCPY)|g' \ 3571 -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) $(
3892 -e 's|@''REPLACE_TIME''@|$(REPLACE_TIME)|g' \ 3898 -e 's|@''REPLACE_TIME''@|$(REPLACE_TIME)|g' \
3893 -e 's|@''REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \ 3899 -e 's|@''REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \
3894 -e 's|@''REPLACE_TIMESPEC_GET''@|$(REPLACE_TIMESPEC_GET)|g' \ 3900 -e 's|@''REPLACE_TIMESPEC_GET''@|$(REPLACE_TIMESPEC_GET)|g' \
3901 -e 's|@''REPLACE_TIMESPEC_GETRES''@|$(REPLACE_TIMESPEC_GETRES)|g' \
3895 -e 's|@''REPLACE_TZSET''@|$(REPLACE_TZSET)|g' \ 3902 -e 's|@''REPLACE_TZSET''@|$(REPLACE_TZSET)|g' \
3896 -e 's|@''PTHREAD_H_DEFINES_STRUCT_TIMESPEC''@|$(PTHREAD_H_DEFINES_STRUCT_TIMESPEC)|g' \ 3903 -e 's|@''PTHREAD_H_DEFINES_STRUCT_TIMESPEC''@|$(PTHREAD_H_DEFINES_STRUCT_TIMESPEC)|g' \
3897 -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ 3904 -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 @@
130# define BOOL_WIDTH 1 130# define BOOL_WIDTH 1
131# define BOOL_MAX 1 131# define BOOL_MAX 1
132# elif ! defined BOOL_MAX 132# elif ! defined BOOL_MAX
133# define BOOL_MAX ((((1U << (BOOL_WIDTH - 1)) - 1) << 1) + 1) 133# define BOOL_MAX 1
134# endif 134# endif
135#endif 135#endif
136 136
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 @@
1/* Copyright (C) 1991-2024 Free Software Foundation, Inc. 1/* Generate time strings.
2 This file is part of the GNU C Library. 2
3 Copyright (C) 2024 Free Software Foundation, Inc.
3 4
4 This file is free software: you can redistribute it and/or modify 5 This file is free software: you can redistribute it and/or modify
5 it under the terms of the GNU Lesser General Public License as 6 it under the terms of the GNU Lesser General Public License as
@@ -14,1497 +15,5 @@
14 You should have received a copy of the GNU Lesser General Public License 15 You should have received a copy of the GNU Lesser General Public License
15 along with this program. If not, see <https://www.gnu.org/licenses/>. */ 16 along with this program. If not, see <https://www.gnu.org/licenses/>. */
16 17
17#ifdef _LIBC 18#define my_strftime nstrftime
18# define USE_IN_EXTENDED_LOCALE_MODEL 1 19#include "strftime.c"
19# define HAVE_STRUCT_ERA_ENTRY 1
20# define HAVE_TM_GMTOFF 1
21# define HAVE_STRUCT_TM_TM_ZONE 1
22# define HAVE_TZNAME 1
23# include "../locale/localeinfo.h"
24#else
25# include <libc-config.h>
26# if FPRINTFTIME
27# include "fprintftime.h"
28# else
29# include "strftime.h"
30# endif
31# include "time-internal.h"
32#endif
33
34#include <ctype.h>
35#include <errno.h>
36#include <time.h>
37
38#if HAVE_TZNAME && !HAVE_DECL_TZNAME
39extern char *tzname[];
40#endif
41
42/* Do multibyte processing if multibyte encodings are supported, unless
43 multibyte sequences are safe in formats. Multibyte sequences are
44 safe if they cannot contain byte sequences that look like format
45 conversion specifications. The multibyte encodings used by the
46 C library on the various platforms (UTF-8, GB2312, GBK, CP936,
47 GB18030, EUC-TW, BIG5, BIG5-HKSCS, CP950, EUC-JP, EUC-KR, CP949,
48 SHIFT_JIS, CP932, JOHAB) are safe for formats, because the byte '%'
49 cannot occur in a multibyte character except in the first byte.
50
51 The DEC-HANYU encoding used on OSF/1 is not safe for formats, but
52 this encoding has never been seen in real-life use, so we ignore
53 it. */
54#if !(defined __osf__ && 0)
55# define MULTIBYTE_IS_FORMAT_SAFE 1
56#endif
57#define DO_MULTIBYTE (! MULTIBYTE_IS_FORMAT_SAFE)
58
59#if DO_MULTIBYTE
60# include <wchar.h>
61 static const mbstate_t mbstate_zero;
62#endif
63
64#include <limits.h>
65#include <stdckdint.h>
66#include <stddef.h>
67#include <stdlib.h>
68#include <string.h>
69
70#include "attribute.h"
71#include <intprops.h>
72
73#ifdef COMPILE_WIDE
74# include <endian.h>
75# define CHAR_T wchar_t
76# define UCHAR_T unsigned int
77# define L_(Str) L##Str
78# define NLW(Sym) _NL_W##Sym
79
80# define MEMCPY(d, s, n) __wmemcpy (d, s, n)
81# define STRLEN(s) __wcslen (s)
82
83#else
84# define CHAR_T char
85# define UCHAR_T unsigned char
86# define L_(Str) Str
87# define NLW(Sym) Sym
88# define ABALTMON_1 _NL_ABALTMON_1
89
90# define MEMCPY(d, s, n) memcpy (d, s, n)
91# define STRLEN(s) strlen (s)
92
93#endif
94
95/* Shift A right by B bits portably, by dividing A by 2**B and
96 truncating towards minus infinity. A and B should be free of side
97 effects, and B should be in the range 0 <= B <= INT_BITS - 2, where
98 INT_BITS is the number of useful bits in an int. GNU code can
99 assume that INT_BITS is at least 32.
100
101 ISO C99 says that A >> B is implementation-defined if A < 0. Some
102 implementations (e.g., UNICOS 9.0 on a Cray Y-MP EL) don't shift
103 right in the usual way when A < 0, so SHR falls back on division if
104 ordinary A >> B doesn't seem to be the usual signed shift. */
105#define SHR(a, b) \
106 (-1 >> 1 == -1 \
107 ? (a) >> (b) \
108 : ((a) + ((a) < 0)) / (1 << (b)) - ((a) < 0))
109
110#define TM_YEAR_BASE 1900
111
112#ifndef __isleap
113/* Nonzero if YEAR is a leap year (every 4 years,
114 except every 100th isn't, and every 400th is). */
115# define __isleap(year) \
116 ((year) % 4 == 0 && ((year) % 100 != 0 || (year) % 400 == 0))
117#endif
118
119
120#ifdef _LIBC
121# define mktime_z(tz, tm) mktime (tm)
122# define tzname __tzname
123# define tzset __tzset
124#endif
125
126#ifndef FPRINTFTIME
127# define FPRINTFTIME 0
128#endif
129
130#if FPRINTFTIME
131# define STREAM_OR_CHAR_T FILE
132# define STRFTIME_ARG(x) /* empty */
133#else
134# define STREAM_OR_CHAR_T CHAR_T
135# define STRFTIME_ARG(x) x,
136#endif
137
138#if FPRINTFTIME
139# define memset_byte(P, Len, Byte) \
140 do { size_t _i; for (_i = 0; _i < Len; _i++) fputc (Byte, P); } while (0)
141# define memset_space(P, Len) memset_byte (P, Len, ' ')
142# define memset_zero(P, Len) memset_byte (P, Len, '0')
143#elif defined COMPILE_WIDE
144# define memset_space(P, Len) (wmemset (P, L' ', Len), (P) += (Len))
145# define memset_zero(P, Len) (wmemset (P, L'0', Len), (P) += (Len))
146#else
147# define memset_space(P, Len) (memset (P, ' ', Len), (P) += (Len))
148# define memset_zero(P, Len) (memset (P, '0', Len), (P) += (Len))
149#endif
150
151#if FPRINTFTIME
152# define advance(P, N)
153#else
154# define advance(P, N) ((P) += (N))
155#endif
156
157#define add(n, f) width_add (width, n, f)
158#define width_add(width, n, f) \
159 do \
160 { \
161 size_t _n = (n); \
162 size_t _w = pad == L_('-') || width < 0 ? 0 : width; \
163 size_t _incr = _n < _w ? _w : _n; \
164 if (_incr >= maxsize - i) \
165 { \
166 errno = ERANGE; \
167 return 0; \
168 } \
169 if (p) \
170 { \
171 if (_n < _w) \
172 { \
173 size_t _delta = _w - _n; \
174 if (pad == L_('0') || pad == L_('+')) \
175 memset_zero (p, _delta); \
176 else \
177 memset_space (p, _delta); \
178 } \
179 f; \
180 advance (p, _n); \
181 } \
182 i += _incr; \
183 } while (0)
184
185#define add1(c) width_add1 (width, c)
186#if FPRINTFTIME
187# define width_add1(width, c) width_add (width, 1, fputc (c, p))
188#else
189# define width_add1(width, c) width_add (width, 1, *p = c)
190#endif
191
192#define cpy(n, s) width_cpy (width, n, s)
193#if FPRINTFTIME
194# define width_cpy(width, n, s) \
195 width_add (width, n, \
196 do \
197 { \
198 if (to_lowcase) \
199 fwrite_lowcase (p, (s), _n); \
200 else if (to_uppcase) \
201 fwrite_uppcase (p, (s), _n); \
202 else \
203 { \
204 /* Ignore the value of fwrite. The caller can determine whether \
205 an error occurred by inspecting ferror (P). All known fwrite \
206 implementations set the stream's error indicator when they \
207 fail due to ENOMEM etc., even though C11 and POSIX.1-2008 do \
208 not require this. */ \
209 fwrite (s, _n, 1, p); \
210 } \
211 } \
212 while (0) \
213 )
214#else
215# define width_cpy(width, n, s) \
216 width_add (width, n, \
217 if (to_lowcase) \
218 memcpy_lowcase (p, (s), _n LOCALE_ARG); \
219 else if (to_uppcase) \
220 memcpy_uppcase (p, (s), _n LOCALE_ARG); \
221 else \
222 MEMCPY ((void *) p, (void const *) (s), _n))
223#endif
224
225#ifdef COMPILE_WIDE
226# ifndef USE_IN_EXTENDED_LOCALE_MODEL
227# undef __mbsrtowcs_l
228# define __mbsrtowcs_l(d, s, l, st, loc) __mbsrtowcs (d, s, l, st)
229# endif
230#endif
231
232
233#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
234/* We use this code also for the extended locale handling where the
235 function gets as an additional argument the locale which has to be
236 used. To access the values we have to redefine the _NL_CURRENT
237 macro. */
238# define strftime __strftime_l
239# define wcsftime __wcsftime_l
240# undef _NL_CURRENT
241# define _NL_CURRENT(category, item) \
242 (current->values[_NL_ITEM_INDEX (item)].string)
243# define LOCALE_PARAM , locale_t loc
244# define LOCALE_ARG , loc
245# define HELPER_LOCALE_ARG , current
246#else
247# define LOCALE_PARAM
248# define LOCALE_ARG
249# ifdef _LIBC
250# define HELPER_LOCALE_ARG , _NL_CURRENT_DATA (LC_TIME)
251# else
252# define HELPER_LOCALE_ARG
253# endif
254#endif
255
256#ifdef COMPILE_WIDE
257# ifdef USE_IN_EXTENDED_LOCALE_MODEL
258# define TOUPPER(Ch, L) __towupper_l (Ch, L)
259# define TOLOWER(Ch, L) __towlower_l (Ch, L)
260# else
261# define TOUPPER(Ch, L) towupper (Ch)
262# define TOLOWER(Ch, L) towlower (Ch)
263# endif
264#else
265# ifdef USE_IN_EXTENDED_LOCALE_MODEL
266# define TOUPPER(Ch, L) __toupper_l (Ch, L)
267# define TOLOWER(Ch, L) __tolower_l (Ch, L)
268# else
269# define TOUPPER(Ch, L) toupper (Ch)
270# define TOLOWER(Ch, L) tolower (Ch)
271# endif
272#endif
273/* We don't use 'isdigit' here since the locale dependent
274 interpretation is not what we want here. We only need to accept
275 the arabic digits in the ASCII range. One day there is perhaps a
276 more reliable way to accept other sets of digits. */
277#define ISDIGIT(Ch) ((unsigned int) (Ch) - L_('0') <= 9)
278
279/* Avoid false GCC warning "'memset' specified size 18446744073709551615 exceeds
280 maximum object size 9223372036854775807", caused by insufficient data flow
281 analysis and value propagation of the 'width_add' expansion when GCC is not
282 optimizing. Cf. <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=88443>. */
283#if __GNUC__ >= 7 && !__OPTIMIZE__
284# pragma GCC diagnostic ignored "-Wstringop-overflow"
285#endif
286
287#if FPRINTFTIME
288static void
289fwrite_lowcase (FILE *fp, const CHAR_T *src, size_t len)
290{
291 while (len-- > 0)
292 {
293 fputc (TOLOWER ((UCHAR_T) *src, loc), fp);
294 ++src;
295 }
296}
297
298static void
299fwrite_uppcase (FILE *fp, const CHAR_T *src, size_t len)
300{
301 while (len-- > 0)
302 {
303 fputc (TOUPPER ((UCHAR_T) *src, loc), fp);
304 ++src;
305 }
306}
307#else
308static CHAR_T *memcpy_lowcase (CHAR_T *dest, const CHAR_T *src,
309 size_t len LOCALE_PARAM);
310
311static CHAR_T *
312memcpy_lowcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
313{
314 while (len-- > 0)
315 dest[len] = TOLOWER ((UCHAR_T) src[len], loc);
316 return dest;
317}
318
319static CHAR_T *memcpy_uppcase (CHAR_T *dest, const CHAR_T *src,
320 size_t len LOCALE_PARAM);
321
322static CHAR_T *
323memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
324{
325 while (len-- > 0)
326 dest[len] = TOUPPER ((UCHAR_T) src[len], loc);
327 return dest;
328}
329#endif
330
331
332#if ! HAVE_TM_GMTOFF
333/* Yield the difference between *A and *B,
334 measured in seconds, ignoring leap seconds. */
335# define tm_diff ftime_tm_diff
336static int tm_diff (const struct tm *, const struct tm *);
337static int
338tm_diff (const struct tm *a, const struct tm *b)
339{
340 /* Compute intervening leap days correctly even if year is negative.
341 Take care to avoid int overflow in leap day calculations,
342 but it's OK to assume that A and B are close to each other. */
343 int a4 = SHR (a->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (a->tm_year & 3);
344 int b4 = SHR (b->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (b->tm_year & 3);
345 int a100 = (a4 + (a4 < 0)) / 25 - (a4 < 0);
346 int b100 = (b4 + (b4 < 0)) / 25 - (b4 < 0);
347 int a400 = SHR (a100, 2);
348 int b400 = SHR (b100, 2);
349 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
350 int years = a->tm_year - b->tm_year;
351 int days = (365 * years + intervening_leap_days
352 + (a->tm_yday - b->tm_yday));
353 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
354 + (a->tm_min - b->tm_min))
355 + (a->tm_sec - b->tm_sec));
356}
357#endif /* ! HAVE_TM_GMTOFF */
358
359
360
361/* The number of days from the first day of the first ISO week of this
362 year to the year day YDAY with week day WDAY. ISO weeks start on
363 Monday; the first ISO week has the year's first Thursday. YDAY may
364 be as small as YDAY_MINIMUM. */
365#define ISO_WEEK_START_WDAY 1 /* Monday */
366#define ISO_WEEK1_WDAY 4 /* Thursday */
367#define YDAY_MINIMUM (-366)
368static int iso_week_days (int, int);
369static __inline int
370iso_week_days (int yday, int wday)
371{
372 /* Add enough to the first operand of % to make it nonnegative. */
373 int big_enough_multiple_of_7 = (-YDAY_MINIMUM / 7 + 2) * 7;
374 return (yday
375 - (yday - wday + ISO_WEEK1_WDAY + big_enough_multiple_of_7) % 7
376 + ISO_WEEK1_WDAY - ISO_WEEK_START_WDAY);
377}
378
379
380/* When compiling this file, GNU applications can #define my_strftime
381 to a symbol (typically nstrftime) to get an extended strftime with
382 extra arguments TZ and NS. */
383
384#if FPRINTFTIME
385# undef my_strftime
386# define my_strftime fprintftime
387#endif
388
389#ifdef my_strftime
390# define extra_args , tz, ns
391# define extra_args_spec , timezone_t tz, int ns
392#else
393# if defined COMPILE_WIDE
394# define my_strftime wcsftime
395# define nl_get_alt_digit _nl_get_walt_digit
396# else
397# define my_strftime strftime
398# define nl_get_alt_digit _nl_get_alt_digit
399# endif
400# define extra_args
401# define extra_args_spec
402/* We don't have this information in general. */
403# define tz 1
404# define ns 0
405#endif
406
407static size_t __strftime_internal (STREAM_OR_CHAR_T *, STRFTIME_ARG (size_t)
408 const CHAR_T *, const struct tm *,
409 bool, int, int, bool *
410 extra_args_spec LOCALE_PARAM);
411
412/* Write information from TP into S according to the format
413 string FORMAT, writing no more that MAXSIZE characters
414 (including the terminating '\0') and returning number of
415 characters written. If S is NULL, nothing will be written
416 anywhere, so to determine how many characters would be
417 written, use NULL for S and (size_t) -1 for MAXSIZE. */
418size_t
419my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
420 const CHAR_T *format,
421 const struct tm *tp extra_args_spec LOCALE_PARAM)
422{
423 bool tzset_called = false;
424 return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, false,
425 0, -1, &tzset_called extra_args LOCALE_ARG);
426}
427libc_hidden_def (my_strftime)
428
429/* Just like my_strftime, above, but with more parameters.
430 UPCASE indicates that the result should be converted to upper case.
431 YR_SPEC and WIDTH specify the padding and width for the year.
432 *TZSET_CALLED indicates whether tzset has been called here. */
433static size_t
434__strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
435 const CHAR_T *format,
436 const struct tm *tp, bool upcase,
437 int yr_spec, int width, bool *tzset_called
438 extra_args_spec LOCALE_PARAM)
439{
440#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
441 struct __locale_data *const current = loc->__locales[LC_TIME];
442#endif
443#if FPRINTFTIME
444 size_t maxsize = (size_t) -1;
445#endif
446
447 int saved_errno = errno;
448 int hour12 = tp->tm_hour;
449#ifdef _NL_CURRENT
450 /* We cannot make the following values variables since we must delay
451 the evaluation of these values until really needed since some
452 expressions might not be valid in every situation. The 'struct tm'
453 might be generated by a strptime() call that initialized
454 only a few elements. Dereference the pointers only if the format
455 requires this. Then it is ok to fail if the pointers are invalid. */
456# define a_wkday \
457 ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
458 ? "?" : _NL_CURRENT (LC_TIME, NLW(ABDAY_1) + tp->tm_wday)))
459# define f_wkday \
460 ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
461 ? "?" : _NL_CURRENT (LC_TIME, NLW(DAY_1) + tp->tm_wday)))
462# define a_month \
463 ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
464 ? "?" : _NL_CURRENT (LC_TIME, NLW(ABMON_1) + tp->tm_mon)))
465# define f_month \
466 ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
467 ? "?" : _NL_CURRENT (LC_TIME, NLW(MON_1) + tp->tm_mon)))
468# define a_altmonth \
469 ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
470 ? "?" : _NL_CURRENT (LC_TIME, NLW(ABALTMON_1) + tp->tm_mon)))
471# define f_altmonth \
472 ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
473 ? "?" : _NL_CURRENT (LC_TIME, NLW(ALTMON_1) + tp->tm_mon)))
474# define ampm \
475 ((const CHAR_T *) _NL_CURRENT (LC_TIME, tp->tm_hour > 11 \
476 ? NLW(PM_STR) : NLW(AM_STR)))
477
478# define aw_len STRLEN (a_wkday)
479# define am_len STRLEN (a_month)
480# define aam_len STRLEN (a_altmonth)
481# define ap_len STRLEN (ampm)
482#endif
483#if HAVE_TZNAME
484 char **tzname_vec = tzname;
485#endif
486 const char *zone;
487 size_t i = 0;
488 STREAM_OR_CHAR_T *p = s;
489 const CHAR_T *f;
490#if DO_MULTIBYTE && !defined COMPILE_WIDE
491 const char *format_end = NULL;
492#endif
493
494 zone = NULL;
495#if HAVE_STRUCT_TM_TM_ZONE
496 /* The POSIX test suite assumes that setting
497 the environment variable TZ to a new value before calling strftime()
498 will influence the result (the %Z format) even if the information in
499 TP is computed with a totally different time zone.
500 This is bogus: though POSIX allows bad behavior like this,
501 POSIX does not require it. Do the right thing instead. */
502 zone = (const char *) tp->tm_zone;
503#endif
504#if HAVE_TZNAME
505 if (!tz)
506 {
507 if (! (zone && *zone))
508 zone = "GMT";
509 }
510 else
511 {
512# if !HAVE_STRUCT_TM_TM_ZONE
513 /* Infer the zone name from *TZ instead of from TZNAME. */
514 tzname_vec = tz->tzname_copy;
515# endif
516 }
517 /* The tzset() call might have changed the value. */
518 if (!(zone && *zone) && tp->tm_isdst >= 0)
519 {
520 /* POSIX.1 requires that local time zone information be used as
521 though strftime called tzset. */
522# ifndef my_strftime
523 if (!*tzset_called)
524 {
525 tzset ();
526 *tzset_called = true;
527 }
528# endif
529 zone = tzname_vec[tp->tm_isdst != 0];
530 }
531#endif
532 if (! zone)
533 zone = "";
534
535 if (hour12 > 12)
536 hour12 -= 12;
537 else
538 if (hour12 == 0)
539 hour12 = 12;
540
541 for (f = format; *f != '\0'; width = -1, f++)
542 {
543 int pad = 0; /* Padding for number ('_', '-', '+', '0', or 0). */
544 int modifier; /* Field modifier ('E', 'O', or 0). */
545 int digits = 0; /* Max digits for numeric format. */
546 int number_value; /* Numeric value to be printed. */
547 unsigned int u_number_value; /* (unsigned int) number_value. */
548 bool negative_number; /* The number is negative. */
549 bool always_output_a_sign; /* +/- should always be output. */
550 int tz_colon_mask; /* Bitmask of where ':' should appear. */
551 const CHAR_T *subfmt;
552 CHAR_T *bufp;
553 CHAR_T buf[1
554 + 2 /* for the two colons in a %::z or %:::z time zone */
555 + (sizeof (int) < sizeof (time_t)
556 ? INT_STRLEN_BOUND (time_t)
557 : INT_STRLEN_BOUND (int))];
558 bool to_lowcase = false;
559 bool to_uppcase = upcase;
560 size_t colons;
561 bool change_case = false;
562 int format_char;
563 int subwidth;
564
565#if DO_MULTIBYTE && !defined COMPILE_WIDE
566 switch (*f)
567 {
568 case L_('%'):
569 break;
570
571 case L_('\b'): case L_('\t'): case L_('\n'):
572 case L_('\v'): case L_('\f'): case L_('\r'):
573 case L_(' '): case L_('!'): case L_('"'): case L_('#'): case L_('&'):
574 case L_('\''): case L_('('): case L_(')'): case L_('*'): case L_('+'):
575 case L_(','): case L_('-'): case L_('.'): case L_('/'): case L_('0'):
576 case L_('1'): case L_('2'): case L_('3'): case L_('4'): case L_('5'):
577 case L_('6'): case L_('7'): case L_('8'): case L_('9'): case L_(':'):
578 case L_(';'): case L_('<'): case L_('='): case L_('>'): case L_('?'):
579 case L_('A'): case L_('B'): case L_('C'): case L_('D'): case L_('E'):
580 case L_('F'): case L_('G'): case L_('H'): case L_('I'): case L_('J'):
581 case L_('K'): case L_('L'): case L_('M'): case L_('N'): case L_('O'):
582 case L_('P'): case L_('Q'): case L_('R'): case L_('S'): case L_('T'):
583 case L_('U'): case L_('V'): case L_('W'): case L_('X'): case L_('Y'):
584 case L_('Z'): case L_('['): case L_('\\'): case L_(']'): case L_('^'):
585 case L_('_'): case L_('a'): case L_('b'): case L_('c'): case L_('d'):
586 case L_('e'): case L_('f'): case L_('g'): case L_('h'): case L_('i'):
587 case L_('j'): case L_('k'): case L_('l'): case L_('m'): case L_('n'):
588 case L_('o'): case L_('p'): case L_('q'): case L_('r'): case L_('s'):
589 case L_('t'): case L_('u'): case L_('v'): case L_('w'): case L_('x'):
590 case L_('y'): case L_('z'): case L_('{'): case L_('|'): case L_('}'):
591 case L_('~'):
592 /* The C Standard requires these 98 characters (plus '%') to
593 be in the basic execution character set. None of these
594 characters can start a multibyte sequence, so they need
595 not be analyzed further. */
596 add1 (*f);
597 continue;
598
599 default:
600 /* Copy this multibyte sequence until we reach its end, find
601 an error, or come back to the initial shift state. */
602 {
603 mbstate_t mbstate = mbstate_zero;
604 size_t len = 0;
605 size_t fsize;
606
607 if (! format_end)
608 format_end = f + strlen (f) + 1;
609 fsize = format_end - f;
610
611 do
612 {
613 size_t bytes = mbrlen (f + len, fsize - len, &mbstate);
614
615 if (bytes == 0)
616 break;
617
618 if (bytes == (size_t) -2)
619 {
620 len += strlen (f + len);
621 break;
622 }
623
624 if (bytes == (size_t) -1)
625 {
626 len++;
627 break;
628 }
629
630 len += bytes;
631 }
632 while (! mbsinit (&mbstate));
633
634 cpy (len, f);
635 f += len - 1;
636 continue;
637 }
638 }
639
640#else /* ! DO_MULTIBYTE */
641
642 /* Either multibyte encodings are not supported, they are
643 safe for formats, so any non-'%' byte can be copied through,
644 or this is the wide character version. */
645 if (*f != L_('%'))
646 {
647 add1 (*f);
648 continue;
649 }
650
651#endif /* ! DO_MULTIBYTE */
652
653 char const *percent = f;
654
655 /* Check for flags that can modify a format. */
656 while (1)
657 {
658 switch (*++f)
659 {
660 /* This influences the number formats. */
661 case L_('_'):
662 case L_('-'):
663 case L_('+'):
664 case L_('0'):
665 pad = *f;
666 continue;
667
668 /* This changes textual output. */
669 case L_('^'):
670 to_uppcase = true;
671 continue;
672 case L_('#'):
673 change_case = true;
674 continue;
675
676 default:
677 break;
678 }
679 break;
680 }
681
682 if (ISDIGIT (*f))
683 {
684 width = 0;
685 do
686 {
687 if (ckd_mul (&width, width, 10)
688 || ckd_add (&width, width, *f - L_('0')))
689 width = INT_MAX;
690 ++f;
691 }
692 while (ISDIGIT (*f));
693 }
694
695 /* Check for modifiers. */
696 switch (*f)
697 {
698 case L_('E'):
699 case L_('O'):
700 modifier = *f++;
701 break;
702
703 default:
704 modifier = 0;
705 break;
706 }
707
708 /* Now do the specified format. */
709 format_char = *f;
710 switch (format_char)
711 {
712#define DO_NUMBER(d, v) \
713 do \
714 { \
715 digits = d; \
716 number_value = v; \
717 goto do_number; \
718 } \
719 while (0)
720#define DO_SIGNED_NUMBER(d, negative, v) \
721 DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_signed_number)
722#define DO_YEARISH(d, negative, v) \
723 DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_yearish)
724#define DO_MAYBE_SIGNED_NUMBER(d, negative, v, label) \
725 do \
726 { \
727 digits = d; \
728 negative_number = negative; \
729 u_number_value = v; \
730 goto label; \
731 } \
732 while (0)
733
734 /* The mask is not what you might think.
735 When the ordinal i'th bit is set, insert a colon
736 before the i'th digit of the time zone representation. */
737#define DO_TZ_OFFSET(d, mask, v) \
738 do \
739 { \
740 digits = d; \
741 tz_colon_mask = mask; \
742 u_number_value = v; \
743 goto do_tz_offset; \
744 } \
745 while (0)
746#define DO_NUMBER_SPACEPAD(d, v) \
747 do \
748 { \
749 digits = d; \
750 number_value = v; \
751 goto do_number_spacepad; \
752 } \
753 while (0)
754
755 case L_('%'):
756 if (f - 1 != percent)
757 goto bad_percent;
758 add1 (*f);
759 break;
760
761 case L_('a'):
762 if (modifier != 0)
763 goto bad_format;
764 if (change_case)
765 {
766 to_uppcase = true;
767 to_lowcase = false;
768 }
769#ifdef _NL_CURRENT
770 cpy (aw_len, a_wkday);
771 break;
772#else
773 goto underlying_strftime;
774#endif
775
776 case 'A':
777 if (modifier != 0)
778 goto bad_format;
779 if (change_case)
780 {
781 to_uppcase = true;
782 to_lowcase = false;
783 }
784#ifdef _NL_CURRENT
785 cpy (STRLEN (f_wkday), f_wkday);
786 break;
787#else
788 goto underlying_strftime;
789#endif
790
791 case L_('b'):
792 case L_('h'):
793 if (change_case)
794 {
795 to_uppcase = true;
796 to_lowcase = false;
797 }
798 if (modifier == L_('E'))
799 goto bad_format;
800#ifdef _NL_CURRENT
801 if (modifier == L_('O'))
802 cpy (aam_len, a_altmonth);
803 else
804 cpy (am_len, a_month);
805 break;
806#else
807 goto underlying_strftime;
808#endif
809
810 case L_('B'):
811 if (modifier == L_('E'))
812 goto bad_format;
813 if (change_case)
814 {
815 to_uppcase = true;
816 to_lowcase = false;
817 }
818#ifdef _NL_CURRENT
819 if (modifier == L_('O'))
820 cpy (STRLEN (f_altmonth), f_altmonth);
821 else
822 cpy (STRLEN (f_month), f_month);
823 break;
824#else
825 goto underlying_strftime;
826#endif
827
828 case L_('c'):
829 if (modifier == L_('O'))
830 goto bad_format;
831#ifdef _NL_CURRENT
832 if (! (modifier == L_('E')
833 && (*(subfmt =
834 (const CHAR_T *) _NL_CURRENT (LC_TIME,
835 NLW(ERA_D_T_FMT)))
836 != '\0')))
837 subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_T_FMT));
838#else
839 goto underlying_strftime;
840#endif
841
842 subformat:
843 subwidth = -1;
844 subformat_width:
845 {
846 size_t len = __strftime_internal (NULL, STRFTIME_ARG ((size_t) -1)
847 subfmt, tp, to_uppcase,
848 pad, subwidth, tzset_called
849 extra_args LOCALE_ARG);
850 add (len, __strftime_internal (p,
851 STRFTIME_ARG (maxsize - i)
852 subfmt, tp, to_uppcase,
853 pad, subwidth, tzset_called
854 extra_args LOCALE_ARG));
855 }
856 break;
857
858#if !(defined _NL_CURRENT && HAVE_STRUCT_ERA_ENTRY)
859 underlying_strftime:
860 {
861 /* The relevant information is available only via the
862 underlying strftime implementation, so use that. */
863 char ufmt[5];
864 char *u = ufmt;
865 char ubuf[1024]; /* enough for any single format in practice */
866 size_t len;
867 /* Make sure we're calling the actual underlying strftime.
868 In some cases, config.h contains something like
869 "#define strftime rpl_strftime". */
870# ifdef strftime
871# undef strftime
872 size_t strftime ();
873# endif
874
875 /* The space helps distinguish strftime failure from empty
876 output. */
877 *u++ = ' ';
878 *u++ = '%';
879 if (modifier != 0)
880 *u++ = modifier;
881 *u++ = format_char;
882 *u = '\0';
883 len = strftime (ubuf, sizeof ubuf, ufmt, tp);
884 if (len != 0)
885 cpy (len - 1, ubuf + 1);
886 }
887 break;
888#endif
889
890 case L_('C'):
891 if (modifier == L_('E'))
892 {
893#if HAVE_STRUCT_ERA_ENTRY
894 struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
895 if (era)
896 {
897# ifdef COMPILE_WIDE
898 size_t len = __wcslen (era->era_wname);
899 cpy (len, era->era_wname);
900# else
901 size_t len = strlen (era->era_name);
902 cpy (len, era->era_name);
903# endif
904 break;
905 }
906#else
907 goto underlying_strftime;
908#endif
909 }
910
911 {
912 bool negative_year = tp->tm_year < - TM_YEAR_BASE;
913 bool zero_thru_1899 = !negative_year & (tp->tm_year < 0);
914 int century = ((tp->tm_year - 99 * zero_thru_1899) / 100
915 + TM_YEAR_BASE / 100);
916 DO_YEARISH (2, negative_year, century);
917 }
918
919 case L_('x'):
920 if (modifier == L_('O'))
921 goto bad_format;
922#ifdef _NL_CURRENT
923 if (! (modifier == L_('E')
924 && (*(subfmt =
925 (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_D_FMT)))
926 != L_('\0'))))
927 subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_FMT));
928 goto subformat;
929#else
930 goto underlying_strftime;
931#endif
932 case L_('D'):
933 if (modifier != 0)
934 goto bad_format;
935 subfmt = L_("%m/%d/%y");
936 goto subformat;
937
938 case L_('d'):
939 if (modifier == L_('E'))
940 goto bad_format;
941
942 DO_NUMBER (2, tp->tm_mday);
943
944 case L_('e'):
945 if (modifier == L_('E'))
946 goto bad_format;
947
948 DO_NUMBER_SPACEPAD (2, tp->tm_mday);
949
950 /* All numeric formats set DIGITS and NUMBER_VALUE (or U_NUMBER_VALUE)
951 and then jump to one of these labels. */
952
953 do_tz_offset:
954 always_output_a_sign = true;
955 goto do_number_body;
956
957 do_yearish:
958 if (pad == 0)
959 pad = yr_spec;
960 always_output_a_sign
961 = (pad == L_('+')
962 && ((digits == 2 ? 99 : 9999) < u_number_value
963 || digits < width));
964 goto do_maybe_signed_number;
965
966 do_number_spacepad:
967 if (pad == 0)
968 pad = L_('_');
969
970 do_number:
971 /* Format NUMBER_VALUE according to the MODIFIER flag. */
972 negative_number = number_value < 0;
973 u_number_value = number_value;
974
975 do_signed_number:
976 always_output_a_sign = false;
977
978 do_maybe_signed_number:
979 tz_colon_mask = 0;
980
981 do_number_body:
982 /* Format U_NUMBER_VALUE according to the MODIFIER flag.
983 NEGATIVE_NUMBER is nonzero if the original number was
984 negative; in this case it was converted directly to
985 unsigned int (i.e., modulo (UINT_MAX + 1)) without
986 negating it. */
987 if (modifier == L_('O') && !negative_number)
988 {
989#ifdef _NL_CURRENT
990 /* Get the locale specific alternate representation of
991 the number. If none exist NULL is returned. */
992 const CHAR_T *cp = nl_get_alt_digit (u_number_value
993 HELPER_LOCALE_ARG);
994
995 if (cp != NULL)
996 {
997 size_t digitlen = STRLEN (cp);
998 if (digitlen != 0)
999 {
1000 cpy (digitlen, cp);
1001 break;
1002 }
1003 }
1004#else
1005 goto underlying_strftime;
1006#endif
1007 }
1008
1009 bufp = buf + sizeof (buf) / sizeof (buf[0]);
1010
1011 if (negative_number)
1012 u_number_value = - u_number_value;
1013
1014 do
1015 {
1016 if (tz_colon_mask & 1)
1017 *--bufp = ':';
1018 tz_colon_mask >>= 1;
1019 *--bufp = u_number_value % 10 + L_('0');
1020 u_number_value /= 10;
1021 }
1022 while (u_number_value != 0 || tz_colon_mask != 0);
1023
1024 do_number_sign_and_padding:
1025 if (pad == 0)
1026 pad = L_('0');
1027 if (width < 0)
1028 width = digits;
1029
1030 {
1031 CHAR_T sign_char = (negative_number ? L_('-')
1032 : always_output_a_sign ? L_('+')
1033 : 0);
1034 int numlen = buf + sizeof buf / sizeof buf[0] - bufp;
1035 int shortage = width - !!sign_char - numlen;
1036 int padding = pad == L_('-') || shortage <= 0 ? 0 : shortage;
1037
1038 if (sign_char)
1039 {
1040 if (pad == L_('_'))
1041 {
1042 if (p)
1043 memset_space (p, padding);
1044 i += padding;
1045 width -= padding;
1046 }
1047 width_add1 (0, sign_char);
1048 width--;
1049 }
1050
1051 cpy (numlen, bufp);
1052 }
1053 break;
1054
1055 case L_('F'):
1056 if (modifier != 0)
1057 goto bad_format;
1058 if (pad == 0 && width < 0)
1059 {
1060 pad = L_('+');
1061 subwidth = 4;
1062 }
1063 else
1064 {
1065 subwidth = width - 6;
1066 if (subwidth < 0)
1067 subwidth = 0;
1068 }
1069 subfmt = L_("%Y-%m-%d");
1070 goto subformat_width;
1071
1072 case L_('H'):
1073 if (modifier == L_('E'))
1074 goto bad_format;
1075
1076 DO_NUMBER (2, tp->tm_hour);
1077
1078 case L_('I'):
1079 if (modifier == L_('E'))
1080 goto bad_format;
1081
1082 DO_NUMBER (2, hour12);
1083
1084 case L_('k'): /* GNU extension. */
1085 if (modifier == L_('E'))
1086 goto bad_format;
1087
1088 DO_NUMBER_SPACEPAD (2, tp->tm_hour);
1089
1090 case L_('l'): /* GNU extension. */
1091 if (modifier == L_('E'))
1092 goto bad_format;
1093
1094 DO_NUMBER_SPACEPAD (2, hour12);
1095
1096 case L_('j'):
1097 if (modifier == L_('E'))
1098 goto bad_format;
1099
1100 DO_SIGNED_NUMBER (3, tp->tm_yday < -1, tp->tm_yday + 1U);
1101
1102 case L_('M'):
1103 if (modifier == L_('E'))
1104 goto bad_format;
1105
1106 DO_NUMBER (2, tp->tm_min);
1107
1108 case L_('m'):
1109 if (modifier == L_('E'))
1110 goto bad_format;
1111
1112 DO_SIGNED_NUMBER (2, tp->tm_mon < -1, tp->tm_mon + 1U);
1113
1114#ifndef _LIBC
1115 case L_('N'): /* GNU extension. */
1116 if (modifier == L_('E'))
1117 goto bad_format;
1118 {
1119 int n = ns, ns_digits = 9;
1120 if (width <= 0)
1121 width = ns_digits;
1122 int ndigs = ns_digits;
1123 while (width < ndigs || (1 < ndigs && n % 10 == 0))
1124 ndigs--, n /= 10;
1125 for (int j = ndigs; 0 < j; j--)
1126 buf[j - 1] = n % 10 + L_('0'), n /= 10;
1127 if (!pad)
1128 pad = L_('0');
1129 width_cpy (0, ndigs, buf);
1130 width_add (width - ndigs, 0, (void) 0);
1131 }
1132 break;
1133#endif
1134
1135 case L_('n'):
1136 add1 (L_('\n'));
1137 break;
1138
1139 case L_('P'):
1140 to_lowcase = true;
1141#ifndef _NL_CURRENT
1142 format_char = L_('p');
1143#endif
1144 FALLTHROUGH;
1145 case L_('p'):
1146 if (change_case)
1147 {
1148 to_uppcase = false;
1149 to_lowcase = true;
1150 }
1151#ifdef _NL_CURRENT
1152 cpy (ap_len, ampm);
1153 break;
1154#else
1155 goto underlying_strftime;
1156#endif
1157
1158 case L_('q'): /* GNU extension. */
1159 DO_SIGNED_NUMBER (1, false, ((tp->tm_mon * 11) >> 5) + 1);
1160
1161 case L_('R'):
1162 subfmt = L_("%H:%M");
1163 goto subformat;
1164
1165 case L_('r'):
1166#ifdef _NL_CURRENT
1167 if (*(subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME,
1168 NLW(T_FMT_AMPM)))
1169 == L_('\0'))
1170 subfmt = L_("%I:%M:%S %p");
1171 goto subformat;
1172#else
1173 goto underlying_strftime;
1174#endif
1175
1176 case L_('S'):
1177 if (modifier == L_('E'))
1178 goto bad_format;
1179
1180 DO_NUMBER (2, tp->tm_sec);
1181
1182 case L_('s'): /* GNU extension. */
1183 {
1184 struct tm ltm;
1185 time_t t;
1186
1187 ltm = *tp;
1188 ltm.tm_yday = -1;
1189 t = mktime_z (tz, &ltm);
1190 if (ltm.tm_yday < 0)
1191 {
1192 errno = EOVERFLOW;
1193 return 0;
1194 }
1195
1196 /* Generate string value for T using time_t arithmetic;
1197 this works even if sizeof (long) < sizeof (time_t). */
1198
1199 bufp = buf + sizeof (buf) / sizeof (buf[0]);
1200 negative_number = t < 0;
1201
1202 do
1203 {
1204 int d = t % 10;
1205 t /= 10;
1206 *--bufp = (negative_number ? -d : d) + L_('0');
1207 }
1208 while (t != 0);
1209
1210 digits = 1;
1211 always_output_a_sign = false;
1212 goto do_number_sign_and_padding;
1213 }
1214
1215 case L_('X'):
1216 if (modifier == L_('O'))
1217 goto bad_format;
1218#ifdef _NL_CURRENT
1219 if (! (modifier == L_('E')
1220 && (*(subfmt =
1221 (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_T_FMT)))
1222 != L_('\0'))))
1223 subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(T_FMT));
1224 goto subformat;
1225#else
1226 goto underlying_strftime;
1227#endif
1228 case L_('T'):
1229 subfmt = L_("%H:%M:%S");
1230 goto subformat;
1231
1232 case L_('t'):
1233 add1 (L_('\t'));
1234 break;
1235
1236 case L_('u'):
1237 DO_NUMBER (1, (tp->tm_wday - 1 + 7) % 7 + 1);
1238
1239 case L_('U'):
1240 if (modifier == L_('E'))
1241 goto bad_format;
1242
1243 DO_NUMBER (2, (tp->tm_yday - tp->tm_wday + 7) / 7);
1244
1245 case L_('V'):
1246 case L_('g'):
1247 case L_('G'):
1248 if (modifier == L_('E'))
1249 goto bad_format;
1250 {
1251 /* YEAR is a leap year if and only if (tp->tm_year + TM_YEAR_BASE)
1252 is a leap year, except that YEAR and YEAR - 1 both work
1253 correctly even when (tp->tm_year + TM_YEAR_BASE) would
1254 overflow. */
1255 int year = (tp->tm_year
1256 + (tp->tm_year < 0
1257 ? TM_YEAR_BASE % 400
1258 : TM_YEAR_BASE % 400 - 400));
1259 int year_adjust = 0;
1260 int days = iso_week_days (tp->tm_yday, tp->tm_wday);
1261
1262 if (days < 0)
1263 {
1264 /* This ISO week belongs to the previous year. */
1265 year_adjust = -1;
1266 days = iso_week_days (tp->tm_yday + (365 + __isleap (year - 1)),
1267 tp->tm_wday);
1268 }
1269 else
1270 {
1271 int d = iso_week_days (tp->tm_yday - (365 + __isleap (year)),
1272 tp->tm_wday);
1273 if (0 <= d)
1274 {
1275 /* This ISO week belongs to the next year. */
1276 year_adjust = 1;
1277 days = d;
1278 }
1279 }
1280
1281 switch (*f)
1282 {
1283 case L_('g'):
1284 {
1285 int yy = (tp->tm_year % 100 + year_adjust) % 100;
1286 DO_YEARISH (2, false,
1287 (0 <= yy
1288 ? yy
1289 : tp->tm_year < -TM_YEAR_BASE - year_adjust
1290 ? -yy
1291 : yy + 100));
1292 }
1293
1294 case L_('G'):
1295 DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE - year_adjust,
1296 (tp->tm_year + (unsigned int) TM_YEAR_BASE
1297 + year_adjust));
1298
1299 default:
1300 DO_NUMBER (2, days / 7 + 1);
1301 }
1302 }
1303
1304 case L_('W'):
1305 if (modifier == L_('E'))
1306 goto bad_format;
1307
1308 DO_NUMBER (2, (tp->tm_yday - (tp->tm_wday - 1 + 7) % 7 + 7) / 7);
1309
1310 case L_('w'):
1311 if (modifier == L_('E'))
1312 goto bad_format;
1313
1314 DO_NUMBER (1, tp->tm_wday);
1315
1316 case L_('Y'):
1317 if (modifier == L_('E'))
1318 {
1319#if HAVE_STRUCT_ERA_ENTRY
1320 struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
1321 if (era)
1322 {
1323# ifdef COMPILE_WIDE
1324 subfmt = era->era_wformat;
1325# else
1326 subfmt = era->era_format;
1327# endif
1328 if (pad == 0)
1329 pad = yr_spec;
1330 goto subformat;
1331 }
1332#else
1333 goto underlying_strftime;
1334#endif
1335 }
1336 if (modifier == L_('O'))
1337 goto bad_format;
1338
1339 DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE,
1340 tp->tm_year + (unsigned int) TM_YEAR_BASE);
1341
1342 case L_('y'):
1343 if (modifier == L_('E'))
1344 {
1345#if HAVE_STRUCT_ERA_ENTRY
1346 struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
1347 if (era)
1348 {
1349 int delta = tp->tm_year - era->start_date[0];
1350 if (pad == 0)
1351 pad = yr_spec;
1352 DO_NUMBER (2, (era->offset
1353 + delta * era->absolute_direction));
1354 }
1355#else
1356 goto underlying_strftime;
1357#endif
1358 }
1359
1360 {
1361 int yy = tp->tm_year % 100;
1362 if (yy < 0)
1363 yy = tp->tm_year < - TM_YEAR_BASE ? -yy : yy + 100;
1364 DO_YEARISH (2, false, yy);
1365 }
1366
1367 case L_('Z'):
1368 if (change_case)
1369 {
1370 to_uppcase = false;
1371 to_lowcase = true;
1372 }
1373
1374#ifdef COMPILE_WIDE
1375 {
1376 /* The zone string is always given in multibyte form. We have
1377 to convert it to wide character. */
1378 size_t w = pad == L_('-') || width < 0 ? 0 : width;
1379 char const *z = zone;
1380 mbstate_t st = {0};
1381 size_t len = __mbsrtowcs_l (p, &z, maxsize - i, &st, loc);
1382 if (len == (size_t) -1)
1383 return 0;
1384 size_t incr = len < w ? w : len;
1385 if (incr >= maxsize - i)
1386 {
1387 errno = ERANGE;
1388 return 0;
1389 }
1390 if (p)
1391 {
1392 if (len < w)
1393 {
1394 size_t delta = w - len;
1395 __wmemmove (p + delta, p, len);
1396 wchar_t wc = pad == L_('0') || pad == L_('+') ? L'0' : L' ';
1397 wmemset (p, wc, delta);
1398 }
1399 p += incr;
1400 }
1401 i += incr;
1402 }
1403#else
1404 cpy (strlen (zone), zone);
1405#endif
1406 break;
1407
1408 case L_(':'):
1409 /* :, ::, and ::: are valid only just before 'z'.
1410 :::: etc. are rejected later. */
1411 for (colons = 1; f[colons] == L_(':'); colons++)
1412 continue;
1413 if (f[colons] != L_('z'))
1414 goto bad_format;
1415 f += colons;
1416 goto do_z_conversion;
1417
1418 case L_('z'):
1419 colons = 0;
1420
1421 do_z_conversion:
1422 if (tp->tm_isdst < 0)
1423 break;
1424
1425 {
1426 int diff;
1427 int hour_diff;
1428 int min_diff;
1429 int sec_diff;
1430#if HAVE_TM_GMTOFF
1431 diff = tp->tm_gmtoff;
1432#else
1433 if (!tz)
1434 diff = 0;
1435 else
1436 {
1437 struct tm gtm;
1438 struct tm ltm;
1439 time_t lt;
1440
1441 /* POSIX.1 requires that local time zone information be used as
1442 though strftime called tzset. */
1443# ifndef my_strftime
1444 if (!*tzset_called)
1445 {
1446 tzset ();
1447 *tzset_called = true;
1448 }
1449# endif
1450
1451 ltm = *tp;
1452 ltm.tm_wday = -1;
1453 lt = mktime_z (tz, &ltm);
1454 if (ltm.tm_wday < 0 || ! localtime_rz (0, &lt, &gtm))
1455 break;
1456 diff = tm_diff (&ltm, &gtm);
1457 }
1458#endif
1459
1460 negative_number = diff < 0 || (diff == 0 && *zone == '-');
1461 hour_diff = diff / 60 / 60;
1462 min_diff = diff / 60 % 60;
1463 sec_diff = diff % 60;
1464
1465 switch (colons)
1466 {
1467 case 0: /* +hhmm */
1468 DO_TZ_OFFSET (5, 0, hour_diff * 100 + min_diff);
1469
1470 case 1: tz_hh_mm: /* +hh:mm */
1471 DO_TZ_OFFSET (6, 04, hour_diff * 100 + min_diff);
1472
1473 case 2: tz_hh_mm_ss: /* +hh:mm:ss */
1474 DO_TZ_OFFSET (9, 024,
1475 hour_diff * 10000 + min_diff * 100 + sec_diff);
1476
1477 case 3: /* +hh if possible, else +hh:mm, else +hh:mm:ss */
1478 if (sec_diff != 0)
1479 goto tz_hh_mm_ss;
1480 if (min_diff != 0)
1481 goto tz_hh_mm;
1482 DO_TZ_OFFSET (3, 0, hour_diff);
1483
1484 default:
1485 goto bad_format;
1486 }
1487 }
1488
1489 case L_('\0'): /* GNU extension: % at end of format. */
1490 bad_percent:
1491 --f;
1492 FALLTHROUGH;
1493 default:
1494 /* Unknown format; output the format, including the '%',
1495 since this is most likely the right thing to do if a
1496 multibyte string has been misparsed. */
1497 bad_format:
1498 cpy (f - percent + 1, percent);
1499 break;
1500 }
1501 }
1502
1503#if ! FPRINTFTIME
1504 if (p && maxsize != 0)
1505 *p = L_('\0');
1506#endif
1507
1508 errno = saved_errno;
1509 return i;
1510}
diff --git a/lib/strftime.c b/lib/strftime.c
new file mode 100644
index 00000000000..128176cad40
--- /dev/null
+++ b/lib/strftime.c
@@ -0,0 +1,2051 @@
1/* Copyright (C) 1991-2024 Free Software Foundation, Inc.
2 This file is part of the GNU C Library.
3
4 This file is free software: you can redistribute it and/or modify
5 it under the terms of the GNU Lesser General Public License as
6 published by the Free Software Foundation, either version 3 of the
7 License, or (at your option) any later version.
8
9 This file is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU Lesser General Public License for more details.
13
14 You should have received a copy of the GNU Lesser General Public License
15 along with this program. If not, see <https://www.gnu.org/licenses/>. */
16
17#ifndef FPRINTFTIME
18# define FPRINTFTIME 0
19#endif
20
21#ifndef USE_C_LOCALE
22# define USE_C_LOCALE 0
23#endif
24
25#ifdef _LIBC
26# define USE_IN_EXTENDED_LOCALE_MODEL 1
27# define HAVE_STRUCT_ERA_ENTRY 1
28# define HAVE_TM_GMTOFF 1
29# define HAVE_STRUCT_TM_TM_ZONE 1
30# define HAVE_TZNAME 1
31# include "../locale/localeinfo.h"
32#else
33# include <libc-config.h>
34# if FPRINTFTIME
35# include "fprintftime.h"
36# else
37# include "strftime.h"
38# endif
39# include "time-internal.h"
40#endif
41
42/* Whether to require GNU behavior for AM and PM indicators, even on
43 other platforms. This matters only in non-C locales.
44 The default is to require it; you can override this via
45 AC_DEFINE([REQUIRE_GNUISH_STRFTIME_AM_PM], 1) and if you do that
46 you may be able to omit Gnulib's localename module and its dependencies. */
47#ifndef REQUIRE_GNUISH_STRFTIME_AM_PM
48# define REQUIRE_GNUISH_STRFTIME_AM_PM true
49#endif
50#if USE_C_LOCALE
51# undef REQUIRE_GNUISH_STRFTIME_AM_PM
52# define REQUIRE_GNUISH_STRFTIME_AM_PM false
53#endif
54
55#if USE_C_LOCALE
56# include "c-ctype.h"
57#else
58# include <ctype.h>
59#endif
60#include <errno.h>
61#include <time.h>
62
63#if HAVE_TZNAME && !HAVE_DECL_TZNAME
64extern char *tzname[];
65#endif
66
67/* Do multibyte processing if multibyte encodings are supported, unless
68 multibyte sequences are safe in formats. Multibyte sequences are
69 safe if they cannot contain byte sequences that look like format
70 conversion specifications. The multibyte encodings used by the
71 C library on the various platforms (UTF-8, GB2312, GBK, CP936,
72 GB18030, EUC-TW, BIG5, BIG5-HKSCS, CP950, EUC-JP, EUC-KR, CP949,
73 SHIFT_JIS, CP932, JOHAB) are safe for formats, because the byte '%'
74 cannot occur in a multibyte character except in the first byte.
75
76 The DEC-HANYU encoding used on OSF/1 is not safe for formats, but
77 this encoding has never been seen in real-life use, so we ignore
78 it. */
79#if !(defined __osf__ && 0)
80# define MULTIBYTE_IS_FORMAT_SAFE 1
81#endif
82#define DO_MULTIBYTE (! MULTIBYTE_IS_FORMAT_SAFE)
83
84#if DO_MULTIBYTE
85# include <wchar.h>
86 static const mbstate_t mbstate_zero;
87#endif
88
89#include <limits.h>
90#include <stdckdint.h>
91#include <stddef.h>
92#include <stdlib.h>
93#include <string.h>
94
95#if USE_C_LOCALE && HAVE_STRFTIME_L
96# include <locale.h>
97#endif
98
99#if (defined __NetBSD__ || defined __sun) && REQUIRE_GNUISH_STRFTIME_AM_PM
100# include <locale.h>
101# include "localename.h"
102#endif
103
104#include "attribute.h"
105#include <intprops.h>
106
107#ifdef COMPILE_WIDE
108# include <endian.h>
109# define CHAR_T wchar_t
110# define UCHAR_T unsigned int
111# define L_(Str) L##Str
112# define NLW(Sym) _NL_W##Sym
113
114# define MEMCPY(d, s, n) __wmemcpy (d, s, n)
115# define STRLEN(s) __wcslen (s)
116
117#else
118# define CHAR_T char
119# define UCHAR_T unsigned char
120# define L_(Str) Str
121# define NLW(Sym) Sym
122# define ABALTMON_1 _NL_ABALTMON_1
123
124# define MEMCPY(d, s, n) memcpy (d, s, n)
125# define STRLEN(s) strlen (s)
126
127#endif
128
129/* Shift A right by B bits portably, by dividing A by 2**B and
130 truncating towards minus infinity. A and B should be free of side
131 effects, and B should be in the range 0 <= B <= INT_BITS - 2, where
132 INT_BITS is the number of useful bits in an int. GNU code can
133 assume that INT_BITS is at least 32.
134
135 ISO C99 says that A >> B is implementation-defined if A < 0. Some
136 implementations (e.g., UNICOS 9.0 on a Cray Y-MP EL) don't shift
137 right in the usual way when A < 0, so SHR falls back on division if
138 ordinary A >> B doesn't seem to be the usual signed shift. */
139#define SHR(a, b) \
140 (-1 >> 1 == -1 \
141 ? (a) >> (b) \
142 : ((a) + ((a) < 0)) / (1 << (b)) - ((a) < 0))
143
144#define TM_YEAR_BASE 1900
145
146#ifndef __isleap
147/* Nonzero if YEAR is a leap year (every 4 years,
148 except every 100th isn't, and every 400th is). */
149# define __isleap(year) \
150 ((year) % 4 == 0 && ((year) % 100 != 0 || (year) % 400 == 0))
151#endif
152
153
154#ifdef _LIBC
155# define mktime_z(tz, tm) mktime (tm)
156# define tzname __tzname
157# define tzset __tzset
158
159# define time_t __time64_t
160# define __gmtime_r(t, tp) __gmtime64_r (t, tp)
161# define mktime(tp) __mktime64 (tp)
162#endif
163
164#if FPRINTFTIME
165# define STREAM_OR_CHAR_T FILE
166# define STRFTIME_ARG(x) /* empty */
167#else
168# define STREAM_OR_CHAR_T CHAR_T
169# define STRFTIME_ARG(x) x,
170#endif
171
172#if FPRINTFTIME
173# define memset_byte(P, Len, Byte) \
174 do { size_t _i; for (_i = 0; _i < Len; _i++) fputc (Byte, P); } while (0)
175# define memset_space(P, Len) memset_byte (P, Len, ' ')
176# define memset_zero(P, Len) memset_byte (P, Len, '0')
177#elif defined COMPILE_WIDE
178# define memset_space(P, Len) (wmemset (P, L' ', Len), (P) += (Len))
179# define memset_zero(P, Len) (wmemset (P, L'0', Len), (P) += (Len))
180#else
181# define memset_space(P, Len) (memset (P, ' ', Len), (P) += (Len))
182# define memset_zero(P, Len) (memset (P, '0', Len), (P) += (Len))
183#endif
184
185#if FPRINTFTIME
186# define advance(P, N)
187#else
188# define advance(P, N) ((P) += (N))
189#endif
190
191#define add(n, f) width_add (width, n, f)
192#define width_add(width, n, f) \
193 do \
194 { \
195 size_t _n = (n); \
196 size_t _w = pad == L_('-') || width < 0 ? 0 : width; \
197 size_t _incr = _n < _w ? _w : _n; \
198 if (_incr >= maxsize - i) \
199 { \
200 errno = ERANGE; \
201 return 0; \
202 } \
203 if (p) \
204 { \
205 if (_n < _w) \
206 { \
207 size_t _delta = _w - _n; \
208 if (pad == L_('0') || pad == L_('+')) \
209 memset_zero (p, _delta); \
210 else \
211 memset_space (p, _delta); \
212 } \
213 f; \
214 advance (p, _n); \
215 } \
216 i += _incr; \
217 } while (0)
218
219#define add1(c) width_add1 (width, c)
220#if FPRINTFTIME
221# define width_add1(width, c) width_add (width, 1, fputc (c, p))
222#else
223# define width_add1(width, c) width_add (width, 1, *p = c)
224#endif
225
226#define cpy(n, s) width_cpy (width, n, s)
227#if FPRINTFTIME
228# define width_cpy(width, n, s) \
229 width_add (width, n, \
230 do \
231 { \
232 if (to_lowcase) \
233 fwrite_lowcase (p, (s), _n); \
234 else if (to_uppcase) \
235 fwrite_uppcase (p, (s), _n); \
236 else \
237 { \
238 /* Ignore the value of fwrite. The caller can determine whether \
239 an error occurred by inspecting ferror (P). All known fwrite \
240 implementations set the stream's error indicator when they \
241 fail due to ENOMEM etc., even though C11 and POSIX.1-2008 do \
242 not require this. */ \
243 fwrite (s, _n, 1, p); \
244 } \
245 } \
246 while (0) \
247 )
248#else
249# define width_cpy(width, n, s) \
250 width_add (width, n, \
251 if (to_lowcase) \
252 memcpy_lowcase (p, (s), _n LOCALE_ARG); \
253 else if (to_uppcase) \
254 memcpy_uppcase (p, (s), _n LOCALE_ARG); \
255 else \
256 MEMCPY ((void *) p, (void const *) (s), _n))
257#endif
258
259#ifdef COMPILE_WIDE
260# ifndef USE_IN_EXTENDED_LOCALE_MODEL
261# undef __mbsrtowcs_l
262# define __mbsrtowcs_l(d, s, l, st, loc) __mbsrtowcs (d, s, l, st)
263# endif
264#endif
265
266
267#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
268/* We use this code also for the extended locale handling where the
269 function gets as an additional argument the locale which has to be
270 used. To access the values we have to redefine the _NL_CURRENT
271 macro. */
272# define strftime __strftime_l
273# define wcsftime __wcsftime_l
274# undef _NL_CURRENT
275# define _NL_CURRENT(category, item) \
276 (current->values[_NL_ITEM_INDEX (item)].string)
277# define LOCALE_PARAM , locale_t loc
278# define LOCALE_ARG , loc
279# define HELPER_LOCALE_ARG , current
280#else
281# define LOCALE_PARAM
282# define LOCALE_ARG
283# ifdef _LIBC
284# define HELPER_LOCALE_ARG , _NL_CURRENT_DATA (LC_TIME)
285# else
286# define HELPER_LOCALE_ARG
287# endif
288#endif
289
290#ifdef COMPILE_WIDE
291# ifdef USE_IN_EXTENDED_LOCALE_MODEL
292# define TOUPPER(Ch, L) __towupper_l (Ch, L)
293# define TOLOWER(Ch, L) __towlower_l (Ch, L)
294# else
295# define TOUPPER(Ch, L) towupper (Ch)
296# define TOLOWER(Ch, L) towlower (Ch)
297# endif
298#else
299# ifdef USE_IN_EXTENDED_LOCALE_MODEL
300# define TOUPPER(Ch, L) __toupper_l (Ch, L)
301# define TOLOWER(Ch, L) __tolower_l (Ch, L)
302# else
303# if USE_C_LOCALE
304# define TOUPPER(Ch, L) c_toupper (Ch)
305# define TOLOWER(Ch, L) c_tolower (Ch)
306# else
307# define TOUPPER(Ch, L) toupper (Ch)
308# define TOLOWER(Ch, L) tolower (Ch)
309# endif
310# endif
311#endif
312/* We don't use 'isdigit' here since the locale dependent
313 interpretation is not what we want here. We only need to accept
314 the arabic digits in the ASCII range. One day there is perhaps a
315 more reliable way to accept other sets of digits. */
316#define ISDIGIT(Ch) ((unsigned int) (Ch) - L_('0') <= 9)
317
318/* Avoid false GCC warning "'memset' specified size 18446744073709551615 exceeds
319 maximum object size 9223372036854775807", caused by insufficient data flow
320 analysis and value propagation of the 'width_add' expansion when GCC is not
321 optimizing. Cf. <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=88443>. */
322#if __GNUC__ >= 7 && !__OPTIMIZE__
323# pragma GCC diagnostic ignored "-Wstringop-overflow"
324#endif
325
326#if FPRINTFTIME
327static void
328fwrite_lowcase (FILE *fp, const CHAR_T *src, size_t len)
329{
330 while (len-- > 0)
331 {
332 fputc (TOLOWER ((UCHAR_T) *src, loc), fp);
333 ++src;
334 }
335}
336
337static void
338fwrite_uppcase (FILE *fp, const CHAR_T *src, size_t len)
339{
340 while (len-- > 0)
341 {
342 fputc (TOUPPER ((UCHAR_T) *src, loc), fp);
343 ++src;
344 }
345}
346#else
347static CHAR_T *memcpy_lowcase (CHAR_T *dest, const CHAR_T *src,
348 size_t len LOCALE_PARAM);
349
350static CHAR_T *
351memcpy_lowcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
352{
353 while (len-- > 0)
354 dest[len] = TOLOWER ((UCHAR_T) src[len], loc);
355 return dest;
356}
357
358static CHAR_T *memcpy_uppcase (CHAR_T *dest, const CHAR_T *src,
359 size_t len LOCALE_PARAM);
360
361static CHAR_T *
362memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
363{
364 while (len-- > 0)
365 dest[len] = TOUPPER ((UCHAR_T) src[len], loc);
366 return dest;
367}
368#endif
369
370
371#if USE_C_LOCALE && HAVE_STRFTIME_L
372
373/* Cache for the C locale object.
374 Marked volatile so that different threads see the same value
375 (avoids locking). */
376static volatile locale_t c_locale_cache;
377
378/* Return the C locale object, or (locale_t) 0 with errno set
379 if it cannot be created. */
380static locale_t
381c_locale (void)
382{
383 if (!c_locale_cache)
384 c_locale_cache = newlocale (LC_ALL_MASK, "C", (locale_t) 0);
385 return c_locale_cache;
386}
387
388#endif
389
390
391#if (defined __NetBSD__ || defined __sun) && REQUIRE_GNUISH_STRFTIME_AM_PM
392
393/* Return true if an AM/PM indicator should be removed. */
394static bool
395should_remove_ampm (void)
396{
397 /* According to glibc's 'am_pm' attribute in the locale database, an AM/PM
398 indicator should be absent in the locales for the following languages:
399 ab an ast az be ber bg br bs ce cs csb cv da de dsb eo et eu fa fi fo fr
400 fur fy ga gl gv hr hsb ht hu hy it ka kk kl ku kv kw ky lb lg li lij ln
401 lt lv mg mhr mi mk mn ms mt nb nds nhn nl nn nr nso oc os pap pl pt ro
402 ru rw sah sc se sgs sk sl sm sr ss st su sv szl tg tk tn ts tt ug uk unm
403 uz ve wae wo xh zu */
404 const char *loc = gl_locale_name_unsafe (LC_TIME, "LC_TIME");
405 bool remove_ampm = false;
406 switch (loc[0])
407 {
408 case 'a':
409 switch (loc[1])
410 {
411 case 'b': case 'n': case 'z':
412 if (loc[2] == '\0' || loc[2] == '_')
413 remove_ampm = true;
414 break;
415 case 's':
416 if (loc[2] == 't' && (loc[3] == '\0' || loc[3] == '_'))
417 remove_ampm = true;
418 break;
419 default:
420 break;
421 }
422 break;
423 case 'b':
424 switch (loc[1])
425 {
426 case 'e':
427 if (loc[2] == '\0' || loc[2] == '_'
428 || (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_')))
429 remove_ampm = true;
430 break;
431 case 'g': case 'r': case 's':
432 if (loc[2] == '\0' || loc[2] == '_')
433 remove_ampm = true;
434 break;
435 default:
436 break;
437 }
438 break;
439 case 'c':
440 switch (loc[1])
441 {
442 case 'e': case 'v':
443 if (loc[2] == '\0' || loc[2] == '_')
444 remove_ampm = true;
445 break;
446 case 's':
447 if (loc[2] == '\0' || loc[2] == '_'
448 || (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_')))
449 remove_ampm = true;
450 break;
451 default:
452 break;
453 }
454 break;
455 case 'd':
456 switch (loc[1])
457 {
458 case 'a': case 'e':
459 if (loc[2] == '\0' || loc[2] == '_')
460 remove_ampm = true;
461 break;
462 case 's':
463 if (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_'))
464 remove_ampm = true;
465 break;
466 default:
467 break;
468 }
469 break;
470 case 'e':
471 switch (loc[1])
472 {
473 case 'o': case 't': case 'u':
474 if (loc[2] == '\0' || loc[2] == '_')
475 remove_ampm = true;
476 break;
477 default:
478 break;
479 }
480 break;
481 case 'f':
482 switch (loc[1])
483 {
484 case 'a': case 'i': case 'o': case 'r': case 'y':
485 if (loc[2] == '\0' || loc[2] == '_')
486 remove_ampm = true;
487 break;
488 case 'u':
489 if (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_'))
490 remove_ampm = true;
491 break;
492 default:
493 break;
494 }
495 break;
496 case 'g':
497 switch (loc[1])
498 {
499 case 'a': case 'l': case 'v':
500 if (loc[2] == '\0' || loc[2] == '_')
501 remove_ampm = true;
502 break;
503 default:
504 break;
505 }
506 break;
507 case 'h':
508 switch (loc[1])
509 {
510 case 'r': case 't': case 'u': case 'y':
511 if (loc[2] == '\0' || loc[2] == '_')
512 remove_ampm = true;
513 break;
514 case 's':
515 if (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_'))
516 remove_ampm = true;
517 break;
518 default:
519 break;
520 }
521 break;
522 case 'i':
523 switch (loc[1])
524 {
525 case 't':
526 if (loc[2] == '\0' || loc[2] == '_')
527 remove_ampm = true;
528 break;
529 default:
530 break;
531 }
532 break;
533 case 'k':
534 switch (loc[1])
535 {
536 case 'a': case 'k': case 'l': case 'u': case 'v': case 'w': case 'y':
537 if (loc[2] == '\0' || loc[2] == '_')
538 remove_ampm = true;
539 break;
540 default:
541 break;
542 }
543 break;
544 case 'l':
545 switch (loc[1])
546 {
547 case 'b': case 'g': case 'n': case 't': case 'v':
548 if (loc[2] == '\0' || loc[2] == '_')
549 remove_ampm = true;
550 break;
551 case 'i':
552 if (loc[2] == 'j' && (loc[3] == '\0' || loc[3] == '_'))
553 remove_ampm = true;
554 break;
555 default:
556 break;
557 }
558 break;
559 case 'm':
560 switch (loc[1])
561 {
562 case 'g': case 'i': case 'k': case 'n': case 's': case 't':
563 if (loc[2] == '\0' || loc[2] == '_')
564 remove_ampm = true;
565 break;
566 case 'h':
567 if (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_'))
568 remove_ampm = true;
569 break;
570 default:
571 break;
572 }
573 break;
574 case 'n':
575 switch (loc[1])
576 {
577 case 'b': case 'l': case 'n': case 'r':
578 if (loc[2] == '\0' || loc[2] == '_')
579 remove_ampm = true;
580 break;
581 case 'd':
582 if (loc[2] == 's' && (loc[3] == '\0' || loc[3] == '_'))
583 remove_ampm = true;
584 break;
585 case 'h':
586 if (loc[2] == 'n' && (loc[3] == '\0' || loc[3] == '_'))
587 remove_ampm = true;
588 break;
589 case 's':
590 if (loc[2] == 'o' && (loc[3] == '\0' || loc[3] == '_'))
591 remove_ampm = true;
592 break;
593 default:
594 break;
595 }
596 break;
597 case 'o':
598 switch (loc[1])
599 {
600 case 'c': case 's':
601 if (loc[2] == '\0' || loc[2] == '_')
602 remove_ampm = true;
603 break;
604 default:
605 break;
606 }
607 break;
608 case 'p':
609 switch (loc[1])
610 {
611 case 'l': case 't':
612 if (loc[2] == '\0' || loc[2] == '_')
613 remove_ampm = true;
614 break;
615 case 'a':
616 if (loc[2] == 'p' && (loc[3] == '\0' || loc[3] == '_'))
617 remove_ampm = true;
618 break;
619 default:
620 break;
621 }
622 break;
623 case 'r':
624 switch (loc[1])
625 {
626 case 'o': case 'u': case 'w':
627 if (loc[2] == '\0' || loc[2] == '_')
628 remove_ampm = true;
629 break;
630 default:
631 break;
632 }
633 break;
634 case 's':
635 switch (loc[1])
636 {
637 case 'c': case 'e': case 'k': case 'l': case 'm': case 'r': case 's':
638 case 't': case 'u': case 'v':
639 if (loc[2] == '\0' || loc[2] == '_')
640 remove_ampm = true;
641 break;
642 case 'a':
643 if (loc[2] == 'h' && (loc[3] == '\0' || loc[3] == '_'))
644 remove_ampm = true;
645 break;
646 case 'g':
647 if (loc[2] == 's' && (loc[3] == '\0' || loc[3] == '_'))
648 remove_ampm = true;
649 break;
650 case 'z':
651 if (loc[2] == 'l' && (loc[3] == '\0' || loc[3] == '_'))
652 remove_ampm = true;
653 break;
654 default:
655 break;
656 }
657 break;
658 case 't':
659 switch (loc[1])
660 {
661 case 'g': case 'k': case 'n': case 's': case 't':
662 if (loc[2] == '\0' || loc[2] == '_')
663 remove_ampm = true;
664 break;
665 default:
666 break;
667 }
668 break;
669 case 'u':
670 switch (loc[1])
671 {
672 case 'g': case 'k': case 'z':
673 if (loc[2] == '\0' || loc[2] == '_')
674 remove_ampm = true;
675 break;
676 case 'n':
677 if (loc[2] == 'm'&& (loc[3] == '\0' || loc[3] == '_'))
678 remove_ampm = true;
679 break;
680 default:
681 break;
682 }
683 break;
684 case 'v':
685 switch (loc[1])
686 {
687 case 'e':
688 if (loc[2] == '\0' || loc[2] == '_')
689 remove_ampm = true;
690 break;
691 default:
692 break;
693 }
694 break;
695 case 'w':
696 switch (loc[1])
697 {
698 case 'a':
699 if (loc[2] == 'e' && (loc[3] == '\0' || loc[3] == '_'))
700 remove_ampm = true;
701 break;
702 case 'o':
703 if (loc[2] == '\0' || loc[2] == '_')
704 remove_ampm = true;
705 break;
706 default:
707 break;
708 }
709 break;
710 case 'x':
711 switch (loc[1])
712 {
713 case 'h':
714 if (loc[2] == '\0' || loc[2] == '_')
715 remove_ampm = true;
716 break;
717 default:
718 break;
719 }
720 break;
721 case 'z':
722 switch (loc[1])
723 {
724 case 'u':
725 if (loc[2] == '\0' || loc[2] == '_')
726 remove_ampm = true;
727 break;
728 default:
729 break;
730 }
731 break;
732 default:
733 break;
734 }
735 return remove_ampm;
736}
737
738#endif
739
740
741#if ! HAVE_TM_GMTOFF
742/* Yield the difference between *A and *B,
743 measured in seconds, ignoring leap seconds. */
744# define tm_diff ftime_tm_diff
745static int tm_diff (const struct tm *, const struct tm *);
746static int
747tm_diff (const struct tm *a, const struct tm *b)
748{
749 /* Compute intervening leap days correctly even if year is negative.
750 Take care to avoid int overflow in leap day calculations,
751 but it's OK to assume that A and B are close to each other. */
752 int a4 = SHR (a->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (a->tm_year & 3);
753 int b4 = SHR (b->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (b->tm_year & 3);
754 int a100 = (a4 + (a4 < 0)) / 25 - (a4 < 0);
755 int b100 = (b4 + (b4 < 0)) / 25 - (b4 < 0);
756 int a400 = SHR (a100, 2);
757 int b400 = SHR (b100, 2);
758 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
759 int years = a->tm_year - b->tm_year;
760 int days = (365 * years + intervening_leap_days
761 + (a->tm_yday - b->tm_yday));
762 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
763 + (a->tm_min - b->tm_min))
764 + (a->tm_sec - b->tm_sec));
765}
766#endif /* ! HAVE_TM_GMTOFF */
767
768
769
770/* The number of days from the first day of the first ISO week of this
771 year to the year day YDAY with week day WDAY. ISO weeks start on
772 Monday; the first ISO week has the year's first Thursday. YDAY may
773 be as small as YDAY_MINIMUM. */
774#define ISO_WEEK_START_WDAY 1 /* Monday */
775#define ISO_WEEK1_WDAY 4 /* Thursday */
776#define YDAY_MINIMUM (-366)
777static int iso_week_days (int, int);
778static __inline int
779iso_week_days (int yday, int wday)
780{
781 /* Add enough to the first operand of % to make it nonnegative. */
782 int big_enough_multiple_of_7 = (-YDAY_MINIMUM / 7 + 2) * 7;
783 return (yday
784 - (yday - wday + ISO_WEEK1_WDAY + big_enough_multiple_of_7) % 7
785 + ISO_WEEK1_WDAY - ISO_WEEK_START_WDAY);
786}
787
788
789#if !defined _NL_CURRENT && (USE_C_LOCALE && !HAVE_STRFTIME_L)
790static CHAR_T const c_weekday_names[][sizeof "Wednesday"] =
791 {
792 L_("Sunday"), L_("Monday"), L_("Tuesday"), L_("Wednesday"),
793 L_("Thursday"), L_("Friday"), L_("Saturday")
794 };
795static CHAR_T const c_month_names[][sizeof "September"] =
796 {
797 L_("January"), L_("February"), L_("March"), L_("April"), L_("May"),
798 L_("June"), L_("July"), L_("August"), L_("September"), L_("October"),
799 L_("November"), L_("December")
800 };
801#endif
802
803
804/* When compiling this file, GNU applications can #define my_strftime
805 to a symbol (typically nstrftime) to get an extended strftime with
806 extra arguments TZ and NS. */
807
808#ifdef my_strftime
809# define extra_args , tz, ns
810# define extra_args_spec , timezone_t tz, int ns
811#else
812# if defined COMPILE_WIDE
813# define my_strftime wcsftime
814# define nl_get_alt_digit _nl_get_walt_digit
815# else
816# define my_strftime strftime
817# define nl_get_alt_digit _nl_get_alt_digit
818# endif
819# define extra_args
820# define extra_args_spec
821/* We don't have this information in general. */
822# define tz 1
823# define ns 0
824#endif
825
826static size_t __strftime_internal (STREAM_OR_CHAR_T *, STRFTIME_ARG (size_t)
827 const CHAR_T *, const struct tm *,
828 bool, int, int, bool *
829 extra_args_spec LOCALE_PARAM);
830
831/* Write information from TP into S according to the format
832 string FORMAT, writing no more that MAXSIZE characters
833 (including the terminating '\0') and returning number of
834 characters written. If S is NULL, nothing will be written
835 anywhere, so to determine how many characters would be
836 written, use NULL for S and (size_t) -1 for MAXSIZE. */
837size_t
838my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
839 const CHAR_T *format,
840 const struct tm *tp extra_args_spec LOCALE_PARAM)
841{
842 bool tzset_called = false;
843 return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, false,
844 0, -1, &tzset_called extra_args LOCALE_ARG);
845}
846libc_hidden_def (my_strftime)
847
848/* Just like my_strftime, above, but with more parameters.
849 UPCASE indicates that the result should be converted to upper case.
850 YR_SPEC and WIDTH specify the padding and width for the year.
851 *TZSET_CALLED indicates whether tzset has been called here. */
852static size_t
853__strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
854 const CHAR_T *format,
855 const struct tm *tp, bool upcase,
856 int yr_spec, int width, bool *tzset_called
857 extra_args_spec LOCALE_PARAM)
858{
859#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
860 struct __locale_data *const current = loc->__locales[LC_TIME];
861#endif
862#if FPRINTFTIME
863 size_t maxsize = (size_t) -1;
864#endif
865
866 int saved_errno = errno;
867 int hour12 = tp->tm_hour;
868#ifdef _NL_CURRENT
869 /* We cannot make the following values variables since we must delay
870 the evaluation of these values until really needed since some
871 expressions might not be valid in every situation. The 'struct tm'
872 might be generated by a strptime() call that initialized
873 only a few elements. Dereference the pointers only if the format
874 requires this. Then it is ok to fail if the pointers are invalid. */
875# define a_wkday \
876 ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
877 ? "?" : _NL_CURRENT (LC_TIME, NLW(ABDAY_1) + tp->tm_wday)))
878# define f_wkday \
879 ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
880 ? "?" : _NL_CURRENT (LC_TIME, NLW(DAY_1) + tp->tm_wday)))
881# define a_month \
882 ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
883 ? "?" : _NL_CURRENT (LC_TIME, NLW(ABMON_1) + tp->tm_mon)))
884# define f_month \
885 ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
886 ? "?" : _NL_CURRENT (LC_TIME, NLW(MON_1) + tp->tm_mon)))
887# define a_altmonth \
888 ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
889 ? "?" : _NL_CURRENT (LC_TIME, NLW(ABALTMON_1) + tp->tm_mon)))
890# define f_altmonth \
891 ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
892 ? "?" : _NL_CURRENT (LC_TIME, NLW(ALTMON_1) + tp->tm_mon)))
893# define ampm \
894 ((const CHAR_T *) _NL_CURRENT (LC_TIME, tp->tm_hour > 11 \
895 ? NLW(PM_STR) : NLW(AM_STR)))
896
897# define aw_len STRLEN (a_wkday)
898# define am_len STRLEN (a_month)
899# define aam_len STRLEN (a_altmonth)
900# define ap_len STRLEN (ampm)
901#elif USE_C_LOCALE && !HAVE_STRFTIME_L
902/* The English abbreviated weekday names are just the first 3 characters of the
903 English full weekday names. */
904# define a_wkday \
905 (tp->tm_wday < 0 || tp->tm_wday > 6 ? L_("?") : c_weekday_names[tp->tm_wday])
906# define aw_len 3
907# define f_wkday \
908 (tp->tm_wday < 0 || tp->tm_wday > 6 ? L_("?") : c_weekday_names[tp->tm_wday])
909/* The English abbreviated month names are just the first 3 characters of the
910 English full month names. */
911# define a_month \
912 (tp->tm_mon < 0 || tp->tm_mon > 11 ? L_("?") : c_month_names[tp->tm_mon])
913# define am_len 3
914# define f_month \
915 (tp->tm_mon < 0 || tp->tm_mon > 11 ? L_("?") : c_month_names[tp->tm_mon])
916/* The English AM/PM strings happen to have the same length, namely 2. */
917# define ampm (L_("AMPM") + 2 * (tp->tm_hour > 11))
918# define ap_len 2
919#endif
920#if HAVE_TZNAME
921 char **tzname_vec = tzname;
922#endif
923 const char *zone;
924 size_t i = 0;
925 STREAM_OR_CHAR_T *p = s;
926 const CHAR_T *f;
927#if DO_MULTIBYTE && !defined COMPILE_WIDE
928 const char *format_end = NULL;
929#endif
930
931 zone = NULL;
932#if HAVE_STRUCT_TM_TM_ZONE
933 /* The POSIX test suite assumes that setting
934 the environment variable TZ to a new value before calling strftime()
935 will influence the result (the %Z format) even if the information in
936 TP is computed with a totally different time zone.
937 This is bogus: though POSIX allows bad behavior like this,
938 POSIX does not require it. Do the right thing instead. */
939 zone = (const char *) tp->tm_zone;
940#endif
941#if HAVE_TZNAME
942 if (!tz)
943 {
944 if (! (zone && *zone))
945 zone = "GMT";
946 }
947 else
948 {
949# if !HAVE_STRUCT_TM_TM_ZONE
950 /* Infer the zone name from *TZ instead of from TZNAME. */
951 tzname_vec = tz->tzname_copy;
952# endif
953 }
954 /* The tzset() call might have changed the value. */
955 if (!(zone && *zone) && tp->tm_isdst >= 0)
956 {
957 /* POSIX.1 requires that local time zone information be used as
958 though strftime called tzset. */
959# ifndef my_strftime
960 if (!*tzset_called)
961 {
962 tzset ();
963 *tzset_called = true;
964 }
965# endif
966 zone = tzname_vec[tp->tm_isdst != 0];
967 }
968#endif
969 if (! zone)
970 zone = "";
971
972 if (hour12 > 12)
973 hour12 -= 12;
974 else
975 if (hour12 == 0)
976 hour12 = 12;
977
978 for (f = format; *f != '\0'; width = -1, f++)
979 {
980 int pad = 0; /* Padding for number ('_', '-', '+', '0', or 0). */
981 int modifier; /* Field modifier ('E', 'O', or 0). */
982 int digits = 0; /* Max digits for numeric format. */
983 int number_value; /* Numeric value to be printed. */
984 unsigned int u_number_value; /* (unsigned int) number_value. */
985 bool negative_number; /* The number is negative. */
986 bool always_output_a_sign; /* +/- should always be output. */
987 int tz_colon_mask; /* Bitmask of where ':' should appear. */
988 const CHAR_T *subfmt;
989 CHAR_T *bufp;
990 CHAR_T buf[1
991 + 2 /* for the two colons in a %::z or %:::z time zone */
992 + (sizeof (int) < sizeof (time_t)
993 ? INT_STRLEN_BOUND (time_t)
994 : INT_STRLEN_BOUND (int))];
995 bool to_lowcase = false;
996 bool to_uppcase = upcase;
997 size_t colons;
998 bool change_case = false;
999 int format_char;
1000 int subwidth;
1001
1002#if DO_MULTIBYTE && !defined COMPILE_WIDE
1003 switch (*f)
1004 {
1005 case L_('%'):
1006 break;
1007
1008 case L_('\b'): case L_('\t'): case L_('\n'):
1009 case L_('\v'): case L_('\f'): case L_('\r'):
1010 case L_(' '): case L_('!'): case L_('"'): case L_('#'): case L_('&'):
1011 case L_('\''): case L_('('): case L_(')'): case L_('*'): case L_('+'):
1012 case L_(','): case L_('-'): case L_('.'): case L_('/'): case L_('0'):
1013 case L_('1'): case L_('2'): case L_('3'): case L_('4'): case L_('5'):
1014 case L_('6'): case L_('7'): case L_('8'): case L_('9'): case L_(':'):
1015 case L_(';'): case L_('<'): case L_('='): case L_('>'): case L_('?'):
1016 case L_('A'): case L_('B'): case L_('C'): case L_('D'): case L_('E'):
1017 case L_('F'): case L_('G'): case L_('H'): case L_('I'): case L_('J'):
1018 case L_('K'): case L_('L'): case L_('M'): case L_('N'): case L_('O'):
1019 case L_('P'): case L_('Q'): case L_('R'): case L_('S'): case L_('T'):
1020 case L_('U'): case L_('V'): case L_('W'): case L_('X'): case L_('Y'):
1021 case L_('Z'): case L_('['): case L_('\\'): case L_(']'): case L_('^'):
1022 case L_('_'): case L_('a'): case L_('b'): case L_('c'): case L_('d'):
1023 case L_('e'): case L_('f'): case L_('g'): case L_('h'): case L_('i'):
1024 case L_('j'): case L_('k'): case L_('l'): case L_('m'): case L_('n'):
1025 case L_('o'): case L_('p'): case L_('q'): case L_('r'): case L_('s'):
1026 case L_('t'): case L_('u'): case L_('v'): case L_('w'): case L_('x'):
1027 case L_('y'): case L_('z'): case L_('{'): case L_('|'): case L_('}'):
1028 case L_('~'):
1029 /* The C Standard requires these 98 characters (plus '%') to
1030 be in the basic execution character set. None of these
1031 characters can start a multibyte sequence, so they need
1032 not be analyzed further. */
1033 add1 (*f);
1034 continue;
1035
1036 default:
1037 /* Copy this multibyte sequence until we reach its end, find
1038 an error, or come back to the initial shift state. */
1039 {
1040 mbstate_t mbstate = mbstate_zero;
1041 size_t len = 0;
1042 size_t fsize;
1043
1044 if (! format_end)
1045 format_end = f + strlen (f) + 1;
1046 fsize = format_end - f;
1047
1048 do
1049 {
1050 size_t bytes = mbrlen (f + len, fsize - len, &mbstate);
1051
1052 if (bytes == 0)
1053 break;
1054
1055 if (bytes == (size_t) -2)
1056 {
1057 len += strlen (f + len);
1058 break;
1059 }
1060
1061 if (bytes == (size_t) -1)
1062 {
1063 len++;
1064 break;
1065 }
1066
1067 len += bytes;
1068 }
1069 while (! mbsinit (&mbstate));
1070
1071 cpy (len, f);
1072 f += len - 1;
1073 continue;
1074 }
1075 }
1076
1077#else /* ! DO_MULTIBYTE */
1078
1079 /* Either multibyte encodings are not supported, they are
1080 safe for formats, so any non-'%' byte can be copied through,
1081 or this is the wide character version. */
1082 if (*f != L_('%'))
1083 {
1084 add1 (*f);
1085 continue;
1086 }
1087
1088#endif /* ! DO_MULTIBYTE */
1089
1090 char const *percent = f;
1091
1092 /* Check for flags that can modify a format. */
1093 while (1)
1094 {
1095 switch (*++f)
1096 {
1097 /* This influences the number formats. */
1098 case L_('_'):
1099 case L_('-'):
1100 case L_('+'):
1101 case L_('0'):
1102 pad = *f;
1103 continue;
1104
1105 /* This changes textual output. */
1106 case L_('^'):
1107 to_uppcase = true;
1108 continue;
1109 case L_('#'):
1110 change_case = true;
1111 continue;
1112
1113 default:
1114 break;
1115 }
1116 break;
1117 }
1118
1119 if (ISDIGIT (*f))
1120 {
1121 width = 0;
1122 do
1123 {
1124 if (ckd_mul (&width, width, 10)
1125 || ckd_add (&width, width, *f - L_('0')))
1126 width = INT_MAX;
1127 ++f;
1128 }
1129 while (ISDIGIT (*f));
1130 }
1131
1132 /* Check for modifiers. */
1133 switch (*f)
1134 {
1135 case L_('E'):
1136 case L_('O'):
1137 modifier = *f++;
1138 break;
1139
1140 default:
1141 modifier = 0;
1142 break;
1143 }
1144
1145 /* Now do the specified format. */
1146 format_char = *f;
1147 switch (format_char)
1148 {
1149#define DO_NUMBER(d, v) \
1150 do \
1151 { \
1152 digits = d; \
1153 number_value = v; \
1154 goto do_number; \
1155 } \
1156 while (0)
1157#define DO_SIGNED_NUMBER(d, negative, v) \
1158 DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_signed_number)
1159#define DO_YEARISH(d, negative, v) \
1160 DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_yearish)
1161#define DO_MAYBE_SIGNED_NUMBER(d, negative, v, label) \
1162 do \
1163 { \
1164 digits = d; \
1165 negative_number = negative; \
1166 u_number_value = v; \
1167 goto label; \
1168 } \
1169 while (0)
1170
1171 /* The mask is not what you might think.
1172 When the ordinal i'th bit is set, insert a colon
1173 before the i'th digit of the time zone representation. */
1174#define DO_TZ_OFFSET(d, mask, v) \
1175 do \
1176 { \
1177 digits = d; \
1178 tz_colon_mask = mask; \
1179 u_number_value = v; \
1180 goto do_tz_offset; \
1181 } \
1182 while (0)
1183#define DO_NUMBER_SPACEPAD(d, v) \
1184 do \
1185 { \
1186 digits = d; \
1187 number_value = v; \
1188 goto do_number_spacepad; \
1189 } \
1190 while (0)
1191
1192 case L_('%'):
1193 if (f - 1 != percent)
1194 goto bad_percent;
1195 add1 (*f);
1196 break;
1197
1198 case L_('a'):
1199 if (modifier != 0)
1200 goto bad_format;
1201 if (change_case)
1202 {
1203 to_uppcase = true;
1204 to_lowcase = false;
1205 }
1206#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
1207 cpy (aw_len, a_wkday);
1208 break;
1209#else
1210 goto underlying_strftime;
1211#endif
1212
1213 case 'A':
1214 if (modifier != 0)
1215 goto bad_format;
1216 if (change_case)
1217 {
1218 to_uppcase = true;
1219 to_lowcase = false;
1220 }
1221#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
1222 cpy (STRLEN (f_wkday), f_wkday);
1223 break;
1224#else
1225 goto underlying_strftime;
1226#endif
1227
1228 case L_('b'):
1229 case L_('h'):
1230 if (change_case)
1231 {
1232 to_uppcase = true;
1233 to_lowcase = false;
1234 }
1235 if (modifier == L_('E'))
1236 goto bad_format;
1237#ifdef _NL_CURRENT
1238 if (modifier == L_('O'))
1239 cpy (aam_len, a_altmonth);
1240 else
1241 cpy (am_len, a_month);
1242 break;
1243#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1244 cpy (am_len, a_month);
1245 break;
1246#else
1247 goto underlying_strftime;
1248#endif
1249
1250 case L_('B'):
1251 if (modifier == L_('E'))
1252 goto bad_format;
1253 if (change_case)
1254 {
1255 to_uppcase = true;
1256 to_lowcase = false;
1257 }
1258#ifdef _NL_CURRENT
1259 if (modifier == L_('O'))
1260 cpy (STRLEN (f_altmonth), f_altmonth);
1261 else
1262 cpy (STRLEN (f_month), f_month);
1263 break;
1264#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1265 cpy (STRLEN (f_month), f_month);
1266 break;
1267#else
1268 goto underlying_strftime;
1269#endif
1270
1271 case L_('c'):
1272 if (modifier == L_('O'))
1273 goto bad_format;
1274#ifdef _NL_CURRENT
1275 if (! (modifier == L_('E')
1276 && (*(subfmt =
1277 (const CHAR_T *) _NL_CURRENT (LC_TIME,
1278 NLW(ERA_D_T_FMT)))
1279 != '\0')))
1280 subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_T_FMT));
1281#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1282 subfmt = L_("%a %b %e %H:%M:%S %Y");
1283#else
1284 goto underlying_strftime;
1285#endif
1286
1287 subformat:
1288 subwidth = -1;
1289 subformat_width:
1290 {
1291 size_t len = __strftime_internal (NULL, STRFTIME_ARG ((size_t) -1)
1292 subfmt, tp, to_uppcase,
1293 pad, subwidth, tzset_called
1294 extra_args LOCALE_ARG);
1295 add (len, __strftime_internal (p,
1296 STRFTIME_ARG (maxsize - i)
1297 subfmt, tp, to_uppcase,
1298 pad, subwidth, tzset_called
1299 extra_args LOCALE_ARG));
1300 }
1301 break;
1302
1303#if !((defined _NL_CURRENT && HAVE_STRUCT_ERA_ENTRY) || (USE_C_LOCALE && !HAVE_STRFTIME_L))
1304 underlying_strftime:
1305 {
1306 /* The relevant information is available only via the
1307 underlying strftime implementation, so use that. */
1308 char ufmt[5];
1309 char *u = ufmt;
1310 char ubuf[1024]; /* enough for any single format in practice */
1311 size_t len;
1312 /* Make sure we're calling the actual underlying strftime.
1313 In some cases, config.h contains something like
1314 "#define strftime rpl_strftime". */
1315# ifdef strftime
1316# undef strftime
1317 size_t strftime (char *, size_t, const char *, struct tm const *);
1318# endif
1319
1320 /* The space helps distinguish strftime failure from empty
1321 output. */
1322 *u++ = ' ';
1323 *u++ = '%';
1324 if (modifier != 0)
1325 *u++ = modifier;
1326 *u++ = format_char;
1327 *u = '\0';
1328
1329# if USE_C_LOCALE /* implies HAVE_STRFTIME_L */
1330 locale_t locale = c_locale ();
1331 if (!locale)
1332 return 0; /* errno is set here */
1333 len = strftime_l (ubuf, sizeof ubuf, ufmt, tp, locale);
1334# else
1335 len = strftime (ubuf, sizeof ubuf, ufmt, tp);
1336# endif
1337 if (len != 0)
1338 {
1339# if defined __NetBSD__ || defined __sun /* NetBSD, Solaris */
1340 if (format_char == L_('c'))
1341 {
1342 /* The output of the strftime %c directive consists of the
1343 date, the time, and the time zone. But the time zone is
1344 wrong, since neither TZ nor ZONE was passed as argument.
1345 Therefore, remove the the last space-delimited word.
1346 In order not to accidentally remove a date or a year
1347 (that contains no letter) or an AM/PM indicator (that has
1348 length 2), remove that last word only if it contains a
1349 letter and has length >= 3. */
1350 char *space;
1351 for (space = ubuf + len - 1; *space != ' '; space--)
1352 ;
1353 if (space > ubuf)
1354 {
1355 /* Found a space. */
1356 if (strlen (space + 1) >= 3)
1357 {
1358 /* The last word has length >= 3. */
1359 bool found_letter = false;
1360 const char *p;
1361 for (p = space + 1; *p != '\0'; p++)
1362 if ((*p >= 'A' && *p <= 'Z')
1363 || (*p >= 'a' && *p <= 'z'))
1364 {
1365 found_letter = true;
1366 break;
1367 }
1368 if (found_letter)
1369 {
1370 /* The last word contains a letter. */
1371 *space = '\0';
1372 len = space - ubuf;
1373 }
1374 }
1375 }
1376 }
1377# if REQUIRE_GNUISH_STRFTIME_AM_PM
1378 /* The output of the strftime %p and %r directives contains
1379 an AM/PM indicator even for locales where it is not
1380 suitable, such as French. Remove this indicator. */
1381 else if (format_char == L_('p'))
1382 {
1383 bool found_ampm = (len > 1);
1384 if (found_ampm && should_remove_ampm ())
1385 {
1386 ubuf[1] = '\0';
1387 len = 1;
1388 }
1389 }
1390 else if (format_char == L_('r'))
1391 {
1392 char last_char = ubuf[len - 1];
1393 bool found_ampm = !(last_char >= '0' && last_char <= '9');
1394 if (found_ampm && should_remove_ampm ())
1395 {
1396 char *space;
1397 for (space = ubuf + len - 1; *space != ' '; space--)
1398 ;
1399 if (space > ubuf)
1400 {
1401 *space = '\0';
1402 len = space - ubuf;
1403 }
1404 }
1405 }
1406# endif
1407# endif
1408 cpy (len - 1, ubuf + 1);
1409 }
1410 }
1411 break;
1412#endif
1413
1414 case L_('C'):
1415 if (modifier == L_('E'))
1416 {
1417#if HAVE_STRUCT_ERA_ENTRY
1418 struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
1419 if (era)
1420 {
1421# ifdef COMPILE_WIDE
1422 size_t len = __wcslen (era->era_wname);
1423 cpy (len, era->era_wname);
1424# else
1425 size_t len = strlen (era->era_name);
1426 cpy (len, era->era_name);
1427# endif
1428 break;
1429 }
1430#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1431#else
1432 goto underlying_strftime;
1433#endif
1434 }
1435
1436 {
1437 bool negative_year = tp->tm_year < - TM_YEAR_BASE;
1438 bool zero_thru_1899 = !negative_year & (tp->tm_year < 0);
1439 int century = ((tp->tm_year - 99 * zero_thru_1899) / 100
1440 + TM_YEAR_BASE / 100);
1441 DO_YEARISH (2, negative_year, century);
1442 }
1443
1444 case L_('x'):
1445 if (modifier == L_('O'))
1446 goto bad_format;
1447#ifdef _NL_CURRENT
1448 if (! (modifier == L_('E')
1449 && (*(subfmt =
1450 (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_D_FMT)))
1451 != L_('\0'))))
1452 subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_FMT));
1453 goto subformat;
1454#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1455 subfmt = L_("%m/%d/%y");
1456 goto subformat;
1457#else
1458 goto underlying_strftime;
1459#endif
1460 case L_('D'):
1461 if (modifier != 0)
1462 goto bad_format;
1463 subfmt = L_("%m/%d/%y");
1464 goto subformat;
1465
1466 case L_('d'):
1467 if (modifier == L_('E'))
1468 goto bad_format;
1469
1470 DO_NUMBER (2, tp->tm_mday);
1471
1472 case L_('e'):
1473 if (modifier == L_('E'))
1474 goto bad_format;
1475
1476 DO_NUMBER_SPACEPAD (2, tp->tm_mday);
1477
1478 /* All numeric formats set DIGITS and NUMBER_VALUE (or U_NUMBER_VALUE)
1479 and then jump to one of these labels. */
1480
1481 do_tz_offset:
1482 always_output_a_sign = true;
1483 goto do_number_body;
1484
1485 do_yearish:
1486 if (pad == 0)
1487 pad = yr_spec;
1488 always_output_a_sign
1489 = (pad == L_('+')
1490 && ((digits == 2 ? 99 : 9999) < u_number_value
1491 || digits < width));
1492 goto do_maybe_signed_number;
1493
1494 do_number_spacepad:
1495 if (pad == 0)
1496 pad = L_('_');
1497
1498 do_number:
1499 /* Format NUMBER_VALUE according to the MODIFIER flag. */
1500 negative_number = number_value < 0;
1501 u_number_value = number_value;
1502
1503 do_signed_number:
1504 always_output_a_sign = false;
1505
1506 do_maybe_signed_number:
1507 tz_colon_mask = 0;
1508
1509 do_number_body:
1510 /* Format U_NUMBER_VALUE according to the MODIFIER flag.
1511 NEGATIVE_NUMBER is nonzero if the original number was
1512 negative; in this case it was converted directly to
1513 unsigned int (i.e., modulo (UINT_MAX + 1)) without
1514 negating it. */
1515 if (modifier == L_('O') && !negative_number)
1516 {
1517#ifdef _NL_CURRENT
1518 /* Get the locale specific alternate representation of
1519 the number. If none exist NULL is returned. */
1520 const CHAR_T *cp = nl_get_alt_digit (u_number_value
1521 HELPER_LOCALE_ARG);
1522
1523 if (cp != NULL)
1524 {
1525 size_t digitlen = STRLEN (cp);
1526 if (digitlen != 0)
1527 {
1528 cpy (digitlen, cp);
1529 break;
1530 }
1531 }
1532#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1533#else
1534 goto underlying_strftime;
1535#endif
1536 }
1537
1538 bufp = buf + sizeof (buf) / sizeof (buf[0]);
1539
1540 if (negative_number)
1541 u_number_value = - u_number_value;
1542
1543 do
1544 {
1545 if (tz_colon_mask & 1)
1546 *--bufp = ':';
1547 tz_colon_mask >>= 1;
1548 *--bufp = u_number_value % 10 + L_('0');
1549 u_number_value /= 10;
1550 }
1551 while (u_number_value != 0 || tz_colon_mask != 0);
1552
1553 do_number_sign_and_padding:
1554 if (pad == 0)
1555 pad = L_('0');
1556 if (width < 0)
1557 width = digits;
1558
1559 {
1560 CHAR_T sign_char = (negative_number ? L_('-')
1561 : always_output_a_sign ? L_('+')
1562 : 0);
1563 int numlen = buf + sizeof buf / sizeof buf[0] - bufp;
1564 int shortage = width - !!sign_char - numlen;
1565 int padding = pad == L_('-') || shortage <= 0 ? 0 : shortage;
1566
1567 if (sign_char)
1568 {
1569 if (pad == L_('_'))
1570 {
1571 if (p)
1572 memset_space (p, padding);
1573 i += padding;
1574 width -= padding;
1575 }
1576 width_add1 (0, sign_char);
1577 width--;
1578 }
1579
1580 cpy (numlen, bufp);
1581 }
1582 break;
1583
1584 case L_('F'):
1585 if (modifier != 0)
1586 goto bad_format;
1587 if (pad == 0 && width < 0)
1588 {
1589 pad = L_('+');
1590 subwidth = 4;
1591 }
1592 else
1593 {
1594 subwidth = width - 6;
1595 if (subwidth < 0)
1596 subwidth = 0;
1597 }
1598 subfmt = L_("%Y-%m-%d");
1599 goto subformat_width;
1600
1601 case L_('H'):
1602 if (modifier == L_('E'))
1603 goto bad_format;
1604
1605 DO_NUMBER (2, tp->tm_hour);
1606
1607 case L_('I'):
1608 if (modifier == L_('E'))
1609 goto bad_format;
1610
1611 DO_NUMBER (2, hour12);
1612
1613 case L_('k'): /* GNU extension. */
1614 if (modifier == L_('E'))
1615 goto bad_format;
1616
1617 DO_NUMBER_SPACEPAD (2, tp->tm_hour);
1618
1619 case L_('l'): /* GNU extension. */
1620 if (modifier == L_('E'))
1621 goto bad_format;
1622
1623 DO_NUMBER_SPACEPAD (2, hour12);
1624
1625 case L_('j'):
1626 if (modifier == L_('E'))
1627 goto bad_format;
1628
1629 DO_SIGNED_NUMBER (3, tp->tm_yday < -1, tp->tm_yday + 1U);
1630
1631 case L_('M'):
1632 if (modifier == L_('E'))
1633 goto bad_format;
1634
1635 DO_NUMBER (2, tp->tm_min);
1636
1637 case L_('m'):
1638 if (modifier == L_('E'))
1639 goto bad_format;
1640
1641 DO_SIGNED_NUMBER (2, tp->tm_mon < -1, tp->tm_mon + 1U);
1642
1643#ifndef _LIBC
1644 case L_('N'): /* GNU extension. */
1645 if (modifier == L_('E'))
1646 goto bad_format;
1647 {
1648 int n = ns, ns_digits = 9;
1649 if (width <= 0)
1650 width = ns_digits;
1651 int ndigs = ns_digits;
1652 while (width < ndigs || (1 < ndigs && n % 10 == 0))
1653 ndigs--, n /= 10;
1654 for (int j = ndigs; 0 < j; j--)
1655 buf[j - 1] = n % 10 + L_('0'), n /= 10;
1656 if (!pad)
1657 pad = L_('0');
1658 width_cpy (0, ndigs, buf);
1659 width_add (width - ndigs, 0, (void) 0);
1660 }
1661 break;
1662#endif
1663
1664 case L_('n'):
1665 add1 (L_('\n'));
1666 break;
1667
1668 case L_('P'):
1669 to_lowcase = true;
1670#ifndef _NL_CURRENT
1671 format_char = L_('p');
1672#endif
1673 FALLTHROUGH;
1674 case L_('p'):
1675 if (change_case)
1676 {
1677 to_uppcase = false;
1678 to_lowcase = true;
1679 }
1680#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
1681 cpy (ap_len, ampm);
1682 break;
1683#else
1684 goto underlying_strftime;
1685#endif
1686
1687 case L_('q'): /* GNU extension. */
1688 DO_SIGNED_NUMBER (1, false, ((tp->tm_mon * 11) >> 5) + 1);
1689
1690 case L_('R'):
1691 subfmt = L_("%H:%M");
1692 goto subformat;
1693
1694 case L_('r'):
1695#ifdef _NL_CURRENT
1696 if (*(subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME,
1697 NLW(T_FMT_AMPM)))
1698 == L_('\0'))
1699 subfmt = L_("%I:%M:%S %p");
1700 goto subformat;
1701#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1702 subfmt = L_("%I:%M:%S %p");
1703 goto subformat;
1704#elif (defined __APPLE__ && defined __MACH__) || defined __FreeBSD__
1705 /* macOS, FreeBSD strftime() may produce empty output for "%r". */
1706 subfmt = L_("%I:%M:%S %p");
1707 goto subformat;
1708#else
1709 goto underlying_strftime;
1710#endif
1711
1712 case L_('S'):
1713 if (modifier == L_('E'))
1714 goto bad_format;
1715
1716 DO_NUMBER (2, tp->tm_sec);
1717
1718 case L_('s'): /* GNU extension. */
1719 {
1720 struct tm ltm;
1721 time_t t;
1722
1723 ltm = *tp;
1724 ltm.tm_yday = -1;
1725 t = mktime_z (tz, &ltm);
1726 if (ltm.tm_yday < 0)
1727 {
1728 errno = EOVERFLOW;
1729 return 0;
1730 }
1731
1732 /* Generate string value for T using time_t arithmetic;
1733 this works even if sizeof (long) < sizeof (time_t). */
1734
1735 bufp = buf + sizeof (buf) / sizeof (buf[0]);
1736 negative_number = t < 0;
1737
1738 do
1739 {
1740 int d = t % 10;
1741 t /= 10;
1742 *--bufp = (negative_number ? -d : d) + L_('0');
1743 }
1744 while (t != 0);
1745
1746 digits = 1;
1747 always_output_a_sign = false;
1748 goto do_number_sign_and_padding;
1749 }
1750
1751 case L_('X'):
1752 if (modifier == L_('O'))
1753 goto bad_format;
1754#ifdef _NL_CURRENT
1755 if (! (modifier == L_('E')
1756 && (*(subfmt =
1757 (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_T_FMT)))
1758 != L_('\0'))))
1759 subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(T_FMT));
1760 goto subformat;
1761#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1762 subfmt = L_("%H:%M:%S");
1763 goto subformat;
1764#else
1765 goto underlying_strftime;
1766#endif
1767 case L_('T'):
1768 subfmt = L_("%H:%M:%S");
1769 goto subformat;
1770
1771 case L_('t'):
1772 add1 (L_('\t'));
1773 break;
1774
1775 case L_('u'):
1776 DO_NUMBER (1, (tp->tm_wday - 1 + 7) % 7 + 1);
1777
1778 case L_('U'):
1779 if (modifier == L_('E'))
1780 goto bad_format;
1781
1782 DO_NUMBER (2, (tp->tm_yday - tp->tm_wday + 7) / 7);
1783
1784 case L_('V'):
1785 case L_('g'):
1786 case L_('G'):
1787 if (modifier == L_('E'))
1788 goto bad_format;
1789 {
1790 /* YEAR is a leap year if and only if (tp->tm_year + TM_YEAR_BASE)
1791 is a leap year, except that YEAR and YEAR - 1 both work
1792 correctly even when (tp->tm_year + TM_YEAR_BASE) would
1793 overflow. */
1794 int year = (tp->tm_year
1795 + (tp->tm_year < 0
1796 ? TM_YEAR_BASE % 400
1797 : TM_YEAR_BASE % 400 - 400));
1798 int year_adjust = 0;
1799 int days = iso_week_days (tp->tm_yday, tp->tm_wday);
1800
1801 if (days < 0)
1802 {
1803 /* This ISO week belongs to the previous year. */
1804 year_adjust = -1;
1805 days = iso_week_days (tp->tm_yday + (365 + __isleap (year - 1)),
1806 tp->tm_wday);
1807 }
1808 else
1809 {
1810 int d = iso_week_days (tp->tm_yday - (365 + __isleap (year)),
1811 tp->tm_wday);
1812 if (0 <= d)
1813 {
1814 /* This ISO week belongs to the next year. */
1815 year_adjust = 1;
1816 days = d;
1817 }
1818 }
1819
1820 switch (*f)
1821 {
1822 case L_('g'):
1823 {
1824 int yy = (tp->tm_year % 100 + year_adjust) % 100;
1825 DO_YEARISH (2, false,
1826 (0 <= yy
1827 ? yy
1828 : tp->tm_year < -TM_YEAR_BASE - year_adjust
1829 ? -yy
1830 : yy + 100));
1831 }
1832
1833 case L_('G'):
1834 DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE - year_adjust,
1835 (tp->tm_year + (unsigned int) TM_YEAR_BASE
1836 + year_adjust));
1837
1838 default:
1839 DO_NUMBER (2, days / 7 + 1);
1840 }
1841 }
1842
1843 case L_('W'):
1844 if (modifier == L_('E'))
1845 goto bad_format;
1846
1847 DO_NUMBER (2, (tp->tm_yday - (tp->tm_wday - 1 + 7) % 7 + 7) / 7);
1848
1849 case L_('w'):
1850 if (modifier == L_('E'))
1851 goto bad_format;
1852
1853 DO_NUMBER (1, tp->tm_wday);
1854
1855 case L_('Y'):
1856 if (modifier == L_('E'))
1857 {
1858#if HAVE_STRUCT_ERA_ENTRY
1859 struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
1860 if (era)
1861 {
1862# ifdef COMPILE_WIDE
1863 subfmt = era->era_wformat;
1864# else
1865 subfmt = era->era_format;
1866# endif
1867 if (pad == 0)
1868 pad = yr_spec;
1869 goto subformat;
1870 }
1871#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1872#else
1873 goto underlying_strftime;
1874#endif
1875 }
1876 if (modifier == L_('O'))
1877 goto bad_format;
1878
1879 DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE,
1880 tp->tm_year + (unsigned int) TM_YEAR_BASE);
1881
1882 case L_('y'):
1883 if (modifier == L_('E'))
1884 {
1885#if HAVE_STRUCT_ERA_ENTRY
1886 struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
1887 if (era)
1888 {
1889 int delta = tp->tm_year - era->start_date[0];
1890 if (pad == 0)
1891 pad = yr_spec;
1892 DO_NUMBER (2, (era->offset
1893 + delta * era->absolute_direction));
1894 }
1895#elif USE_C_LOCALE && !HAVE_STRFTIME_L
1896#else
1897 goto underlying_strftime;
1898#endif
1899 }
1900
1901 {
1902 int yy = tp->tm_year % 100;
1903 if (yy < 0)
1904 yy = tp->tm_year < - TM_YEAR_BASE ? -yy : yy + 100;
1905 DO_YEARISH (2, false, yy);
1906 }
1907
1908 case L_('Z'):
1909 if (change_case)
1910 {
1911 to_uppcase = false;
1912 to_lowcase = true;
1913 }
1914
1915#ifdef COMPILE_WIDE
1916 {
1917 /* The zone string is always given in multibyte form. We have
1918 to convert it to wide character. */
1919 size_t w = pad == L_('-') || width < 0 ? 0 : width;
1920 char const *z = zone;
1921 mbstate_t st = {0};
1922 size_t len = __mbsrtowcs_l (p, &z, maxsize - i, &st, loc);
1923 if (len == (size_t) -1)
1924 return 0;
1925 size_t incr = len < w ? w : len;
1926 if (incr >= maxsize - i)
1927 {
1928 errno = ERANGE;
1929 return 0;
1930 }
1931 if (p)
1932 {
1933 if (len < w)
1934 {
1935 size_t delta = w - len;
1936 __wmemmove (p + delta, p, len);
1937 wchar_t wc = pad == L_('0') || pad == L_('+') ? L'0' : L' ';
1938 wmemset (p, wc, delta);
1939 }
1940 p += incr;
1941 }
1942 i += incr;
1943 }
1944#else
1945 cpy (strlen (zone), zone);
1946#endif
1947 break;
1948
1949 case L_(':'):
1950 /* :, ::, and ::: are valid only just before 'z'.
1951 :::: etc. are rejected later. */
1952 for (colons = 1; f[colons] == L_(':'); colons++)
1953 continue;
1954 if (f[colons] != L_('z'))
1955 goto bad_format;
1956 f += colons;
1957 goto do_z_conversion;
1958
1959 case L_('z'):
1960 colons = 0;
1961
1962 do_z_conversion:
1963 if (tp->tm_isdst < 0)
1964 break;
1965
1966 {
1967 int diff;
1968 int hour_diff;
1969 int min_diff;
1970 int sec_diff;
1971#if HAVE_TM_GMTOFF
1972 diff = tp->tm_gmtoff;
1973#else
1974 if (!tz)
1975 diff = 0;
1976 else
1977 {
1978 struct tm gtm;
1979 struct tm ltm;
1980 time_t lt;
1981
1982 /* POSIX.1 requires that local time zone information be used as
1983 though strftime called tzset. */
1984# ifndef my_strftime
1985 if (!*tzset_called)
1986 {
1987 tzset ();
1988 *tzset_called = true;
1989 }
1990# endif
1991
1992 ltm = *tp;
1993 ltm.tm_wday = -1;
1994 lt = mktime_z (tz, &ltm);
1995 if (ltm.tm_wday < 0 || ! localtime_rz (0, &lt, &gtm))
1996 break;
1997 diff = tm_diff (&ltm, &gtm);
1998 }
1999#endif
2000
2001 negative_number = diff < 0 || (diff == 0 && *zone == '-');
2002 hour_diff = diff / 60 / 60;
2003 min_diff = diff / 60 % 60;
2004 sec_diff = diff % 60;
2005
2006 switch (colons)
2007 {
2008 case 0: /* +hhmm */
2009 DO_TZ_OFFSET (5, 0, hour_diff * 100 + min_diff);
2010
2011 case 1: tz_hh_mm: /* +hh:mm */
2012 DO_TZ_OFFSET (6, 04, hour_diff * 100 + min_diff);
2013
2014 case 2: tz_hh_mm_ss: /* +hh:mm:ss */
2015 DO_TZ_OFFSET (9, 024,
2016 hour_diff * 10000 + min_diff * 100 + sec_diff);
2017
2018 case 3: /* +hh if possible, else +hh:mm, else +hh:mm:ss */
2019 if (sec_diff != 0)
2020 goto tz_hh_mm_ss;
2021 if (min_diff != 0)
2022 goto tz_hh_mm;
2023 DO_TZ_OFFSET (3, 0, hour_diff);
2024
2025 default:
2026 goto bad_format;
2027 }
2028 }
2029
2030 case L_('\0'): /* GNU extension: % at end of format. */
2031 bad_percent:
2032 --f;
2033 FALLTHROUGH;
2034 default:
2035 /* Unknown format; output the format, including the '%',
2036 since this is most likely the right thing to do if a
2037 multibyte string has been misparsed. */
2038 bad_format:
2039 cpy (f - percent + 1, percent);
2040 break;
2041 }
2042 }
2043
2044#if ! FPRINTFTIME
2045 if (p && maxsize != 0)
2046 *p = L_('\0');
2047#endif
2048
2049 errno = saved_errno;
2050 return i;
2051}
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 @@
21extern "C" { 21extern "C" {
22#endif 22#endif
23 23
24/* Just like strftime, but with two more arguments: 24/* Formats the broken-down time *__TP, with additional __NS nanoseconds,
25 POSIX requires that strftime use the local timezone information. 25 into the buffer __S of size __MAXSIZE, according to the rules of the
26 Use the timezone __TZ instead. Use __NS as the number of 26 LC_TIME category of the current locale.
27 nanoseconds in the %N directive. 27
28 28 Uses the time zone __TZ.
29 On error, set errno and return 0. Otherwise, return the number of 29 If *__TP represents local time, __TZ should be set to
30 bytes generated (not counting the trailing NUL), preserving errno 30 tzalloc (getenv ("TZ")).
31 if the number is 0. This errno behavior is in draft POSIX 202x 31 If *__TP represents universal time (a.k.a. GMT), __TZ should be set to
32 plus some requested changes to POSIX. */ 32 (timezone_t) 0.
33size_t nstrftime (char *restrict, size_t, char const *, struct tm const *, 33
34 timezone_t __tz, int __ns); 34 The format string __FORMAT, including GNU extensions, is described in
35 the GNU libc's strftime() documentation:
36 <https://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html>
37 Additionally, the following conversion is supported:
38 %N The number of nanoseconds, passed as __NS argument.
39 Here's a summary of the available conversions (= format directives):
40 literal characters %n %t %%
41 date:
42 century %C
43 year %Y %y
44 week-based year %G %g
45 month (in year) %m %B %b %h
46 week in year %U %W %V
47 day in year %j
48 day (in month) %d %e
49 day in week %u %w %A %a
50 year, month, day %x %F %D
51 time:
52 half-day %p %P
53 hour %H %k %I %l
54 minute (in hour) %M
55 hour, minute %R
56 second (in minute) %S
57 hour, minute, second %r %T %X
58 second (since epoch) %s
59 date and time: %c
60 time zone: %z %Z
61 nanosecond %N
62
63 Stores the result, as a string with a trailing NUL character, at the
64 beginning of the array __S[0..__MAXSIZE-1], if it fits, and returns
65 the length of that string, not counting the trailing NUL. In this case,
66 errno is preserved if the return value is 0.
67 If it does not fit, this function sets errno to ERANGE and returns 0.
68 Upon other errors, this function sets errno and returns 0 as well.
69
70 Note: The errno behavior is in draft POSIX 202x plus some requested
71 changes to POSIX.
72
73 This function is like strftime, but with two more arguments:
74 * __TZ instead of the local timezone information,
75 * __NS as the number of nanoseconds in the %N directive.
76 */
77size_t nstrftime (char *restrict __s, size_t __maxsize,
78 char const *__format,
79 struct tm const *__tp, timezone_t __tz, int __ns);
80
81/* Like nstrftime, except that it uses the "C" locale instead of the
82 current locale. */
83size_t c_nstrftime (char *restrict __s, size_t __maxsize,
84 char const *__format,
85 struct tm const *__tp, timezone_t __tz, int __ns);
35 86
36#ifdef __cplusplus 87#ifdef __cplusplus
37} 88}
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 - "
414/* Overwrite a block of memory. The compiler will not optimize 414/* Overwrite a block of memory. The compiler will not optimize
415 effects away, even if the block is dead after the call. */ 415 effects away, even if the block is dead after the call. */
416#if @GNULIB_MEMSET_EXPLICIT@ 416#if @GNULIB_MEMSET_EXPLICIT@
417# if ! @HAVE_MEMSET_EXPLICIT@ 417# if @REPLACE_MEMSET_EXPLICIT@
418# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
419# undef memset_explicit
420# define memset_explicit rpl_memset_explicit
421# endif
422_GL_FUNCDECL_RPL (memset_explicit, void *,
423 (void *__dest, int __c, size_t __n) _GL_ARG_NONNULL ((1)));
424_GL_CXXALIAS_RPL (memset_explicit, void *, (void *__dest, int __c, size_t __n));
425# else
426# if !@HAVE_MEMSET_EXPLICIT@
418_GL_FUNCDECL_SYS (memset_explicit, void *, 427_GL_FUNCDECL_SYS (memset_explicit, void *,
419 (void *__dest, int __c, size_t __n) _GL_ARG_NONNULL ((1))); 428 (void *__dest, int __c, size_t __n) _GL_ARG_NONNULL ((1)));
420# endif 429# endif
421_GL_CXXALIAS_SYS (memset_explicit, void *, (void *__dest, int __c, size_t __n)); 430_GL_CXXALIAS_SYS (memset_explicit, void *, (void *__dest, int __c, size_t __n));
431# endif
422_GL_CXXALIASWARN (memset_explicit); 432_GL_CXXALIASWARN (memset_explicit);
423#elif defined GNULIB_POSIXCHECK 433#elif defined GNULIB_POSIXCHECK
424# undef memset_explicit 434# 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 - "
154/* Set *TS to the current time resolution, and return BASE. 154/* Set *TS to the current time resolution, and return BASE.
155 Upon failure, return 0. */ 155 Upon failure, return 0. */
156# if @GNULIB_TIMESPEC_GETRES@ 156# if @GNULIB_TIMESPEC_GETRES@
157# if ! @HAVE_TIMESPEC_GETRES@ 157# if @REPLACE_TIMESPEC_GETRES@
158# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
159# undef timespec_getres
160# define timespec_getres rpl_timespec_getres
161# endif
162_GL_FUNCDECL_RPL (timespec_getres, int, (struct timespec *ts, int base)
163 _GL_ARG_NONNULL ((1)));
164_GL_CXXALIAS_RPL (timespec_getres, int, (struct timespec *ts, int base));
165# else
166# if !@HAVE_TIMESPEC_GETRES@
158_GL_FUNCDECL_SYS (timespec_getres, int, (struct timespec *ts, int base) 167_GL_FUNCDECL_SYS (timespec_getres, int, (struct timespec *ts, int base)
159 _GL_ARG_NONNULL ((1))); 168 _GL_ARG_NONNULL ((1)));
160# endif 169# endif
161_GL_CXXALIAS_SYS (timespec_getres, int, (struct timespec *ts, int base)); 170_GL_CXXALIAS_SYS (timespec_getres, int, (struct timespec *ts, int base));
171# endif
162_GL_CXXALIASWARN (timespec_getres); 172_GL_CXXALIASWARN (timespec_getres);
163# elif defined GNULIB_POSIXCHECK 173# elif defined GNULIB_POSIXCHECK
164# undef timespec_getres 174# undef timespec_getres
@@ -428,11 +438,7 @@ _GL_CXXALIAS_SYS (ctime, char *, (time_t const *__tp));
428_GL_CXXALIASWARN (ctime); 438_GL_CXXALIASWARN (ctime);
429# endif 439# endif
430# elif defined GNULIB_POSIXCHECK 440# elif defined GNULIB_POSIXCHECK
431# undef ctime 441/* No need to warn about portability, as a more serious warning is below. */
432# if HAVE_RAW_DECL_CTIME
433_GL_WARN_ON_USE (ctime, "ctime has portability problems - "
434 "use gnulib module ctime for portability");
435# endif
436# endif 442# endif
437 443
438/* Convert *TP to a date and time string. See 444/* 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 @@
21 21
22#include <time.h> 22#include <time.h>
23 23
24/* The replacement functions in this file are only used on native Windows.
25 They are multithread-safe, because the gmtime() and localtime() functions
26 on native Windows — both in the ucrt and in the older MSVCRT — return a
27 pointer to a 'struct tm' in thread-local memory. */
28
24static struct tm * 29static struct tm *
25copy_tm_result (struct tm *dest, struct tm const *src) 30copy_tm_result (struct tm *dest, struct tm const *src)
26{ 31{
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 @@
32 _GL_WARN_ON_USE_ATTRIBUTE is for functions with 'static' or 'inline' 32 _GL_WARN_ON_USE_ATTRIBUTE is for functions with 'static' or 'inline'
33 linkage. 33 linkage.
34 34
35 _GL_WARN_ON_USE should not be used more than once for a given function
36 in a given compilation unit (because this may generate a warning even
37 if the function is never called).
38
35 However, one of the reasons that a function is a portability trap is 39 However, one of the reasons that a function is a portability trap is
36 if it has the wrong signature. Declaring FUNCTION with a different 40 if it has the wrong signature. Declaring FUNCTION with a different
37 signature in C is a compilation error, so this macro must use the 41 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 @@
29 is SIZE_MAX - 1. */ 29 is SIZE_MAX - 1. */
30#define __xalloc_oversized(n, s) \ 30#define __xalloc_oversized(n, s) \
31 ((s) != 0 \ 31 ((s) != 0 \
32 && ((size_t) (PTRDIFF_MAX < SIZE_MAX ? PTRDIFF_MAX : SIZE_MAX - 1) / (s) \ 32 && (PTRDIFF_MAX < SIZE_MAX ? PTRDIFF_MAX : SIZE_MAX - 1) / (s) < (n))
33 < (n)))
34 33
35/* Return 1 if and only if an array of N objects, each of size S, 34/* Return 1 if and only if an array of N objects, each of size S,
36 cannot exist reliably because its total size in bytes would exceed 35 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.")
602 "Undefine all abbrevs in abbrev table TABLE, leaving TABLE empty." 602 "Undefine all abbrevs in abbrev table TABLE, leaving TABLE empty."
603 (setq abbrevs-changed t) 603 (setq abbrevs-changed t)
604 (let* ((sym (obarray-get table ""))) 604 (let* ((sym (obarray-get table "")))
605 (dotimes (i (length table)) 605 (obarray-clear table)
606 (aset table i 0))
607 ;; Preserve the table's properties. 606 ;; Preserve the table's properties.
608 (cl-assert sym) 607 (cl-assert sym)
609 (let ((newsym (obarray-put table ""))) 608 (let ((newsym (obarray-put table "")))
@@ -721,7 +720,7 @@ either a single abbrev table or a list of abbrev tables."
721 ;; to treat the distinction between a single table and a list of tables. 720 ;; to treat the distinction between a single table and a list of tables.
722 (cond 721 (cond
723 ((consp tables) tables) 722 ((consp tables) tables)
724 ((vectorp tables) (list tables)) 723 ((obarrayp tables) (list tables))
725 (t 724 (t
726 (let ((tables (if (listp local-abbrev-table) 725 (let ((tables (if (listp local-abbrev-table)
727 (append local-abbrev-table 726 (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',
161(defcustom allout-command-prefix "\C-c " 161(defcustom allout-command-prefix "\C-c "
162 "Key sequence to be used as prefix for outline mode command key bindings. 162 "Key sequence to be used as prefix for outline mode command key bindings.
163 163
164Default is `\C-c<space>'; just `\C-c' is more short-and-sweet, if you're 164Default is \\`C-c SPC'; just \\`C-c' is more short-and-sweet, if you're
165willing to let allout use a bunch of \C-c keybindings." 165willing to let allout use a bunch of \\`C-c' keybindings."
166 :type 'string 166 :type 'key-sequence
167 :group 'allout-keybindings 167 :group 'allout-keybindings
168 :set #'allout-compose-and-institute-keymap) 168 :set #'allout-compose-and-institute-keymap)
169;;;_ = allout-keybindings-binding 169;;;_ = 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:
1985 1985
1986 1986
1987(defun auth-source--decode-octal-string (string) 1987(defun auth-source--decode-octal-string (string)
1988 "Convert octal STRING to utf-8 string. E.g: \"a\134b\" to \"a\b\"." 1988 "Convert octal STRING to utf-8 string. E.g.: \"a\\134b\" to \"a\\b\"."
1989 (let ((list (string-to-list string)) 1989 (let ((list (string-to-list string))
1990 (size (length string))) 1990 (size (length string)))
1991 (decode-coding-string 1991 (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."
155(add-to-list 'emulation-mode-map-alists 155(add-to-list 'emulation-mode-map-alists
156 `((override-global-mode . ,override-global-map))) 156 `((override-global-mode . ,override-global-map)))
157 157
158;;;###autoload
158(defvar personal-keybindings nil 159(defvar personal-keybindings nil
159 "List of bindings performed by `bind-key'. 160 "List of bindings performed by `bind-key'.
160 161
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."
100This is set by the prefix argument to `buffer-menu' and related 100This is set by the prefix argument to `buffer-menu' and related
101commands.") 101commands.")
102 102
103(defvar-local Buffer-menu-show-internal nil
104 "Non-nil if the current Buffer Menu lists internal buffers.
105Internal buffers are those whose names start with a space.")
106
103(defvar-local Buffer-menu-filter-predicate nil 107(defvar-local Buffer-menu-filter-predicate nil
104 "Function to filter out buffers in the buffer list. 108 "Function to filter out buffers in the buffer list.
105Buffers that don't satisfy the predicate will be skipped. 109Buffers that don't satisfy the predicate will be skipped.
@@ -140,6 +144,7 @@ then the buffer will be displayed in the buffer list.")
140 "V" #'Buffer-menu-view 144 "V" #'Buffer-menu-view
141 "O" #'Buffer-menu-view-other-window 145 "O" #'Buffer-menu-view-other-window
142 "T" #'Buffer-menu-toggle-files-only 146 "T" #'Buffer-menu-toggle-files-only
147 "I" #'Buffer-menu-toggle-internal
143 "M-s a C-s" #'Buffer-menu-isearch-buffers 148 "M-s a C-s" #'Buffer-menu-isearch-buffers
144 "M-s a C-M-s" #'Buffer-menu-isearch-buffers-regexp 149 "M-s a C-M-s" #'Buffer-menu-isearch-buffers-regexp
145 "M-s a C-o" #'Buffer-menu-multi-occur 150 "M-s a C-o" #'Buffer-menu-multi-occur
@@ -197,6 +202,10 @@ then the buffer will be displayed in the buffer list.")
197 :help "Toggle whether the current buffer-menu displays only file buffers" 202 :help "Toggle whether the current buffer-menu displays only file buffers"
198 :style toggle 203 :style toggle
199 :selected Buffer-menu-files-only] 204 :selected Buffer-menu-files-only]
205 ["Show Internal Buffers" Buffer-menu-toggle-internal
206 :help "Toggle whether the current buffer-menu displays internal buffers"
207 :style toggle
208 :selected Buffer-menu-show-internal]
200 "---" 209 "---"
201 ["Refresh" revert-buffer 210 ["Refresh" revert-buffer
202 :help "Refresh the *Buffer List* buffer contents"] 211 :help "Refresh the *Buffer List* buffer contents"]
@@ -317,6 +326,11 @@ ARG, show only buffers that are visiting files."
317 (interactive "P") 326 (interactive "P")
318 (display-buffer (list-buffers-noselect arg))) 327 (display-buffer (list-buffers-noselect arg)))
319 328
329(defun Buffer-menu--selection-message ()
330 (message (cond (Buffer-menu-files-only "Showing only file-visiting buffers.")
331 (Buffer-menu-show-internal "Showing all buffers.")
332 (t "Showing all buffers except internal ones."))))
333
320(defun Buffer-menu-toggle-files-only (arg) 334(defun Buffer-menu-toggle-files-only (arg)
321 "Toggle whether the current `buffer-menu' displays only file buffers. 335 "Toggle whether the current `buffer-menu' displays only file buffers.
322With a positive ARG, display only file buffers. With zero or 336With a positive ARG, display only file buffers. With zero or
@@ -325,9 +339,18 @@ negative ARG, display other buffers as well."
325 (setq Buffer-menu-files-only 339 (setq Buffer-menu-files-only
326 (cond ((not arg) (not Buffer-menu-files-only)) 340 (cond ((not arg) (not Buffer-menu-files-only))
327 ((> (prefix-numeric-value arg) 0) t))) 341 ((> (prefix-numeric-value arg) 0) t)))
328 (message (if Buffer-menu-files-only 342 (Buffer-menu--selection-message)
329 "Showing only file-visiting buffers." 343 (revert-buffer))
330 "Showing all non-internal buffers.")) 344
345(defun Buffer-menu-toggle-internal (arg)
346 "Toggle whether the current `buffer-menu' displays internal buffers.
347With a positive ARG, don't show internal buffers. With zero or
348negative ARG, display internal buffers as well."
349 (interactive "P" Buffer-menu-mode)
350 (setq Buffer-menu-show-internal
351 (cond ((not arg) (not Buffer-menu-show-internal))
352 ((> (prefix-numeric-value arg) 0) t)))
353 (Buffer-menu--selection-message)
331 (revert-buffer)) 354 (revert-buffer))
332 355
333(define-obsolete-function-alias 'Buffer-menu-sort 'tabulated-list-sort 356(define-obsolete-function-alias 'Buffer-menu-sort 'tabulated-list-sort
@@ -569,13 +592,17 @@ If UNMARK is non-nil, unmark them."
569(defun Buffer-menu-other-window () 592(defun Buffer-menu-other-window ()
570 "Select this line's buffer in other window, leaving buffer menu visible." 593 "Select this line's buffer in other window, leaving buffer menu visible."
571 (interactive nil Buffer-menu-mode) 594 (interactive nil Buffer-menu-mode)
572 (switch-to-buffer-other-window (Buffer-menu-buffer t))) 595 (let ((display-buffer-overriding-action
596 '(nil (inhibit-same-window . t))))
597 (switch-to-buffer-other-window (Buffer-menu-buffer t))))
573 598
574(defun Buffer-menu-switch-other-window () 599(defun Buffer-menu-switch-other-window ()
575 "Make the other window select this line's buffer. 600 "Make the other window select this line's buffer.
576The current window remains selected." 601The current window remains selected."
577 (interactive nil Buffer-menu-mode) 602 (interactive nil Buffer-menu-mode)
578 (display-buffer (Buffer-menu-buffer t) t)) 603 (let ((display-buffer-overriding-action
604 '(nil (inhibit-same-window . t))))
605 (display-buffer (Buffer-menu-buffer t) t)))
579 606
580(defun Buffer-menu-2-window () 607(defun Buffer-menu-2-window ()
581 "Select this line's buffer, with previous buffer in second window." 608 "Select this line's buffer, with previous buffer in second window."
@@ -667,6 +694,7 @@ See more at `Buffer-menu-filter-predicate'."
667 (marked-buffers (Buffer-menu-marked-buffers)) 694 (marked-buffers (Buffer-menu-marked-buffers))
668 (buffer-menu-buffer (current-buffer)) 695 (buffer-menu-buffer (current-buffer))
669 (show-non-file (not Buffer-menu-files-only)) 696 (show-non-file (not Buffer-menu-files-only))
697 (show-internal Buffer-menu-show-internal)
670 (filter-predicate (and (functionp Buffer-menu-filter-predicate) 698 (filter-predicate (and (functionp Buffer-menu-filter-predicate)
671 Buffer-menu-filter-predicate)) 699 Buffer-menu-filter-predicate))
672 entries name-width) 700 entries name-width)
@@ -686,7 +714,8 @@ See more at `Buffer-menu-filter-predicate'."
686 (file buffer-file-name)) 714 (file buffer-file-name))
687 (when (and (buffer-live-p buffer) 715 (when (and (buffer-live-p buffer)
688 (or buffer-list 716 (or buffer-list
689 (and (or (not (string= (substring name 0 1) " ")) 717 (and (or show-internal
718 (not (string= (substring name 0 1) " "))
690 file) 719 file)
691 (not (eq buffer buffer-menu-buffer)) 720 (not (eq buffer buffer-menu-buffer))
692 (or file show-non-file) 721 (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 @@
1;;; mode-local.el --- Support for mode local facilities -*- lexical-binding:t -*- 1;;; mode-local.el --- Support for mode local facilities -*- lexical-binding:t -*-
2;; 2;;
3;; Copyright (C) 2004-2005, 2007-2024 Free Software Foundation, Inc. 3;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
4;; 4;;
5;; Author: David Ponce <david@dponce.com> 5;; Author: David Ponce <david@dponce.com>
6;; Created: 27 Apr 2004 6;; Created: 27 Apr 2004
@@ -84,7 +84,7 @@ MODES can be a symbol or a list of symbols.
84FUNCTION does not have arguments." 84FUNCTION does not have arguments."
85 (setq modes (ensure-list modes)) 85 (setq modes (ensure-list modes))
86 (mode-local-map-file-buffers 86 (mode-local-map-file-buffers
87 function (lambda () (apply #'derived-mode-p modes)))) 87 function (lambda () (derived-mode-p modes))))
88 88
89;;; Hook machinery 89;;; Hook machinery
90;; 90;;
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:
153 "Return the dynamic macro map for the current buffer." 153 "Return the dynamic macro map for the current buffer."
154 (or semantic-lex-spp-dynamic-macro-symbol-obarray 154 (or semantic-lex-spp-dynamic-macro-symbol-obarray
155 (setq semantic-lex-spp-dynamic-macro-symbol-obarray 155 (setq semantic-lex-spp-dynamic-macro-symbol-obarray
156 (make-vector 13 0)))) 156 (obarray-make 13))))
157 157
158(defsubst semantic-lex-spp-dynamic-map-stack () 158(defsubst semantic-lex-spp-dynamic-map-stack ()
159 "Return the dynamic macro map for the current buffer." 159 "Return the dynamic macro map for the current buffer."
160 (or semantic-lex-spp-dynamic-macro-symbol-obarray-stack 160 (or semantic-lex-spp-dynamic-macro-symbol-obarray-stack
161 (setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack 161 (setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack
162 (make-vector 13 0)))) 162 (obarray-make 13))))
163 163
164(defun semantic-lex-spp-value-valid-p (value) 164(defun semantic-lex-spp-value-valid-p (value)
165 "Return non-nil if VALUE is valid." 165 "Return non-nil if VALUE is valid."
@@ -260,7 +260,7 @@ NAME is the name of the spp macro symbol to define.
260REPLACEMENT a string that would be substituted in for NAME." 260REPLACEMENT a string that would be substituted in for NAME."
261 261
262 ;; Create the symbol hash table 262 ;; Create the symbol hash table
263 (let ((semantic-lex-spp-macro-symbol-obarray (make-vector 13 0)) 263 (let ((semantic-lex-spp-macro-symbol-obarray (obarray-make 13))
264 spec) 264 spec)
265 ;; fill it with stuff 265 ;; fill it with stuff
266 (while specs 266 (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
259apply those properties. 259apply those properties.
260PROPSPECS must be a list of (NAME PROPERTY VALUE) elements." 260PROPSPECS must be a list of (NAME PROPERTY VALUE) elements."
261 ;; Create the symbol hash table 261 ;; Create the symbol hash table
262 (let ((semantic-flex-keywords-obarray (make-vector 13 0)) 262 (let ((semantic-flex-keywords-obarray (obarray-make 13))
263 spec) 263 spec)
264 ;; fill it with stuff 264 ;; fill it with stuff
265 (while specs 265 (while specs
@@ -416,7 +416,7 @@ If optional argument PROPSPECS is non-nil, then interpret it, and
416apply those properties. 416apply those properties.
417PROPSPECS must be a list of (TYPE PROPERTY VALUE)." 417PROPSPECS must be a list of (TYPE PROPERTY VALUE)."
418 ;; Create the symbol hash table 418 ;; Create the symbol hash table
419 (let* ((semantic-lex-types-obarray (make-vector 13 0)) 419 (let* ((semantic-lex-types-obarray (obarray-make 13))
420 spec type tokens token alist default) 420 spec type tokens token alist default)
421 ;; fill it with stuff 421 ;; fill it with stuff
422 (while specs 422 (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."
254See also `comint-read-input-ring' and `comint-write-input-ring'. 254See also `comint-read-input-ring' and `comint-write-input-ring'.
255`comint-mode' makes this a buffer-local variable. You probably want 255`comint-mode' makes this a buffer-local variable. You probably want
256to set this in a mode hook, rather than customize the default value." 256to set this in a mode hook, rather than customize the default value."
257 :type '(choice (const :tag "nil" nil) 257 :type '(choice (const :tag "Disable input history" nil)
258 file) 258 file)
259 :group 'comint) 259 :group 'comint)
260 260
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."
302 ;; never display a stale preview and that the preview doesn't 302 ;; never display a stale preview and that the preview doesn't
303 ;; flicker, even with slow completion backends. 303 ;; flicker, even with slow completion backends.
304 (let* ((beg (completion-preview--get 'completion-preview-beg)) 304 (let* ((beg (completion-preview--get 'completion-preview-beg))
305 (end (max (point) (overlay-start completion-preview--overlay)))
305 (cands (completion-preview--get 'completion-preview-cands)) 306 (cands (completion-preview--get 'completion-preview-cands))
306 (index (completion-preview--get 'completion-preview-index)) 307 (index (completion-preview--get 'completion-preview-index))
307 (cand (nth index cands)) 308 (cand (nth index cands))
308 (len (length cand)) 309 (after (completion-preview--get 'after-string))
309 (end (+ beg len)) 310 (face (get-text-property 0 'face after)))
310 (cur (point)) 311 (if (and (<= beg (point) end (1- (+ beg (length cand))))
311 (face (get-text-property 0 'face (completion-preview--get 'after-string)))) 312 (string-prefix-p (buffer-substring beg end) cand))
312 (if (and (< beg cur end) (string-prefix-p (buffer-substring beg cur) cand))
313 ;; The previous preview is still applicable, update it. 313 ;; The previous preview is still applicable, update it.
314 (overlay-put (completion-preview--make-overlay 314 (overlay-put (completion-preview--make-overlay
315 cur (propertize (substring cand (- cur beg)) 315 end (propertize (substring cand (- end beg))
316 'face face 316 'face face
317 'mouse-face 'completion-preview-highlight 317 'mouse-face 'completion-preview-highlight
318 'keymap completion-preview--mouse-map)) 318 'keymap completion-preview--mouse-map))
319 'completion-preview-end cur) 319 'completion-preview-end end)
320 ;; The previous preview is no longer applicable, hide it. 320 ;; The previous preview is no longer applicable, hide it.
321 (completion-preview-active-mode -1)))) 321 (completion-preview-active-mode -1))))
322 ;; Run `completion-at-point-functions' to get a new candidate. 322 ;; Run `completion-at-point-functions' to get a new candidate.
@@ -366,16 +366,16 @@ prefix argument and defaults to 1."
366 (interactive "p") 366 (interactive "p")
367 (when completion-preview-active-mode 367 (when completion-preview-active-mode
368 (let* ((beg (completion-preview--get 'completion-preview-beg)) 368 (let* ((beg (completion-preview--get 'completion-preview-beg))
369 (end (completion-preview--get 'completion-preview-end))
369 (all (completion-preview--get 'completion-preview-cands)) 370 (all (completion-preview--get 'completion-preview-cands))
370 (cur (completion-preview--get 'completion-preview-index)) 371 (cur (completion-preview--get 'completion-preview-index))
371 (len (length all)) 372 (len (length all))
372 (new (mod (+ cur direction) len)) 373 (new (mod (+ cur direction) len))
373 (str (nth new all)) 374 (str (nth new all)))
374 (pos (point))) 375 (while (or (<= (+ beg (length str)) end)
375 (while (or (<= (+ beg (length str)) pos) 376 (not (string-prefix-p (buffer-substring beg end) str)))
376 (not (string-prefix-p (buffer-substring beg pos) str)))
377 (setq new (mod (+ new direction) len) str (nth new all))) 377 (setq new (mod (+ new direction) len) str (nth new all)))
378 (let ((aft (propertize (substring str (- pos beg)) 378 (let ((aft (propertize (substring str (- end beg))
379 'face (if (< 1 len) 379 'face (if (< 1 len)
380 'completion-preview 380 'completion-preview
381 'completion-preview-exact) 381 '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'."
875;; GNU implements obarrays 875;; GNU implements obarrays
876(defconst cmpl-obarray-length 511) 876(defconst cmpl-obarray-length 511)
877 877
878(defvar cmpl-prefix-obarray (make-vector cmpl-obarray-length 0) 878(defvar cmpl-prefix-obarray (obarray-make cmpl-obarray-length)
879 "An obarray used to store the downcased completion prefixes. 879 "An obarray used to store the downcased completion prefixes.
880Each symbol is bound to a list of completion entries.") 880Each symbol is bound to a list of completion entries.")
881 881
882(defvar cmpl-obarray (make-vector cmpl-obarray-length 0) 882(defvar cmpl-obarray (obarray-make cmpl-obarray-length)
883 "An obarray used to store the downcased completions. 883 "An obarray used to store the downcased completions.
884Each symbol is bound to a single completion entry.") 884Each symbol is bound to a single completion entry.")
885 885
@@ -962,8 +962,8 @@ Each symbol is bound to a single completion entry.")
962(defun clear-all-completions () 962(defun clear-all-completions ()
963 "Initialize the completion storage. All existing completions are lost." 963 "Initialize the completion storage. All existing completions are lost."
964 (interactive) 964 (interactive)
965 (setq cmpl-prefix-obarray (make-vector cmpl-obarray-length 0)) 965 (setq cmpl-prefix-obarray (obarray-make cmpl-obarray-length))
966 (setq cmpl-obarray (make-vector cmpl-obarray-length 0))) 966 (setq cmpl-obarray (obarray-make cmpl-obarray-length)))
967 967
968(defun list-all-completions () 968(defun list-all-completions ()
969 "Return a list of all the known completion entries." 969 "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
@@ -1228,6 +1228,41 @@ If OTHER-WINDOW is non-nil, display in another window."
1228 (message "`%s' is an alias for `%s'" symbol basevar)))) 1228 (message "`%s' is an alias for `%s'" symbol basevar))))
1229 1229
1230;;;###autoload 1230;;;###autoload
1231(defun customize-toggle-option (symbol)
1232 "Toggle the value of boolean option SYMBOL for this session."
1233 (interactive (let ((prompt "Toggle boolean option: ") opts)
1234 (mapatoms
1235 (lambda (sym)
1236 (when (eq (get sym 'custom-type) 'boolean)
1237 (push sym opts))))
1238 (list (intern (completing-read prompt opts nil nil nil nil
1239 (symbol-at-point))))))
1240 (let* ((setter (or (get symbol 'custom-set) #'set-default))
1241 (getter (or (get symbol 'custom-get) #'symbol-value))
1242 (value (condition-case nil
1243 (funcall getter symbol)
1244 (void-variable (error "`%s' is not bound" symbol))))
1245 (type (get symbol 'custom-type)))
1246 (cond
1247 ((eq type 'boolean))
1248 ((and (null type)
1249 (yes-or-no-p
1250 (format "`%s' doesn't have a type, and has the value %S. \
1251Proceed to toggle?" symbol value))))
1252 ((yes-or-no-p
1253 (format "`%s' is of type %s, and has the value %S. \
1254Proceed to toggle?"
1255 symbol type value)))
1256 ((error "Abort toggling of option `%s'" symbol)))
1257 (message "%s user options `%s'."
1258 (if (funcall setter symbol (not value))
1259 "Enabled" "Disabled")
1260 symbol)))
1261
1262;;;###autoload
1263(defalias 'toggle-option #'customize-toggle-option)
1264
1265;;;###autoload
1231(defalias 'customize-variable-other-window 'customize-option-other-window) 1266(defalias 'customize-variable-other-window 'customize-option-other-window)
1232 1267
1233;;;###autoload 1268;;;###autoload
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 @@
32(defun custom-declare-face (face spec doc &rest args) 32(defun custom-declare-face (face spec doc &rest args)
33 "Like `defface', but with FACE evaluated as a normal argument." 33 "Like `defface', but with FACE evaluated as a normal argument."
34 (when (and doc 34 (when (and doc
35 (not (stringp doc))) 35 (not (documentation-stringp doc)))
36 (error "Invalid (or missing) doc string %S" doc)) 36 (error "Invalid (or missing) doc string %S" doc))
37 (unless (get face 'face-defface-spec) 37 (unless (get face 'face-defface-spec)
38 (face-spec-set face (purecopy spec) 'face-defface-spec) 38 (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
371 (auto-save-timeout auto-save (choice (const :tag "off" nil) 371 (auto-save-timeout auto-save (choice (const :tag "off" nil)
372 (integer :format "%v"))) 372 (integer :format "%v")))
373 (echo-keystrokes minibuffer number) 373 (echo-keystrokes minibuffer number)
374 (echo-keystrokes-help minibuffer boolean "30.1")
374 (polling-period keyboard float) 375 (polling-period keyboard float)
375 (double-click-time mouse (restricted-sexp 376 (double-click-time mouse (restricted-sexp
376 :match-alternatives (integerp 'nil 't))) 377 :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.")
163(define-minor-mode desktop-save-mode 163(define-minor-mode desktop-save-mode
164 "Toggle desktop saving (Desktop Save mode). 164 "Toggle desktop saving (Desktop Save mode).
165 165
166When Desktop Save mode is enabled, the state of Emacs is saved from 166When Desktop Save mode is enabled, the state of Emacs is saved from one
167one session to another. In particular, Emacs will save the desktop when 167session to another. The saved Emacs \"desktop configuration\" includes the
168it exits (this may prompt you; see the option `desktop-save'). The next 168buffers, their file names, major modes, buffer positions, window and frame
169time Emacs starts, if this mode is active it will restore the desktop. 169configuration, and some important global variables.
170
171To enable this feature for future sessions, customize `desktop-save-mode'
172to t, or add this line in your init file:
173
174 (desktop-save-mode 1)
175
176When this mode is enabled, Emacs will save the desktop when it exits
177(this may prompt you, see the option `desktop-save'). The next time
178Emacs starts, if this mode is active it will restore the desktop.
170 179
171To manually save the desktop at any time, use the command \\[desktop-save]. 180To manually save the desktop at any time, use the command \\[desktop-save].
172To load it, use \\[desktop-read]. 181To 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."
4321 (prefix-numeric-value arg) 4321 (prefix-numeric-value arg)
4322 (lambda () 4322 (lambda ()
4323 (when (or (not (looking-at-p dired-re-dot)) 4323 (when (or (not (looking-at-p dired-re-dot))
4324 ;; Don't skip symlinks to ".", "..", etc.
4325 (save-excursion
4326 (re-search-forward
4327 dired-permission-flags-regexp nil t)
4328 (eq (char-after (match-beginning 1)) ?l))
4324 (not (equal dired-marker-char dired-del-marker))) 4329 (not (equal dired-marker-char dired-del-marker)))
4325 (delete-char 1) 4330 (delete-char 1)
4326 (insert dired-marker-char)))))))) 4331 (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'."
231 :type 'boolean) 231 :type 'boolean)
232 232
233(defvar byte-compile-dynamic nil 233(defvar byte-compile-dynamic nil
234 "If non-nil, compile function bodies so they load lazily. 234 "Formerly used to compile function bodies so they load lazily.
235They are hidden in comments in the compiled file, 235This variable no longer has any effect.")
236and each one is brought into core when the
237function is called.
238
239To enable this option, make it a file-local variable
240in the source file you want it to apply to.
241For example, add -*-byte-compile-dynamic: t;-*- on the first line.
242
243When this option is true, if you load the compiled file and then move it,
244the functions you loaded will not be able to run.")
245(make-obsolete-variable 'byte-compile-dynamic "not worthwhile any more." "27.1") 236(make-obsolete-variable 'byte-compile-dynamic "not worthwhile any more." "27.1")
246;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp) 237;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp)
247 238
@@ -294,6 +285,7 @@ The information is logged to `byte-compile-log-buffer'."
294(defconst byte-compile-warning-types 285(defconst byte-compile-warning-types
295 '( callargs constants 286 '( callargs constants
296 docstrings docstrings-non-ascii-quotes docstrings-wide 287 docstrings docstrings-non-ascii-quotes docstrings-wide
288 docstrings-control-chars
297 empty-body free-vars ignored-return-value interactive-only 289 empty-body free-vars ignored-return-value interactive-only
298 lexical lexical-dynamic make-local 290 lexical lexical-dynamic make-local
299 mapcar ; obsolete 291 mapcar ; obsolete
@@ -316,6 +308,8 @@ Elements of the list may be:
316 docstrings that are too wide, containing lines longer than both 308 docstrings that are too wide, containing lines longer than both
317 `byte-compile-docstring-max-column' and `fill-column' characters. 309 `byte-compile-docstring-max-column' and `fill-column' characters.
318 Only enabled when `docstrings' also is. 310 Only enabled when `docstrings' also is.
311 docstrings-control-chars
312 docstrings that contain control characters other than NL and TAB
319 empty-body body argument to a special form or macro is empty. 313 empty-body body argument to a special form or macro is empty.
320 free-vars references to variables not in the current lexical scope. 314 free-vars references to variables not in the current lexical scope.
321 ignored-return-value 315 ignored-return-value
@@ -354,7 +348,7 @@ A value of `all' really means all."
354 '(docstrings-non-ascii-quotes) 348 '(docstrings-non-ascii-quotes)
355 "List of warning types that are only enabled during Emacs builds. 349 "List of warning types that are only enabled during Emacs builds.
356This is typically either warning types that are being phased in 350This is typically either warning types that are being phased in
357(but shouldn't be enabled for packages yet), or that are only relevant 351\(but shouldn't be enabled for packages yet), or that are only relevant
358for the Emacs build itself.") 352for the Emacs build itself.")
359 353
360(defvar byte-compile--suppressed-warnings nil 354(defvar byte-compile--suppressed-warnings nil
@@ -1749,68 +1743,100 @@ Also ignore URLs."
1749The byte-compiler will emit a warning for documentation strings 1743The byte-compiler will emit a warning for documentation strings
1750containing lines wider than this. If `fill-column' has a larger 1744containing lines wider than this. If `fill-column' has a larger
1751value, it will override this variable." 1745value, it will override this variable."
1752 :group 'bytecomp
1753 :type 'natnum 1746 :type 'natnum
1754 :safe #'natnump 1747 :safe #'natnump
1755 :version "28.1") 1748 :version "28.1")
1756 1749
1757(define-obsolete-function-alias 'byte-compile-docstring-length-warn 1750(defun byte-compile--list-with-n (list n elem)
1758 'byte-compile-docstring-style-warn "29.1") 1751 "Return LIST with its Nth element replaced by ELEM."
1759 1752 (if (eq elem (nth n list))
1760(defun byte-compile-docstring-style-warn (form) 1753 list
1761 "Warn if there are stylistic problems with the docstring in FORM. 1754 (nconc (take n list)
1762Warn if documentation string of FORM is too wide. 1755 (list elem)
1756 (nthcdr (1+ n) list))))
1757
1758(defun byte-compile--docstring-style-warn (docs kind name)
1759 "Warn if there are stylistic problems in the docstring DOCS.
1760Warn if documentation string is too wide.
1763It is too wide if it has any lines longer than the largest of 1761It is too wide if it has any lines longer than the largest of
1764`fill-column' and `byte-compile-docstring-max-column'." 1762`fill-column' and `byte-compile-docstring-max-column'."
1765 (when (byte-compile-warning-enabled-p 'docstrings) 1763 (when (byte-compile-warning-enabled-p 'docstrings)
1766 (let* ((kind nil) (name nil) (docs nil) 1764 (let* ((name (if (eq (car-safe name) 'quote) (cadr name) name))
1767 (prefix (lambda () 1765 (prefix (lambda ()
1768 (format "%s%s" 1766 (format "%s%s"
1769 kind 1767 kind
1770 (if name (format-message " `%s' " name) ""))))) 1768 (if name (format-message " `%S' " name) "")))))
1771 (pcase (car form) 1769 (let ((col (max byte-compile-docstring-max-column fill-column)))
1772 ((or 'autoload 'custom-declare-variable 'defalias 1770 (when (and (byte-compile-warning-enabled-p 'docstrings-wide)
1773 'defconst 'define-abbrev-table 1771 (byte-compile--wide-docstring-p docs col))
1774 'defvar 'defvaralias 1772 (byte-compile-warn-x
1775 'custom-declare-face) 1773 name
1776 (setq kind (nth 0 form)) 1774 "%sdocstring wider than %s characters" (funcall prefix) col)))
1777 (setq name (nth 1 form)) 1775
1778 (when (and (consp name) (eq (car name) 'quote)) 1776 (when (byte-compile-warning-enabled-p 'docstrings-control-chars)
1779 (setq name (cadr name))) 1777 (let ((start 0)
1780 (setq docs (nth 3 form))) 1778 (len (length docs)))
1781 ('lambda 1779 (while (and (< start len)
1782 (setq kind "") ; can't be "function", unfortunately 1780 (string-match (rx (intersection (in (0 . 31) 127)
1783 (setq docs (nth 2 form)))) 1781 (not (in "\n\t"))))
1784 (when (and kind docs (stringp docs)) 1782 docs start))
1785 (let ((col (max byte-compile-docstring-max-column fill-column))) 1783 (let* ((ofs (match-beginning 0))
1786 (when (and (byte-compile-warning-enabled-p 'docstrings-wide) 1784 (c (aref docs ofs)))
1787 (byte-compile--wide-docstring-p docs col)) 1785 ;; FIXME: it should be possible to use the exact source position
1788 (byte-compile-warn-x 1786 ;; of the control char in most cases, and it would be helpful
1789 name 1787 (byte-compile-warn-x
1790 "%sdocstring wider than %s characters" (funcall prefix) col))) 1788 name
1791 ;; There's a "naked" ' character before a symbol/list, so it 1789 "%sdocstring contains control char #x%02x (position %d)"
1792 ;; should probably be quoted with \=. 1790 (funcall prefix) c ofs)
1793 (when (string-match-p (rx (| (in " \t") bol) 1791 (setq start (1+ ofs))))))
1794 (? (in "\"#")) 1792
1795 "'" 1793 ;; There's a "naked" ' character before a symbol/list, so it
1796 (in "A-Za-z" "(")) 1794 ;; should probably be quoted with \=.
1795 (when (string-match-p (rx (| (in " \t") bol)
1796 (? (in "\"#"))
1797 "'"
1798 (in "A-Za-z" "("))
1799 docs)
1800 (byte-compile-warn-x
1801 name
1802 (concat "%sdocstring has wrong usage of unescaped single quotes"
1803 " (use \\=%c or different quoting such as %c...%c)")
1804 (funcall prefix) ?' ?` ?'))
1805 ;; There's a "Unicode quote" in the string -- it should probably
1806 ;; be an ASCII one instead.
1807 (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
1808 (when (string-match-p (rx (| " \"" (in " \t") bol)
1809 (in "‘’"))
1797 docs) 1810 docs)
1798 (byte-compile-warn-x 1811 (byte-compile-warn-x
1799 name 1812 name
1800 (concat "%sdocstring has wrong usage of unescaped single quotes" 1813 "%sdocstring uses curved single quotes; use %s instead of ‘...’"
1801 " (use \\=%c or different quoting such as %c...%c)") 1814 (funcall prefix) "`...'"))))))
1802 (funcall prefix) ?' ?` ?')) 1815
1803 ;; There's a "Unicode quote" in the string -- it should probably 1816(defvar byte-compile--\#$) ; Special value that will print as `#$'.
1804 ;; be an ASCII one instead. 1817(defvar byte-compile--docstrings nil "Table of already compiled docstrings.")
1805 (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) 1818
1806 (when (string-match-p (rx (| " \"" (in " \t") bol) 1819(defun byte-compile--docstring (doc kind name &optional is-a-value)
1807 (in "‘’")) 1820 (byte-compile--docstring-style-warn doc kind name)
1808 docs) 1821 ;; Make docstrings dynamic, when applicable.
1809 (byte-compile-warn-x 1822 (cond
1810 name 1823 ((and byte-compile-dynamic-docstrings
1811 "%sdocstring uses curved single quotes; use %s instead of ‘...’" 1824 ;; The native compiler doesn't use those dynamic docstrings.
1812 (funcall prefix) "`...'")))))) 1825 (not byte-native-compiling)
1813 form) 1826 ;; Docstrings can only be dynamic when compiling a file.
1827 byte-compile--\#$)
1828 (let* ((byte-pos (with-memoization
1829 ;; Reuse a previously written identical docstring.
1830 ;; This is not done out of thriftiness but to try and
1831 ;; make sure that "equal" functions remain `equal'.
1832 ;; (Often those identical docstrings come from
1833 ;; `help-add-fundoc-usage').
1834 ;; Needed e.g. for `advice-tests-nadvice'.
1835 (gethash doc byte-compile--docstrings)
1836 (byte-compile-output-as-comment doc nil)))
1837 (newdoc (cons byte-compile--\#$ byte-pos)))
1838 (if is-a-value newdoc (macroexp-quote newdoc))))
1839 (t doc)))
1814 1840
1815;; If we have compiled any calls to functions which are not known to be 1841;; If we have compiled any calls to functions which are not known to be
1816;; defined, issue a warning enumerating them. 1842;; defined, issue a warning enumerating them.
@@ -1845,6 +1871,8 @@ It is too wide if it has any lines longer than the largest of
1845 ;; macroenvironment. 1871 ;; macroenvironment.
1846 (copy-alist byte-compile-initial-macro-environment)) 1872 (copy-alist byte-compile-initial-macro-environment))
1847 (byte-compile--outbuffer nil) 1873 (byte-compile--outbuffer nil)
1874 (byte-compile--\#$ nil)
1875 (byte-compile--docstrings (make-hash-table :test 'equal))
1848 (overriding-plist-environment nil) 1876 (overriding-plist-environment nil)
1849 (byte-compile-function-environment nil) 1877 (byte-compile-function-environment nil)
1850 (byte-compile-bound-variables nil) 1878 (byte-compile-bound-variables nil)
@@ -1858,7 +1886,6 @@ It is too wide if it has any lines longer than the largest of
1858 ;; 1886 ;;
1859 (byte-compile-verbose byte-compile-verbose) 1887 (byte-compile-verbose byte-compile-verbose)
1860 (byte-optimize byte-optimize) 1888 (byte-optimize byte-optimize)
1861 (byte-compile-dynamic byte-compile-dynamic)
1862 (byte-compile-dynamic-docstrings 1889 (byte-compile-dynamic-docstrings
1863 byte-compile-dynamic-docstrings) 1890 byte-compile-dynamic-docstrings)
1864 (byte-compile-warnings byte-compile-warnings) 1891 (byte-compile-warnings byte-compile-warnings)
@@ -2373,7 +2400,12 @@ With argument ARG, insert value in current buffer after the form."
2373 (setq case-fold-search nil)) 2400 (setq case-fold-search nil))
2374 (displaying-byte-compile-warnings 2401 (displaying-byte-compile-warnings
2375 (with-current-buffer inbuffer 2402 (with-current-buffer inbuffer
2376 (when byte-compile-current-file 2403 (when byte-compile-dest-file
2404 (setq byte-compile--\#$
2405 (copy-sequence ;It needs to be a fresh new object.
2406 ;; Also it stands for the `load-file-name' when the `.elc' will
2407 ;; be loaded, so make it look like it.
2408 byte-compile-dest-file))
2377 (byte-compile-insert-header byte-compile-current-file 2409 (byte-compile-insert-header byte-compile-current-file
2378 byte-compile--outbuffer) 2410 byte-compile--outbuffer)
2379 ;; Instruct native-comp to ignore this file. 2411 ;; Instruct native-comp to ignore this file.
@@ -2428,8 +2460,7 @@ With argument ARG, insert value in current buffer after the form."
2428(defun byte-compile-insert-header (_filename outbuffer) 2460(defun byte-compile-insert-header (_filename outbuffer)
2429 "Insert a header at the start of OUTBUFFER. 2461 "Insert a header at the start of OUTBUFFER.
2430Call from the source buffer." 2462Call from the source buffer."
2431 (let ((dynamic byte-compile-dynamic) 2463 (let ((optimize byte-optimize))
2432 (optimize byte-optimize))
2433 (with-current-buffer outbuffer 2464 (with-current-buffer outbuffer
2434 (goto-char (point-min)) 2465 (goto-char (point-min))
2435 ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After 2466 ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After
@@ -2463,18 +2494,11 @@ Call from the source buffer."
2463 ((eq optimize 'byte) " byte-level optimization only") 2494 ((eq optimize 'byte) " byte-level optimization only")
2464 (optimize " all optimizations") 2495 (optimize " all optimizations")
2465 (t "out optimization")) 2496 (t "out optimization"))
2466 ".\n" 2497 ".\n\n\n"))))
2467 (if dynamic ";;; Function definitions are lazy-loaded.\n"
2468 "")
2469 "\n\n"))))
2470 2498
2471(defun byte-compile-output-file-form (form) 2499(defun byte-compile-output-file-form (form)
2472 ;; Write the given form to the output buffer, being careful of docstrings 2500 ;; Write the given form to the output buffer, being careful of docstrings
2473 ;; (for `byte-compile-dynamic-docstrings') in defvar, defvaralias, 2501 ;; (for `byte-compile-dynamic-docstrings').
2474 ;; defconst, autoload, and custom-declare-variable.
2475 ;; defalias calls are output directly by byte-compile-file-form-defmumble;
2476 ;; it does not pay to first build the defalias in defmumble and then parse
2477 ;; it here.
2478 (when byte-native-compiling 2502 (when byte-native-compiling
2479 ;; Spill output for the native compiler here 2503 ;; Spill output for the native compiler here
2480 (push (make-byte-to-native-top-level :form form :lexical lexical-binding) 2504 (push (make-byte-to-native-top-level :form form :lexical lexical-binding)
@@ -2484,153 +2508,17 @@ Call from the source buffer."
2484 (print-level nil) 2508 (print-level nil)
2485 (print-quoted t) 2509 (print-quoted t)
2486 (print-gensym t) 2510 (print-gensym t)
2487 (print-circle t)) ; Handle circular data structures. 2511 (print-circle t)
2488 (if (memq (car-safe form) '(defvar defvaralias defconst 2512 (print-continuous-numbering t)
2489 autoload custom-declare-variable)) 2513 (print-number-table (make-hash-table :test #'eq)))
2490 (byte-compile-output-docform nil nil nil '("\n(" ")") form nil 3 nil 2514 (when byte-compile--\#$
2491 (memq (car form) 2515 (puthash byte-compile--\#$ "#$" print-number-table))
2492 '(defvaralias autoload 2516 (princ "\n" byte-compile--outbuffer)
2493 custom-declare-variable))) 2517 (prin1 form byte-compile--outbuffer)
2494 (princ "\n" byte-compile--outbuffer) 2518 nil))
2495 (prin1 form byte-compile--outbuffer)
2496 nil)))
2497 2519
2498(defvar byte-compile--for-effect) 2520(defvar byte-compile--for-effect)
2499 2521
2500(defun byte-compile--output-docform-recurse
2501 (info position form cvecindex docindex specindex quoted)
2502 "Print a form with a doc string. INFO is (prefix postfix).
2503POSITION is where the next doc string is to be inserted.
2504CVECINDEX is the index in the FORM of the constant vector, or nil.
2505DOCINDEX is the index of the doc string (or nil) in the FORM.
2506If SPECINDEX is non-nil, it is the index in FORM
2507of the function bytecode string. In that case,
2508we output that argument and the following argument
2509\(the constants vector) together, for lazy loading.
2510QUOTED says that we have to put a quote before the
2511list that represents a doc string reference.
2512`defvaralias', `autoload' and `custom-declare-variable' need that.
2513
2514Return the position after any inserted docstrings as comments."
2515 (let ((index 0)
2516 doc-string-position)
2517 ;; Insert the doc string, and make it a comment with #@LENGTH.
2518 (when (and byte-compile-dynamic-docstrings
2519 (stringp (nth docindex form)))
2520 (goto-char position)
2521 (setq doc-string-position
2522 (byte-compile-output-as-comment
2523 (nth docindex form) nil)
2524 position (point))
2525 (goto-char (point-max)))
2526
2527 (insert (car info))
2528 (prin1 (car form) byte-compile--outbuffer)
2529 (while (setq form (cdr form))
2530 (setq index (1+ index))
2531 (insert " ")
2532 (cond ((and (numberp specindex) (= index specindex)
2533 ;; Don't handle the definition dynamically
2534 ;; if it refers (or might refer)
2535 ;; to objects already output
2536 ;; (for instance, gensyms in the arg list).
2537 (let (non-nil)
2538 (when (hash-table-p print-number-table)
2539 (maphash (lambda (_k v) (if v (setq non-nil t)))
2540 print-number-table))
2541 (not non-nil)))
2542 ;; Output the byte code and constants specially
2543 ;; for lazy dynamic loading.
2544 (goto-char position)
2545 (let ((lazy-position (byte-compile-output-as-comment
2546 (cons (car form) (nth 1 form))
2547 t)))
2548 (setq position (point))
2549 (goto-char (point-max))
2550 (princ (format "(#$ . %d) nil" lazy-position)
2551 byte-compile--outbuffer)
2552 (setq form (cdr form))
2553 (setq index (1+ index))))
2554 ((eq index cvecindex)
2555 (let* ((cvec (car form))
2556 (len (length cvec))
2557 (index2 0)
2558 elt)
2559 (insert "[")
2560 (while (< index2 len)
2561 (setq elt (aref cvec index2))
2562 (if (byte-code-function-p elt)
2563 (setq position
2564 (byte-compile--output-docform-recurse
2565 '("#[" "]") position
2566 (append elt nil) ; Convert the vector to a list.
2567 2 4 specindex nil))
2568 (prin1 elt byte-compile--outbuffer))
2569 (setq index2 (1+ index2))
2570 (unless (eq index2 len)
2571 (insert " ")))
2572 (insert "]")))
2573 ((= index docindex)
2574 (cond
2575 (doc-string-position
2576 (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
2577 doc-string-position)
2578 byte-compile--outbuffer))
2579 ((stringp (car form))
2580 (let ((print-escape-newlines nil))
2581 (goto-char (prog1 (1+ (point))
2582 (prin1 (car form)
2583 byte-compile--outbuffer)))
2584 (insert "\\\n")
2585 (goto-char (point-max))))
2586 (t (prin1 (car form) byte-compile--outbuffer))))
2587 (t (prin1 (car form) byte-compile--outbuffer))))
2588 (insert (cadr info))
2589 position))
2590
2591(defun byte-compile-output-docform (preface tailpiece name info form
2592 cvecindex docindex
2593 specindex quoted)
2594 "Print a form with a doc string. INFO is (prefix postfix).
2595If PREFACE, NAME, and TAILPIECE are non-nil, print them too,
2596before/after INFO and the FORM but after the doc string itself.
2597CVECINDEX is the index in the FORM of the constant vector, or nil.
2598DOCINDEX is the index of the doc string (or nil) in the FORM.
2599If SPECINDEX is non-nil, it is the index in FORM
2600of the function bytecode string. In that case,
2601we output that argument and the following argument
2602\(the constants vector) together, for lazy loading.
2603QUOTED says that we have to put a quote before the
2604list that represents a doc string reference.
2605`defvaralias', `autoload' and `custom-declare-variable' need that."
2606 ;; We need to examine byte-compile-dynamic-docstrings
2607 ;; in the input buffer (now current), not in the output buffer.
2608 (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
2609 (with-current-buffer byte-compile--outbuffer
2610 (let ((byte-compile-dynamic-docstrings dynamic-docstrings)
2611 (position (point))
2612 (print-continuous-numbering t)
2613 print-number-table
2614 ;; FIXME: The bindings below are only needed for when we're
2615 ;; called from ...-defmumble.
2616 (print-escape-newlines t)
2617 (print-length nil)
2618 (print-level nil)
2619 (print-quoted t)
2620 (print-gensym t)
2621 (print-circle t)) ; Handle circular data structures.
2622 (when preface
2623 ;; FIXME: We don't handle uninterned names correctly.
2624 ;; E.g. if cl-define-compiler-macro uses uninterned name we get:
2625 ;; (defalias '#1=#:foo--cmacro #[514 ...])
2626 ;; (put 'foo 'compiler-macro '#:foo--cmacro)
2627 (insert preface)
2628 (prin1 name byte-compile--outbuffer))
2629 (byte-compile--output-docform-recurse
2630 info position form cvecindex docindex specindex quoted)
2631 (when tailpiece
2632 (insert tailpiece))))))
2633
2634(defun byte-compile-keep-pending (form &optional handler) 2522(defun byte-compile-keep-pending (form &optional handler)
2635 (if (memq byte-optimize '(t source)) 2523 (if (memq byte-optimize '(t source))
2636 (setq form (byte-optimize-one-form form t))) 2524 (setq form (byte-optimize-one-form form t)))
@@ -2650,7 +2538,7 @@ list that represents a doc string reference.
2650 (if byte-compile-output 2538 (if byte-compile-output
2651 (let ((form (byte-compile-out-toplevel t 'file))) 2539 (let ((form (byte-compile-out-toplevel t 'file)))
2652 (cond ((eq (car-safe form) 'progn) 2540 (cond ((eq (car-safe form) 'progn)
2653 (mapc 'byte-compile-output-file-form (cdr form))) 2541 (mapc #'byte-compile-output-file-form (cdr form)))
2654 (form 2542 (form
2655 (byte-compile-output-file-form form))) 2543 (byte-compile-output-file-form form)))
2656 (setq byte-compile-constants nil 2544 (setq byte-compile-constants nil
@@ -2725,12 +2613,12 @@ list that represents a doc string reference.
2725 (setq byte-compile-unresolved-functions 2613 (setq byte-compile-unresolved-functions
2726 (delq (assq funsym byte-compile-unresolved-functions) 2614 (delq (assq funsym byte-compile-unresolved-functions)
2727 byte-compile-unresolved-functions))))) 2615 byte-compile-unresolved-functions)))))
2728 (if (stringp (nth 3 form)) 2616 (let* ((doc (nth 3 form))
2729 (prog1 2617 (newdoc (if (not (stringp doc)) doc
2730 form 2618 (byte-compile--docstring
2731 (byte-compile-docstring-style-warn form)) 2619 doc 'autoload (nth 1 form)))))
2732 ;; No doc string, so we can compile this as a normal form. 2620 (byte-compile-keep-pending (byte-compile--list-with-n form 3 newdoc)
2733 (byte-compile-keep-pending form 'byte-compile-normal-call))) 2621 #'byte-compile-normal-call)))
2734 2622
2735(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) 2623(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
2736(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) 2624(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
@@ -2742,9 +2630,10 @@ list that represents a doc string reference.
2742 (byte-compile-warn-x 2630 (byte-compile-warn-x
2743 sym "global/dynamic var `%s' lacks a prefix" sym))) 2631 sym "global/dynamic var `%s' lacks a prefix" sym)))
2744 2632
2745(defun byte-compile--declare-var (sym) 2633(defun byte-compile--declare-var (sym &optional not-toplevel)
2746 (byte-compile--check-prefixed-var sym) 2634 (byte-compile--check-prefixed-var sym)
2747 (when (memq sym byte-compile-lexical-variables) 2635 (when (and (not not-toplevel)
2636 (memq sym byte-compile-lexical-variables))
2748 (setq byte-compile-lexical-variables 2637 (setq byte-compile-lexical-variables
2749 (delq sym byte-compile-lexical-variables)) 2638 (delq sym byte-compile-lexical-variables))
2750 (when (byte-compile-warning-enabled-p 'lexical sym) 2639 (when (byte-compile-warning-enabled-p 'lexical sym)
@@ -2753,19 +2642,7 @@ list that represents a doc string reference.
2753 (push sym byte-compile--seen-defvars)) 2642 (push sym byte-compile--seen-defvars))
2754 2643
2755(defun byte-compile-file-form-defvar (form) 2644(defun byte-compile-file-form-defvar (form)
2756 (let ((sym (nth 1 form))) 2645 (byte-compile-defvar form 'toplevel))
2757 (byte-compile--declare-var sym)
2758 (if (eq (car form) 'defconst)
2759 (push sym byte-compile-const-variables)))
2760 (if (and (null (cddr form)) ;No `value' provided.
2761 (eq (car form) 'defvar)) ;Just a declaration.
2762 nil
2763 (byte-compile-docstring-style-warn form)
2764 (setq form (copy-sequence form))
2765 (when (consp (nth 2 form))
2766 (setcar (cdr (cdr form))
2767 (byte-compile-top-level (nth 2 form) nil 'file)))
2768 form))
2769 2646
2770(put 'define-abbrev-table 'byte-hunk-handler 2647(put 'define-abbrev-table 'byte-hunk-handler
2771 'byte-compile-file-form-defvar-function) 2648 'byte-compile-file-form-defvar-function)
@@ -2773,26 +2650,37 @@ list that represents a doc string reference.
2773 2650
2774(defun byte-compile-file-form-defvar-function (form) 2651(defun byte-compile-file-form-defvar-function (form)
2775 (pcase-let (((or `',name (let name nil)) (nth 1 form))) 2652 (pcase-let (((or `',name (let name nil)) (nth 1 form)))
2776 (if name (byte-compile--declare-var name))) 2653 (if name (byte-compile--declare-var name))
2777 ;; Variable aliases are better declared before the corresponding variable, 2654 ;; Variable aliases are better declared before the corresponding variable,
2778 ;; since it makes it more likely that only one of the two vars has a value 2655 ;; since it makes it more likely that only one of the two vars has a value
2779 ;; before the `defvaralias' gets executed, which avoids the need to 2656 ;; before the `defvaralias' gets executed, which avoids the need to
2780 ;; merge values. 2657 ;; merge values.
2781 (pcase form 2658 (pcase form
2782 (`(defvaralias ,_ ',newname . ,_) 2659 (`(defvaralias ,_ ',newname . ,_)
2783 (when (memq newname byte-compile-bound-variables) 2660 (when (memq newname byte-compile-bound-variables)
2784 (if (byte-compile-warning-enabled-p 'suspicious) 2661 (if (byte-compile-warning-enabled-p 'suspicious)
2785 (byte-compile-warn-x 2662 (byte-compile-warn-x
2786 newname 2663 newname
2787 "Alias for `%S' should be declared before its referent" newname))))) 2664 "Alias for `%S' should be declared before its referent"
2788 (byte-compile-docstring-style-warn form) 2665 newname)))))
2789 (byte-compile-keep-pending form)) 2666 (let ((doc (nth 3 form)))
2667 (when (stringp doc)
2668 (setcar (nthcdr 3 form)
2669 (byte-compile--docstring doc (nth 0 form) name))))
2670 (byte-compile-keep-pending form)))
2790 2671
2791(put 'custom-declare-variable 'byte-hunk-handler 2672(put 'custom-declare-variable 'byte-hunk-handler
2792 'byte-compile-file-form-defvar-function) 2673 'byte-compile-file-form-defvar-function)
2793 2674
2794(put 'custom-declare-face 'byte-hunk-handler 2675(put 'custom-declare-face 'byte-hunk-handler
2795 'byte-compile-docstring-style-warn) 2676 #'byte-compile--custom-declare-face)
2677(defun byte-compile--custom-declare-face (form)
2678 (let ((kind (nth 0 form)) (name (nth 1 form)) (docs (nth 3 form)))
2679 (when (stringp docs)
2680 (let ((newdocs (byte-compile--docstring docs kind name)))
2681 (unless (eq docs newdocs)
2682 (setq form (byte-compile--list-with-n form 3 newdocs)))))
2683 form))
2796 2684
2797(put 'require 'byte-hunk-handler 'byte-compile-file-form-require) 2685(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
2798(defun byte-compile-file-form-require (form) 2686(defun byte-compile-file-form-require (form)
@@ -2946,34 +2834,24 @@ not to take responsibility for the actual compilation of the code."
2946 (cons (cons bare-name code) 2834 (cons (cons bare-name code)
2947 (symbol-value this-kind)))) 2835 (symbol-value this-kind))))
2948 2836
2949 (if rest 2837 (byte-compile-flush-pending)
2950 ;; There are additional args to `defalias' (like maybe a docstring) 2838 (let ((newform `(defalias ',bare-name
2951 ;; that the code below can't handle: punt! 2839 ,(if macro `'(macro . ,code) code) ,@rest)))
2952 nil
2953 ;; Otherwise, we have a bona-fide defun/defmacro definition, and use
2954 ;; special code to allow dynamic docstrings and byte-code.
2955 (byte-compile-flush-pending)
2956 (when byte-native-compiling 2840 (when byte-native-compiling
2957 ;; Spill output for the native compiler here. 2841 ;; Don't let `byte-compile-output-file-form' push the form to
2842 ;; `byte-to-native-top-level-forms' because we want to use
2843 ;; `make-byte-to-native-func-def' when possible.
2958 (push 2844 (push
2959 (if macro 2845 (if (or macro rest)
2960 (make-byte-to-native-top-level 2846 (make-byte-to-native-top-level
2961 :form `(defalias ',name '(macro . ,code) nil) 2847 :form newform
2962 :lexical lexical-binding) 2848 :lexical lexical-binding)
2963 (make-byte-to-native-func-def :name name 2849 (make-byte-to-native-func-def :name name
2964 :byte-func code)) 2850 :byte-func code))
2965 byte-to-native-top-level-forms)) 2851 byte-to-native-top-level-forms))
2966 ;; Output the form by hand, that's much simpler than having 2852 (let ((byte-native-compiling nil))
2967 ;; b-c-output-file-form analyze the defalias. 2853 (byte-compile-output-file-form newform)))
2968 (byte-compile-output-docform 2854 t))))
2969 "\n(defalias '" ")"
2970 bare-name
2971 (if macro '(" '(macro . #[" "])") '(" #[" "]"))
2972 (append code nil) ; Turn byte-code-function-p into list.
2973 2 4
2974 (and (atom code) byte-compile-dynamic 1)
2975 nil)
2976 t)))))
2977 2855
2978(defun byte-compile-output-as-comment (exp quoted) 2856(defun byte-compile-output-as-comment (exp quoted)
2979 "Print Lisp object EXP in the output file at point, inside a comment. 2857 "Print Lisp object EXP in the output file at point, inside a comment.
@@ -3018,18 +2896,10 @@ otherwise, print without quoting."
3018 2896
3019(defun byte-compile--reify-function (fun) 2897(defun byte-compile--reify-function (fun)
3020 "Return an expression which will evaluate to a function value FUN. 2898 "Return an expression which will evaluate to a function value FUN.
3021FUN should be either a `lambda' value or a `closure' value." 2899FUN should be an interpreted closure."
3022 (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) 2900 (pcase-let* ((`(closure ,env ,args . ,body) fun)
3023 `(closure ,env ,args . ,body)) 2901 (`(,preamble . ,body) (macroexp-parse-body body))
3024 fun)
3025 (preamble nil)
3026 (renv ())) 2902 (renv ()))
3027 ;; Split docstring and `interactive' form from body.
3028 (when (stringp (car body))
3029 (push (pop body) preamble))
3030 (when (eq (car-safe (car body)) 'interactive)
3031 (push (pop body) preamble))
3032 (setq preamble (nreverse preamble))
3033 ;; Turn the function's closed vars (if any) into local let bindings. 2903 ;; Turn the function's closed vars (if any) into local let bindings.
3034 (dolist (binding env) 2904 (dolist (binding env)
3035 (cond 2905 (cond
@@ -3051,41 +2921,39 @@ If FORM is a lambda or a macro, byte-compile it as a function."
3051 (fun (if (symbolp form) 2921 (fun (if (symbolp form)
3052 (symbol-function form) 2922 (symbol-function form)
3053 form)) 2923 form))
3054 (macro (eq (car-safe fun) 'macro))) 2924 (macro (eq (car-safe fun) 'macro))
3055 (if macro 2925 (need-a-value nil))
3056 (setq fun (cdr fun))) 2926 (when macro
3057 (prog1 2927 (setq need-a-value t)
3058 (cond 2928 (setq fun (cdr fun)))
3059 ;; Up until Emacs-24.1, byte-compile silently did nothing 2929 (cond
3060 ;; when asked to compile something invalid. So let's tone 2930 ;; Up until Emacs-24.1, byte-compile silently did nothing
3061 ;; down the complaint from an error to a simple message for 2931 ;; when asked to compile something invalid. So let's tone
3062 ;; the known case where signaling an error causes problems. 2932 ;; down the complaint from an error to a simple message for
3063 ((compiled-function-p fun) 2933 ;; the known case where signaling an error causes problems.
3064 (message "Function %s is already compiled" 2934 ((compiled-function-p fun)
3065 (if (symbolp form) form "provided")) 2935 (message "Function %s is already compiled"
3066 fun) 2936 (if (symbolp form) form "provided"))
3067 (t 2937 fun)
3068 (let (final-eval) 2938 (t
3069 (when (or (symbolp form) (eq (car-safe fun) 'closure)) 2939 (when (or (symbolp form) (eq (car-safe fun) 'closure))
3070 ;; `fun' is a function *value*, so try to recover its corresponding 2940 ;; `fun' is a function *value*, so try to recover its
3071 ;; source code. 2941 ;; corresponding source code.
3072 (setq lexical-binding (eq (car fun) 'closure)) 2942 (when (setq lexical-binding (eq (car-safe fun) 'closure))
3073 (setq fun (byte-compile--reify-function fun)) 2943 (setq fun (byte-compile--reify-function fun)))
3074 (setq final-eval t)) 2944 (setq need-a-value t))
3075 ;; Expand macros. 2945 ;; Expand macros.
3076 (setq fun (byte-compile-preprocess fun)) 2946 (setq fun (byte-compile-preprocess fun))
3077 (setq fun (byte-compile-top-level fun nil 'eval)) 2947 (setq fun (byte-compile-top-level fun nil 'eval))
3078 (if (symbolp form) 2948 (when need-a-value
3079 ;; byte-compile-top-level returns an *expression* equivalent to the 2949 ;; `byte-compile-top-level' returns an *expression* equivalent to
3080 ;; `fun' expression, so we need to evaluate it, tho normally 2950 ;; the `fun' expression, so we need to evaluate it, tho normally
3081 ;; this is not needed because the expression is just a constant 2951 ;; this is not needed because the expression is just a constant
3082 ;; byte-code object, which is self-evaluating. 2952 ;; byte-code object, which is self-evaluating.
3083 (setq fun (eval fun t))) 2953 (setq fun (eval fun lexical-binding)))
3084 (if final-eval 2954 (if macro (push 'macro fun))
3085 (setq fun (eval fun t))) 2955 (if (symbolp form) (fset form fun))
3086 (if macro (push 'macro fun)) 2956 fun))))))
3087 (if (symbolp form) (fset form fun))
3088 fun))))))))
3089 2957
3090(defun byte-compile-sexp (sexp) 2958(defun byte-compile-sexp (sexp)
3091 "Compile and return SEXP." 2959 "Compile and return SEXP."
@@ -3184,9 +3052,9 @@ lambda-expression."
3184 (setq fun (cons 'lambda fun)) 3052 (setq fun (cons 'lambda fun))
3185 (unless (eq 'lambda (car-safe fun)) 3053 (unless (eq 'lambda (car-safe fun))
3186 (error "Not a lambda list: %S" fun))) 3054 (error "Not a lambda list: %S" fun)))
3187 (byte-compile-docstring-style-warn fun)
3188 (byte-compile-check-lambda-list (nth 1 fun)) 3055 (byte-compile-check-lambda-list (nth 1 fun))
3189 (let* ((arglist (nth 1 fun)) 3056 (let* ((arglist (nth 1 fun))
3057 (bare-arglist (byte-run-strip-symbol-positions arglist)) ; for compile-defun.
3190 (arglistvars (byte-run-strip-symbol-positions 3058 (arglistvars (byte-run-strip-symbol-positions
3191 (byte-compile-arglist-vars arglist))) 3059 (byte-compile-arglist-vars arglist)))
3192 (byte-compile-bound-variables 3060 (byte-compile-bound-variables
@@ -3195,16 +3063,22 @@ lambda-expression."
3195 (body (cdr (cdr fun))) 3063 (body (cdr (cdr fun)))
3196 (doc (if (stringp (car body)) 3064 (doc (if (stringp (car body))
3197 (prog1 (car body) 3065 (prog1 (car body)
3198 ;; Discard the doc string 3066 ;; Discard the doc string from the body
3199 ;; unless it is the last element of the body. 3067 ;; unless it is the last element of the body.
3200 (if (cdr body) 3068 (if (cdr body)
3201 (setq body (cdr body)))))) 3069 (setq body (cdr body))))))
3202 (int (assq 'interactive body)) 3070 (int (assq 'interactive body))
3203 command-modes) 3071 command-modes)
3204 (when lexical-binding 3072 (when lexical-binding
3073 (when arglist
3074 ;; byte-compile-make-args-desc lost the args's names,
3075 ;; so preserve them in the docstring.
3076 (setq doc (help-add-fundoc-usage doc bare-arglist)))
3205 (dolist (var arglistvars) 3077 (dolist (var arglistvars)
3206 (when (assq var byte-compile--known-dynamic-vars) 3078 (when (assq var byte-compile--known-dynamic-vars)
3207 (byte-compile--warn-lexical-dynamic var 'lambda)))) 3079 (byte-compile--warn-lexical-dynamic var 'lambda))))
3080 (when (stringp doc)
3081 (setq doc (byte-compile--docstring doc "" nil 'is-a-value)))
3208 ;; Process the interactive spec. 3082 ;; Process the interactive spec.
3209 (when int 3083 (when int
3210 ;; Skip (interactive) if it is in front (the most usual location). 3084 ;; Skip (interactive) if it is in front (the most usual location).
@@ -3248,8 +3122,7 @@ lambda-expression."
3248 (and lexical-binding 3122 (and lexical-binding
3249 (byte-compile-make-lambda-lexenv 3123 (byte-compile-make-lambda-lexenv
3250 arglistvars)) 3124 arglistvars))
3251 reserved-csts)) 3125 reserved-csts)))
3252 (bare-arglist (byte-run-strip-symbol-positions arglist))) ; for compile-defun.
3253 ;; Build the actual byte-coded function. 3126 ;; Build the actual byte-coded function.
3254 (cl-assert (eq 'byte-code (car-safe compiled))) 3127 (cl-assert (eq 'byte-code (car-safe compiled)))
3255 (let ((out 3128 (let ((out
@@ -3261,12 +3134,7 @@ lambda-expression."
3261 ;; byte-string, constants-vector, stack depth 3134 ;; byte-string, constants-vector, stack depth
3262 (cdr compiled) 3135 (cdr compiled)
3263 ;; optionally, the doc string. 3136 ;; optionally, the doc string.
3264 (cond ((and lexical-binding arglist) 3137 (when (or doc int) (list doc))
3265 ;; byte-compile-make-args-desc lost the args's names,
3266 ;; so preserve them in the docstring.
3267 (list (help-add-fundoc-usage doc bare-arglist)))
3268 ((or doc int)
3269 (list doc)))
3270 ;; optionally, the interactive spec (and the modes the 3138 ;; optionally, the interactive spec (and the modes the
3271 ;; command applies to). 3139 ;; command applies to).
3272 (cond 3140 (cond
@@ -3820,7 +3688,6 @@ lambda-expression."
3820 (alen (length (cdr form))) 3688 (alen (length (cdr form)))
3821 (dynbinds ()) 3689 (dynbinds ())
3822 lap) 3690 lap)
3823 (fetch-bytecode fun)
3824 (setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t)) 3691 (setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t))
3825 ;; optimized switch bytecode makes it impossible to guess the correct 3692 ;; optimized switch bytecode makes it impossible to guess the correct
3826 ;; `byte-compile-depth', which can result in incorrect inlined code. 3693 ;; `byte-compile-depth', which can result in incorrect inlined code.
@@ -5147,49 +5014,49 @@ binding slots have been popped."
5147 (push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars)) 5014 (push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars))
5148 (byte-compile-normal-call form)) 5015 (byte-compile-normal-call form))
5149 5016
5150(defun byte-compile-defvar (form) 5017(defun byte-compile-defvar (form &optional toplevel)
5151 ;; This is not used for file-level defvar/consts. 5018 (let* ((fun (nth 0 form))
5152 (when (and (symbolp (nth 1 form)) 5019 (var (nth 1 form))
5153 (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) 5020 (value (nth 2 form))
5154 (byte-compile-warning-enabled-p 'lexical (nth 1 form))) 5021 (string (nth 3 form)))
5155 (byte-compile-warn-x 5022 (byte-compile--declare-var var (not toplevel))
5156 (nth 1 form)
5157 "global/dynamic var `%s' lacks a prefix"
5158 (nth 1 form)))
5159 (byte-compile-docstring-style-warn form)
5160 (let ((fun (nth 0 form))
5161 (var (nth 1 form))
5162 (value (nth 2 form))
5163 (string (nth 3 form)))
5164 (when (or (> (length form) 4)
5165 (and (eq fun 'defconst) (null (cddr form))))
5166 (let ((ncall (length (cdr form))))
5167 (byte-compile-warn-x
5168 fun
5169 "`%s' called with %d argument%s, but %s %s"
5170 fun ncall
5171 (if (= 1 ncall) "" "s")
5172 (if (< ncall 2) "requires" "accepts only")
5173 "2-3")))
5174 (push var byte-compile-bound-variables)
5175 (if (eq fun 'defconst) 5023 (if (eq fun 'defconst)
5176 (push var byte-compile-const-variables)) 5024 (push var byte-compile-const-variables))
5177 (when (and string (not (stringp string))) 5025 (cond
5026 ((stringp string)
5027 (setq string (byte-compile--docstring string fun var 'is-a-value)))
5028 (string
5178 (byte-compile-warn-x 5029 (byte-compile-warn-x
5179 string 5030 string
5180 "third arg to `%s %s' is not a string: %s" 5031 "third arg to `%s %s' is not a string: %s"
5181 fun var string)) 5032 fun var string)))
5182 ;; Delegate the actual work to the function version of the 5033 (if toplevel
5183 ;; special form, named with a "-1" suffix. 5034 ;; At top-level we emit calls to defvar/defconst.
5184 (byte-compile-form-do-effect 5035 (if (and (null (cddr form)) ;No `value' provided.
5185 (cond 5036 (eq (car form) 'defvar)) ;Just a declaration.
5186 ((eq fun 'defconst) `(defconst-1 ',var ,@(nthcdr 2 form))) 5037 nil
5187 ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo. 5038 (let ((tail (nthcdr 4 form)))
5188 (t `(defvar-1 ',var 5039 (when (or tail string) (push string tail))
5189 ;; Don't eval `value' if `defvar' wouldn't eval it either. 5040 (when (cddr form)
5190 ,(if (macroexp-const-p value) value 5041 (push (if (not (consp value)) value
5191 `(if (boundp ',var) nil ,value)) 5042 (byte-compile-top-level value nil 'file))
5192 ,@(nthcdr 3 form))))))) 5043 tail))
5044 `(,fun ,var ,@tail)))
5045 ;; At non-top-level, since there is no byte code for
5046 ;; defvar/defconst, we delegate the actual work to the function
5047 ;; version of the special form, named with a "-1" suffix.
5048 (byte-compile-form-do-effect
5049 (cond
5050 ((eq fun 'defconst)
5051 `(defconst-1 ',var ,@(byte-compile--list-with-n
5052 (nthcdr 2 form) 1 (macroexp-quote string))))
5053 ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo.
5054 (t `(defvar-1 ',var
5055 ;; Don't eval `value' if `defvar' wouldn't eval it either.
5056 ,(if (macroexp-const-p value) value
5057 `(if (boundp ',var) nil ,value))
5058 ,@(byte-compile--list-with-n
5059 (nthcdr 3 form) 0 (macroexp-quote string)))))))))
5193 5060
5194(defun byte-compile-autoload (form) 5061(defun byte-compile-autoload (form)
5195 (and (macroexp-const-p (nth 1 form)) 5062 (and (macroexp-const-p (nth 1 form))
@@ -5215,14 +5082,6 @@ binding slots have been popped."
5215 ;; For the compilation itself, we could largely get rid of this hunk-handler, 5082 ;; For the compilation itself, we could largely get rid of this hunk-handler,
5216 ;; if it weren't for the fact that we need to figure out when a defalias 5083 ;; if it weren't for the fact that we need to figure out when a defalias
5217 ;; defines a macro, so as to add it to byte-compile-macro-environment. 5084 ;; defines a macro, so as to add it to byte-compile-macro-environment.
5218 ;;
5219 ;; FIXME: we also use this hunk-handler to implement the function's
5220 ;; dynamic docstring feature (via byte-compile-file-form-defmumble).
5221 ;; We should probably actually implement it (more elegantly) in
5222 ;; byte-compile-lambda so it applies to all lambdas. We did it here
5223 ;; so the resulting .elc format was recognizable by make-docfile,
5224 ;; but since then we stopped using DOC for the docstrings of
5225 ;; preloaded elc files so that obstacle is gone.
5226 (let ((byte-compile-free-references nil) 5085 (let ((byte-compile-free-references nil)
5227 (byte-compile-free-assignments nil)) 5086 (byte-compile-free-assignments nil))
5228 (pcase form 5087 (pcase form
@@ -5231,7 +5090,11 @@ binding slots have been popped."
5231 ;; - `arg' is the expression to which it is defined. 5090 ;; - `arg' is the expression to which it is defined.
5232 ;; - `rest' is the rest of the arguments. 5091 ;; - `rest' is the rest of the arguments.
5233 (`(,_ ',name ,arg . ,rest) 5092 (`(,_ ',name ,arg . ,rest)
5234 (byte-compile-docstring-style-warn form) 5093 (let ((doc (car rest)))
5094 (when (stringp doc)
5095 (setq rest (byte-compile--list-with-n
5096 rest 0
5097 (byte-compile--docstring doc (nth 0 form) name)))))
5235 (pcase-let* 5098 (pcase-let*
5236 ;; `macro' is non-nil if it defines a macro. 5099 ;; `macro' is non-nil if it defines a macro.
5237 ;; `fun' is the function part of `arg' (defaults to `arg'). 5100 ;; `fun' is the function part of `arg' (defaults to `arg').
@@ -5900,6 +5763,16 @@ and corresponding effects."
5900 (eval form) 5763 (eval form)
5901 form))) 5764 form)))
5902 5765
5766;; Report comma operator used outside of backquote.
5767;; Inside backquote, backquote will transform it before it gets here.
5768
5769(put '\, 'compiler-macro #'bytecomp--report-comma)
5770(defun bytecomp--report-comma (form &rest _ignore)
5771 (macroexp-warn-and-return
5772 (format-message "`%s' called -- perhaps used not within backquote"
5773 (car form))
5774 form (list 'suspicious (car form)) t))
5775
5903;; Check for (in)comparable constant values in calls to `eq', `memq' etc. 5776;; Check for (in)comparable constant values in calls to `eq', `memq' etc.
5904 5777
5905(defun bytecomp--dodgy-eq-arg-p (x number-ok) 5778(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."
621 (cconv-convert exp env extend)) 621 (cconv-convert exp env extend))
622 622
623 (`(,func . ,forms) 623 (`(,func . ,forms)
624 (if (symbolp func) 624 (if (or (symbolp func) (functionp func))
625 ;; First element is function or whatever function-like forms are: 625 ;; First element is function or whatever function-like forms are:
626 ;; or, and, if, catch, progn, prog1, while, until 626 ;; or, and, if, catch, progn, prog1, while, until
627 `(,func . ,(mapcar (lambda (form) 627 (let ((args (mapcar (lambda (form) (cconv-convert form env extend))
628 (cconv-convert form env extend)) 628 forms)))
629 forms)) 629 (unless (symbolp func)
630 (byte-compile-warn-x
631 form
632 "Use `funcall' instead of `%s' in the function position" func))
633 `(,func . ,args))
630 (byte-compile-warn-x form "Malformed function `%S'" func) 634 (byte-compile-warn-x form "Malformed function `%S'" func)
631 nil)) 635 nil))
632 636
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)."
85 (let (alist) 85 (let (alist)
86 (with-temp-buffer 86 (with-temp-buffer
87 (insert-file-contents file) 87 (insert-file-contents file)
88 ;; Ensure shorthands available, as we will be `read'ing Elisp
89 ;; (bug#67523)
90 (let (enable-local-variables) (hack-local-variables))
88 ;; FIXME we could theoretically be inside a string. 91 ;; FIXME we could theoretically be inside a string.
89 (while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t) 92 (while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t)
90 (let ((pos (match-beginning 1))) 93 (let ((pos (match-beginning 1)))
@@ -145,64 +148,70 @@ is a string giving details of the error."
145 (if (file-regular-p fnfile) 148 (if (file-regular-p fnfile)
146 (with-temp-buffer 149 (with-temp-buffer
147 (insert-file-contents fnfile) 150 (insert-file-contents fnfile)
151 (unless cflag
152 ;; If in Elisp, ensure syntax and shorthands available
153 ;; (bug#67523)
154 (set-syntax-table emacs-lisp-mode-syntax-table)
155 (let (enable-local-variables) (hack-local-variables)))
148 ;; defsubst's don't _have_ to be known at compile time. 156 ;; defsubst's don't _have_ to be known at compile time.
149 (setq re (format (if cflag 157 (setq re (if cflag
150 "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" 158 (format "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\""
151 "^[ \t]*(\\(fset[ \t]+'\\|\ 159 (regexp-opt (mapcar 'cadr fnlist) t))
160 "^[ \t]*(\\(fset[ \t]+'\\|\
152cl-def\\(?:generic\\|method\\|un\\)\\|\ 161cl-def\\(?:generic\\|method\\|un\\)\\|\
153def\\(?:un\\|subst\\|foo\\|method\\|class\\|\ 162def\\(?:un\\|subst\\|foo\\|method\\|class\\|\
154ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\ 163ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\
155\\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\ 164\\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\
156ine-overloadable-function\\)\\)\ 165ine-overloadable-function\\)\\)\
157[ \t]*%s\\([ \t;]+\\|$\\)") 166[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)\\([ \t;]+\\|$\\)"))
158 (regexp-opt (mapcar 'cadr fnlist) t)))
159 (while (re-search-forward re nil t) 167 (while (re-search-forward re nil t)
160 (skip-chars-forward " \t\n") 168 (skip-chars-forward " \t\n")
161 (setq fn (match-string 2) 169 (setq fn (symbol-name (car (read-from-string (match-string 2)))))
162 type (match-string 1) 170 (when (member fn (mapcar 'cadr fnlist))
163 ;; (min . max) for a fixed number of arguments, or 171 (setq type (match-string 1)
164 ;; arglists with optional elements. 172 ;; (min . max) for a fixed number of arguments, or
165 ;; (min) for arglists with &rest. 173 ;; arglists with optional elements.
166 ;; sig = 'err means we could not find an arglist. 174 ;; (min) for arglists with &rest.
167 sig (cond (cflag 175 ;; sig = 'err means we could not find an arglist.
168 (or 176 sig (cond (cflag
169 (when (search-forward "," nil t 3) 177 (or
170 (skip-chars-forward " \t\n") 178 (when (search-forward "," nil t 3)
171 ;; Assuming minargs and maxargs on same line. 179 (skip-chars-forward " \t\n")
172 (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\ 180 ;; Assuming minargs and maxargs on same line.
181 (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\
173\\([0-9]+\\|MANY\\|UNEVALLED\\)") 182\\([0-9]+\\|MANY\\|UNEVALLED\\)")
174 (setq minargs (string-to-number 183 (setq minargs (string-to-number
175 (match-string 1)) 184 (match-string 1))
176 maxargs (match-string 2)) 185 maxargs (match-string 2))
177 (cons minargs (unless (string-match "[^0-9]" 186 (cons minargs (unless (string-match "[^0-9]"
178 maxargs) 187 maxargs)
179 (string-to-number 188 (string-to-number
180 maxargs))))) 189 maxargs)))))
181 'err)) 190 'err))
182 ((string-match 191 ((string-match
183 "\\`define-\\(derived\\|generic\\)-mode\\'" 192 "\\`define-\\(derived\\|generic\\)-mode\\'"
184 type) 193 type)
185 '(0 . 0)) 194 '(0 . 0))
186 ((string-match 195 ((string-match
187 "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'" 196 "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'"
188 type) 197 type)
189 '(0 . 1)) 198 '(0 . 1))
190 ;; Prompt to update. 199 ;; Prompt to update.
191 ((string-match 200 ((string-match
192 "\\`define-obsolete-function-alias\\>" 201 "\\`define-obsolete-function-alias\\>"
193 type) 202 type)
194 'obsolete) 203 'obsolete)
195 ;; Can't easily check arguments in these cases. 204 ;; Can't easily check arguments in these cases.
196 ((string-match "\\`\\(def\\(alias\\|class\\)\\|\ 205 ((string-match "\\`\\(def\\(alias\\|class\\)\\|\
197fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) 206fset\\|\\(?:cl-\\)?defmethod\\)\\>" type)
198 t) 207 t)
199 ((looking-at "\\((\\|nil\\)") 208 ((looking-at "\\((\\|nil\\)")
200 (byte-compile-arglist-signature 209 (byte-compile-arglist-signature
201 (read (current-buffer)))) 210 (read (current-buffer))))
202 (t 211 (t
203 'err)) 212 'err))
204 ;; alist of functions and arglist signatures. 213 ;; alist of functions and arglist signatures.
205 siglist (cons (cons fn sig) siglist))))) 214 siglist (cons (cons fn sig) siglist))))))
206 (dolist (e fnlist) 215 (dolist (e fnlist)
207 (setq arglist (nth 2 e) 216 (setq arglist (nth 2 e)
208 type 217 type
@@ -319,9 +328,14 @@ Returns non-nil if any false statements are found."
319 (setq root (directory-file-name (file-relative-name root))) 328 (setq root (directory-file-name (file-relative-name root)))
320 (or (file-directory-p root) 329 (or (file-directory-p root)
321 (error "Directory `%s' not found" root)) 330 (error "Directory `%s' not found" root))
322 (let ((files (directory-files-recursively root "\\.el\\'"))) 331 (when-let* ((files (directory-files-recursively root "\\.el\\'"))
323 (when files 332 (files (mapcan (lambda (file)
324 (apply #'check-declare-files files)))) 333 ;; Filter out lock files.
334 (and (not (string-prefix-p
335 ".#" (file-name-nondirectory file)))
336 (list file)))
337 files)))
338 (apply #'check-declare-files files)))
325 339
326(provide 'check-declare) 340(provide 'check-declare)
327 341
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."
1994 (defun-depth (ppss-depth (syntax-ppss))) 1994 (defun-depth (ppss-depth (syntax-ppss)))
1995 (lst nil) 1995 (lst nil)
1996 (ret nil) 1996 (ret nil)
1997 (oo (make-vector 3 0))) ;substitute obarray for `read' 1997 (oo (obarray-make 3))) ;substitute obarray for `read'
1998 (forward-char 1) 1998 (forward-char 1)
1999 (forward-sexp 1) 1999 (forward-sexp 1)
2000 (skip-chars-forward " \n\t") 2000 (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'."
1140 1140
1141(add-hook 'help-fns-describe-function-functions #'cl--generic-describe) 1141(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
1142(defun cl--generic-describe (function) 1142(defun cl--generic-describe (function)
1143 ;; Supposedly this is called from help-fns, so help-fns should be loaded at
1144 ;; this point.
1145 (declare-function help-fns-short-filename "help-fns" (filename))
1146 (let ((generic (if (symbolp function) (cl--generic function)))) 1143 (let ((generic (if (symbolp function) (cl--generic function))))
1147 (when generic 1144 (when generic
1148 (require 'help-mode) ;Needed for `help-function-def' button!
1149 (save-excursion 1145 (save-excursion
1150 ;; Ensure that we have two blank lines (but not more). 1146 ;; Ensure that we have two blank lines (but not more).
1151 (unless (looking-back "\n\n" (- (point) 2)) 1147 (unless (looking-back "\n\n" (- (point) 2))
@@ -1153,33 +1149,49 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
1153 (insert "This is a generic function.\n\n") 1149 (insert "This is a generic function.\n\n")
1154 (insert (propertize "Implementations:\n\n" 'face 'bold)) 1150 (insert (propertize "Implementations:\n\n" 'face 'bold))
1155 ;; Loop over fanciful generics 1151 ;; Loop over fanciful generics
1156 (dolist (method (cl--generic-method-table generic)) 1152 (cl--map-methods-documentation
1157 (pcase-let* 1153 function
1158 ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))) 1154 (lambda (quals signature file doc)
1159 ;; FIXME: Add hyperlinks for the types as well. 1155 (insert (format "%s%S%s\n\n%s\n\n"
1160 (let ((print-quoted nil) 1156 quals signature
1161 (quals (if (length> qualifiers 0) 1157 (if file (format-message " in `%s'." file) "")
1162 (concat (substring qualifiers 1158 (or doc "Undocumented")))))))))
1163 0 (string-match " *\\'" 1159
1164 qualifiers)) 1160(defun cl--map-methods-documentation (funname metname-printer)
1165 "\n") 1161 "Iterate on FUNNAME's methods documentation at point."
1166 ""))) 1162 ;; Supposedly this is called from help-fns, so help-fns should be loaded at
1167 (insert (format "%s%S" 1163 ;; this point.
1168 quals 1164 (require 'help-fns)
1169 (cons function 1165 (declare-function help-fns-short-filename "help-fns" (filename))
1170 (cl--generic-upcase-formal-args args))))) 1166 (let ((generic (if (symbolp funname) (cl--generic funname))))
1171 (let* ((met-name (cl--generic-load-hist-format 1167 (when generic
1172 function 1168 (require 'help-mode) ;Needed for `help-function-def' button!
1173 (cl--generic-method-qualifiers method) 1169 ;; Loop over fanciful generics
1174 (cl--generic-method-specializers method))) 1170 (dolist (method (cl--generic-method-table generic))
1175 (file (find-lisp-object-file-name met-name 'cl-defmethod))) 1171 (pcase-let*
1176 (when file 1172 ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))
1177 (insert (substitute-command-keys " in `")) 1173 ;; FIXME: Add hyperlinks for the types as well.
1178 (help-insert-xref-button (help-fns-short-filename file) 1174 (quals (if (length> qualifiers 0)
1179 'help-function-def met-name file 1175 (concat (substring qualifiers
1180 'cl-defmethod) 1176 0 (string-match " *\\'"
1181 (insert (substitute-command-keys "'.\n")))) 1177 qualifiers))
1182 (insert "\n" (or doc "Undocumented") "\n\n"))))))) 1178 "\n")
1179 ""))
1180 (met-name (cl--generic-load-hist-format
1181 funname
1182 (cl--generic-method-qualifiers method)
1183 (cl--generic-method-specializers method)))
1184 (file (find-lisp-object-file-name met-name 'cl-defmethod)))
1185 (funcall metname-printer
1186 quals
1187 (cons funname
1188 (cl--generic-upcase-formal-args args))
1189 (when file
1190 (make-text-button (help-fns-short-filename file) nil
1191 'type 'help-function-def
1192 'help-args
1193 (list met-name file 'cl-defmethod)))
1194 doc))))))
1183 1195
1184(defun cl--generic-specializers-apply-to-type-p (specializers type) 1196(defun cl--generic-specializers-apply-to-type-p (specializers type)
1185 "Return non-nil if a method with SPECIALIZERS applies to TYPE." 1197 "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
3344contents of field NAME is matched against PAT, or they can be of 3344contents of field NAME is matched against PAT, or they can be of
3345the form NAME which is a shorthand for (NAME NAME)." 3345the form NAME which is a shorthand for (NAME NAME)."
3346 (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp]))) 3346 (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp])))
3347 `(and (pred (pcase--flip cl-typep ',type)) 3347 `(and (pred (cl-typep _ ',type))
3348 ,@(mapcar 3348 ,@(mapcar
3349 (lambda (field) 3349 (lambda (field)
3350 (let* ((name (if (consp field) (car field) field)) 3350 (let* ((name (if (consp field) (car field) field))
3351 (pat (if (consp field) (cadr field) field))) 3351 (pat (if (consp field) (cadr field) field)))
3352 `(app ,(if (eq (cl-struct-sequence-type type) 'list) 3352 `(app ,(if (eq (cl-struct-sequence-type type) 'list)
3353 `(nth ,(cl-struct-slot-offset type name)) 3353 `(nth ,(cl-struct-slot-offset type name))
3354 `(pcase--flip aref ,(cl-struct-slot-offset type name))) 3354 `(aref _ ,(cl-struct-slot-offset type name)))
3355 ,pat))) 3355 ,pat)))
3356 fields))) 3356 fields)))
3357 3357
@@ -3368,13 +3368,13 @@ the form NAME which is a shorthand for (NAME NAME)."
3368 "Extra special cases for `cl-typep' predicates." 3368 "Extra special cases for `cl-typep' predicates."
3369 (let* ((x1 pred1) (x2 pred2) 3369 (let* ((x1 pred1) (x2 pred2)
3370 (t1 3370 (t1
3371 (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1)) 3371 (and (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1))
3372 (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1)) 3372 (eq '_ (car-safe x1)) (setq x1 (cdr x1))
3373 (null (cdr-safe x1)) (setq x1 (car x1)) 3373 (null (cdr-safe x1)) (setq x1 (car x1))
3374 (eq 'quote (car-safe x1)) (cadr x1))) 3374 (eq 'quote (car-safe x1)) (cadr x1)))
3375 (t2 3375 (t2
3376 (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2)) 3376 (and (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2))
3377 (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2)) 3377 (eq '_ (car-safe x2)) (setq x2 (cdr x2))
3378 (null (cdr-safe x2)) (setq x2 (car x2)) 3378 (null (cdr-safe x2)) (setq x2 (car x2))
3379 (eq 'quote (car-safe x2)) (cadr x2)))) 3379 (eq 'quote (car-safe x2)) (cadr x2))))
3380 (or 3380 (or
@@ -3460,6 +3460,7 @@ Of course, we really can't know that for sure, so it's just a heuristic."
3460 (or (cdr (assq sym byte-compile-function-environment)) 3460 (or (cdr (assq sym byte-compile-function-environment))
3461 (cdr (assq sym macroexpand-all-environment)))))) 3461 (cdr (assq sym macroexpand-all-environment))))))
3462 3462
3463;; Please keep it in sync with `comp-known-predicates'.
3463(pcase-dolist (`(,type . ,pred) 3464(pcase-dolist (`(,type . ,pred)
3464 ;; Mostly kept in alphabetical order. 3465 ;; Mostly kept in alphabetical order.
3465 '((array . arrayp) 3466 '((array . arrayp)
@@ -3487,6 +3488,7 @@ Of course, we really can't know that for sure, so it's just a heuristic."
3487 (natnum . natnump) 3488 (natnum . natnump)
3488 (number . numberp) 3489 (number . numberp)
3489 (null . null) 3490 (null . null)
3491 (obarray . obarrayp)
3490 (overlay . overlayp) 3492 (overlay . overlayp)
3491 (process . processp) 3493 (process . processp)
3492 (real . numberp) 3494 (real . numberp)
@@ -3494,6 +3496,7 @@ Of course, we really can't know that for sure, so it's just a heuristic."
3494 (subr . subrp) 3496 (subr . subrp)
3495 (string . stringp) 3497 (string . stringp)
3496 (symbol . symbolp) 3498 (symbol . symbolp)
3499 (symbol-with-pos . symbol-with-pos-p)
3497 (vector . vectorp) 3500 (vector . vectorp)
3498 (window . windowp) 3501 (window . windowp)
3499 ;; FIXME: Do we really want to consider these types? 3502 ;; 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."
3818(pcase-defmacro cl-type (type) 3821(pcase-defmacro cl-type (type)
3819 "Pcase pattern that matches objects of TYPE. 3822 "Pcase pattern that matches objects of TYPE.
3820TYPE is a type descriptor as accepted by `cl-typep', which see." 3823TYPE is a type descriptor as accepted by `cl-typep', which see."
3821 `(pred (pcase--flip cl-typep ',type))) 3824 `(pred (cl-typep _ ',type)))
3825
3822 3826
3823;; Local variables: 3827;; Local variables:
3824;; generated-autoload-file: "cl-loaddefs.el" 3828;; 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 @@
62 tree-sitter-parser user-ptr font-object font-entity font-spec 62 tree-sitter-parser user-ptr font-object font-entity font-spec
63 condvar mutex thread terminal hash-table frame buffer function 63 condvar mutex thread terminal hash-table frame buffer function
64 window process window-configuration overlay integer-or-marker 64 window process window-configuration overlay integer-or-marker
65 number-or-marker symbol array) 65 number-or-marker symbol array obarray)
66 (number float integer) 66 (number float integer)
67 (number-or-marker marker number) 67 (number-or-marker marker number)
68 (integer bignum fixnum) 68 (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."
240 (integer-or-marker-p (function (t) boolean)) 240 (integer-or-marker-p (function (t) boolean))
241 (integerp (function (t) boolean)) 241 (integerp (function (t) boolean))
242 (interactive-p (function () boolean)) 242 (interactive-p (function () boolean))
243 (intern-soft (function ((or string symbol) &optional vector) symbol)) 243 (intern-soft (function ((or string symbol) &optional (or obarray vector))
244 symbol))
244 (invocation-directory (function () string)) 245 (invocation-directory (function () string))
245 (invocation-name (function () string)) 246 (invocation-name (function () string))
246 (isnan (function (float) boolean)) 247 (isnan (function (float) boolean))
@@ -309,7 +310,7 @@ Used to modify the compiler environment."
309 (numberp (function (t) boolean)) 310 (numberp (function (t) boolean))
310 (one-window-p (function (&optional t t) boolean)) 311 (one-window-p (function (&optional t t) boolean))
311 (overlayp (function (t) boolean)) 312 (overlayp (function (t) boolean))
312 (parse-colon-path (function (string) cons)) 313 (parse-colon-path (function (string) list))
313 (plist-get (function (list t &optional t) t)) 314 (plist-get (function (list t &optional t) t))
314 (plist-member (function (list t &optional t) list)) 315 (plist-member (function (list t &optional t) list))
315 (point (function () integer)) 316 (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 @@
44 ;; TODO can we just add t in `cl--typeof-types'? 44 ;; TODO can we just add t in `cl--typeof-types'?
45 "Like `cl--typeof-types' but with t as common supertype.") 45 "Like `cl--typeof-types' but with t as common supertype.")
46 46
47(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr 47(cl-defstruct (comp-cstr (:constructor comp--type-to-cstr
48 (type &aux 48 (type &aux
49 (null (eq type 'null)) 49 (null (eq type 'null))
50 (integer (eq type 'integer)) 50 (integer (eq type 'integer))
@@ -55,7 +55,7 @@
55 '(nil))) 55 '(nil)))
56 (range (when integer 56 (range (when integer
57 '((- . +)))))) 57 '((- . +))))))
58 (:constructor comp-value-to-cstr 58 (:constructor comp--value-to-cstr
59 (value &aux 59 (value &aux
60 (integer (integerp value)) 60 (integer (integerp value))
61 (valset (unless integer 61 (valset (unless integer
@@ -63,7 +63,7 @@
63 (range (when integer 63 (range (when integer
64 `((,value . ,value)))) 64 `((,value . ,value))))
65 (typeset ()))) 65 (typeset ())))
66 (:constructor comp-irange-to-cstr 66 (:constructor comp--irange-to-cstr
67 (irange &aux 67 (irange &aux
68 (range (list irange)) 68 (range (list irange))
69 (typeset ()))) 69 (typeset ())))
@@ -229,10 +229,10 @@ Return them as multiple value."
229;; builds. 229;; builds.
230(defvar comp-ctxt nil) 230(defvar comp-ctxt nil)
231 231
232(defvar comp-cstr-one (comp-value-to-cstr 1) 232(defvar comp-cstr-one (comp--value-to-cstr 1)
233 "Represent the integer immediate one.") 233 "Represent the integer immediate one.")
234 234
235(defvar comp-cstr-t (comp-type-to-cstr t) 235(defvar comp-cstr-t (comp--type-to-cstr t)
236 "Represent the superclass t.") 236 "Represent the superclass t.")
237 237
238 238
@@ -249,6 +249,8 @@ Return them as multiple value."
249 t) 249 t)
250 ((and (not (symbolp x)) (symbolp y)) 250 ((and (not (symbolp x)) (symbolp y))
251 nil) 251 nil)
252 ((or (consp x) (consp y)
253 nil))
252 (t 254 (t
253 (< (sxhash-equal x) 255 (< (sxhash-equal x)
254 (sxhash-equal y))))))) 256 (sxhash-equal y)))))))
@@ -1211,14 +1213,14 @@ FN non-nil indicates we are parsing a function lambda list."
1211 ('nil 1213 ('nil
1212 (make-comp-cstr :typeset ())) 1214 (make-comp-cstr :typeset ()))
1213 ('fixnum 1215 ('fixnum
1214 (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) 1216 (comp--irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum)))
1215 ('boolean 1217 ('boolean
1216 (comp-type-spec-to-cstr '(member t nil))) 1218 (comp-type-spec-to-cstr '(member t nil)))
1217 ('integer 1219 ('integer
1218 (comp-irange-to-cstr '(- . +))) 1220 (comp--irange-to-cstr '(- . +)))
1219 ('null (comp-value-to-cstr nil)) 1221 ('null (comp--value-to-cstr nil))
1220 ((pred atom) 1222 ((pred atom)
1221 (comp-type-to-cstr type-spec)) 1223 (comp--type-to-cstr type-spec))
1222 (`(or . ,rest) 1224 (`(or . ,rest)
1223 (apply #'comp-cstr-union-make 1225 (apply #'comp-cstr-union-make
1224 (mapcar #'comp-type-spec-to-cstr rest))) 1226 (mapcar #'comp-type-spec-to-cstr rest)))
@@ -1228,16 +1230,16 @@ FN non-nil indicates we are parsing a function lambda list."
1228 (`(not ,cstr) 1230 (`(not ,cstr)
1229 (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) 1231 (comp-cstr-negation-make (comp-type-spec-to-cstr cstr)))
1230 (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) 1232 (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h))
1231 (comp-irange-to-cstr `(,l . ,h))) 1233 (comp--irange-to-cstr `(,l . ,h)))
1232 (`(integer * ,(and (pred integerp) h)) 1234 (`(integer * ,(and (pred integerp) h))
1233 (comp-irange-to-cstr `(- . ,h))) 1235 (comp--irange-to-cstr `(- . ,h)))
1234 (`(integer ,(and (pred integerp) l) *) 1236 (`(integer ,(and (pred integerp) l) *)
1235 (comp-irange-to-cstr `(,l . +))) 1237 (comp--irange-to-cstr `(,l . +)))
1236 (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p)) 1238 (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p))
1237 ;; No float range support :/ 1239 ;; No float range support :/
1238 (comp-type-to-cstr 'float)) 1240 (comp--type-to-cstr 'float))
1239 (`(member . ,rest) 1241 (`(member . ,rest)
1240 (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) 1242 (apply #'comp-cstr-union-make (mapcar #'comp--value-to-cstr rest)))
1241 (`(function ,args ,ret) 1243 (`(function ,args ,ret)
1242 (make-comp-cstr-f 1244 (make-comp-cstr-f
1243 :args (mapcar (lambda (x) 1245 :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 @@
25 25
26;; While the main native compiler is implemented in comp.el, when 26;; While the main native compiler is implemented in comp.el, when
27;; commonly used as a jit compiler it is only loaded by Emacs sub 27;; commonly used as a jit compiler it is only loaded by Emacs sub
28;; processes performing async compilation. This files contains all 28;; processes performing async compilation. This file contains all
29;; the code needed to drive async compilations and any Lisp code 29;; the code needed to drive async compilations and any Lisp code
30;; needed at runtime to run native code. 30;; needed at runtime to run native code.
31 31
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 @@
43(defvar native-comp-eln-load-path) 43(defvar native-comp-eln-load-path)
44(defvar native-comp-enable-subr-trampolines) 44(defvar native-comp-enable-subr-trampolines)
45 45
46(declare-function comp--compile-ctxt-to-file "comp.c") 46(declare-function comp--compile-ctxt-to-file0 "comp.c")
47(declare-function comp--init-ctxt "comp.c") 47(declare-function comp--init-ctxt "comp.c")
48(declare-function comp--release-ctxt "comp.c") 48(declare-function comp--release-ctxt "comp.c")
49(declare-function comp-el-to-eln-filename "comp.c") 49(declare-function comp-el-to-eln-filename "comp.c")
@@ -68,7 +68,7 @@
68 :safe #'integerp 68 :safe #'integerp
69 :version "28.1") 69 :version "28.1")
70 70
71(defcustom native-comp-debug 0 71(defcustom native-comp-debug 0
72 "Debug level for native compilation, a number between 0 and 3. 72 "Debug level for native compilation, a number between 0 and 3.
73This is intended for debugging the compiler itself. 73This is intended for debugging the compiler itself.
74 0 no debug output. 74 0 no debug output.
@@ -155,17 +155,18 @@ native compilation runs.")
155 "Current allocation class. 155 "Current allocation class.
156Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") 156Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.")
157 157
158(defconst comp-passes '(comp-spill-lap 158(defconst comp-passes '(comp--spill-lap
159 comp-limplify 159 comp--limplify
160 comp-fwprop 160 comp--fwprop
161 comp-call-optim 161 comp--call-optim
162 comp-ipa-pure 162 comp--ipa-pure
163 comp-add-cstrs 163 comp--add-cstrs
164 comp-fwprop 164 comp--fwprop
165 comp-tco 165 comp--tco
166 comp-fwprop 166 comp--fwprop
167 comp-remove-type-hints 167 comp--remove-type-hints
168 comp-final) 168 comp--compute-function-types
169 comp--final)
169 "Passes to be executed in order.") 170 "Passes to be executed in order.")
170 171
171(defvar comp-disabled-passes '() 172(defvar comp-disabled-passes '()
@@ -187,31 +188,42 @@ Useful to hook into pass checkers.")
187 finally return h) 188 finally return h)
188 "Hash table function -> `comp-constraint'.") 189 "Hash table function -> `comp-constraint'.")
189 190
191;; Keep it in sync with the `cl-deftype-satisfies' property set in
192;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the
193;; relation type <-> predicate is not bijective (bug#45576).
190(defconst comp-known-predicates 194(defconst comp-known-predicates
191 '((arrayp . array) 195 '((arrayp . array)
192 (atom . atom) 196 (atom . atom)
193 (characterp . fixnum)
194 (booleanp . boolean)
195 (bool-vector-p . bool-vector) 197 (bool-vector-p . bool-vector)
198 (booleanp . boolean)
196 (bufferp . buffer) 199 (bufferp . buffer)
197 (natnump . (integer 0 *))
198 (char-table-p . char-table) 200 (char-table-p . char-table)
199 (hash-table-p . hash-table) 201 (characterp . fixnum)
200 (consp . cons) 202 (consp . cons)
201 (integerp . integer)
202 (floatp . float) 203 (floatp . float)
204 (framep . frame)
203 (functionp . (or function symbol)) 205 (functionp . (or function symbol))
206 (hash-table-p . hash-table)
207 (integer-or-marker-p . integer-or-marker)
204 (integerp . integer) 208 (integerp . integer)
205 (keywordp . keyword) 209 (keywordp . keyword)
206 (listp . list) 210 (listp . list)
207 (numberp . number) 211 (markerp . marker)
212 (natnump . (integer 0 *))
208 (null . null) 213 (null . null)
214 (number-or-marker-p . number-or-marker)
209 (numberp . number) 215 (numberp . number)
216 (numberp . number)
217 (obarrayp . obarray)
218 (overlayp . overlay)
219 (processp . process)
210 (sequencep . sequence) 220 (sequencep . sequence)
211 (stringp . string) 221 (stringp . string)
222 (subrp . subr)
223 (symbol-with-pos-p . symbol-with-pos)
212 (symbolp . symbol) 224 (symbolp . symbol)
213 (vectorp . vector) 225 (vectorp . vector)
214 (integer-or-marker-p . integer-or-marker)) 226 (windowp . window))
215 "Alist predicate -> matched type specifier.") 227 "Alist predicate -> matched type specifier.")
216 228
217(defconst comp-known-predicates-h 229(defconst comp-known-predicates-h
@@ -388,7 +400,7 @@ This is typically for top-level forms other than defun.")
388 (closed nil :type boolean 400 (closed nil :type boolean
389 :documentation "t if closed.") 401 :documentation "t if closed.")
390 ;; All the following are for SSA and CGF analysis. 402 ;; All the following are for SSA and CGF analysis.
391 ;; Keep in sync with `comp-clean-ssa'!! 403 ;; Keep in sync with `comp--clean-ssa'!!
392 (in-edges () :type list 404 (in-edges () :type list
393 :documentation "List of incoming edges.") 405 :documentation "List of incoming edges.")
394 (out-edges () :type list 406 (out-edges () :type list
@@ -416,7 +428,7 @@ into it.")
416 :documentation "Start block LAP address.") 428 :documentation "Start block LAP address.")
417 (non-ret-insn nil :type list 429 (non-ret-insn nil :type list
418 :documentation "Insn known to perform a non local exit. 430 :documentation "Insn known to perform a non local exit.
419`comp-fwprop' may identify and store here basic blocks performing 431`comp--fwprop' may identify and store here basic blocks performing
420non local exits and mark it rewrite it later.") 432non local exits and mark it rewrite it later.")
421 (no-ret nil :type boolean 433 (no-ret nil :type boolean
422 :documentation "t when the block is known to perform a 434 :documentation "t when the block is known to perform a
@@ -507,7 +519,7 @@ CFG is mutated by a pass.")
507 (lambda-list nil :type list 519 (lambda-list nil :type list
508 :documentation "Original lambda-list.")) 520 :documentation "Original lambda-list."))
509 521
510(cl-defstruct (comp-mvar (:constructor make--comp-mvar) 522(cl-defstruct (comp-mvar (:constructor make--comp-mvar0)
511 (:include comp-cstr)) 523 (:include comp-cstr))
512 "A meta-variable being a slot in the meta-stack." 524 "A meta-variable being a slot in the meta-stack."
513 (id nil :type (or null number) 525 (id nil :type (or null number)
@@ -516,6 +528,7 @@ CFG is mutated by a pass.")
516 :documentation "Slot number in the array if a number or 528 :documentation "Slot number in the array if a number or
517 `scratch' for scratch slot.")) 529 `scratch' for scratch slot."))
518 530
531;; In use by comp.c.
519(defun comp-mvar-type-hint-match-p (mvar type-hint) 532(defun comp-mvar-type-hint-match-p (mvar type-hint)
520 "Match MVAR against TYPE-HINT. 533 "Match MVAR against TYPE-HINT.
521In use by the back-end." 534In use by the back-end."
@@ -569,10 +582,9 @@ In use by the back-end."
569 finally return t) 582 finally return t)
570 t)) 583 t))
571 584
572(defsubst comp--symbol-func-to-fun (symbol-funcion) 585(defsubst comp--symbol-func-to-fun (symbol-func)
573 "Given a function called SYMBOL-FUNCION return its `comp-func'." 586 "Given a function called SYMBOL-FUNC return its `comp-func'."
574 (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h 587 (gethash (gethash symbol-func (comp-ctxt-sym-to-c-name-h comp-ctxt))
575 comp-ctxt))
576 (comp-ctxt-funcs-h comp-ctxt))) 588 (comp-ctxt-funcs-h comp-ctxt)))
577 589
578(defun comp--function-pure-p (f) 590(defun comp--function-pure-p (f)
@@ -637,7 +649,7 @@ VERBOSITY is a number between 0 and 3."
637 649
638 650
639 651
640(defmacro comp-loop-insn-in-block (basic-block &rest body) 652(defmacro comp--loop-insn-in-block (basic-block &rest body)
641 "Loop over all insns in BASIC-BLOCK executing BODY. 653 "Loop over all insns in BASIC-BLOCK executing BODY.
642Inside BODY, `insn' and `insn-cell'can be used to read or set the 654Inside BODY, `insn' and `insn-cell'can be used to read or set the
643current instruction or its cell." 655current instruction or its cell."
@@ -651,19 +663,19 @@ current instruction or its cell."
651 663
652;;; spill-lap pass specific code. 664;;; spill-lap pass specific code.
653 665
654(defun comp-lex-byte-func-p (f) 666(defun comp--lex-byte-func-p (f)
655 "Return t if F is a lexically-scoped byte compiled function." 667 "Return t if F is a lexically-scoped byte compiled function."
656 (and (byte-code-function-p f) 668 (and (byte-code-function-p f)
657 (fixnump (aref f 0)))) 669 (fixnump (aref f 0))))
658 670
659(defun comp-spill-decl-spec (function-name spec) 671(defun comp--spill-decl-spec (function-name spec)
660 "Return the declared specifier SPEC for FUNCTION-NAME." 672 "Return the declared specifier SPEC for FUNCTION-NAME."
661 (plist-get (cdr (assq function-name byte-to-native-plist-environment)) 673 (plist-get (cdr (assq function-name byte-to-native-plist-environment))
662 spec)) 674 spec))
663 675
664(defun comp-spill-speed (function-name) 676(defun comp--spill-speed (function-name)
665 "Return the speed for FUNCTION-NAME." 677 "Return the speed for FUNCTION-NAME."
666 (or (comp-spill-decl-spec function-name 'speed) 678 (or (comp--spill-decl-spec function-name 'speed)
667 (comp-ctxt-speed comp-ctxt))) 679 (comp-ctxt-speed comp-ctxt)))
668 680
669;; Autoloaded as might be used by `disassemble-internal'. 681;; Autoloaded as might be used by `disassemble-internal'.
@@ -702,7 +714,7 @@ clashes."
702 ;; pick the first one. 714 ;; pick the first one.
703 (concat prefix crypted "_" human-readable "_0")))) 715 (concat prefix crypted "_" human-readable "_0"))))
704 716
705(defun comp-decrypt-arg-list (x function-name) 717(defun comp--decrypt-arg-list (x function-name)
706 "Decrypt argument list X for FUNCTION-NAME." 718 "Decrypt argument list X for FUNCTION-NAME."
707 (unless (fixnump x) 719 (unless (fixnump x)
708 (signal 'native-compiler-error-dyn-func (list function-name))) 720 (signal 'native-compiler-error-dyn-func (list function-name)))
@@ -717,21 +729,21 @@ clashes."
717 :nonrest nonrest 729 :nonrest nonrest
718 :rest rest)))) 730 :rest rest))))
719 731
720(defsubst comp-byte-frame-size (byte-compiled-func) 732(defsubst comp--byte-frame-size (byte-compiled-func)
721 "Return the frame size to be allocated for BYTE-COMPILED-FUNC." 733 "Return the frame size to be allocated for BYTE-COMPILED-FUNC."
722 (aref byte-compiled-func 3)) 734 (aref byte-compiled-func 3))
723 735
724(defun comp-add-func-to-ctxt (func) 736(defun comp--add-func-to-ctxt (func)
725 "Add FUNC to the current compiler context." 737 "Add FUNC to the current compiler context."
726 (let ((name (comp-func-name func)) 738 (let ((name (comp-func-name func))
727 (c-name (comp-func-c-name func))) 739 (c-name (comp-func-c-name func)))
728 (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt)) 740 (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt))
729 (puthash c-name func (comp-ctxt-funcs-h comp-ctxt)))) 741 (puthash c-name func (comp-ctxt-funcs-h comp-ctxt))))
730 742
731(cl-defgeneric comp-spill-lap-function (input) 743(cl-defgeneric comp--spill-lap-function (input)
732 "Byte-compile INPUT and spill lap for further stages.") 744 "Byte-compile INPUT and spill lap for further stages.")
733 745
734(cl-defmethod comp-spill-lap-function ((function-name symbol)) 746(cl-defmethod comp--spill-lap-function ((function-name symbol))
735 "Byte-compile FUNCTION-NAME, spilling data from the byte compiler." 747 "Byte-compile FUNCTION-NAME, spilling data from the byte compiler."
736 (unless (comp-ctxt-output comp-ctxt) 748 (unless (comp-ctxt-output comp-ctxt)
737 (setf (comp-ctxt-output comp-ctxt) 749 (setf (comp-ctxt-output comp-ctxt)
@@ -747,9 +759,9 @@ clashes."
747 (list (make-byte-to-native-func-def :name function-name 759 (list (make-byte-to-native-func-def :name function-name
748 :c-name c-name 760 :c-name c-name
749 :byte-func byte-code))) 761 :byte-func byte-code)))
750 (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) 762 (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h)))
751 763
752(cl-defmethod comp-spill-lap-function ((form list)) 764(cl-defmethod comp--spill-lap-function ((form list))
753 "Byte-compile FORM, spilling data from the byte compiler." 765 "Byte-compile FORM, spilling data from the byte compiler."
754 (unless (memq (car-safe form) '(lambda closure)) 766 (unless (memq (car-safe form) '(lambda closure))
755 (signal 'native-compiler-error 767 (signal 'native-compiler-error
@@ -763,9 +775,9 @@ clashes."
763 (list (make-byte-to-native-func-def :name '--anonymous-lambda 775 (list (make-byte-to-native-func-def :name '--anonymous-lambda
764 :c-name c-name 776 :c-name c-name
765 :byte-func byte-code))) 777 :byte-func byte-code)))
766 (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) 778 (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h)))
767 779
768(defun comp-intern-func-in-ctxt (_ obj) 780(defun comp--intern-func-in-ctxt (_ obj)
769 "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." 781 "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'."
770 (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) 782 (when-let ((byte-func (byte-to-native-lambda-byte-func obj)))
771 (let* ((lap (byte-to-native-lambda-lap obj)) 783 (let* ((lap (byte-to-native-lambda-lap obj))
@@ -778,9 +790,9 @@ clashes."
778 (name (when top-l-form 790 (name (when top-l-form
779 (byte-to-native-func-def-name top-l-form))) 791 (byte-to-native-func-def-name top-l-form)))
780 (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) 792 (c-name (comp-c-func-name (or name "anonymous-lambda") "F"))
781 (func (if (comp-lex-byte-func-p byte-func) 793 (func (if (comp--lex-byte-func-p byte-func)
782 (make-comp-func-l 794 (make-comp-func-l
783 :args (comp-decrypt-arg-list (aref byte-func 0) 795 :args (comp--decrypt-arg-list (aref byte-func 0)
784 name)) 796 name))
785 (make-comp-func-d :lambda-list (aref byte-func 0))))) 797 (make-comp-func-d :lambda-list (aref byte-func 0)))))
786 (setf (comp-func-name func) name 798 (setf (comp-func-name func) name
@@ -790,9 +802,9 @@ clashes."
790 (comp-func-command-modes func) (command-modes byte-func) 802 (comp-func-command-modes func) (command-modes byte-func)
791 (comp-func-c-name func) c-name 803 (comp-func-c-name func) c-name
792 (comp-func-lap func) lap 804 (comp-func-lap func) lap
793 (comp-func-frame-size func) (comp-byte-frame-size byte-func) 805 (comp-func-frame-size func) (comp--byte-frame-size byte-func)
794 (comp-func-speed func) (comp-spill-speed name) 806 (comp-func-speed func) (comp--spill-speed name)
795 (comp-func-pure func) (comp-spill-decl-spec name 'pure)) 807 (comp-func-pure func) (comp--spill-decl-spec name 'pure))
796 808
797 ;; Store the c-name to have it retrievable from 809 ;; Store the c-name to have it retrievable from
798 ;; `comp-ctxt-top-level-forms'. 810 ;; `comp-ctxt-top-level-forms'.
@@ -800,11 +812,11 @@ clashes."
800 (setf (byte-to-native-func-def-c-name top-l-form) c-name)) 812 (setf (byte-to-native-func-def-c-name top-l-form) c-name))
801 (unless name 813 (unless name
802 (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) 814 (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)))
803 (comp-add-func-to-ctxt func) 815 (comp--add-func-to-ctxt func)
804 (comp-log (format "Function %s:\n" name) 1) 816 (comp-log (format "Function %s:\n" name) 1)
805 (comp-log lap 1 t)))) 817 (comp-log lap 1 t))))
806 818
807(cl-defmethod comp-spill-lap-function ((filename string)) 819(cl-defmethod comp--spill-lap-function ((filename string))
808 "Byte-compile FILENAME, spilling data from the byte compiler." 820 "Byte-compile FILENAME, spilling data from the byte compiler."
809 (byte-compile-file filename) 821 (byte-compile-file filename)
810 (when (or (null byte-native-qualities) 822 (when (or (null byte-native-qualities)
@@ -829,7 +841,7 @@ clashes."
829 collect 841 collect
830 (if (and (byte-to-native-func-def-p form) 842 (if (and (byte-to-native-func-def-p form)
831 (eq -1 843 (eq -1
832 (comp-spill-speed (byte-to-native-func-def-name form)))) 844 (comp--spill-speed (byte-to-native-func-def-name form))))
833 (let ((byte-code (byte-to-native-func-def-byte-func form))) 845 (let ((byte-code (byte-to-native-func-def-byte-func form)))
834 (remhash byte-code byte-to-native-lambdas-h) 846 (remhash byte-code byte-to-native-lambdas-h)
835 (make-byte-to-native-top-level 847 (make-byte-to-native-top-level
@@ -837,11 +849,11 @@ clashes."
837 ',(byte-to-native-func-def-name form) 849 ',(byte-to-native-func-def-name form)
838 ,byte-code 850 ,byte-code
839 nil) 851 nil)
840 :lexical (comp-lex-byte-func-p byte-code))) 852 :lexical (comp--lex-byte-func-p byte-code)))
841 form))) 853 form)))
842 (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) 854 (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))
843 855
844(defun comp-spill-lap (input) 856(defun comp--spill-lap (input)
845 "Byte-compile and spill the LAP representation for INPUT. 857 "Byte-compile and spill the LAP representation for INPUT.
846If INPUT is a symbol, it is the function-name to be compiled. 858If INPUT is a symbol, it is the function-name to be compiled.
847If INPUT is a string, it is the filename to be compiled." 859If 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."
849 (byte-to-native-lambdas-h (make-hash-table :test #'eq)) 861 (byte-to-native-lambdas-h (make-hash-table :test #'eq))
850 (byte-to-native-top-level-forms ()) 862 (byte-to-native-top-level-forms ())
851 (byte-to-native-plist-environment ()) 863 (byte-to-native-plist-environment ())
852 (res (comp-spill-lap-function input))) 864 (res (comp--spill-lap-function input)))
853 (comp-cstr-ctxt-update-type-slots comp-ctxt) 865 (comp-cstr-ctxt-update-type-slots comp-ctxt)
854 res)) 866 res))
855 867
@@ -878,55 +890,55 @@ Points to the next slot to be filled.")
878 byte-switch byte-pushconditioncase) 890 byte-switch byte-pushconditioncase)
879 "LAP end of basic blocks op codes.") 891 "LAP end of basic blocks op codes.")
880 892
881(defun comp-lap-eob-p (inst) 893(defun comp--lap-eob-p (inst)
882 "Return t if INST closes the current basic blocks, nil otherwise." 894 "Return t if INST closes the current basic blocks, nil otherwise."
883 (when (memq (car inst) comp-lap-eob-ops) 895 (when (memq (car inst) comp-lap-eob-ops)
884 t)) 896 t))
885 897
886(defun comp-lap-fall-through-p (inst) 898(defun comp--lap-fall-through-p (inst)
887 "Return t if INST falls through, nil otherwise." 899 "Return t if INST falls through, nil otherwise."
888 (when (not (memq (car inst) '(byte-goto byte-return))) 900 (when (not (memq (car inst) '(byte-goto byte-return)))
889 t)) 901 t))
890 902
891(defsubst comp-sp () 903(defsubst comp--sp ()
892 "Current stack pointer." 904 "Current stack pointer."
893 (declare (gv-setter (lambda (val) 905 (declare (gv-setter (lambda (val)
894 `(setf (comp-limplify-sp comp-pass) ,val)))) 906 `(setf (comp-limplify-sp comp-pass) ,val))))
895 (comp-limplify-sp comp-pass)) 907 (comp-limplify-sp comp-pass))
896 908
897(defmacro comp-with-sp (sp &rest body) 909(defmacro comp--with-sp (sp &rest body)
898 "Execute BODY setting the stack pointer to SP. 910 "Execute BODY setting the stack pointer to SP.
899Restore the original value afterwards." 911Restore the original value afterwards."
900 (declare (debug (form body)) 912 (declare (debug (form body))
901 (indent defun)) 913 (indent defun))
902 (let ((sym (gensym))) 914 (let ((sym (gensym)))
903 `(let ((,sym (comp-sp))) 915 `(let ((,sym (comp--sp)))
904 (setf (comp-sp) ,sp) 916 (setf (comp--sp) ,sp)
905 (progn ,@body) 917 (progn ,@body)
906 (setf (comp-sp) ,sym)))) 918 (setf (comp--sp) ,sym))))
907 919
908(defsubst comp-slot-n (n) 920(defsubst comp--slot-n (n)
909 "Slot N into the meta-stack." 921 "Slot N into the meta-stack."
910 (comp-vec-aref (comp-limplify-frame comp-pass) n)) 922 (comp-vec-aref (comp-limplify-frame comp-pass) n))
911 923
912(defsubst comp-slot () 924(defsubst comp--slot ()
913 "Current slot into the meta-stack pointed by sp." 925 "Current slot into the meta-stack pointed by sp."
914 (comp-slot-n (comp-sp))) 926 (comp--slot-n (comp--sp)))
915 927
916(defsubst comp-slot+1 () 928(defsubst comp--slot+1 ()
917 "Slot into the meta-stack pointed by sp + 1." 929 "Slot into the meta-stack pointed by sp + 1."
918 (comp-slot-n (1+ (comp-sp)))) 930 (comp--slot-n (1+ (comp--sp))))
919 931
920(defsubst comp-label-to-addr (label) 932(defsubst comp--label-to-addr (label)
921 "Find the address of LABEL." 933 "Find the address of LABEL."
922 (or (gethash label (comp-limplify-label-to-addr comp-pass)) 934 (or (gethash label (comp-limplify-label-to-addr comp-pass))
923 (signal 'native-ice (list "label not found" label)))) 935 (signal 'native-ice (list "label not found" label))))
924 936
925(defsubst comp-mark-curr-bb-closed () 937(defsubst comp--mark-curr-bb-closed ()
926 "Mark the current basic block as closed." 938 "Mark the current basic block as closed."
927 (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)) 939 (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t))
928 940
929(defun comp-bb-maybe-add (lap-addr &optional sp) 941(defun comp--bb-maybe-add (lap-addr &optional sp)
930 "If necessary create a pending basic block for LAP-ADDR with stack depth SP. 942 "If necessary create a pending basic block for LAP-ADDR with stack depth SP.
931The basic block is returned regardless it was already declared or not." 943The basic block is returned regardless it was already declared or not."
932 (let ((bb (or (cl-loop ; See if the block was already limplified. 944 (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."
944 (signal 'native-ice (list "incoherent stack pointers" 956 (signal 'native-ice (list "incoherent stack pointers"
945 sp (comp-block-lap-sp bb)))) 957 sp (comp-block-lap-sp bb))))
946 bb) 958 bb)
947 (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym)) 959 (car (push (make--comp-block-lap lap-addr sp (comp--new-block-sym))
948 (comp-limplify-pending-blocks comp-pass)))))) 960 (comp-limplify-pending-blocks comp-pass))))))
949 961
950(defsubst comp-call (func &rest args) 962(defsubst comp--call (func &rest args)
951 "Emit a call for function FUNC with ARGS." 963 "Emit a call for function FUNC with ARGS."
952 `(call ,func ,@args)) 964 `(call ,func ,@args))
953 965
954(defun comp-callref (func nargs stack-off) 966(defun comp--callref (func nargs stack-off)
955 "Emit a call using narg abi for FUNC. 967 "Emit a call using narg abi for FUNC.
956NARGS is the number of arguments. 968NARGS is the number of arguments.
957STACK-OFF is the index of the first slot frame involved." 969STACK-OFF is the index of the first slot frame involved."
958 `(callref ,func ,@(cl-loop repeat nargs 970 `(callref ,func ,@(cl-loop repeat nargs
959 for sp from stack-off 971 for sp from stack-off
960 collect (comp-slot-n sp)))) 972 collect (comp--slot-n sp))))
961 973
962(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg) 974(cl-defun make--comp-mvar (&key slot (constant nil const-vld) type neg)
963 "`comp-mvar' initializer." 975 "`comp-mvar' initializer."
964 (let ((mvar (make--comp-mvar :slot slot))) 976 (let ((mvar (make--comp-mvar0 :slot slot)))
965 (when const-vld 977 (when const-vld
966 (comp--add-const-to-relocs constant) 978 (comp--add-const-to-relocs constant)
967 (setf (comp-cstr-imm mvar) constant)) 979 (setf (comp-cstr-imm mvar) constant))
@@ -971,49 +983,49 @@ STACK-OFF is the index of the first slot frame involved."
971 (setf (comp-mvar-neg mvar) t)) 983 (setf (comp-mvar-neg mvar) t))
972 mvar)) 984 mvar))
973 985
974(defun comp-new-frame (size vsize &optional ssa) 986(defun comp--new-frame (size vsize &optional ssa)
975 "Return a clean frame of meta variables of size SIZE and VSIZE. 987 "Return a clean frame of meta variables of size SIZE and VSIZE.
976If SSA is non-nil, populate it with m-var in ssa form." 988If SSA is non-nil, populate it with m-var in ssa form."
977 (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) 989 (cl-loop with v = (make-comp-vec :beg (- vsize) :end size)
978 for i from (- vsize) below size 990 for i from (- vsize) below size
979 for mvar = (if ssa 991 for mvar = (if ssa
980 (make-comp-ssa-mvar :slot i) 992 (make--comp--ssa-mvar :slot i)
981 (make-comp-mvar :slot i)) 993 (make--comp-mvar :slot i))
982 do (setf (comp-vec-aref v i) mvar) 994 do (setf (comp-vec-aref v i) mvar)
983 finally return v)) 995 finally return v))
984 996
985(defun comp-emit (insn) 997(defun comp--emit (insn)
986 "Emit INSN into basic block BB." 998 "Emit INSN into basic block BB."
987 (let ((bb (comp-limplify-curr-block comp-pass))) 999 (let ((bb (comp-limplify-curr-block comp-pass)))
988 (cl-assert (not (comp-block-closed bb))) 1000 (cl-assert (not (comp-block-closed bb)))
989 (push insn (comp-block-insns bb)))) 1001 (push insn (comp-block-insns bb))))
990 1002
991(defun comp-emit-set-call (call) 1003(defun comp--emit-set-call (call)
992 "Emit CALL assigning the result to the current slot frame. 1004 "Emit CALL assigning the result to the current slot frame.
993If the callee function is known to have a return type, propagate it." 1005If the callee function is known to have a return type, propagate it."
994 (cl-assert call) 1006 (cl-assert call)
995 (comp-emit (list 'set (comp-slot) call))) 1007 (comp--emit (list 'set (comp--slot) call)))
996 1008
997(defun comp-copy-slot (src-n &optional dst-n) 1009(defun comp--copy-slot (src-n &optional dst-n)
998 "Set slot number DST-N to slot number SRC-N as source. 1010 "Set slot number DST-N to slot number SRC-N as source.
999If DST-N is specified, use it; otherwise assume it to be the current slot." 1011If DST-N is specified, use it; otherwise assume it to be the current slot."
1000 (comp-with-sp (or dst-n (comp-sp)) 1012 (comp--with-sp (or dst-n (comp--sp))
1001 (let ((src-slot (comp-slot-n src-n))) 1013 (let ((src-slot (comp--slot-n src-n)))
1002 (cl-assert src-slot) 1014 (cl-assert src-slot)
1003 (comp-emit `(set ,(comp-slot) ,src-slot))))) 1015 (comp--emit `(set ,(comp--slot) ,src-slot)))))
1004 1016
1005(defsubst comp-emit-annotation (str) 1017(defsubst comp--emit-annotation (str)
1006 "Emit annotation STR." 1018 "Emit annotation STR."
1007 (comp-emit `(comment ,str))) 1019 (comp--emit `(comment ,str)))
1008 1020
1009(defsubst comp-emit-setimm (val) 1021(defsubst comp--emit-setimm (val)
1010 "Set constant VAL to current slot." 1022 "Set constant VAL to current slot."
1011 (comp--add-const-to-relocs val) 1023 (comp--add-const-to-relocs val)
1012 ;; Leave relocation index nil on purpose, will be fixed-up in final 1024 ;; Leave relocation index nil on purpose, will be fixed-up in final
1013 ;; by `comp-finalize-relocs'. 1025 ;; by `comp-finalize-relocs'.
1014 (comp-emit `(setimm ,(comp-slot) ,val))) 1026 (comp--emit `(setimm ,(comp--slot) ,val)))
1015 1027
1016(defun comp-make-curr-block (block-name entry-sp &optional addr) 1028(defun comp--make-curr-block (block-name entry-sp &optional addr)
1017 "Create a basic block with BLOCK-NAME and set it as current block. 1029 "Create a basic block with BLOCK-NAME and set it as current block.
1018ENTRY-SP is the sp value when entering. 1030ENTRY-SP is the sp value when entering.
1019Add block to the current function and return it." 1031Add block to the current function and return it."
@@ -1025,104 +1037,104 @@ Add block to the current function and return it."
1025 (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) 1037 (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
1026 bb)) 1038 bb))
1027 1039
1028(defun comp-latch-make-fill (target) 1040(defun comp--latch-make-fill (target)
1029 "Create a latch pointing to TARGET and fill it. 1041 "Create a latch pointing to TARGET and fill it.
1030Return the created latch." 1042Return the created latch."
1031 (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) 1043 (let ((latch (make-comp-latch :name (comp--new-block-sym "latch")))
1032 (curr-bb (comp-limplify-curr-block comp-pass))) 1044 (curr-bb (comp-limplify-curr-block comp-pass)))
1033 ;; See `comp-make-curr-block'. 1045 ;; See `comp--make-curr-block'.
1034 (setf (comp-limplify-curr-block comp-pass) latch) 1046 (setf (comp-limplify-curr-block comp-pass) latch)
1035 (when (< (comp-func-speed comp-func) 3) 1047 (when (< (comp-func-speed comp-func) 3)
1036 ;; At speed 3 the programmer is responsible to manually 1048 ;; At speed 3 the programmer is responsible to manually
1037 ;; place `comp-maybe-gc-or-quit'. 1049 ;; place `comp-maybe-gc-or-quit'.
1038 (comp-emit '(call comp-maybe-gc-or-quit))) 1050 (comp--emit '(call comp-maybe-gc-or-quit)))
1039 ;; See `comp-emit-uncond-jump'. 1051 ;; See `comp--emit-uncond-jump'.
1040 (comp-emit `(jump ,(comp-block-name target))) 1052 (comp--emit `(jump ,(comp-block-name target)))
1041 (comp-mark-curr-bb-closed) 1053 (comp--mark-curr-bb-closed)
1042 (puthash (comp-block-name latch) latch (comp-func-blocks comp-func)) 1054 (puthash (comp-block-name latch) latch (comp-func-blocks comp-func))
1043 (setf (comp-limplify-curr-block comp-pass) curr-bb) 1055 (setf (comp-limplify-curr-block comp-pass) curr-bb)
1044 latch)) 1056 latch))
1045 1057
1046(defun comp-emit-uncond-jump (lap-label) 1058(defun comp--emit-uncond-jump (lap-label)
1047 "Emit an unconditional branch to LAP-LABEL." 1059 "Emit an unconditional branch to LAP-LABEL."
1048 (cl-destructuring-bind (label-num . stack-depth) lap-label 1060 (cl-destructuring-bind (label-num . stack-depth) lap-label
1049 (when stack-depth 1061 (when stack-depth
1050 (cl-assert (= (1- stack-depth) (comp-sp)))) 1062 (cl-assert (= (1- stack-depth) (comp--sp))))
1051 (let* ((target-addr (comp-label-to-addr label-num)) 1063 (let* ((target-addr (comp--label-to-addr label-num))
1052 (target (comp-bb-maybe-add target-addr 1064 (target (comp--bb-maybe-add target-addr
1053 (comp-sp))) 1065 (comp--sp)))
1054 (latch (when (< target-addr (comp-limplify-pc comp-pass)) 1066 (latch (when (< target-addr (comp-limplify-pc comp-pass))
1055 (comp-latch-make-fill target))) 1067 (comp--latch-make-fill target)))
1056 (eff-target-name (comp-block-name (or latch target)))) 1068 (eff-target-name (comp-block-name (or latch target))))
1057 (comp-emit `(jump ,eff-target-name)) 1069 (comp--emit `(jump ,eff-target-name))
1058 (comp-mark-curr-bb-closed)))) 1070 (comp--mark-curr-bb-closed))))
1059 1071
1060(defun comp-emit-cond-jump (a b target-offset lap-label negated) 1072(defun comp--emit-cond-jump (a b target-offset lap-label negated)
1061 "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. 1073 "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ.
1062TARGET-OFFSET is the positive offset on the SP when branching to the target 1074TARGET-OFFSET is the positive offset on the SP when branching to the target
1063block. 1075block.
1064If NEGATED is non null, negate the tested condition. 1076If NEGATED is non null, negate the tested condition.
1065Return value is the fall-through block name." 1077Return value is the fall-through block name."
1066 (cl-destructuring-bind (label-num . label-sp) lap-label 1078 (cl-destructuring-bind (label-num . label-sp) lap-label
1067 (let* ((bb (comp-block-name (comp-bb-maybe-add 1079 (let* ((bb (comp-block-name (comp--bb-maybe-add
1068 (1+ (comp-limplify-pc comp-pass)) 1080 (1+ (comp-limplify-pc comp-pass))
1069 (comp-sp)))) ; Fall through block. 1081 (comp--sp)))) ; Fall through block.
1070 (target-sp (+ target-offset (comp-sp))) 1082 (target-sp (+ target-offset (comp--sp)))
1071 (target-addr (comp-label-to-addr label-num)) 1083 (target-addr (comp--label-to-addr label-num))
1072 (target (comp-bb-maybe-add target-addr target-sp)) 1084 (target (comp--bb-maybe-add target-addr target-sp))
1073 (latch (when (< target-addr (comp-limplify-pc comp-pass)) 1085 (latch (when (< target-addr (comp-limplify-pc comp-pass))
1074 (comp-latch-make-fill target))) 1086 (comp--latch-make-fill target)))
1075 (eff-target-name (comp-block-name (or latch target)))) 1087 (eff-target-name (comp-block-name (or latch target))))
1076 (when label-sp 1088 (when label-sp
1077 (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) 1089 (cl-assert (= (1- label-sp) (+ target-offset (comp--sp)))))
1078 (comp-emit (if negated 1090 (comp--emit (if negated
1079 (list 'cond-jump a b bb eff-target-name) 1091 (list 'cond-jump a b bb eff-target-name)
1080 (list 'cond-jump a b eff-target-name bb))) 1092 (list 'cond-jump a b eff-target-name bb)))
1081 (comp-mark-curr-bb-closed) 1093 (comp--mark-curr-bb-closed)
1082 bb))) 1094 bb)))
1083 1095
1084(defun comp-emit-handler (lap-label handler-type) 1096(defun comp--emit-handler (lap-label handler-type)
1085 "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE." 1097 "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE."
1086 (cl-destructuring-bind (label-num . label-sp) lap-label 1098 (cl-destructuring-bind (label-num . label-sp) lap-label
1087 (cl-assert (= (- label-sp 2) (comp-sp))) 1099 (cl-assert (= (- label-sp 2) (comp--sp)))
1088 (setf (comp-func-has-non-local comp-func) t) 1100 (setf (comp-func-has-non-local comp-func) t)
1089 (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) 1101 (let* ((guarded-bb (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass))
1090 (comp-sp))) 1102 (comp--sp)))
1091 (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) 1103 (handler-bb (comp--bb-maybe-add (comp--label-to-addr label-num)
1092 (1+ (comp-sp)))) 1104 (1+ (comp--sp))))
1093 (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym)))) 1105 (pop-bb (make--comp-block-lap nil (comp--sp) (comp--new-block-sym))))
1094 (comp-emit (list 'push-handler 1106 (comp--emit (list 'push-handler
1095 handler-type 1107 handler-type
1096 (comp-slot+1) 1108 (comp--slot+1)
1097 (comp-block-name pop-bb) 1109 (comp-block-name pop-bb)
1098 (comp-block-name guarded-bb))) 1110 (comp-block-name guarded-bb)))
1099 (comp-mark-curr-bb-closed) 1111 (comp--mark-curr-bb-closed)
1100 ;; Emit the basic block to pop the handler if we got the non local. 1112 ;; Emit the basic block to pop the handler if we got the non local.
1101 (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func)) 1113 (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func))
1102 (setf (comp-limplify-curr-block comp-pass) pop-bb) 1114 (setf (comp-limplify-curr-block comp-pass) pop-bb)
1103 (comp-emit `(fetch-handler ,(comp-slot+1))) 1115 (comp--emit `(fetch-handler ,(comp--slot+1)))
1104 (comp-emit `(jump ,(comp-block-name handler-bb))) 1116 (comp--emit `(jump ,(comp-block-name handler-bb)))
1105 (comp-mark-curr-bb-closed)))) 1117 (comp--mark-curr-bb-closed))))
1106 1118
1107(defun comp-limplify-listn (n) 1119(defun comp--limplify-listn (n)
1108 "Limplify list N." 1120 "Limplify list N."
1109 (comp-with-sp (+ (comp-sp) n -1) 1121 (comp--with-sp (+ (comp--sp) n -1)
1110 (comp-emit-set-call (comp-call 'cons 1122 (comp--emit-set-call (comp--call 'cons
1111 (comp-slot) 1123 (comp--slot)
1112 (make-comp-mvar :constant nil)))) 1124 (make--comp-mvar :constant nil))))
1113 (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) 1125 (cl-loop for sp from (+ (comp--sp) n -2) downto (comp--sp)
1114 do (comp-with-sp sp 1126 do (comp--with-sp sp
1115 (comp-emit-set-call (comp-call 'cons 1127 (comp--emit-set-call (comp--call 'cons
1116 (comp-slot) 1128 (comp--slot)
1117 (comp-slot+1)))))) 1129 (comp--slot+1))))))
1118 1130
1119(defun comp-new-block-sym (&optional postfix) 1131(defun comp--new-block-sym (&optional postfix)
1120 "Return a unique symbol postfixing POSTFIX naming the next new basic block." 1132 "Return a unique symbol postfixing POSTFIX naming the next new basic block."
1121 (intern (format (if postfix "bb_%s_%s" "bb_%s") 1133 (intern (format (if postfix "bb_%s_%s" "bb_%s")
1122 (funcall (comp-func-block-cnt-gen comp-func)) 1134 (funcall (comp-func-block-cnt-gen comp-func))
1123 postfix))) 1135 postfix)))
1124 1136
1125(defun comp-fill-label-h () 1137(defun comp--fill-label-h ()
1126 "Fill label-to-addr hash table for the current function." 1138 "Fill label-to-addr hash table for the current function."
1127 (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) 1139 (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql))
1128 (cl-loop for insn in (comp-func-lap comp-func) 1140 (cl-loop for insn in (comp-func-lap comp-func)
@@ -1131,7 +1143,7 @@ Return value is the fall-through block name."
1131 (`(TAG ,label . ,_) 1143 (`(TAG ,label . ,_)
1132 (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) 1144 (puthash label addr (comp-limplify-label-to-addr comp-pass))))))
1133 1145
1134(defun comp-jump-table-optimizable (jmp-table) 1146(defun comp--jump-table-optimizable (jmp-table)
1135 "Return t if JMP-TABLE can be optimized out." 1147 "Return t if JMP-TABLE can be optimized out."
1136 ;; Identify LAP sequences like: 1148 ;; Identify LAP sequences like:
1137 ;; (byte-constant #s(hash-table test eq purecopy t data (created 126 deleted 126 changed 126)) . 24) 1149 ;; (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."
1143 (`(TAG ,target . ,_label-sp) 1155 (`(TAG ,target . ,_label-sp)
1144 (= target (car targets))))))) 1156 (= target (car targets)))))))
1145 1157
1146(defun comp-emit-switch (var last-insn) 1158(defun comp--emit-switch (var last-insn)
1147 "Emit a Limple for a lap jump table given VAR and LAST-INSN." 1159 "Emit a Limple for a lap jump table given VAR and LAST-INSN."
1148 ;; FIXME this not efficient for big jump tables. We should have a second 1160 ;; FIXME this not efficient for big jump tables. We should have a second
1149 ;; strategy for this case. 1161 ;; strategy for this case.
1150 (pcase last-insn 1162 (pcase last-insn
1151 (`(setimm ,_ ,jmp-table) 1163 (`(setimm ,_ ,jmp-table)
1152 (unless (comp-jump-table-optimizable jmp-table) 1164 (unless (comp--jump-table-optimizable jmp-table)
1153 (cl-loop 1165 (cl-loop
1154 for test being each hash-keys of jmp-table 1166 for test being each hash-keys of jmp-table
1155 using (hash-value target-label) 1167 using (hash-value target-label)
@@ -1157,27 +1169,27 @@ Return value is the fall-through block name."
1157 with test-func = (hash-table-test jmp-table) 1169 with test-func = (hash-table-test jmp-table)
1158 for n from 1 1170 for n from 1
1159 for last = (= n len) 1171 for last = (= n len)
1160 for m-test = (make-comp-mvar :constant test) 1172 for m-test = (make--comp-mvar :constant test)
1161 for target-name = (comp-block-name (comp-bb-maybe-add 1173 for target-name = (comp-block-name (comp--bb-maybe-add
1162 (comp-label-to-addr target-label) 1174 (comp--label-to-addr target-label)
1163 (comp-sp))) 1175 (comp--sp)))
1164 for ff-bb = (if last 1176 for ff-bb = (if last
1165 (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) 1177 (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass))
1166 (comp-sp)) 1178 (comp--sp))
1167 (make--comp-block-lap nil 1179 (make--comp-block-lap nil
1168 (comp-sp) 1180 (comp--sp)
1169 (comp-new-block-sym))) 1181 (comp--new-block-sym)))
1170 for ff-bb-name = (comp-block-name ff-bb) 1182 for ff-bb-name = (comp-block-name ff-bb)
1171 if (eq test-func 'eq) 1183 if (eq test-func 'eq)
1172 do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name)) 1184 do (comp--emit (list 'cond-jump var m-test target-name ff-bb-name))
1173 else 1185 else
1174 ;; Store the result of the comparison into the scratch slot before 1186 ;; Store the result of the comparison into the scratch slot before
1175 ;; emitting the conditional jump. 1187 ;; emitting the conditional jump.
1176 do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) 1188 do (comp--emit (list 'set (make--comp-mvar :slot 'scratch)
1177 (comp-call test-func var m-test))) 1189 (comp--call test-func var m-test)))
1178 (comp-emit (list 'cond-jump 1190 (comp--emit (list 'cond-jump
1179 (make-comp-mvar :slot 'scratch) 1191 (make--comp-mvar :slot 'scratch)
1180 (make-comp-mvar :constant nil) 1192 (make--comp-mvar :constant nil)
1181 ff-bb-name target-name)) 1193 ff-bb-name target-name))
1182 unless last 1194 unless last
1183 ;; All fall through are artificially created here except the last one. 1195 ;; All fall through are artificially created here except the last one.
@@ -1192,7 +1204,7 @@ SUBR-NAME is the name of function."
1192 (or (gethash subr-name comp-subr-arities-h) 1204 (or (gethash subr-name comp-subr-arities-h)
1193 (func-arity subr-name))) 1205 (func-arity subr-name)))
1194 1206
1195(defun comp-emit-set-call-subr (subr-name sp-delta) 1207(defun comp--emit-set-call-subr (subr-name sp-delta)
1196 "Emit a call for SUBR-NAME. 1208 "Emit a call for SUBR-NAME.
1197SP-DELTA is the stack adjustment." 1209SP-DELTA is the stack adjustment."
1198 (let* ((nargs (1+ (- sp-delta))) 1210 (let* ((nargs (1+ (- sp-delta)))
@@ -1203,39 +1215,39 @@ SP-DELTA is the stack adjustment."
1203 (signal 'native-ice (list "subr contains unevalled args" subr-name))) 1215 (signal 'native-ice (list "subr contains unevalled args" subr-name)))
1204 (if (eq maxarg 'many) 1216 (if (eq maxarg 'many)
1205 ;; callref case. 1217 ;; callref case.
1206 (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) 1218 (comp--emit-set-call (comp--callref subr-name nargs (comp--sp)))
1207 ;; Normal call. 1219 ;; Normal call.
1208 (unless (and (>= maxarg nargs) (<= minarg nargs)) 1220 (unless (and (>= maxarg nargs) (<= minarg nargs))
1209 (signal 'native-ice 1221 (signal 'native-ice
1210 (list "incoherent stack adjustment" nargs maxarg minarg))) 1222 (list "incoherent stack adjustment" nargs maxarg minarg)))
1211 (let* ((subr-name subr-name) 1223 (let* ((subr-name subr-name)
1212 (slots (cl-loop for i from 0 below maxarg 1224 (slots (cl-loop for i from 0 below maxarg
1213 collect (comp-slot-n (+ i (comp-sp)))))) 1225 collect (comp--slot-n (+ i (comp--sp))))))
1214 (comp-emit-set-call (apply #'comp-call (cons subr-name slots))))))) 1226 (comp--emit-set-call (apply #'comp--call (cons subr-name slots)))))))
1215 1227
1216(eval-when-compile 1228(eval-when-compile
1217 (defun comp-op-to-fun (x) 1229 (defun comp--op-to-fun (x)
1218 "Given the LAP op strip \"byte-\" to have the subr name." 1230 "Given the LAP op strip \"byte-\" to have the subr name."
1219 (intern (string-replace "byte-" "" x))) 1231 (intern (string-replace "byte-" "" x)))
1220 1232
1221 (defun comp-body-eff (body op-name sp-delta) 1233 (defun comp--body-eff (body op-name sp-delta)
1222 "Given the original BODY, compute the effective one. 1234 "Given the original BODY, compute the effective one.
1223When BODY is `auto', guess function name from the LAP byte-code 1235When BODY is `auto', guess function name from the LAP byte-code
1224name. Otherwise expect lname fnname." 1236name. Otherwise expect lname fnname."
1225 (pcase (car body) 1237 (pcase (car body)
1226 ('auto 1238 ('auto
1227 `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta))) 1239 `((comp--emit-set-call-subr ',(comp--op-to-fun op-name) ,sp-delta)))
1228 ((pred symbolp) 1240 ((pred symbolp)
1229 `((comp-emit-set-call-subr ',(car body) ,sp-delta))) 1241 `((comp--emit-set-call-subr ',(car body) ,sp-delta)))
1230 (_ body)))) 1242 (_ body))))
1231 1243
1232(defmacro comp-op-case (&rest cases) 1244(defmacro comp--op-case (&rest cases)
1233 "Expand CASES into the corresponding `pcase' expansion. 1245 "Expand CASES into the corresponding `pcase' expansion.
1234This is responsible for generating the proper stack adjustment, when known, 1246This is responsible for generating the proper stack adjustment, when known,
1235and the annotation emission." 1247and the annotation emission."
1236 (declare (debug (body)) 1248 (declare (debug (body))
1237 (indent defun)) 1249 (indent defun))
1238 (declare-function comp-body-eff nil (body op-name sp-delta)) 1250 (declare-function comp--body-eff nil (body op-name sp-delta))
1239 `(pcase op 1251 `(pcase op
1240 ,@(cl-loop for (op . body) in cases 1252 ,@(cl-loop for (op . body) in cases
1241 for sp-delta = (gethash op comp-op-stack-info) 1253 for sp-delta = (gethash op comp-op-stack-info)
@@ -1244,55 +1256,55 @@ and the annotation emission."
1244 collect `(',op 1256 collect `(',op
1245 ;; Log all LAP ops except the TAG one. 1257 ;; Log all LAP ops except the TAG one.
1246 ;; ,(unless (eq op 'TAG) 1258 ;; ,(unless (eq op 'TAG)
1247 ;; `(comp-emit-annotation 1259 ;; `(comp--emit-annotation
1248 ;; ,(concat "LAP op " op-name))) 1260 ;; ,(concat "LAP op " op-name)))
1249 ;; Emit the stack adjustment if present. 1261 ;; Emit the stack adjustment if present.
1250 ,(when (and sp-delta (not (eq 0 sp-delta))) 1262 ,(when (and sp-delta (not (eq 0 sp-delta)))
1251 `(cl-incf (comp-sp) ,sp-delta)) 1263 `(cl-incf (comp--sp) ,sp-delta))
1252 ,@(comp-body-eff body op-name sp-delta)) 1264 ,@(comp--body-eff body op-name sp-delta))
1253 else 1265 else
1254 collect `(',op (signal 'native-ice 1266 collect `(',op (signal 'native-ice
1255 (list "unsupported LAP op" ',op-name)))) 1267 (list "unsupported LAP op" ',op-name))))
1256 (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) 1268 (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op))))))
1257 1269
1258(defun comp-limplify-lap-inst (insn) 1270(defun comp--limplify-lap-inst (insn)
1259 "Limplify LAP instruction INSN pushing it in the proper basic block." 1271 "Limplify LAP instruction INSN pushing it in the proper basic block."
1260 (let ((op (car insn)) 1272 (let ((op (car insn))
1261 (arg (if (consp (cdr insn)) 1273 (arg (if (consp (cdr insn))
1262 (cadr insn) 1274 (cadr insn)
1263 (cdr insn)))) 1275 (cdr insn))))
1264 (comp-op-case 1276 (comp--op-case
1265 (TAG 1277 (TAG
1266 (cl-destructuring-bind (_TAG label-num . label-sp) insn 1278 (cl-destructuring-bind (_TAG label-num . label-sp) insn
1267 ;; Paranoid? 1279 ;; Paranoid?
1268 (when label-sp 1280 (when label-sp
1269 (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))) 1281 (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass))))
1270 (comp-emit-annotation (format "LAP TAG %d" label-num)))) 1282 (comp--emit-annotation (format "LAP TAG %d" label-num))))
1271 (byte-stack-ref 1283 (byte-stack-ref
1272 (comp-copy-slot (- (comp-sp) arg 1))) 1284 (comp--copy-slot (- (comp--sp) arg 1)))
1273 (byte-varref 1285 (byte-varref
1274 (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar 1286 (comp--emit-set-call (comp--call 'symbol-value (make--comp-mvar
1275 :constant arg)))) 1287 :constant arg))))
1276 (byte-varset 1288 (byte-varset
1277 (comp-emit (comp-call 'set_internal 1289 (comp--emit (comp--call 'set_internal
1278 (make-comp-mvar :constant arg) 1290 (make--comp-mvar :constant arg)
1279 (comp-slot+1)))) 1291 (comp--slot+1))))
1280 (byte-varbind ;; Verify 1292 (byte-varbind ;; Verify
1281 (comp-emit (comp-call 'specbind 1293 (comp--emit (comp--call 'specbind
1282 (make-comp-mvar :constant arg) 1294 (make--comp-mvar :constant arg)
1283 (comp-slot+1)))) 1295 (comp--slot+1))))
1284 (byte-call 1296 (byte-call
1285 (cl-incf (comp-sp) (- arg)) 1297 (cl-incf (comp--sp) (- arg))
1286 (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) 1298 (comp--emit-set-call (comp--callref 'funcall (1+ arg) (comp--sp))))
1287 (byte-unbind 1299 (byte-unbind
1288 (comp-emit (comp-call 'helper_unbind_n 1300 (comp--emit (comp--call 'helper_unbind_n
1289 (make-comp-mvar :constant arg)))) 1301 (make--comp-mvar :constant arg))))
1290 (byte-pophandler 1302 (byte-pophandler
1291 (comp-emit '(pop-handler))) 1303 (comp--emit '(pop-handler)))
1292 (byte-pushconditioncase 1304 (byte-pushconditioncase
1293 (comp-emit-handler (cddr insn) 'condition-case)) 1305 (comp--emit-handler (cddr insn) 'condition-case))
1294 (byte-pushcatch 1306 (byte-pushcatch
1295 (comp-emit-handler (cddr insn) 'catcher)) 1307 (comp--emit-handler (cddr insn) 'catcher))
1296 (byte-nth auto) 1308 (byte-nth auto)
1297 (byte-symbolp auto) 1309 (byte-symbolp auto)
1298 (byte-consp auto) 1310 (byte-consp auto)
@@ -1301,19 +1313,19 @@ and the annotation emission."
1301 (byte-eq auto) 1313 (byte-eq auto)
1302 (byte-memq auto) 1314 (byte-memq auto)
1303 (byte-not 1315 (byte-not
1304 (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp)) 1316 (comp--emit-set-call (comp--call 'eq (comp--slot-n (comp--sp))
1305 (make-comp-mvar :constant nil)))) 1317 (make--comp-mvar :constant nil))))
1306 (byte-car auto) 1318 (byte-car auto)
1307 (byte-cdr auto) 1319 (byte-cdr auto)
1308 (byte-cons auto) 1320 (byte-cons auto)
1309 (byte-list1 1321 (byte-list1
1310 (comp-limplify-listn 1)) 1322 (comp--limplify-listn 1))
1311 (byte-list2 1323 (byte-list2
1312 (comp-limplify-listn 2)) 1324 (comp--limplify-listn 2))
1313 (byte-list3 1325 (byte-list3
1314 (comp-limplify-listn 3)) 1326 (comp--limplify-listn 3))
1315 (byte-list4 1327 (byte-list4
1316 (comp-limplify-listn 4)) 1328 (comp--limplify-listn 4))
1317 (byte-length auto) 1329 (byte-length auto)
1318 (byte-aref auto) 1330 (byte-aref auto)
1319 (byte-aset auto) 1331 (byte-aset auto)
@@ -1324,11 +1336,11 @@ and the annotation emission."
1324 (byte-get auto) 1336 (byte-get auto)
1325 (byte-substring auto) 1337 (byte-substring auto)
1326 (byte-concat2 1338 (byte-concat2
1327 (comp-emit-set-call (comp-callref 'concat 2 (comp-sp)))) 1339 (comp--emit-set-call (comp--callref 'concat 2 (comp--sp))))
1328 (byte-concat3 1340 (byte-concat3
1329 (comp-emit-set-call (comp-callref 'concat 3 (comp-sp)))) 1341 (comp--emit-set-call (comp--callref 'concat 3 (comp--sp))))
1330 (byte-concat4 1342 (byte-concat4
1331 (comp-emit-set-call (comp-callref 'concat 4 (comp-sp)))) 1343 (comp--emit-set-call (comp--callref 'concat 4 (comp--sp))))
1332 (byte-sub1 1-) 1344 (byte-sub1 1-)
1333 (byte-add1 1+) 1345 (byte-add1 1+)
1334 (byte-eqlsign =) 1346 (byte-eqlsign =)
@@ -1338,7 +1350,7 @@ and the annotation emission."
1338 (byte-geq >=) 1350 (byte-geq >=)
1339 (byte-diff -) 1351 (byte-diff -)
1340 (byte-negate 1352 (byte-negate
1341 (comp-emit-set-call (comp-call 'negate (comp-slot)))) 1353 (comp--emit-set-call (comp--call 'negate (comp--slot))))
1342 (byte-plus +) 1354 (byte-plus +)
1343 (byte-max auto) 1355 (byte-max auto)
1344 (byte-min auto) 1356 (byte-min auto)
@@ -1353,9 +1365,9 @@ and the annotation emission."
1353 (byte-preceding-char preceding-char) 1365 (byte-preceding-char preceding-char)
1354 (byte-current-column auto) 1366 (byte-current-column auto)
1355 (byte-indent-to 1367 (byte-indent-to
1356 (comp-emit-set-call (comp-call 'indent-to 1368 (comp--emit-set-call (comp--call 'indent-to
1357 (comp-slot) 1369 (comp--slot)
1358 (make-comp-mvar :constant nil)))) 1370 (make--comp-mvar :constant nil))))
1359 (byte-scan-buffer-OBSOLETE) 1371 (byte-scan-buffer-OBSOLETE)
1360 (byte-eolp auto) 1372 (byte-eolp auto)
1361 (byte-eobp auto) 1373 (byte-eobp auto)
@@ -1364,7 +1376,7 @@ and the annotation emission."
1364 (byte-current-buffer auto) 1376 (byte-current-buffer auto)
1365 (byte-set-buffer auto) 1377 (byte-set-buffer auto)
1366 (byte-save-current-buffer 1378 (byte-save-current-buffer
1367 (comp-emit (comp-call 'record_unwind_current_buffer))) 1379 (comp--emit (comp--call 'record_unwind_current_buffer)))
1368 (byte-set-mark-OBSOLETE) 1380 (byte-set-mark-OBSOLETE)
1369 (byte-interactive-p-OBSOLETE) 1381 (byte-interactive-p-OBSOLETE)
1370 (byte-forward-char auto) 1382 (byte-forward-char auto)
@@ -1376,41 +1388,41 @@ and the annotation emission."
1376 (byte-buffer-substring auto) 1388 (byte-buffer-substring auto)
1377 (byte-delete-region auto) 1389 (byte-delete-region auto)
1378 (byte-narrow-to-region 1390 (byte-narrow-to-region
1379 (comp-emit-set-call (comp-call 'narrow-to-region 1391 (comp--emit-set-call (comp--call 'narrow-to-region
1380 (comp-slot) 1392 (comp--slot)
1381 (comp-slot+1)))) 1393 (comp--slot+1))))
1382 (byte-widen 1394 (byte-widen
1383 (comp-emit-set-call (comp-call 'widen))) 1395 (comp--emit-set-call (comp--call 'widen)))
1384 (byte-end-of-line auto) 1396 (byte-end-of-line auto)
1385 (byte-constant2) ; TODO 1397 (byte-constant2) ; TODO
1386 ;; Branches. 1398 ;; Branches.
1387 (byte-goto 1399 (byte-goto
1388 (comp-emit-uncond-jump (cddr insn))) 1400 (comp--emit-uncond-jump (cddr insn)))
1389 (byte-goto-if-nil 1401 (byte-goto-if-nil
1390 (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 1402 (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0
1391 (cddr insn) nil)) 1403 (cddr insn) nil))
1392 (byte-goto-if-not-nil 1404 (byte-goto-if-not-nil
1393 (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 1405 (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0
1394 (cddr insn) t)) 1406 (cddr insn) t))
1395 (byte-goto-if-nil-else-pop 1407 (byte-goto-if-nil-else-pop
1396 (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 1408 (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1
1397 (cddr insn) nil)) 1409 (cddr insn) nil))
1398 (byte-goto-if-not-nil-else-pop 1410 (byte-goto-if-not-nil-else-pop
1399 (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 1411 (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1
1400 (cddr insn) t)) 1412 (cddr insn) t))
1401 (byte-return 1413 (byte-return
1402 (comp-emit `(return ,(comp-slot+1)))) 1414 (comp--emit `(return ,(comp--slot+1))))
1403 (byte-discard 'pass) 1415 (byte-discard 'pass)
1404 (byte-dup 1416 (byte-dup
1405 (comp-copy-slot (1- (comp-sp)))) 1417 (comp--copy-slot (1- (comp--sp))))
1406 (byte-save-excursion 1418 (byte-save-excursion
1407 (comp-emit (comp-call 'record_unwind_protect_excursion))) 1419 (comp--emit (comp--call 'record_unwind_protect_excursion)))
1408 (byte-save-window-excursion-OBSOLETE) 1420 (byte-save-window-excursion-OBSOLETE)
1409 (byte-save-restriction 1421 (byte-save-restriction
1410 (comp-emit (comp-call 'helper_save_restriction))) 1422 (comp--emit (comp--call 'helper_save_restriction)))
1411 (byte-catch) ;; Obsolete 1423 (byte-catch) ;; Obsolete
1412 (byte-unwind-protect 1424 (byte-unwind-protect
1413 (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) 1425 (comp--emit (comp--call 'helper_unwind_protect (comp--slot+1))))
1414 (byte-condition-case) ;; Obsolete 1426 (byte-condition-case) ;; Obsolete
1415 (byte-temp-output-buffer-setup-OBSOLETE) 1427 (byte-temp-output-buffer-setup-OBSOLETE)
1416 (byte-temp-output-buffer-show-OBSOLETE) 1428 (byte-temp-output-buffer-show-OBSOLETE)
@@ -1437,61 +1449,61 @@ and the annotation emission."
1437 (byte-numberp auto) 1449 (byte-numberp auto)
1438 (byte-integerp auto) 1450 (byte-integerp auto)
1439 (byte-listN 1451 (byte-listN
1440 (cl-incf (comp-sp) (- 1 arg)) 1452 (cl-incf (comp--sp) (- 1 arg))
1441 (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) 1453 (comp--emit-set-call (comp--callref 'list arg (comp--sp))))
1442 (byte-concatN 1454 (byte-concatN
1443 (cl-incf (comp-sp) (- 1 arg)) 1455 (cl-incf (comp--sp) (- 1 arg))
1444 (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) 1456 (comp--emit-set-call (comp--callref 'concat arg (comp--sp))))
1445 (byte-insertN 1457 (byte-insertN
1446 (cl-incf (comp-sp) (- 1 arg)) 1458 (cl-incf (comp--sp) (- 1 arg))
1447 (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) 1459 (comp--emit-set-call (comp--callref 'insert arg (comp--sp))))
1448 (byte-stack-set 1460 (byte-stack-set
1449 (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1))) 1461 (comp--copy-slot (1+ (comp--sp)) (- (comp--sp) arg -1)))
1450 (byte-stack-set2 (cl-assert nil)) ;; TODO 1462 (byte-stack-set2 (cl-assert nil)) ;; TODO
1451 (byte-discardN 1463 (byte-discardN
1452 (cl-incf (comp-sp) (- arg))) 1464 (cl-incf (comp--sp) (- arg)))
1453 (byte-switch 1465 (byte-switch
1454 ;; Assume to follow the emission of a setimm. 1466 ;; Assume to follow the emission of a setimm.
1455 ;; This is checked into comp-emit-switch. 1467 ;; This is checked into comp--emit-switch.
1456 (comp-emit-switch (comp-slot+1) 1468 (comp--emit-switch (comp--slot+1)
1457 (cl-first (comp-block-insns 1469 (cl-first (comp-block-insns
1458 (comp-limplify-curr-block comp-pass))))) 1470 (comp-limplify-curr-block comp-pass)))))
1459 (byte-constant 1471 (byte-constant
1460 (comp-emit-setimm arg)) 1472 (comp--emit-setimm arg))
1461 (byte-discardN-preserve-tos 1473 (byte-discardN-preserve-tos
1462 (cl-incf (comp-sp) (- arg)) 1474 (cl-incf (comp--sp) (- arg))
1463 (comp-copy-slot (+ arg (comp-sp))))))) 1475 (comp--copy-slot (+ arg (comp--sp)))))))
1464 1476
1465(defun comp-emit-narg-prologue (minarg nonrest rest) 1477(defun comp--emit-narg-prologue (minarg nonrest rest)
1466 "Emit the prologue for a narg function." 1478 "Emit the prologue for a narg function."
1467 (cl-loop for i below minarg 1479 (cl-loop for i below minarg
1468 do (comp-emit `(set-args-to-local ,(comp-slot-n i))) 1480 do (comp--emit `(set-args-to-local ,(comp--slot-n i)))
1469 (comp-emit '(inc-args))) 1481 (comp--emit '(inc-args)))
1470 (cl-loop for i from minarg below nonrest 1482 (cl-loop for i from minarg below nonrest
1471 for bb = (intern (format "entry_%s" i)) 1483 for bb = (intern (format "entry_%s" i))
1472 for fallback = (intern (format "entry_fallback_%s" i)) 1484 for fallback = (intern (format "entry_fallback_%s" i))
1473 do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb)) 1485 do (comp--emit `(cond-jump-narg-leq ,i ,fallback ,bb))
1474 (comp-make-curr-block bb (comp-sp)) 1486 (comp--make-curr-block bb (comp--sp))
1475 (comp-emit `(set-args-to-local ,(comp-slot-n i))) 1487 (comp--emit `(set-args-to-local ,(comp--slot-n i)))
1476 (comp-emit '(inc-args)) 1488 (comp--emit '(inc-args))
1477 finally (comp-emit '(jump entry_rest_args))) 1489 finally (comp--emit '(jump entry_rest_args)))
1478 (when (/= minarg nonrest) 1490 (when (/= minarg nonrest)
1479 (cl-loop for i from minarg below nonrest 1491 (cl-loop for i from minarg below nonrest
1480 for bb = (intern (format "entry_fallback_%s" i)) 1492 for bb = (intern (format "entry_fallback_%s" i))
1481 for next-bb = (if (= (1+ i) nonrest) 1493 for next-bb = (if (= (1+ i) nonrest)
1482 'entry_rest_args 1494 'entry_rest_args
1483 (intern (format "entry_fallback_%s" (1+ i)))) 1495 (intern (format "entry_fallback_%s" (1+ i))))
1484 do (comp-with-sp i 1496 do (comp--with-sp i
1485 (comp-make-curr-block bb (comp-sp)) 1497 (comp--make-curr-block bb (comp--sp))
1486 (comp-emit-setimm nil) 1498 (comp--emit-setimm nil)
1487 (comp-emit `(jump ,next-bb))))) 1499 (comp--emit `(jump ,next-bb)))))
1488 (comp-make-curr-block 'entry_rest_args (comp-sp)) 1500 (comp--make-curr-block 'entry_rest_args (comp--sp))
1489 (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) 1501 (comp--emit `(set-rest-args-to-local ,(comp--slot-n nonrest)))
1490 (setf (comp-sp) nonrest) 1502 (setf (comp--sp) nonrest)
1491 (when (and (> nonrest 8) (null rest)) 1503 (when (and (> nonrest 8) (null rest))
1492 (cl-decf (comp-sp)))) 1504 (cl-decf (comp--sp))))
1493 1505
1494(defun comp-limplify-finalize-function (func) 1506(defun comp--limplify-finalize-function (func)
1495 "Reverse insns into all basic blocks of FUNC." 1507 "Reverse insns into all basic blocks of FUNC."
1496 (cl-loop for bb being the hash-value in (comp-func-blocks func) 1508 (cl-loop for bb being the hash-value in (comp-func-blocks func)
1497 do (setf (comp-block-insns bb) 1509 do (setf (comp-block-insns bb)
@@ -1499,49 +1511,49 @@ and the annotation emission."
1499 (comp--log-func func 2) 1511 (comp--log-func func 2)
1500 func) 1512 func)
1501 1513
1502(cl-defgeneric comp-prepare-args-for-top-level (function) 1514(cl-defgeneric comp--prepare-args-for-top-level (function)
1503 "Given FUNCTION, return the two arguments for comp--register-...") 1515 "Given FUNCTION, return the two arguments for comp--register-...")
1504 1516
1505(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) 1517(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-l))
1506 "Lexically-scoped FUNCTION." 1518 "Lexically-scoped FUNCTION."
1507 (let ((args (comp-func-l-args function))) 1519 (let ((args (comp-func-l-args function)))
1508 (cons (make-comp-mvar :constant (comp-args-base-min args)) 1520 (cons (make--comp-mvar :constant (comp-args-base-min args))
1509 (make-comp-mvar :constant (cond 1521 (make--comp-mvar :constant (cond
1510 ((comp-args-p args) (comp-args-max args)) 1522 ((comp-args-p args) (comp-args-max args))
1511 ((comp-nargs-rest args) 'many) 1523 ((comp-nargs-rest args) 'many)
1512 (t (comp-nargs-nonrest args))))))) 1524 (t (comp-nargs-nonrest args)))))))
1513 1525
1514(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d)) 1526(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-d))
1515 "Dynamically scoped FUNCTION." 1527 "Dynamically scoped FUNCTION."
1516 (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function))) 1528 (cons (make--comp-mvar :constant (func-arity (comp-func-byte-func function)))
1517 (let ((comp-curr-allocation-class 'd-default)) 1529 (let ((comp-curr-allocation-class 'd-default))
1518 ;; Lambda-lists must stay in the same relocation class of 1530 ;; Lambda-lists must stay in the same relocation class of
1519 ;; the object referenced by code to respect uninterned 1531 ;; the object referenced by code to respect uninterned
1520 ;; symbols. 1532 ;; symbols.
1521 (make-comp-mvar :constant (comp-func-d-lambda-list function))))) 1533 (make--comp-mvar :constant (comp-func-d-lambda-list function)))))
1522 1534
1523(cl-defgeneric comp-emit-for-top-level (form for-late-load) 1535(cl-defgeneric comp--emit-for-top-level (form for-late-load)
1524 "Emit the Limple code for top level FORM.") 1536 "Emit the Limple code for top level FORM.")
1525 1537
1526(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def) 1538(cl-defmethod comp--emit-for-top-level ((form byte-to-native-func-def)
1527 for-late-load) 1539 for-late-load)
1528 (let* ((name (byte-to-native-func-def-name form)) 1540 (let* ((name (byte-to-native-func-def-name form))
1529 (c-name (byte-to-native-func-def-c-name form)) 1541 (c-name (byte-to-native-func-def-c-name form))
1530 (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) 1542 (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt)))
1531 (args (comp-prepare-args-for-top-level f))) 1543 (args (comp--prepare-args-for-top-level f)))
1532 (cl-assert (and name f)) 1544 (cl-assert (and name f))
1533 (comp-emit 1545 (comp--emit
1534 `(set ,(make-comp-mvar :slot 1) 1546 `(set ,(make--comp-mvar :slot 1)
1535 ,(comp-call (if for-late-load 1547 ,(comp--call (if for-late-load
1536 'comp--late-register-subr 1548 'comp--late-register-subr
1537 'comp--register-subr) 1549 'comp--register-subr)
1538 (make-comp-mvar :constant name) 1550 (make--comp-mvar :constant name)
1539 (make-comp-mvar :constant c-name) 1551 (make--comp-mvar :constant c-name)
1540 (car args) 1552 (car args)
1541 (cdr args) 1553 (cdr args)
1542 (setf (comp-func-type f) 1554 (setf (comp-func-type f)
1543 (make-comp-mvar :constant nil)) 1555 (make--comp-mvar :constant nil))
1544 (make-comp-mvar 1556 (make--comp-mvar
1545 :constant 1557 :constant
1546 (list 1558 (list
1547 (let* ((h (comp-ctxt-function-docs comp-ctxt)) 1559 (let* ((h (comp-ctxt-function-docs comp-ctxt))
@@ -1552,40 +1564,40 @@ and the annotation emission."
1552 (comp-func-command-modes f))) 1564 (comp-func-command-modes f)))
1553 ;; This is the compilation unit it-self passed as 1565 ;; This is the compilation unit it-self passed as
1554 ;; parameter. 1566 ;; parameter.
1555 (make-comp-mvar :slot 0)))))) 1567 (make--comp-mvar :slot 0))))))
1556 1568
1557(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) 1569(cl-defmethod comp--emit-for-top-level ((form byte-to-native-top-level)
1558 for-late-load) 1570 for-late-load)
1559 (unless for-late-load 1571 (unless for-late-load
1560 (comp-emit 1572 (comp--emit
1561 (comp-call 'eval 1573 (comp--call 'eval
1562 (let ((comp-curr-allocation-class 'd-impure)) 1574 (let ((comp-curr-allocation-class 'd-impure))
1563 (make-comp-mvar :constant 1575 (make--comp-mvar :constant
1564 (byte-to-native-top-level-form form))) 1576 (byte-to-native-top-level-form form)))
1565 (make-comp-mvar :constant 1577 (make--comp-mvar :constant
1566 (byte-to-native-top-level-lexical form)))))) 1578 (byte-to-native-top-level-lexical form))))))
1567 1579
1568(defun comp-emit-lambda-for-top-level (func) 1580(defun comp--emit-lambda-for-top-level (func)
1569 "Emit the creation of subrs for lambda FUNC. 1581 "Emit the creation of subrs for lambda FUNC.
1570These are stored in the reloc data array." 1582These are stored in the reloc data array."
1571 (let ((args (comp-prepare-args-for-top-level func))) 1583 (let ((args (comp--prepare-args-for-top-level func)))
1572 (let ((comp-curr-allocation-class 'd-impure)) 1584 (let ((comp-curr-allocation-class 'd-impure))
1573 (comp--add-const-to-relocs (comp-func-byte-func func))) 1585 (comp--add-const-to-relocs (comp-func-byte-func func)))
1574 (comp-emit 1586 (comp--emit
1575 (comp-call 'comp--register-lambda 1587 (comp--call 'comp--register-lambda
1576 ;; mvar to be fixed-up when containers are 1588 ;; mvar to be fixed-up when containers are
1577 ;; finalized. 1589 ;; finalized.
1578 (or (gethash (comp-func-byte-func func) 1590 (or (gethash (comp-func-byte-func func)
1579 (comp-ctxt-lambda-fixups-h comp-ctxt)) 1591 (comp-ctxt-lambda-fixups-h comp-ctxt))
1580 (puthash (comp-func-byte-func func) 1592 (puthash (comp-func-byte-func func)
1581 (make-comp-mvar :constant nil) 1593 (make--comp-mvar :constant nil)
1582 (comp-ctxt-lambda-fixups-h comp-ctxt))) 1594 (comp-ctxt-lambda-fixups-h comp-ctxt)))
1583 (make-comp-mvar :constant (comp-func-c-name func)) 1595 (make--comp-mvar :constant (comp-func-c-name func))
1584 (car args) 1596 (car args)
1585 (cdr args) 1597 (cdr args)
1586 (setf (comp-func-type func) 1598 (setf (comp-func-type func)
1587 (make-comp-mvar :constant nil)) 1599 (make--comp-mvar :constant nil))
1588 (make-comp-mvar 1600 (make--comp-mvar
1589 :constant 1601 :constant
1590 (list 1602 (list
1591 (let* ((h (comp-ctxt-function-docs comp-ctxt)) 1603 (let* ((h (comp-ctxt-function-docs comp-ctxt))
@@ -1596,9 +1608,9 @@ These are stored in the reloc data array."
1596 (comp-func-command-modes func))) 1608 (comp-func-command-modes func)))
1597 ;; This is the compilation unit it-self passed as 1609 ;; This is the compilation unit it-self passed as
1598 ;; parameter. 1610 ;; parameter.
1599 (make-comp-mvar :slot 0))))) 1611 (make--comp-mvar :slot 0)))))
1600 1612
1601(defun comp-limplify-top-level (for-late-load) 1613(defun comp--limplify-top-level (for-late-load)
1602 "Create a Limple function to modify the global environment at load. 1614 "Create a Limple function to modify the global environment at load.
1603When FOR-LATE-LOAD is non-nil, the emitted function modifies only 1615When FOR-LATE-LOAD is non-nil, the emitted function modifies only
1604function definition. 1616function definition.
@@ -1628,22 +1640,22 @@ into the C code forwarding the compilation unit."
1628 (comp-func func) 1640 (comp-func func)
1629 (comp-pass (make-comp-limplify 1641 (comp-pass (make-comp-limplify
1630 :curr-block (make--comp-block-lap -1 0 'top-level) 1642 :curr-block (make--comp-block-lap -1 0 'top-level)
1631 :frame (comp-new-frame 1 0)))) 1643 :frame (comp--new-frame 1 0))))
1632 (comp-make-curr-block 'entry (comp-sp)) 1644 (comp--make-curr-block 'entry (comp--sp))
1633 (comp-emit-annotation (if for-late-load 1645 (comp--emit-annotation (if for-late-load
1634 "Late top level" 1646 "Late top level"
1635 "Top level")) 1647 "Top level"))
1636 ;; Assign the compilation unit incoming as parameter to the slot frame 0. 1648 ;; Assign the compilation unit incoming as parameter to the slot frame 0.
1637 (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) 1649 (comp--emit `(set-par-to-local ,(comp--slot-n 0) 0))
1638 (maphash (lambda (_ func) 1650 (maphash (lambda (_ func)
1639 (comp-emit-lambda-for-top-level func)) 1651 (comp--emit-lambda-for-top-level func))
1640 (comp-ctxt-byte-func-to-func-h comp-ctxt)) 1652 (comp-ctxt-byte-func-to-func-h comp-ctxt))
1641 (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) 1653 (mapc (lambda (x) (comp--emit-for-top-level x for-late-load))
1642 (comp-ctxt-top-level-forms comp-ctxt)) 1654 (comp-ctxt-top-level-forms comp-ctxt))
1643 (comp-emit `(return ,(make-comp-mvar :slot 1))) 1655 (comp--emit `(return ,(make--comp-mvar :slot 1)))
1644 (comp-limplify-finalize-function func))) 1656 (comp--limplify-finalize-function func)))
1645 1657
1646(defun comp-addr-to-bb-name (addr) 1658(defun comp--addr-to-bb-name (addr)
1647 "Search for a block starting at ADDR into pending or limplified blocks." 1659 "Search for a block starting at ADDR into pending or limplified blocks."
1648 ;; FIXME Actually we could have another hash for this. 1660 ;; FIXME Actually we could have another hash for this.
1649 (cl-flet ((pred (bb) 1661 (cl-flet ((pred (bb)
@@ -1655,7 +1667,7 @@ into the C code forwarding the compilation unit."
1655 when (pred bb) 1667 when (pred bb)
1656 return (comp-block-name bb))))) 1668 return (comp-block-name bb)))))
1657 1669
1658(defun comp-limplify-block (bb) 1670(defun comp--limplify-block (bb)
1659 "Limplify basic-block BB and add it to the current function." 1671 "Limplify basic-block BB and add it to the current function."
1660 (setf (comp-limplify-curr-block comp-pass) bb 1672 (setf (comp-limplify-curr-block comp-pass) bb
1661 (comp-limplify-sp comp-pass) (comp-block-lap-sp bb) 1673 (comp-limplify-sp comp-pass) (comp-block-lap-sp bb)
@@ -1666,51 +1678,51 @@ into the C code forwarding the compilation unit."
1666 (comp-func-lap comp-func)) 1678 (comp-func-lap comp-func))
1667 for inst = (car inst-cell) 1679 for inst = (car inst-cell)
1668 for next-inst = (car-safe (cdr inst-cell)) 1680 for next-inst = (car-safe (cdr inst-cell))
1669 do (comp-limplify-lap-inst inst) 1681 do (comp--limplify-lap-inst inst)
1670 (cl-incf (comp-limplify-pc comp-pass)) 1682 (cl-incf (comp-limplify-pc comp-pass))
1671 when (comp-lap-fall-through-p inst) 1683 when (comp--lap-fall-through-p inst)
1672 do (pcase next-inst 1684 do (pcase next-inst
1673 (`(TAG ,_label . ,label-sp) 1685 (`(TAG ,_label . ,label-sp)
1674 (when label-sp 1686 (when label-sp
1675 (cl-assert (= (1- label-sp) (comp-sp)))) 1687 (cl-assert (= (1- label-sp) (comp--sp))))
1676 (let* ((stack-depth (if label-sp 1688 (let* ((stack-depth (if label-sp
1677 (1- label-sp) 1689 (1- label-sp)
1678 (comp-sp))) 1690 (comp--sp)))
1679 (next-bb (comp-block-name (comp-bb-maybe-add 1691 (next-bb (comp-block-name (comp--bb-maybe-add
1680 (comp-limplify-pc comp-pass) 1692 (comp-limplify-pc comp-pass)
1681 stack-depth)))) 1693 stack-depth))))
1682 (unless (comp-block-closed bb) 1694 (unless (comp-block-closed bb)
1683 (comp-emit `(jump ,next-bb)))) 1695 (comp--emit `(jump ,next-bb))))
1684 (cl-return))) 1696 (cl-return)))
1685 until (comp-lap-eob-p inst))) 1697 until (comp--lap-eob-p inst)))
1686 1698
1687(defun comp-limplify-function (func) 1699(defun comp--limplify-function (func)
1688 "Limplify a single function FUNC." 1700 "Limplify a single function FUNC."
1689 (let* ((frame-size (comp-func-frame-size func)) 1701 (let* ((frame-size (comp-func-frame-size func))
1690 (comp-func func) 1702 (comp-func func)
1691 (comp-pass (make-comp-limplify 1703 (comp-pass (make-comp-limplify
1692 :frame (comp-new-frame frame-size 0)))) 1704 :frame (comp--new-frame frame-size 0))))
1693 (comp-fill-label-h) 1705 (comp--fill-label-h)
1694 ;; Prologue 1706 ;; Prologue
1695 (comp-make-curr-block 'entry (comp-sp)) 1707 (comp--make-curr-block 'entry (comp--sp))
1696 (comp-emit-annotation (concat "Lisp function: " 1708 (comp--emit-annotation (concat "Lisp function: "
1697 (symbol-name (comp-func-name func)))) 1709 (symbol-name (comp-func-name func))))
1698 ;; Dynamic functions have parameters bound by the trampoline. 1710 ;; Dynamic functions have parameters bound by the trampoline.
1699 (when (comp-func-l-p func) 1711 (when (comp-func-l-p func)
1700 (let ((args (comp-func-l-args func))) 1712 (let ((args (comp-func-l-args func)))
1701 (if (comp-args-p args) 1713 (if (comp-args-p args)
1702 (cl-loop for i below (comp-args-max args) 1714 (cl-loop for i below (comp-args-max args)
1703 do (cl-incf (comp-sp)) 1715 do (cl-incf (comp--sp))
1704 (comp-emit `(set-par-to-local ,(comp-slot) ,i))) 1716 (comp--emit `(set-par-to-local ,(comp--slot) ,i)))
1705 (comp-emit-narg-prologue (comp-args-base-min args) 1717 (comp--emit-narg-prologue (comp-args-base-min args)
1706 (comp-nargs-nonrest args) 1718 (comp-nargs-nonrest args)
1707 (comp-nargs-rest args))))) 1719 (comp-nargs-rest args)))))
1708 (comp-emit '(jump bb_0)) 1720 (comp--emit '(jump bb_0))
1709 ;; Body 1721 ;; Body
1710 (comp-bb-maybe-add 0 (comp-sp)) 1722 (comp--bb-maybe-add 0 (comp--sp))
1711 (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) 1723 (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass))
1712 while next-bb 1724 while next-bb
1713 do (comp-limplify-block next-bb)) 1725 do (comp--limplify-block next-bb))
1714 ;; Sanity check against block duplication. 1726 ;; Sanity check against block duplication.
1715 (cl-loop with addr-h = (make-hash-table) 1727 (cl-loop with addr-h = (make-hash-table)
1716 for bb being the hash-value in (comp-func-blocks func) 1728 for bb being the hash-value in (comp-func-blocks func)
@@ -1719,15 +1731,15 @@ into the C code forwarding the compilation unit."
1719 when addr 1731 when addr
1720 do (cl-assert (null (gethash addr addr-h))) 1732 do (cl-assert (null (gethash addr addr-h)))
1721 (puthash addr t addr-h)) 1733 (puthash addr t addr-h))
1722 (comp-limplify-finalize-function func))) 1734 (comp--limplify-finalize-function func)))
1723 1735
1724(defun comp-limplify (_) 1736(defun comp--limplify (_)
1725 "Compute LIMPLE IR for forms in `comp-ctxt'." 1737 "Compute LIMPLE IR for forms in `comp-ctxt'."
1726 (maphash (lambda (_ f) (comp-limplify-function f)) 1738 (maphash (lambda (_ f) (comp--limplify-function f))
1727 (comp-ctxt-funcs-h comp-ctxt)) 1739 (comp-ctxt-funcs-h comp-ctxt))
1728 (comp-add-func-to-ctxt (comp-limplify-top-level nil)) 1740 (comp--add-func-to-ctxt (comp--limplify-top-level nil))
1729 (when (comp-ctxt-with-late-load comp-ctxt) 1741 (when (comp-ctxt-with-late-load comp-ctxt)
1730 (comp-add-func-to-ctxt (comp-limplify-top-level t)))) 1742 (comp--add-func-to-ctxt (comp--limplify-top-level t))))
1731 1743
1732 1744
1733;;; add-cstrs pass specific code. 1745;;; add-cstrs pass specific code.
@@ -1751,22 +1763,22 @@ into the C code forwarding the compilation unit."
1751;; type specifier. 1763;; type specifier.
1752 1764
1753 1765
1754(defsubst comp-mvar-used-p (mvar) 1766(defsubst comp--mvar-used-p (mvar)
1755 "Non-nil when MVAR is used as lhs in the current function." 1767 "Non-nil when MVAR is used as lhs in the current function."
1756 (declare (gv-setter (lambda (val) 1768 (declare (gv-setter (lambda (val)
1757 `(puthash ,mvar ,val comp-pass)))) 1769 `(puthash ,mvar ,val comp-pass))))
1758 (gethash mvar comp-pass)) 1770 (gethash mvar comp-pass))
1759 1771
1760(defun comp-collect-mvars (form) 1772(defun comp--collect-mvars (form)
1761 "Add rhs m-var present in FORM into `comp-pass'." 1773 "Add rhs m-var present in FORM into `comp-pass'."
1762 (cl-loop for x in form 1774 (cl-loop for x in form
1763 if (consp x) 1775 if (consp x)
1764 do (comp-collect-mvars x) 1776 do (comp--collect-mvars x)
1765 else 1777 else
1766 when (comp-mvar-p x) 1778 when (comp-mvar-p x)
1767 do (setf (comp-mvar-used-p x) t))) 1779 do (setf (comp--mvar-used-p x) t)))
1768 1780
1769(defun comp-collect-rhs () 1781(defun comp--collect-rhs ()
1770 "Collect all lhs mvars into `comp-pass'." 1782 "Collect all lhs mvars into `comp-pass'."
1771 (cl-loop 1783 (cl-loop
1772 for b being each hash-value of (comp-func-blocks comp-func) 1784 for b being each hash-value of (comp-func-blocks comp-func)
@@ -1774,11 +1786,11 @@ into the C code forwarding the compilation unit."
1774 for insn in (comp-block-insns b) 1786 for insn in (comp-block-insns b)
1775 for (op . args) = insn 1787 for (op . args) = insn
1776 if (comp--assign-op-p op) 1788 if (comp--assign-op-p op)
1777 do (comp-collect-mvars (cdr args)) 1789 do (comp--collect-mvars (cdr args))
1778 else 1790 else
1779 do (comp-collect-mvars args)))) 1791 do (comp--collect-mvars args))))
1780 1792
1781(defun comp-negate-arithm-cmp-fun (function) 1793(defun comp--negate-arithm-cmp-fun (function)
1782 "Negate FUNCTION. 1794 "Negate FUNCTION.
1783Return nil if we don't want to emit constraints for its negation." 1795Return nil if we don't want to emit constraints for its negation."
1784 (cl-ecase function 1796 (cl-ecase function
@@ -1788,7 +1800,7 @@ Return nil if we don't want to emit constraints for its negation."
1788 (>= '<) 1800 (>= '<)
1789 (<= '>))) 1801 (<= '>)))
1790 1802
1791(defun comp-reverse-arithm-fun (function) 1803(defun comp--reverse-arithm-fun (function)
1792 "Reverse FUNCTION." 1804 "Reverse FUNCTION."
1793 (cl-case function 1805 (cl-case function
1794 (= '=) 1806 (= '=)
@@ -1798,7 +1810,7 @@ Return nil if we don't want to emit constraints for its negation."
1798 (<= '>=) 1810 (<= '>=)
1799 (t function))) 1811 (t function)))
1800 1812
1801(defun comp-emit-assume (kind lhs rhs bb negated) 1813(defun comp--emit-assume (kind lhs rhs bb negated)
1802 "Emit an assume of kind KIND for mvar LHS being RHS. 1814 "Emit an assume of kind KIND for mvar LHS being RHS.
1803When NEGATED is non-nil, the assumption is negated. 1815When NEGATED is non-nil, the assumption is negated.
1804The assume is emitted at the beginning of the block BB." 1816The 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."
1808 ((or 'and 'and-nhc) 1820 ((or 'and 'and-nhc)
1809 (if (comp-mvar-p rhs) 1821 (if (comp-mvar-p rhs)
1810 (let ((tmp-mvar (if negated 1822 (let ((tmp-mvar (if negated
1811 (make-comp-mvar :slot (comp-mvar-slot rhs)) 1823 (make--comp-mvar :slot (comp-mvar-slot rhs))
1812 rhs))) 1824 rhs)))
1813 (push `(assume ,(make-comp-mvar :slot lhs-slot) 1825 (push `(assume ,(make--comp-mvar :slot lhs-slot)
1814 (,kind ,lhs ,tmp-mvar)) 1826 (,kind ,lhs ,tmp-mvar))
1815 (comp-block-insns bb)) 1827 (comp-block-insns bb))
1816 (if negated 1828 (if negated
1817 (push `(assume ,tmp-mvar (not ,rhs)) 1829 (push `(assume ,tmp-mvar (not ,rhs))
1818 (comp-block-insns bb)))) 1830 (comp-block-insns bb))))
1819 ;; If is only a constraint we can negate it directly. 1831 ;; If is only a constraint we can negate it directly.
1820 (push `(assume ,(make-comp-mvar :slot lhs-slot) 1832 (push `(assume ,(make--comp-mvar :slot lhs-slot)
1821 (,kind ,lhs ,(if negated 1833 (,kind ,lhs ,(if negated
1822 (comp-cstr-negation-make rhs) 1834 (comp-cstr-negation-make rhs)
1823 rhs))) 1835 rhs)))
1824 (comp-block-insns bb)))) 1836 (comp-block-insns bb))))
1825 ((pred comp--arithm-cmp-fun-p) 1837 ((pred comp--arithm-cmp-fun-p)
1826 (when-let ((kind (if negated 1838 (when-let ((kind (if negated
1827 (comp-negate-arithm-cmp-fun kind) 1839 (comp--negate-arithm-cmp-fun kind)
1828 kind))) 1840 kind)))
1829 (push `(assume ,(make-comp-mvar :slot lhs-slot) 1841 (push `(assume ,(make--comp-mvar :slot lhs-slot)
1830 (,kind ,lhs 1842 (,kind ,lhs
1831 ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) 1843 ,(if-let* ((vld (comp-cstr-imm-vld-p rhs))
1832 (val (comp-cstr-imm rhs)) 1844 (val (comp-cstr-imm rhs))
1833 (ok (and (integerp val) 1845 (ok (and (integerp val)
1834 (not (memq kind '(= !=)))))) 1846 (not (memq kind '(= !=))))))
1835 val 1847 val
1836 (make-comp-mvar :slot (comp-mvar-slot rhs))))) 1848 (make--comp-mvar :slot (comp-mvar-slot rhs)))))
1837 (comp-block-insns bb)))) 1849 (comp-block-insns bb))))
1838 (_ (cl-assert nil))) 1850 (_ (cl-assert nil)))
1839 (setf (comp-func-ssa-status comp-func) 'dirty))) 1851 (setf (comp-func-ssa-status comp-func) 'dirty)))
1840 1852
1841(defun comp-maybe-add-vmvar (op cmp-res insns-seq) 1853(defun comp--maybe-add-vmvar (op cmp-res insns-seq)
1842 "If CMP-RES is clobbering OP emit a new constrained mvar and return it. 1854 "If CMP-RES is clobbering OP emit a new constrained mvar and return it.
1843Return OP otherwise." 1855Return OP otherwise."
1844 (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) 1856 (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res)))
1845 (new-mvar (make-comp-mvar 1857 (new-mvar (make--comp-mvar
1846 :slot 1858 :slot
1847 (- (cl-incf (comp-func-vframe-size comp-func)))))) 1859 (- (cl-incf (comp-func-vframe-size comp-func))))))
1848 (progn 1860 (progn
@@ -1850,7 +1862,7 @@ Return OP otherwise."
1850 new-mvar) 1862 new-mvar)
1851 op)) 1863 op))
1852 1864
1853(defun comp-add-new-block-between (bb-symbol bb-a bb-b) 1865(defun comp--add-new-block-between (bb-symbol bb-a bb-b)
1854 "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." 1866 "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B."
1855 (cl-loop 1867 (cl-loop
1856 with new-bb = (make-comp-block-cstr :name bb-symbol 1868 with new-bb = (make-comp-block-cstr :name bb-symbol
@@ -1873,7 +1885,7 @@ Return OP otherwise."
1873 finally (cl-assert nil))) 1885 finally (cl-assert nil)))
1874 1886
1875;; Cheap substitute to a copy propagation pass... 1887;; Cheap substitute to a copy propagation pass...
1876(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) 1888(defun comp--cond-cstrs-target-mvar (mvar exit-insn bb)
1877 "Given MVAR, search in BB the original mvar MVAR got assigned from. 1889 "Given MVAR, search in BB the original mvar MVAR got assigned from.
1878Keep on searching till EXIT-INSN is encountered." 1890Keep on searching till EXIT-INSN is encountered."
1879 (cl-flet ((targetp (x) 1891 (cl-flet ((targetp (x)
@@ -1890,7 +1902,7 @@ Keep on searching till EXIT-INSN is encountered."
1890 (setf res rhs))) 1902 (setf res rhs)))
1891 finally (cl-assert nil)))) 1903 finally (cl-assert nil))))
1892 1904
1893(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym) 1905(defun comp--add-cond-cstrs-target-block (curr-bb target-bb-sym)
1894 "Return the appropriate basic block to add constraint assumptions into. 1906 "Return the appropriate basic block to add constraint assumptions into.
1895CURR-BB is the current basic block. 1907CURR-BB is the current basic block.
1896TARGET-BB-SYM is the symbol name of the target block." 1908TARGET-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."
1910 until (null (gethash new-name (comp-func-blocks comp-func))) 1922 until (null (gethash new-name (comp-func-blocks comp-func)))
1911 finally 1923 finally
1912 ;; Add it. 1924 ;; Add it.
1913 (cl-return (comp-add-new-block-between new-name curr-bb target-bb)))))) 1925 (cl-return (comp--add-new-block-between new-name curr-bb target-bb))))))
1914 1926
1915(defun comp-add-cond-cstrs-simple () 1927(defun comp--add-cond-cstrs-simple ()
1916 "`comp-add-cstrs' worker function for each selected function." 1928 "`comp--add-cstrs' worker function for each selected function."
1917 (cl-loop 1929 (cl-loop
1918 for b being each hash-value of (comp-func-blocks comp-func) 1930 for b being each hash-value of (comp-func-blocks comp-func)
1919 do 1931 do
@@ -1929,26 +1941,26 @@ TARGET-BB-SYM is the symbol name of the target block."
1929 for branch-target-cell on blocks 1941 for branch-target-cell on blocks
1930 for branch-target = (car branch-target-cell) 1942 for branch-target = (car branch-target-cell)
1931 for negated in '(nil t) 1943 for negated in '(nil t)
1932 when (comp-mvar-used-p tmp-mvar) 1944 when (comp--mvar-used-p tmp-mvar)
1933 do 1945 do
1934 (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) 1946 (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
1935 (setf (car branch-target-cell) (comp-block-name block-target)) 1947 (setf (car branch-target-cell) (comp-block-name block-target))
1936 (comp-emit-assume 'and tmp-mvar obj2 block-target negated)) 1948 (comp--emit-assume 'and tmp-mvar obj2 block-target negated))
1937 finally (cl-return-from in-the-basic-block))) 1949 finally (cl-return-from in-the-basic-block)))
1938 (`((cond-jump ,obj1 ,obj2 . ,blocks)) 1950 (`((cond-jump ,obj1 ,obj2 . ,blocks))
1939 (cl-loop 1951 (cl-loop
1940 for branch-target-cell on blocks 1952 for branch-target-cell on blocks
1941 for branch-target = (car branch-target-cell) 1953 for branch-target = (car branch-target-cell)
1942 for negated in '(nil t) 1954 for negated in '(nil t)
1943 when (comp-mvar-used-p obj1) 1955 when (comp--mvar-used-p obj1)
1944 do 1956 do
1945 (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) 1957 (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
1946 (setf (car branch-target-cell) (comp-block-name block-target)) 1958 (setf (car branch-target-cell) (comp-block-name block-target))
1947 (comp-emit-assume 'and obj1 obj2 block-target negated)) 1959 (comp--emit-assume 'and obj1 obj2 block-target negated))
1948 finally (cl-return-from in-the-basic-block))))))) 1960 finally (cl-return-from in-the-basic-block)))))))
1949 1961
1950(defun comp-add-cond-cstrs () 1962(defun comp--add-cond-cstrs ()
1951 "`comp-add-cstrs' worker function for each selected function." 1963 "`comp--add-cstrs' worker function for each selected function."
1952 (cl-loop 1964 (cl-loop
1953 for b being each hash-value of (comp-func-blocks comp-func) 1965 for b being each hash-value of (comp-func-blocks comp-func)
1954 do 1966 do
@@ -1967,13 +1979,13 @@ TARGET-BB-SYM is the symbol name of the target block."
1967 (set ,(and (pred comp-mvar-p) mvar-3) 1979 (set ,(and (pred comp-mvar-p) mvar-3)
1968 (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) 1980 (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
1969 (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) 1981 (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
1970 (comp-emit-assume 'and mvar-tested 1982 (comp--emit-assume 'and mvar-tested
1971 (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) 1983 (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
1972 (comp-add-cond-cstrs-target-block b bb2) 1984 (comp--add-cond-cstrs-target-block b bb2)
1973 nil) 1985 nil)
1974 (comp-emit-assume 'and mvar-tested 1986 (comp--emit-assume 'and mvar-tested
1975 (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) 1987 (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
1976 (comp-add-cond-cstrs-target-block b bb1) 1988 (comp--add-cond-cstrs-target-block b bb1)
1977 t)) 1989 t))
1978 (`((set ,(and (pred comp-mvar-p) cmp-res) 1990 (`((set ,(and (pred comp-mvar-p) cmp-res)
1979 (,(pred comp--call-op-p) 1991 (,(pred comp--call-op-p)
@@ -1984,8 +1996,8 @@ TARGET-BB-SYM is the symbol name of the target block."
1984 ;; (comment ,_comment-str) 1996 ;; (comment ,_comment-str)
1985 (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) 1997 (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
1986 (cl-loop 1998 (cl-loop
1987 with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) 1999 with target-mvar1 = (comp--cond-cstrs-target-mvar op1 (car insns-seq) b)
1988 with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) 2000 with target-mvar2 = (comp--cond-cstrs-target-mvar op2 (car insns-seq) b)
1989 for branch-target-cell on blocks 2001 for branch-target-cell on blocks
1990 for branch-target = (car branch-target-cell) 2002 for branch-target = (car branch-target-cell)
1991 for negated in '(t nil) 2003 for negated in '(t nil)
@@ -1994,19 +2006,19 @@ TARGET-BB-SYM is the symbol name of the target block."
1994 (eql 'and-nhc) 2006 (eql 'and-nhc)
1995 (eq 'and) 2007 (eq 'and)
1996 (t fun)) 2008 (t fun))
1997 when (or (comp-mvar-used-p target-mvar1) 2009 when (or (comp--mvar-used-p target-mvar1)
1998 (comp-mvar-used-p target-mvar2)) 2010 (comp--mvar-used-p target-mvar2))
1999 do 2011 do
2000 (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) 2012 (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
2001 (setf (car branch-target-cell) (comp-block-name block-target)) 2013 (setf (car branch-target-cell) (comp-block-name block-target))
2002 (when (comp-mvar-used-p target-mvar1) 2014 (when (comp--mvar-used-p target-mvar1)
2003 (comp-emit-assume kind target-mvar1 2015 (comp--emit-assume kind target-mvar1
2004 (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) 2016 (comp--maybe-add-vmvar op2 cmp-res prev-insns-seq)
2005 block-target negated)) 2017 block-target negated))
2006 (when (comp-mvar-used-p target-mvar2) 2018 (when (comp--mvar-used-p target-mvar2)
2007 (comp-emit-assume (comp-reverse-arithm-fun kind) 2019 (comp--emit-assume (comp--reverse-arithm-fun kind)
2008 target-mvar2 2020 target-mvar2
2009 (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) 2021 (comp--maybe-add-vmvar op1 cmp-res prev-insns-seq)
2010 block-target negated))) 2022 block-target negated)))
2011 finally (cl-return-from in-the-basic-block))) 2023 finally (cl-return-from in-the-basic-block)))
2012 (`((set ,(and (pred comp-mvar-p) cmp-res) 2024 (`((set ,(and (pred comp-mvar-p) cmp-res)
@@ -2016,16 +2028,16 @@ TARGET-BB-SYM is the symbol name of the target block."
2016 ;; (comment ,_comment-str) 2028 ;; (comment ,_comment-str)
2017 (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) 2029 (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
2018 (cl-loop 2030 (cl-loop
2019 with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) 2031 with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b)
2020 with cstr = (comp--pred-to-cstr fun) 2032 with cstr = (comp--pred-to-cstr fun)
2021 for branch-target-cell on blocks 2033 for branch-target-cell on blocks
2022 for branch-target = (car branch-target-cell) 2034 for branch-target = (car branch-target-cell)
2023 for negated in '(t nil) 2035 for negated in '(t nil)
2024 when (comp-mvar-used-p target-mvar) 2036 when (comp--mvar-used-p target-mvar)
2025 do 2037 do
2026 (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) 2038 (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
2027 (setf (car branch-target-cell) (comp-block-name block-target)) 2039 (setf (car branch-target-cell) (comp-block-name block-target))
2028 (comp-emit-assume 'and target-mvar cstr block-target negated)) 2040 (comp--emit-assume 'and target-mvar cstr block-target negated))
2029 finally (cl-return-from in-the-basic-block))) 2041 finally (cl-return-from in-the-basic-block)))
2030 ;; Match predicate on the negated branch (unless). 2042 ;; Match predicate on the negated branch (unless).
2031 (`((set ,(and (pred comp-mvar-p) cmp-res) 2043 (`((set ,(and (pred comp-mvar-p) cmp-res)
@@ -2035,20 +2047,20 @@ TARGET-BB-SYM is the symbol name of the target block."
2035 (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p))) 2047 (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p)))
2036 (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) 2048 (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks))
2037 (cl-loop 2049 (cl-loop
2038 with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) 2050 with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b)
2039 with cstr = (comp--pred-to-cstr fun) 2051 with cstr = (comp--pred-to-cstr fun)
2040 for branch-target-cell on blocks 2052 for branch-target-cell on blocks
2041 for branch-target = (car branch-target-cell) 2053 for branch-target = (car branch-target-cell)
2042 for negated in '(nil t) 2054 for negated in '(nil t)
2043 when (comp-mvar-used-p target-mvar) 2055 when (comp--mvar-used-p target-mvar)
2044 do 2056 do
2045 (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) 2057 (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
2046 (setf (car branch-target-cell) (comp-block-name block-target)) 2058 (setf (car branch-target-cell) (comp-block-name block-target))
2047 (comp-emit-assume 'and target-mvar cstr block-target negated)) 2059 (comp--emit-assume 'and target-mvar cstr block-target negated))
2048 finally (cl-return-from in-the-basic-block)))) 2060 finally (cl-return-from in-the-basic-block))))
2049 (setf prev-insns-seq insns-seq)))) 2061 (setf prev-insns-seq insns-seq))))
2050 2062
2051(defsubst comp-insert-insn (insn insn-cell) 2063(defsubst comp--insert-insn (insn insn-cell)
2052 "Insert INSN as second insn of INSN-CELL." 2064 "Insert INSN as second insn of INSN-CELL."
2053 (let ((next-cell (cdr insn-cell)) 2065 (let ((next-cell (cdr insn-cell))
2054 (new-cell `(,insn))) 2066 (new-cell `(,insn)))
@@ -2056,15 +2068,15 @@ TARGET-BB-SYM is the symbol name of the target block."
2056 (cdr new-cell) next-cell 2068 (cdr new-cell) next-cell
2057 (comp-func-ssa-status comp-func) 'dirty))) 2069 (comp-func-ssa-status comp-func) 'dirty)))
2058 2070
2059(defun comp-emit-call-cstr (mvar call-cell cstr) 2071(defun comp--emit-call-cstr (mvar call-cell cstr)
2060 "Emit a constraint CSTR for MVAR after CALL-CELL." 2072 "Emit a constraint CSTR for MVAR after CALL-CELL."
2061 (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) 2073 (let* ((new-mvar (make--comp-mvar :slot (comp-mvar-slot mvar)))
2062 ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and 2074 ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and
2063 ;; fwprop convergence!! 2075 ;; fwprop convergence!!
2064 (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr)))) 2076 (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))
2065 (comp-insert-insn insn call-cell))) 2077 (comp--insert-insn insn call-cell)))
2066 2078
2067(defun comp-lambda-list-gen (lambda-list) 2079(defun comp--lambda-list-gen (lambda-list)
2068 "Return a generator to iterate over LAMBDA-LIST." 2080 "Return a generator to iterate over LAMBDA-LIST."
2069 (lambda () 2081 (lambda ()
2070 (cl-case (car lambda-list) 2082 (cl-case (car lambda-list)
@@ -2080,12 +2092,12 @@ TARGET-BB-SYM is the symbol name of the target block."
2080 (car lambda-list) 2092 (car lambda-list)
2081 (setf lambda-list (cdr lambda-list))))))) 2093 (setf lambda-list (cdr lambda-list)))))))
2082 2094
2083(defun comp-add-call-cstr () 2095(defun comp--add-call-cstr ()
2084 "Add args assumptions for each function of which the type specifier is known." 2096 "Add args assumptions for each function of which the type specifier is known."
2085 (cl-loop 2097 (cl-loop
2086 for bb being each hash-value of (comp-func-blocks comp-func) 2098 for bb being each hash-value of (comp-func-blocks comp-func)
2087 do 2099 do
2088 (comp-loop-insn-in-block bb 2100 (comp--loop-insn-in-block bb
2089 (when-let ((match 2101 (when-let ((match
2090 (pcase insn 2102 (pcase insn
2091 (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) 2103 (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args))
@@ -2096,10 +2108,10 @@ TARGET-BB-SYM is the symbol name of the target block."
2096 (cl-values f cstr-f nil args)))))) 2108 (cl-values f cstr-f nil args))))))
2097 (cl-multiple-value-bind (f cstr-f lhs args) match 2109 (cl-multiple-value-bind (f cstr-f lhs args) match
2098 (cl-loop 2110 (cl-loop
2099 with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) 2111 with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f))
2100 for arg in args 2112 for arg in args
2101 for cstr = (funcall gen) 2113 for cstr = (funcall gen)
2102 for target = (comp-cond-cstrs-target-mvar arg insn bb) 2114 for target = (comp--cond-cstrs-target-mvar arg insn bb)
2103 unless (comp-cstr-p cstr) 2115 unless (comp-cstr-p cstr)
2104 do (signal 'native-ice 2116 do (signal 'native-ice
2105 (list "Incoherent type specifier for function" f)) 2117 (list "Incoherent type specifier for function" f))
@@ -2110,9 +2122,9 @@ TARGET-BB-SYM is the symbol name of the target block."
2110 (or (null lhs) 2122 (or (null lhs)
2111 (not (eql (comp-mvar-slot lhs) 2123 (not (eql (comp-mvar-slot lhs)
2112 (comp-mvar-slot target))))) 2124 (comp-mvar-slot target)))))
2113 do (comp-emit-call-cstr target insn-cell cstr))))))) 2125 do (comp--emit-call-cstr target insn-cell cstr)))))))
2114 2126
2115(defun comp-add-cstrs (_) 2127(defun comp--add-cstrs (_)
2116 "Rewrite conditional branches adding appropriate `assume' insns. 2128 "Rewrite conditional branches adding appropriate `assume' insns.
2117This is introducing and placing `assume' insns in use by fwprop 2129This is introducing and placing `assume' insns in use by fwprop
2118to propagate conditional branch test information on target basic 2130to propagate conditional branch test information on target basic
@@ -2126,10 +2138,10 @@ blocks."
2126 (not (comp-func-has-non-local f))) 2138 (not (comp-func-has-non-local f)))
2127 (let ((comp-func f) 2139 (let ((comp-func f)
2128 (comp-pass (make-hash-table :test #'eq))) 2140 (comp-pass (make-hash-table :test #'eq)))
2129 (comp-collect-rhs) 2141 (comp--collect-rhs)
2130 (comp-add-cond-cstrs-simple) 2142 (comp--add-cond-cstrs-simple)
2131 (comp-add-cond-cstrs) 2143 (comp--add-cond-cstrs)
2132 (comp-add-call-cstr) 2144 (comp--add-call-cstr)
2133 (comp--log-func comp-func 3)))) 2145 (comp--log-func comp-func 3))))
2134 (comp-ctxt-funcs-h comp-ctxt))) 2146 (comp-ctxt-funcs-h comp-ctxt)))
2135 2147
@@ -2141,7 +2153,7 @@ blocks."
2141;; avoid optimizing-out functions and preventing their redefinition 2153;; avoid optimizing-out functions and preventing their redefinition
2142;; being effective. 2154;; being effective.
2143 2155
2144(defun comp-collect-calls (f) 2156(defun comp--collect-calls (f)
2145 "Return a list with all the functions called by F." 2157 "Return a list with all the functions called by F."
2146 (cl-loop 2158 (cl-loop
2147 with h = (make-hash-table :test #'eq) 2159 with h = (make-hash-table :test #'eq)
@@ -2161,17 +2173,17 @@ blocks."
2161 (comp-ctxt-funcs-h comp-ctxt))) 2173 (comp-ctxt-funcs-h comp-ctxt)))
2162 f)))) 2174 f))))
2163 2175
2164(defun comp-pure-infer-func (f) 2176(defun comp--pure-infer-func (f)
2165 "If all functions called by F are pure then F is pure too." 2177 "If all functions called by F are pure then F is pure too."
2166 (when (and (cl-every (lambda (x) 2178 (when (and (cl-every (lambda (x)
2167 (or (comp--function-pure-p x) 2179 (or (comp--function-pure-p x)
2168 (eq x (comp-func-name f)))) 2180 (eq x (comp-func-name f))))
2169 (comp-collect-calls f)) 2181 (comp--collect-calls f))
2170 (not (eq (comp-func-pure f) t))) 2182 (not (eq (comp-func-pure f) t)))
2171 (comp-log (format "%s inferred to be pure" (comp-func-name f))) 2183 (comp-log (format "%s inferred to be pure" (comp-func-name f)))
2172 (setf (comp-func-pure f) t))) 2184 (setf (comp-func-pure f) t)))
2173 2185
2174(defun comp-ipa-pure (_) 2186(defun comp--ipa-pure (_)
2175 "Infer function purity." 2187 "Infer function purity."
2176 (cl-loop 2188 (cl-loop
2177 with pure-n = 0 2189 with pure-n = 0
@@ -2184,7 +2196,7 @@ blocks."
2184 when (and (>= (comp-func-speed f) 3) 2196 when (and (>= (comp-func-speed f) 3)
2185 (comp-func-l-p f) 2197 (comp-func-l-p f)
2186 (not (comp-func-pure f))) 2198 (not (comp-func-pure f)))
2187 do (comp-pure-infer-func f) 2199 do (comp--pure-infer-func f)
2188 count (comp-func-pure f)))) 2200 count (comp-func-pure f))))
2189 finally (comp-log (format "ipa-pure iterated %d times" n)))) 2201 finally (comp-log (format "ipa-pure iterated %d times" n))))
2190 2202
@@ -2198,13 +2210,13 @@ blocks."
2198;; this form is called 'minimal SSA form'. 2210;; this form is called 'minimal SSA form'.
2199;; This pass should be run every time basic blocks or m-var are shuffled. 2211;; This pass should be run every time basic blocks or m-var are shuffled.
2200 2212
2201(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type) 2213(cl-defun make--comp--ssa-mvar (&rest rest &key _slot _constant _type)
2202 "Same as `make-comp-mvar' but set the `id' slot." 2214 "Same as `make--comp-mvar' but set the `id' slot."
2203 (let ((mvar (apply #'make-comp-mvar rest))) 2215 (let ((mvar (apply #'make--comp-mvar rest)))
2204 (setf (comp-mvar-id mvar) (sxhash-eq mvar)) 2216 (setf (comp-mvar-id mvar) (sxhash-eq mvar))
2205 mvar)) 2217 mvar))
2206 2218
2207(defun comp-clean-ssa (f) 2219(defun comp--clean-ssa (f)
2208 "Clean-up SSA for function F." 2220 "Clean-up SSA for function F."
2209 (setf (comp-func-edges-h f) (make-hash-table)) 2221 (setf (comp-func-edges-h f) (make-hash-table))
2210 (cl-loop 2222 (cl-loop
@@ -2220,7 +2232,7 @@ blocks."
2220 unless (eq 'phi (car insn)) 2232 unless (eq 'phi (car insn))
2221 collect insn)))) 2233 collect insn))))
2222 2234
2223(defun comp-compute-edges () 2235(defun comp--compute-edges ()
2224 "Compute the basic block edges for the current function." 2236 "Compute the basic block edges for the current function."
2225 (cl-loop with blocks = (comp-func-blocks comp-func) 2237 (cl-loop with blocks = (comp-func-blocks comp-func)
2226 for bb being each hash-value of blocks 2238 for bb being each hash-value of blocks
@@ -2256,7 +2268,7 @@ blocks."
2256 (comp-block-in-edges (comp-edge-dst edge)))) 2268 (comp-block-in-edges (comp-edge-dst edge))))
2257 (comp--log-edges comp-func))) 2269 (comp--log-edges comp-func)))
2258 2270
2259(defun comp-collect-rev-post-order (basic-block) 2271(defun comp--collect-rev-post-order (basic-block)
2260 "Walk BASIC-BLOCK children and return their name in reversed post-order." 2272 "Walk BASIC-BLOCK children and return their name in reversed post-order."
2261 (let ((visited (make-hash-table)) 2273 (let ((visited (make-hash-table))
2262 (acc ())) 2274 (acc ()))
@@ -2271,7 +2283,7 @@ blocks."
2271 (collect-rec basic-block) 2283 (collect-rec basic-block)
2272 acc))) 2284 acc)))
2273 2285
2274(defun comp-compute-dominator-tree () 2286(defun comp--compute-dominator-tree ()
2275 "Compute immediate dominators for each basic block in current function." 2287 "Compute immediate dominators for each basic block in current function."
2276 ;; Originally based on: "A Simple, Fast Dominance Algorithm" 2288 ;; Originally based on: "A Simple, Fast Dominance Algorithm"
2277 ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). 2289 ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
@@ -2296,7 +2308,7 @@ blocks."
2296 ;; No point to go on if the only bb is 'entry'. 2308 ;; No point to go on if the only bb is 'entry'.
2297 (bb0 (gethash 'bb_0 blocks))) 2309 (bb0 (gethash 'bb_0 blocks)))
2298 (cl-loop 2310 (cl-loop
2299 with rev-bb-list = (comp-collect-rev-post-order entry) 2311 with rev-bb-list = (comp--collect-rev-post-order entry)
2300 with changed = t 2312 with changed = t
2301 while changed 2313 while changed
2302 initially (progn 2314 initially (progn
@@ -2323,7 +2335,7 @@ blocks."
2323 new-idom) 2335 new-idom)
2324 changed t)))))) 2336 changed t))))))
2325 2337
2326(defun comp-compute-dominator-frontiers () 2338(defun comp--compute-dominator-frontiers ()
2327 "Compute the dominator frontier for each basic block in `comp-func'." 2339 "Compute the dominator frontier for each basic block in `comp-func'."
2328 ;; Originally based on: "A Simple, Fast Dominance Algorithm" 2340 ;; Originally based on: "A Simple, Fast Dominance Algorithm"
2329 ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). 2341 ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
@@ -2338,7 +2350,7 @@ blocks."
2338 (puthash b-name b (comp-block-df runner)) 2350 (puthash b-name b (comp-block-df runner))
2339 (setf runner (comp-block-idom runner)))))) 2351 (setf runner (comp-block-idom runner))))))
2340 2352
2341(defun comp-log-block-info () 2353(defun comp--log-block-info ()
2342 "Log basic blocks info for the current function." 2354 "Log basic blocks info for the current function."
2343 (maphash (lambda (name bb) 2355 (maphash (lambda (name bb)
2344 (let ((dom (comp-block-idom bb)) 2356 (let ((dom (comp-block-idom bb))
@@ -2351,7 +2363,7 @@ blocks."
2351 3))) 2363 3)))
2352 (comp-func-blocks comp-func))) 2364 (comp-func-blocks comp-func)))
2353 2365
2354(defun comp-place-phis () 2366(defun comp--place-phis ()
2355 "Place phi insns into the current function." 2367 "Place phi insns into the current function."
2356 ;; Originally based on: Static Single Assignment Book 2368 ;; Originally based on: Static Single Assignment Book
2357 ;; Algorithm 3.1: Standard algorithm for inserting phi-functions 2369 ;; Algorithm 3.1: Standard algorithm for inserting phi-functions
@@ -2392,7 +2404,7 @@ blocks."
2392 (unless (cl-find y defs-v) 2404 (unless (cl-find y defs-v)
2393 (push y w)))))))) 2405 (push y w))))))))
2394 2406
2395(defun comp-dom-tree-walker (bb pre-lambda post-lambda) 2407(defun comp--dom-tree-walker (bb pre-lambda post-lambda)
2396 "Dominator tree walker function starting from basic block BB. 2408 "Dominator tree walker function starting from basic block BB.
2397PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." 2409PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
2398 (when pre-lambda 2410 (when pre-lambda
@@ -2402,18 +2414,18 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
2402 for child = (comp-edge-dst ed) 2414 for child = (comp-edge-dst ed)
2403 when (eq bb (comp-block-idom child)) 2415 when (eq bb (comp-block-idom child))
2404 ;; Current block is the immediate dominator then recur. 2416 ;; Current block is the immediate dominator then recur.
2405 do (comp-dom-tree-walker child pre-lambda post-lambda))) 2417 do (comp--dom-tree-walker child pre-lambda post-lambda)))
2406 (when post-lambda 2418 (when post-lambda
2407 (funcall post-lambda bb))) 2419 (funcall post-lambda bb)))
2408 2420
2409(cl-defstruct (comp-ssa (:copier nil)) 2421(cl-defstruct (comp--ssa (:copier nil))
2410 "Support structure used while SSA renaming." 2422 "Support structure used while SSA renaming."
2411 (frame (comp-new-frame (comp-func-frame-size comp-func) 2423 (frame (comp--new-frame (comp-func-frame-size comp-func)
2412 (comp-func-vframe-size comp-func) t) 2424 (comp-func-vframe-size comp-func) t)
2413 :type comp-vec 2425 :type comp-vec
2414 :documentation "`comp-vec' of m-vars.")) 2426 :documentation "`comp-vec' of m-vars."))
2415 2427
2416(defun comp-ssa-rename-insn (insn frame) 2428(defun comp--ssa-rename-insn (insn frame)
2417 (cl-loop 2429 (cl-loop
2418 for slot-n from (- (comp-func-vframe-size comp-func)) 2430 for slot-n from (- (comp-func-vframe-size comp-func))
2419 below (comp-func-frame-size comp-func) 2431 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."
2424 (eql slot-n (comp-mvar-slot x)))) 2436 (eql slot-n (comp-mvar-slot x))))
2425 (new-lvalue () 2437 (new-lvalue ()
2426 ;; If is an assignment make a new mvar and put it as l-value. 2438 ;; If is an assignment make a new mvar and put it as l-value.
2427 (let ((mvar (make-comp-ssa-mvar :slot slot-n))) 2439 (let ((mvar (make--comp--ssa-mvar :slot slot-n)))
2428 (setf (comp-vec-aref frame slot-n) mvar 2440 (setf (comp-vec-aref frame slot-n) mvar
2429 (cadr insn) mvar)))) 2441 (cadr insn) mvar))))
2430 (pcase insn 2442 (pcase insn
@@ -2434,7 +2446,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
2434 (new-lvalue)) 2446 (new-lvalue))
2435 (`(fetch-handler . ,_) 2447 (`(fetch-handler . ,_)
2436 ;; Clobber all no matter what! 2448 ;; Clobber all no matter what!
2437 (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) 2449 (setf (comp-vec-aref frame slot-n) (make--comp--ssa-mvar :slot slot-n)))
2438 (`(phi ,n) 2450 (`(phi ,n)
2439 (when (equal n slot-n) 2451 (when (equal n slot-n)
2440 (new-lvalue))) 2452 (new-lvalue)))
@@ -2442,7 +2454,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
2442 (let ((mvar (comp-vec-aref frame slot-n))) 2454 (let ((mvar (comp-vec-aref frame slot-n)))
2443 (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) 2455 (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))))))))
2444 2456
2445(defun comp-ssa-rename () 2457(defun comp--ssa-rename ()
2446 "Entry point to rename into SSA within the current function." 2458 "Entry point to rename into SSA within the current function."
2447 (comp-log "Renaming\n" 2) 2459 (comp-log "Renaming\n" 2)
2448 (let ((visited (make-hash-table))) 2460 (let ((visited (make-hash-table)))
@@ -2450,7 +2462,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
2450 (unless (gethash bb visited) 2462 (unless (gethash bb visited)
2451 (puthash bb t visited) 2463 (puthash bb t visited)
2452 (cl-loop for insn in (comp-block-insns bb) 2464 (cl-loop for insn in (comp-block-insns bb)
2453 do (comp-ssa-rename-insn insn in-frame)) 2465 do (comp--ssa-rename-insn insn in-frame))
2454 (setf (comp-block-final-frame bb) 2466 (setf (comp-block-final-frame bb)
2455 (copy-sequence in-frame)) 2467 (copy-sequence in-frame))
2456 (when-let ((out-edges (comp-block-out-edges bb))) 2468 (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."
2461 do (ssa-rename-rec child (comp-vec-copy in-frame))))))) 2473 do (ssa-rename-rec child (comp-vec-copy in-frame)))))))
2462 2474
2463 (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) 2475 (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func))
2464 (comp-new-frame (comp-func-frame-size comp-func) 2476 (comp--new-frame (comp-func-frame-size comp-func)
2465 (comp-func-vframe-size comp-func) 2477 (comp-func-vframe-size comp-func)
2466 t))))) 2478 t)))))
2467 2479
2468(defun comp-finalize-phis () 2480(defun comp--finalize-phis ()
2469 "Fixup r-values into phis in all basic blocks." 2481 "Fixup r-values into phis in all basic blocks."
2470 (cl-flet ((finalize-phi (args b) 2482 (cl-flet ((finalize-phi (args b)
2471 ;; Concatenate into args all incoming m-vars for this phi. 2483 ;; 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."
2482 when (eq op 'phi) 2494 when (eq op 'phi)
2483 do (finalize-phi args b))))) 2495 do (finalize-phi args b)))))
2484 2496
2485(defun comp-remove-unreachable-blocks () 2497(defun comp--remove-unreachable-blocks ()
2486 "Remove unreachable basic blocks. 2498 "Remove unreachable basic blocks.
2487Return t when one or more block was removed, nil otherwise." 2499Return t when one or more block was removed, nil otherwise."
2488 (cl-loop 2500 (cl-loop
@@ -2498,7 +2510,7 @@ Return t when one or more block was removed, nil otherwise."
2498 ret t) 2510 ret t)
2499 finally return ret)) 2511 finally return ret))
2500 2512
2501(defun comp-ssa () 2513(defun comp--ssa ()
2502 "Port all functions into minimal SSA form." 2514 "Port all functions into minimal SSA form."
2503 (maphash (lambda (_ f) 2515 (maphash (lambda (_ f)
2504 (let* ((comp-func f) 2516 (let* ((comp-func f)
@@ -2506,15 +2518,15 @@ Return t when one or more block was removed, nil otherwise."
2506 (unless (eq ssa-status t) 2518 (unless (eq ssa-status t)
2507 (cl-loop 2519 (cl-loop
2508 when (eq ssa-status 'dirty) 2520 when (eq ssa-status 'dirty)
2509 do (comp-clean-ssa f) 2521 do (comp--clean-ssa f)
2510 do (comp-compute-edges) 2522 do (comp--compute-edges)
2511 (comp-compute-dominator-tree) 2523 (comp--compute-dominator-tree)
2512 until (null (comp-remove-unreachable-blocks))) 2524 until (null (comp--remove-unreachable-blocks)))
2513 (comp-compute-dominator-frontiers) 2525 (comp--compute-dominator-frontiers)
2514 (comp-log-block-info) 2526 (comp--log-block-info)
2515 (comp-place-phis) 2527 (comp--place-phis)
2516 (comp-ssa-rename) 2528 (comp--ssa-rename)
2517 (comp-finalize-phis) 2529 (comp--finalize-phis)
2518 (comp--log-func comp-func 3) 2530 (comp--log-func comp-func 3)
2519 (setf (comp-func-ssa-status f) t)))) 2531 (setf (comp-func-ssa-status f) t))))
2520 (comp-ctxt-funcs-h comp-ctxt))) 2532 (comp-ctxt-funcs-h comp-ctxt)))
@@ -2526,12 +2538,12 @@ Return t when one or more block was removed, nil otherwise."
2526;; This is also responsible for removing function calls to pure functions if 2538;; This is also responsible for removing function calls to pure functions if
2527;; possible. 2539;; possible.
2528 2540
2529(defconst comp-fwprop-max-insns-scan 4500 2541(defconst comp--fwprop-max-insns-scan 4500
2530 ;; Chosen as ~ the greatest required value for full convergence 2542 ;; Chosen as ~ the greatest required value for full convergence
2531 ;; native compiling all Emacs code-base. 2543 ;; native compiling all Emacs code-base.
2532 "Max number of scanned insn before giving-up.") 2544 "Max number of scanned insn before giving-up.")
2533 2545
2534(defun comp-copy-insn (insn) 2546(defun comp--copy-insn (insn)
2535 "Deep copy INSN." 2547 "Deep copy INSN."
2536 ;; Adapted from `copy-tree'. 2548 ;; Adapted from `copy-tree'.
2537 (if (consp insn) 2549 (if (consp insn)
@@ -2539,16 +2551,16 @@ Return t when one or more block was removed, nil otherwise."
2539 (while (consp insn) 2551 (while (consp insn)
2540 (let ((newcar (car insn))) 2552 (let ((newcar (car insn)))
2541 (if (or (consp (car insn)) (comp-mvar-p (car insn))) 2553 (if (or (consp (car insn)) (comp-mvar-p (car insn)))
2542 (setf newcar (comp-copy-insn (car insn)))) 2554 (setf newcar (comp--copy-insn (car insn))))
2543 (push newcar result)) 2555 (push newcar result))
2544 (setf insn (cdr insn))) 2556 (setf insn (cdr insn)))
2545 (nconc (nreverse result) 2557 (nconc (nreverse result)
2546 (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) 2558 (if (comp-mvar-p insn) (comp--copy-insn insn) insn)))
2547 (if (comp-mvar-p insn) 2559 (if (comp-mvar-p insn)
2548 (copy-comp-mvar insn) 2560 (copy-comp-mvar insn)
2549 insn))) 2561 insn)))
2550 2562
2551(defmacro comp-apply-in-env (func &rest args) 2563(defmacro comp--apply-in-env (func &rest args)
2552 "Apply FUNC to ARGS in the current compilation environment." 2564 "Apply FUNC to ARGS in the current compilation environment."
2553 `(let ((env (cl-loop 2565 `(let ((env (cl-loop
2554 for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) 2566 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."
2564 for (func-name . def) in env 2576 for (func-name . def) in env
2565 do (setf (symbol-function func-name) def))))) 2577 do (setf (symbol-function func-name) def)))))
2566 2578
2567(defun comp-fwprop-prologue () 2579(defun comp--fwprop-prologue ()
2568 "Prologue for the propagate pass. 2580 "Prologue for the propagate pass.
2569Here goes everything that can be done not iteratively (read once). 2581Here goes everything that can be done not iteratively (read once).
2570Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or invoked? 2582Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or invoked?
@@ -2576,16 +2588,16 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or
2576 (`(setimm ,lval ,v) 2588 (`(setimm ,lval ,v)
2577 (setf (comp-cstr-imm lval) v)))))) 2589 (setf (comp-cstr-imm lval) v))))))
2578 2590
2579(defun comp-function-foldable-p (f args) 2591(defun comp--function-foldable-p (f args)
2580 "Given function F called with ARGS, return non-nil when optimizable." 2592 "Given function F called with ARGS, return non-nil when optimizable."
2581 (and (comp--function-pure-p f) 2593 (and (comp--function-pure-p f)
2582 (cl-every #'comp-cstr-imm-vld-p args))) 2594 (cl-every #'comp-cstr-imm-vld-p args)))
2583 2595
2584(defun comp-function-call-maybe-fold (insn f args) 2596(defun comp--function-call-maybe-fold (insn f args)
2585 "Given INSN, when F is pure if all ARGS are known, remove the function call. 2597 "Given INSN, when F is pure if all ARGS are known, remove the function call.
2586Return non-nil if the function is folded successfully." 2598Return non-nil if the function is folded successfully."
2587 (cl-flet ((rewrite-insn-as-setimm (insn value) 2599 (cl-flet ((rewrite-insn-as-setimm (insn value)
2588 ;; See `comp-emit-setimm'. 2600 ;; See `comp--emit-setimm'.
2589 (comp--add-const-to-relocs value) 2601 (comp--add-const-to-relocs value)
2590 (setf (car insn) 'setimm 2602 (setf (car insn) 'setimm
2591 (cddr insn) `(,value)))) 2603 (cddr insn) `(,value))))
@@ -2597,7 +2609,7 @@ Return non-nil if the function is folded successfully."
2597 comp-symbol-values-optimizable))) 2609 comp-symbol-values-optimizable)))
2598 (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm 2610 (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm
2599 (car args)))))) 2611 (car args))))))
2600 ((comp-function-foldable-p f args) 2612 ((comp--function-foldable-p f args)
2601 (ignore-errors 2613 (ignore-errors
2602 ;; No point to complain here in case of error because we 2614 ;; No point to complain here in case of error because we
2603 ;; should do basic block pruning in order to be sure that this 2615 ;; 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."
2608 ;; and know to be pure. 2620 ;; and know to be pure.
2609 (comp-func-byte-func f-in-ctxt) 2621 (comp-func-byte-func f-in-ctxt)
2610 f)) 2622 f))
2611 (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args)))) 2623 (value (comp--apply-in-env f (mapcar #'comp-cstr-imm args))))
2612 (rewrite-insn-as-setimm insn value))))))) 2624 (rewrite-insn-as-setimm insn value)))))))
2613 2625
2614(defun comp-fwprop-call (insn lval f args) 2626(defun comp--fwprop-call (insn lval f args)
2615 "Propagate on a call INSN into LVAL. 2627 "Propagate on a call INSN into LVAL.
2616F is the function being called with arguments ARGS. 2628F is the function being called with arguments ARGS.
2617Fold the call in case." 2629Fold the call in case."
2618 (unless (comp-function-call-maybe-fold insn f args) 2630 (unless (comp--function-call-maybe-fold insn f args)
2619 (when (and (eq 'funcall f) 2631 (when (and (eq 'funcall f)
2620 (comp-cstr-imm-vld-p (car args))) 2632 (comp-cstr-imm-vld-p (car args)))
2621 (setf f (comp-cstr-imm (car args)) 2633 (setf f (comp-cstr-imm (car args))
@@ -2636,16 +2648,16 @@ Fold the call in case."
2636 (comp-type-spec-to-cstr 2648 (comp-type-spec-to-cstr
2637 (comp-cstr-imm (car args))))))))) 2649 (comp-cstr-imm (car args)))))))))
2638 2650
2639(defun comp-fwprop-insn (insn) 2651(defun comp--fwprop-insn (insn)
2640 "Propagate within INSN." 2652 "Propagate within INSN."
2641 (pcase insn 2653 (pcase insn
2642 (`(set ,lval ,rval) 2654 (`(set ,lval ,rval)
2643 (pcase rval 2655 (pcase rval
2644 (`(,(or 'call 'callref) ,f . ,args) 2656 (`(,(or 'call 'callref) ,f . ,args)
2645 (comp-fwprop-call insn lval f args)) 2657 (comp--fwprop-call insn lval f args))
2646 (`(,(or 'direct-call 'direct-callref) ,f . ,args) 2658 (`(,(or 'direct-call 'direct-callref) ,f . ,args)
2647 (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) 2659 (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
2648 (comp-fwprop-call insn lval f args))) 2660 (comp--fwprop-call insn lval f args)))
2649 (_ 2661 (_
2650 (comp-cstr-shallow-copy lval rval)))) 2662 (comp-cstr-shallow-copy lval rval))))
2651 (`(assume ,lval ,(and (pred comp-mvar-p) rval)) 2663 (`(assume ,lval ,(and (pred comp-mvar-p) rval))
@@ -2690,7 +2702,7 @@ Fold the call in case."
2690 (rvals (mapcar #'car rest))) 2702 (rvals (mapcar #'car rest)))
2691 (apply prop-fn lval rvals))))) 2703 (apply prop-fn lval rvals)))))
2692 2704
2693(defun comp-fwprop* () 2705(defun comp--fwprop* ()
2694 "Propagate for set* and phi operands. 2706 "Propagate for set* and phi operands.
2695Return t if something was changed." 2707Return t if something was changed."
2696 (cl-loop named outer 2708 (cl-loop named outer
@@ -2702,17 +2714,17 @@ Return t if something was changed."
2702 for insn in (comp-block-insns b) 2714 for insn in (comp-block-insns b)
2703 for orig-insn = (unless modified 2715 for orig-insn = (unless modified
2704 ;; Save consing after 1st change. 2716 ;; Save consing after 1st change.
2705 (comp-copy-insn insn)) 2717 (comp--copy-insn insn))
2706 do 2718 do
2707 (comp-fwprop-insn insn) 2719 (comp--fwprop-insn insn)
2708 (cl-incf i) 2720 (cl-incf i)
2709 when (and (null modified) (not (equal insn orig-insn))) 2721 when (and (null modified) (not (equal insn orig-insn)))
2710 do (setf modified t)) 2722 do (setf modified t))
2711 when (> i comp-fwprop-max-insns-scan) 2723 when (> i comp--fwprop-max-insns-scan)
2712 do (cl-return-from outer nil) 2724 do (cl-return-from outer nil)
2713 finally return modified)) 2725 finally return modified))
2714 2726
2715(defun comp-rewrite-non-locals () 2727(defun comp--rewrite-non-locals ()
2716 "Make explicit in LIMPLE non-local exits if identified." 2728 "Make explicit in LIMPLE non-local exits if identified."
2717 (cl-loop 2729 (cl-loop
2718 for bb being each hash-value of (comp-func-blocks comp-func) 2730 for bb being each hash-value of (comp-func-blocks comp-func)
@@ -2729,26 +2741,26 @@ Return t if something was changed."
2729 (cdr insn-seq) '((unreachable)) 2741 (cdr insn-seq) '((unreachable))
2730 (comp-func-ssa-status comp-func) 'dirty)))) 2742 (comp-func-ssa-status comp-func) 'dirty))))
2731 2743
2732(defun comp-fwprop (_) 2744(defun comp--fwprop (_)
2733 "Forward propagate types and consts within the lattice." 2745 "Forward propagate types and consts within the lattice."
2734 (comp-ssa) 2746 (comp--ssa)
2735 (comp-dead-code) 2747 (comp--dead-code)
2736 (maphash (lambda (_ f) 2748 (maphash (lambda (_ f)
2737 (when (and (>= (comp-func-speed f) 2) 2749 (when (and (>= (comp-func-speed f) 2)
2738 ;; FIXME remove the following condition when tested. 2750 ;; FIXME remove the following condition when tested.
2739 (not (comp-func-has-non-local f))) 2751 (not (comp-func-has-non-local f)))
2740 (let ((comp-func f)) 2752 (let ((comp-func f))
2741 (comp-fwprop-prologue) 2753 (comp--fwprop-prologue)
2742 (cl-loop 2754 (cl-loop
2743 for i from 1 to 100 2755 for i from 1 to 100
2744 while (comp-fwprop*) 2756 while (comp--fwprop*)
2745 finally 2757 finally
2746 (when (= i 100) 2758 (when (= i 100)
2747 (display-warning 2759 (display-warning
2748 'comp 2760 'comp
2749 (format "fwprop pass jammed into %s?" (comp-func-name f)))) 2761 (format "fwprop pass jammed into %s?" (comp-func-name f))))
2750 (comp-log (format "Propagation run %d times\n" i) 2)) 2762 (comp-log (format "Propagation run %d times\n" i) 2))
2751 (comp-rewrite-non-locals) 2763 (comp--rewrite-non-locals)
2752 (comp--log-func comp-func 3)))) 2764 (comp--log-func comp-func 3))))
2753 (comp-ctxt-funcs-h comp-ctxt))) 2765 (comp-ctxt-funcs-h comp-ctxt)))
2754 2766
@@ -2768,7 +2780,7 @@ Return t if something was changed."
2768;; the full compilation unit. 2780;; the full compilation unit.
2769;; For this reason this is triggered only at native-comp-speed == 3. 2781;; For this reason this is triggered only at native-comp-speed == 3.
2770 2782
2771(defun comp-func-in-unit (func) 2783(defun comp--func-in-unit (func)
2772 "Given FUNC return the `comp-fun' definition in the current context. 2784 "Given FUNC return the `comp-fun' definition in the current context.
2773FUNCTION can be a function-name or byte compiled function." 2785FUNCTION can be a function-name or byte compiled function."
2774 (if (symbolp func) 2786 (if (symbolp func)
@@ -2776,11 +2788,11 @@ FUNCTION can be a function-name or byte compiled function."
2776 (cl-assert (byte-code-function-p func)) 2788 (cl-assert (byte-code-function-p func))
2777 (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) 2789 (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt))))
2778 2790
2779(defun comp-call-optim-form-call (callee args) 2791(defun comp--call-optim-form-call (callee args)
2780 (cl-flet ((fill-args (args total) 2792 (cl-flet ((fill-args (args total)
2781 ;; Fill missing args to reach TOTAL 2793 ;; Fill missing args to reach TOTAL
2782 (append args (cl-loop repeat (- total (length args)) 2794 (append args (cl-loop repeat (- total (length args))
2783 collect (make-comp-mvar :constant nil))))) 2795 collect (make--comp-mvar :constant nil)))))
2784 (when (and callee 2796 (when (and callee
2785 (or (symbolp callee) 2797 (or (symbolp callee)
2786 (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt))) 2798 (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."
2798 ;; actually cheaper since it avoids the call to the 2810 ;; actually cheaper since it avoids the call to the
2799 ;; intermediate native trampoline (bug#67005). 2811 ;; intermediate native trampoline (bug#67005).
2800 (subrp (subrp f)) 2812 (subrp (subrp f))
2801 (comp-func-callee (comp-func-in-unit callee))) 2813 (comp-func-callee (comp--func-in-unit callee)))
2802 (cond 2814 (cond
2803 ((and subrp (not (subr-native-elisp-p f))) 2815 ((and subrp (not (subr-native-elisp-p f)))
2804 ;; Trampoline removal. 2816 ;; Trampoline removal.
@@ -2833,30 +2845,30 @@ FUNCTION can be a function-name or byte compiled function."
2833 ((comp--type-hint-p callee) 2845 ((comp--type-hint-p callee)
2834 `(call ,callee ,@args))))))) 2846 `(call ,callee ,@args)))))))
2835 2847
2836(defun comp-call-optim-func () 2848(defun comp--call-optim-func ()
2837 "Perform the trampoline call optimization for the current function." 2849 "Perform the trampoline call optimization for the current function."
2838 (cl-loop 2850 (cl-loop
2839 for b being each hash-value of (comp-func-blocks comp-func) 2851 for b being each hash-value of (comp-func-blocks comp-func)
2840 do (comp-loop-insn-in-block b 2852 do (comp--loop-insn-in-block b
2841 (pcase insn 2853 (pcase insn
2842 (`(set ,lval (callref funcall ,f . ,rest)) 2854 (`(set ,lval (callref funcall ,f . ,rest))
2843 (when-let ((ok (comp-cstr-imm-vld-p f)) 2855 (when-let ((ok (comp-cstr-imm-vld-p f))
2844 (new-form (comp-call-optim-form-call 2856 (new-form (comp--call-optim-form-call
2845 (comp-cstr-imm f) rest))) 2857 (comp-cstr-imm f) rest)))
2846 (setf insn `(set ,lval ,new-form)))) 2858 (setf insn `(set ,lval ,new-form))))
2847 (`(callref funcall ,f . ,rest) 2859 (`(callref funcall ,f . ,rest)
2848 (when-let ((ok (comp-cstr-imm-vld-p f)) 2860 (when-let ((ok (comp-cstr-imm-vld-p f))
2849 (new-form (comp-call-optim-form-call 2861 (new-form (comp--call-optim-form-call
2850 (comp-cstr-imm f) rest))) 2862 (comp-cstr-imm f) rest)))
2851 (setf insn new-form))))))) 2863 (setf insn new-form)))))))
2852 2864
2853(defun comp-call-optim (_) 2865(defun comp--call-optim (_)
2854 "Try to optimize out funcall trampoline usage when possible." 2866 "Try to optimize out funcall trampoline usage when possible."
2855 (maphash (lambda (_ f) 2867 (maphash (lambda (_ f)
2856 (when (and (>= (comp-func-speed f) 2) 2868 (when (and (>= (comp-func-speed f) 2)
2857 (comp-func-l-p f)) 2869 (comp-func-l-p f))
2858 (let ((comp-func f)) 2870 (let ((comp-func f))
2859 (comp-call-optim-func)))) 2871 (comp--call-optim-func))))
2860 (comp-ctxt-funcs-h comp-ctxt))) 2872 (comp-ctxt-funcs-h comp-ctxt)))
2861 2873
2862 2874
@@ -2867,16 +2879,16 @@ FUNCTION can be a function-name or byte compiled function."
2867;; 2879;;
2868;; This pass can be run as last optim. 2880;; This pass can be run as last optim.
2869 2881
2870(defun comp-collect-mvar-ids (insn) 2882(defun comp--collect-mvar-ids (insn)
2871 "Collect the m-var unique identifiers into INSN." 2883 "Collect the m-var unique identifiers into INSN."
2872 (cl-loop for x in insn 2884 (cl-loop for x in insn
2873 if (consp x) 2885 if (consp x)
2874 append (comp-collect-mvar-ids x) 2886 append (comp--collect-mvar-ids x)
2875 else 2887 else
2876 when (comp-mvar-p x) 2888 when (comp-mvar-p x)
2877 collect (comp-mvar-id x))) 2889 collect (comp-mvar-id x)))
2878 2890
2879(defun comp-dead-assignments-func () 2891(defun comp--dead-assignments-func ()
2880 "Clean-up dead assignments into current function. 2892 "Clean-up dead assignments into current function.
2881Return the list of m-var ids nuked." 2893Return the list of m-var ids nuked."
2882 (let ((l-vals ()) 2894 (let ((l-vals ())
@@ -2889,9 +2901,9 @@ Return the list of m-var ids nuked."
2889 for (op arg0 . rest) = insn 2901 for (op arg0 . rest) = insn
2890 if (comp--assign-op-p op) 2902 if (comp--assign-op-p op)
2891 do (push (comp-mvar-id arg0) l-vals) 2903 do (push (comp-mvar-id arg0) l-vals)
2892 (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) 2904 (setf r-vals (nconc (comp--collect-mvar-ids rest) r-vals))
2893 else 2905 else
2894 do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) 2906 do (setf r-vals (nconc (comp--collect-mvar-ids insn) r-vals))))
2895 ;; Every l-value appearing that does not appear as r-value has no right to 2907 ;; Every l-value appearing that does not appear as r-value has no right to
2896 ;; exist and gets nuked. 2908 ;; exist and gets nuked.
2897 (let ((nuke-list (cl-set-difference l-vals r-vals))) 2909 (let ((nuke-list (cl-set-difference l-vals r-vals)))
@@ -2903,7 +2915,7 @@ Return the list of m-var ids nuked."
2903 3) 2915 3)
2904 (cl-loop 2916 (cl-loop
2905 for b being each hash-value of (comp-func-blocks comp-func) 2917 for b being each hash-value of (comp-func-blocks comp-func)
2906 do (comp-loop-insn-in-block b 2918 do (comp--loop-insn-in-block b
2907 (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn 2919 (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn
2908 (when (and (comp--assign-op-p op) 2920 (when (and (comp--assign-op-p op)
2909 (memq (comp-mvar-id arg0) nuke-list)) 2921 (memq (comp-mvar-id arg0) nuke-list))
@@ -2914,7 +2926,7 @@ Return the list of m-var ids nuked."
2914 insn)))))))) 2926 insn))))))))
2915 nuke-list))) 2927 nuke-list)))
2916 2928
2917(defun comp-dead-code () 2929(defun comp--dead-code ()
2918 "Dead code elimination." 2930 "Dead code elimination."
2919 (maphash (lambda (_ f) 2931 (maphash (lambda (_ f)
2920 (when (and (>= (comp-func-speed f) 2) 2932 (when (and (>= (comp-func-speed f) 2)
@@ -2923,7 +2935,7 @@ Return the list of m-var ids nuked."
2923 (cl-loop 2935 (cl-loop
2924 for comp-func = f 2936 for comp-func = f
2925 for i from 1 2937 for i from 1
2926 while (comp-dead-assignments-func) 2938 while (comp--dead-assignments-func)
2927 finally (comp-log (format "dead code rm run %d times\n" i) 2) 2939 finally (comp-log (format "dead code rm run %d times\n" i) 2)
2928 (comp--log-func comp-func 3)))) 2940 (comp--log-func comp-func 3))))
2929 (comp-ctxt-funcs-h comp-ctxt))) 2941 (comp-ctxt-funcs-h comp-ctxt)))
@@ -2931,14 +2943,14 @@ Return the list of m-var ids nuked."
2931 2943
2932;;; Tail Call Optimization pass specific code. 2944;;; Tail Call Optimization pass specific code.
2933 2945
2934(defun comp-form-tco-call-seq (args) 2946(defun comp--form-tco-call-seq (args)
2935 "Generate a TCO sequence for ARGS." 2947 "Generate a TCO sequence for ARGS."
2936 `(,@(cl-loop for arg in args 2948 `(,@(cl-loop for arg in args
2937 for i from 0 2949 for i from 0
2938 collect `(set ,(make-comp-mvar :slot i) ,arg)) 2950 collect `(set ,(make--comp-mvar :slot i) ,arg))
2939 (jump bb_0))) 2951 (jump bb_0)))
2940 2952
2941(defun comp-tco-func () 2953(defun comp--tco-func ()
2942 "Try to pattern match and perform TCO within the current function." 2954 "Try to pattern match and perform TCO within the current function."
2943 (cl-loop 2955 (cl-loop
2944 for b being each hash-value of (comp-func-blocks comp-func) 2956 for b being each hash-value of (comp-func-blocks comp-func)
@@ -2951,20 +2963,20 @@ Return the list of m-var ids nuked."
2951 (return ,ret-val)) 2963 (return ,ret-val))
2952 (when (and (string= func (comp-func-c-name comp-func)) 2964 (when (and (string= func (comp-func-c-name comp-func))
2953 (eq l-val ret-val)) 2965 (eq l-val ret-val))
2954 (let ((tco-seq (comp-form-tco-call-seq args))) 2966 (let ((tco-seq (comp--form-tco-call-seq args)))
2955 (setf (car insns-seq) (car tco-seq) 2967 (setf (car insns-seq) (car tco-seq)
2956 (cdr insns-seq) (cdr tco-seq) 2968 (cdr insns-seq) (cdr tco-seq)
2957 (comp-func-ssa-status comp-func) 'dirty) 2969 (comp-func-ssa-status comp-func) 'dirty)
2958 (cl-return-from in-the-basic-block)))))))) 2970 (cl-return-from in-the-basic-block))))))))
2959 2971
2960(defun comp-tco (_) 2972(defun comp--tco (_)
2961 "Simple peephole pass performing self TCO." 2973 "Simple peephole pass performing self TCO."
2962 (maphash (lambda (_ f) 2974 (maphash (lambda (_ f)
2963 (when (and (>= (comp-func-speed f) 3) 2975 (when (and (>= (comp-func-speed f) 3)
2964 (comp-func-l-p f) 2976 (comp-func-l-p f)
2965 (not (comp-func-has-non-local f))) 2977 (not (comp-func-has-non-local f)))
2966 (let ((comp-func f)) 2978 (let ((comp-func f))
2967 (comp-tco-func) 2979 (comp--tco-func)
2968 (comp--log-func comp-func 3)))) 2980 (comp--log-func comp-func 3))))
2969 (comp-ctxt-funcs-h comp-ctxt))) 2981 (comp-ctxt-funcs-h comp-ctxt)))
2970 2982
@@ -2974,29 +2986,62 @@ Return the list of m-var ids nuked."
2974;; This must run after all SSA prop not to have the type hint 2986;; This must run after all SSA prop not to have the type hint
2975;; information overwritten. 2987;; information overwritten.
2976 2988
2977(defun comp-remove-type-hints-func () 2989(defun comp--remove-type-hints-func ()
2978 "Remove type hints from the current function. 2990 "Remove type hints from the current function.
2979These are substituted with a normal `set' op." 2991These are substituted with a normal `set' op."
2980 (cl-loop 2992 (cl-loop
2981 for b being each hash-value of (comp-func-blocks comp-func) 2993 for b being each hash-value of (comp-func-blocks comp-func)
2982 do (comp-loop-insn-in-block b 2994 do (comp--loop-insn-in-block b
2983 (pcase insn 2995 (pcase insn
2984 (`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val)) 2996 (`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val))
2985 (setf insn `(set ,l-val ,r-val))))))) 2997 (setf insn `(set ,l-val ,r-val)))))))
2986 2998
2987(defun comp-remove-type-hints (_) 2999(defun comp--remove-type-hints (_)
2988 "Dead code elimination." 3000 "Dead code elimination."
2989 (maphash (lambda (_ f) 3001 (maphash (lambda (_ f)
2990 (when (>= (comp-func-speed f) 2) 3002 (when (>= (comp-func-speed f) 2)
2991 (let ((comp-func f)) 3003 (let ((comp-func f))
2992 (comp-remove-type-hints-func) 3004 (comp--remove-type-hints-func)
2993 (comp--log-func comp-func 3)))) 3005 (comp--log-func comp-func 3))))
2994 (comp-ctxt-funcs-h comp-ctxt))) 3006 (comp-ctxt-funcs-h comp-ctxt)))
2995 3007
2996 3008
3009;;; Function types pass specific code.
3010
3011(defun comp--compute-function-type (_ func)
3012 "Compute type specifier for `comp-func' FUNC.
3013Set it into the `type' slot."
3014 (when (and (comp-func-l-p func)
3015 (comp-mvar-p (comp-func-type func)))
3016 (let* ((comp-func (make-comp-func))
3017 (res-mvar (apply #'comp-cstr-union
3018 (make-comp-cstr)
3019 (cl-loop
3020 with res = nil
3021 for bb being the hash-value in (comp-func-blocks
3022 func)
3023 do (cl-loop
3024 for insn in (comp-block-insns bb)
3025 ;; Collect over every exit point the returned
3026 ;; mvars and union results.
3027 do (pcase insn
3028 (`(return ,mvar)
3029 (push mvar res))))
3030 finally return res)))
3031 (type `(function ,(comp--args-to-lambda-list (comp-func-l-args func))
3032 ,(comp-cstr-to-type-spec res-mvar))))
3033 (comp--add-const-to-relocs type)
3034 ;; Fix it up.
3035 (setf (comp-cstr-imm (comp-func-type func)) type))))
3036
3037(defun comp--compute-function-types (_)
3038 "Compute and store the type specifier for all functions."
3039 (maphash #'comp--compute-function-type (comp-ctxt-funcs-h comp-ctxt)))
3040
3041
2997;;; Final pass specific code. 3042;;; Final pass specific code.
2998 3043
2999(defun comp-args-to-lambda-list (args) 3044(defun comp--args-to-lambda-list (args)
3000 "Return a lambda list for ARGS." 3045 "Return a lambda list for ARGS."
3001 (cl-loop 3046 (cl-loop
3002 with res 3047 with res
@@ -3021,33 +3066,7 @@ These are substituted with a normal `set' op."
3021 (push 't res)))) 3066 (push 't res))))
3022 (cl-return (reverse res)))) 3067 (cl-return (reverse res))))
3023 3068
3024(defun comp-compute-function-type (_ func) 3069(defun comp--finalize-container (cont)
3025 "Compute type specifier for `comp-func' FUNC.
3026Set it into the `type' slot."
3027 (when (and (comp-func-l-p func)
3028 (comp-mvar-p (comp-func-type func)))
3029 (let* ((comp-func (make-comp-func))
3030 (res-mvar (apply #'comp-cstr-union
3031 (make-comp-cstr)
3032 (cl-loop
3033 with res = nil
3034 for bb being the hash-value in (comp-func-blocks
3035 func)
3036 do (cl-loop
3037 for insn in (comp-block-insns bb)
3038 ;; Collect over every exit point the returned
3039 ;; mvars and union results.
3040 do (pcase insn
3041 (`(return ,mvar)
3042 (push mvar res))))
3043 finally return res)))
3044 (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func))
3045 ,(comp-cstr-to-type-spec res-mvar))))
3046 (comp--add-const-to-relocs type)
3047 ;; Fix it up.
3048 (setf (comp-cstr-imm (comp-func-type func)) type))))
3049
3050(defun comp-finalize-container (cont)
3051 "Finalize data container CONT." 3070 "Finalize data container CONT."
3052 (setf (comp-data-container-l cont) 3071 (setf (comp-data-container-l cont)
3053 (cl-loop with h = (comp-data-container-idx cont) 3072 (cl-loop with h = (comp-data-container-idx cont)
@@ -3065,7 +3084,7 @@ Set it into the `type' slot."
3065 'lambda-fixup 3084 'lambda-fixup
3066 obj)))) 3085 obj))))
3067 3086
3068(defun comp-finalize-relocs () 3087(defun comp--finalize-relocs ()
3069 "Finalize data containers for each relocation class. 3088 "Finalize data containers for each relocation class.
3070Remove immediate duplicates within relocation classes. 3089Remove immediate duplicates within relocation classes.
3071Update all insn accordingly." 3090Update all insn accordingly."
@@ -3081,7 +3100,7 @@ Update all insn accordingly."
3081 (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) 3100 (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt))
3082 (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) 3101 (d-ephemeral-idx (comp-data-container-idx d-ephemeral)))
3083 ;; We never want compiled lambdas ending up in pure space. A copy must 3102 ;; We never want compiled lambdas ending up in pure space. A copy must
3084 ;; be already present in impure (see `comp-emit-lambda-for-top-level'). 3103 ;; be already present in impure (see `comp--emit-lambda-for-top-level').
3085 (cl-loop for obj being each hash-keys of d-default-idx 3104 (cl-loop for obj being each hash-keys of d-default-idx
3086 when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt)) 3105 when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt))
3087 do (cl-assert (gethash obj d-impure-idx)) 3106 do (cl-assert (gethash obj d-impure-idx))
@@ -3097,7 +3116,7 @@ Update all insn accordingly."
3097 do (remhash obj d-ephemeral-idx)) 3116 do (remhash obj d-ephemeral-idx))
3098 ;; Fix-up indexes in each relocation class and fill corresponding 3117 ;; Fix-up indexes in each relocation class and fill corresponding
3099 ;; reloc lists. 3118 ;; reloc lists.
3100 (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)) 3119 (mapc #'comp--finalize-container (list d-default d-impure d-ephemeral))
3101 ;; Make a vector from the function documentation hash table. 3120 ;; Make a vector from the function documentation hash table.
3102 (cl-loop with h = (comp-ctxt-function-docs comp-ctxt) 3121 (cl-loop with h = (comp-ctxt-function-docs comp-ctxt)
3103 with v = (make-vector (hash-table-count h) nil) 3122 with v = (make-vector (hash-table-count h) nil)
@@ -3121,11 +3140,11 @@ Update all insn accordingly."
3121 (comp-mvar-range mvar) (list (cons idx idx))) 3140 (comp-mvar-range mvar) (list (cons idx idx)))
3122 (puthash idx t reverse-h)))) 3141 (puthash idx t reverse-h))))
3123 3142
3124(defun comp-compile-ctxt-to-file (name) 3143(defun comp--compile-ctxt-to-file (name)
3125 "Compile as native code the current context naming it NAME. 3144 "Compile as native code the current context naming it NAME.
3126Prepare every function for final compilation and drive the C back-end." 3145Prepare every function for final compilation and drive the C back-end."
3127 (let ((dir (file-name-directory name))) 3146 (let ((dir (file-name-directory name)))
3128 (comp-finalize-relocs) 3147 (comp--finalize-relocs)
3129 (maphash (lambda (_ f) 3148 (maphash (lambda (_ f)
3130 (comp--log-func f 1)) 3149 (comp--log-func f 1))
3131 (comp-ctxt-funcs-h comp-ctxt)) 3150 (comp-ctxt-funcs-h comp-ctxt))
@@ -3133,12 +3152,12 @@ Prepare every function for final compilation and drive the C back-end."
3133 ;; In case it's created in the meanwhile. 3152 ;; In case it's created in the meanwhile.
3134 (ignore-error file-already-exists 3153 (ignore-error file-already-exists
3135 (make-directory dir t))) 3154 (make-directory dir t)))
3136 (comp--compile-ctxt-to-file name))) 3155 (comp--compile-ctxt-to-file0 name)))
3137 3156
3138(defun comp-final1 () 3157(defun comp--final1 ()
3139 (comp--init-ctxt) 3158 (comp--init-ctxt)
3140 (unwind-protect 3159 (unwind-protect
3141 (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)) 3160 (comp--compile-ctxt-to-file (comp-ctxt-output comp-ctxt))
3142 (comp--release-ctxt))) 3161 (comp--release-ctxt)))
3143 3162
3144(defvar comp-async-compilation nil 3163(defvar comp-async-compilation nil
@@ -3147,17 +3166,16 @@ Prepare every function for final compilation and drive the C back-end."
3147(defvar comp-running-batch-compilation nil 3166(defvar comp-running-batch-compilation nil
3148 "Non-nil when compilation is driven by any `batch-*-compile' function.") 3167 "Non-nil when compilation is driven by any `batch-*-compile' function.")
3149 3168
3150(defun comp-final (_) 3169(defun comp--final (_)
3151 "Final pass driving the C back-end for code emission." 3170 "Final pass driving the C back-end for code emission."
3152 (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt))
3153 (unless comp-dry-run 3171 (unless comp-dry-run
3154 ;; Always run the C side of the compilation as a sub-process 3172 ;; Always run the C side of the compilation as a sub-process
3155 ;; unless during bootstrap or async compilation (bug#45056). GCC 3173 ;; unless during bootstrap or async compilation (bug#45056). GCC
3156 ;; leaks memory but also interfere with the ability of Emacs to 3174 ;; leaks memory but also interfere with the ability of Emacs to
3157 ;; detect when a sub-process completes (TODO understand why). 3175 ;; detect when a sub-process completes (TODO understand why).
3158 (if (or comp-running-batch-compilation comp-async-compilation) 3176 (if (or comp-running-batch-compilation comp-async-compilation)
3159 (comp-final1) 3177 (comp--final1)
3160 ;; Call comp-final1 in a child process. 3178 ;; Call comp--final1 in a child process.
3161 (let* ((output (comp-ctxt-output comp-ctxt)) 3179 (let* ((output (comp-ctxt-output comp-ctxt))
3162 (print-escape-newlines t) 3180 (print-escape-newlines t)
3163 (print-length nil) 3181 (print-length nil)
@@ -3179,7 +3197,7 @@ Prepare every function for final compilation and drive the C back-end."
3179 load-path ',load-path) 3197 load-path ',load-path)
3180 ,native-comp-async-env-modifier-form 3198 ,native-comp-async-env-modifier-form
3181 (message "Compiling %s..." ',output) 3199 (message "Compiling %s..." ',output)
3182 (comp-final1))) 3200 (comp--final1)))
3183 (temp-file (make-temp-file 3201 (temp-file (make-temp-file
3184 (concat "emacs-int-comp-" 3202 (concat "emacs-int-comp-"
3185 (file-name-base output) "-") 3203 (file-name-base output) "-")
@@ -3223,7 +3241,7 @@ Prepare every function for final compilation and drive the C back-end."
3223 3241
3224;; Primitive function advice machinery 3242;; Primitive function advice machinery
3225 3243
3226(defun comp-make-lambda-list-from-subr (subr) 3244(defun comp--make-lambda-list-from-subr (subr)
3227 "Given SUBR return the equivalent lambda-list." 3245 "Given SUBR return the equivalent lambda-list."
3228 (pcase-let ((`(,min . ,max) (subr-arity subr)) 3246 (pcase-let ((`(,min . ,max) (subr-arity subr))
3229 (lambda-list '())) 3247 (lambda-list '()))
@@ -3267,7 +3285,7 @@ Prepare every function for final compilation and drive the C back-end."
3267;;;###autoload 3285;;;###autoload
3268(defun comp-trampoline-compile (subr-name) 3286(defun comp-trampoline-compile (subr-name)
3269 "Synthesize compile and return a trampoline for SUBR-NAME." 3287 "Synthesize compile and return a trampoline for SUBR-NAME."
3270 (let* ((lambda-list (comp-make-lambda-list-from-subr 3288 (let* ((lambda-list (comp--make-lambda-list-from-subr
3271 (symbol-function subr-name))) 3289 (symbol-function subr-name)))
3272 ;; The synthesized trampoline must expose the exact same ABI of 3290 ;; The synthesized trampoline must expose the exact same ABI of
3273 ;; the primitive we are replacing in the function reloc table. 3291 ;; the primitive we are replacing in the function reloc table.
@@ -3311,6 +3329,7 @@ filename (including FILE)."
3311 do (ignore-error file-error 3329 do (ignore-error file-error
3312 (comp-delete-or-replace-file f)))))) 3330 (comp-delete-or-replace-file f))))))
3313 3331
3332;; In use by comp.c.
3314(defun comp-delete-or-replace-file (oldfile &optional newfile) 3333(defun comp-delete-or-replace-file (oldfile &optional newfile)
3315 "Replace OLDFILE with NEWFILE. 3334 "Replace OLDFILE with NEWFILE.
3316When NEWFILE is nil just delete OLDFILE. 3335When NEWFILE is nil just delete OLDFILE.
@@ -3399,16 +3418,18 @@ the deferred compilation mechanism."
3399 (if (and comp-async-compilation 3418 (if (and comp-async-compilation
3400 (not (eq (car err) 'native-compiler-error))) 3419 (not (eq (car err) 'native-compiler-error)))
3401 (progn 3420 (progn
3402 (message (if err-val 3421 (message "%s: Error %s"
3403 "%s: Error: %s %s"
3404 "%s: Error %s")
3405 function-or-file 3422 function-or-file
3406 (get (car err) 'error-message) 3423 (error-message-string err))
3407 (car-safe err-val))
3408 (kill-emacs -1)) 3424 (kill-emacs -1))
3409 ;; Otherwise re-signal it adding the compilation input. 3425 ;; Otherwise re-signal it adding the compilation input.
3426 ;; FIXME: We can't just insert arbitrary info in the
3427 ;; error-data part of an error: the handler may expect
3428 ;; specific data at specific positions!
3410 (signal (car err) (if (consp err-val) 3429 (signal (car err) (if (consp err-val)
3411 (cons function-or-file err-val) 3430 (cons function-or-file err-val)
3431 ;; FIXME: `err-val' is supposed to be
3432 ;; a list, so it can only be nil here!
3412 (list function-or-file err-val))))))) 3433 (list function-or-file err-val)))))))
3413 (if (stringp function-or-file) 3434 (if (stringp function-or-file)
3414 data 3435 data
@@ -3492,7 +3513,8 @@ last directory in `native-comp-eln-load-path')."
3492 else 3513 else
3493 collect (byte-compile-file file)))) 3514 collect (byte-compile-file file))))
3494 3515
3495(defun comp-write-bytecode-file (eln-file) 3516;; In use by elisp-mode.el
3517(defun comp--write-bytecode-file (eln-file)
3496 "After native compilation write the bytecode file for ELN-FILE. 3518 "After native compilation write the bytecode file for ELN-FILE.
3497Make sure that eln file is younger than byte-compiled one and 3519Make sure that eln file is younger than byte-compiled one and
3498return the filename of this last. 3520return the filename of this last.
@@ -3529,7 +3551,7 @@ variable \"NATIVE_DISABLED\" is set, only byte compile."
3529 (car (last native-comp-eln-load-path))) 3551 (car (last native-comp-eln-load-path)))
3530 (byte-to-native-output-buffer-file nil) 3552 (byte-to-native-output-buffer-file nil)
3531 (eln-file (car (batch-native-compile)))) 3553 (eln-file (car (batch-native-compile))))
3532 (comp-write-bytecode-file eln-file) 3554 (comp--write-bytecode-file eln-file)
3533 (setq command-line-args-left (cdr command-line-args-left))))) 3555 (setq command-line-args-left (cdr command-line-args-left)))))
3534 3556
3535(defun native-compile-prune-cache () 3557(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 @@
1;;; compat.el --- Stub of the Compatibility Library -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2021-2024 Free Software Foundation, Inc.
4
5;; Author: \
6;; Philip Kaludercic <philipk@posteo.net>, \
7;; Daniel Mendler <mail@daniel-mendler.de>
8;; Maintainer: \
9;; Daniel Mendler <mail@daniel-mendler.de>, \
10;; Compat Development <~pkal/compat-devel@lists.sr.ht>,
11;; emacs-devel@gnu.org
12;; URL: https://github.com/emacs-compat/compat
13;; Keywords: lisp, maint
14
15;; This program is free software; you can redistribute it and/or modify
16;; it under the terms of the GNU General Public License as published by
17;; the Free Software Foundation, either version 3 of the License, or
18;; (at your option) any later version.
19
20;; This program is distributed in the hope that it will be useful,
21;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23;; GNU General Public License for more details.
24
25;; You should have received a copy of the GNU General Public License
26;; along with this program. If not, see <https://www.gnu.org/licenses/>.
27
28;;; Commentary:
29
30;; The Compat package on ELPA provides forward-compatibility
31;; definitions for other packages. While mostly transparent, a
32;; minimal API is necessary whenever core definitions change calling
33;; conventions (e.g. `plist-get' can be invoked with a predicate from
34;; Emacs 29.1 onward). For core packages on ELPA to be able to take
35;; advantage of this functionality, the macros `compat-function' and
36;; `compat-call' have to be available in the core, usable even if
37;; users do not have the Compat package installed, which this file
38;; ensures.
39
40;; A basic introduction to Compat is given in the Info node `(elisp)
41;; Forwards Compatibility'. Further details on Compat are documented
42;; in the Info node `(compat) Top' (installed along with the Compat
43;; package) or read the same manual online:
44;; https://elpa.gnu.org/packages/doc/compat.html.
45
46;;; Code:
47
48(defmacro compat-function (fun)
49 "Return compatibility function symbol for FUN.
50This is a pseudo-compatibility stub for core packages on ELPA,
51that depend on the Compat package, whenever the user doesn't have
52the package installed on their current system."
53 `#',fun)
54
55(defmacro compat-call (fun &rest args)
56 "Call compatibility function or macro FUN with ARGS.
57This is a pseudo-compatibility stub for core packages on ELPA,
58that depend on the Compat package, whenever the user doesn't have
59the package installed on their current system."
60 (cons fun args))
61
62;;;; Clever trick to avoid installing Compat if not necessary
63
64;; The versioning scheme of the Compat package follows that of Emacs,
65;; to indicate the version of Emacs, that functionality is being
66;; provided for. For example, the Compat version number 29.2.3.9
67;; would attempt to provide compatibility definitions up to Emacs
68;; 29.2, while also designating that this is the third major release
69;; and ninth minor release of Compat, for the specific Emacs release.
70
71;; The package version of this file is specified programmatically,
72;; instead of giving a fixed version in the header of this file. This
73;; is done to ensure that the version of compat.el provided by Emacs
74;; always corresponds to the current version of Emacs. In addition to
75;; the major-minor version, a large "major release" makes sure that
76;; the built-in version of Compat is always preferred over an external
77;; installation. This means that if a package specifies a dependency
78;; on Compat which matches the current or an older version of Emacs
79;; that is being used, no additional dependencies have to be
80;; downloaded.
81;;
82;; Further details and background on this file can be found in the
83;; bug#66554 discussion.
84
85;;;###autoload (push (list 'compat
86;;;###autoload emacs-major-version
87;;;###autoload emacs-minor-version
88;;;###autoload 9999)
89;;;###autoload package--builtin-versions)
90
91(provide 'compat)
92;;; 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."
365 docstring)) 365 docstring))
366 366
367 367
368;;; OBSOLETE
369;; The functions below are only provided for backward compatibility with
370;; code byte-compiled with versions of derived.el prior to Emacs-21.
371
372(defsubst derived-mode-setup-function-name (mode)
373 "Construct a setup-function name based on a MODE name."
374 (declare (obsolete nil "28.1"))
375 (intern (concat (symbol-name mode) "-setup")))
376
377
378;; Utility functions for defining a derived mode.
379
380;;;###autoload
381(defun derived-mode-init-mode-variables (mode)
382 "Initialize variables for a new MODE.
383Right now, if they don't already exist, set up a blank keymap, an
384empty syntax table, and an empty abbrev table -- these will be merged
385the first time the mode is used."
386
387 (if (boundp (derived-mode-map-name mode))
388 t
389 (eval `(defvar ,(derived-mode-map-name mode)
390 (make-sparse-keymap)
391 ,(format "Keymap for %s." mode)))
392 (put (derived-mode-map-name mode) 'derived-mode-unmerged t))
393
394 (if (boundp (derived-mode-syntax-table-name mode))
395 t
396 (eval `(defvar ,(derived-mode-syntax-table-name mode)
397 ;; Make a syntax table which doesn't specify anything
398 ;; for any char. Valid data will be merged in by
399 ;; derived-mode-merge-syntax-tables.
400 (make-char-table 'syntax-table nil)
401 ,(format "Syntax table for %s." mode)))
402 (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t))
403
404 (if (boundp (derived-mode-abbrev-table-name mode))
405 t
406 (eval `(defvar ,(derived-mode-abbrev-table-name mode)
407 (progn
408 (define-abbrev-table (derived-mode-abbrev-table-name ',mode) nil)
409 (make-abbrev-table))
410 ,(format "Abbrev table for %s." mode)))))
411
412;; Utility functions for running a derived mode.
413
414(defun derived-mode-set-keymap (mode)
415 "Set the keymap of the new MODE, maybe merging with the parent."
416 (let* ((map-name (derived-mode-map-name mode))
417 (new-map (eval map-name))
418 (old-map (current-local-map)))
419 (and old-map
420 (get map-name 'derived-mode-unmerged)
421 (derived-mode-merge-keymaps old-map new-map))
422 (put map-name 'derived-mode-unmerged nil)
423 (use-local-map new-map)))
424
425(defun derived-mode-set-syntax-table (mode)
426 "Set the syntax table of the new MODE, maybe merging with the parent."
427 (let* ((table-name (derived-mode-syntax-table-name mode))
428 (old-table (syntax-table))
429 (new-table (eval table-name)))
430 (if (get table-name 'derived-mode-unmerged)
431 (derived-mode-merge-syntax-tables old-table new-table))
432 (put table-name 'derived-mode-unmerged nil)
433 (set-syntax-table new-table)))
434
435(defun derived-mode-set-abbrev-table (mode)
436 "Set the abbrev table for MODE if it exists.
437Always merge its parent into it, since the merge is non-destructive."
438 (let* ((table-name (derived-mode-abbrev-table-name mode))
439 (old-table local-abbrev-table)
440 (new-table (eval table-name)))
441 (derived-mode-merge-abbrev-tables old-table new-table)
442 (setq local-abbrev-table new-table)))
443
444(defun derived-mode-run-hooks (mode)
445 "Run the mode hook for MODE."
446 (let ((hooks-name (derived-mode-hook-name mode)))
447 (if (boundp hooks-name)
448 (run-hooks hooks-name))))
449
450;; Functions to merge maps and tables.
451
452(defun derived-mode-merge-keymaps (old new)
453 "Merge an OLD keymap into a NEW one.
454The old keymap is set to be the last cdr of the new one, so that there will
455be automatic inheritance."
456 ;; ?? Can this just use `set-keymap-parent'?
457 (let ((tail new))
458 ;; Scan the NEW map for prefix keys.
459 (while (consp tail)
460 (and (consp (car tail))
461 (let* ((key (vector (car (car tail))))
462 (subnew (lookup-key new key))
463 (subold (lookup-key old key)))
464 ;; If KEY is a prefix key in both OLD and NEW, merge them.
465 (and (keymapp subnew) (keymapp subold)
466 (derived-mode-merge-keymaps subold subnew))))
467 (and (vectorp (car tail))
468 ;; Search a vector of ASCII char bindings for prefix keys.
469 (let ((i (1- (length (car tail)))))
470 (while (>= i 0)
471 (let* ((key (vector i))
472 (subnew (lookup-key new key))
473 (subold (lookup-key old key)))
474 ;; If KEY is a prefix key in both OLD and NEW, merge them.
475 (and (keymapp subnew) (keymapp subold)
476 (derived-mode-merge-keymaps subold subnew)))
477 (setq i (1- i)))))
478 (setq tail (cdr tail))))
479 (setcdr (nthcdr (1- (length new)) new) old))
480
481(defun derived-mode-merge-syntax-tables (old new)
482 "Merge an OLD syntax table into a NEW one.
483Where the new table already has an entry, nothing is copied from the old one."
484 (set-char-table-parent new old))
485
486;; Merge an old abbrev table into a new one.
487;; This function requires internal knowledge of how abbrev tables work,
488;; presuming that they are obarrays with the abbrev as the symbol, the expansion
489;; as the value of the symbol, and the hook as the function definition.
490(defun derived-mode-merge-abbrev-tables (old new)
491 (if old
492 (mapatoms
493 (lambda (symbol)
494 (or (intern-soft (symbol-name symbol) new)
495 (define-abbrev new (symbol-name symbol)
496 (symbol-value symbol) (symbol-function symbol))))
497 old)))
498
499(provide 'derived) 368(provide 'derived)
500 369
501;;; derived.el ends here 370;;; 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."
191 (if (consp obj) 191 (if (consp obj)
192 (setq bytes (car (cdr obj)) ;the byte code 192 (setq bytes (car (cdr obj)) ;the byte code
193 constvec (car (cdr (cdr obj)))) ;constant vector 193 constvec (car (cdr (cdr obj)))) ;constant vector
194 ;; If it is lazy-loaded, load it now
195 (fetch-bytecode obj)
196 (setq bytes (aref obj 1) 194 (setq bytes (aref obj 1)
197 constvec (aref obj 2))) 195 constvec (aref obj 2)))
198 (cl-assert (not (multibyte-string-p bytes))) 196 (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.")
132 (string-replace "'" "\\='" (format "%S" getter))))) 132 (string-replace "'" "\\='" (format "%S" getter)))))
133 (let ((start (point))) 133 (let ((start (point)))
134 (insert argdoc) 134 (insert argdoc)
135 (when (fboundp 'fill-region) 135 (when (fboundp 'fill-region) ;Don't break bootstrap!
136 (fill-region start (point) 'left t)))) 136 (fill-region start (point) 'left t))))
137 ;; Finally, insert the keymap. 137 ;; Finally, insert the keymap.
138 (when (and (boundp keymap-sym) 138 (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."
481 (edebug--eval-defun #'eval-defun edebug-it))) 481 (edebug--eval-defun #'eval-defun edebug-it)))
482 482
483;;;###autoload 483;;;###autoload
484(defalias 'edebug-defun 'edebug-eval-top-level-form) 484(defalias 'edebug-defun #'edebug-eval-top-level-form)
485 485
486;;;###autoload 486;;;###autoload
487(defun edebug-eval-top-level-form () 487(defun edebug-eval-top-level-form ()
@@ -1729,7 +1729,7 @@ contains a circular object."
1729(defun edebug-match-form (cursor) 1729(defun edebug-match-form (cursor)
1730 (list (edebug-form cursor))) 1730 (list (edebug-form cursor)))
1731 1731
1732(defalias 'edebug-match-place 'edebug-match-form) 1732(defalias 'edebug-match-place #'edebug-match-form)
1733 ;; Currently identical to edebug-match-form. 1733 ;; Currently identical to edebug-match-form.
1734 ;; This is for common lisp setf-style place arguments. 1734 ;; This is for common lisp setf-style place arguments.
1735 1735
@@ -2277,12 +2277,7 @@ only be active while Edebug is. It checks `debug-on-error' to see
2277whether it should call the debugger. When execution is resumed, the 2277whether it should call the debugger. When execution is resumed, the
2278error is signaled again." 2278error is signaled again."
2279 (if (and (listp debug-on-error) (memq signal-name debug-on-error)) 2279 (if (and (listp debug-on-error) (memq signal-name debug-on-error))
2280 (edebug 'error (cons signal-name signal-data))) 2280 (edebug 'error (cons signal-name signal-data))))
2281 ;; If we reach here without another non-local exit, then send signal again.
2282 ;; i.e. the signal is not continuable, yet.
2283 ;; Avoid infinite recursion.
2284 (let ((signal-hook-function nil))
2285 (signal signal-name signal-data)))
2286 2281
2287;;; Entering Edebug 2282;;; Entering Edebug
2288 2283
@@ -2326,6 +2321,12 @@ and run its entry function, and set up `edebug-before' and
2326 (debug-on-error (or debug-on-error edebug-on-error)) 2321 (debug-on-error (or debug-on-error edebug-on-error))
2327 (debug-on-quit edebug-on-quit)) 2322 (debug-on-quit edebug-on-quit))
2328 (unwind-protect 2323 (unwind-protect
2324 ;; FIXME: We could replace this `signal-hook-function' with
2325 ;; a cleaner `handler-bind' but then we wouldn't be able to
2326 ;; install it here (i.e. once and for all when entering
2327 ;; an Edebugged function), but instead it would have to
2328 ;; be installed into a modified `edebug-after' which wraps
2329 ;; the `handler-bind' around its argument(s). :-(
2329 (let ((signal-hook-function #'edebug-signal)) 2330 (let ((signal-hook-function #'edebug-signal))
2330 (setq edebug-execution-mode (or edebug-next-execution-mode 2331 (setq edebug-execution-mode (or edebug-next-execution-mode
2331 edebug-initial-mode 2332 edebug-initial-mode
@@ -3348,7 +3349,7 @@ With prefix argument, make it a temporary breakpoint."
3348 (message "%s" msg))) 3349 (message "%s" msg)))
3349 3350
3350 3351
3351(defalias 'edebug-step-through-mode 'edebug-step-mode) 3352(defalias 'edebug-step-through-mode #'edebug-step-mode)
3352 3353
3353(defun edebug-step-mode () 3354(defun edebug-step-mode ()
3354 "Proceed to next stop point." 3355 "Proceed to next stop point."
@@ -3836,12 +3837,12 @@ be installed in `emacs-lisp-mode-map'.")
3836 3837
3837;; Global GUD bindings for all emacs-lisp-mode buffers. 3838;; Global GUD bindings for all emacs-lisp-mode buffers.
3838(unless edebug-inhibit-emacs-lisp-mode-bindings 3839(unless edebug-inhibit-emacs-lisp-mode-bindings
3839 (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) 3840 (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" #'edebug-step-mode)
3840 (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) 3841 (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" #'edebug-next-mode)
3841 (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) 3842 (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" #'edebug-go-mode)
3842 (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) 3843 (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" #'edebug-where)
3843 ;; The following isn't a GUD binding. 3844 ;; The following isn't a GUD binding.
3844 (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" 'edebug-set-initial-mode)) 3845 (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" #'edebug-set-initial-mode))
3845 3846
3846(defvar-keymap edebug-mode-map 3847(defvar-keymap edebug-mode-map
3847 :parent emacs-lisp-mode-map 3848 :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
387 ,@(mapcar (lambda (field) 387 ,@(mapcar (lambda (field)
388 (pcase-exhaustive field 388 (pcase-exhaustive field
389 (`(,name ,pat) 389 (`(,name ,pat)
390 `(app (pcase--flip eieio-oref ',name) ,pat)) 390 `(app (eieio-oref _ ',name) ,pat))
391 ((pred symbolp) 391 ((pred symbolp)
392 `(app (pcase--flip eieio-oref ',field) ,field)))) 392 `(app (eieio-oref _ ',field) ,field))))
393 fields))) 393 fields)))
394 394
395;;; Simple generators, and query functions. None of these would do 395;;; 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.")
155 155
156(defvar eldoc-message-commands 156(defvar eldoc-message-commands
157 ;; Don't define as `defconst' since it would then go to (read-only) purespace. 157 ;; Don't define as `defconst' since it would then go to (read-only) purespace.
158 (make-vector eldoc-message-commands-table-size 0) 158 (obarray-make eldoc-message-commands-table-size)
159 "Commands after which it is appropriate to print in the echo area. 159 "Commands after which it is appropriate to print in the echo area.
160ElDoc does not try to print function arglists, etc., after just any command, 160ElDoc does not try to print function arglists, etc., after just any command,
161because some commands print their own messages in the echo area and these 161because some commands print their own messages in the echo area and these
@@ -191,7 +191,7 @@ It should receive the same arguments as `message'.")
191 191
192When `eldoc-print-after-edit' is non-nil, ElDoc messages are only 192When `eldoc-print-after-edit' is non-nil, ElDoc messages are only
193printed after commands contained in this obarray." 193printed after commands contained in this obarray."
194 (let ((cmds (make-vector 31 0)) 194 (let ((cmds (obarray-make 31))
195 (re (regexp-opt '("delete" "insert" "edit" "electric" "newline")))) 195 (re (regexp-opt '("delete" "insert" "edit" "electric" "newline"))))
196 (mapatoms (lambda (s) 196 (mapatoms (lambda (s)
197 (and (commandp s) 197 (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'."
266 (insert-file-contents file) 266 (insert-file-contents file)
267 (let ((buffer-file-name file) 267 (let ((buffer-file-name file)
268 (max-lisp-eval-depth (max 1000 max-lisp-eval-depth))) 268 (max-lisp-eval-depth (max 1000 max-lisp-eval-depth)))
269 (hack-local-variables)
269 (with-syntax-table emacs-lisp-mode-syntax-table 270 (with-syntax-table emacs-lisp-mode-syntax-table
270 (mapc 'elint-top-form (elint-update-env))))) 271 (mapc 'elint-top-form (elint-update-env)))))
271 (elint-set-mode-line) 272 (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 @@
60ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ 60ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\
61foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ 61foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\
62cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ 62cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\
63transient-define-\\(?:prefix\\|suffix\\|infix\\|argument\\)\\|\
63menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" 64menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)"
64 find-function-space-re 65 find-function-space-re
65 "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") 66 "\\('\\|(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 @@
80 (error "inline-const-p can only be used within define-inline")) 80 (error "inline-const-p can only be used within define-inline"))
81 81
82(defmacro inline-const-val (_exp) 82(defmacro inline-const-val (_exp)
83 "Return the value of EXP." 83 "Return the value of EXP.
84During inlining, if the value of EXP is not yet known, this aborts the
85inlining and makes us revert to a non-inlined function call."
84 (declare (debug t)) 86 (declare (debug t))
85 (error "inline-const-val can only be used within define-inline")) 87 (error "inline-const-val can only be used within define-inline"))
86 88
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."
1347(put 'condition-case 'lisp-indent-function 2) 1347(put 'condition-case 'lisp-indent-function 2)
1348(put 'handler-case 'lisp-indent-function 1) ;CL 1348(put 'handler-case 'lisp-indent-function 1) ;CL
1349(put 'unwind-protect 'lisp-indent-function 1) 1349(put 'unwind-protect 'lisp-indent-function 1)
1350(put 'with-output-to-temp-buffer 'lisp-indent-function 1)
1351(put 'closure 'lisp-indent-function 2) 1350(put 'closure 'lisp-indent-function 2)
1352 1351
1353(defun indent-sexp (&optional endpos) 1352(defun indent-sexp (&optional endpos)
@@ -1420,14 +1419,15 @@ A prefix argument specifies pretty-printing."
1420 1419
1421;;;; Lisp paragraph filling commands. 1420;;;; Lisp paragraph filling commands.
1422 1421
1423(defcustom emacs-lisp-docstring-fill-column 65 1422(defcustom emacs-lisp-docstring-fill-column 72
1424 "Value of `fill-column' to use when filling a docstring. 1423 "Value of `fill-column' to use when filling a docstring.
1425Any non-integer value means do not use a different value of 1424Any non-integer value means do not use a different value of
1426`fill-column' when filling docstrings." 1425`fill-column' when filling docstrings."
1427 :type '(choice (integer) 1426 :type '(choice (integer)
1428 (const :tag "Use the current `fill-column'" t)) 1427 (const :tag "Use the current `fill-column'" t))
1429 :safe (lambda (x) (or (eq x t) (integerp x))) 1428 :safe (lambda (x) (or (eq x t) (integerp x)))
1430 :group 'lisp) 1429 :group 'lisp
1430 :version "30.1")
1431 1431
1432(defun lisp-fill-paragraph (&optional justify) 1432(defun lisp-fill-paragraph (&optional justify)
1433 "Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings. 1433 "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."
183 (loaddefs-generate--shorten-autoload 183 (loaddefs-generate--shorten-autoload
184 `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type)))) 184 `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type))))
185 185
186 ((and expansion (memq car '(progn prog1))) 186 ;; Look inside `progn', and `eval-and-compile', since these
187 ;; are often used in the expansion of things like `pcase-defmacro'.
188 ((and expansion (memq car '(progn prog1 eval-and-compile)))
187 (let ((end (memq :autoload-end form))) 189 (let ((end (memq :autoload-end form)))
188 (when end ;Cut-off anything after the :autoload-end marker. 190 (when end ;Cut-off anything after the :autoload-end marker.
189 (setq form (copy-sequence form)) 191 (setq form (copy-sequence form))
@@ -199,8 +201,7 @@ expression, in which case we want to handle forms differently."
199 define-globalized-minor-mode defun defmacro 201 define-globalized-minor-mode defun defmacro
200 easy-mmode-define-minor-mode define-minor-mode 202 easy-mmode-define-minor-mode define-minor-mode
201 define-inline cl-defun cl-defmacro cl-defgeneric 203 define-inline cl-defun cl-defmacro cl-defgeneric
202 cl-defstruct pcase-defmacro iter-defun cl-iter-defun 204 cl-defstruct pcase-defmacro iter-defun cl-iter-defun))
203 transient-define-prefix))
204 (macrop car) 205 (macrop car)
205 (setq expand (let ((load-true-file-name file) 206 (setq expand (let ((load-true-file-name file)
206 (load-file-name file)) 207 (load-file-name file))
@@ -216,13 +217,17 @@ expression, in which case we want to handle forms differently."
216 define-globalized-minor-mode 217 define-globalized-minor-mode
217 easy-mmode-define-minor-mode define-minor-mode 218 easy-mmode-define-minor-mode define-minor-mode
218 cl-defun defun* cl-defmacro defmacro* 219 cl-defun defun* cl-defmacro defmacro*
219 define-overloadable-function)) 220 define-overloadable-function
221 transient-define-prefix transient-define-suffix
222 transient-define-infix transient-define-argument))
220 (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*))) 223 (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*)))
221 (name (nth 1 form)) 224 (name (nth 1 form))
222 (args (pcase car 225 (args (pcase car
223 ((or 'defun 'defmacro 226 ((or 'defun 'defmacro
224 'defun* 'defmacro* 'cl-defun 'cl-defmacro 227 'defun* 'defmacro* 'cl-defun 'cl-defmacro
225 'define-overloadable-function) 228 'define-overloadable-function
229 'transient-define-prefix 'transient-define-suffix
230 'transient-define-infix 'transient-define-argument)
226 (nth 2 form)) 231 (nth 2 form))
227 ('define-skeleton '(&optional str arg)) 232 ('define-skeleton '(&optional str arg))
228 ((or 'define-generic-mode 'define-derived-mode 233 ((or 'define-generic-mode 'define-derived-mode
@@ -244,7 +249,11 @@ expression, in which case we want to handle forms differently."
244 define-global-minor-mode 249 define-global-minor-mode
245 define-globalized-minor-mode 250 define-globalized-minor-mode
246 easy-mmode-define-minor-mode 251 easy-mmode-define-minor-mode
247 define-minor-mode)) 252 define-minor-mode
253 transient-define-prefix
254 transient-define-suffix
255 transient-define-infix
256 transient-define-argument))
248 t) 257 t)
249 (and (eq (car-safe (car body)) 'interactive) 258 (and (eq (car-safe (car body)) 'interactive)
250 ;; List of modes or just t. 259 ;; List of modes or just t.
@@ -378,6 +387,7 @@ don't include."
378 (let ((defs nil) 387 (let ((defs nil)
379 (load-name (loaddefs-generate--file-load-name file main-outfile)) 388 (load-name (loaddefs-generate--file-load-name file main-outfile))
380 (compute-prefixes t) 389 (compute-prefixes t)
390 read-symbol-shorthands
381 local-outfile inhibit-autoloads) 391 local-outfile inhibit-autoloads)
382 (with-temp-buffer 392 (with-temp-buffer
383 (insert-file-contents file) 393 (insert-file-contents file)
@@ -399,7 +409,22 @@ don't include."
399 (setq inhibit-autoloads (read (current-buffer))))) 409 (setq inhibit-autoloads (read (current-buffer)))))
400 (save-excursion 410 (save-excursion
401 (when (re-search-forward "autoload-compute-prefixes: *" nil t) 411 (when (re-search-forward "autoload-compute-prefixes: *" nil t)
402 (setq compute-prefixes (read (current-buffer)))))) 412 (setq compute-prefixes (read (current-buffer)))))
413 (save-excursion
414 ;; Since we're "open-coding", we have to repeat more
415 ;; complicated logic in `hack-local-variables'.
416 (when-let ((beg
417 (re-search-forward "read-symbol-shorthands: *" nil t)))
418 ;; `read-symbol-shorthands' alist ends with two parens.
419 (let* ((end (re-search-forward ")[;\n\s]*)"))
420 (commentless (replace-regexp-in-string
421 "\n\\s-*;+" ""
422 (buffer-substring beg end)))
423 (unsorted-shorthands (car (read-from-string commentless))))
424 (setq read-symbol-shorthands
425 (sort unsorted-shorthands
426 (lambda (sh1 sh2)
427 (> (length (car sh1)) (length (car sh2))))))))))
403 428
404 ;; We always return the package version (even for pre-dumped 429 ;; We always return the package version (even for pre-dumped
405 ;; files). 430 ;; files).
@@ -473,27 +498,35 @@ don't include."
473 498
474 (when (and autoload-compute-prefixes 499 (when (and autoload-compute-prefixes
475 compute-prefixes) 500 compute-prefixes)
476 (when-let ((form (loaddefs-generate--compute-prefixes load-name))) 501 (with-demoted-errors "%S"
477 ;; This output needs to always go in the main loaddefs.el, 502 (when-let
478 ;; regardless of `generated-autoload-file'. 503 ((form (loaddefs-generate--compute-prefixes load-name)))
479 (push (list main-outfile file form) defs))))) 504 ;; This output needs to always go in the main loaddefs.el,
505 ;; regardless of `generated-autoload-file'.
506 (push (list main-outfile file form) defs))))))
480 defs)) 507 defs))
481 508
482(defun loaddefs-generate--compute-prefixes (load-name) 509(defun loaddefs-generate--compute-prefixes (load-name)
483 (goto-char (point-min)) 510 (goto-char (point-min))
484 (let ((prefs nil)) 511 (let ((prefs nil)
512 (temp-obarray (obarray-make)))
485 ;; Avoid (defvar <foo>) by requiring a trailing space. 513 ;; Avoid (defvar <foo>) by requiring a trailing space.
486 (while (re-search-forward 514 (while (re-search-forward
487 "^(\\(def[^ \t\n]+\\)[ \t\n]+['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t) 515 "^(\\(def[^ \t\n]+\\)[ \t\n]+['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t)
488 (unless (member (match-string 1) autoload-ignored-definitions) 516 (unless (member (match-string 1) autoload-ignored-definitions)
489 (let ((name (match-string-no-properties 2))) 517 (let* ((name (match-string-no-properties 2))
490 (when (save-excursion 518 ;; Consider `read-symbol-shorthands'.
491 (goto-char (match-beginning 0)) 519 (probe (let ((obarray temp-obarray))
492 (or (bobp) 520 (car (read-from-string name)))))
493 (progn 521 (when (symbolp probe)
494 (forward-line -1) 522 (setq name (symbol-name probe))
495 (not (looking-at ";;;###autoload"))))) 523 (when (save-excursion
496 (push name prefs))))) 524 (goto-char (match-beginning 0))
525 (or (bobp)
526 (progn
527 (forward-line -1)
528 (not (looking-at ";;;###autoload")))))
529 (push name prefs))))))
497 (loaddefs-generate--make-prefixes prefs load-name))) 530 (loaddefs-generate--make-prefixes prefs load-name)))
498 531
499(defun loaddefs-generate--rubric (file &optional type feature compile) 532(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
608done using `pcase--flip'. 608done using `pcase--flip'.
609 609
610KEY is the key sought in the map. DEFAULT is the default value." 610KEY is the key sought in the map. DEFAULT is the default value."
611 ;; It's obsolete in Emacs>29, but `map.el' is distributed via GNU ELPA
612 ;; for earlier Emacsen.
613 (declare (obsolete _ "30.1"))
611 `(map-elt ,map ,key ,default)) 614 `(map-elt ,map ,key ,default))
612 615
613(defun map--make-pcase-bindings (args) 616(defun map--make-pcase-bindings (args)
614 "Return a list of pcase bindings from ARGS to the elements of a map." 617 "Return a list of pcase bindings from ARGS to the elements of a map."
615 (mapcar (lambda (elt) 618 (mapcar (if (< emacs-major-version 30)
616 (cond ((consp elt) 619 (lambda (elt)
617 `(app (map--pcase-map-elt ,(car elt) ,(caddr elt)) 620 (cond ((consp elt)
618 ,(cadr elt))) 621 `(app (map--pcase-map-elt ,(car elt) ,(caddr elt))
619 ((keywordp elt) 622 ,(cadr elt)))
620 (let ((var (intern (substring (symbol-name elt) 1)))) 623 ((keywordp elt)
621 `(app (pcase--flip map-elt ,elt) ,var))) 624 (let ((var (intern (substring (symbol-name elt) 1))))
622 (t `(app (pcase--flip map-elt ',elt) ,elt)))) 625 `(app (pcase--flip map-elt ,elt) ,var)))
626 (t `(app (pcase--flip map-elt ',elt) ,elt))))
627 (lambda (elt)
628 (cond ((consp elt)
629 `(app (map-elt _ ,(car elt) ,(caddr elt))
630 ,(cadr elt)))
631 ((keywordp elt)
632 (let ((var (intern (substring (symbol-name elt) 1))))
633 `(app (map-elt _ ,elt) ,var)))
634 (t `(app (map-elt _ ',elt) ,elt)))))
623 args)) 635 args))
624 636
625(defun map--make-pcase-patterns (args) 637(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
501autoloads, generating a package description file (used to 501autoloads, generating a package description file (used to
502identify a package as a VC package later on), building 502identify a package as a VC package later on), building
503documentation and marking the package as installed." 503documentation and marking the package as installed."
504 (let ((pkg-spec (package-vc--desc->spec pkg-desc)) 504 (let* ((pkg-spec (package-vc--desc->spec pkg-desc))
505 missing) 505 (lisp-dir (plist-get pkg-spec :lisp-dir))
506 (lisp-path (file-name-concat pkg-dir lisp-dir))
507 missing)
506 508
507 ;; In case the package was installed directly from source, the 509 ;; In case the package was installed directly from source, the
508 ;; dependency list wasn't know beforehand, and they might have 510 ;; dependency list wasn't know beforehand, and they might have
@@ -519,7 +521,7 @@ documentation and marking the package as installed."
519 "\\|") 521 "\\|")
520 regexp-unmatchable)) 522 regexp-unmatchable))
521 (deps '())) 523 (deps '()))
522 (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) 524 (dolist (file (directory-files lisp-path t "\\.el\\'" t))
523 (unless (string-match-p ignored-files file) 525 (unless (string-match-p ignored-files file)
524 (with-temp-buffer 526 (with-temp-buffer
525 (insert-file-contents file) 527 (insert-file-contents file)
@@ -532,6 +534,7 @@ documentation and marking the package as installed."
532 (setq deps)))))) 534 (setq deps))))))
533 (dolist (dep deps) 535 (dolist (dep deps)
534 (cl-callf version-to-list (cadr dep))) 536 (cl-callf version-to-list (cadr dep)))
537 (setf (package-desc-reqs pkg-desc) deps)
535 (setf missing (package-vc-install-dependencies (delete-dups deps))) 538 (setf missing (package-vc-install-dependencies (delete-dups deps)))
536 (setf missing (delq (assq (package-desc-name pkg-desc) 539 (setf missing (delq (assq (package-desc-name pkg-desc)
537 missing) 540 missing)
@@ -541,10 +544,8 @@ documentation and marking the package as installed."
541 (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) 544 (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir)))
542 ;; Generate autoloads 545 ;; Generate autoloads
543 (let* ((name (package-desc-name pkg-desc)) 546 (let* ((name (package-desc-name pkg-desc))
544 (auto-name (format "%s-autoloads.el" name)) 547 (auto-name (format "%s-autoloads.el" name)))
545 (lisp-dir (plist-get pkg-spec :lisp-dir))) 548 (package-generate-autoloads name lisp-path)
546 (package-generate-autoloads
547 name (file-name-concat pkg-dir lisp-dir))
548 (when lisp-dir 549 (when lisp-dir
549 (write-region 550 (write-region
550 (with-temp-buffer 551 (with-temp-buffer
@@ -938,8 +939,8 @@ for the last released version of the package."
938 (interactive 939 (interactive
939 (let* ((name (package-vc--read-package-name "Fetch package source: "))) 940 (let* ((name (package-vc--read-package-name "Fetch package source: ")))
940 (list (cadr (assoc name package-archive-contents #'string=)) 941 (list (cadr (assoc name package-archive-contents #'string=))
941 (read-file-name "Clone into new or empty directory: " nil nil t nil 942 (read-directory-name "Clone into new or empty directory: " nil nil
942 (lambda (dir) (or (not (file-exists-p dir)) 943 (lambda (dir) (or (not (file-exists-p dir))
943 (directory-empty-p dir)))) 944 (directory-empty-p dir))))
944 (and current-prefix-arg :last-release)))) 945 (and current-prefix-arg :last-release))))
945 (package-vc--archives-initialize) 946 (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
2610are invalid due to changed byte-code, macros or the like." 2610are invalid due to changed byte-code, macros or the like."
2611 (interactive) 2611 (interactive)
2612 (pcase-dolist (`(_ ,pkg-desc) package-alist) 2612 (pcase-dolist (`(_ ,pkg-desc) package-alist)
2613 (package-recompile pkg-desc))) 2613 (with-demoted-errors "Error while recompiling: %S"
2614 (package-recompile pkg-desc))))
2614 2615
2615;;;###autoload 2616;;;###autoload
2616(defun package-autoremove () 2617(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:
131 call it with one argument 131 call it with one argument
132 (F ARG1 .. ARGn) 132 (F ARG1 .. ARGn)
133 call F with ARG1..ARGn and EXPVAL as n+1'th argument 133 call F with ARG1..ARGn and EXPVAL as n+1'th argument
134 (F ARG1 .. _ .. ARGn)
135 call F, passing EXPVAL at the _ position.
134 136
135FUN, BOOLEXP, and subsequent PAT can refer to variables 137FUN, BOOLEXP, and subsequent PAT can refer to variables
136bound earlier in the pattern by a SYMBOL pattern. 138bound earlier in the pattern by a SYMBOL pattern.
@@ -163,8 +165,12 @@ Emacs Lisp manual for more information and examples."
163 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) 165 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
164 expansion)))) 166 expansion))))
165 167
166(declare-function help-fns--signature "help-fns" 168(defconst pcase--find-macro-def-regexp "(pcase-defmacro[\s\t\n]+%s[\s\t\n]*(")
167 (function doc real-def real-function buffer)) 169
170(with-eval-after-load 'find-func
171 (defvar find-function-regexp-alist)
172 (add-to-list 'find-function-regexp-alist
173 `(pcase-macro . pcase--find-macro-def-regexp)))
168 174
169;; FIXME: Obviously, this will collide with nadvice's use of 175;; FIXME: Obviously, this will collide with nadvice's use of
170;; function-documentation if we happen to advise `pcase'. 176;; function-documentation if we happen to advise `pcase'.
@@ -174,9 +180,10 @@ Emacs Lisp manual for more information and examples."
174(defun pcase--make-docstring () 180(defun pcase--make-docstring ()
175 (let* ((main (documentation (symbol-function 'pcase) 'raw)) 181 (let* ((main (documentation (symbol-function 'pcase) 'raw))
176 (ud (help-split-fundoc main 'pcase))) 182 (ud (help-split-fundoc main 'pcase)))
177 ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works,
178 ;; where cl-lib is anything using pcase-defmacro.
179 (require 'help-fns) 183 (require 'help-fns)
184 (declare-function help-fns-short-filename "help-fns" (filename))
185 (declare-function help-fns--signature "help-fns"
186 (function doc real-def real-function buffer))
180 (with-temp-buffer 187 (with-temp-buffer
181 (insert (or (cdr ud) main)) 188 (insert (or (cdr ud) main))
182 ;; Presentation Note: For conceptual continuity, we guarantee 189 ;; Presentation Note: For conceptual continuity, we guarantee
@@ -197,11 +204,20 @@ Emacs Lisp manual for more information and examples."
197 (let* ((pair (pop more)) 204 (let* ((pair (pop more))
198 (symbol (car pair)) 205 (symbol (car pair))
199 (me (cdr pair)) 206 (me (cdr pair))
200 (doc (documentation me 'raw))) 207 (doc (documentation me 'raw))
208 (filename (find-lisp-object-file-name me 'defun)))
201 (insert "\n\n-- ") 209 (insert "\n\n-- ")
202 (setq doc (help-fns--signature symbol doc me 210 (setq doc (help-fns--signature symbol doc me
203 (indirect-function me) 211 (indirect-function me)
204 nil)) 212 nil))
213 (when filename
214 (save-excursion
215 (forward-char -1)
216 (insert (format-message " in `"))
217 (help-insert-xref-button (help-fns-short-filename filename)
218 'help-function-def symbol filename
219 'pcase-macro)
220 (insert (format-message "'."))))
205 (insert "\n" (or doc "Not documented."))))) 221 (insert "\n" (or doc "Not documented.")))))
206 (let ((combined-doc (buffer-string))) 222 (let ((combined-doc (buffer-string)))
207 (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) 223 (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
269EXP in each binding in BINDINGS can use the results of the destructuring 285EXP in each binding in BINDINGS can use the results of the destructuring
270bindings that precede it in BINDINGS' order. 286bindings that precede it in BINDINGS' order.
271 287
272Each EXP should match (i.e. be of compatible structure) to its 288Each EXP should match its respective PATTERN (i.e. be of structure
273respective PATTERN; a mismatch may signal an error or may go 289compatible to PATTERN); a mismatch may signal an error or may go
274undetected, binding variables to arbitrary values, such as nil." 290undetected, binding variables to arbitrary values, such as nil."
275 (declare (indent 1) 291 (declare (indent 1)
276 (debug ((&rest (pcase-PAT &optional form)) body))) 292 (debug ((&rest (pcase-PAT &optional form)) body)))
@@ -291,8 +307,8 @@ All EXPs are evaluated first, and then used to perform destructuring
291bindings by matching each EXP against its respective PATTERN. Then 307bindings by matching each EXP against its respective PATTERN. Then
292BODY is evaluated with those bindings in effect. 308BODY is evaluated with those bindings in effect.
293 309
294Each EXP should match (i.e. be of compatible structure) to its 310Each EXP should match its respective PATTERN (i.e. be of structure
295respective PATTERN; a mismatch may signal an error or may go 311compatible to PATTERN); a mismatch may signal an error or may go
296undetected, binding variables to arbitrary values, such as nil." 312undetected, binding variables to arbitrary values, such as nil."
297 (declare (indent 1) (debug pcase-let*)) 313 (declare (indent 1) (debug pcase-let*))
298 (if (null (cdr bindings)) 314 (if (null (cdr bindings))
@@ -800,10 +816,10 @@ A and B can be one of:
800 #'compiled-function-p)))) 816 #'compiled-function-p))))
801 (pcase--mutually-exclusive-p (cadr upat) otherpred)) 817 (pcase--mutually-exclusive-p (cadr upat) otherpred))
802 '(:pcase--fail . nil)) 818 '(:pcase--fail . nil))
803 ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c)))) 819 ;; Since we turn (or 'a 'b 'c) into (pred (memq _ '(a b c)))
804 ;; try and preserve the info we get from that memq test. 820 ;; try and preserve the info we get from that memq test.
805 ((and (eq 'pcase--flip (car-safe (cadr upat))) 821 ((and (memq (car-safe (cadr upat)) '(memq member memql))
806 (memq (cadr (cadr upat)) '(memq member memql)) 822 (eq (cadr (cadr upat)) '_)
807 (eq 'quote (car-safe (nth 2 (cadr upat)))) 823 (eq 'quote (car-safe (nth 2 (cadr upat))))
808 (eq 'quote (car-safe pat))) 824 (eq 'quote (car-safe pat)))
809 (let ((set (cadr (nth 2 (cadr upat))))) 825 (let ((set (cadr (nth 2 (cadr upat)))))
@@ -851,7 +867,7 @@ A and B can be one of:
851 867
852(defmacro pcase--flip (fun arg1 arg2) 868(defmacro pcase--flip (fun arg1 arg2)
853 "Helper function, used internally to avoid (funcall (lambda ...) ...)." 869 "Helper function, used internally to avoid (funcall (lambda ...) ...)."
854 (declare (debug (sexp body))) 870 (declare (debug (sexp body)) (obsolete _ "30.1"))
855 `(,fun ,arg2 ,arg1)) 871 `(,fun ,arg2 ,arg1))
856 872
857(defun pcase--funcall (fun arg vars) 873(defun pcase--funcall (fun arg vars)
@@ -872,9 +888,13 @@ A and B can be one of:
872 (let ((newsym (gensym "x"))) 888 (let ((newsym (gensym "x")))
873 (push (list newsym arg) env) 889 (push (list newsym arg) env)
874 (setq arg newsym))) 890 (setq arg newsym)))
875 (if (or (functionp fun) (not (consp fun))) 891 (cond
876 `(funcall #',fun ,arg) 892 ((or (functionp fun) (not (consp fun)))
877 `(,@fun ,arg))))) 893 `(funcall #',fun ,arg))
894 ((memq '_ fun)
895 (mapcar (lambda (x) (if (eq '_ x) arg x)) fun))
896 (t
897 `(,@fun ,arg))))))
878 (if (null env) 898 (if (null env)
879 call 899 call
880 ;; Let's not replace `vars' in `fun' since it's 900 ;; 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
935 ;; Yes, we can use `memql' (or `member')! 955 ;; Yes, we can use `memql' (or `member')!
936 ((> (length simples) 1) 956 ((> (length simples) 1)
937 (pcase--u1 (cons `(match ,var 957 (pcase--u1 (cons `(match ,var
938 . (pred (pcase--flip ,mem-fun ',simples))) 958 . (pred (,mem-fun _ ',simples)))
939 (cdr matches)) 959 (cdr matches))
940 code vars 960 code vars
941 (if (null others) rest 961 (if (null others) rest
@@ -1082,12 +1102,13 @@ The predicate is the logical-AND of:
1082 (declare (debug (pcase-QPAT))) 1102 (declare (debug (pcase-QPAT)))
1083 (cond 1103 (cond
1084 ((eq (car-safe qpat) '\,) (cadr qpat)) 1104 ((eq (car-safe qpat) '\,) (cadr qpat))
1105 ((eq (car-safe qpat) '\,@) (error "Unsupported QPAT: %S" qpat))
1085 ((vectorp qpat) 1106 ((vectorp qpat)
1086 `(and (pred vectorp) 1107 `(and (pred vectorp)
1087 (app length ,(length qpat)) 1108 (app length ,(length qpat))
1088 ,@(let ((upats nil)) 1109 ,@(let ((upats nil))
1089 (dotimes (i (length qpat)) 1110 (dotimes (i (length qpat))
1090 (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i))) 1111 (push `(app (aref _ ,i) ,(list '\` (aref qpat i)))
1091 upats)) 1112 upats))
1092 (nreverse upats)))) 1113 (nreverse upats))))
1093 ((consp qpat) 1114 ((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."
619 (unless rest-marker 619 (unless rest-marker
620 (pcase name 620 (pcase name
621 (`&rest 621 (`&rest
622 (progn (push `(app (pcase--flip seq-drop ,index) 622 (progn (push `(app (seq-drop _ ,index)
623 ,(seq--elt-safe args (1+ index))) 623 ,(seq--elt-safe args (1+ index)))
624 bindings) 624 bindings)
625 (setq rest-marker t))) 625 (setq rest-marker t)))
626 (_ 626 (_
627 (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings)))) 627 (push `(app (seq--elt-safe _ ,index) ,name) bindings))))
628 (setq index (1+ index))) 628 (setq index (1+ index)))
629 bindings)) 629 bindings))
630 630
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
@@ -51,6 +51,17 @@
51 "Face used for a section.") 51 "Face used for a section.")
52 52
53;;;###autoload 53;;;###autoload
54(defun shortdoc--check (group functions)
55 (let ((keywords '( :no-manual :args :eval :no-eval :no-value :no-eval*
56 :result :result-string :eg-result :eg-result-string :doc)))
57 (dolist (f functions)
58 (when (consp f)
59 (dolist (x f)
60 (when (and (keywordp x) (not (memq x keywords)))
61 (error "Shortdoc %s function `%s': bad keyword `%s'"
62 group (car f) x)))))))
63
64;;;###autoload
54(progn 65(progn
55 (defvar shortdoc--groups nil) 66 (defvar shortdoc--groups nil)
56 67
@@ -118,6 +129,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
118`:no-eval*', `:result', `:result-string', `:eg-result' and 129`:no-eval*', `:result', `:result-string', `:eg-result' and
119`:eg-result-string' properties." 130`:eg-result-string' properties."
120 (declare (indent defun)) 131 (declare (indent defun))
132 (shortdoc--check group functions)
121 `(progn 133 `(progn
122 (setq shortdoc--groups (delq (assq ',group shortdoc--groups) 134 (setq shortdoc--groups (delq (assq ',group shortdoc--groups)
123 shortdoc--groups)) 135 shortdoc--groups))
@@ -715,7 +727,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
715 :eval (plist-get '(a 1 b 2 c 3) 'b)) 727 :eval (plist-get '(a 1 b 2 c 3) 'b))
716 (plist-put 728 (plist-put
717 :no-eval (setq plist (plist-put plist 'd 4)) 729 :no-eval (setq plist (plist-put plist 'd 4))
718 :eq-result (a 1 b 2 c 3 d 4)) 730 :eg-result (a 1 b 2 c 3 d 4))
719 (plist-member 731 (plist-member
720 :eval (plist-member '(a 1 b 2 c 3) 'b)) 732 :eval (plist-member '(a 1 b 2 c 3) 'b))
721 "Data About Lists" 733 "Data About Lists"
@@ -735,9 +747,13 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
735 (intern 747 (intern
736 :eval (intern "abc")) 748 :eval (intern "abc"))
737 (intern-soft 749 (intern-soft
750 :eval (intern-soft "list")
738 :eval (intern-soft "Phooey!")) 751 :eval (intern-soft "Phooey!"))
739 (make-symbol 752 (make-symbol
740 :eval (make-symbol "abc")) 753 :eval (make-symbol "abc"))
754 (gensym
755 :no-eval (gensym)
756 :eg-result g37)
741 "Comparing symbols" 757 "Comparing symbols"
742 (eq 758 (eq
743 :eval (eq 'abc 'abc) 759 :eval (eq 'abc 'abc)
@@ -748,7 +764,20 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
748 :eval (equal 'abc 'abc)) 764 :eval (equal 'abc 'abc))
749 "Name" 765 "Name"
750 (symbol-name 766 (symbol-name
751 :eval (symbol-name 'abc))) 767 :eval (symbol-name 'abc))
768 "Obarrays"
769 (obarray-make
770 :eval (obarray-make))
771 (obarrayp
772 :eval (obarrayp (obarray-make))
773 :eval (obarrayp nil))
774 (unintern
775 :no-eval (unintern "abc" my-obarray)
776 :eg-result t)
777 (mapatoms
778 :no-eval (mapatoms (lambda (symbol) (print symbol)) my-obarray))
779 (obarray-clear
780 :no-eval (obarray-clear my-obarray)))
752 781
753(define-short-documentation-group comparison 782(define-short-documentation-group comparison
754 "General-purpose" 783 "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 @@
52 :version "28.1" 52 :version "28.1"
53 :group 'font-lock-faces) 53 :group 'font-lock-faces)
54 54
55(defun shorthands--mismatch-from-end (str1 str2)
56 "Tell index of first mismatch in STR1 and STR2, from end.
57The index is a valid 0-based index on STR1. Returns nil if STR1
58equals STR2. Return 0 if STR1 is a suffix of STR2."
59 (cl-loop with l1 = (length str1) with l2 = (length str2)
60 for i from 1
61 for i1 = (- l1 i) for i2 = (- l2 i)
62 while (eq (aref str1 i1) (aref str2 i2))
63 if (zerop i2) return (if (zerop i1) nil i1)
64 if (zerop i1) return 0
65 finally (return i1)))
66
67(defun shorthands-font-lock-shorthands (limit) 55(defun shorthands-font-lock-shorthands (limit)
56 "Font lock until LIMIT considering `read-symbol-shorthands'."
68 (when read-symbol-shorthands 57 (when read-symbol-shorthands
69 (while (re-search-forward 58 (while (re-search-forward
70 (concat "\\_<\\(" (rx lisp-mode-symbol) "\\)\\_>") 59 (concat "\\_<\\(" (rx lisp-mode-symbol) "\\)\\_>")
71 limit t) 60 limit t)
72 (let* ((existing (get-text-property (match-beginning 1) 'face)) 61 (let* ((existing (get-text-property (match-beginning 1) 'face))
62 (print-name (match-string 1))
73 (probe (and (not (memq existing '(font-lock-comment-face 63 (probe (and (not (memq existing '(font-lock-comment-face
74 font-lock-string-face))) 64 font-lock-string-face)))
75 (intern-soft (match-string 1)))) 65 (intern-soft print-name)))
76 (sname (and probe (symbol-name probe))) 66 (symbol-name (and probe (symbol-name probe)))
77 (mismatch (and sname (shorthands--mismatch-from-end 67 (prefix (and symbol-name
78 (match-string 1) sname))) 68 (not (string-equal print-name symbol-name))
79 (guess (and mismatch (1+ mismatch)))) 69 (car (assoc print-name
80 (when guess 70 read-symbol-shorthands
81 (when (and (< guess (1- (length (match-string 1)))) 71 #'string-prefix-p)))))
82 ;; In bug#67390 we allow other separators 72 (when prefix
83 (eq (char-syntax (aref (match-string 1) guess)) ?_))
84 (setq guess (1+ guess)))
85 (add-face-text-property (match-beginning 1) 73 (add-face-text-property (match-beginning 1)
86 (+ (match-beginning 1) guess) 74 (+ (match-beginning 1) (length prefix))
87 'elisp-shorthand-font-lock-face)))))) 75 'elisp-shorthand-font-lock-face))))))
88 76
89(font-lock-add-keywords 'emacs-lisp-mode '((shorthands-font-lock-shorthands)) t) 77(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."
193 ;; Do this so we'll see strings: 193 ;; Do this so we'll see strings:
194 (cl-prin1-to-string value) 194 (cl-prin1-to-string value)
195 ctx))))) 195 ctx)))))
196 196
197(defvar trace--timer nil) 197(defvar trace--timer nil)
198 198
199(defun trace--display-buffer (buf) 199(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."
47 (repeat :tag "Random pool" 47 (repeat :tag "Random pool"
48 (string :tag "Keyserver address")) 48 (string :tag "Keyserver address"))
49 (const "keyring.debian.org") 49 (const "keyring.debian.org")
50 (const "keys.gnupg.net")
51 (const "keyserver.ubuntu.com") 50 (const "keyserver.ubuntu.com")
52 (const "pgp.mit.edu") 51 (const "pgp.mit.edu")
53 (const "pool.sks-keyservers.net")
54 (const "zimmermann.mayfirst.org")
55 (string :tag "Custom keyserver")) 52 (string :tag "Custom keyserver"))
56 :version "28.1") 53 :version "28.1")
57 54
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."
73 :group 'epa 73 :group 'epa
74 :version "24.4") 74 :version "24.4")
75 75
76(defcustom epa-keys-select-method 'buffer
77 "Method used to select keys in `epa-select-keys'.
78If the value is \\='buffer, the default, keys are selected via a
79pop-up buffer. If the value is \\='minibuffer, keys are selected
80via the minibuffer instead, using `completing-read-multiple'.
81Any other value is treated as \\='buffer."
82 :type '(choice (const :tag "Read keys from a pop-up buffer" buffer)
83 (const :tag "Read keys from minibuffer" minibuffer))
84 :group 'epa
85 :version "30.1")
86
76;;; Faces 87;;; Faces
77 88
78(defgroup epa-faces nil 89(defgroup epa-faces nil
@@ -450,6 +461,25 @@ q trust status questionable. - trust status unspecified.
450 (epa--marked-keys)) 461 (epa--marked-keys))
451 (kill-buffer epa-keys-buffer))))) 462 (kill-buffer epa-keys-buffer)))))
452 463
464(defun epa--select-keys-in-minibuffer (prompt keys)
465 (let* ((prompt (pcase-let ((`(,first ,second ,third)
466 (string-split prompt "\\."))
467 (hint "(separated by comma)"))
468 (if third
469 (format "%s %s. %s: " first hint second)
470 (format "%s %s: " first hint))))
471 (keys-alist
472 (seq-map
473 (lambda (key)
474 (cons (substring-no-properties
475 (epa--button-key-text key))
476 key))
477 keys))
478 (selected-keys (completing-read-multiple prompt keys-alist)))
479 (seq-map
480 (lambda (key) (cdr (assoc key keys-alist)))
481 selected-keys)))
482
453;;;###autoload 483;;;###autoload
454(defun epa-select-keys (context prompt &optional names secret) 484(defun epa-select-keys (context prompt &optional names secret)
455 "Display a user's keyring and ask him to select keys. 485 "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
459the keys are listed. 489the keys are listed.
460If SECRET is non-nil, list secret keys instead of public keys." 490If SECRET is non-nil, list secret keys instead of public keys."
461 (let ((keys (epg-list-keys context names secret))) 491 (let ((keys (epg-list-keys context names secret)))
462 (epa--select-keys prompt keys))) 492 (pcase epa-keys-select-method
493 ('minibuffer (epa--select-keys-in-minibuffer prompt keys))
494 (_ (epa--select-keys prompt keys)))))
463 495
464;;;; Key Details 496;;;; Key Details
465 497
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 @@
158(declare-function erc-parse-user "erc" (string)) 158(declare-function erc-parse-user "erc" (string))
159(declare-function erc-process-away "erc" (proc away-p)) 159(declare-function erc-process-away "erc" (proc away-p))
160(declare-function erc-process-ctcp-query "erc" (proc parsed nick login host)) 160(declare-function erc-process-ctcp-query "erc" (proc parsed nick login host))
161(declare-function erc-query-buffer-p "erc" (&optional buffer))
162(declare-function erc-remove-channel-member "erc" (channel nick)) 161(declare-function erc-remove-channel-member "erc" (channel nick))
163(declare-function erc-remove-channel-users "erc" nil) 162(declare-function erc-remove-channel-users "erc" nil)
164(declare-function erc-remove-user "erc" (nick)) 163(declare-function erc-remove-user "erc" (nick))
@@ -254,6 +253,11 @@ Entries are of the form:
254or 253or
255 (PARAMETER) if no value is provided. 254 (PARAMETER) if no value is provided.
256 255
256where PARAMETER is a string and VALUE is a string or nil. For
257compatibility, a raw parameter of the form \"FOO=\" becomes
258(\"FOO\" . \"\") even though it's equivalent to the preferred
259canonical form \"FOO\" and its lisp representation (\"FOO\").
260
257Some examples of possible parameters sent by servers: 261Some examples of possible parameters sent by servers:
258CHANMODES=b,k,l,imnpst - list of supported channel modes 262CHANMODES=b,k,l,imnpst - list of supported channel modes
259CHANNELLEN=50 - maximum length of channel names 263CHANNELLEN=50 - maximum length of channel names
@@ -273,7 +277,8 @@ WALLCHOPS - supports sending messages to all operators in a channel")
273(defvar-local erc--isupport-params nil 277(defvar-local erc--isupport-params nil
274 "Hash map of \"ISUPPORT\" params. 278 "Hash map of \"ISUPPORT\" params.
275Keys are symbols. Values are lists of zero or more strings with hex 279Keys are symbols. Values are lists of zero or more strings with hex
276escapes removed.") 280escapes removed. ERC normalizes incoming parameters of the form
281\"FOO=\" to (FOO).")
277 282
278;;; Server and connection state 283;;; Server and connection state
279 284
@@ -1474,10 +1479,12 @@ for decoding."
1474 (let ((args (erc-response.command-args parsed-response)) 1479 (let ((args (erc-response.command-args parsed-response))
1475 (decode-target nil) 1480 (decode-target nil)
1476 (decoded-args ())) 1481 (decoded-args ()))
1482 ;; FIXME this should stop after the first match.
1477 (dolist (arg args nil) 1483 (dolist (arg args nil)
1478 (when (string-match "^[#&].*" arg) 1484 (when (string-match "^[#&].*" arg)
1479 (setq decode-target arg))) 1485 (setq decode-target arg)))
1480 (when (stringp decode-target) 1486 (when (stringp decode-target)
1487 ;; FIXME `decode-target' should be passed as TARGET.
1481 (setq decode-target (erc-decode-string-from-target decode-target nil))) 1488 (setq decode-target (erc-decode-string-from-target decode-target nil)))
1482 (setf (erc-response.unparsed parsed-response) 1489 (setf (erc-response.unparsed parsed-response)
1483 (erc-decode-string-from-target 1490 (erc-decode-string-from-target
@@ -2150,10 +2157,6 @@ Then display the welcome message."
2150 ;; 2157 ;;
2151 ;; > The server SHOULD send "X", not "X="; this is the normalized form. 2158 ;; > The server SHOULD send "X", not "X="; this is the normalized form.
2152 ;; 2159 ;;
2153 ;; Note: for now, assume the server will only send non-empty values,
2154 ;; possibly with printable ASCII escapes. Though in practice, the
2155 ;; only two escapes we're likely to see are backslash and space,
2156 ;; meaning the pattern is too liberal.
2157 (let (case-fold-search) 2160 (let (case-fold-search)
2158 (mapcar 2161 (mapcar
2159 (lambda (v) 2162 (lambda (v)
@@ -2164,7 +2167,9 @@ Then display the welcome message."
2164 (string-match "[\\]x[0-9A-F][0-9A-F]" v start)) 2167 (string-match "[\\]x[0-9A-F][0-9A-F]" v start))
2165 (setq m (substring v (+ 2 (match-beginning 0)) (match-end 0)) 2168 (setq m (substring v (+ 2 (match-beginning 0)) (match-end 0))
2166 c (string-to-number m 16)) 2169 c (string-to-number m 16))
2167 (if (<= ?\ c ?~) 2170 ;; In practice, this range is too liberal. The only
2171 ;; escapes we're likely to see are ?\\, ?=, and ?\s.
2172 (if (<= ?\s c ?~)
2168 (setq v (concat (substring v 0 (match-beginning 0)) 2173 (setq v (concat (substring v 0 (match-beginning 0))
2169 (string c) 2174 (string c)
2170 (substring v (match-end 0))) 2175 (substring v (match-end 0)))
@@ -2189,8 +2194,9 @@ primitive value."
2189 (or erc-server-parameters 2194 (or erc-server-parameters
2190 (erc-with-server-buffer 2195 (erc-with-server-buffer
2191 erc-server-parameters))))) 2196 erc-server-parameters)))))
2192 (if (cdr v) 2197 (if-let ((val (cdr v))
2193 (erc--parse-isupport-value (cdr v)) 2198 ((not (string-empty-p val))))
2199 (erc--parse-isupport-value val)
2194 '--empty--))))) 2200 '--empty--)))))
2195 (pcase value 2201 (pcase value
2196 ('--empty-- (unless single (list key))) 2202 ('--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."
171 171
172;; After dropping 28, we can use prefixed "erc-autoload" cookies. 172;; After dropping 28, we can use prefixed "erc-autoload" cookies.
173(defun erc--normalize-module-symbol (symbol) 173(defun erc--normalize-module-symbol (symbol)
174 "Return preferred SYMBOL for `erc--modules'." 174 "Return preferred SYMBOL for `erc--module'."
175 (while-let ((canonical (get symbol 'erc--module)) 175 (while-let ((canonical (get symbol 'erc--module))
176 ((not (eq canonical symbol)))) 176 ((not (eq canonical symbol))))
177 (setq symbol canonical)) 177 (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 @@
31 31
32;;; Code: 32;;; Code:
33 33
34(require 'compat nil 'noerror) 34(require 'compat)
35(eval-when-compile (require 'cl-lib)) 35(eval-when-compile (require 'cl-lib))
36 36
37;; Except for the "erc-" namespacing, these two definitions should be 37(define-obsolete-function-alias 'erc-compat-function #'compat-function "30.1")
38;; continuously updated to match the latest upstream ones verbatim. 38(define-obsolete-function-alias 'erc-compat-call #'compat-call "30.1")
39;; Although they're pretty simple, it's likely not worth checking for
40;; and possibly deferring to the non-prefixed versions.
41;;
42;; BEGIN Compat macros
43
44;;;; Macros for extended compatibility function calls
45
46(defmacro erc-compat-function (fun)
47 "Return compatibility function symbol for FUN.
48
49If the Emacs version provides a sufficiently recent version of
50FUN, the symbol FUN is returned itself. Otherwise the macro
51returns the symbol of a compatibility function which supports the
52behavior and calling convention of the current stable Emacs
53version. For example Compat 29.1 will provide compatibility
54functions which implement the behavior and calling convention of
55Emacs 29.1.
56
57See also `compat-call' to directly call compatibility functions."
58 (let ((compat (intern (format "compat--%s" fun))))
59 `#',(if (fboundp compat) compat fun)))
60
61(defmacro erc-compat-call (fun &rest args)
62 "Call compatibility function or macro FUN with ARGS.
63
64A good example function is `plist-get' which was extended with an
65additional predicate argument in Emacs 29.1. The compatibility
66function, which supports this additional argument, can be
67obtained via (compat-function plist-get) and called
68via (compat-call plist-get plist prop predicate). It is not
69possible to directly call (plist-get plist prop predicate) on
70Emacs older than 29.1, since the original `plist-get' function
71does not yet support the predicate argument. Note that the
72Compat library never overrides existing functions.
73
74See also `compat-function' to lookup compatibility functions."
75 (let ((compat (intern (format "compat--%s" fun))))
76 `(,(if (fboundp compat) compat fun) ,@args)))
77
78;; END Compat macros
79 39
80;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") 40;;;###autoload(autoload 'erc-define-minor-mode "erc-compat")
81(define-obsolete-function-alias 'erc-define-minor-mode 41(define-obsolete-function-alias 'erc-define-minor-mode
@@ -102,7 +62,7 @@ See `erc-encoding-coding-alist'."
102 62
103(defun erc-set-write-file-functions (new-val) 63(defun erc-set-write-file-functions (new-val)
104 (declare (obsolete nil "28.1")) 64 (declare (obsolete nil "28.1"))
105 (set (make-local-variable 'write-file-functions) new-val)) 65 (setq-local write-file-functions new-val))
106 66
107(defvar erc-emacs-build-time 67(defvar erc-emacs-build-time
108 (if (or (stringp emacs-build-time) (not emacs-build-time)) 68 (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 @@
44(define-erc-module fill nil 44(define-erc-module fill nil
45 "Manage filling in ERC buffers. 45 "Manage filling in ERC buffers.
46ERC fill mode is a global minor mode. When enabled, messages in 46ERC fill mode is a global minor mode. When enabled, messages in
47the channel buffers are filled." 47channel buffers are filled. See also `erc-fill-wrap-mode'."
48 ;; FIXME ensure a consistent ordering relative to hook members from
49 ;; other modules. Ideally, this module's processing should happen
50 ;; after "morphological" modifications to a message's text but
51 ;; before superficial decorations.
52 ((add-hook 'erc-insert-modify-hook #'erc-fill 60) 48 ((add-hook 'erc-insert-modify-hook #'erc-fill 60)
53 (add-hook 'erc-send-modify-hook #'erc-fill 60)) 49 (add-hook 'erc-send-modify-hook #'erc-fill 60))
54 ((remove-hook 'erc-insert-modify-hook #'erc-fill) 50 ((remove-hook 'erc-insert-modify-hook #'erc-fill)
@@ -425,8 +421,11 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'."
425 "<remap> <erc-bol>" #'erc-fill--wrap-beginning-of-line) 421 "<remap> <erc-bol>" #'erc-fill--wrap-beginning-of-line)
426 422
427(defvar erc-button-mode) 423(defvar erc-button-mode)
424(defvar erc-scrolltobottom-mode)
428(defvar erc-legacy-invisible-bounds-p) 425(defvar erc-legacy-invisible-bounds-p)
429 426
427(defvar erc--fill-wrap-scrolltobottom-exempt-p nil)
428
430(defun erc-fill--wrap-ensure-dependencies () 429(defun erc-fill--wrap-ensure-dependencies ()
431 (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) 430 (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p))
432 (when erc-legacy-invisible-bounds-p 431 (when erc-legacy-invisible-bounds-p
@@ -439,6 +438,10 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'."
439 (unless erc-fill-mode 438 (unless erc-fill-mode
440 (push 'fill missing-deps) 439 (push 'fill missing-deps)
441 (erc-fill-mode +1)) 440 (erc-fill-mode +1))
441 (unless (or erc-scrolltobottom-mode erc--fill-wrap-scrolltobottom-exempt-p
442 (memq 'scrolltobottom erc-modules))
443 (push 'scrolltobottom missing-deps)
444 (erc-scrolltobottom-mode +1))
442 (when erc-fill-wrap-merge 445 (when erc-fill-wrap-merge
443 (require 'erc-button) 446 (require 'erc-button)
444 (unless erc-button-mode 447 (unless erc-button-mode
@@ -459,27 +462,25 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'."
459;;;###autoload(put 'fill-wrap 'erc--feature 'erc-fill) 462;;;###autoload(put 'fill-wrap 'erc--feature 'erc-fill)
460(define-erc-module fill-wrap nil 463(define-erc-module fill-wrap nil
461 "Fill style leveraging `visual-line-mode'. 464 "Fill style leveraging `visual-line-mode'.
465
462This module displays nicks overhanging leftward to a common 466This module displays nicks overhanging leftward to a common
463offset, as determined by the option `erc-fill-static-center'. 467offset, as determined by the option `erc-fill-static-center'. It
464And it \"wraps\" messages at a common margin width, as determined 468also \"wraps\" messages at a common width, as determined by the
465by the option `erc-fill-wrap-margin-width'. To use it, either 469option `erc-fill-wrap-margin-width'. To use it, either include
466include `fill-wrap' in `erc-modules' or set `erc-fill-function' 470`fill-wrap' in `erc-modules' or set `erc-fill-function' to
467to `erc-fill-wrap'. Most users will want to enable the 471`erc-fill-wrap'.
468`scrolltobottom' module as well. 472
469 473Once enabled, use \\[erc-fill-wrap-nudge] to adjust the width of
470During sessions in which this module is active, use 474the indent and the stamp margin. And For cycling between
471\\[erc-fill-wrap-nudge] to adjust the width of the indent and the 475logical- and screen-line oriented command movement, see
472stamp margin, and use \\[erc-fill-wrap-toggle-truncate-lines] for 476\\[erc-fill-wrap-toggle-truncate-lines]. Similarly, use
473cycling between logical- and screen-line oriented command 477\\[erc-fill-wrap-refill-buffer] to fix alignment problems after
474movement. Similarly, use \\[erc-fill-wrap-refill-buffer] to fix 478running certain commands, like `text-scale-adjust'. Also see
475alignment problems after running certain commands, like 479related stylistic options `erc-fill-wrap-merge', and
476`text-scale-adjust'. Also see related stylistic options 480`erc-fill-wrap-merge-indicator'. (Hint: in narrow windows, try
477`erc-fill-wrap-merge', and `erc-fill-wrap-merge-indicator'. 481setting `erc-fill-static-center' to 1, and if you use
478\(Hint: in narrow windows, where is space tight, try setting 482`erc-fill-wrap-merge-indicator', choose \"Leading MIDDLE DOT sans
479`erc-fill-static-center' to 1. And if you also use the option 483gap\" or one of the \"trailing\" items from the Customize menu.)
480`erc-fill-wrap-merge-indicator', set that to value-menu item
481\"Leading MIDDLE DOT sans gap\" or one of the various
482\"trailing\" items.)
483 484
484This module imposes various restrictions on the appearance of 485This module imposes various restrictions on the appearance of
485timestamps. Most notably, it insists on displaying them in the 486timestamps. Most notably, it insists on displaying them in the
@@ -497,11 +498,12 @@ a workaround provided by `erc-stamp-prefix-log-filter', which
497strips trailing stamps from logged messages and instead prepends 498strips trailing stamps from logged messages and instead prepends
498them to every line. 499them to every line.
499 500
500As a so-called \"local\" module, `fill-wrap' depends on the 501A so-called \"local\" module, `fill-wrap' depends on the global
501global modules `fill', `stamp', and `button'; it activates them 502modules `fill', `stamp', `button', and `scrolltobottom'. It
502as needed when initializing. Please note that enabling and 503activates them as needed when initializing and leaves them
503disabling this module by invoking one of its minor-mode toggles 504enabled when shutting down. To opt out of `scrolltobottom'
504is not recommended." 505specifically, disable its minor mode, `erc-scrolltobottom-mode',
506via `erc-fill-wrap-mode-hook'."
505 ((erc-fill--wrap-ensure-dependencies) 507 ((erc-fill--wrap-ensure-dependencies)
506 (erc--restore-initialize-priors erc-fill-wrap-mode 508 (erc--restore-initialize-priors erc-fill-wrap-mode
507 erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys 509 erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys
@@ -832,7 +834,7 @@ decorations applied by third-party modules."
832 (line (count-screen-lines (window-start) (window-point)))) 834 (line (count-screen-lines (window-start) (window-point))))
833 (when (zerop arg) 835 (when (zerop arg)
834 (setq arg 1)) 836 (setq arg 1))
835 (erc-compat-call 837 (compat-call
836 set-transient-map 838 set-transient-map
837 (let ((map (make-sparse-keymap))) 839 (let ((map (make-sparse-keymap)))
838 (dolist (key '(?= ?- ?0)) 840 (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+."
83 (when (and erc-scrolltobottom-all (< emacs-major-version 28)) 83 (when (and erc-scrolltobottom-all (< emacs-major-version 28))
84 (erc-button--display-error-notice-with-keys 84 (erc-button--display-error-notice-with-keys
85 "Option `erc-scrolltobottom-all' requires Emacs 28+. Disabling.") 85 "Option `erc-scrolltobottom-all' requires Emacs 28+. Disabling.")
86 (setopt erc-scrolltobottom-all nil)) 86 (setq erc-scrolltobottom-all nil))
87 (unless erc--updating-modules-p (erc-buffer-do #'erc--scrolltobottom-setup)) 87 (unless erc--updating-modules-p (erc-buffer-do #'erc--scrolltobottom-setup))
88 (if erc-scrolltobottom-all 88 (if erc-scrolltobottom-all
89 (progn 89 (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."
1123 (lambda () 1123 (lambda ()
1124 (when (and erc--target (eq (erc--target-symbol erc--target) 1124 (when (and erc--target (eq (erc--target-symbol erc--target)
1125 (erc--target-symbol target))) 1125 (erc--target-symbol target)))
1126 (let ((oursp (if (erc--target-channel-local-p target) 1126 ;; When a server sends administrative queries immediately
1127 (equal announced erc-server-announced-name) 1127 ;; after connection registration and before the session has a
1128 (erc-networks--id-equal-p identity erc-networks--id)))) 1128 ;; net-id, the buffer remains orphaned until reassociated
1129 (funcall (if oursp on-dupe on-collision)))))))) 1129 ;; here retroactively.
1130 (unless erc-networks--id
1131 (let ((id (erc-with-server-buffer erc-networks--id))
1132 (server-buffer (process-buffer erc-server-process)))
1133 (apply #'erc-button--display-error-notice-with-keys
1134 server-buffer
1135 (concat "Missing network session (ID) for %S. "
1136 (if id "Using `%S' from %S." "Ignoring."))
1137 (current-buffer)
1138 (and id (list (erc-networks--id-symbol
1139 (setq erc-networks--id id))
1140 server-buffer)))))
1141 (when erc-networks--id
1142 (let ((oursp (if (erc--target-channel-local-p target)
1143 (equal announced erc-server-announced-name)
1144 (erc-networks--id-equal-p identity
1145 erc-networks--id))))
1146 (funcall (if oursp on-dupe on-collision)))))))))
1130 1147
1131(defconst erc-networks--qualified-sep "@" 1148(defconst erc-networks--qualified-sep "@"
1132 "Separator used for naming a target buffer.") 1149 "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."
566(defun erc-speedbar--reset-last-ran-on-timer () 566(defun erc-speedbar--reset-last-ran-on-timer ()
567 "Reset `erc-speedbar--last-ran'." 567 "Reset `erc-speedbar--last-ran'."
568 (when speedbar-buffer 568 (when speedbar-buffer
569 (setf (buffer-local-value 'erc-speedbar--last-ran speedbar-buffer) 569 (with-suppressed-warnings ((obsolete buffer-local-value)) ; <=29
570 (current-time)))) 570 (setf (buffer-local-value 'erc-speedbar--last-ran speedbar-buffer)
571 (current-time)))))
571 572
572;;;###autoload(autoload 'erc-nickbar-mode "erc-speedbar" nil t) 573;;;###autoload(autoload 'erc-nickbar-mode "erc-speedbar" nil t)
573(define-erc-module nickbar nil 574(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."
184 (add-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect) 184 (add-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)
185 (add-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear 40) 185 (add-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear 40)
186 (unless erc--updating-modules-p (erc-buffer-do #'erc-stamp--setup))) 186 (unless erc--updating-modules-p (erc-buffer-do #'erc-stamp--setup)))
187 ((remove-hook 'erc-mode-hook #'erc-munge-invisibility-spec) 187 ((remove-hook 'erc-mode-hook #'erc-stamp--setup)
188 (remove-hook 'erc-insert-modify-hook #'erc-add-timestamp) 188 (remove-hook 'erc-insert-modify-hook #'erc-add-timestamp)
189 (remove-hook 'erc-send-modify-hook #'erc-add-timestamp) 189 (remove-hook 'erc-send-modify-hook #'erc-add-timestamp)
190 (remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect) 190 (remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)
@@ -198,6 +198,7 @@ from entering them and instead jump over them."
198 "Escape hatch for omitting stamps when first char is invisible.") 198 "Escape hatch for omitting stamps when first char is invisible.")
199 199
200(defun erc-stamp--recover-on-reconnect () 200(defun erc-stamp--recover-on-reconnect ()
201 "Attempt to restore \"last-inserted\" snapshots from prior session."
201 (when-let ((priors (or erc--server-reconnecting erc--target-priors))) 202 (when-let ((priors (or erc--server-reconnecting erc--target-priors)))
202 (dolist (var '(erc-timestamp-last-inserted 203 (dolist (var '(erc-timestamp-last-inserted
203 erc-timestamp-last-inserted-left 204 erc-timestamp-last-inserted-left
@@ -827,6 +828,7 @@ left-sided stamps and date stamps inserted by this function."
827;; perform day alignments via this function only when needed. 828;; perform day alignments via this function only when needed.
828(defun erc-stamp--time-as-day (current-time) 829(defun erc-stamp--time-as-day (current-time)
829 "Discard hour, minute, and second info from timestamp CURRENT-TIME." 830 "Discard hour, minute, and second info from timestamp CURRENT-TIME."
831 (defvar current-time-list) ; <=28
830 (let* ((current-time-list) ; flag 832 (let* ((current-time-list) ; flag
831 (decoded (decode-time current-time erc-stamp--tz))) 833 (decoded (decode-time current-time erc-stamp--tz)))
832 (setf (decoded-time-second decoded) 0 834 (setf (decoded-time-second decoded) 0
@@ -854,12 +856,20 @@ Return the empty string if FORMAT is nil."
854 856
855(defvar-local erc-stamp--csf-props-updated-p nil) 857(defvar-local erc-stamp--csf-props-updated-p nil)
856 858
857;; This function is used to munge `buffer-invisibility-spec' to an 859(define-obsolete-function-alias 'erc-munge-invisibility-spec
858;; appropriate value. Currently, it only handles timestamps, thus its 860 #'erc-stamp--manage-local-options-state "30.1"
859;; location. If you add other features which affect invisibility, 861 "Perform setup and teardown of `stamp'-owned options.
860;; please modify this function and move it to a more appropriate 862
861;; location. 863Note that this function's role in practice has long defied its
862(defun erc-munge-invisibility-spec () 864stated mandate as claimed in a now deleted comment, which
865envisioned it as evolving into a central toggle for modifying
866`buffer-invisibility-spec' on behalf of options and features
867ERC-wide.")
868(defun erc-stamp--manage-local-options-state ()
869 "Perform local setup and teardown for `stamp'-owned options.
870For `erc-timestamp-intangible', toggle `cursor-intangible-mode'.
871For `erc-echo-timestamps', integrate with `cursor-sensor-mode'.
872For `erc-hide-timestamps, modify `buffer-invisibility-spec'."
863 (if erc-timestamp-intangible 873 (if erc-timestamp-intangible
864 (cursor-intangible-mode +1) ; idempotent 874 (cursor-intangible-mode +1) ; idempotent
865 (when (bound-and-true-p cursor-intangible-mode) 875 (when (bound-and-true-p cursor-intangible-mode)
@@ -869,10 +879,12 @@ Return the empty string if FORMAT is nil."
869 (unless erc-stamp--permanent-cursor-sensor-functions 879 (unless erc-stamp--permanent-cursor-sensor-functions
870 (dolist (hook '(erc-insert-post-hook erc-send-post-hook)) 880 (dolist (hook '(erc-insert-post-hook erc-send-post-hook))
871 (add-hook hook #'erc-stamp--add-csf-on-post-modify nil t)) 881 (add-hook hook #'erc-stamp--add-csf-on-post-modify nil t))
872 (erc--restore-initialize-priors erc-stamp-mode 882 (setq erc-stamp--csf-props-updated-p
873 erc-stamp--csf-props-updated-p nil) 883 (alist-get 'erc-stamp--csf-props-updated-p
884 (or erc--server-reconnecting erc--target-priors)))
874 (unless erc-stamp--csf-props-updated-p 885 (unless erc-stamp--csf-props-updated-p
875 (setq erc-stamp--csf-props-updated-p t) 886 (setq erc-stamp--csf-props-updated-p t)
887 ;; Spoof `erc--ts' as being non-nil.
876 (let ((erc--msg-props (map-into '((erc--ts . t)) 'hash-table))) 888 (let ((erc--msg-props (map-into '((erc--ts . t)) 'hash-table)))
877 (with-silent-modifications 889 (with-silent-modifications
878 (erc--traverse-inserted 890 (erc--traverse-inserted
@@ -902,9 +914,9 @@ Return the empty string if FORMAT is nil."
902(defun erc-stamp--setup () 914(defun erc-stamp--setup ()
903 "Enable or disable buffer-local `erc-stamp-mode' modifications." 915 "Enable or disable buffer-local `erc-stamp-mode' modifications."
904 (if erc-stamp-mode 916 (if erc-stamp-mode
905 (erc-munge-invisibility-spec) 917 (erc-stamp--manage-local-options-state)
906 (let (erc-echo-timestamps erc-hide-timestamps erc-timestamp-intangible) 918 (let (erc-echo-timestamps erc-hide-timestamps erc-timestamp-intangible)
907 (erc-munge-invisibility-spec)) 919 (erc-stamp--manage-local-options-state))
908 ;; Undo local mods from `erc-insert-timestamp-left-and-right'. 920 ;; Undo local mods from `erc-insert-timestamp-left-and-right'.
909 (erc-stamp--date-mode -1) ; kills `erc-timestamp-last-inserted-left' 921 (erc-stamp--date-mode -1) ; kills `erc-timestamp-last-inserted-left'
910 (kill-local-variable 'erc-stamp--last-stamp) 922 (kill-local-variable 'erc-stamp--last-stamp)
@@ -916,7 +928,7 @@ Return the empty string if FORMAT is nil."
916 "Hide timestamp information from display." 928 "Hide timestamp information from display."
917 (interactive) 929 (interactive)
918 (setq erc-hide-timestamps t) 930 (setq erc-hide-timestamps t)
919 (erc-munge-invisibility-spec)) 931 (erc-stamp--manage-local-options-state))
920 932
921(defun erc-show-timestamps () 933(defun erc-show-timestamps ()
922 "Show timestamp information on display. 934 "Show timestamp information on display.
@@ -924,7 +936,7 @@ This function only works if `erc-timestamp-format' was previously
924set, and timestamping is already active." 936set, and timestamping is already active."
925 (interactive) 937 (interactive)
926 (setq erc-hide-timestamps nil) 938 (setq erc-hide-timestamps nil)
927 (erc-munge-invisibility-spec)) 939 (erc-stamp--manage-local-options-state))
928 940
929(defun erc-toggle-timestamps () 941(defun erc-toggle-timestamps ()
930 "Hide or show timestamps in ERC buffers. 942 "Hide or show timestamps in ERC buffers.
@@ -938,7 +950,7 @@ enabled when the message was inserted."
938 (setq erc-hide-timestamps t)) 950 (setq erc-hide-timestamps t))
939 (mapc (lambda (buffer) 951 (mapc (lambda (buffer)
940 (with-current-buffer buffer 952 (with-current-buffer buffer
941 (erc-munge-invisibility-spec))) 953 (erc-stamp--manage-local-options-state)))
942 (erc-buffer-list))) 954 (erc-buffer-list)))
943 955
944(defvar-local erc-stamp--last-stamp nil) 956(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."
135 "Running scripts at startup and with /LOAD." 135 "Running scripts at startup and with /LOAD."
136 :group 'erc) 136 :group 'erc)
137 137
138;; Add `custom-loads' features for group symbols missing from a
139;; supported Emacs version, possibly because they belong to a new ERC
140;; library. These groups all share their library's feature name.
141;;;###autoload(dolist (symbol '( erc-sasl erc-spelling ; 29
142;;;###autoload erc-imenu erc-nicks)) ; 30
143;;;###autoload (custom-add-load symbol symbol))
144
138(defvar erc-message-parsed) ; only known to this file 145(defvar erc-message-parsed) ; only known to this file
139 146
140(defvar erc--msg-props nil 147(defvar erc--msg-props nil
@@ -1531,7 +1538,7 @@ Bound to local variables from an existing (logical) session's
1531buffer during local-module setup and `erc-mode-hook' activation.") 1538buffer during local-module setup and `erc-mode-hook' activation.")
1532 1539
1533(defmacro erc--restore-initialize-priors (mode &rest vars) 1540(defmacro erc--restore-initialize-priors (mode &rest vars)
1534 "Restore local VARS for MODE from a previous session." 1541 "Restore local VARS for local minor MODE from a previous session."
1535 (declare (indent 1)) 1542 (declare (indent 1))
1536 (let ((priors (make-symbol "priors")) 1543 (let ((priors (make-symbol "priors"))
1537 (initp (make-symbol "initp")) 1544 (initp (make-symbol "initp"))
@@ -1541,6 +1548,8 @@ buffer during local-module setup and `erc-mode-hook' activation.")
1541 (push `(,k (if ,initp (alist-get ',k ,priors) ,(pop vars))) forms)) 1548 (push `(,k (if ,initp (alist-get ',k ,priors) ,(pop vars))) forms))
1542 `(let* ((,priors (or erc--server-reconnecting erc--target-priors)) 1549 `(let* ((,priors (or erc--server-reconnecting erc--target-priors))
1543 (,initp (and ,priors (alist-get ',mode ,priors)))) 1550 (,initp (and ,priors (alist-get ',mode ,priors))))
1551 (unless (local-variable-if-set-p ',mode)
1552 (error "Not a local minor mode var: %s" ',mode))
1544 (setq ,@(mapcan #'identity (nreverse forms)))))) 1553 (setq ,@(mapcan #'identity (nreverse forms))))))
1545 1554
1546(defun erc--target-from-string (string) 1555(defun erc--target-from-string (string)
@@ -1654,11 +1663,7 @@ If BUFFER is nil, the current buffer is used."
1654(defun erc-query-buffer-p (&optional buffer) 1663(defun erc-query-buffer-p (&optional buffer)
1655 "Return non-nil if BUFFER is an ERC query buffer. 1664 "Return non-nil if BUFFER is an ERC query buffer.
1656If BUFFER is nil, the current buffer is used." 1665If BUFFER is nil, the current buffer is used."
1657 (with-current-buffer (or buffer (current-buffer)) 1666 (not (erc-channel-p (or buffer (current-buffer)))))
1658 (let ((target (erc-target)))
1659 (and (eq major-mode 'erc-mode)
1660 target
1661 (not (memq (aref target 0) '(?# ?& ?+ ?!)))))))
1662 1667
1663(defun erc-ison-p (nick) 1668(defun erc-ison-p (nick)
1664 "Return non-nil if NICK is online." 1669 "Return non-nil if NICK is online."
@@ -1873,18 +1878,20 @@ buries those."
1873 :group 'erc-buffers 1878 :group 'erc-buffers
1874 :type 'boolean) 1879 :type 'boolean)
1875 1880
1876(defun erc-channel-p (channel) 1881(defvar erc--fallback-channel-prefixes "#&"
1877 "Return non-nil if CHANNEL seems to be an IRC channel name." 1882 "Prefix chars for distinguishing channel targets when CHANTYPES is unknown.")
1878 (cond ((stringp channel) 1883
1879 (memq (aref channel 0) 1884(defun erc-channel-p (target)
1880 (if-let ((types (erc--get-isupport-entry 'CHANTYPES 'single))) 1885 "Return non-nil if TARGET is a valid channel name or a channel buffer."
1881 (append types nil) 1886 (cond ((stringp target)
1882 '(?# ?& ?+ ?!)))) 1887 (and-let*
1883 ((and-let* (((bufferp channel)) 1888 (((not (string-empty-p target)))
1884 ((buffer-live-p channel)) 1889 (value (let ((entry (erc--get-isupport-entry 'CHANTYPES)))
1885 (target (buffer-local-value 'erc--target channel))) 1890 (if entry (cadr entry) erc--fallback-channel-prefixes)))
1886 (erc-channel-p (erc--target-string target)))) 1891 ((erc--strpos (aref target 0) value)))))
1887 (t nil))) 1892 ((and-let* (((buffer-live-p target))
1893 (target (buffer-local-value 'erc--target target))
1894 ((erc--target-channel-p target)))))))
1888 1895
1889;; For the sake of compatibility, a historical quirk concerning this 1896;; For the sake of compatibility, a historical quirk concerning this
1890;; option, when nil, has been preserved: all buffers are suffixed with 1897;; option, when nil, has been preserved: all buffers are suffixed with
@@ -2183,13 +2190,17 @@ buffer rather than a server buffer.")
2183 (cl-pushnew mod (if (get mod 'erc--module) built-in third-party))) 2190 (cl-pushnew mod (if (get mod 'erc--module) built-in third-party)))
2184 `(,@(sort built-in #'string-lessp) ,@(nreverse third-party)))) 2191 `(,@(sort built-in #'string-lessp) ,@(nreverse third-party))))
2185 2192
2193;;;###autoload(custom-autoload 'erc-modules "erc")
2194
2186(defcustom erc-modules '( autojoin button completion fill imenu irccontrols 2195(defcustom erc-modules '( autojoin button completion fill imenu irccontrols
2187 list match menu move-to-prompt netsplit 2196 list match menu move-to-prompt netsplit
2188 networks readonly ring stamp track) 2197 networks readonly ring stamp track)
2189 "A list of modules which ERC should enable. 2198 "Modules to enable while connecting.
2190If you set the value of this without using `customize' remember to call 2199When modifying this option in lisp code, use a Custom-friendly
2191\(erc-update-modules) after you change it. When using `customize', modules 2200facilitator, like `setopt', or call `erc-update-modules'
2192removed from the list will be disabled." 2201afterward. This ensures a consistent ordering and disables
2202removed modules. It also gives packages access to the hook
2203`erc-before-connect'."
2193 :get (lambda (sym) 2204 :get (lambda (sym)
2194 ;; replace outdated names with their newer equivalents 2205 ;; replace outdated names with their newer equivalents
2195 (erc-migrate-modules (symbol-value sym))) 2206 (erc-migrate-modules (symbol-value sym)))
@@ -2473,29 +2484,22 @@ nil."
2473 (cl-assert (= (point) (point-max))))) 2484 (cl-assert (= (point) (point-max)))))
2474 2485
2475(defun erc-open (&optional server port nick full-name 2486(defun erc-open (&optional server port nick full-name
2476 connect passwd tgt-list channel process 2487 connect passwd _tgt-list channel process
2477 client-certificate user id) 2488 client-certificate user id)
2478 "Connect to SERVER on PORT as NICK with USER and FULL-NAME. 2489 "Return a new or reinitialized server or target buffer.
2479 2490If CONNECT is non-nil, connect to SERVER and return its new or
2480If CONNECT is non-nil, connect to the server. Otherwise assume 2491reassociated buffer. Otherwise, assume PROCESS is non-nil and belongs
2481already connected and just create a separate buffer for the new 2492to an active session, and return a new or refurbished target buffer for
2482target given by CHANNEL, meaning these parameters are mutually 2493CHANNEL, which may also be a query target (the parameter name remains
2483exclusive. Note that CHANNEL may also be a query; its name has 2494for historical reasons). Pass SERVER, PORT, NICK, USER, FULL-NAME, and
2484been retained for historical reasons. 2495PASSWD to `erc-determine-parameters' for preserving as session-local
2485 2496variables. Do something similar for CLIENT-CERTIFICATE and ID, which
2486Use PASSWD as user password on the server. If TGT-LIST is 2497should be as described by `erc-tls'.
2487non-nil, use it to initialize `erc-default-recipients'. 2498
2488 2499Note that ERC ignores TGT-LIST and initializes `erc-default-recipients'
2489CLIENT-CERTIFICATE, if non-nil, should either be a list where the 2500with CHANNEL as its only member. Note also that this function has the
2490first element is the file name of the private key corresponding 2501side effect of setting the current buffer to the one it returns. Use
2491to a client certificate and the second element is the file name 2502`with-current-buffer' or `save-excursion' to nullify this effect."
2492of the client certificate itself to use when connecting over TLS,
2493or t, which means that `auth-source' will be queried for the
2494private key and the certificate.
2495
2496When non-nil, ID should be a symbol for identifying the connection.
2497
2498Returns the buffer for the given server or channel."
2499 (let* ((target (and channel (erc--target-from-string channel))) 2503 (let* ((target (and channel (erc--target-from-string channel)))
2500 (buffer (erc-get-buffer-create server port nil target id)) 2504 (buffer (erc-get-buffer-create server port nil target id))
2501 (old-buffer (current-buffer)) 2505 (old-buffer (current-buffer))
@@ -2532,7 +2536,7 @@ Returns the buffer for the given server or channel."
2532 ;; connection parameters 2536 ;; connection parameters
2533 (setq erc-server-process process) 2537 (setq erc-server-process process)
2534 ;; stack of default recipients 2538 ;; stack of default recipients
2535 (setq erc-default-recipients tgt-list) 2539 (when channel (setq erc-default-recipients (list channel)))
2536 (when target 2540 (when target
2537 (setq erc--target target 2541 (setq erc--target target
2538 erc-network (erc-network))) 2542 erc-network (erc-network)))
@@ -2768,8 +2772,9 @@ PORT, NICK, and PASSWORD, along with USER and FULL-NAME when
2768given a prefix argument. Non-interactively, expect the rarely 2772given a prefix argument. Non-interactively, expect the rarely
2769needed ID parameter, when non-nil, to be a symbol or a string for 2773needed ID parameter, when non-nil, to be a symbol or a string for
2770naming the server buffer and identifying the connection 2774naming the server buffer and identifying the connection
2771unequivocally. (See Info node `(erc) Connecting' for details 2775unequivocally. Once connected, return the server buffer. (See
2772about all mentioned parameters.) 2776Info node `(erc) Connecting' for details about all mentioned
2777parameters.)
2773 2778
2774Together with `erc-tls', this command serves as the main entry 2779Together with `erc-tls', this command serves as the main entry
2775point for ERC, the powerful, modular, and extensible IRC client. 2780point for ERC, the powerful, modular, and extensible IRC client.
@@ -3828,14 +3833,14 @@ TYPE, when non-nil, to be a symbol handled by
3828string MSG). Expect BUFFER to be among the sort accepted by the 3833string MSG). Expect BUFFER to be among the sort accepted by the
3829function `erc-display-line'. 3834function `erc-display-line'.
3830 3835
3831Expect BUFFER to be a live `erc-mode' buffer, a list of such 3836When non-nil, expect BUFFER to be a live `erc-mode' buffer, a
3832buffers, or the symbols `all' or `active'. If `all', insert 3837list of such buffers, or the symbols `all' or `active'. If
3833STRING in all buffers for the current session. If `active', 3838`all', insert STRING in all buffers for the current session. If
3834defer to the function `erc-active-buffer', which may return the 3839`active', defer to the function `erc-active-buffer', which may
3835session's server buffer if the previously active buffer has been 3840return the session's server buffer if the previously active
3836killed. If BUFFER is nil or a network process, pretend it's set 3841buffer has been killed. If BUFFER is nil or a network process,
3837to the appropriate server buffer. Otherwise, use the current 3842pretend it's set to the appropriate server buffer. Otherwise,
3838buffer. 3843use the current buffer.
3839 3844
3840When TYPE is a list of symbols, call handlers from left to right 3845When TYPE is a list of symbols, call handlers from left to right
3841without influencing how they behave when encountering existing 3846without influencing how they behave when encountering existing
@@ -3848,11 +3853,10 @@ being (erc-error-face erc-notice-face) throughout MSG when
3848`erc-notice-highlight-type' is left at its default, `all'. 3853`erc-notice-highlight-type' is left at its default, `all'.
3849 3854
3850As of ERC 5.6, assume third-party code will use this function 3855As of ERC 5.6, assume third-party code will use this function
3851instead of lower-level ones, like `erc-insert-line', when needing 3856instead of lower-level ones, like `erc-insert-line', to insert
3852ERC to process arbitrary informative messages as if they'd been 3857arbitrary informative messages as if sent by the server. That
3853sent from a server. That is, guarantee \"local\" messages, for 3858is, tell modules to treat a \"local\" message for which PARSED is
3854which PARSED is typically nil, will be subject to buttonizing, 3859nil like any other server-sent message."
3855filling, and other effects."
3856 (let* ((erc--msg-props 3860 (let* ((erc--msg-props
3857 (or erc--msg-props 3861 (or erc--msg-props
3858 (let ((table (make-hash-table)) 3862 (let ((table (make-hash-table))
@@ -4042,16 +4046,42 @@ this function from interpreting the line as a command."
4042;; Input commands handlers 4046;; Input commands handlers
4043;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4047;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4044 4048
4045(defun erc-cmd-AMSG (line) 4049(defun erc--connected-and-joined-p ()
4046 "Send LINE to all channels of the current server that you are on." 4050 (and (erc--current-buffer-joined-p)
4047 (interactive "sSend to all channels you're on: ") 4051 erc-server-connected))
4048 (setq line (erc-trim-string line)) 4052
4053(defun erc-cmd-GMSG (line)
4054 "Send LINE to all channels on all networks you are on."
4055 (setq line (string-remove-prefix " " line))
4049 (erc-with-all-buffers-of-server nil 4056 (erc-with-all-buffers-of-server nil
4050 (lambda () 4057 #'erc--connected-and-joined-p
4051 (erc-channel-p (erc-default-target))) 4058 (erc-send-message line)))
4059(put 'erc-cmd-GMSG 'do-not-parse-args t)
4060
4061(defun erc-cmd-AMSG (line)
4062 "Send LINE to all channels of the current network.
4063Interactively, prompt for the line of text to send."
4064 (interactive "sSend to all channels on this network: ")
4065 (setq line (string-remove-prefix " " line))
4066 (erc-with-all-buffers-of-server erc-server-process
4067 #'erc--connected-and-joined-p
4052 (erc-send-message line))) 4068 (erc-send-message line)))
4053(put 'erc-cmd-AMSG 'do-not-parse-args t) 4069(put 'erc-cmd-AMSG 'do-not-parse-args t)
4054 4070
4071(defun erc-cmd-GME (line)
4072 "Send LINE as an action to all channels on all networks you are on."
4073 (erc-with-all-buffers-of-server nil
4074 #'erc--connected-and-joined-p
4075 (erc-cmd-ME line)))
4076(put 'erc-cmd-GME 'do-not-parse-args t)
4077
4078(defun erc-cmd-AME (line)
4079 "Send LINE as an action to all channels on the current network."
4080 (erc-with-all-buffers-of-server erc-server-process
4081 #'erc--connected-and-joined-p
4082 (erc-cmd-ME line)))
4083(put 'erc-cmd-AME 'do-not-parse-args t)
4084
4055(defun erc-cmd-SAY (line) 4085(defun erc-cmd-SAY (line)
4056 "Send LINE to the current query or channel as a message, not a command. 4086 "Send LINE to the current query or channel as a message, not a command.
4057 4087
@@ -6810,7 +6840,7 @@ stand-in from the fallback value \"(qaohv)~&@%+\"."
6810 "Return numeric rank for CHAR or nil if unknown. 6840 "Return numeric rank for CHAR or nil if unknown.
6811For example, given letters \"qaohv\" return 1 for ?v, 2 for ?h, 6841For example, given letters \"qaohv\" return 1 for ?v, 2 for ?h,
6812and 4 for ?o, etc. If given, expect PARSED-PREFIX to be a 6842and 4 for ?o, etc. If given, expect PARSED-PREFIX to be a
6813`erc--parse-prefix' object. With FROM-PREFIX-P, expect CHAR to 6843`erc--parsed-prefix' object. With FROM-PREFIX-P, expect CHAR to
6814be a prefix instead." 6844be a prefix instead."
6815 (and-let* ((obj (or parsed-prefix (erc--parsed-prefix))) 6845 (and-let* ((obj (or parsed-prefix (erc--parsed-prefix)))
6816 (pos (erc--strpos char (if from-prefix-p 6846 (pos (erc--strpos char (if from-prefix-p
@@ -9487,6 +9517,7 @@ guarantee that the input method functions properly for the
9487purpose of typing within the ERC prompt." 9517purpose of typing within the ERC prompt."
9488 (when (and (eq major-mode 'erc-mode) 9518 (when (and (eq major-mode 'erc-mode)
9489 (fboundp 'set-text-conversion-style)) 9519 (fboundp 'set-text-conversion-style))
9520 (defvar text-conversion-style) ; avoid free variable warning on <=29
9490 (if (>= (point) (erc-beg-of-input-line)) 9521 (if (>= (point) (erc-beg-of-input-line))
9491 (unless (eq text-conversion-style 'action) 9522 (unless (eq text-conversion-style 'action)
9492 (set-text-conversion-style 'action)) 9523 (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.
590 :external "cp" 590 :external "cp"
591 :show-usage 591 :show-usage
592 :usage "[OPTION]... SOURCE DEST 592 :usage "[OPTION]... SOURCE DEST
593 or: cp [OPTION]... SOURCE... DIRECTORY 593 or: cp [OPTION]... SOURCE... DIRECTORY
594Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.") 594Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.")
595 (if archive 595 (if archive
596 (setq preserve t no-dereference t em-recursive t)) 596 (setq preserve t no-dereference t em-recursive t))
@@ -618,11 +618,11 @@ Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.")
618 :preserve-args 618 :preserve-args
619 :external "ln" 619 :external "ln"
620 :show-usage 620 :show-usage
621 :usage "[OPTION]... TARGET [LINK_NAME] 621 :usage "[OPTION]... TARGET LINK_NAME
622 or: ln [OPTION]... TARGET... DIRECTORY 622 or: ln [OPTION]... TARGET... DIRECTORY
623Create a link to the specified TARGET with optional LINK_NAME. If there is 623Create a link to the specified TARGET with LINK_NAME. If there is more
624more than one TARGET, the last argument must be a directory; create links 624than one TARGET, the last argument must be a directory; create links in
625in DIRECTORY to each TARGET. Create hard links by default, symbolic links 625DIRECTORY to each TARGET. Create hard links by default, symbolic links
626with `--symbolic'. When creating hard links, each TARGET must exist.") 626with `--symbolic'. When creating hard links, each TARGET must exist.")
627 (let ((no-dereference t)) 627 (let ((no-dereference t))
628 (eshell-mvcpln-template "ln" "linking" 628 (eshell-mvcpln-template "ln" "linking"
@@ -940,7 +940,7 @@ external command."
940 "display data only this many levels of data") 940 "display data only this many levels of data")
941 (?h "human-readable" 1024 human-readable 941 (?h "human-readable" 1024 human-readable
942 "print sizes in human readable format") 942 "print sizes in human readable format")
943 (?H "is" 1000 human-readable 943 (?H "si" 1000 human-readable
944 "likewise, but use powers of 1000 not 1024") 944 "likewise, but use powers of 1000 not 1024")
945 (?k "kilobytes" 1024 block-size 945 (?k "kilobytes" 1024 block-size
946 "like --block-size 1024") 946 "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,
285allows values to be converted to numbers where appropriate. 285allows values to be converted to numbers where appropriate.
286 286
287ARGS should be a list of lists of arguments, such as that 287ARGS should be a list of lists of arguments, such as that
288produced by `eshell-prepare-slice'. \"Adjacent\" values of 288produced by `eshell-prepare-splice'. \"Adjacent\" values of
289consecutive arguments will be passed to `eshell-concat'. For 289consecutive arguments will be passed to `eshell-concat'. For
290example, if ARGS is 290example, if ARGS is
291 291
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."
253 "Add a set of paths to PATH." 253 "Add a set of paths to PATH."
254 (eshell-eval-using-options 254 (eshell-eval-using-options
255 "addpath" args 255 "addpath" args
256 '((?b "begin" nil prepend "add path element at beginning") 256 '((?b "begin" nil prepend "add to beginning of $PATH")
257 (?h "help" nil nil "display this usage message") 257 (?h "help" nil nil "display this usage message")
258 :usage "[-b] PATH 258 :usage "[-b] DIR...
259Adds the given PATH to $PATH.") 259Adds the given DIR to $PATH.")
260 (let ((path (eshell-get-path t))) 260 (let ((path (eshell-get-path t)))
261 (if args 261 (if args
262 (progn 262 (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'.")
290 "C-e" #'eshell-show-maximum-output 290 "C-e" #'eshell-show-maximum-output
291 "C-f" #'eshell-forward-argument 291 "C-f" #'eshell-forward-argument
292 "C-m" #'eshell-copy-old-input 292 "C-m" #'eshell-copy-old-input
293 "C-o" #'eshell-kill-output 293 "C-o" #'eshell-delete-output
294 "C-r" #'eshell-show-output 294 "C-r" #'eshell-show-output
295 "C-t" #'eshell-truncate-buffer 295 "C-t" #'eshell-truncate-buffer
296 "C-u" #'eshell-kill-input 296 "C-u" #'eshell-kill-input
@@ -832,15 +832,23 @@ This function should be in the list `eshell-output-filter-functions'."
832 eshell-last-output-start 832 eshell-last-output-start
833 eshell-last-output-end)) 833 eshell-last-output-end))
834 834
835(defun eshell-kill-output () 835(defun eshell-delete-output (&optional kill)
836 "Kill all output from interpreter since last input. 836 "Delete all output from interpreter since last input.
837Does not delete the prompt." 837If KILL is non-nil (interactively, the prefix), save the killed text in
838 (interactive) 838the kill ring.
839
840This command does not delete the prompt."
841 (interactive "P")
839 (save-excursion 842 (save-excursion
840 (goto-char (eshell-beginning-of-output)) 843 (goto-char (eshell-beginning-of-output))
841 (insert "*** output flushed ***\n") 844 (insert "*** output flushed ***\n")
845 (when kill
846 (copy-region-as-kill (point) (eshell-end-of-output)))
842 (delete-region (point) (eshell-end-of-output)))) 847 (delete-region (point) (eshell-end-of-output))))
843 848
849(define-obsolete-function-alias 'eshell-kill-output
850 #'eshell-delete-output "30.1")
851
844(defun eshell-show-output (&optional arg) 852(defun eshell-show-output (&optional arg)
845 "Display start of this batch of interpreter output at top of window. 853 "Display start of this batch of interpreter output at top of window.
846Sets mark to the value of point when this command is run. 854Sets 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.
100Lastly, any remaining arguments will be available in the locally 100Lastly, any remaining arguments will be available in the locally
101let-bound variable `args'." 101let-bound variable `args'."
102 (declare (debug (form form sexp body))) 102 (declare (debug (form form sexp body)))
103 `(let* ((temp-args 103 (let ((option-syms (eshell--get-option-symbols
104 ,(if (memq ':preserve-args (cadr options)) 104 ;; `options' is of the form (quote OPTS).
105 (list 'copy-tree macro-args) 105 (cadr options))))
106 (list 'eshell-stringify-list 106 `(let* ((temp-args
107 (list 'flatten-tree macro-args)))) 107 ,(if (memq ':preserve-args (cadr options))
108 (processed-args (eshell--do-opts ,name ,options temp-args ,macro-args)) 108 (list 'copy-tree macro-args)
109 ,@(delete-dups 109 (list 'eshell-stringify-list
110 (delq nil (mapcar (lambda (opt) 110 (list 'flatten-tree macro-args))))
111 (and (listp opt) (nth 3 opt) 111 (args (eshell--do-opts ,name temp-args ,macro-args
112 `(,(nth 3 opt) (pop processed-args)))) 112 ,options ',option-syms))
113 ;; `options' is of the form (quote OPTS). 113 ;; Bind all the option variables. When done, `args' will
114 (cadr options)))) 114 ;; contain any remaining positional arguments.
115 (args processed-args)) 115 ,@(mapcar (lambda (sym) `(,sym (pop args))) option-syms))
116 ;; Silence unused lexical variable warning if body does not use `args'. 116 ;; Silence unused lexical variable warning if body does not use `args'.
117 (ignore args) 117 (ignore args)
118 ,@body-forms)) 118 ,@body-forms)))
119 119
120;;; Internal Functions: 120;;; Internal Functions:
121 121
122;; Documented part of the interface; see eshell-eval-using-options. 122;; Documented part of the interface; see eshell-eval-using-options.
123(defvar eshell--args) 123(defvar eshell--args)
124 124
125(defun eshell--do-opts (name options args orig-args) 125(defun eshell--get-option-symbols (options)
126 "Get a list of symbols for the specified OPTIONS.
127OPTIONS is a list of command-line options from
128`eshell-eval-using-options' (which see)."
129 (delete-dups
130 (delq nil (mapcar (lambda (opt) (and (listp opt) (nth 3 opt)))
131 options))))
132
133(defun eshell--do-opts (name args orig-args options option-syms)
126 "Helper function for `eshell-eval-using-options'. 134 "Helper function for `eshell-eval-using-options'.
127This code doesn't really need to be macro expanded everywhere." 135This code doesn't really need to be macro expanded everywhere."
128 (require 'esh-ext) 136 (require 'esh-ext)
@@ -134,7 +142,8 @@ This code doesn't really need to be macro expanded everywhere."
134 (if (and (= (length args) 0) 142 (if (and (= (length args) 0)
135 (memq ':show-usage options)) 143 (memq ':show-usage options))
136 (eshell-show-usage name options) 144 (eshell-show-usage name options)
137 (setq args (eshell--process-args name args options)) 145 (setq args (eshell--process-args name args options
146 option-syms))
138 nil)))) 147 nil))))
139 (when usage-msg 148 (when usage-msg
140 (user-error "%s" usage-msg)))))) 149 (user-error "%s" usage-msg))))))
@@ -269,16 +278,13 @@ triggered to say that the switch is unrecognized."
269 "%s: unrecognized option --%s") 278 "%s: unrecognized option --%s")
270 name (car switch))))))) 279 name (car switch)))))))
271 280
272(defun eshell--process-args (name args options) 281(defun eshell--process-args (name args options option-syms)
273 "Process the given ARGS using OPTIONS." 282 "Process the given ARGS for the command NAME using OPTIONS.
274 (let* ((seen ()) 283OPTION-SYMS is a list of symbols that will hold the processed arguments.
275 (opt-vals (delq nil (mapcar (lambda (opt) 284
276 (when (listp opt) 285Return a list of values corresponding to each element in OPTION-SYMS,
277 (let ((sym (nth 3 opt))) 286followed by any additional positional arguments."
278 (when (and sym (not (memq sym seen))) 287 (let* ((opt-vals (mapcar #'list option-syms))
279 (push sym seen)
280 (list sym)))))
281 options)))
282 (ai 0) arg 288 (ai 0) arg
283 (eshell--args args) 289 (eshell--args args)
284 (pos-argument-found nil)) 290 (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."
433 (?h "help" nil nil "show this usage screen") 433 (?h "help" nil nil "show this usage screen")
434 :external "env" 434 :external "env"
435 :parse-leading-options-only 435 :parse-leading-options-only
436 :usage "[NAME=VALUE]... [COMMAND [ARG]...]") 436 :usage "[NAME=VALUE]... [COMMAND]...")
437 (if args 437 (if args
438 (or (eshell-parse-local-variables args) 438 (or (eshell-parse-local-variables args)
439 (eshell-named-command (car args) (cdr args))) 439 (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'."
651If FACE is a face-alias, get the documentation for the target face." 651If FACE is a face-alias, get the documentation for the target face."
652 (let ((alias (get face 'face-alias))) 652 (let ((alias (get face 'face-alias)))
653 (if alias 653 (if alias
654 (let ((doc (get alias 'face-documentation))) 654 (let ((doc (documentation-property alias 'face-documentation)))
655 (format "%s is an alias for the face `%s'.%s" face alias 655 (format "%s is an alias for the face `%s'.%s" face alias
656 (if doc (format "\n%s" doc) 656 (if doc (format "\n%s" doc)
657 ""))) 657 "")))
658 (get face 'face-documentation)))) 658 (documentation-property face 'face-documentation))))
659 659
660 660
661(defun set-face-documentation (face string) 661(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,
1098the guessing would position point before punctuation (like comma) 1098the guessing would position point before punctuation (like comma)
1099after the file extension: 1099after the file extension:
1100 1100
1101 C:\temp\file.log, which contain .... 1101 C:\\temp\\file.log, which contain ....
1102 =============================== (before) 1102 =============================== (before)
1103 ---------------- (after) 1103 ---------------- (after)
1104 1104
1105 1105
1106 C:\temp\file.log on Windows or /tmp/file.log on Unix 1106 C:\\temp\\file.log on Windows or /tmp/file.log on Unix
1107 =============================== (before) 1107 =============================== (before)
1108 ---------------- (after) 1108 ---------------- (after)
1109 1109
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.
2747Finishes by calling the functions in `find-file-hook' 2747Finishes by calling the functions in `find-file-hook'
2748unless NOMODES is non-nil." 2748unless NOMODES is non-nil."
2749 (setq buffer-read-only (not (file-writable-p buffer-file-name))) 2749 (setq buffer-read-only (not (file-writable-p buffer-file-name)))
2750 ;; The above is sufficiently like turning on read-only-mode, so run
2751 ;; the mode hook here by hand.
2752 (if buffer-read-only
2753 (run-hooks 'read-only-mode-hook))
2750 (if noninteractive 2754 (if noninteractive
2751 nil 2755 nil
2752 (let* (not-serious 2756 (let* (not-serious
@@ -3270,7 +3274,16 @@ and `inhibit-local-variables-suffixes'. If
3270 ;; Optional group 1: env(1) invocation. 3274 ;; Optional group 1: env(1) invocation.
3271 "\\(" 3275 "\\("
3272 "[^ \t\n]*/bin/env[ \t]*" 3276 "[^ \t\n]*/bin/env[ \t]*"
3273 "\\(?:-S[ \t]*\\|--split-string\\(?:=\\|[ \t]*\\)\\)?" 3277 ;; Within group 1: possible -S/--split-string and environment
3278 ;; adjustments.
3279 "\\(?:"
3280 ;; -S/--split-string
3281 "\\(?:-[0a-z]*S[ \t]*\\|--split-string=\\)"
3282 ;; More env arguments.
3283 "\\(?:-[^ \t\n]+[ \t]+\\)*"
3284 ;; Interpreter environment modifications.
3285 "\\(?:[^ \t\n]+=[^ \t\n]*[ \t]+\\)*"
3286 "\\)?"
3274 "\\)?" 3287 "\\)?"
3275 ;; Group 2: interpreter. 3288 ;; Group 2: interpreter.
3276 "\\([^ \t\n]+\\)")) 3289 "\\([^ \t\n]+\\)"))
@@ -3754,7 +3767,8 @@ function is allowed to change the contents of this alist.
3754This hook is called only if there is at least one file-local 3767This hook is called only if there is at least one file-local
3755variable to set.") 3768variable to set.")
3756 3769
3757(defvar permanently-enabled-local-variables '(lexical-binding) 3770(defvar permanently-enabled-local-variables
3771 '(lexical-binding read-symbol-shorthands)
3758 "A list of file-local variables that are always enabled. 3772 "A list of file-local variables that are always enabled.
3759This overrides any `enable-local-variables' setting.") 3773This overrides any `enable-local-variables' setting.")
3760 3774
@@ -4190,6 +4204,13 @@ major-mode."
4190 ;; to use 'thisbuf's name in the 4204 ;; to use 'thisbuf's name in the
4191 ;; warning message. 4205 ;; warning message.
4192 (or (buffer-file-name thisbuf) "")))))) 4206 (or (buffer-file-name thisbuf) ""))))))
4207 ((eq var 'read-symbol-shorthands)
4208 ;; Sort automatically by shorthand length
4209 ;; in descending order.
4210 (setq val (sort val
4211 (lambda (sh1 sh2) (> (length (car sh1))
4212 (length (car sh2))))))
4213 (push (cons 'read-symbol-shorthands val) result))
4193 ((and (eq var 'mode) handle-mode)) 4214 ((and (eq var 'mode) handle-mode))
4194 (t 4215 (t
4195 (ignore-errors 4216 (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."
161(define-obsolete-function-alias 'filesets-member #'cl-member "28.1") 161(define-obsolete-function-alias 'filesets-member #'cl-member "28.1")
162(define-obsolete-function-alias 'filesets-sublist #'seq-subseq "28.1") 162(define-obsolete-function-alias 'filesets-sublist #'seq-subseq "28.1")
163 163
164(defun filesets-select-command (cmd-list)
165 "Select one command from CMD-LIST -- a string with space separated names."
166 (let ((this (shell-command-to-string
167 (format "which --skip-alias %s 2> %s | head -n 1"
168 cmd-list null-device))))
169 (if (equal this "")
170 nil
171 (file-name-nondirectory (substring this 0 (- (length this) 1))))))
172
173(defun filesets-which-command (cmd) 164(defun filesets-which-command (cmd)
174 "Call \"which CMD\"." 165 "Call \"which CMD\"."
175 (shell-command-to-string (format "which %s" cmd))) 166 (shell-command-to-string (format "which %s" (shell-quote-argument cmd))))
176 167
177(defun filesets-which-command-p (cmd) 168(defun filesets-which-command-p (cmd)
178 "Call \"which CMD\" and return non-nil if the command was found." 169 "Call \"which CMD\" and return non-nil if the command was found."
@@ -547,16 +538,6 @@ the filename."
547 538
548(defcustom filesets-external-viewers 539(defcustom filesets-external-viewers
549 (let 540 (let
550 ;; ((ps-cmd (or (and (boundp 'my-ps-viewer) my-ps-viewer)
551 ;; (filesets-select-command "ggv gv")))
552 ;; (pdf-cmd (or (and (boundp 'my-ps-viewer) my-pdf-viewer)
553 ;; (filesets-select-command "xpdf acroread")))
554 ;; (dvi-cmd (or (and (boundp 'my-ps-viewer) my-dvi-viewer)
555 ;; (filesets-select-command "xdvi tkdvi")))
556 ;; (doc-cmd (or (and (boundp 'my-ps-viewer) my-doc-viewer)
557 ;; (filesets-select-command "antiword")))
558 ;; (pic-cmd (or (and (boundp 'my-ps-viewer) my-pic-viewer)
559 ;; (filesets-select-command "gqview ee display"))))
560 ((ps-cmd "ggv") 541 ((ps-cmd "ggv")
561 (pdf-cmd "xpdf") 542 (pdf-cmd "xpdf")
562 (dvi-cmd "xdvi") 543 (dvi-cmd "xdvi")
@@ -1084,10 +1065,6 @@ Return full path if FULL-FLAG is non-nil."
1084 (t 1065 (t
1085 (error "Filesets: %s does not exist" dir)))) 1066 (error "Filesets: %s does not exist" dir))))
1086 1067
1087(defun filesets-quote (txt)
1088 "Return TXT in quotes."
1089 (concat "\"" txt "\""))
1090
1091(defun filesets-get-selection () 1068(defun filesets-get-selection ()
1092 "Get the text between mark and point -- i.e. the selection or region." 1069 "Get the text between mark and point -- i.e. the selection or region."
1093 (let ((m (mark)) 1070 (let ((m (mark))
@@ -1098,7 +1075,7 @@ Return full path if FULL-FLAG is non-nil."
1098 1075
1099(defun filesets-get-quoted-selection () 1076(defun filesets-get-quoted-selection ()
1100 "Return the currently selected text in quotes." 1077 "Return the currently selected text in quotes."
1101 (filesets-quote (filesets-get-selection))) 1078 (shell-quote-argument (filesets-get-selection)))
1102 1079
1103(defun filesets-get-shortcut (n) 1080(defun filesets-get-shortcut (n)
1104 "Create menu shortcuts based on number N." 1081 "Create menu shortcuts based on number N."
@@ -1245,12 +1222,13 @@ Use the viewer defined in EV-ENTRY (a valid element of
1245 (if fmt 1222 (if fmt
1246 (mapconcat 1223 (mapconcat
1247 (lambda (this) 1224 (lambda (this)
1248 (if (stringp this) (format this file) 1225 (if (stringp this)
1249 (format "%S" (if (functionp this) 1226 (format this (shell-quote-argument file))
1250 (funcall this) 1227 (shell-quote-argument (if (functionp this)
1251 this)))) 1228 (funcall this)
1229 this))))
1252 fmt "") 1230 fmt "")
1253 (format "%S" file)))) 1231 (shell-quote-argument file))))
1254 (output 1232 (output
1255 (cond 1233 (cond
1256 ((and (functionp vwr) co-flag) 1234 ((and (functionp vwr) co-flag)
@@ -1259,7 +1237,7 @@ Use the viewer defined in EV-ENTRY (a valid element of
1259 (funcall vwr file) 1237 (funcall vwr file)
1260 nil) 1238 nil)
1261 (co-flag 1239 (co-flag
1262 (shell-command-to-string (format "%s %s" vwr args))) 1240 (shell-command-to-string (format "%s %s" vwr args)))
1263 (t 1241 (t
1264 (shell-command (format "%s %s&" vwr args)) 1242 (shell-command (format "%s %s&" vwr args))
1265 nil)))) 1243 nil))))
@@ -2483,11 +2461,15 @@ Set up hooks, load the cache file -- if existing -- and build the menu."
2483 (setq filesets-menu-use-cached-flag t))) 2461 (setq filesets-menu-use-cached-flag t)))
2484 (filesets-build-menu))) 2462 (filesets-build-menu)))
2485 2463
2464;;; obsolete
2465
2486(defun filesets-error (_class &rest args) 2466(defun filesets-error (_class &rest args)
2487 "`error' wrapper." 2467 "`error' wrapper."
2488 (declare (obsolete error "28.1")) 2468 (declare (obsolete error "28.1"))
2489 (error "%s" (mapconcat #'identity args " "))) 2469 (error "%s" (mapconcat #'identity args " ")))
2490 2470
2471(define-obsolete-function-alias 'filesets-quote #'shell-quote-argument "30.1")
2472
2491(provide 'filesets) 2473(provide 'filesets)
2492 2474
2493;;; filesets.el ends here 2475;;; 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.")
343 343
344(defvar forms-write-file-filter nil 344(defvar forms-write-file-filter nil
345 "The name of a function that is called before writing the data file. 345 "The name of a function that is called before writing the data file.
346This can be used to undo the effects of `form-read-file-filter'.") 346This can be used to undo the effects of `forms-read-file-filter'.")
347 347
348(defvar forms-new-record-filter nil 348(defvar forms-new-record-filter nil
349 "The name of a function that is called when a new record is created.") 349 "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:
2910 (car func) 2910 (car func)
2911 (gnus-byte-compile `(lambda () ,func))))) 2911 (gnus-byte-compile `(lambda () ,func)))))
2912 2912
2913(defun gnus-agent-true () 2913(defalias 'gnus-agent-true #'always)
2914 "Return t."
2915 t)
2916 2914
2917(defun gnus-agent-false () 2915(defalias 'gnus-agent-false #'ignore)
2918 "Return nil."
2919 nil)
2920 2916
2921(defun gnus-category-make-function-1 (predicate) 2917(defun gnus-category-make-function-1 (predicate)
2922 "Make a function from PREDICATE." 2918 "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."
694 694
695(defcustom gnus-page-delimiter "^\^L" 695(defcustom gnus-page-delimiter "^\^L"
696 "Regexp describing what to use as article page delimiters. 696 "Regexp describing what to use as article page delimiters.
697The default value is \"^\^L\", which is a form linefeed at the 697The default value is \"^\\^L\", which is a form linefeed at the
698beginning of a line." 698beginning of a line."
699 :type 'regexp 699 :type 'regexp
700 :group 'gnus-article-various) 700 :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."
111 111
112(autoload 'gnus-completing-read "gnus-util") 112(autoload 'gnus-completing-read "gnus-util")
113 113
114(defcustom gnus-dired-attach-at-end t
115 "Non-nil means that files should be attached at the end of a buffer."
116 :group 'mail ;; dired?
117 :version "30.1"
118 :type 'boolean)
119
114;; Method to attach files to a mail composition. 120;; Method to attach files to a mail composition.
115(defun gnus-dired-attach (files-to-attach) 121(defun gnus-dired-attach (files-to-attach)
116 "Attach dired's marked files to a gnus message composition. 122 "Attach dired's marked files to a gnus message composition.
@@ -161,7 +167,8 @@ filenames."
161 167
162 ;; set buffer to destination buffer, and attach files 168 ;; set buffer to destination buffer, and attach files
163 (set-buffer destination) 169 (set-buffer destination)
164 (goto-char (point-max)) ;attach at end of buffer 170 (when gnus-dired-attach-at-end
171 (goto-char (point-max))) ;attach at end of buffer
165 (while files-to-attach 172 (while files-to-attach
166 (mml-attach-file (car files-to-attach) 173 (mml-attach-file (car files-to-attach)
167 (or (mm-default-file-type (car files-to-attach)) 174 (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.
1189The reply will include all From/Cc headers from the original 1189The reply will include all From/Cc headers from the original
1190messages as the To/Cc headers. 1190messages as the To/Cc headers.
1191 1191
1192If prefix argument YANK is non-nil, the original article(s) will 1192If prefix argument YANK is non-nil, the original article will
1193be yanked automatically." 1193be yanked automatically."
1194 (interactive (list (and current-prefix-arg 1194 (interactive (list (and current-prefix-arg
1195 (gnus-summary-work-articles 1))) 1195 (gnus-summary-work-articles 1)))
1196 gnus-summary-mode) 1196 gnus-summary-mode)
1197 (gnus-summary-reply yank t (gnus-summary-work-articles yank))) 1197 (gnus-summary-reply yank t (gnus-summary-work-articles current-prefix-arg)))
1198 1198
1199(defun gnus-summary-very-wide-reply-with-original (n) 1199(defun gnus-summary-very-wide-reply-with-original (n)
1200 "Start composing a very wide reply mail a set of messages. 1200 "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."
893 (t "permanent")) 893 (t "permanent"))
894 header 894 header
895 (if (< score 0) "lower" "raise")) 895 (if (< score 0) "lower" "raise"))
896 (if (numberp match) 896 (cond ((numberp match) (int-to-string match))
897 (int-to-string match) 897 ((string= header "date")
898 match)))) 898 (int-to-string
899 (-
900 (/ (car (time-convert (current-time) 1)) 86400)
901 (/ (car (time-convert (gnus-date-get-time match) 1))
902 86400))))
903 (t match)))))
899 904
900 ;; If this is an integer comparison, we transform from string to int. 905 ;; If this is an integer comparison, we transform from string to int.
901 (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) 906 (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'."
1113 (setq gnus-info-buffer (current-buffer)) 1113 (setq gnus-info-buffer (current-buffer))
1114 (gnus-configure-windows 'info))) 1114 (gnus-configure-windows 'info)))
1115 1115
1116(defun gnus-not-ignore (&rest _args) 1116(defalias 'gnus-not-ignore #'always)
1117 t)
1118 1117
1119(defvar gnus-directory-sep-char-regexp "/" 1118(defvar gnus-directory-sep-char-regexp "/"
1120 "The regexp of directory separator character. 1119 "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."
309 :group 'gnus-start 309 :group 'gnus-start
310 :type 'boolean) 310 :type 'boolean)
311 311
312(defcustom gnus-mode-line-logo
313 '((:type svg :file "gnus-pointer.svg" :ascent center)
314 (:type xpm :file "gnus-pointer.xpm" :ascent center)
315 (:type xbm :file "gnus-pointer.xbm" :ascent center))
316 "Image spec for the Gnus logo to be displayed in mode-line.
317
318If non-nil, it should be a list of image specifications to be passed
319as the first argument to `find-image', which see. Then, if the display
320is capable of showing images, the Gnus logo will be displayed as part of
321the buffer-identification in the mode-line of Gnus-buffers.
322
323If nil, there will be no Gnus logo in the mode-line."
324 :group 'gnus-visual
325 :type '(choice
326 (repeat :tag "List of Gnus logo image specifications" (plist))
327 (const :tag "Don't display Gnus logo" nil))
328 :version "30.1")
329
312(defun gnus-mode-line-buffer-identification (line) 330(defun gnus-mode-line-buffer-identification (line)
313 (let* ((str (car-safe line)) 331 (let* ((str (car-safe line))
314 (str (if (stringp str) 332 (str (if (stringp str)
315 (car (propertized-buffer-identification str)) 333 (car (propertized-buffer-identification str))
316 str))) 334 str)))
317 (if (or (not (fboundp 'find-image)) 335 (if (or (not gnus-mode-line-logo)
336 (not (fboundp 'find-image))
318 (not (display-graphic-p)) 337 (not (display-graphic-p))
319 (not (stringp str)) 338 (not (stringp str))
320 (not (string-match "^Gnus:" str))) 339 (not (string-match "^Gnus:" str)))
@@ -325,14 +344,7 @@ be set in `.emacs' instead."
325 (add-text-properties 344 (add-text-properties
326 0 5 345 0 5
327 (list 'display 346 (list 'display
328 (find-image 347 (find-image gnus-mode-line-logo t)
329 '((:type svg :file "gnus-pointer.svg"
330 :ascent center)
331 (:type xpm :file "gnus-pointer.xpm"
332 :ascent center)
333 (:type xbm :file "gnus-pointer.xbm"
334 :ascent center))
335 t)
336 'help-echo (if gnus-emacs-version 348 'help-echo (if gnus-emacs-version
337 (format 349 (format
338 "This is %s, %s." 350 "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."
1016 (nnheader-skeleton-replace from to t)) 1016 (nnheader-skeleton-replace from to t))
1017 1017
1018(defun nnheader-strip-cr () 1018(defun nnheader-strip-cr ()
1019 "Strip all \r's from the current buffer." 1019 "Strip all \\r's from the current buffer."
1020 (nnheader-skeleton-replace "\r")) 1020 (nnheader-skeleton-replace "\r"))
1021 1021
1022(define-obsolete-function-alias 'nnheader-cancel-timer 'cancel-timer "27.1") 1022(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."
1799 alias) 1799 alias)
1800 "")))) 1800 ""))))
1801 (insert "\nDocumentation:\n" 1801 (insert "\nDocumentation:\n"
1802 (substitute-command-keys 1802 (or (face-documentation face)
1803 (or (face-documentation face) 1803 "Not documented as a face.")
1804 "Not documented as a face."))
1805 "\n\n")) 1804 "\n\n"))
1806 (with-current-buffer standard-output 1805 (with-current-buffer standard-output
1807 (save-excursion 1806 (save-excursion
@@ -2134,6 +2133,12 @@ keymap value."
2134 (when used-gentemp 2133 (when used-gentemp
2135 (makunbound keymap)))) 2134 (makunbound keymap))))
2136 2135
2136(defcustom describe-mode-outline t
2137 "Non-nil enables outlines in the output buffer of `describe-mode'."
2138 :type 'boolean
2139 :group 'help
2140 :version "30.1")
2141
2137;;;###autoload 2142;;;###autoload
2138(defun describe-mode (&optional buffer) 2143(defun describe-mode (&optional buffer)
2139 "Display documentation of current major mode and minor modes. 2144 "Display documentation of current major mode and minor modes.
@@ -2146,7 +2151,10 @@ variable \(listed in `minor-mode-alist') must also be a function
2146whose documentation describes the minor mode. 2151whose documentation describes the minor mode.
2147 2152
2148If called from Lisp with a non-nil BUFFER argument, display 2153If called from Lisp with a non-nil BUFFER argument, display
2149documentation for the major and minor modes of that buffer." 2154documentation for the major and minor modes of that buffer.
2155
2156When `describe-mode-outline' is non-nil, Outline minor mode
2157is enabled in the Help buffer."
2150 (interactive "@") 2158 (interactive "@")
2151 (unless buffer 2159 (unless buffer
2152 (setq buffer (current-buffer))) 2160 (setq buffer (current-buffer)))
@@ -2160,13 +2168,20 @@ documentation for the major and minor modes of that buffer."
2160 (with-current-buffer (help-buffer) 2168 (with-current-buffer (help-buffer)
2161 ;; Add the local minor modes at the start. 2169 ;; Add the local minor modes at the start.
2162 (when local-minors 2170 (when local-minors
2163 (insert (format "Minor mode%s enabled in this buffer:" 2171 (unless describe-mode-outline
2164 (if (length> local-minors 1) 2172 (insert (format "Minor mode%s enabled in this buffer:"
2165 "s" ""))) 2173 (if (length> local-minors 1)
2174 "s" ""))))
2166 (describe-mode--minor-modes local-minors)) 2175 (describe-mode--minor-modes local-minors))
2167 2176
2168 ;; Document the major mode. 2177 ;; Document the major mode.
2169 (let ((major (buffer-local-value 'major-mode buffer))) 2178 (let ((major (buffer-local-value 'major-mode buffer)))
2179 (when describe-mode-outline
2180 (goto-char (point-min))
2181 (put-text-property
2182 (point) (progn (insert (format "Major mode %S" major)) (point))
2183 'outline-level 1)
2184 (insert "\n\n"))
2170 (insert "The major mode is " 2185 (insert "The major mode is "
2171 (buttonize 2186 (buttonize
2172 (propertize (format-mode-line 2187 (propertize (format-mode-line
@@ -2190,36 +2205,56 @@ documentation for the major and minor modes of that buffer."
2190 2205
2191 ;; Insert the global minor modes after the major mode. 2206 ;; Insert the global minor modes after the major mode.
2192 (when global-minor-modes 2207 (when global-minor-modes
2193 (insert (format "Global minor mode%s enabled:" 2208 (unless describe-mode-outline
2194 (if (length> global-minor-modes 1) 2209 (insert (format "Global minor mode%s enabled:"
2195 "s" ""))) 2210 (if (length> global-minor-modes 1)
2196 (describe-mode--minor-modes global-minor-modes) 2211 "s" ""))))
2197 (when (re-search-forward "^\f") 2212 (describe-mode--minor-modes global-minor-modes t)
2198 (beginning-of-line) 2213 (unless describe-mode-outline
2199 (ensure-empty-lines 1))) 2214 (when (re-search-forward "^\f")
2215 (beginning-of-line)
2216 (ensure-empty-lines 1))))
2217
2218 (when describe-mode-outline
2219 (setq-local outline-search-function #'outline-search-level)
2220 (setq-local outline-level (lambda () 1))
2221 (setq-local outline-minor-mode-cycle t
2222 outline-minor-mode-highlight t
2223 outline-minor-mode-use-buttons 'insert)
2224 (outline-minor-mode 1))
2225
2200 ;; For the sake of IELM and maybe others 2226 ;; For the sake of IELM and maybe others
2201 nil))))) 2227 nil)))))
2202 2228
2203(defun describe-mode--minor-modes (modes) 2229(defun describe-mode--minor-modes (modes &optional global)
2204 (dolist (mode (seq-sort #'string< modes)) 2230 (dolist (mode (seq-sort #'string< modes))
2205 (let ((pretty-minor-mode 2231 (let ((pretty-minor-mode
2206 (capitalize 2232 (capitalize
2207 (replace-regexp-in-string 2233 (replace-regexp-in-string
2208 "\\(\\(-minor\\)?-mode\\)?\\'" "" 2234 "\\(\\(-minor\\)?-mode\\)?\\'" ""
2209 (symbol-name mode))))) 2235 (symbol-name mode)))))
2210 (insert 2236 (if (not describe-mode-outline)
2211 " " 2237 (insert
2212 (buttonize 2238 " "
2213 pretty-minor-mode 2239 (buttonize
2214 (lambda (mode) 2240 pretty-minor-mode
2215 (goto-char (point-min)) 2241 (lambda (mode)
2216 (text-property-search-forward 2242 (goto-char (point-min))
2217 'help-minor-mode mode t) 2243 (text-property-search-forward
2218 (beginning-of-line)) 2244 'help-minor-mode mode t)
2219 mode)) 2245 (beginning-of-line))
2246 mode))
2247 (goto-char (point-max))
2248 (put-text-property
2249 (point) (progn (insert (if global "Global" "Local")
2250 (format " minor mode %S" mode))
2251 (point))
2252 'outline-level 1)
2253 (insert "\n\n"))
2220 (save-excursion 2254 (save-excursion
2221 (goto-char (point-max)) 2255 (unless describe-mode-outline
2222 (insert "\n\n\f\n") 2256 (goto-char (point-max))
2257 (insert "\n\n\f\n"))
2223 ;; Document the minor modes fully. 2258 ;; Document the minor modes fully.
2224 (insert (buttonize 2259 (insert (buttonize
2225 (propertize pretty-minor-mode 'help-minor-mode mode) 2260 (propertize pretty-minor-mode 'help-minor-mode mode)
@@ -2233,11 +2268,14 @@ documentation for the major and minor modes of that buffer."
2233 (format "indicator%s" 2268 (format "indicator%s"
2234 indicator))))) 2269 indicator)))))
2235 (insert (or (help-split-fundoc (documentation mode) nil 'doc) 2270 (insert (or (help-split-fundoc (documentation mode) nil 'doc)
2236 "No docstring"))))) 2271 "No docstring"))
2237 (forward-line -1) 2272 (when describe-mode-outline
2238 (fill-paragraph nil) 2273 (insert "\n\n")))))
2239 (forward-paragraph 1) 2274 (unless describe-mode-outline
2240 (ensure-empty-lines 1)) 2275 (forward-line -1)
2276 (fill-paragraph nil)
2277 (forward-paragraph 1)
2278 (ensure-empty-lines 1)))
2241 2279
2242(defun help-fns--list-local-commands () 2280(defun help-fns--list-local-commands ()
2243 (let ((functions nil)) 2281 (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."
501 ;; Disable `outline-minor-mode' in a reused Help buffer 501 ;; Disable `outline-minor-mode' in a reused Help buffer
502 ;; created by `describe-bindings' that enables this mode. 502 ;; created by `describe-bindings' that enables this mode.
503 (when (bound-and-true-p outline-minor-mode) 503 (when (bound-and-true-p outline-minor-mode)
504 (outline-minor-mode -1)) 504 (outline-minor-mode -1)
505 (mapc #'kill-local-variable
506 '(outline-search-function
507 outline-regexp
508 outline-heading-end-regexp
509 outline-level
510 outline-minor-mode-cycle
511 outline-minor-mode-highlight
512 outline-minor-mode-use-buttons
513 outline-default-state
514 outline-default-rules)))
505 (when help-xref-stack-item 515 (when help-xref-stack-item
506 (push (cons (point) help-xref-stack-item) help-xref-stack) 516 (push (cons (point) help-xref-stack-item) help-xref-stack)
507 (setq help-xref-forward-stack nil)) 517 (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.")
151 ("Mark & Kill" 151 ("Mark & Kill"
152 (set-mark-command . "mark") 152 (set-mark-command . "mark")
153 (kill-line . "kill line") 153 (kill-line . "kill line")
154 (kill-ring-save . "kill region") 154 (kill-region . "kill region")
155 (yank . "yank") 155 (yank . "yank")
156 (exchange-point-and-mark . "swap")) 156 (exchange-point-and-mark . "swap"))
157 ("Projects" 157 ("Projects"
@@ -165,7 +165,15 @@ buffer.")
165 (isearch-forward . "search") 165 (isearch-forward . "search")
166 (isearch-backward . "reverse search") 166 (isearch-backward . "reverse search")
167 (query-replace . "search & replace") 167 (query-replace . "search & replace")
168 (fill-paragraph . "reformat")))) 168 (fill-paragraph . "reformat")))
169 "Data structure for `help-quick'.
170Value should be a list of elements, each element should of the form
171
172 (GROUP-NAME (COMMAND . DESCRIPTION) (COMMAND . DESCRIPTION)...)
173
174where GROUP-NAME is the name of the group of the commands,
175COMMAND is the symbol of a command and DESCRIPTION is its short
176description, 10 to 15 char5acters at most.")
169 177
170(declare-function prop-match-value "text-property-search" (match)) 178(declare-function prop-match-value "text-property-search" (match))
171 179
@@ -2253,6 +2261,27 @@ The `temp-buffer-window-setup-hook' hook is called."
2253 (with-output-to-temp-buffer " *Char Help*" 2261 (with-output-to-temp-buffer " *Char Help*"
2254 (princ msg))))) 2262 (princ msg)))))
2255 2263
2264(defun help--append-keystrokes-help (str)
2265 (let* ((keys (this-single-command-keys))
2266 (bindings (delete nil
2267 (mapcar (lambda (map) (lookup-key map keys t))
2268 (current-active-maps t)))))
2269 (catch 'res
2270 (dolist (val help-event-list)
2271 (let ((key (vector (if (eql val 'help)
2272 help-char
2273 val))))
2274 (unless (seq-find (lambda (map) (and (keymapp map) (lookup-key map key)))
2275 bindings)
2276 (throw 'res
2277 (concat
2278 str
2279 (substitute-command-keys
2280 (format
2281 " (\\`%s' for help)"
2282 (key-description key))))))))
2283 str)))
2284
2256 2285
2257(defun help--docstring-quote (string) 2286(defun help--docstring-quote (string)
2258 "Return a doc string that represents STRING. 2287 "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
110such as `edebug-defun' to work with such inputs." 110such as `edebug-defun' to work with such inputs."
111 :type 'boolean) 111 :type 'boolean)
112 112
113(defcustom ielm-history-file-name
114 (locate-user-emacs-file "ielm-history.eld")
115 "If non-nil, name of the file to read/write IELM input history."
116 :type '(choice (const :tag "Disable input history" nil)
117 file)
118 :version "30.1")
119
113(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook) 120(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook)
114(defcustom ielm-mode-hook nil 121(defcustom ielm-mode-hook nil
115 "Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started." 122 "Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started."
@@ -503,6 +510,17 @@ behavior of the indirect buffer."
503 (funcall pp-default-function beg end) 510 (funcall pp-default-function beg end)
504 end)) 511 end))
505 512
513;;; Input history
514
515(defvar ielm--exit nil
516 "Function to call when Emacs is killed.")
517
518(defun ielm--input-history-writer (buf)
519 "Return a function writing IELM input history to BUF."
520 (lambda ()
521 (with-current-buffer buf
522 (comint-write-input-ring))))
523
506;;; Major mode 524;;; Major mode
507 525
508(define-derived-mode inferior-emacs-lisp-mode comint-mode "IELM" 526(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:
605 #'ielm-indirect-setup-hook 'append t) 623 #'ielm-indirect-setup-hook 'append t)
606 (setq comint-indirect-setup-function #'emacs-lisp-mode) 624 (setq comint-indirect-setup-function #'emacs-lisp-mode)
607 625
626 ;; Input history
627 (setq-local comint-input-ring-file-name ielm-history-file-name)
628 (setq-local ielm--exit (ielm--input-history-writer (current-buffer)))
629 (setq-local kill-buffer-hook
630 (lambda ()
631 (funcall ielm--exit)
632 (remove-hook 'kill-emacs-hook ielm--exit)))
633 (unless noninteractive
634 (add-hook 'kill-emacs-hook ielm--exit))
635 (comint-read-input-ring t)
636
608 ;; A dummy process to keep comint happy. It will never get any input 637 ;; A dummy process to keep comint happy. It will never get any input
609 (unless (comint-check-proc (current-buffer)) 638 (unless (comint-check-proc (current-buffer))
610 ;; Was cat, but on non-Unix platforms that might not exist, so 639 ;; 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."
759 759
760;;;###autoload 760;;;###autoload
761(defun find-image (specs &optional cache) 761(defun find-image (specs &optional cache)
762 "Find an image, choosing one of a list of image specifications. 762 "Find an image that satisfies one of a list of image specifications.
763 763
764SPECS is a list of image specifications. 764SPECS is a list of image specifications.
765 765
766Each image specification in SPECS is a property list. The contents of 766Each image specification in SPECS is a property list. The
767a specification are image type dependent. All specifications must at 767contents of a specification are image type dependent; see the
768least contain either the property `:file FILE' or `:data DATA', 768info node `(elisp)Image Descriptors' for details. All specifications
769where FILE is the file to load the image from, and DATA is a string 769must at least contain either the property `:file FILE' or `:data DATA',
770containing the actual image data. If the property `:type TYPE' is 770where FILE is the file from which to load the image, and DATA is a
771omitted or nil, try to determine the image type from its first few 771string containing the actual image data. If the property `:type TYPE'
772is omitted or nil, try to determine the image type from its first few
772bytes of image data. If that doesn't work, and the property `:file 773bytes of image data. If that doesn't work, and the property `:file
773FILE' provide a file name, use its file extension as image type. 774FILE' provide a file name, use its file extension as idication of the
774If `:type TYPE' is provided, it must match the actual type 775image type. If `:type TYPE' is provided, it must match the actual type
775determined for FILE or DATA by `create-image'. Return nil if no 776determined for FILE or DATA by `create-image'.
776specification is satisfied. 777
778The function returns the image specification for the first specification
779in the list whose TYPE is supported and FILE, if specified, exists. It
780returns nil if no specification in the list can be satisfied.
777 781
778If CACHE is non-nil, results are cached and returned on subsequent calls. 782If CACHE is non-nil, results are cached and returned on subsequent calls.
779 783
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).
231MANUALs represents the name of one or more manuals. It can 231MANUALs represents the name of one or more manuals. It can
232either be a string or a list of strings. URL-SPEC can be a 232either be a string or a list of strings. URL-SPEC can be a
233string in which the substring \"%m\" will be expanded to the 233string in which the substring \"%m\" will be expanded to the
234manual-name, \"%n\" to the node-name, and \"%e\" to the 234manual-name and \"%n\" to the node-name. \"%e\" will expand to
235URL-encoded node-name (without a `.html' suffix). (The 235the URL-encoded node-name, including the `.html' extension; in
236case of the Top node, it will expand to the empty string. (The
236URL-encoding of the node-name mimics GNU Texinfo, as documented 237URL-encoding of the node-name mimics GNU Texinfo, as documented
237at Info node `(texinfo)HTML Xref Node Name Expansion'.) 238at Info node `(texinfo)HTML Xref Node Name Expansion'.)
238Alternatively, URL-SPEC can be a function which is given 239Alternatively, URL-SPEC can be a function which is given
@@ -499,6 +500,7 @@ or `Info-virtual-nodes'."
499 (".info.bz2" . ("bzip2" "-dc")) 500 (".info.bz2" . ("bzip2" "-dc"))
500 (".info.xz" . "unxz") 501 (".info.xz" . "unxz")
501 (".info.zst" . ("zstd" "-dc")) 502 (".info.zst" . ("zstd" "-dc"))
503 (".info.lz" . ("lzip" "-dc"))
502 (".info" . nil) 504 (".info" . nil)
503 ("-info.Z" . "uncompress") 505 ("-info.Z" . "uncompress")
504 ("-info.Y" . "unyabba") 506 ("-info.Y" . "unyabba")
@@ -507,6 +509,7 @@ or `Info-virtual-nodes'."
507 ("-info.z" . "gunzip") 509 ("-info.z" . "gunzip")
508 ("-info.xz" . "unxz") 510 ("-info.xz" . "unxz")
509 ("-info.zst" . ("zstd" "-dc")) 511 ("-info.zst" . ("zstd" "-dc"))
512 ("-info.lz" . ("lzip" "-dc"))
510 ("-info" . nil) 513 ("-info" . nil)
511 ("/index.Z" . "uncompress") 514 ("/index.Z" . "uncompress")
512 ("/index.Y" . "unyabba") 515 ("/index.Y" . "unyabba")
@@ -515,6 +518,7 @@ or `Info-virtual-nodes'."
515 ("/index.bz2" . ("bzip2" "-dc")) 518 ("/index.bz2" . ("bzip2" "-dc"))
516 ("/index.xz" . "unxz") 519 ("/index.xz" . "unxz")
517 ("/index.zst" . ("zstd" "-dc")) 520 ("/index.zst" . ("zstd" "-dc"))
521 ("/index.lz" . ("lzip" "-dc"))
518 ("/index" . nil) 522 ("/index" . nil)
519 (".Z" . "uncompress") 523 (".Z" . "uncompress")
520 (".Y" . "unyabba") 524 (".Y" . "unyabba")
@@ -523,6 +527,7 @@ or `Info-virtual-nodes'."
523 (".bz2" . ("bzip2" "-dc")) 527 (".bz2" . ("bzip2" "-dc"))
524 (".xz" . "unxz") 528 (".xz" . "unxz")
525 (".zst" . ("zstd" "-dc")) 529 (".zst" . ("zstd" "-dc"))
530 (".lz" . ("lzip" "-dc"))
526 ("" . nil))) 531 ("" . nil)))
527 "List of file name suffixes and associated decoding commands. 532 "List of file name suffixes and associated decoding commands.
528Each entry should be (SUFFIX . STRING); the file is given to 533Each entry should be (SUFFIX . STRING); the file is given to
@@ -1924,18 +1929,20 @@ NODE should be a string of the form \"(manual)Node\"."
1924 ;; (info "(texinfo) HTML Xref Node Name Expansion") 1929 ;; (info "(texinfo) HTML Xref Node Name Expansion")
1925 (if (equal node "Top") 1930 (if (equal node "Top")
1926 "" 1931 ""
1927 (url-hexify-string 1932 (concat
1928 (string-replace " " "-" 1933 (url-hexify-string
1929 (mapconcat 1934 (string-replace " " "-"
1930 (lambda (ch) 1935 (mapconcat
1931 (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^- 1936 (lambda (ch)
1932 (<= 33 ch 47) ; !"#$%&'()*+,-./ 1937 (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^-
1933 (<= 58 ch 64) ; :;<=>?@ 1938 (<= 33 ch 47) ; !"#$%&'()*+,-./
1934 (<= 91 ch 96) ; [\]_` 1939 (<= 58 ch 64) ; :;<=>?@
1935 (<= 123 ch 127)) ; {|}~ DEL 1940 (<= 91 ch 96) ; [\]_`
1936 (format "_00%x" ch) 1941 (<= 123 ch 127)) ; {|}~ DEL
1937 (char-to-string ch))) 1942 (format "_00%x" ch)
1938 node "")))))) 1943 (char-to-string ch)))
1944 node "")))
1945 ".html"))))
1939 (cond 1946 (cond
1940 ((stringp url-spec) 1947 ((stringp url-spec)
1941 (format-spec url-spec 1948 (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 @@
31;; Convert cxterm dictionary (of TIT format) to quail-package. 31;; Convert cxterm dictionary (of TIT format) to quail-package.
32;; 32;;
33;; Usage (within Emacs): 33;; Usage (within Emacs):
34;; M-x titdic-convert<CR>CXTERM-DICTIONARY-NAME<CR> 34;; M-x tit-dic-convert<CR>CXTERM-DICTIONARY-NAME<CR>
35;; Usage (from shell): 35;; Usage (from shell):
36;; % emacs -batch -l titdic-cnv -f batch-titdic-convert\ 36;; % emacs -batch -l titdic-cnv -f batch-tit-dic-convert\
37;; [-dir DIR] [DIR | FILE] ... 37;; [-dir DIR] [DIR | FILE] ...
38;; 38;;
39;; When you run titdic-convert within Emacs, you have a chance to 39;; When you run `tit-dic-convert' within Emacs, you have a chance to
40;; modify arguments of `quail-define-package' before saving the 40;; modify arguments of `quail-define-package' before saving the
41;; converted file. For instance, you are likely to modify TITLE, 41;; converted file. For instance, you are likely to modify TITLE,
42;; DOCSTRING, and KEY-BINDINGS. 42;; DOCSTRING, and KEY-BINDINGS.
@@ -90,7 +90,8 @@
90;; \<quail-translation-docstring> is replaced by a description about 90;; \<quail-translation-docstring> is replaced by a description about
91;; how to select a translation from a list of candidates. 91;; how to select a translation from a list of candidates.
92 92
93(defvar quail-cxterm-package-ext-info 93(define-obsolete-variable-alias 'quail-cxterm-package-ext-info 'tit-quail-cxterm-package-ext-info "30.1")
94(defvar tit-quail-cxterm-package-ext-info
94 '(("chinese-4corner" "四角") 95 '(("chinese-4corner" "四角")
95 ("chinese-array30" "30") 96 ("chinese-array30" "30")
96 ("chinese-ccdospy" "缩拼" 97 ("chinese-ccdospy" "缩拼"
@@ -277,7 +278,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
277 (tit-moveleft ",<") 278 (tit-moveleft ",<")
278 (tit-keyprompt nil)) 279 (tit-keyprompt nil))
279 280
280 (generate-lisp-file-heading filename 'titdic-convert :code nil) 281 (generate-lisp-file-heading filename 'tit-dic-convert :code nil)
281 (princ ";; Quail package `") 282 (princ ";; Quail package `")
282 (princ package) 283 (princ package)
283 (princ "\n") 284 (princ "\n")
@@ -354,7 +355,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
354 355
355 (princ "(quail-define-package ") 356 (princ "(quail-define-package ")
356 ;; Args NAME, LANGUAGE, TITLE 357 ;; Args NAME, LANGUAGE, TITLE
357 (let ((title (nth 1 (assoc package quail-cxterm-package-ext-info)))) 358 (let ((title (nth 1 (assoc package tit-quail-cxterm-package-ext-info))))
358 (princ "\"") 359 (princ "\"")
359 (princ package) 360 (princ package)
360 (princ "\" \"") 361 (princ "\" \"")
@@ -383,7 +384,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
383 (let ((doc (concat tit-prompt "\n")) 384 (let ((doc (concat tit-prompt "\n"))
384 (comments (if tit-comments 385 (comments (if tit-comments
385 (mapconcat #'identity (nreverse tit-comments) "\n"))) 386 (mapconcat #'identity (nreverse tit-comments) "\n")))
386 (doc-ext (nth 2 (assoc package quail-cxterm-package-ext-info)))) 387 (doc-ext (nth 2 (assoc package tit-quail-cxterm-package-ext-info))))
387 (if comments 388 (if comments
388 (setq doc (concat doc "\n" comments "\n"))) 389 (setq doc (concat doc "\n" comments "\n")))
389 (if doc-ext 390 (if doc-ext
@@ -476,6 +477,9 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
476 477
477;;;###autoload 478;;;###autoload
478(defun titdic-convert (filename &optional dirname) 479(defun titdic-convert (filename &optional dirname)
480 (declare (obsolete tit-dic-convert "30.1"))
481 (tit-dic-convert filename dirname))
482(defun tit-dic-convert (filename &optional dirname)
479 "Convert a TIT dictionary of FILENAME into a Quail package. 483 "Convert a TIT dictionary of FILENAME into a Quail package.
480Optional argument DIRNAME if specified is the directory name under which 484Optional argument DIRNAME if specified is the directory name under which
481the generated Quail package is saved." 485the generated Quail package is saved."
@@ -531,21 +535,24 @@ the generated Quail package is saved."
531 535
532;;;###autoload 536;;;###autoload
533(defun batch-titdic-convert (&optional force) 537(defun batch-titdic-convert (&optional force)
534 "Run `titdic-convert' on the files remaining on the command line. 538 (declare (obsolete batch-tit-dic-convert "30.1"))
539 (batch-tit-dic-convert force))
540(defun batch-tit-dic-convert (&optional force)
541 "Run `tit-dic-convert' on the files remaining on the command line.
535Use this from the command line, with `-batch'; 542Use this from the command line, with `-batch';
536it won't work in an interactive Emacs. 543it won't work in an interactive Emacs.
537For example, invoke \"emacs -batch -f batch-titdic-convert XXX.tit\" to 544For example, invoke \"emacs -batch -f batch-tit-dic-convert XXX.tit\" to
538 generate Quail package file \"xxx.el\" from TIT dictionary file \"XXX.tit\". 545 generate Quail package file \"xxx.el\" from TIT dictionary file \"XXX.tit\".
539To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." 546To get complete usage, invoke \"emacs -batch -f batch-tit-dic-convert -h\"."
540 (defvar command-line-args-left) ; Avoid compiler warning. 547 (defvar command-line-args-left) ; Avoid compiler warning.
541 (if (not noninteractive) 548 (if (not noninteractive)
542 (error "`batch-titdic-convert' should be used only with -batch")) 549 (error "`batch-tit-dic-convert' should be used only with -batch"))
543 (if (string= (car command-line-args-left) "-h") 550 (if (string= (car command-line-args-left) "-h")
544 (progn 551 (progn
545 (message "To convert XXX.tit and YYY.tit into xxx.el and yyy.el:") 552 (message "To convert XXX.tit and YYY.tit into xxx.el and yyy.el:")
546 (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert XXX.tit YYY.tit") 553 (message " %% emacs -batch -l titdic-cnv -f batch-tit-dic-convert XXX.tit YYY.tit")
547 (message "To convert XXX.tit into DIR/xxx.el:") 554 (message "To convert XXX.tit into DIR/xxx.el:")
548 (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert -dir DIR XXX.tit")) 555 (message " %% emacs -batch -l titdic-cnv -f batch-tit-dic-convert -dir DIR XXX.tit"))
549 (let (targetdir filename files file) 556 (let (targetdir filename files file)
550 (if (string= (car command-line-args-left) "-dir") 557 (if (string= (car command-line-args-left) "-dir")
551 (progn 558 (progn
@@ -564,7 +571,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
564 (when (or force 571 (when (or force
565 (file-newer-than-file-p 572 (file-newer-than-file-p
566 file (tit-make-quail-package-file-name file targetdir))) 573 file (tit-make-quail-package-file-name file targetdir)))
567 (titdic-convert file targetdir)) 574 (tit-dic-convert file targetdir))
568 (setq files (cdr files))) 575 (setq files (cdr files)))
569 (setq command-line-args-left (cdr command-line-args-left))))) 576 (setq command-line-args-left (cdr command-line-args-left)))))
570 (kill-emacs 0)) 577 (kill-emacs 0))
@@ -583,10 +590,11 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
583;; COPYRIGHT-NOTICE ;; Copyright notice of the source dictionary. 590;; COPYRIGHT-NOTICE ;; Copyright notice of the source dictionary.
584;; ) 591;; )
585 592
586(defvar quail-misc-package-ext-info 593(define-obsolete-variable-alias 'quail-misc-package-ext-info 'tit-quail-misc-package-ext-info "30.1")
594(defvar tit-quail-misc-package-ext-info
587 '(("chinese-b5-tsangchi" "倉B" 595 '(("chinese-b5-tsangchi" "倉B"
588 "cangjie-table.b5" big5 "tsang-b5.el" 596 "cangjie-table.b5" big5 "tsang-b5.el"
589 tsang-b5-converter 597 tit--tsang-b5-converter
590 "\ 598 "\
591;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw> 599;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
592;; # 600;; #
@@ -596,7 +604,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
596 604
597 ("chinese-b5-quick" "簡B" 605 ("chinese-b5-quick" "簡B"
598 "cangjie-table.b5" big5 "quick-b5.el" 606 "cangjie-table.b5" big5 "quick-b5.el"
599 quick-b5-converter 607 tit--quick-b5-converter
600 "\ 608 "\
601;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw> 609;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
602;; # 610;; #
@@ -606,7 +614,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
606 614
607 ("chinese-cns-tsangchi" "倉C" 615 ("chinese-cns-tsangchi" "倉C"
608 "cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el" 616 "cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el"
609 tsang-cns-converter 617 tit--tsang-cns-converter
610 "\ 618 "\
611;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw> 619;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
612;; # 620;; #
@@ -616,7 +624,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
616 624
617 ("chinese-cns-quick" "簡C" 625 ("chinese-cns-quick" "簡C"
618 "cangjie-table.cns" iso-2022-cn-ext "quick-cns.el" 626 "cangjie-table.cns" iso-2022-cn-ext "quick-cns.el"
619 quick-cns-converter 627 tit--quick-cns-converter
620 "\ 628 "\
621;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw> 629;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
622;; # 630;; #
@@ -626,7 +634,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
626 634
627 ("chinese-py" "拼G" 635 ("chinese-py" "拼G"
628 "pinyin.map" cn-gb-2312 "PY.el" 636 "pinyin.map" cn-gb-2312 "PY.el"
629 py-converter 637 tit--py-converter
630 "\ 638 "\
631;; \"pinyin.map\" is included in a free package called CCE. It is 639;; \"pinyin.map\" is included in a free package called CCE. It is
632;; available at: [link needs updating -- SK 2021-09-27] 640;; 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\"."
654 662
655 ("chinese-ziranma" "自然" 663 ("chinese-ziranma" "自然"
656 "ziranma.cin" cn-gb-2312 "ZIRANMA.el" 664 "ziranma.cin" cn-gb-2312 "ZIRANMA.el"
657 ziranma-converter 665 tit--ziranma-converter
658 "\ 666 "\
659;; \"ziranma.cin\" is included in a free package called CCE. It is 667;; \"ziranma.cin\" is included in a free package called CCE. It is
660;; available at: [link needs updating -- SK 2021-09-27] 668;; 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\"."
682 690
683 ("chinese-ctlau" "刘粤" 691 ("chinese-ctlau" "刘粤"
684 "CTLau.html" cn-gb-2312 "CTLau.el" 692 "CTLau.html" cn-gb-2312 "CTLau.el"
685 ctlau-gb-converter 693 tit--ctlau-gb-converter
686 "\ 694 "\
687;; \"CTLau.html\" is available at: 695;; \"CTLau.html\" is available at:
688;; 696;;
@@ -707,7 +715,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
707 715
708 ("chinese-ctlaub" "劉粵" 716 ("chinese-ctlaub" "劉粵"
709 "CTLau-b5.html" big5 "CTLau-b5.el" 717 "CTLau-b5.html" big5 "CTLau-b5.el"
710 ctlau-b5-converter 718 tit--ctlau-b5-converter
711 "\ 719 "\
712;; \"CTLau-b5.html\" is available at: 720;; \"CTLau-b5.html\" is available at:
713;; 721;;
@@ -740,7 +748,8 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
740;; input method is for inputting Big5 characters. Otherwise the input 748;; input method is for inputting Big5 characters. Otherwise the input
741;; method is for inputting CNS characters. 749;; method is for inputting CNS characters.
742 750
743(defun tsang-quick-converter (dicbuf tsang-p big5-p) 751(define-obsolete-function-alias 'tsang-quick-converter #'tit--tsang-quick-converter "30.1")
752(defun tit--tsang-quick-converter (dicbuf tsang-p big5-p)
744 (let ((fulltitle (if tsang-p "倉頡" "簡易")) 753 (let ((fulltitle (if tsang-p "倉頡" "簡易"))
745 dic) 754 dic)
746 (goto-char (point-max)) 755 (goto-char (point-max))
@@ -822,23 +831,28 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
822 (if big5-p (nth 1 elt) (nth 2 elt)))))) 831 (if big5-p (nth 1 elt) (nth 2 elt))))))
823 (insert ")\n"))) 832 (insert ")\n")))
824 833
825(defun tsang-b5-converter (dicbuf) 834(define-obsolete-function-alias 'tsang-b5-converter #'tit--tsang-b5-converter "30.1")
826 (tsang-quick-converter dicbuf t t)) 835(defun tit--tsang-b5-converter (dicbuf)
836 (tit--tsang-quick-converter dicbuf t t))
827 837
828(defun quick-b5-converter (dicbuf) 838(define-obsolete-function-alias 'quick-b5-converter #'tit--quick-b5-converter "30.1")
829 (tsang-quick-converter dicbuf nil t)) 839(defun tit--quick-b5-converter (dicbuf)
840 (tit--tsang-quick-converter dicbuf nil t))
830 841
831(defun tsang-cns-converter (dicbuf) 842(define-obsolete-function-alias 'tsang-cns-converter #'tit--tsang-cns-converter "30.1")
832 (tsang-quick-converter dicbuf t nil)) 843(defun tit--tsang-cns-converter (dicbuf)
844 (tit--tsang-quick-converter dicbuf t nil))
833 845
834(defun quick-cns-converter (dicbuf) 846(define-obsolete-function-alias 'quick-cns-converter #'tit--quick-cns-converter "30.1")
835 (tsang-quick-converter dicbuf nil nil)) 847(defun tit--quick-cns-converter (dicbuf)
848 (tit--tsang-quick-converter dicbuf nil nil))
836 849
837;; Generate a code of a Quail package in the current buffer from 850;; Generate a code of a Quail package in the current buffer from
838;; Pinyin dictionary in the buffer DICBUF. The input method name of 851;; Pinyin dictionary in the buffer DICBUF. The input method name of
839;; the Quail package is NAME, and the title string is TITLE. 852;; the Quail package is NAME, and the title string is TITLE.
840 853
841(defun py-converter (dicbuf) 854(define-obsolete-function-alias 'py-converter #'tit--py-converter "30.1")
855(defun tit--py-converter (dicbuf)
842 (goto-char (point-max)) 856 (goto-char (point-max))
843 (insert (format "%S\n" "汉字输入∷拼音∷ 857 (insert (format "%S\n" "汉字输入∷拼音∷
844 858
@@ -913,7 +927,8 @@ method `chinese-tonepy' with which you must specify tones by digits
913;; Ziranma dictionary in the buffer DICBUF. The input method name of 927;; Ziranma dictionary in the buffer DICBUF. The input method name of
914;; the Quail package is NAME, and the title string is TITLE. 928;; the Quail package is NAME, and the title string is TITLE.
915 929
916(defun ziranma-converter (dicbuf) 930(define-obsolete-function-alias 'ziranma-converter #'tit--ziranma-converter "30.1")
931(defun tit--ziranma-converter (dicbuf)
917 (let (dic) 932 (let (dic)
918 (with-current-buffer dicbuf 933 (with-current-buffer dicbuf
919 (goto-char (point-min)) 934 (goto-char (point-min))
@@ -1022,7 +1037,8 @@ To input symbols and punctuation, type `/' followed by one of `a' to
1022;; method name of the Quail package is NAME, and the title string is 1037;; method name of the Quail package is NAME, and the title string is
1023;; TITLE. DESCRIPTION is the string shown by describe-input-method. 1038;; TITLE. DESCRIPTION is the string shown by describe-input-method.
1024 1039
1025(defun ctlau-converter (dicbuf description) 1040(define-obsolete-function-alias 'ctlau-converter #'tit--ctlau-converter "30.1")
1041(defun tit--ctlau-converter (dicbuf description)
1026 (goto-char (point-max)) 1042 (goto-char (point-max))
1027 (insert (format "%S\n" description)) 1043 (insert (format "%S\n" description))
1028 (insert " '((\"\C-?\" . quail-delete-last-char) 1044 (insert " '((\"\C-?\" . quail-delete-last-char)
@@ -1071,8 +1087,9 @@ To input symbols and punctuation, type `/' followed by one of `a' to
1071 (forward-line 1))) 1087 (forward-line 1)))
1072 (insert ")\n")) 1088 (insert ")\n"))
1073 1089
1074(defun ctlau-gb-converter (dicbuf) 1090(define-obsolete-function-alias 'ctlau-gb-converter #'tit--ctlau-gb-converter "30.1")
1075 (ctlau-converter dicbuf 1091(defun tit--ctlau-gb-converter (dicbuf)
1092 (tit--ctlau-converter dicbuf
1076"汉字输入∷刘锡祥式粤音∷ 1093"汉字输入∷刘锡祥式粤音∷
1077 1094
1078 刘锡祥式粤语注音方案 1095 刘锡祥式粤语注音方案
@@ -1085,8 +1102,9 @@ To input symbols and punctuation, type `/' followed by one of `a' to
1085 Some infrequent GB characters are accessed by typing \\, followed by 1102 Some infrequent GB characters are accessed by typing \\, followed by
1086 the Cantonese romanization of the respective radical (部首).")) 1103 the Cantonese romanization of the respective radical (部首)."))
1087 1104
1088(defun ctlau-b5-converter (dicbuf) 1105(define-obsolete-function-alias 'ctlau-b5-converter #'tit--ctlau-b5-converter "30.1")
1089 (ctlau-converter dicbuf 1106(defun tit--ctlau-b5-converter (dicbuf)
1107 (tit--ctlau-converter dicbuf
1090"漢字輸入:劉錫祥式粵音: 1108"漢字輸入:劉錫祥式粵音:
1091 1109
1092 劉錫祥式粵語注音方案 1110 劉錫祥式粵語注音方案
@@ -1101,14 +1119,15 @@ To input symbols and punctuation, type `/' followed by one of `a' to
1101 1119
1102(declare-function dos-8+3-filename "dos-fns.el" (filename)) 1120(declare-function dos-8+3-filename "dos-fns.el" (filename))
1103 1121
1104(defun miscdic-convert (filename &optional dirname) 1122(define-obsolete-function-alias 'miscdic-convert #'tit-miscdic-convert "30.1")
1123(defun tit-miscdic-convert (filename &optional dirname)
1105 "Convert a dictionary file FILENAME into a Quail package. 1124 "Convert a dictionary file FILENAME into a Quail package.
1106Optional argument DIRNAME if specified is the directory name under which 1125Optional argument DIRNAME if specified is the directory name under which
1107the generated Quail package is saved." 1126the generated Quail package is saved."
1108 (interactive "FInput method dictionary file: ") 1127 (interactive "FInput method dictionary file: ")
1109 (or (file-readable-p filename) 1128 (or (file-readable-p filename)
1110 (error "%s does not exist" filename)) 1129 (error "%s does not exist" filename))
1111 (let ((tail quail-misc-package-ext-info) 1130 (let ((tail tit-quail-misc-package-ext-info)
1112 coding-system-for-write 1131 coding-system-for-write
1113 slot 1132 slot
1114 name title dicfile coding quailfile converter copyright) 1133 name title dicfile coding quailfile converter copyright)
@@ -1137,7 +1156,7 @@ the generated Quail package is saved."
1137 ;; Explicitly set eol format to `unix'. 1156 ;; Explicitly set eol format to `unix'.
1138 (setq coding-system-for-write 'utf-8-unix) 1157 (setq coding-system-for-write 'utf-8-unix)
1139 (with-temp-file (expand-file-name quailfile dirname) 1158 (with-temp-file (expand-file-name quailfile dirname)
1140 (generate-lisp-file-heading quailfile 'miscdic-convert) 1159 (generate-lisp-file-heading quailfile 'tit-miscdic-convert)
1141 (insert (format-message ";; Quail package `%s'\n" name)) 1160 (insert (format-message ";; Quail package `%s'\n" name))
1142 (insert ";; Source dictionary file: " dicfile "\n") 1161 (insert ";; Source dictionary file: " dicfile "\n")
1143 (insert ";; Copyright notice of the source file\n") 1162 (insert ";; Copyright notice of the source file\n")
@@ -1164,15 +1183,17 @@ the generated Quail package is saved."
1164 quailfile :inhibit-provide t :compile t :coding nil))) 1183 quailfile :inhibit-provide t :compile t :coding nil)))
1165 (setq tail (cdr tail))))) 1184 (setq tail (cdr tail)))))
1166 1185
1167(defun batch-miscdic-convert () 1186;; Used in `Makefile.in'.
1168 "Run `miscdic-convert' on the files remaining on the command line. 1187(define-obsolete-function-alias 'batch-miscdic-convert #'batch-tit-miscdic-convert "30.1")
1188(defun batch-tit-miscdic-convert ()
1189 "Run `tit-miscdic-convert' on the files remaining on the command line.
1169Use this from the command line, with `-batch'; 1190Use this from the command line, with `-batch';
1170it won't work in an interactive Emacs. 1191it won't work in an interactive Emacs.
1171If there's an argument \"-dir\", the next argument specifies a directory 1192If there's an argument \"-dir\", the next argument specifies a directory
1172to store generated Quail packages." 1193to store generated Quail packages."
1173 (defvar command-line-args-left) ; Avoid compiler warning. 1194 (defvar command-line-args-left) ; Avoid compiler warning.
1174 (if (not noninteractive) 1195 (if (not noninteractive)
1175 (error "`batch-miscdic-convert' should be used only with -batch")) 1196 (error "`batch-tit-miscdic-convert' should be used only with -batch"))
1176 (let ((dir default-directory) 1197 (let ((dir default-directory)
1177 filename) 1198 filename)
1178 (while command-line-args-left 1199 (while command-line-args-left
@@ -1186,11 +1207,13 @@ to store generated Quail packages."
1186 (if (file-directory-p filename) 1207 (if (file-directory-p filename)
1187 (dolist (file (directory-files filename t nil t)) 1208 (dolist (file (directory-files filename t nil t))
1188 (or (file-directory-p file) 1209 (or (file-directory-p file)
1189 (miscdic-convert file dir))) 1210 (tit-miscdic-convert file dir)))
1190 (miscdic-convert filename dir)))) 1211 (tit-miscdic-convert filename dir))))
1191 (kill-emacs 0)) 1212 (kill-emacs 0))
1192 1213
1193(defun pinyin-convert () 1214;; Used in `Makefile.in'.
1215(define-obsolete-function-alias 'pinyin-convert #'tit-pinyin-convert "30.1")
1216(defun tit-pinyin-convert ()
1194 "Convert text file pinyin.map into an elisp library. 1217 "Convert text file pinyin.map into an elisp library.
1195The library is named pinyin.el, and contains the constant 1218The library is named pinyin.el, and contains the constant
1196`pinyin-character-map'." 1219`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:
635 (unwind-protect 635 (unwind-protect
636 (let ((tmp-dump-mode dump-mode) 636 (let ((tmp-dump-mode dump-mode)
637 (dump-mode nil) 637 (dump-mode nil)
638 ;; Set `lexical-binding' to nil by default
639 ;; in the dumped Emacs.
638 (lexical-binding nil)) 640 (lexical-binding nil))
639 (if (member tmp-dump-mode '("pdump" "pbootstrap")) 641 (if (member tmp-dump-mode '("pdump" "pbootstrap"))
640 (dump-emacs-portable (expand-file-name output invocation-directory)) 642 (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."
1845;; https://en.wikipedia.org/wiki/List_of_Internet_top-level_domains 1845;; https://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
1846 1846
1847(defconst mail-extr-all-top-level-domains 1847(defconst mail-extr-all-top-level-domains
1848 (let ((ob (make-vector 739 0))) 1848 (let ((ob (obarray-make 739)))
1849 (mapc 1849 (mapc
1850 (lambda (x) 1850 (lambda (x)
1851 (put (intern (downcase (car x)) ob) 1851 (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.)")
171;;;###autoload 171;;;###autoload
172(defun mail-abbrevs-setup () 172(defun mail-abbrevs-setup ()
173 "Initialize use of the `mailabbrev' package." 173 "Initialize use of the `mailabbrev' package."
174 (if (and (not (vectorp mail-abbrevs)) 174 (if (and (not (obarrayp mail-abbrevs))
175 (file-exists-p mail-personal-alias-file)) 175 (file-exists-p mail-personal-alias-file))
176 (progn 176 (progn
177 (setq mail-abbrev-modtime 177 (setq mail-abbrev-modtime
@@ -196,7 +196,7 @@ no aliases, which is represented by this being a table with no entries.)")
196 "Read mail aliases from personal mail alias file and set `mail-abbrevs'. 196 "Read mail aliases from personal mail alias file and set `mail-abbrevs'.
197By default this is the file specified by `mail-personal-alias-file'." 197By default this is the file specified by `mail-personal-alias-file'."
198 (setq file (expand-file-name (or file mail-personal-alias-file))) 198 (setq file (expand-file-name (or file mail-personal-alias-file)))
199 (if (vectorp mail-abbrevs) 199 (if (obarrayp mail-abbrevs)
200 nil 200 nil
201 (setq mail-abbrevs nil) 201 (setq mail-abbrevs nil)
202 (define-abbrev-table 'mail-abbrevs '())) 202 (define-abbrev-table 'mail-abbrevs '()))
@@ -278,7 +278,7 @@ double-quotes."
278 ;; true, and we do some evil space->comma hacking like /bin/mail does. 278 ;; true, and we do some evil space->comma hacking like /bin/mail does.
279 (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ") 279 (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
280 ;; Read the defaults first, if we have not done so. 280 ;; Read the defaults first, if we have not done so.
281 (unless (vectorp mail-abbrevs) (build-mail-abbrevs)) 281 (unless (obarrayp mail-abbrevs) (build-mail-abbrevs))
282 ;; strip garbage from front and end 282 ;; strip garbage from front and end
283 (if (string-match "\\`[ \t\n,]+" definition) 283 (if (string-match "\\`[ \t\n,]+" definition)
284 (setq definition (substring definition (match-end 0)))) 284 (setq definition (substring definition (match-end 0))))
@@ -355,7 +355,7 @@ double-quotes."
355 (if mail-abbrev-aliases-need-to-be-resolved 355 (if mail-abbrev-aliases-need-to-be-resolved
356 (progn 356 (progn
357;; (message "Resolving mail aliases...") 357;; (message "Resolving mail aliases...")
358 (if (vectorp mail-abbrevs) 358 (if (obarrayp mail-abbrevs)
359 (mapatoms (function mail-resolve-all-aliases-1) mail-abbrevs)) 359 (mapatoms (function mail-resolve-all-aliases-1) mail-abbrevs))
360 (setq mail-abbrev-aliases-need-to-be-resolved nil) 360 (setq mail-abbrev-aliases-need-to-be-resolved nil)
361;; (message "Resolving mail aliases... done.") 361;; (message "Resolving mail aliases... done.")
@@ -555,9 +555,9 @@ of a mail alias. The value is set up, buffer-local, when first needed.")
555(defun mail-abbrev-insert-alias (&optional alias) 555(defun mail-abbrev-insert-alias (&optional alias)
556 "Prompt for and insert a mail alias." 556 "Prompt for and insert a mail alias."
557 (interactive (progn 557 (interactive (progn
558 (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup)) 558 (if (not (obarrayp mail-abbrevs)) (mail-abbrevs-setup))
559 (list (completing-read "Expand alias: " mail-abbrevs nil t)))) 559 (list (completing-read "Expand alias: " mail-abbrevs nil t))))
560 (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup)) 560 (if (not (obarrayp mail-abbrevs)) (mail-abbrevs-setup))
561 (insert (or (and alias (symbol-value (intern-soft alias mail-abbrevs))) "")) 561 (insert (or (and alias (symbol-value (intern-soft alias mail-abbrevs))) ""))
562 (mail-abbrev-expand-hook)) 562 (mail-abbrev-expand-hook))
563 563
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.")
805 "\\(" cite-chars "[ \t]*\\)\\)+\\)" 805 "\\(" cite-chars "[ \t]*\\)\\)+\\)"
806 "\\(.*\\)") 806 "\\(.*\\)")
807 (beginning-of-line) (end-of-line) 807 (beginning-of-line) (end-of-line)
808 (1 font-lock-comment-delimiter-face nil t) 808 (1 'font-lock-comment-delimiter-face nil t)
809 (5 font-lock-comment-face nil t))) 809 (5 'font-lock-comment-face nil t)))
810 '("^\\(X-[a-z0-9-]+\\|In-Reply-To\\|Date\\):.*\\(\n[ \t]+.*\\)*$" 810 '("^\\(X-[a-z0-9-]+\\|In-Reply-To\\|Date\\):.*\\(\n[ \t]+.*\\)*$"
811 . 'rmail-header-name)))) 811 . 'rmail-header-name))))
812 "Additional expressions to highlight in Rmail mode.") 812 "Additional expressions to highlight in Rmail mode.")
@@ -815,7 +815,7 @@ that knows the exact ordering of the \\( \\) subexpressions.")
815(defun rmail-pop-to-buffer (&rest args) 815(defun rmail-pop-to-buffer (&rest args)
816 "Like `pop-to-buffer', but with `split-width-threshold' set to nil." 816 "Like `pop-to-buffer', but with `split-width-threshold' set to nil."
817 (let (split-width-threshold) 817 (let (split-width-threshold)
818 (apply 'pop-to-buffer args))) 818 (apply #'pop-to-buffer args)))
819 819
820;; Perform BODY in the summary buffer 820;; Perform BODY in the summary buffer
821;; in such a way that its cursor is properly updated in its own window. 821;; 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."
1008(defvar rmail-mode-map 1008(defvar rmail-mode-map
1009 (let ((map (make-keymap))) 1009 (let ((map (make-keymap)))
1010 (suppress-keymap map) 1010 (suppress-keymap map)
1011 (define-key map "a" 'rmail-add-label) 1011 (define-key map "a" #'rmail-add-label)
1012 (define-key map "b" 'rmail-bury) 1012 (define-key map "b" #'rmail-bury)
1013 (define-key map "c" 'rmail-continue) 1013 (define-key map "c" #'rmail-continue)
1014 (define-key map "d" 'rmail-delete-forward) 1014 (define-key map "d" #'rmail-delete-forward)
1015 (define-key map "\C-d" 'rmail-delete-backward) 1015 (define-key map "\C-d" #'rmail-delete-backward)
1016 (define-key map "e" 'rmail-edit-current-message) 1016 (define-key map "e" #'rmail-edit-current-message)
1017 ;; If you change this, change the rmail-resend menu-item's :keys. 1017 ;; If you change this, change the rmail-resend menu-item's :keys.
1018 (define-key map "f" 'rmail-forward) 1018 (define-key map "f" #'rmail-forward)
1019 (define-key map "g" 'rmail-get-new-mail) 1019 (define-key map "g" #'rmail-get-new-mail)
1020 (define-key map "h" 'rmail-summary) 1020 (define-key map "h" #'rmail-summary)
1021 (define-key map "i" 'rmail-input) 1021 (define-key map "i" #'rmail-input)
1022 (define-key map "j" 'rmail-show-message) 1022 (define-key map "j" #'rmail-show-message)
1023 (define-key map "k" 'rmail-kill-label) 1023 (define-key map "k" #'rmail-kill-label)
1024 (define-key map "l" 'rmail-summary-by-labels) 1024 (define-key map "l" #'rmail-summary-by-labels)
1025 (define-key map "\e\C-h" 'rmail-summary) 1025 (define-key map "\e\C-h" #'rmail-summary)
1026 (define-key map "\e\C-l" 'rmail-summary-by-labels) 1026 (define-key map "\e\C-l" #'rmail-summary-by-labels)
1027 (define-key map "\e\C-r" 'rmail-summary-by-recipients) 1027 (define-key map "\e\C-r" #'rmail-summary-by-recipients)
1028 (define-key map "\e\C-s" 'rmail-summary-by-regexp) 1028 (define-key map "\e\C-s" #'rmail-summary-by-regexp)
1029 (define-key map "\e\C-f" 'rmail-summary-by-senders) 1029 (define-key map "\e\C-f" #'rmail-summary-by-senders)
1030 (define-key map "\e\C-t" 'rmail-summary-by-topic) 1030 (define-key map "\e\C-t" #'rmail-summary-by-topic)
1031 (define-key map "m" 'rmail-mail) 1031 (define-key map "m" #'rmail-mail)
1032 (define-key map "\em" 'rmail-retry-failure) 1032 (define-key map "\em" #'rmail-retry-failure)
1033 (define-key map "n" 'rmail-next-undeleted-message) 1033 (define-key map "n" #'rmail-next-undeleted-message)
1034 (define-key map "\en" 'rmail-next-message) 1034 (define-key map "\en" #'rmail-next-message)
1035 (define-key map "\e\C-n" 'rmail-next-labeled-message) 1035 (define-key map "\e\C-n" #'rmail-next-labeled-message)
1036 (define-key map "o" 'rmail-output) 1036 (define-key map "o" #'rmail-output)
1037 (define-key map "\C-o" 'rmail-output-as-seen) 1037 (define-key map "\C-o" #'rmail-output-as-seen)
1038 (define-key map "p" 'rmail-previous-undeleted-message) 1038 (define-key map "p" #'rmail-previous-undeleted-message)
1039 (define-key map "\ep" 'rmail-previous-message) 1039 (define-key map "\ep" #'rmail-previous-message)
1040 (define-key map "\e\C-p" 'rmail-previous-labeled-message) 1040 (define-key map "\e\C-p" #'rmail-previous-labeled-message)
1041 (define-key map "q" 'rmail-quit) 1041 (define-key map "q" #'rmail-quit)
1042 (define-key map "r" 'rmail-reply) 1042 (define-key map "r" #'rmail-reply)
1043 ;; I find I can't live without the default M-r command -- rms. 1043 ;; I find I can't live without the default M-r command -- rms.
1044 ;; (define-key rmail-mode-map "\er" 'rmail-search-backwards) 1044 ;; (define-key rmail-mode-map "\er" #'rmail-search-backwards)
1045 (define-key map "s" 'rmail-expunge-and-save) 1045 (define-key map "s" #'rmail-expunge-and-save)
1046 (define-key map "\es" 'rmail-search) 1046 (define-key map "\es" #'rmail-search)
1047 (define-key map "t" 'rmail-toggle-header) 1047 (define-key map "t" #'rmail-toggle-header)
1048 (define-key map "u" 'rmail-undelete-previous-message) 1048 (define-key map "u" #'rmail-undelete-previous-message)
1049 (define-key map "v" 'rmail-mime) 1049 (define-key map "v" #'rmail-mime)
1050 (define-key map "w" 'rmail-output-body-to-file) 1050 (define-key map "w" #'rmail-output-body-to-file)
1051 (define-key map "\C-c\C-w" 'rmail-widen) 1051 (define-key map "\C-c\C-w" #'rmail-widen)
1052 (define-key map "x" 'rmail-expunge) 1052 (define-key map "x" #'rmail-expunge)
1053 (define-key map "." 'rmail-beginning-of-message) 1053 (define-key map "." #'rmail-beginning-of-message)
1054 (define-key map "/" 'rmail-end-of-message) 1054 (define-key map "/" #'rmail-end-of-message)
1055 (define-key map "<" 'rmail-first-message) 1055 (define-key map "<" #'rmail-first-message)
1056 (define-key map ">" 'rmail-last-message) 1056 (define-key map ">" #'rmail-last-message)
1057 (define-key map " " 'scroll-up-command) 1057 (define-key map " " #'scroll-up-command)
1058 (define-key map [?\S-\ ] 'scroll-down-command) 1058 (define-key map [?\S-\ ] #'scroll-down-command)
1059 (define-key map "\177" 'scroll-down-command) 1059 (define-key map "\177" #'scroll-down-command)
1060 (define-key map "?" 'describe-mode) 1060 (define-key map "?" #'describe-mode)
1061 (define-key map "\C-c\C-d" 'rmail-epa-decrypt) 1061 (define-key map "\C-c\C-d" #'rmail-epa-decrypt)
1062 (define-key map "\C-c\C-s\C-d" 'rmail-sort-by-date) 1062 (define-key map "\C-c\C-s\C-d" #'rmail-sort-by-date)
1063 (define-key map "\C-c\C-s\C-s" 'rmail-sort-by-subject) 1063 (define-key map "\C-c\C-s\C-s" #'rmail-sort-by-subject)
1064 (define-key map "\C-c\C-s\C-a" 'rmail-sort-by-author) 1064 (define-key map "\C-c\C-s\C-a" #'rmail-sort-by-author)
1065 (define-key map "\C-c\C-s\C-r" 'rmail-sort-by-recipient) 1065 (define-key map "\C-c\C-s\C-r" #'rmail-sort-by-recipient)
1066 (define-key map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent) 1066 (define-key map "\C-c\C-s\C-c" #'rmail-sort-by-correspondent)
1067 (define-key map "\C-c\C-s\C-l" 'rmail-sort-by-lines) 1067 (define-key map "\C-c\C-s\C-l" #'rmail-sort-by-lines)
1068 (define-key map "\C-c\C-s\C-k" 'rmail-sort-by-labels) 1068 (define-key map "\C-c\C-s\C-k" #'rmail-sort-by-labels)
1069 (define-key map "\C-c\C-n" 'rmail-next-same-subject) 1069 (define-key map "\C-c\C-n" #'rmail-next-same-subject)
1070 (define-key map "\C-c\C-p" 'rmail-previous-same-subject) 1070 (define-key map "\C-c\C-p" #'rmail-previous-same-subject)
1071 1071
1072 1072
1073 (define-key map [menu-bar] (make-sparse-keymap)) 1073 (define-key map [menu-bar] (make-sparse-keymap))
@@ -1344,9 +1344,9 @@ Instead, these commands are available:
1344 (setq local-abbrev-table text-mode-abbrev-table) 1344 (setq local-abbrev-table text-mode-abbrev-table)
1345 ;; Functions to support buffer swapping: 1345 ;; Functions to support buffer swapping:
1346 (add-hook 'write-region-annotate-functions 1346 (add-hook 'write-region-annotate-functions
1347 'rmail-write-region-annotate nil t) 1347 #'rmail-write-region-annotate nil t)
1348 (add-hook 'kill-buffer-hook 'rmail-mode-kill-buffer-hook nil t) 1348 (add-hook 'kill-buffer-hook #'rmail-mode-kill-buffer-hook nil t)
1349 (add-hook 'change-major-mode-hook 'rmail-change-major-mode-hook nil t)) 1349 (add-hook 'change-major-mode-hook #'rmail-change-major-mode-hook nil t))
1350 1350
1351(defun rmail-generate-viewer-buffer () 1351(defun rmail-generate-viewer-buffer ()
1352 "Return a reusable buffer suitable for viewing messages. 1352 "Return a reusable buffer suitable for viewing messages.
@@ -1363,7 +1363,7 @@ Create the buffer if necessary."
1363 (file-name-nondirectory 1363 (file-name-nondirectory
1364 (or buffer-file-name (buffer-name))))))) 1364 (or buffer-file-name (buffer-name)))))))
1365 (with-current-buffer newbuf 1365 (with-current-buffer newbuf
1366 (add-hook 'kill-buffer-hook 'rmail-view-buffer-kill-buffer-hook nil t)) 1366 (add-hook 'kill-buffer-hook #'rmail-view-buffer-kill-buffer-hook nil t))
1367 newbuf))) 1367 newbuf)))
1368 1368
1369(defun rmail-swap-buffers () 1369(defun rmail-swap-buffers ()
@@ -1479,7 +1479,7 @@ If so restore the actual mbox message collection."
1479 ;; Don't turn off auto-saving based on the size of the buffer 1479 ;; Don't turn off auto-saving based on the size of the buffer
1480 ;; because that code does not understand buffer-swapping. 1480 ;; because that code does not understand buffer-swapping.
1481 (setq-local auto-save-include-big-deletions t) 1481 (setq-local auto-save-include-big-deletions t)
1482 (setq-local revert-buffer-function 'rmail-revert) 1482 (setq-local revert-buffer-function #'rmail-revert)
1483 (setq-local font-lock-defaults 1483 (setq-local font-lock-defaults
1484 '(rmail-font-lock-keywords 1484 '(rmail-font-lock-keywords
1485 t t nil nil 1485 t t nil nil
@@ -1490,7 +1490,7 @@ If so restore the actual mbox message collection."
1490 (setq-local file-precious-flag t) 1490 (setq-local file-precious-flag t)
1491 (setq-local desktop-save-buffer t) 1491 (setq-local desktop-save-buffer t)
1492 (setq-local save-buffer-coding-system 'no-conversion) 1492 (setq-local save-buffer-coding-system 'no-conversion)
1493 (setq next-error-move-function 'rmail-next-error-move)) 1493 (setq next-error-move-function #'rmail-next-error-move))
1494 1494
1495;; Handle M-x revert-buffer done in an rmail-mode buffer. 1495;; Handle M-x revert-buffer done in an rmail-mode buffer.
1496(defun rmail-revert (arg noconfirm) 1496(defun rmail-revert (arg noconfirm)
@@ -1606,7 +1606,7 @@ The duplicate copy goes into the Rmail file just after the original."
1606 (files (directory-files start t rmail-secondary-file-regexp))) 1606 (files (directory-files start t rmail-secondary-file-regexp)))
1607 ;; Sort here instead of in directory-files 1607 ;; Sort here instead of in directory-files
1608 ;; because this list is usually much shorter. 1608 ;; because this list is usually much shorter.
1609 (sort files 'string<)))) 1609 (sort files #'string<))))
1610 1610
1611(defun rmail-list-to-menu (menu-name l action &optional full-name) 1611(defun rmail-list-to-menu (menu-name l action &optional full-name)
1612 (let ((menu (make-sparse-keymap menu-name)) 1612 (let ((menu (make-sparse-keymap menu-name))
@@ -2026,7 +2026,7 @@ Value is the size of the newly read mail after conversion."
2026 rmail-movemail-flags) 2026 rmail-movemail-flags)
2027 (list file tofile) 2027 (list file tofile)
2028 (if password (list password) nil)))) 2028 (if password (list password) nil))))
2029 (apply 'call-process args)) 2029 (apply #'call-process args))
2030 (if (not (buffer-modified-p errors)) 2030 (if (not (buffer-modified-p errors))
2031 ;; No output => movemail won 2031 ;; No output => movemail won
2032 nil 2032 nil
@@ -2518,7 +2518,7 @@ Output a helpful message unless NOMSG is non-nil."
2518 ;; which will never be used. 2518 ;; which will never be used.
2519 (push nil messages-head) 2519 (push nil messages-head)
2520 (push ?0 deleted-head) 2520 (push ?0 deleted-head)
2521 (setq rmail-message-vector (apply 'vector messages-head) 2521 (setq rmail-message-vector (apply #'vector messages-head)
2522 rmail-deleted-vector (concat deleted-head)) 2522 rmail-deleted-vector (concat deleted-head))
2523 2523
2524 (setq rmail-summary-vector (make-vector rmail-total-messages nil) 2524 (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."
3605 (cons (aref messages number) nil))) 3605 (cons (aref messages number) nil)))
3606 (setq rmail-current-message new-message-number 3606 (setq rmail-current-message new-message-number
3607 rmail-total-messages counter 3607 rmail-total-messages counter
3608 rmail-message-vector (apply 'vector messages-head) 3608 rmail-message-vector (apply #'vector messages-head)
3609 rmail-deleted-vector (make-string (1+ counter) ?\s) 3609 rmail-deleted-vector (make-string (1+ counter) ?\s)
3610 rmail-summary-vector (vconcat (nreverse new-summary)) 3610 rmail-summary-vector (vconcat (nreverse new-summary))
3611 rmail-msgref-vector (apply 'vector (nreverse new-msgref)) 3611 rmail-msgref-vector (apply #'vector (nreverse new-msgref))
3612 win t))) 3612 win t)))
3613 (message "Expunging deleted messages...done") 3613 (message "Expunging deleted messages...done")
3614 (if (not win) 3614 (if (not win)
@@ -3891,7 +3891,7 @@ use \\[mail-yank-original] to yank the original message into it."
3891 (if (or references message-id) 3891 (if (or references message-id)
3892 (list (cons "References" (if references 3892 (list (cons "References" (if references
3893 (concat 3893 (concat
3894 (mapconcat 'identity references " ") 3894 (mapconcat #'identity references " ")
3895 " " message-id) 3895 " " message-id)
3896 message-id))))))) 3896 message-id)))))))
3897 3897
@@ -4089,26 +4089,24 @@ typically for purposes of moderating a list."
4089 (insert "Resent-Bcc: " (user-login-name) "\n")) 4089 (insert "Resent-Bcc: " (user-login-name) "\n"))
4090 (insert "Resent-To: " (if (stringp address) 4090 (insert "Resent-To: " (if (stringp address)
4091 address 4091 address
4092 (mapconcat 'identity address ",\n\t")) 4092 (mapconcat #'identity address ",\n\t"))
4093 "\n") 4093 "\n")
4094 ;; Expand abbrevs in the recipients. 4094 ;; Expand abbrevs in the recipients.
4095 (save-excursion 4095 (save-excursion
4096 (if (featurep 'mailabbrev) 4096 (if (featurep 'mailabbrev)
4097 (let ((end (point-marker)) 4097 (let ((end (point-marker))
4098 (local-abbrev-table mail-abbrevs) 4098 (local-abbrev-table mail-abbrevs))
4099 (old-syntax-table (syntax-table))) 4099 (if (and (not (obarrayp mail-abbrevs))
4100 (if (and (not (vectorp mail-abbrevs))
4101 (file-exists-p mail-personal-alias-file)) 4100 (file-exists-p mail-personal-alias-file))
4102 (build-mail-abbrevs)) 4101 (build-mail-abbrevs))
4103 (unless mail-abbrev-syntax-table 4102 (unless mail-abbrev-syntax-table
4104 (mail-abbrev-make-syntax-table)) 4103 (mail-abbrev-make-syntax-table))
4105 (set-syntax-table mail-abbrev-syntax-table) 4104 (with-syntax-table mail-abbrev-syntax-table
4106 (goto-char before) 4105 (goto-char before)
4107 (while (and (< (point) end) 4106 (while (and (< (point) end)
4108 (progn (forward-word-strictly 1) 4107 (progn (forward-word-strictly 1)
4109 (<= (point) end))) 4108 (<= (point) end)))
4110 (expand-abbrev)) 4109 (expand-abbrev))))
4111 (set-syntax-table old-syntax-table))
4112 (expand-mail-aliases before (point))))) 4110 (expand-mail-aliases before (point)))))
4113 ;;>> Set up comment, if any. 4111 ;;>> Set up comment, if any.
4114 (if (and (sequencep comment) (not (zerop (length comment)))) 4112 (if (and (sequencep comment) (not (zerop (length comment))))
@@ -4335,7 +4333,7 @@ This has an effect only if a summary buffer exists."
4335 4333
4336(defun rmail-fontify-buffer-function () 4334(defun rmail-fontify-buffer-function ()
4337 ;; This function's symbol is bound to font-lock-fontify-buffer-function. 4335 ;; This function's symbol is bound to font-lock-fontify-buffer-function.
4338 (add-hook 'rmail-show-message-hook 'rmail-fontify-message nil t) 4336 (add-hook 'rmail-show-message-hook #'rmail-fontify-message nil t)
4339 ;; If we're already showing a message, fontify it now. 4337 ;; If we're already showing a message, fontify it now.
4340 (if rmail-current-message (rmail-fontify-message)) 4338 (if rmail-current-message (rmail-fontify-message))
4341 ;; Prevent Font Lock mode from kicking in. 4339 ;; Prevent Font Lock mode from kicking in.
@@ -4346,7 +4344,7 @@ This has an effect only if a summary buffer exists."
4346 (with-silent-modifications 4344 (with-silent-modifications
4347 (save-restriction 4345 (save-restriction
4348 (widen) 4346 (widen)
4349 (remove-hook 'rmail-show-message-hook 'rmail-fontify-message t) 4347 (remove-hook 'rmail-show-message-hook #'rmail-fontify-message t)
4350 (remove-text-properties (point-min) (point-max) '(rmail-fontified nil)) 4348 (remove-text-properties (point-min) (point-max) '(rmail-fontified nil))
4351 (font-lock-default-unfontify-buffer)))) 4349 (font-lock-default-unfontify-buffer))))
4352 4350
@@ -4381,11 +4379,12 @@ browsing, and moving of messages."
4381 "Install those variables used by speedbar to enhance rmail." 4379 "Install those variables used by speedbar to enhance rmail."
4382 (unless rmail-speedbar-key-map 4380 (unless rmail-speedbar-key-map
4383 (setq rmail-speedbar-key-map (speedbar-make-specialized-keymap)) 4381 (setq rmail-speedbar-key-map (speedbar-make-specialized-keymap))
4384 (define-key rmail-speedbar-key-map "e" 'speedbar-edit-line) 4382 (declare-function speedbar-edit-line "speedbar")
4385 (define-key rmail-speedbar-key-map "r" 'speedbar-edit-line) 4383 (define-key rmail-speedbar-key-map "e" #'speedbar-edit-line)
4386 (define-key rmail-speedbar-key-map "\C-m" 'speedbar-edit-line) 4384 (define-key rmail-speedbar-key-map "r" #'speedbar-edit-line)
4385 (define-key rmail-speedbar-key-map "\C-m" #'speedbar-edit-line)
4387 (define-key rmail-speedbar-key-map "M" 4386 (define-key rmail-speedbar-key-map "M"
4388 'rmail-speedbar-move-message-to-folder-on-line))) 4387 #'rmail-speedbar-move-message-to-folder-on-line)))
4389 4388
4390;; Mouse-3. 4389;; Mouse-3.
4391(defvar rmail-speedbar-menu-items 4390(defvar rmail-speedbar-menu-items
@@ -4829,7 +4828,8 @@ Content-Transfer-Encoding: base64\n")
4829 (with-current-buffer 4828 (with-current-buffer
4830 (if (rmail-buffers-swapped-p) rmail-buffer rmail-view-buffer) 4829 (if (rmail-buffers-swapped-p) rmail-buffer rmail-view-buffer)
4831 (setq buffer-file-coding-system rmail-message-encoding)))) 4830 (setq buffer-file-coding-system rmail-message-encoding))))
4832(add-hook 'after-save-hook 'rmail-after-save-hook) 4831;; FIXME: Don't do it globally!!
4832(add-hook 'after-save-hook #'rmail-after-save-hook)
4833 4833
4834 4834
4835;;; Mailing list support 4835;;; 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 @@
31;; Global to all RMAIL buffers. It exists for the sake of completion. 31;; Global to all RMAIL buffers. It exists for the sake of completion.
32;; It is better to use strings with the label functions and let them 32;; It is better to use strings with the label functions and let them
33;; worry about making the label. 33;; worry about making the label.
34(defvar rmail-label-obarray (make-vector 47 0) 34(defvar rmail-label-obarray (obarray-make 47)
35 "Obarray of labels used by Rmail. 35 "Obarray of labels used by Rmail.
36`rmail-read-label' uses this to offer completion.") 36`rmail-read-label' uses this to offer completion.")
37 37
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"))
1353 (frame-visible-p 1353 (frame-visible-p
1354 (symbol-value 'speedbar-frame)))))) 1354 (symbol-value 'speedbar-frame))))))
1355 1355
1356 (bindings--define-key menu [showhide-outline-minor-mode]
1357 '(menu-item "Outlines" outline-minor-mode
1358 :help "Turn outline-minor-mode on/off"
1359 :visible (seq-some #'local-variable-p
1360 '(outline-search-function
1361 outline-regexp outline-level))
1362 :button (:toggle . (and (boundp 'outline-minor-mode)
1363 outline-minor-mode))))
1364
1356 (bindings--define-key menu [showhide-tab-line-mode] 1365 (bindings--define-key menu [showhide-tab-line-mode]
1357 '(menu-item "Window Tab Line" global-tab-line-mode 1366 '(menu-item "Window Tab Line" global-tab-line-mode
1358 :help "Turn window-local tab-lines on/off" 1367 :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)."
321 ;; Predicates are called differently depending on the nature of 321 ;; Predicates are called differently depending on the nature of
322 ;; the completion table :-( 322 ;; the completion table :-(
323 (cond 323 (cond
324 ((vectorp table) ;Obarray. 324 ((obarrayp table)
325 (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) 325 (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
326 ((hash-table-p table) 326 ((hash-table-p table)
327 (lambda (s _v) (funcall pred (concat prefix s)))) 327 (lambda (s _v) (funcall pred (concat prefix s))))
@@ -1970,10 +1970,13 @@ appear to be a match."
1970 ;; Allow user to specify null string 1970 ;; Allow user to specify null string
1971 ((= beg end) (funcall exit-function)) 1971 ((= beg end) (funcall exit-function))
1972 ;; The CONFIRM argument is a predicate. 1972 ;; The CONFIRM argument is a predicate.
1973 ((and (functionp minibuffer-completion-confirm) 1973 ((functionp minibuffer-completion-confirm)
1974 (funcall minibuffer-completion-confirm 1974 (if (funcall minibuffer-completion-confirm
1975 (buffer-substring beg end))) 1975 (buffer-substring beg end))
1976 (funcall exit-function)) 1976 (funcall exit-function)
1977 (unless completion-fail-discreetly
1978 (ding)
1979 (completion--message "No match"))))
1977 ;; See if we have a completion from the table. 1980 ;; See if we have a completion from the table.
1978 ((test-completion (buffer-substring beg end) 1981 ((test-completion (buffer-substring beg end)
1979 minibuffer-completion-table 1982 minibuffer-completion-table
@@ -3482,9 +3485,10 @@ Fourth arg MUSTMATCH can take the following values:
3482 input, but she needs to confirm her choice if she called 3485 input, but she needs to confirm her choice if she called
3483 `minibuffer-complete' right before `minibuffer-complete-and-exit' 3486 `minibuffer-complete' right before `minibuffer-complete-and-exit'
3484 and the input is not an existing file. 3487 and the input is not an existing file.
3485- a function, which will be called with the input as the 3488- a function, which will be called with a single argument, the
3486 argument. If the function returns a non-nil value, the 3489 input unquoted by `substitute-in-file-name', which see. If the
3487 minibuffer is exited with that argument as the value. 3490 function returns a non-nil value, the minibuffer is exited with
3491 that argument as the value.
3488- anything else behaves like t except that typing RET does not exit if it 3492- anything else behaves like t except that typing RET does not exit if it
3489 does non-null completion. 3493 does non-null completion.
3490 3494
@@ -3573,7 +3577,13 @@ See `read-file-name' for the meaning of the arguments."
3573 (let ((ignore-case read-file-name-completion-ignore-case) 3577 (let ((ignore-case read-file-name-completion-ignore-case)
3574 (minibuffer-completing-file-name t) 3578 (minibuffer-completing-file-name t)
3575 (pred (or predicate 'file-exists-p)) 3579 (pred (or predicate 'file-exists-p))
3576 (add-to-history nil)) 3580 (add-to-history nil)
3581 (require-match (if (functionp mustmatch)
3582 (lambda (input)
3583 (funcall mustmatch
3584 ;; User-supplied MUSTMATCH expects an unquoted filename
3585 (substitute-in-file-name input)))
3586 mustmatch)))
3577 3587
3578 (let* ((val 3588 (let* ((val
3579 (if (or (not (next-read-file-uses-dialog-p)) 3589 (if (or (not (next-read-file-uses-dialog-p))
@@ -3609,7 +3619,7 @@ See `read-file-name' for the meaning of the arguments."
3609 (read-file-name--defaults dir initial)))) 3619 (read-file-name--defaults dir initial))))
3610 (set-syntax-table minibuffer-local-filename-syntax)) 3620 (set-syntax-table minibuffer-local-filename-syntax))
3611 (completing-read prompt 'read-file-name-internal 3621 (completing-read prompt 'read-file-name-internal
3612 pred mustmatch insdef 3622 pred require-match insdef
3613 'file-name-history default-filename))) 3623 'file-name-history default-filename)))
3614 ;; If DEFAULT-FILENAME not supplied and DIR contains 3624 ;; If DEFAULT-FILENAME not supplied and DIR contains
3615 ;; a file name, split it. 3625 ;; 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.")
1867(defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t) 1867(defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t)
1868 1868
1869(defun mpc-volume-refresh () 1869(defun mpc-volume-refresh ()
1870 ;; Maintain the volume. 1870 "Maintain the volume."
1871 (setq mpc-volume 1871 (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status))
1872 (mpc-volume-widget 1872 (status-vol (cdr (assq 'volume mpc-status))))
1873 (string-to-number (cdr (assq 'volume mpc-status))))) 1873 ;; If MPD is paused or stopped the volume is nil.
1874 (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status))) 1874 (when status-vol
1875 (setq mpc-volume
1876 (mpc-volume-widget
1877 (string-to-number status-vol))))
1875 (when (buffer-live-p status-buf) 1878 (when (buffer-live-p status-buf)
1876 (with-current-buffer status-buf (force-mode-line-update))))) 1879 (with-current-buffer status-buf (force-mode-line-update)))))
1877 1880
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."
688(defun browse-url-url-at-point () 688(defun browse-url-url-at-point ()
689 (or (thing-at-point 'url t) 689 (or (thing-at-point 'url t)
690 ;; assume that the user is pointing at something like gnu.org/gnu 690 ;; assume that the user is pointing at something like gnu.org/gnu
691 (let ((f (thing-at-point 'filename t))) 691 (when-let ((f (thing-at-point 'filename t)))
692 (and f (concat browse-url-default-scheme "://" f))))) 692 (if (string-match-p browse-url-button-regexp f)
693 f
694 (concat browse-url-default-scheme "://" f)))))
693 695
694;; Having this as a separate function called by the browser-specific 696;; Having this as a separate function called by the browser-specific
695;; functions allows them to be stand-alone commands, making it easier 697;; 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."
1322 :type 'boolean 1324 :type 'boolean
1323 :version "30.1") 1325 :version "30.1")
1324 1326
1325(declare-function android-browse-url "androidselect.c") 1327(declare-function android-browse-url "../term/android-win")
1326 1328
1327;;;###autoload 1329;;;###autoload
1328(defun browse-url-default-android-browser (url &optional _new-window) 1330(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\"."
359 result)) 359 result))
360 360
361;;; Interface functions. 361;;; Interface functions.
362(defvar dns-cache (make-vector 4096 0)) 362(defvar dns-cache (obarray-make 4096))
363 363
364(defun dns-query-cached (name &optional type fullp reversep) 364(defun dns-query-cached (name &optional type fullp reversep)
365 (let* ((key (format "%s:%s:%s:%s" name type fullp reversep)) 365 (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."
340(defun eww-suggested-uris nil 340(defun eww-suggested-uris nil
341 "Return the list of URIs to suggest at the `eww' prompt. 341 "Return the list of URIs to suggest at the `eww' prompt.
342This list can be customized via `eww-suggest-uris'." 342This list can be customized via `eww-suggest-uris'."
343 (let ((obseen (make-vector 42 0)) 343 (let ((obseen (obarray-make 42))
344 (uris nil)) 344 (uris nil))
345 (dolist (fun eww-suggest-uris) 345 (dolist (fun eww-suggest-uris)
346 (let ((ret (funcall fun))) 346 (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."
1057 (setq imap-capability nil) 1057 (setq imap-capability nil)
1058 (setq streams nil)))))) 1058 (setq streams nil))))))
1059 (when (imap-opened buffer) 1059 (when (imap-opened buffer)
1060 (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) 1060 (setq imap-mailbox-data (obarray-make imap-mailbox-prime)))
1061 ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer) 1061 ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer)
1062 (when imap-stream 1062 (when imap-stream
1063 buffer)))) 1063 buffer))))
@@ -1280,7 +1280,7 @@ If EXAMINE is non-nil, do a read-only select."
1280 (concat (if examine "EXAMINE" "SELECT") " \"" 1280 (concat (if examine "EXAMINE" "SELECT") " \""
1281 mailbox "\""))) 1281 mailbox "\"")))
1282 (progn 1282 (progn
1283 (setq imap-message-data (make-vector imap-message-prime 0) 1283 (setq imap-message-data (obarray-make imap-message-prime)
1284 imap-state (if examine 'examine 'selected)) 1284 imap-state (if examine 'examine 'selected))
1285 imap-current-mailbox) 1285 imap-current-mailbox)
1286 ;; Failed SELECT/EXAMINE unselects current mailbox 1286 ;; Failed SELECT/EXAMINE unselects current mailbox
@@ -1722,7 +1722,7 @@ See `imap-enable-exchange-bug-workaround'."
1722 (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox)))) 1722 (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1723 (let ((old-mailbox imap-current-mailbox) 1723 (let ((old-mailbox imap-current-mailbox)
1724 (state imap-state) 1724 (state imap-state)
1725 (imap-message-data (make-vector 2 0))) 1725 (imap-message-data (obarray-make 2)))
1726 (when (imap-mailbox-examine-1 mailbox) 1726 (when (imap-mailbox-examine-1 mailbox)
1727 (prog1 1727 (prog1
1728 (and (imap-fetch-safe '("*" . "*:*") "UID") 1728 (and (imap-fetch-safe '("*" . "*:*") "UID")
@@ -1768,7 +1768,7 @@ first element. The rest of list contains the saved articles' UIDs."
1768 (imap-mailbox-get-1 'appenduid mailbox) 1768 (imap-mailbox-get-1 'appenduid mailbox)
1769 (let ((old-mailbox imap-current-mailbox) 1769 (let ((old-mailbox imap-current-mailbox)
1770 (state imap-state) 1770 (state imap-state)
1771 (imap-message-data (make-vector 2 0))) 1771 (imap-message-data (obarray-make 2)))
1772 (when (imap-mailbox-examine-1 mailbox) 1772 (when (imap-mailbox-examine-1 mailbox)
1773 (prog1 1773 (prog1
1774 (and (imap-fetch-safe '("*" . "*:*") "UID") 1774 (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."
1437 (shr-dom-print elem))))) 1437 (shr-dom-print elem)))))
1438 (insert (format "</%s>" (dom-tag dom)))) 1438 (insert (format "</%s>" (dom-tag dom))))
1439 1439
1440(defconst shr-correct-attribute-case
1441 '((attributename . attributeName)
1442 (attributetype . attributeType)
1443 (basefrequency . baseFrequency)
1444 (baseprofile . baseProfile)
1445 (calcmode . calcMode)
1446 (clippathunits . clipPathUnits)
1447 (diffuseconstant . diffuseConstant)
1448 (edgemode . edgeMode)
1449 (filterunits . filterUnits)
1450 (glyphref . glyphRef)
1451 (gradienttransform . gradientTransform)
1452 (gradientunits . gradientUnits)
1453 (kernelmatrix . kernelMatrix)
1454 (kernelunitlength . kernelUnitLength)
1455 (keypoints . keyPoints)
1456 (keysplines . keySplines)
1457 (keytimes . keyTimes)
1458 (lengthadjust . lengthAdjust)
1459 (limitingconeangle . limitingConeAngle)
1460 (markerheight . markerHeight)
1461 (markerunits . markerUnits)
1462 (markerwidth . markerWidth)
1463 (maskcontentunits . maskContentUnits)
1464 (maskunits . maskUnits)
1465 (numoctaves . numOctaves)
1466 (pathlength . pathLength)
1467 (patterncontentunits . patternContentUnits)
1468 (patterntransform . patternTransform)
1469 (patternunits . patternUnits)
1470 (pointsatx . pointsAtX)
1471 (pointsaty . pointsAtY)
1472 (pointsatz . pointsAtZ)
1473 (preservealpha . preserveAlpha)
1474 (preserveaspectratio . preserveAspectRatio)
1475 (primitiveunits . primitiveUnits)
1476 (refx . refX)
1477 (refy . refY)
1478 (repeatcount . repeatCount)
1479 (repeatdur . repeatDur)
1480 (requiredextensions . requiredExtensions)
1481 (requiredfeatures . requiredFeatures)
1482 (specularconstant . specularConstant)
1483 (specularexponent . specularExponent)
1484 (spreadmethod . spreadMethod)
1485 (startoffset . startOffset)
1486 (stddeviation . stdDeviation)
1487 (stitchtiles . stitchTiles)
1488 (surfacescale . surfaceScale)
1489 (systemlanguage . systemLanguage)
1490 (tablevalues . tableValues)
1491 (targetx . targetX)
1492 (targety . targetY)
1493 (textlength . textLength)
1494 (viewbox . viewBox)
1495 (viewtarget . viewTarget)
1496 (xchannelselector . xChannelSelector)
1497 (ychannelselector . yChannelSelector)
1498 (zoomandpan . zoomAndPan))
1499 "Attributes for correcting the case in SVG and MathML.
1500Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inforeign .")
1501
1502(defun shr-correct-dom-case (dom)
1503 "Correct the case for SVG segments."
1504 (dolist (attr (dom-attributes dom))
1505 (when-let ((rep (assoc-default (car attr) shr-correct-attribute-case)))
1506 (setcar attr rep)))
1507 (dolist (child (dom-children dom))
1508 (shr-correct-dom-case child))
1509 dom)
1510
1440(defun shr-tag-svg (dom) 1511(defun shr-tag-svg (dom)
1441 (when (and (image-type-available-p 'svg) 1512 (when (and (image-type-available-p 'svg)
1442 (not shr-inhibit-images) 1513 (not shr-inhibit-images)
1443 (dom-attr dom 'width) 1514 (dom-attr dom 'width)
1444 (dom-attr dom 'height)) 1515 (dom-attr dom 'height))
1445 (funcall shr-put-image-function (list (shr-dom-to-xml dom 'utf-8) 1516 (funcall shr-put-image-function
1446 'image/svg+xml) 1517 (list (shr-dom-to-xml (shr-correct-dom-case dom) 'utf-8)
1518 'image/svg+xml)
1447 "SVG Image"))) 1519 "SVG Image")))
1448 1520
1449(defun shr-tag-sup (dom) 1521(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."
263 (tramp-convert-file-attributes v localname id-format 263 (tramp-convert-file-attributes v localname id-format
264 (and 264 (and
265 (tramp-adb-send-command-and-check 265 (tramp-adb-send-command-and-check
266 v (format "%s -d -l %s | cat" 266 v (format "(%s -d -l %s; echo tramp_exit_status $?) | cat"
267 (tramp-adb-get-ls-command v) 267 (tramp-adb-get-ls-command v)
268 (tramp-shell-quote-argument localname))) 268 (tramp-shell-quote-argument localname))
269 nil t)
269 (with-current-buffer (tramp-get-buffer v) 270 (with-current-buffer (tramp-get-buffer v)
270 (tramp-adb-sh-fix-ls-output) 271 (tramp-adb-sh-fix-ls-output)
271 (cdar (tramp-do-parse-file-attributes-with-ls v))))))) 272 (cdar (tramp-do-parse-file-attributes-with-ls v)))))))
@@ -316,9 +317,10 @@ arguments to pass to the OPERATION."
316 directory full match nosort id-format count 317 directory full match nosort id-format count
317 (with-current-buffer (tramp-get-buffer v) 318 (with-current-buffer (tramp-get-buffer v)
318 (when (tramp-adb-send-command-and-check 319 (when (tramp-adb-send-command-and-check
319 v (format "%s -a -l %s | cat" 320 v (format "(%s -a -l %s; echo tramp_exit_status $?) | cat"
320 (tramp-adb-get-ls-command v) 321 (tramp-adb-get-ls-command v)
321 (tramp-shell-quote-argument localname))) 322 (tramp-shell-quote-argument localname))
323 nil t)
322 ;; We insert also filename/. and filename/.., because "ls" 324 ;; We insert also filename/. and filename/.., because "ls"
323 ;; doesn't on some file systems, like "sdcard". 325 ;; doesn't on some file systems, like "sdcard".
324 (unless (search-backward-regexp (rx "." eol) nil t) 326 (unless (search-backward-regexp (rx "." eol) nil t)
@@ -440,10 +442,12 @@ Emacs dired can't find files."
440 filename 442 filename
441 (with-parsed-tramp-file-name (expand-file-name directory) nil 443 (with-parsed-tramp-file-name (expand-file-name directory) nil
442 (with-tramp-file-property v localname "file-name-all-completions" 444 (with-tramp-file-property v localname "file-name-all-completions"
443 (tramp-adb-send-command 445 (unless (tramp-adb-send-command-and-check
444 v (format "%s -a %s | cat" 446 v (format "(%s -a %s; echo tramp_exit_status $?) | cat"
445 (tramp-adb-get-ls-command v) 447 (tramp-adb-get-ls-command v)
446 (tramp-shell-quote-argument localname))) 448 (tramp-shell-quote-argument localname))
449 nil t)
450 (erase-buffer))
447 (mapcar 451 (mapcar
448 (lambda (f) 452 (lambda (f)
449 (if (file-directory-p (expand-file-name f directory)) 453 (if (file-directory-p (expand-file-name f directory))
@@ -1142,17 +1146,23 @@ error and non-nil on success."
1142 (while (search-forward-regexp (rx (+ "\r") eol) nil t) 1146 (while (search-forward-regexp (rx (+ "\r") eol) nil t)
1143 (replace-match "" nil nil))))))) 1147 (replace-match "" nil nil)))))))
1144 1148
1145(defun tramp-adb-send-command-and-check (vec command &optional exit-status) 1149(defun tramp-adb-send-command-and-check
1150 (vec command &optional exit-status command-augmented-p)
1146 "Run COMMAND and check its exit status. 1151 "Run COMMAND and check its exit status.
1147Sends `echo $?' along with the COMMAND for checking the exit 1152Sends `echo $?' along with the COMMAND for checking the exit
1148status. If COMMAND is nil, just sends `echo $?'. Returns nil if 1153status. If COMMAND is nil, just sends `echo $?'. Returns nil if
1149the exit status is not equal 0, and t otherwise. 1154the exit status is not equal 0, and t otherwise.
1150 1155
1156If COMMAND-AUGMENTED-P, COMMAND is already configured to print exit
1157status upon completion and need not be modified.
1158
1151Optional argument EXIT-STATUS, if non-nil, triggers the return of 1159Optional argument EXIT-STATUS, if non-nil, triggers the return of
1152the exit status." 1160the exit status."
1153 (tramp-adb-send-command 1161 (tramp-adb-send-command
1154 vec (if command 1162 vec (if command
1155 (format "%s; echo tramp_exit_status $?" command) 1163 (if command-augmented-p
1164 command
1165 (format "%s; echo tramp_exit_status $?" command))
1156 "echo tramp_exit_status $?")) 1166 "echo tramp_exit_status $?"))
1157 (with-current-buffer (tramp-get-connection-buffer vec) 1167 (with-current-buffer (tramp-get-connection-buffer vec)
1158 (unless (tramp-search-regexp (rx "tramp_exit_status " (+ digit))) 1168 (unless (tramp-search-regexp (rx "tramp_exit_status " (+ digit)))
@@ -1230,7 +1240,7 @@ connection if a previous connection has died for some reason."
1230 (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct? 1240 (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct?
1231 (process-connection-type tramp-process-connection-type) 1241 (process-connection-type tramp-process-connection-type)
1232 (args (tramp-expand-args 1242 (args (tramp-expand-args
1233 vec 'tramp-login-args ?d (or device ""))) 1243 vec 'tramp-login-args nil ?d (or device "")))
1234 (p (let ((default-directory 1244 (p (let ((default-directory
1235 tramp-compat-temporary-file-directory)) 1245 tramp-compat-temporary-file-directory))
1236 (apply 1246 (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 @@
1;;; tramp-androidsu.el --- TRAMP method for Android superuser shells -*- lexical-binding:t -*-
2
3;; Copyright (C) 2024 Free Software Foundation, Inc.
4
5;; Keywords: comm, processes
6;; Package: tramp
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
22
23;;; Commentary:
24
25;; The `su' method struggles (as do other shell-based methods) with the
26;; crippled versions of many Unix utilities installed on Android,
27;; workarounds for which are implemented in the `adb' method. This
28;; method defines a shell-based method that is identical in function to
29;; `su', but reuses such code from the `adb' method where applicable and
30;; also provides for certain mannerisms of popular Android `su'
31;; implementations.
32
33;;; Code:
34
35(require 'tramp)
36(require 'tramp-adb)
37(require 'tramp-sh)
38
39;;;###tramp-autoload
40(defconst tramp-androidsu-method "androidsu"
41 "When this method name is used, forward all calls to su.")
42
43;;;###tramp-autoload
44(defcustom tramp-androidsu-mount-global-namespace t
45 "When non-nil, browse files from within the global mount namespace.
46On systems that assign each application a unique view of the filesystem
47by executing them within individual mount namespaces and thus conceal
48each application's data directories from others, invoke `su' with the
49option `-mm' in order for the shell launched to run within the global
50mount namespace, so that TRAMP may edit files belonging to any and all
51applications."
52 :group 'tramp
53 :version "30.1"
54 :type 'boolean)
55
56(defvar tramp-androidsu-su-mm-supported 'unknown
57 "Whether `su -mm' is supported on this system.")
58
59;;;###tramp-autoload
60(tramp--with-startup
61 (add-to-list 'tramp-methods
62 `(,tramp-androidsu-method
63 (tramp-login-program "su")
64 (tramp-login-args (("-") ("%u")))
65 (tramp-remote-shell "/system/bin/sh")
66 (tramp-remote-shell-login ("-l"))
67 (tramp-remote-shell-args ("-c"))
68 (tramp-tmpdir "/data/local/tmp")
69 (tramp-connection-timeout 10)))
70
71 (add-to-list 'tramp-default-host-alist
72 `(,tramp-androidsu-method nil "localhost")))
73
74(defvar android-use-exec-loader) ; androidfns.c.
75
76(defun tramp-androidsu-maybe-open-connection (vec)
77 "Open a connection VEC if not already open.
78Mostly identical to `tramp-adb-maybe-open-connection', but also disables
79multibyte mode and waits for the shell prompt to appear."
80 ;; During completion, don't reopen a new connection.
81 (unless (tramp-connectable-p vec)
82 (throw 'non-essential 'non-essential))
83
84 (with-tramp-debug-message vec "Opening connection"
85 (let ((p (tramp-get-connection-process vec))
86 (process-name (tramp-get-connection-property vec "process-name"))
87 (process-environment (copy-sequence process-environment)))
88 ;; Open a new connection.
89 (condition-case err
90 (unless (process-live-p p)
91 (with-tramp-progress-reporter
92 vec 3
93 (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
94 (format "Opening connection %s for %s using %s"
95 process-name
96 (tramp-file-name-host vec)
97 (tramp-file-name-method vec))
98 (format "Opening connection %s for %s@%s using %s"
99 process-name
100 (tramp-file-name-user vec)
101 (tramp-file-name-host vec)
102 (tramp-file-name-method vec)))
103 (let* ((coding-system-for-read 'utf-8-unix)
104 (process-connection-type tramp-process-connection-type)
105 ;; The executable loader cannot execute setuid
106 ;; binaries, such as su.
107 (android-use-exec-loader nil)
108 (p (start-process (tramp-get-connection-name vec)
109 (tramp-get-connection-buffer vec)
110 ;; Disregard
111 ;; tramp-encoding-shell, as
112 ;; there's no guarantee that it's
113 ;; possible to execute it with
114 ;; `android-use-exec-loader' off.
115 "/system/bin/sh" "-i"))
116 (user (tramp-file-name-user vec))
117 command)
118 ;; Set sentinel. Initialize variables.
119 (set-process-sentinel p #'tramp-process-sentinel)
120 (tramp-post-process-creation p vec)
121
122 ;; Replace `login-args' place holders.
123 (setq command (format "exec su - %s || exit"
124 (or user "root")))
125
126 ;; Attempt to execute the shell inside the global mount
127 ;; namespace if requested.
128 (when tramp-androidsu-mount-global-namespace
129 (progn
130 (when (eq tramp-androidsu-su-mm-supported 'unknown)
131 ;; Change the prompt in advance so that
132 ;; tramp-adb-send-command-and-check can call
133 ;; tramp-search-regexp.
134 (tramp-adb-send-command
135 vec (format "PS1=%s"
136 (tramp-shell-quote-argument
137 tramp-end-of-output)))
138 (setq tramp-androidsu-su-mm-supported
139 ;; Detect support for `su -mm'.
140 (tramp-adb-send-command-and-check
141 vec "su -mm -c 'exit 24'" 24)))
142 (when tramp-androidsu-su-mm-supported
143 (setq command (format "exec su -mm - %s || exit"
144 (or user "root"))))))
145 ;; Send the command.
146 (tramp-message vec 3 "Sending command `%s'" command)
147 (tramp-adb-send-command vec command t t)
148 ;; Android su binaries contact a background service to
149 ;; obtain authentication; during this process, input
150 ;; received is discarded, so input cannot be
151 ;; guaranteed to reach the root shell until its prompt
152 ;; is displayed.
153 (with-current-buffer (process-buffer p)
154 (tramp-wait-for-regexp p tramp-connection-timeout
155 "#[[:space:]]*$"))
156
157 ;; Set connection-local variables.
158 (tramp-set-connection-local-variables vec)
159
160 ;; Change prompt.
161 (tramp-adb-send-command
162 vec (format "PS1=%s"
163 (tramp-shell-quote-argument tramp-end-of-output)))
164
165 ;; Disable line editing.
166 (tramp-adb-send-command
167 vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs")
168
169 ;; Dump option settings in the traces.
170 (when (>= tramp-verbose 9)
171 (tramp-adb-send-command vec "set -o"))
172
173 ;; Disable Unicode.
174 (tramp-adb-send-command vec "set +U")
175
176 ;; Disable echo expansion.
177 (tramp-adb-send-command
178 vec "stty -inlcr -onlcr -echo kill '^U' erase '^H'" t)
179
180 ;; Check whether the echo has really been disabled.
181 ;; Some implementations, like busybox, don't support
182 ;; disabling.
183 (tramp-adb-send-command vec "echo foo" t)
184 (with-current-buffer (process-buffer p)
185 (goto-char (point-min))
186 (when (looking-at-p "echo foo")
187 (tramp-set-connection-property p "remote-echo" t)
188 (tramp-message vec 5 "Remote echo still on. Ok.")
189 ;; Make sure backspaces and their echo are enabled
190 ;; and no line width magic interferes with them.
191 (tramp-adb-send-command vec
192 "stty icanon erase ^H cols 32767"
193 t)))
194
195 ;; Set the remote PATH to a suitable value.
196 (tramp-set-connection-property vec "remote-path"
197 "/system/bin:/system/xbin")
198
199 ;; Mark it as connected.
200 (tramp-set-connection-property p "connected" t))))
201
202 ;; Cleanup, and propagate the signal.
203 ((error quit)
204 (tramp-cleanup-connection vec t)
205 (signal (car err) (cdr err)))))))
206
207(defun tramp-androidsu-generate-wrapper (function)
208 "Return connection wrapper function for FUNCTION.
209Return a function which temporarily substitutes local replacements for
210the `adb' method's connection management functions around a call to
211FUNCTION."
212 (lambda (&rest args)
213 (let ((tramp-adb-wait-for-output
214 (symbol-function #'tramp-adb-wait-for-output))
215 (tramp-adb-maybe-open-connection
216 (symbol-function #'tramp-adb-maybe-open-connection)))
217 (unwind-protect
218 (progn
219 ;; tramp-adb-wait-for-output addresses problems introduced
220 ;; by the adb utility itself, not Android utilities, so
221 ;; replace it with the regular TRAMP function.
222 (fset 'tramp-adb-wait-for-output #'tramp-wait-for-output)
223 ;; Likewise, except some special treatment is necessary on
224 ;; account of flaws in Android's su implementation.
225 (fset 'tramp-adb-maybe-open-connection
226 #'tramp-androidsu-maybe-open-connection)
227 (apply function args))
228 ;; Restore the original definitions of the functions overridden
229 ;; above.
230 (fset 'tramp-adb-wait-for-output tramp-adb-wait-for-output)
231 (fset 'tramp-adb-maybe-open-connection tramp-adb-maybe-open-connection)))))
232
233(defalias 'tramp-androidsu-handle-access-file
234 (tramp-androidsu-generate-wrapper #'tramp-handle-access-file))
235
236(defalias 'tramp-androidsu-handle-add-name-to-file
237 (tramp-androidsu-generate-wrapper #'tramp-handle-add-name-to-file))
238
239(defalias 'tramp-androidsu-handle-copy-directory
240 (tramp-androidsu-generate-wrapper #'tramp-handle-copy-directory))
241
242(defalias 'tramp-androidsu-sh-handle-copy-file
243 (tramp-androidsu-generate-wrapper #'tramp-sh-handle-copy-file))
244
245(defalias 'tramp-androidsu-adb-handle-delete-directory
246 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-delete-directory))
247
248(defalias 'tramp-androidsu-adb-handle-delete-file
249 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-delete-file))
250
251(defalias 'tramp-androidsu-handle-directory-file-name
252 (tramp-androidsu-generate-wrapper #'tramp-handle-directory-file-name))
253
254(defalias 'tramp-androidsu-handle-directory-files
255 (tramp-androidsu-generate-wrapper #'tramp-handle-directory-files))
256
257(defalias 'tramp-androidsu-adb-handle-directory-files-and-attributes
258 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-directory-files-and-attributes))
259
260(defalias 'tramp-androidsu-handle-dired-uncache
261 (tramp-androidsu-generate-wrapper #'tramp-handle-dired-uncache))
262
263(defalias 'tramp-androidsu-adb-handle-exec-path
264 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-exec-path))
265
266(defalias 'tramp-androidsu-handle-expand-file-name
267 (tramp-androidsu-generate-wrapper #'tramp-handle-expand-file-name))
268
269(defalias 'tramp-androidsu-handle-file-accessible-directory-p
270 (tramp-androidsu-generate-wrapper #'tramp-handle-file-accessible-directory-p))
271
272(defalias 'tramp-androidsu-adb-handle-file-attributes
273 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-attributes))
274
275(defalias 'tramp-androidsu-handle-file-directory-p
276 (tramp-androidsu-generate-wrapper #'tramp-handle-file-directory-p))
277
278(defalias 'tramp-androidsu-handle-file-equal-p
279 (tramp-androidsu-generate-wrapper #'tramp-handle-file-equal-p))
280
281(defalias 'tramp-androidsu-adb-handle-file-executable-p
282 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-executable-p))
283
284(defalias 'tramp-androidsu-adb-handle-file-exists-p
285 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-exists-p))
286
287(defalias 'tramp-androidsu-handle-file-group-gid
288 (tramp-androidsu-generate-wrapper #'tramp-handle-file-group-gid))
289
290(defalias 'tramp-androidsu-handle-file-in-directory-p
291 (tramp-androidsu-generate-wrapper #'tramp-handle-file-in-directory-p))
292
293(defalias 'tramp-androidsu-sh-handle-file-local-copy
294 (tramp-androidsu-generate-wrapper #'tramp-sh-handle-file-local-copy))
295
296(defalias 'tramp-androidsu-handle-file-locked-p
297 (tramp-androidsu-generate-wrapper #'tramp-handle-file-locked-p))
298
299(defalias 'tramp-androidsu-handle-file-modes
300 (tramp-androidsu-generate-wrapper #'tramp-handle-file-modes))
301
302(defalias 'tramp-androidsu-adb-handle-file-name-all-completions
303 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-name-all-completions))
304
305(defalias 'tramp-androidsu-handle-file-name-as-directory
306 (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-as-directory))
307
308(defalias 'tramp-androidsu-handle-file-name-case-insensitive-p
309 (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-case-insensitive-p))
310
311(defalias 'tramp-androidsu-handle-file-name-completion
312 (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-completion))
313
314(defalias 'tramp-androidsu-handle-file-name-directory
315 (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-directory))
316
317(defalias 'tramp-androidsu-handle-file-name-nondirectory
318 (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-nondirectory))
319
320(defalias 'tramp-androidsu-handle-file-newer-than-file-p
321 (tramp-androidsu-generate-wrapper #'tramp-handle-file-newer-than-file-p))
322
323(defalias 'tramp-androidsu-handle-file-notify-add-watch
324 (tramp-androidsu-generate-wrapper #'tramp-handle-file-notify-add-watch))
325
326(defalias 'tramp-androidsu-handle-file-notify-rm-watch
327 (tramp-androidsu-generate-wrapper #'tramp-handle-file-notify-rm-watch))
328
329(defalias 'tramp-androidsu-handle-file-notify-valid-p
330 (tramp-androidsu-generate-wrapper #'tramp-handle-file-notify-valid-p))
331
332(defalias 'tramp-androidsu-adb-handle-file-readable-p
333 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-readable-p))
334
335(defalias 'tramp-androidsu-handle-file-regular-p
336 (tramp-androidsu-generate-wrapper #'tramp-handle-file-regular-p))
337
338(defalias 'tramp-androidsu-handle-file-remote-p
339 (tramp-androidsu-generate-wrapper #'tramp-handle-file-remote-p))
340
341(defalias 'tramp-androidsu-handle-file-selinux-context
342 (tramp-androidsu-generate-wrapper #'tramp-handle-file-selinux-context))
343
344(defalias 'tramp-androidsu-handle-file-symlink-p
345 (tramp-androidsu-generate-wrapper #'tramp-handle-file-symlink-p))
346
347(defalias 'tramp-androidsu-adb-handle-file-system-info
348 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-system-info))
349
350(defalias 'tramp-androidsu-handle-file-truename
351 (tramp-androidsu-generate-wrapper #'tramp-handle-file-truename))
352
353(defalias 'tramp-androidsu-handle-file-user-uid
354 (tramp-androidsu-generate-wrapper #'tramp-handle-file-user-uid))
355
356(defalias 'tramp-androidsu-adb-handle-file-writable-p
357 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-writable-p))
358
359(defalias 'tramp-androidsu-handle-find-backup-file-name
360 (tramp-androidsu-generate-wrapper #'tramp-handle-find-backup-file-name))
361
362(defalias 'tramp-androidsu-handle-insert-directory
363 (tramp-androidsu-generate-wrapper #'tramp-handle-insert-directory))
364
365(defalias 'tramp-androidsu-handle-insert-file-contents
366 (tramp-androidsu-generate-wrapper #'tramp-handle-insert-file-contents))
367
368(defalias 'tramp-androidsu-handle-list-system-processes
369 (tramp-androidsu-generate-wrapper #'tramp-handle-list-system-processes))
370
371(defalias 'tramp-androidsu-handle-load
372 (tramp-androidsu-generate-wrapper #'tramp-handle-load))
373
374(defalias 'tramp-androidsu-handle-lock-file
375 (tramp-androidsu-generate-wrapper #'tramp-handle-lock-file))
376
377(defalias 'tramp-androidsu-handle-make-auto-save-file-name
378 (tramp-androidsu-generate-wrapper #'tramp-handle-make-auto-save-file-name))
379
380(defalias 'tramp-androidsu-adb-handle-make-directory
381 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-make-directory))
382
383(defalias 'tramp-androidsu-handle-make-lock-file-name
384 (tramp-androidsu-generate-wrapper #'tramp-handle-make-lock-file-name))
385
386(defalias 'tramp-androidsu-handle-make-nearby-temp-file
387 (tramp-androidsu-generate-wrapper #'tramp-handle-make-nearby-temp-file))
388
389(defalias 'tramp-androidsu-adb-handle-make-process
390 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-make-process))
391
392(defalias 'tramp-androidsu-sh-handle-make-symbolic-link
393 (tramp-androidsu-generate-wrapper
394 #'tramp-sh-handle-make-symbolic-link))
395
396(defalias 'tramp-androidsu-handle-memory-info
397 (tramp-androidsu-generate-wrapper #'tramp-handle-memory-info))
398
399(defalias 'tramp-androidsu-handle-process-attributes
400 (tramp-androidsu-generate-wrapper #'tramp-handle-process-attributes))
401
402(defalias 'tramp-androidsu-adb-handle-process-file
403 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-process-file))
404
405(defalias 'tramp-androidsu-sh-handle-rename-file
406 (tramp-androidsu-generate-wrapper #'tramp-sh-handle-rename-file))
407
408(defalias 'tramp-androidsu-adb-handle-set-file-modes
409 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-set-file-modes))
410
411(defalias 'tramp-androidsu-adb-handle-set-file-times
412 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-set-file-times))
413
414(defalias 'tramp-androidsu-handle-set-visited-file-modtime
415 (tramp-androidsu-generate-wrapper #'tramp-handle-set-visited-file-modtime))
416
417(defalias 'tramp-androidsu-handle-shell-command
418 (tramp-androidsu-generate-wrapper #'tramp-handle-shell-command))
419
420(defalias 'tramp-androidsu-handle-start-file-process
421 (tramp-androidsu-generate-wrapper #'tramp-handle-start-file-process))
422
423(defalias 'tramp-androidsu-handle-substitute-in-file-name
424 (tramp-androidsu-generate-wrapper #'tramp-handle-substitute-in-file-name))
425
426(defalias 'tramp-androidsu-handle-temporary-file-directory
427 (tramp-androidsu-generate-wrapper #'tramp-handle-temporary-file-directory))
428
429(defalias 'tramp-androidsu-adb-handle-get-remote-gid
430 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-gid))
431
432(defalias 'tramp-androidsu-adb-handle-get-remote-groups
433 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-groups))
434
435(defalias 'tramp-androidsu-adb-handle-get-remote-uid
436 (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-uid))
437
438(defalias 'tramp-androidsu-handle-unlock-file
439 (tramp-androidsu-generate-wrapper #'tramp-handle-unlock-file))
440
441(defalias 'tramp-androidsu-handle-verify-visited-file-modtime
442 (tramp-androidsu-generate-wrapper #'tramp-handle-verify-visited-file-modtime))
443
444(defalias 'tramp-androidsu-sh-handle-write-region
445 (tramp-androidsu-generate-wrapper #'tramp-sh-handle-write-region))
446
447;;;###tramp-autoload
448(defconst tramp-androidsu-file-name-handler-alist
449 '(;; `abbreviate-file-name' performed by default handler.
450 (access-file . tramp-androidsu-handle-access-file)
451 (add-name-to-file . tramp-androidsu-handle-add-name-to-file)
452 ;; `byte-compiler-base-file-name' performed by default handler.
453 (copy-directory . tramp-androidsu-handle-copy-directory)
454 (copy-file . tramp-androidsu-sh-handle-copy-file)
455 (delete-directory . tramp-androidsu-adb-handle-delete-directory)
456 (delete-file . tramp-androidsu-adb-handle-delete-file)
457 ;; `diff-latest-backup-file' performed by default handler.
458 (directory-file-name . tramp-androidsu-handle-directory-file-name)
459 (directory-files . tramp-androidsu-handle-directory-files)
460 (directory-files-and-attributes
461 . tramp-androidsu-adb-handle-directory-files-and-attributes)
462 (dired-compress-file . ignore)
463 (dired-uncache . tramp-androidsu-handle-dired-uncache)
464 (exec-path . tramp-androidsu-adb-handle-exec-path)
465 (expand-file-name . tramp-androidsu-handle-expand-file-name)
466 (file-accessible-directory-p . tramp-androidsu-handle-file-accessible-directory-p)
467 (file-acl . ignore)
468 (file-attributes . tramp-androidsu-adb-handle-file-attributes)
469 (file-directory-p . tramp-androidsu-handle-file-directory-p)
470 (file-equal-p . tramp-androidsu-handle-file-equal-p)
471 (file-executable-p . tramp-androidsu-adb-handle-file-executable-p)
472 (file-exists-p . tramp-androidsu-adb-handle-file-exists-p)
473 (file-group-gid . tramp-androidsu-handle-file-group-gid)
474 (file-in-directory-p . tramp-androidsu-handle-file-in-directory-p)
475 (file-local-copy . tramp-androidsu-sh-handle-file-local-copy)
476 (file-locked-p . tramp-androidsu-handle-file-locked-p)
477 (file-modes . tramp-androidsu-handle-file-modes)
478 (file-name-all-completions . tramp-androidsu-adb-handle-file-name-all-completions)
479 (file-name-as-directory . tramp-androidsu-handle-file-name-as-directory)
480 (file-name-case-insensitive-p . tramp-androidsu-handle-file-name-case-insensitive-p)
481 (file-name-completion . tramp-androidsu-handle-file-name-completion)
482 (file-name-directory . tramp-androidsu-handle-file-name-directory)
483 (file-name-nondirectory . tramp-androidsu-handle-file-name-nondirectory)
484 ;; `file-name-sans-versions' performed by default handler.
485 (file-newer-than-file-p . tramp-androidsu-handle-file-newer-than-file-p)
486 (file-notify-add-watch . tramp-androidsu-handle-file-notify-add-watch)
487 (file-notify-rm-watch . tramp-androidsu-handle-file-notify-rm-watch)
488 (file-notify-valid-p . tramp-androidsu-handle-file-notify-valid-p)
489 (file-ownership-preserved-p . ignore)
490 (file-readable-p . tramp-androidsu-adb-handle-file-readable-p)
491 (file-regular-p . tramp-androidsu-handle-file-regular-p)
492 (file-remote-p . tramp-androidsu-handle-file-remote-p)
493 (file-selinux-context . tramp-androidsu-handle-file-selinux-context)
494 (file-symlink-p . tramp-androidsu-handle-file-symlink-p)
495 (file-system-info . tramp-androidsu-adb-handle-file-system-info)
496 (file-truename . tramp-androidsu-handle-file-truename)
497 (file-user-uid . tramp-androidsu-handle-file-user-uid)
498 (file-writable-p . tramp-androidsu-adb-handle-file-writable-p)
499 (find-backup-file-name . tramp-androidsu-handle-find-backup-file-name)
500 ;; `get-file-buffer' performed by default handler.
501 (insert-directory . tramp-androidsu-handle-insert-directory)
502 (insert-file-contents . tramp-androidsu-handle-insert-file-contents)
503 (list-system-processes . tramp-androidsu-handle-list-system-processes)
504 (load . tramp-androidsu-handle-load)
505 (lock-file . tramp-androidsu-handle-lock-file)
506 (make-auto-save-file-name . tramp-androidsu-handle-make-auto-save-file-name)
507 (make-directory . tramp-androidsu-adb-handle-make-directory)
508 (make-directory-internal . ignore)
509 (make-lock-file-name . tramp-androidsu-handle-make-lock-file-name)
510 (make-nearby-temp-file . tramp-androidsu-handle-make-nearby-temp-file)
511 (make-process . tramp-androidsu-adb-handle-make-process)
512 (make-symbolic-link . tramp-androidsu-sh-handle-make-symbolic-link)
513 (memory-info . tramp-androidsu-handle-memory-info)
514 (process-attributes . tramp-androidsu-handle-process-attributes)
515 (process-file . tramp-androidsu-adb-handle-process-file)
516 (rename-file . tramp-androidsu-sh-handle-rename-file)
517 (set-file-acl . ignore)
518 (set-file-modes . tramp-androidsu-adb-handle-set-file-modes)
519 (set-file-selinux-context . ignore)
520 (set-file-times . tramp-androidsu-adb-handle-set-file-times)
521 (set-visited-file-modtime . tramp-androidsu-handle-set-visited-file-modtime)
522 (shell-command . tramp-androidsu-handle-shell-command)
523 (start-file-process . tramp-androidsu-handle-start-file-process)
524 (substitute-in-file-name . tramp-androidsu-handle-substitute-in-file-name)
525 (temporary-file-directory . tramp-androidsu-handle-temporary-file-directory)
526 (tramp-get-home-directory . ignore)
527 (tramp-get-remote-gid . tramp-androidsu-adb-handle-get-remote-gid)
528 (tramp-get-remote-groups . tramp-androidsu-adb-handle-get-remote-groups)
529 (tramp-get-remote-uid . tramp-androidsu-adb-handle-get-remote-uid)
530 (tramp-set-file-uid-gid . ignore)
531 (unhandled-file-name-directory . ignore)
532 (unlock-file . tramp-androidsu-handle-unlock-file)
533 (vc-registered . ignore)
534 (verify-visited-file-modtime . tramp-androidsu-handle-verify-visited-file-modtime)
535 (write-region . tramp-androidsu-sh-handle-write-region))
536 "Alist of TRAMP handler functions for superuser sessions on Android.")
537
538;; It must be a `defsubst' in order to push the whole code into
539;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
540;;;###tramp-autoload
541(defsubst tramp-androidsu-file-name-p (vec-or-filename)
542 "Check whether VEC-OR-FILENAME is for the `androidsu' method."
543 (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
544 (equal (tramp-file-name-method vec) tramp-androidsu-method)))
545
546;;;###tramp-autoload
547(defun tramp-androidsu-file-name-handler (operation &rest args)
548 "Invoke the `androidsu' handler for OPERATION.
549First arg specifies the OPERATION, second arg is a list of
550arguments to pass to the OPERATION."
551 (if-let ((fn (assoc operation tramp-androidsu-file-name-handler-alist)))
552 (prog1 (save-match-data (apply (cdr fn) args))
553 (setq tramp-debug-message-fnh-function (cdr fn)))
554 (prog1 (tramp-run-real-handler operation args)
555 (setq tramp-debug-message-fnh-function operation))))
556
557;;;###tramp-autoload
558(tramp--with-startup
559 (tramp-register-foreign-file-name-handler
560 #'tramp-androidsu-file-name-p #'tramp-androidsu-file-name-handler))
561
562(connection-local-set-profile-variables
563 'tramp-adb-connection-local-default-ps-profile
564 tramp-adb-connection-local-default-ps-variables)
565
566(with-eval-after-load 'shell
567 (connection-local-set-profiles
568 `(:application tramp :protocol ,tramp-adb-method)
569 'tramp-adb-connection-local-default-shell-profile
570 'tramp-adb-connection-local-default-ps-profile))
571
572(add-hook 'tramp-unload-hook
573 (lambda ()
574 (unload-feature 'tramp-androidsu 'force)))
575
576(provide 'tramp-androidsu)
577;;; 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."
387;;;###autoload 387;;;###autoload
388(progn (defun tramp-register-archive-autoload-file-name-handler () 388(progn (defun tramp-register-archive-autoload-file-name-handler ()
389 "Add archive file name handler to `file-name-handler-alist'." 389 "Add archive file name handler to `file-name-handler-alist'."
390 ;; Do not use read syntax #' for `tramp-archive-file-name-handler', it
391 ;; isn't autoloaded.
390 (when (and tramp-archive-enabled 392 (when (and tramp-archive-enabled
391 (not 393 (not
392 (rassq 'tramp-archive-file-name-handler file-name-handler-alist))) 394 (rassq 'tramp-archive-file-name-handler file-name-handler-alist)))
@@ -443,7 +445,7 @@ arguments to pass to the OPERATION."
443 (and (tramp-archive-file-name-p name) 445 (and (tramp-archive-file-name-p name)
444 (match-string 2 name))) 446 (match-string 2 name)))
445 447
446(defvar tramp-archive-hash (make-hash-table :test 'equal) 448(defvar tramp-archive-hash (make-hash-table :test #'equal)
447 "Hash table for archive local copies. 449 "Hash table for archive local copies.
448The hash key is the archive name. The value is a cons of the 450The hash key is the archive name. The value is a cons of the
449used `tramp-file-name' structure for tramp-gvfs, and the file 451used `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."
144(defun tramp-get-file-property (key file property &optional default) 144(defun tramp-get-file-property (key file property &optional default)
145 "Get the PROPERTY of FILE from the cache context of KEY. 145 "Get the PROPERTY of FILE from the cache context of KEY.
146Return DEFAULT if not set." 146Return DEFAULT if not set."
147 ;; Unify localname. Remove hop from `tramp-file-name' structure.
148 (setq key (tramp-file-name-unify key file)) 147 (setq key (tramp-file-name-unify key file))
149 (if (eq key tramp-cache-undefined) default 148 (if (eq key tramp-cache-undefined) default
150 (let* ((hash (tramp-get-hash-table key)) 149 (let* ((hash (tramp-get-hash-table key))
@@ -191,7 +190,6 @@ Return DEFAULT if not set."
191(defun tramp-set-file-property (key file property value) 190(defun tramp-set-file-property (key file property value)
192 "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. 191 "Set the PROPERTY of FILE to VALUE, in the cache context of KEY.
193Return VALUE." 192Return VALUE."
194 ;; Unify localname. Remove hop from `tramp-file-name' structure.
195 (setq key (tramp-file-name-unify key file)) 193 (setq key (tramp-file-name-unify key file))
196 (if (eq key tramp-cache-undefined) value 194 (if (eq key tramp-cache-undefined) value
197 (let ((hash (tramp-get-hash-table key))) 195 (let ((hash (tramp-get-hash-table key)))
@@ -224,7 +222,6 @@ Return VALUE."
224;;;###tramp-autoload 222;;;###tramp-autoload
225(defun tramp-flush-file-property (key file property) 223(defun tramp-flush-file-property (key file property)
226 "Remove PROPERTY of FILE in the cache context of KEY." 224 "Remove PROPERTY of FILE in the cache context of KEY."
227 ;; Unify localname. Remove hop from `tramp-file-name' structure.
228 (setq key (tramp-file-name-unify key file)) 225 (setq key (tramp-file-name-unify key file))
229 (unless (eq key tramp-cache-undefined) 226 (unless (eq key tramp-cache-undefined)
230 (remhash property (tramp-get-hash-table key)) 227 (remhash property (tramp-get-hash-table key))
@@ -239,7 +236,6 @@ Return VALUE."
239 ;; `file-name-directory' can return nil, for example for "~". 236 ;; `file-name-directory' can return nil, for example for "~".
240 (when-let ((file (file-name-directory file)) 237 (when-let ((file (file-name-directory file))
241 (file (directory-file-name file))) 238 (file (directory-file-name file)))
242 ;; Unify localname. Remove hop from `tramp-file-name' structure.
243 (setq key (tramp-file-name-unify key file)) 239 (setq key (tramp-file-name-unify key file))
244 (unless (eq key tramp-cache-undefined) 240 (unless (eq key tramp-cache-undefined)
245 (dolist (property (hash-table-keys (tramp-get-hash-table key))) 241 (dolist (property (hash-table-keys (tramp-get-hash-table key)))
@@ -254,7 +250,6 @@ Return VALUE."
254(defun tramp-flush-file-properties (key file) 250(defun tramp-flush-file-properties (key file)
255 "Remove all properties of FILE in the cache context of KEY." 251 "Remove all properties of FILE in the cache context of KEY."
256 (let ((truename (tramp-get-file-property key file "file-truename"))) 252 (let ((truename (tramp-get-file-property key file "file-truename")))
257 ;; Unify localname. Remove hop from `tramp-file-name' structure.
258 (setq key (tramp-file-name-unify key file)) 253 (setq key (tramp-file-name-unify key file))
259 (unless (eq key tramp-cache-undefined) 254 (unless (eq key tramp-cache-undefined)
260 (tramp-message key 8 "%s" (tramp-file-name-localname key)) 255 (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."
338 "Save PROPERTY, run BODY, reset PROPERTY. 333 "Save PROPERTY, run BODY, reset PROPERTY.
339Preserve timestamps." 334Preserve timestamps."
340 (declare (indent 3) (debug t)) 335 (declare (indent 3) (debug t))
341 `(progn 336 `(let* ((key (tramp-file-name-unify ,key ,file))
342 ;; Unify localname. Remove hop from `tramp-file-name' structure. 337 (hash (tramp-get-hash-table key))
343 (setf ,key (tramp-file-name-unify ,key ,file)) 338 (cached (and (hash-table-p hash) (gethash ,property hash))))
344 (let* ((hash (tramp-get-hash-table ,key)) 339 (unwind-protect (progn ,@body)
345 (cached (and (hash-table-p hash) (gethash ,property hash)))) 340 ;; Reset PROPERTY. Recompute hash, it could have been flushed.
346 (unwind-protect (progn ,@body) 341 (setq hash (tramp-get-hash-table key))
347 ;; Reset PROPERTY. Recompute hash, it could have been flushed. 342 (if (consp cached)
348 (setq hash (tramp-get-hash-table ,key)) 343 (puthash ,property cached hash)
349 (if (consp cached) 344 (remhash ,property hash)))))
350 (puthash ,property cached hash)
351 (remhash ,property hash))))))
352 345
353;;;###tramp-autoload 346;;;###tramp-autoload
354(defmacro with-tramp-saved-file-properties (key file properties &rest body) 347(defmacro with-tramp-saved-file-properties (key file properties &rest body)
@@ -356,22 +349,20 @@ Preserve timestamps."
356PROPERTIES is a list of file properties (strings). 349PROPERTIES is a list of file properties (strings).
357Preserve timestamps." 350Preserve timestamps."
358 (declare (indent 3) (debug t)) 351 (declare (indent 3) (debug t))
359 `(progn 352 `(let* ((key (tramp-file-name-unify ,key ,file))
360 ;; Unify localname. Remove hop from `tramp-file-name' structure. 353 (hash (tramp-get-hash-table key))
361 (setf ,key (tramp-file-name-unify ,key ,file)) 354 (values
362 (let* ((hash (tramp-get-hash-table ,key)) 355 (and (hash-table-p hash)
363 (values 356 (mapcar
364 (and (hash-table-p hash) 357 (lambda (property) (cons property (gethash property hash)))
365 (mapcar 358 ,properties))))
366 (lambda (property) (cons property (gethash property hash))) 359 (unwind-protect (progn ,@body)
367 ,properties)))) 360 ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
368 (unwind-protect (progn ,@body) 361 (setq hash (tramp-get-hash-table key))
369 ;; Reset PROPERTIES. Recompute hash, it could have been flushed. 362 (dolist (value values)
370 (setq hash (tramp-get-hash-table ,key)) 363 (if (consp (cdr value))
371 (dolist (value values) 364 (puthash (car value) (cdr value) hash)
372 (if (consp (cdr value)) 365 (remhash (car value) hash))))))
373 (puthash (car value) (cdr value) hash)
374 (remhash (car value) hash)))))))
375 366
376;;; -- Properties -- 367;;; -- Properties --
377 368
@@ -473,38 +464,36 @@ used to cache connection properties of the local machine."
473(defmacro with-tramp-saved-connection-property (key property &rest body) 464(defmacro with-tramp-saved-connection-property (key property &rest body)
474 "Save PROPERTY, run BODY, reset PROPERTY." 465 "Save PROPERTY, run BODY, reset PROPERTY."
475 (declare (indent 2) (debug t)) 466 (declare (indent 2) (debug t))
476 `(progn 467 `(let* ((key (tramp-file-name-unify ,key))
477 (setf ,key (tramp-file-name-unify ,key)) 468 (hash (tramp-get-hash-table key))
478 (let* ((hash (tramp-get-hash-table ,key)) 469 (cached (and (hash-table-p hash)
479 (cached (and (hash-table-p hash) 470 (gethash ,property hash tramp-cache-undefined))))
480 (gethash ,property hash tramp-cache-undefined)))) 471 (unwind-protect (progn ,@body)
481 (unwind-protect (progn ,@body) 472 ;; Reset PROPERTY. Recompute hash, it could have been flushed.
482 ;; Reset PROPERTY. Recompute hash, it could have been flushed. 473 (setq hash (tramp-get-hash-table key))
483 (setq hash (tramp-get-hash-table ,key)) 474 (if (not (eq cached tramp-cache-undefined))
484 (if (not (eq cached tramp-cache-undefined)) 475 (puthash ,property cached hash)
485 (puthash ,property cached hash) 476 (remhash ,property hash)))))
486 (remhash ,property hash))))))
487 477
488;;;###tramp-autoload 478;;;###tramp-autoload
489(defmacro with-tramp-saved-connection-properties (key properties &rest body) 479(defmacro with-tramp-saved-connection-properties (key properties &rest body)
490 "Save PROPERTIES, run BODY, reset PROPERTIES. 480 "Save PROPERTIES, run BODY, reset PROPERTIES.
491PROPERTIES is a list of file properties (strings)." 481PROPERTIES is a list of file properties (strings)."
492 (declare (indent 2) (debug t)) 482 (declare (indent 2) (debug t))
493 `(progn 483 `(let* ((key (tramp-file-name-unify ,key))
494 (setf ,key (tramp-file-name-unify ,key)) 484 (hash (tramp-get-hash-table key))
495 (let* ((hash (tramp-get-hash-table ,key)) 485 (values
496 (values 486 (mapcar
497 (mapcar 487 (lambda (property)
498 (lambda (property) 488 (cons property (gethash property hash tramp-cache-undefined)))
499 (cons property (gethash property hash tramp-cache-undefined))) 489 ,properties)))
500 ,properties))) 490 (unwind-protect (progn ,@body)
501 (unwind-protect (progn ,@body) 491 ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
502 ;; Reset PROPERTIES. Recompute hash, it could have been flushed. 492 (setq hash (tramp-get-hash-table key))
503 (setq hash (tramp-get-hash-table ,key)) 493 (dolist (value values)
504 (dolist (value values) 494 (if (not (eq (cdr value) tramp-cache-undefined))
505 (if (not (eq (cdr value) tramp-cache-undefined)) 495 (puthash (car value) (cdr value) hash)
506 (puthash (car value) (cdr value) hash) 496 (remhash (car value) hash))))))
507 (remhash (car value) hash)))))))
508 497
509;;;###tramp-autoload 498;;;###tramp-autoload
510(defun tramp-cache-print (table) 499(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'."
309 309
310;; Macro `connection-local-p' is new in Emacs 30.1. 310;; Macro `connection-local-p' is new in Emacs 30.1.
311(if (macrop 'connection-local-p) 311(if (macrop 'connection-local-p)
312 (defalias 'tramp-compat-connection-local-p #'connection-local-p) 312 (defalias 'tramp-compat-connection-local-p 'connection-local-p)
313 (defmacro tramp-compat-connection-local-p (variable) 313 (defmacro tramp-compat-connection-local-p (variable)
314 "Non-nil if VARIABLE has a connection-local binding in `default-directory'." 314 "Non-nil if VARIABLE has a connection-local binding in `default-directory'."
315 `(let (connection-local-variables-alist file-local-variables-alist) 315 `(let (connection-local-variables-alist file-local-variables-alist)
@@ -337,6 +337,8 @@ Also see `ignore'."
337;; 337;;
338;; * Starting with Emacs 29.1, use `buffer-match-p'. 338;; * Starting with Emacs 29.1, use `buffer-match-p'.
339;; 339;;
340;; * Starting with Emacs 29.1, use `string-split'.
341;;
340;; * Starting with Emacs 30.1, there is `handler-bind'. Use it 342;; * Starting with Emacs 30.1, there is `handler-bind'. Use it
341;; instead of `condition-case' when the origin of an error shall be 343;; instead of `condition-case' when the origin of an error shall be
342;; kept, for example when the HANDLER propagates the error with 344;; 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 @@
31;; Open a file on a running Docker container: 31;; Open a file on a running Docker container:
32;; 32;;
33;; C-x C-f /docker:USER@CONTAINER:/path/to/file 33;; C-x C-f /docker:USER@CONTAINER:/path/to/file
34;; C-x C-f /dockercp:USER@CONTAINER:/path/to/file
34;; 35;;
35;; or Podman: 36;; or Podman:
36;; 37;;
37;; C-x C-f /podman:USER@CONTAINER:/path/to/file 38;; C-x C-f /podman:USER@CONTAINER:/path/to/file
39;; C-x C-f /podmancp:USER@CONTAINER:/path/to/file
38;; 40;;
39;; Where: 41;; Where:
40;; USER is the user on the container to connect as (optional). 42;; USER is the user on the container to connect as (optional).
41;; CONTAINER is the container to connect to. 43;; CONTAINER is the container to connect to.
42;; 44;;
45;; "docker" and "podman" are inline methods, "dockercp" and "podmancp"
46;; are out-of-band methods.
47;;
43;; 48;;
44;; 49;;
45;; Open file in a Kubernetes container: 50;; Open file in a Kubernetes container:
@@ -142,10 +147,20 @@ If it is nil, the default context will be used."
142 "Tramp method name to use to connect to Docker containers.") 147 "Tramp method name to use to connect to Docker containers.")
143 148
144;;;###tramp-autoload 149;;;###tramp-autoload
150(defconst tramp-dockercp-method "dockercp"
151 "Tramp method name to use to connect to Docker containers.
152This is for out-of-band connections.")
153
154;;;###tramp-autoload
145(defconst tramp-podman-method "podman" 155(defconst tramp-podman-method "podman"
146 "Tramp method name to use to connect to Podman containers.") 156 "Tramp method name to use to connect to Podman containers.")
147 157
148;;;###tramp-autoload 158;;;###tramp-autoload
159(defconst tramp-podmancp-method "podmancp"
160 "Tramp method name to use to connect to Podman containers.
161This is for out-of-band connections.")
162
163;;;###tramp-autoload
149(defconst tramp-kubernetes-method "kubernetes" 164(defconst tramp-kubernetes-method "kubernetes"
150 "Tramp method name to use to connect to Kubernetes containers.") 165 "Tramp method name to use to connect to Kubernetes containers.")
151 166
@@ -183,7 +198,8 @@ BODY is the backend specific code."
183(defun tramp-container--completion-function (method) 198(defun tramp-container--completion-function (method)
184 "List running containers available for connection. 199 "List running containers available for connection.
185METHOD is the Tramp method to be used for \"ps\", either 200METHOD is the Tramp method to be used for \"ps\", either
186`tramp-docker-method' or `tramp-podman-method'. 201`tramp-docker-method', `tramp-dockercp-method', `tramp-podman-method',
202or `tramp-podmancp-method'.
187 203
188This function is used by `tramp-set-completion-function', please 204This function is used by `tramp-set-completion-function', please
189see its function help for a description of the format." 205see its function help for a description of the format."
@@ -376,6 +392,23 @@ see its function help for a description of the format."
376 (tramp-remote-shell-args ("-i" "-c")))) 392 (tramp-remote-shell-args ("-i" "-c"))))
377 393
378 (add-to-list 'tramp-methods 394 (add-to-list 'tramp-methods
395 `(,tramp-dockercp-method
396 (tramp-login-program ,tramp-docker-program)
397 (tramp-login-args (("exec")
398 ("-it")
399 ("-u" "%u")
400 ("%h")
401 ("%l")))
402 (tramp-direct-async (,tramp-default-remote-shell "-c"))
403 (tramp-remote-shell ,tramp-default-remote-shell)
404 (tramp-remote-shell-login ("-l"))
405 (tramp-remote-shell-args ("-i" "-c"))
406 (tramp-copy-program ,tramp-docker-program)
407 (tramp-copy-args (("cp")))
408 (tramp-copy-file-name (("%h" ":") ("%f")))
409 (tramp-copy-recursive t)))
410
411 (add-to-list 'tramp-methods
379 `(,tramp-podman-method 412 `(,tramp-podman-method
380 (tramp-login-program ,tramp-podman-program) 413 (tramp-login-program ,tramp-podman-program)
381 (tramp-login-args (("exec") 414 (tramp-login-args (("exec")
@@ -389,6 +422,23 @@ see its function help for a description of the format."
389 (tramp-remote-shell-args ("-i" "-c")))) 422 (tramp-remote-shell-args ("-i" "-c"))))
390 423
391 (add-to-list 'tramp-methods 424 (add-to-list 'tramp-methods
425 `(,tramp-podmancp-method
426 (tramp-login-program ,tramp-podman-program)
427 (tramp-login-args (("exec")
428 ("-it")
429 ("-u" "%u")
430 ("%h")
431 ("%l")))
432 (tramp-direct-async (,tramp-default-remote-shell "-c"))
433 (tramp-remote-shell ,tramp-default-remote-shell)
434 (tramp-remote-shell-login ("-l"))
435 (tramp-remote-shell-args ("-i" "-c"))
436 (tramp-copy-program ,tramp-podman-program)
437 (tramp-copy-args (("cp")))
438 (tramp-copy-file-name (("%h" ":") ("%f")))
439 (tramp-copy-recursive t)))
440
441 (add-to-list 'tramp-methods
392 `(,tramp-kubernetes-method 442 `(,tramp-kubernetes-method
393 (tramp-login-program ,tramp-kubernetes-program) 443 (tramp-login-program ,tramp-kubernetes-program)
394 (tramp-login-args (("%x") ; context and namespace. 444 (tramp-login-args (("%x") ; context and namespace.
@@ -432,10 +482,18 @@ see its function help for a description of the format."
432 `((tramp-container--completion-function ,tramp-docker-method))) 482 `((tramp-container--completion-function ,tramp-docker-method)))
433 483
434 (tramp-set-completion-function 484 (tramp-set-completion-function
485 tramp-dockercp-method
486 `((tramp-container--completion-function ,tramp-dockercp-method)))
487
488 (tramp-set-completion-function
435 tramp-podman-method 489 tramp-podman-method
436 `((tramp-container--completion-function ,tramp-podman-method))) 490 `((tramp-container--completion-function ,tramp-podman-method)))
437 491
438 (tramp-set-completion-function 492 (tramp-set-completion-function
493 tramp-podmancp-method
494 `((tramp-container--completion-function ,tramp-podmancp-method)))
495
496 (tramp-set-completion-function
439 tramp-kubernetes-method 497 tramp-kubernetes-method
440 `((tramp-kubernetes--completion-function ,tramp-kubernetes-method))) 498 `((tramp-kubernetes--completion-function ,tramp-kubernetes-method)))
441 499
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.")
888 "Invoke the GVFS related OPERATION and ARGS. 888 "Invoke the GVFS related OPERATION and ARGS.
889First arg specifies the OPERATION, second arg is a list of 889First arg specifies the OPERATION, second arg is a list of
890arguments to pass to the OPERATION." 890arguments to pass to the OPERATION."
891 (unless tramp-gvfs-enabled 891 ;; `file-remote-p' must not return an error. (Bug#68976)
892 (unless (or tramp-gvfs-enabled (eq operation 'file-remote-p))
892 (tramp-user-error nil "Package `tramp-gvfs' not supported")) 893 (tramp-user-error nil "Package `tramp-gvfs' not supported"))
893 (if-let ((filename (apply #'tramp-file-name-for-operation operation args)) 894 (if-let ((filename (apply #'tramp-file-name-for-operation operation args))
894 (tramp-gvfs-dbus-event-vector 895 (tramp-gvfs-dbus-event-vector
@@ -2293,8 +2294,8 @@ connection if a previous connection has died for some reason."
2293 ;; indicated by the "mounted" signal, i.e. the 2294 ;; indicated by the "mounted" signal, i.e. the
2294 ;; "fuse-mountpoint" file property. 2295 ;; "fuse-mountpoint" file property.
2295 (with-timeout 2296 (with-timeout
2296 ((or (tramp-get-method-parameter vec 'tramp-connection-timeout) 2297 ((tramp-get-method-parameter
2297 tramp-connection-timeout) 2298 vec 'tramp-connection-timeout tramp-connection-timeout)
2298 (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) 2299 (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
2299 (tramp-error 2300 (tramp-error
2300 vec 'file-error 2301 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'."
69 (when minibuffer-completing-file-name 69 (when minibuffer-completing-file-name
70 (setq tramp-rfn-eshadow-overlay 70 (setq tramp-rfn-eshadow-overlay
71 (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end))) 71 (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end)))
72 ;; Copy rfn-eshadow-overlay properties. 72 ;; Copy `rfn-eshadow-overlay' properties.
73 (let ((props (overlay-properties rfn-eshadow-overlay))) 73 (let ((props (overlay-properties rfn-eshadow-overlay)))
74 (while props 74 (while props
75 ;; The `field' property prevents correct minibuffer 75 ;; 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)."
353If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE 353If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE
354forces the backtrace even if `tramp-verbose' is less than 10. 354forces the backtrace even if `tramp-verbose' is less than 10.
355This function is meant for debugging purposes." 355This function is meant for debugging purposes."
356 (declare (tramp-suppress-trace t))
356 (let ((tramp-verbose (if force 10 tramp-verbose))) 357 (let ((tramp-verbose (if force 10 tramp-verbose)))
357 (when (>= tramp-verbose 10) 358 (when (>= tramp-verbose 10)
358 (tramp-message 359 (tramp-message
@@ -364,6 +365,7 @@ VEC-OR-PROC identifies the connection to use, SIGNAL is the
364signal identifier to be raised, remaining arguments passed to 365signal identifier to be raised, remaining arguments passed to
365`tramp-message'. Finally, signal SIGNAL is raised with 366`tramp-message'. Finally, signal SIGNAL is raised with
366FMT-STRING and ARGUMENTS." 367FMT-STRING and ARGUMENTS."
368 (declare (tramp-suppress-trace t))
367 (let (signal-hook-function) 369 (let (signal-hook-function)
368 (tramp-backtrace vec-or-proc) 370 (tramp-backtrace vec-or-proc)
369 (unless arguments 371 (unless arguments
@@ -391,6 +393,7 @@ tramp-tests.el.")
391 "Emit an error, and show BUF. 393 "Emit an error, and show BUF.
392If BUF is nil, show the connection buf. Wait for 30\", or until 394If BUF is nil, show the connection buf. Wait for 30\", or until
393an input event arrives. The other arguments are passed to `tramp-error'." 395an input event arrives. The other arguments are passed to `tramp-error'."
396 (declare (tramp-suppress-trace t))
394 (save-window-excursion 397 (save-window-excursion
395 (let* ((buf (or (and (bufferp buf) buf) 398 (let* ((buf (or (and (bufferp buf) buf)
396 (and (processp vec-or-proc) (process-buffer vec-or-proc)) 399 (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'."
424 427
425(defsubst tramp-user-error (vec-or-proc fmt-string &rest arguments) 428(defsubst tramp-user-error (vec-or-proc fmt-string &rest arguments)
426 "Signal a user error (or \"pilot error\")." 429 "Signal a user error (or \"pilot error\")."
430 (declare (tramp-suppress-trace t))
427 (unwind-protect 431 (unwind-protect
428 (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) 432 (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments)
429 ;; Save exit. 433 ;; 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 @@
38(declare-function dired-compress-file "dired-aux") 38(declare-function dired-compress-file "dired-aux")
39(declare-function dired-remove-file "dired-aux") 39(declare-function dired-remove-file "dired-aux")
40(defvar dired-compress-file-suffixes) 40(defvar dired-compress-file-suffixes)
41(defvar ls-lisp-use-insert-directory-program)
42;; Added in Emacs 28.1. 41;; Added in Emacs 28.1.
43(defvar process-file-return-signal-string) 42(defvar process-file-return-signal-string)
44(defvar vc-handled-backends) 43(defvar vc-handled-backends)
@@ -283,6 +282,7 @@ The string is used in `tramp-methods'.")
283 (tramp-copy-program "nc") 282 (tramp-copy-program "nc")
284 ;; We use "-v" for better error tracking. 283 ;; We use "-v" for better error tracking.
285 (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) 284 (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r")))
285 (tramp-copy-file-name (("%f")))
286 (tramp-remote-copy-program "nc") 286 (tramp-remote-copy-program "nc")
287 ;; We use "-p" as required for newer busyboxes. For older 287 ;; We use "-p" as required for newer busyboxes. For older
288 ;; busybox/nc versions, the value must be (("-l") ("%r")). This 288 ;; busybox/nc versions, the value must be (("-l") ("%r")). This
@@ -429,6 +429,9 @@ The string is used in `tramp-methods'.")
429 eos) 429 eos)
430 nil ,(user-login-name)))) 430 nil ,(user-login-name))))
431 431
432(defconst tramp-default-copy-file-name '(("%u" "@") ("%h" ":") ("%f"))
433 "Default `tramp-copy-file-name' entry for out-of-band methods.")
434
432;;;###tramp-autoload 435;;;###tramp-autoload
433(defconst tramp-completion-function-alist-rsh 436(defconst tramp-completion-function-alist-rsh
434 '((tramp-parse-rhosts "/etc/hosts.equiv") 437 '((tramp-parse-rhosts "/etc/hosts.equiv")
@@ -548,6 +551,7 @@ shell from reading its init file."
548 (tramp-terminal-prompt-regexp tramp-action-terminal) 551 (tramp-terminal-prompt-regexp tramp-action-terminal)
549 (tramp-antispoof-regexp tramp-action-confirm-message) 552 (tramp-antispoof-regexp tramp-action-confirm-message)
550 (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) 553 (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message)
554 (tramp-security-key-pin-regexp tramp-action-otp-password)
551 (tramp-process-alive-regexp tramp-action-process-alive)) 555 (tramp-process-alive-regexp tramp-action-process-alive))
552 "List of pattern/action pairs. 556 "List of pattern/action pairs.
553Whenever a pattern matches, the corresponding action is performed. 557Whenever a pattern matches, the corresponding action is performed.
@@ -567,6 +571,7 @@ corresponding PATTERN matches, the ACTION function is called.")
567 (tramp-wrong-passwd-regexp tramp-action-permission-denied) 571 (tramp-wrong-passwd-regexp tramp-action-permission-denied)
568 (tramp-copy-failed-regexp tramp-action-permission-denied) 572 (tramp-copy-failed-regexp tramp-action-permission-denied)
569 (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) 573 (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message)
574 (tramp-security-key-pin-regexp tramp-action-otp-password)
570 (tramp-process-alive-regexp tramp-action-out-of-band)) 575 (tramp-process-alive-regexp tramp-action-out-of-band))
571 "List of pattern/action pairs. 576 "List of pattern/action pairs.
572This list is used for copying/renaming with out-of-band methods. 577This list is used for copying/renaming with out-of-band methods.
@@ -2010,7 +2015,7 @@ ID-FORMAT valid values are `string' and `integer'."
2010 #'copy-directory 2015 #'copy-directory
2011 (list dirname newname keep-date parents copy-contents)))) 2016 (list dirname newname keep-date parents copy-contents))))
2012 2017
2013 ;; When newname did exist, we have wrong cached values. 2018 ;; NEWNAME has wrong cached values.
2014 (when t2 2019 (when t2
2015 (with-parsed-tramp-file-name (expand-file-name newname) nil 2020 (with-parsed-tramp-file-name (expand-file-name newname) nil
2016 (tramp-flush-file-properties v localname))))))) 2021 (tramp-flush-file-properties v localname)))))))
@@ -2149,24 +2154,24 @@ file names."
2149 ;; One of them must be a Tramp file. 2154 ;; One of them must be a Tramp file.
2150 (error "Tramp implementation says this cannot happen"))) 2155 (error "Tramp implementation says this cannot happen")))
2151 2156
2152 ;; Handle `preserve-extended-attributes'. We ignore
2153 ;; possible errors, because ACL strings could be
2154 ;; incompatible.
2155 (when-let ((attributes (and preserve-extended-attributes
2156 (file-extended-attributes filename))))
2157 (ignore-errors
2158 (set-file-extended-attributes newname attributes)))
2159
2160 ;; In case of `rename', we must flush the cache of the source file. 2157 ;; In case of `rename', we must flush the cache of the source file.
2161 (when (and t1 (eq op 'rename)) 2158 (when (and t1 (eq op 'rename))
2162 (with-parsed-tramp-file-name filename v1 2159 (with-parsed-tramp-file-name filename v1
2163 (tramp-flush-file-properties v1 v1-localname))) 2160 (tramp-flush-file-properties v1 v1-localname)))
2164 2161
2165 ;; When newname did exist, we have wrong cached values. 2162 ;; NEWNAME has wrong cached values.
2166 (when t2 2163 (when t2
2167 (with-parsed-tramp-file-name newname v2 2164 (with-parsed-tramp-file-name newname v2
2168 (tramp-flush-file-properties v2 v2-localname))) 2165 (tramp-flush-file-properties v2 v2-localname)))
2169 2166
2167 ;; Handle `preserve-extended-attributes'. We ignore
2168 ;; possible errors, because ACL strings could be
2169 ;; incompatible.
2170 (when-let ((attributes (and preserve-extended-attributes
2171 (file-extended-attributes filename))))
2172 (ignore-errors
2173 (set-file-extended-attributes newname attributes)))
2174
2170 ;; KEEP-DATE handling. 2175 ;; KEEP-DATE handling.
2171 (when (and keep-date (not copy-keep-date)) 2176 (when (and keep-date (not copy-keep-date))
2172 (tramp-compat-set-file-times 2177 (tramp-compat-set-file-times
@@ -2398,10 +2403,10 @@ The method used must be an out-of-band method."
2398 #'file-name-as-directory 2403 #'file-name-as-directory
2399 #'identity) 2404 #'identity)
2400 (if v1 2405 (if v1
2401 (tramp-make-copy-program-file-name v1) 2406 (tramp-make-copy-file-name v1)
2402 (file-name-unquote filename))) 2407 (file-name-unquote filename)))
2403 target (if v2 2408 target (if v2
2404 (tramp-make-copy-program-file-name v2) 2409 (tramp-make-copy-file-name v2)
2405 (file-name-unquote newname))) 2410 (file-name-unquote newname)))
2406 2411
2407 ;; Check for listener port. 2412 ;; Check for listener port.
@@ -2438,9 +2443,9 @@ The method used must be an out-of-band method."
2438 copy-program (tramp-get-method-parameter v 'tramp-copy-program) 2443 copy-program (tramp-get-method-parameter v 'tramp-copy-program)
2439 copy-args 2444 copy-args
2440 ;; " " has either been a replacement of "%k" (when 2445 ;; " " has either been a replacement of "%k" (when
2441 ;; keep-date argument is non-nil), or a replacement for 2446 ;; KEEP-DATE argument is non-nil), or a replacement for
2442 ;; the whole keep-date sublist. 2447 ;; the whole keep-date sublist.
2443 (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) 2448 (delete " " (apply #'tramp-expand-args v 'tramp-copy-args nil spec))
2444 ;; `tramp-ssh-controlmaster-options' is a string instead 2449 ;; `tramp-ssh-controlmaster-options' is a string instead
2445 ;; of a list. Unflatten it. 2450 ;; of a list. Unflatten it.
2446 copy-args 2451 copy-args
@@ -2449,11 +2454,11 @@ The method used must be an out-of-band method."
2449 (lambda (x) (if (tramp-compat-string-search " " x) 2454 (lambda (x) (if (tramp-compat-string-search " " x)
2450 (split-string x) x)) 2455 (split-string x) x))
2451 copy-args)) 2456 copy-args))
2452 copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) 2457 copy-env (apply #'tramp-expand-args v 'tramp-copy-env nil spec)
2453 remote-copy-program 2458 remote-copy-program
2454 (tramp-get-method-parameter v 'tramp-remote-copy-program) 2459 (tramp-get-method-parameter v 'tramp-remote-copy-program)
2455 remote-copy-args 2460 remote-copy-args
2456 (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) 2461 (apply #'tramp-expand-args v 'tramp-remote-copy-args nil spec))
2457 2462
2458 ;; Check for local copy program. 2463 ;; Check for local copy program.
2459 (unless (executable-find copy-program) 2464 (unless (executable-find copy-program)
@@ -2636,7 +2641,7 @@ The method used must be an out-of-band method."
2636(defun tramp-sh-handle-insert-directory 2641(defun tramp-sh-handle-insert-directory
2637 (filename switches &optional wildcard full-directory-p) 2642 (filename switches &optional wildcard full-directory-p)
2638 "Like `insert-directory' for Tramp files." 2643 "Like `insert-directory' for Tramp files."
2639 (if (and (featurep 'ls-lisp) 2644 (if (and (boundp 'ls-lisp-use-insert-directory-program)
2640 (not ls-lisp-use-insert-directory-program)) 2645 (not ls-lisp-use-insert-directory-program))
2641 (tramp-handle-insert-directory 2646 (tramp-handle-insert-directory
2642 filename switches wildcard full-directory-p) 2647 filename switches wildcard full-directory-p)
@@ -5289,7 +5294,8 @@ connection if a previous connection has died for some reason."
5289 (tramp-get-method-parameter hop 'tramp-async-args))) 5294 (tramp-get-method-parameter hop 'tramp-async-args)))
5290 (connection-timeout 5295 (connection-timeout
5291 (tramp-get-method-parameter 5296 (tramp-get-method-parameter
5292 hop 'tramp-connection-timeout)) 5297 hop 'tramp-connection-timeout
5298 tramp-connection-timeout))
5293 (command 5299 (command
5294 (tramp-get-method-parameter 5300 (tramp-get-method-parameter
5295 hop 'tramp-login-program)) 5301 hop 'tramp-login-program))
@@ -5347,14 +5353,14 @@ connection if a previous connection has died for some reason."
5347 ;; Add arguments for asynchronous processes. 5353 ;; Add arguments for asynchronous processes.
5348 (when process-name async-args) 5354 (when process-name async-args)
5349 (tramp-expand-args 5355 (tramp-expand-args
5350 hop 'tramp-login-args 5356 hop 'tramp-login-args nil
5351 ?h (or l-host "") ?u (or l-user "") ?p (or l-port "") 5357 ?h (or l-host "") ?u (or l-user "") ?p (or l-port "")
5352 ?c (format-spec options (format-spec-make ?t tmpfile)) 5358 ?c (format-spec options (format-spec-make ?t tmpfile))
5353 ?n (concat 5359 ?n (concat
5354 "2>" (tramp-get-remote-null-device previous-hop)) 5360 "2>" (tramp-get-remote-null-device previous-hop))
5355 ?l (concat remote-shell " " extra-args " -i")) 5361 ?l (concat remote-shell " " extra-args " -i"))
5356 ;; A restricted shell does not allow "exec". 5362 ;; A restricted shell does not allow "exec".
5357 (when r-shell '("&&" "exit")) '("||" "exit")) 5363 (when r-shell '("&&" "exit")) '("||" "exit"))
5358 " ")) 5364 " "))
5359 5365
5360 ;; Send the command. 5366 ;; Send the command.
@@ -5364,8 +5370,7 @@ connection if a previous connection has died for some reason."
5364 p vec 5370 p vec
5365 (min 5371 (min
5366 pos (with-current-buffer (process-buffer p) (point-max))) 5372 pos (with-current-buffer (process-buffer p) (point-max)))
5367 tramp-actions-before-shell 5373 tramp-actions-before-shell connection-timeout)
5368 (or connection-timeout tramp-connection-timeout))
5369 (tramp-message 5374 (tramp-message
5370 vec 3 "Found remote shell prompt on `%s'" l-host) 5375 vec 3 "Found remote shell prompt on `%s'" l-host)
5371 5376
@@ -5558,8 +5563,8 @@ raises an error."
5558 string 5563 string
5559 "")) 5564 ""))
5560 5565
5561(defun tramp-make-copy-program-file-name (vec) 5566(defun tramp-make-copy-file-name (vec)
5562 "Create a file name suitable for `scp', `pscp', or `nc' and workalikes." 5567 "Create a file name suitable for out-of-band methods."
5563 (let ((method (tramp-file-name-method vec)) 5568 (let ((method (tramp-file-name-method vec))
5564 (user (tramp-file-name-user vec)) 5569 (user (tramp-file-name-user vec))
5565 (host (tramp-file-name-host vec)) 5570 (host (tramp-file-name-host vec))
@@ -5570,13 +5575,13 @@ raises an error."
5570 ;; This does not work for MS Windows scp, if there are characters 5575 ;; This does not work for MS Windows scp, if there are characters
5571 ;; to be quoted. OpenSSH 8 supports disabling of strict file name 5576 ;; to be quoted. OpenSSH 8 supports disabling of strict file name
5572 ;; checking in scp, we use it when available. 5577 ;; checking in scp, we use it when available.
5573 (unless (string-match-p (rx "ftp" eos) method) 5578 (unless (string-match-p (rx (| "dockercp" "podmancp" "ftp") eos) method)
5574 (setq localname (tramp-unquote-shell-quote-argument localname))) 5579 (setq localname (tramp-unquote-shell-quote-argument localname)))
5575 (cond 5580 (string-join
5576 ((tramp-get-method-parameter vec 'tramp-remote-copy-program) 5581 (apply #'tramp-expand-args vec
5577 localname) 5582 'tramp-copy-file-name tramp-default-copy-file-name
5578 ((tramp-string-empty-or-nil-p user) (format "%s:%s" host localname)) 5583 (list ?h (or host "") ?u (or user "") ?f localname))
5579 (t (format "%s@%s:%s" user host localname))))) 5584 "")))
5580 5585
5581(defun tramp-method-out-of-band-p (vec size) 5586(defun tramp-method-out-of-band-p (vec size)
5582 "Return t if this is an out-of-band method, nil otherwise." 5587 "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."
322 v (tramp-get-method-parameter v 'tramp-login-program) 322 v (tramp-get-method-parameter v 'tramp-login-program)
323 nil outbuf display 323 nil outbuf display
324 (tramp-expand-args 324 (tramp-expand-args
325 v 'tramp-login-args 325 v 'tramp-login-args nil
326 ?h (or (tramp-file-name-host v) "") 326 ?h (or (tramp-file-name-host v) "")
327 ?u (or (tramp-file-name-user v) "") 327 ?u (or (tramp-file-name-user v) "")
328 ?p (or (tramp-file-name-port v) "") 328 ?p (or (tramp-file-name-port v) "")
@@ -424,7 +424,7 @@ connection if a previous connection has died for some reason."
424 (tramp-fuse-mount-spec vec) 424 (tramp-fuse-mount-spec vec)
425 (tramp-fuse-mount-point vec) 425 (tramp-fuse-mount-point vec)
426 (tramp-expand-args 426 (tramp-expand-args
427 vec 'tramp-mount-args 427 vec 'tramp-mount-args nil
428 ?p (or (tramp-file-name-port vec) "")))))) 428 ?p (or (tramp-file-name-port vec) ""))))))
429 (tramp-error 429 (tramp-error
430 vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec))) 430 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."
771 (tramp-get-connection-name vec) (current-buffer) 771 (tramp-get-connection-name vec) (current-buffer)
772 (append 772 (append
773 (tramp-expand-args 773 (tramp-expand-args
774 vec 'tramp-sudo-login 774 vec 'tramp-sudo-login nil
775 ?h (or (tramp-file-name-host vec) "") 775 ?h (or (tramp-file-name-host vec) "")
776 ?u (or (tramp-file-name-user vec) "")) 776 ?u (or (tramp-file-name-user vec) ""))
777 (flatten-tree args)))) 777 (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 @@
67(declare-function file-notify-rm-watch "filenotify") 67(declare-function file-notify-rm-watch "filenotify")
68(declare-function netrc-parse "netrc") 68(declare-function netrc-parse "netrc")
69(defvar auto-save-file-name-transforms) 69(defvar auto-save-file-name-transforms)
70(defvar ls-lisp-dirs-first)
71(defvar ls-lisp-emulation)
72(defvar ls-lisp-ignore-case)
73(defvar ls-lisp-use-insert-directory-program)
74(defvar ls-lisp-verbosity)
75(defvar tramp-prefix-format) 70(defvar tramp-prefix-format)
76(defvar tramp-prefix-regexp) 71(defvar tramp-prefix-regexp)
77(defvar tramp-method-regexp) 72(defvar tramp-method-regexp)
@@ -306,6 +301,15 @@ pair of the form (KEY VALUE). The following KEYs are defined:
306 This specifies the list of parameters to pass to the above mentioned 301 This specifies the list of parameters to pass to the above mentioned
307 program, the hints for `tramp-login-args' also apply here. 302 program, the hints for `tramp-login-args' also apply here.
308 303
304 * `tramp-copy-file-name'
305 The remote source or destination file name for out-of-band methods.
306 You can use \"%u\" and \"%h\" like in `tramp-login-args'.
307 Additionally, \"%f\" denotes the local file name part. This list
308 will be expanded to a string without spaces between the elements of
309 the list.
310
311 The default value is `tramp-default-copy-file-name'.
312
309 * `tramp-copy-env' 313 * `tramp-copy-env'
310 A list of environment variables and their values, which will 314 A list of environment variables and their values, which will
311 be set when calling `tramp-copy-program'. 315 be set when calling `tramp-copy-program'.
@@ -320,8 +324,8 @@ pair of the form (KEY VALUE). The following KEYs are defined:
320 chosen port for the remote listener. 324 chosen port for the remote listener.
321 325
322 * `tramp-copy-keep-date' 326 * `tramp-copy-keep-date'
323 This specifies whether the copying program when the preserves the 327 This specifies whether the copying program preserves the timestamp
324 timestamp of the original file. 328 of the original file.
325 329
326 * `tramp-copy-keep-tmpfile' 330 * `tramp-copy-keep-tmpfile'
327 This specifies whether a temporary local file shall be kept 331 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."
562 eos) 566 eos)
563 "Host names which are regarded as local host. 567 "Host names which are regarded as local host.
564If the local host runs a chrooted environment, set this to nil." 568If the local host runs a chrooted environment, set this to nil."
565 :version "30.1" 569 :version "29.3"
566 :type '(choice (const :tag "Chrooted environment" nil) 570 :type '(choice (const :tag "Chrooted environment" nil)
567 (regexp :tag "Host regexp"))) 571 (regexp :tag "Host regexp")))
568 572
@@ -750,9 +754,8 @@ The regexp should match at end of buffer."
750 754
751;; A security key requires the user physically to touch the device 755;; A security key requires the user physically to touch the device
752;; with their finger. We must tell it to the user. 756;; with their finger. We must tell it to the user.
753;; Added in OpenSSH 8.2. I've tested it with yubikey. Nitrokey and 757;; Added in OpenSSH 8.2. I've tested it with Nitrokey, Titankey, and
754;; Titankey, which have also passed the tests, do not show such a 758;; Yubikey.
755;; message.
756(defcustom tramp-security-key-confirm-regexp 759(defcustom tramp-security-key-confirm-regexp
757 (rx bol (* "\r") "Confirm user presence for key " (* nonl) (* (any "\r\n"))) 760 (rx bol (* "\r") "Confirm user presence for key " (* nonl) (* (any "\r\n")))
758 "Regular expression matching security key confirmation message. 761 "Regular expression matching security key confirmation message.
@@ -775,6 +778,14 @@ The regexp should match at end of buffer."
775 :version "28.1" 778 :version "28.1"
776 :type 'regexp) 779 :type 'regexp)
777 780
781;; Needed only for FIDO2 (residential) keys. Tested with Nitrokey and Yubikey.
782(defcustom tramp-security-key-pin-regexp
783 (rx bol (* "\r") (group "Enter PIN for " (* nonl)) (* (any "\r\n")))
784 "Regular expression matching security key PIN prompt.
785The regexp should match at end of buffer."
786 :version "29.3"
787 :type 'regexp)
788
778(defcustom tramp-operation-not-permitted-regexp 789(defcustom tramp-operation-not-permitted-regexp
779 (rx (| (: "preserving times" (* nonl)) "set mode") ":" (* blank) 790 (rx (| (: "preserving times" (* nonl)) "set mode") ":" (* blank)
780 "Operation not permitted") 791 "Operation not permitted")
@@ -1543,21 +1554,23 @@ LOCALNAME and HOP do not count."
1543 (equal (tramp-file-name-unify vec1) 1554 (equal (tramp-file-name-unify vec1)
1544 (tramp-file-name-unify vec2)))) 1555 (tramp-file-name-unify vec2))))
1545 1556
1546(defun tramp-get-method-parameter (vec param) 1557(defun tramp-get-method-parameter (vec param &optional default)
1547 "Return the method parameter PARAM. 1558 "Return the method parameter PARAM.
1548If VEC is a vector, check first in connection properties. 1559If VEC is a vector, check first in connection properties.
1549Afterwards, check in `tramp-methods'. If the `tramp-methods' 1560Afterwards, check in `tramp-methods'. If the `tramp-methods'
1550entry does not exist, return nil." 1561entry does not exist, return DEFAULT."
1551 (let ((hash-entry 1562 (let ((hash-entry
1552 (replace-regexp-in-string (rx bos "tramp-") "" (symbol-name param)))) 1563 (replace-regexp-in-string (rx bos "tramp-") "" (symbol-name param))))
1553 (if (tramp-connection-property-p vec hash-entry) 1564 (if (tramp-connection-property-p vec hash-entry)
1554 ;; We use the cached property. 1565 ;; We use the cached property.
1555 (tramp-get-connection-property vec hash-entry) 1566 (tramp-get-connection-property vec hash-entry)
1556 ;; Use the static value from `tramp-methods'. 1567 ;; Use the static value from `tramp-methods'.
1557 (when-let ((methods-entry 1568 (if-let ((methods-entry
1558 (assoc 1569 (assoc
1559 param (assoc (tramp-file-name-method vec) tramp-methods)))) 1570 param (assoc (tramp-file-name-method vec) tramp-methods))))
1560 (cadr methods-entry))))) 1571 (cadr methods-entry)
1572 ;; Return the default value.
1573 default))))
1561 1574
1562;; The localname can be quoted with "/:". Extract this. 1575;; The localname can be quoted with "/:". Extract this.
1563(defun tramp-file-name-unquote-localname (vec) 1576(defun tramp-file-name-unquote-localname (vec)
@@ -3941,6 +3954,9 @@ Let-bind it when necessary.")
3941 (tramp-get-method-parameter v 'tramp-case-insensitive) 3954 (tramp-get-method-parameter v 'tramp-case-insensitive)
3942 3955
3943 ;; There isn't. So we must check, in case there's a connection already. 3956 ;; There isn't. So we must check, in case there's a connection already.
3957 ;; Note: We cannot use it as DEFAULT value of
3958 ;; `tramp-get-method-parameter', because it would be evalled
3959 ;; during the call.
3944 (and (let ((non-essential t)) (tramp-connectable-p v)) 3960 (and (let ((non-essential t)) (tramp-connectable-p v))
3945 (with-tramp-connection-property v "case-insensitive" 3961 (with-tramp-connection-property v "case-insensitive"
3946 (ignore-errors 3962 (ignore-errors
@@ -4189,6 +4205,11 @@ Let-bind it when necessary.")
4189 (filename switches &optional wildcard full-directory-p) 4205 (filename switches &optional wildcard full-directory-p)
4190 "Like `insert-directory' for Tramp files." 4206 "Like `insert-directory' for Tramp files."
4191 (require 'ls-lisp) 4207 (require 'ls-lisp)
4208 (defvar ls-lisp-dirs-first)
4209 (defvar ls-lisp-emulation)
4210 (defvar ls-lisp-ignore-case)
4211 (defvar ls-lisp-use-insert-directory-program)
4212 (defvar ls-lisp-verbosity)
4192 (unless switches (setq switches "")) 4213 (unless switches (setq switches ""))
4193 ;; Mark trailing "/". 4214 ;; Mark trailing "/".
4194 (when (and (directory-name-p filename) 4215 (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'.")
4745(defvar tramp-extra-expand-args nil 4766(defvar tramp-extra-expand-args nil
4746 "Method specific arguments.") 4767 "Method specific arguments.")
4747 4768
4748(defun tramp-expand-args (vec parameter &rest spec-list) 4769(defun tramp-expand-args (vec parameter default &rest spec-list)
4749 "Expand login arguments as given by PARAMETER in `tramp-methods'. 4770 "Expand login arguments as given by PARAMETER in `tramp-methods'.
4750PARAMETER is a symbol like `tramp-login-args', denoting a list of 4771PARAMETER is a symbol like `tramp-login-args', denoting a list of
4751list of strings from `tramp-methods', containing %-sequences for 4772list of strings from `tramp-methods', containing %-sequences for
4752substitution. 4773substitution. DEFAULT is used when PARAMETER is not specified.
4753SPEC-LIST is a list of char/value pairs used for 4774SPEC-LIST is a list of char/value pairs used for
4754`format-spec-make'. It is appended by `tramp-extra-expand-args', 4775`format-spec-make'. It is appended by `tramp-extra-expand-args',
4755a connection-local variable." 4776a connection-local variable."
4756 (let ((args (tramp-get-method-parameter vec parameter)) 4777 (let ((args (tramp-get-method-parameter vec parameter default))
4757 (extra-spec-list 4778 (extra-spec-list
4758 (mapcar 4779 (mapcar
4759 #'eval 4780 #'eval
@@ -4932,7 +4953,7 @@ a connection-local variable."
4932 (mapcar 4953 (mapcar
4933 (lambda (x) (split-string x " ")) 4954 (lambda (x) (split-string x " "))
4934 (tramp-expand-args 4955 (tramp-expand-args
4935 v 'tramp-login-args 4956 v 'tramp-login-args nil
4936 ?h (or host "") ?u (or user "") ?p (or port "") 4957 ?h (or host "") ?u (or user "") ?p (or port "")
4937 ?c (format-spec (or options "") (format-spec-make ?t tmpfile)) 4958 ?c (format-spec (or options "") (format-spec-make ?t tmpfile))
4938 ?d (or device "") ?a (or pta "") ?l "")))) 4959 ?d (or device "") ?a (or pta "") ?l ""))))
@@ -5435,7 +5456,7 @@ of."
5435 prompt) 5456 prompt)
5436 (goto-char (point-min)) 5457 (goto-char (point-min))
5437 (tramp-check-for-regexp proc tramp-process-action-regexp) 5458 (tramp-check-for-regexp proc tramp-process-action-regexp)
5438 (setq prompt (concat (match-string 1) " ")) 5459 (setq prompt (concat (string-trim (match-string 1)) " "))
5439 (tramp-message vec 3 "Sending %s" (match-string 1)) 5460 (tramp-message vec 3 "Sending %s" (match-string 1))
5440 ;; We don't call `tramp-send-string' in order to hide the 5461 ;; We don't call `tramp-send-string' in order to hide the
5441 ;; password from the debug buffer and the traces. 5462 ;; password from the debug buffer and the traces.
@@ -5511,14 +5532,16 @@ Wait, until the connection buffer changes."
5511 (ignore set-message-function clear-message-function) 5532 (ignore set-message-function clear-message-function)
5512 (tramp-message vec 6 "\n%s" (buffer-string)) 5533 (tramp-message vec 6 "\n%s" (buffer-string))
5513 (tramp-check-for-regexp proc tramp-process-action-regexp) 5534 (tramp-check-for-regexp proc tramp-process-action-regexp)
5514 (with-temp-message 5535 (with-temp-message (concat (string-trim (match-string 0)) " ")
5515 (replace-regexp-in-string (rx (any "\r\n")) "" (match-string 0))
5516 ;; Hide message in buffer. 5536 ;; Hide message in buffer.
5517 (narrow-to-region (point-max) (point-max)) 5537 (narrow-to-region (point-max) (point-max))
5518 ;; Wait for new output. 5538 ;; Wait for new output.
5519 (while (not (ignore-error file-error 5539 (while (not (ignore-error file-error
5520 (tramp-wait-for-regexp 5540 (tramp-wait-for-regexp
5521 proc 0.1 tramp-security-key-confirmed-regexp))) 5541 proc 0.1
5542 (rx (| (regexp tramp-security-key-confirmed-regexp)
5543 (regexp tramp-security-key-pin-regexp)
5544 (regexp tramp-security-key-timeout-regexp))))))
5522 (when (tramp-check-for-regexp proc tramp-security-key-timeout-regexp) 5545 (when (tramp-check-for-regexp proc tramp-security-key-timeout-regexp)
5523 (throw 'tramp-action 'timeout)) 5546 (throw 'tramp-action 'timeout))
5524 (redisplay 'force)))))) 5547 (redisplay 'force))))))
@@ -6317,9 +6340,8 @@ This handles also chrooted environments, which are not regarded as local."
6317(defun tramp-get-remote-tmpdir (vec) 6340(defun tramp-get-remote-tmpdir (vec)
6318 "Return directory for temporary files on the remote host identified by VEC." 6341 "Return directory for temporary files on the remote host identified by VEC."
6319 (with-tramp-connection-property (tramp-get-process vec) "remote-tmpdir" 6342 (with-tramp-connection-property (tramp-get-process vec) "remote-tmpdir"
6320 (let ((dir 6343 (let ((dir (tramp-make-tramp-file-name
6321 (tramp-make-tramp-file-name 6344 vec (tramp-get-method-parameter vec 'tramp-tmpdir "/tmp"))))
6322 vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp"))))
6323 (or (and (file-directory-p dir) (file-writable-p dir) 6345 (or (and (file-directory-p dir) (file-writable-p dir)
6324 (tramp-file-local-name dir)) 6346 (tramp-file-local-name dir))
6325 (tramp-error vec 'file-error "Directory %s not accessible" dir)) 6347 (tramp-error vec 'file-error "Directory %s not accessible" dir))
@@ -6564,12 +6586,13 @@ Consults the auth-source package."
6564 (tramp-get-connection-property key "login-as"))) 6586 (tramp-get-connection-property key "login-as")))
6565 (host (tramp-file-name-host-port vec)) 6587 (host (tramp-file-name-host-port vec))
6566 (pw-prompt 6588 (pw-prompt
6567 (or prompt 6589 (string-trim-left
6568 (with-current-buffer (process-buffer proc) 6590 (or prompt
6569 (tramp-check-for-regexp proc tramp-password-prompt-regexp) 6591 (with-current-buffer (process-buffer proc)
6570 (if (string-match-p "passphrase" (match-string 1)) 6592 (tramp-check-for-regexp proc tramp-password-prompt-regexp)
6571 (match-string 0) 6593 (if (string-match-p "passphrase" (match-string 1))
6572 (format "%s for %s " (capitalize (match-string 1)) key))))) 6594 (match-string 0)
6595 (format "%s for %s " (capitalize (match-string 1)) key))))))
6573 (auth-source-creation-prompts `((secret . ,pw-prompt))) 6596 (auth-source-creation-prompts `((secret . ,pw-prompt)))
6574 ;; Use connection-local value. 6597 ;; Use connection-local value.
6575 (auth-sources (buffer-local-value 'auth-sources (process-buffer proc))) 6598 (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 @@
27 27
28;;; Code: 28;;; Code:
29 29
30(defconst obarray-default-size 59 30(defconst obarray-default-size 4)
31 "The value 59 is an arbitrary prime number that gives a good hash.") 31(make-obsolete-variable 'obarray-default-size
32 32 "obarrays now grow automatically" "30.1")
33(defun obarray-make (&optional size) 33
34 "Return a new obarray of size SIZE or `obarray-default-size'." 34(defun obarray-size (_ob) obarray-default-size)
35 (let ((size (or size obarray-default-size))) 35(make-obsolete 'obarray-size "obarrays now grow automatically" "30.1")
36 (if (< 0 size)
37 (make-vector size 0)
38 (signal 'wrong-type-argument '(size 0)))))
39
40(defun obarray-size (ob)
41 "Return the number of slots of obarray OB."
42 (length ob))
43
44(defun obarrayp (object)
45 "Return t if OBJECT is an obarray."
46 (and (vectorp object)
47 (< 0 (length object))))
48 36
49;; Don’t use obarray as a variable name to avoid shadowing. 37;; Don’t use obarray as a variable name to avoid shadowing.
50(defun obarray-get (ob name) 38(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."
370This hook is run during minibuffer setup if `iswitchb' is active. 370This hook is run during minibuffer setup if `iswitchb' is active.
371For instance: 371For instance:
372\(add-hook \\='iswitchb-minibuffer-setup-hook 372\(add-hook \\='iswitchb-minibuffer-setup-hook
373 \\='\(lambda () (set (make-local-variable \\='max-mini-window-height) 3))) 373 \\='\(lambda () (setq-local max-mini-window-height 3)))
374will constrain the minibuffer to a maximum height of 3 lines when 374will constrain the minibuffer to a maximum height of 3 lines when
375iswitchb is running." 375iswitchb is running."
376 :type 'hook) 376 :type 'hook)
@@ -1262,7 +1262,7 @@ Modified from `icomplete-completions'."
1262 "Set up minibuffer for `iswitchb-buffer'. 1262 "Set up minibuffer for `iswitchb-buffer'.
1263Copied from `icomplete-minibuffer-setup-hook'." 1263Copied from `icomplete-minibuffer-setup-hook'."
1264 (when (iswitchb-entryfn-p) 1264 (when (iswitchb-entryfn-p)
1265 (set (make-local-variable 'iswitchb-use-mycompletion) t) 1265 (setq-local iswitchb-use-mycompletion t)
1266 (add-hook 'pre-command-hook #'iswitchb-pre-command nil t) 1266 (add-hook 'pre-command-hook #'iswitchb-pre-command nil t)
1267 (add-hook 'post-command-hook #'iswitchb-post-command nil t) 1267 (add-hook 'post-command-hook #'iswitchb-post-command nil t)
1268 (run-hooks 'iswitchb-minibuffer-setup-hook))) 1268 (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."
116 ;; Turn on longlines mode 116 ;; Turn on longlines mode
117 (progn 117 (progn
118 (use-hard-newlines 1 'never) 118 (use-hard-newlines 1 'never)
119 (set (make-local-variable 'require-final-newline) nil) 119 (setq-local require-final-newline nil)
120 (add-to-list 'buffer-file-format 'longlines) 120 (add-to-list 'buffer-file-format 'longlines)
121 (add-hook 'change-major-mode-hook #'longlines-mode-off nil t) 121 (add-hook 'change-major-mode-hook #'longlines-mode-off nil t)
122 (add-hook 'before-revert-hook #'longlines-before-revert-hook nil t) 122 (add-hook 'before-revert-hook #'longlines-before-revert-hook nil t)
123 (make-local-variable 'longlines-auto-wrap) 123 (make-local-variable 'longlines-auto-wrap)
124 (set (make-local-variable 'isearch-search-fun-function) 124 (setq-local isearch-search-fun-function #'longlines-search-function)
125 #'longlines-search-function) 125 (setq-local replace-search-function #'longlines-search-forward)
126 (set (make-local-variable 'replace-search-function) 126 (setq-local replace-re-search-function #'longlines-re-search-forward)
127 #'longlines-search-forward)
128 (set (make-local-variable 'replace-re-search-function)
129 #'longlines-re-search-forward)
130 (add-function :filter-return (local 'filter-buffer-substring-function) 127 (add-function :filter-return (local 'filter-buffer-substring-function)
131 #'longlines-encode-string) 128 #'longlines-encode-string)
132 (when longlines-wrap-follows-window-size 129 (when longlines-wrap-follows-window-size
@@ -136,8 +133,7 @@ newlines are indicated with a symbol."
136 (window-width))) 133 (window-width)))
137 longlines-wrap-follows-window-size 134 longlines-wrap-follows-window-size
138 2))) 135 2)))
139 (set (make-local-variable 'fill-column) 136 (setq-local fill-column (- (window-width) dw)))
140 (- (window-width) dw)))
141 (add-hook 'window-configuration-change-hook 137 (add-hook 'window-configuration-change-hook
142 #'longlines-window-change-function nil t)) 138 #'longlines-window-change-function nil t))
143 (let ((buffer-undo-list t) 139 (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."
85 (set-buffer standard-output) 85 (set-buffer standard-output)
86 (insert-buffer-substring pgg-errors-buffer)))) 86 (insert-buffer-substring pgg-errors-buffer))))
87 87
88(defvar pgg-passphrase-cache (make-vector 7 0)) 88(defvar pgg-passphrase-cache (obarray-make 7))
89 89
90(defvar pgg-pending-timers (make-vector 7 0) 90(defvar pgg-pending-timers (obarray-make 7)
91 "Hash table for managing scheduled pgg cache management timers. 91 "Hash table for managing scheduled pgg cache management timers.
92 92
93We associate key and timer, so the timer can be canceled if a new 93We 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]."
169 ;; compilation-parse-errors will find referenced files by Tramp. 169 ;; compilation-parse-errors will find referenced files by Tramp.
170 (with-current-buffer next-error-last-buffer 170 (with-current-buffer next-error-last-buffer
171 (when (fboundp 'tramp-make-tramp-file-name) 171 (when (fboundp 'tramp-make-tramp-file-name)
172 (set (make-local-variable 'comint-file-name-prefix) 172 (setq-local comint-file-name-prefix
173 (funcall 173 (funcall
174 #'tramp-make-tramp-file-name 174 #'tramp-make-tramp-file-name
175 nil ;; method. 175 nil ;; method.
176 remote-compile-user 176 remote-compile-user
177 remote-compile-host 177 remote-compile-host
178 "")))))) 178 ""))))))
179 179
180;;; rcompile.el ends here 180;;; 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."
4685 (if (and (= char ?f) current-file) 4685 (if (and (= char ?f) current-file)
4686 (concat "file://" current-file) uri)) 4686 (concat "file://" current-file) uri))
4687 "\\'"))))) 4687 "\\'")))))
4688 (prog1 (memq char '(?y ?n ?! ?d ?\s ?f)) 4688 (prog1 (memq char '(?y ?! ?d ?\s ?f))
4689 (quit-window t))))))) 4689 (quit-window t)))))))
4690 4690
4691(defun org-extract-log-state-settings (x) 4691(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
318buffers because it modifies them. 318buffers because it modifies them.
319When the value is `in-margins', then clickable buttons are 319When the value is `in-margins', then clickable buttons are
320displayed in the margins before the headings. 320displayed in the margins before the headings.
321When the value is `t', clickable buttons are displayed 321When the value is t, clickable buttons are displayed
322in the buffer before the headings. The values `t' and 322in the buffer before the headings. The values t and
323`in-margins' can be used in editing buffers because they 323`in-margins' can be used in editing buffers because they
324don't modify the buffer." 324don't modify the buffer."
325 ;; The value `insert' is not intended to be customizable. 325 ;; The value `insert' is not intended to be customizable.
@@ -686,7 +686,7 @@ If POS is nil, use `point' instead."
686(defun outline-back-to-heading (&optional invisible-ok) 686(defun outline-back-to-heading (&optional invisible-ok)
687 "Move to previous heading line, or beg of this line if it's a heading. 687 "Move to previous heading line, or beg of this line if it's a heading.
688Only visible heading lines are considered, unless INVISIBLE-OK is non-nil." 688Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
689 (beginning-of-line) 689 (forward-line 0)
690 (or (outline-on-heading-p invisible-ok) 690 (or (outline-on-heading-p invisible-ok)
691 (let (found) 691 (let (found)
692 (save-excursion 692 (save-excursion
@@ -705,7 +705,7 @@ Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
705 "Return t if point is on a (visible) heading line. 705 "Return t if point is on a (visible) heading line.
706If INVISIBLE-OK is non-nil, an invisible heading line is ok too." 706If INVISIBLE-OK is non-nil, an invisible heading line is ok too."
707 (save-excursion 707 (save-excursion
708 (beginning-of-line) 708 (forward-line 0)
709 (and (bolp) (or invisible-ok (not (outline-invisible-p))) 709 (and (bolp) (or invisible-ok (not (outline-invisible-p)))
710 (if outline-search-function 710 (if outline-search-function
711 (funcall outline-search-function nil nil nil t) 711 (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."
725 (not (string-match (concat "\\`\\(?:" outline-regexp "\\)") 725 (not (string-match (concat "\\`\\(?:" outline-regexp "\\)")
726 (concat head " ")))) 726 (concat head " "))))
727 (setq head (concat head " "))) 727 (setq head (concat head " ")))
728 (unless (bolp) (end-of-line) (newline)) 728 (unless (bolp) (goto-char (pos-eol)) (newline))
729 (insert head) 729 (insert head)
730 (unless (eolp) 730 (unless (eolp)
731 (save-excursion (newline-and-indent))) 731 (save-excursion (newline-and-indent)))
@@ -941,9 +941,7 @@ With ARG, repeats or can move backward if negative.
941A heading line is one that starts with a `*' (or that 941A heading line is one that starts with a `*' (or that
942`outline-regexp' matches)." 942`outline-regexp' matches)."
943 (interactive "p") 943 (interactive "p")
944 (if (< arg 0) 944 (goto-char (if (< arg 0) (pos-bol) (pos-eol)))
945 (beginning-of-line)
946 (end-of-line))
947 (let ((regexp (unless outline-search-function 945 (let ((regexp (unless outline-search-function
948 (concat "^\\(?:" outline-regexp "\\)"))) 946 (concat "^\\(?:" outline-regexp "\\)")))
949 found-heading-p) 947 found-heading-p)
@@ -963,7 +961,7 @@ A heading line is one that starts with a `*' (or that
963 (re-search-forward regexp nil 'move))) 961 (re-search-forward regexp nil 'move)))
964 (outline-invisible-p (match-beginning 0)))) 962 (outline-invisible-p (match-beginning 0))))
965 (setq arg (1- arg))) 963 (setq arg (1- arg)))
966 (if found-heading-p (beginning-of-line)))) 964 (if found-heading-p (forward-line 0))))
967 965
968(defun outline-previous-visible-heading (arg) 966(defun outline-previous-visible-heading (arg)
969 "Move to the previous heading line. 967 "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."
980 (let ((beg)) 978 (let ((beg))
981 (if (outline-on-heading-p) 979 (if (outline-on-heading-p)
982 ;; we are already looking at a heading 980 ;; we are already looking at a heading
983 (beginning-of-line) 981 (forward-line 0)
984 ;; else go back to previous heading 982 ;; else go back to previous heading
985 (outline-previous-visible-heading 1)) 983 (outline-previous-visible-heading 1))
986 (setq beg (point)) 984 (setq beg (point))
@@ -1183,7 +1181,7 @@ of the current heading, or to 1 if the current line is not a heading."
1183 (cond 1181 (cond
1184 (current-prefix-arg (prefix-numeric-value current-prefix-arg)) 1182 (current-prefix-arg (prefix-numeric-value current-prefix-arg))
1185 ((save-excursion 1183 ((save-excursion
1186 (beginning-of-line) 1184 (forward-line 0)
1187 (if outline-search-function 1185 (if outline-search-function
1188 (funcall outline-search-function nil nil nil t) 1186 (funcall outline-search-function nil nil nil t)
1189 (looking-at outline-regexp))) 1187 (looking-at outline-regexp)))
@@ -1243,7 +1241,7 @@ This also unhides the top heading-less body, if any."
1243 (interactive) 1241 (interactive)
1244 (save-excursion 1242 (save-excursion
1245 (outline-back-to-heading) 1243 (outline-back-to-heading)
1246 (if (not (outline-invisible-p (line-end-position))) 1244 (if (not (outline-invisible-p (pos-eol)))
1247 (outline-hide-subtree) 1245 (outline-hide-subtree)
1248 (outline-show-children) 1246 (outline-show-children)
1249 (outline-show-entry)))) 1247 (outline-show-entry))))
@@ -1834,7 +1832,7 @@ With a prefix argument, show headings up to that LEVEL."
1834(defun outline--insert-button (type) 1832(defun outline--insert-button (type)
1835 (with-silent-modifications 1833 (with-silent-modifications
1836 (save-excursion 1834 (save-excursion
1837 (beginning-of-line) 1835 (forward-line 0)
1838 (let ((icon (nth (if (eq type 'close) 1 0) outline--button-icons)) 1836 (let ((icon (nth (if (eq type 'close) 1 0) outline--button-icons))
1839 (o (seq-find (lambda (o) (overlay-get o 'outline-button)) 1837 (o (seq-find (lambda (o) (overlay-get o 'outline-button))
1840 (overlays-at (point))))) 1838 (overlays-at (point)))))
@@ -1842,7 +1840,7 @@ With a prefix argument, show headings up to that LEVEL."
1842 (when (eq outline-minor-mode-use-buttons 'insert) 1840 (when (eq outline-minor-mode-use-buttons 'insert)
1843 (let ((inhibit-read-only t)) 1841 (let ((inhibit-read-only t))
1844 (insert (apply #'propertize " " (text-properties-at (point)))) 1842 (insert (apply #'propertize " " (text-properties-at (point))))
1845 (beginning-of-line))) 1843 (forward-line 0)))
1846 (setq o (make-overlay (point) (1+ (point)))) 1844 (setq o (make-overlay (point) (1+ (point))))
1847 (overlay-put o 'outline-button t) 1845 (overlay-put o 'outline-button t)
1848 (overlay-put o 'evaporate t)) 1846 (overlay-put o 'evaporate t))
@@ -1866,7 +1864,7 @@ With a prefix argument, show headings up to that LEVEL."
1866 (when from 1864 (when from
1867 (save-excursion 1865 (save-excursion
1868 (goto-char from) 1866 (goto-char from)
1869 (setq from (line-beginning-position)))) 1867 (setq from (pos-bol))))
1870 (outline-map-region 1868 (outline-map-region
1871 (lambda () 1869 (lambda ()
1872 (let ((close-p (save-excursion 1870 (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 @@
65(defconst cookie-delimiter "\n%%\n\\|\n%\n\\|\0" 65(defconst cookie-delimiter "\n%%\n\\|\n%\n\\|\0"
66 "Delimiter used to separate cookie file entries.") 66 "Delimiter used to separate cookie file entries.")
67 67
68(defvar cookie-cache (make-vector 511 0) 68(defvar cookie-cache (obarray-make 511)
69 "Cache of cookie files that have already been snarfed.") 69 "Cache of cookie files that have already been snarfed.")
70 70
71(defun cookie-check-file (file) 71(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
2261those ARGS. Usually the LOG string ends with a \\n. 2261those ARGS. Usually the LOG string ends with a \\n.
2262End each bunch of errors with (proced-log t signal): 2262End each bunch of errors with (proced-log t signal):
2263this inserts the current time, buffer and signal at the start of the page, 2263this inserts the current time, buffer and signal at the start of the page,
2264and \f (formfeed) at the end." 2264and \\f (formfeed) at the end."
2265 (let ((obuf (current-buffer))) 2265 (let ((obuf (current-buffer)))
2266 (with-current-buffer (get-buffer-create proced-log-buffer) 2266 (with-current-buffer (get-buffer-create proced-log-buffer)
2267 (goto-char (point-max)) 2267 (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."
922 name))) 922 name)))
923 t)) 923 t))
924 924
925;;; Outline minor mode
926
927(defun c-ts-mode--outline-predicate (node)
928 "Match outlines on lines with function names."
929 (or (and (equal (treesit-node-type node) "function_declarator")
930 (equal (treesit-node-type (treesit-node-parent node))
931 "function_definition"))
932 ;; DEFUNs in Emacs sources.
933 (and c-ts-mode-emacs-sources-support
934 (c-ts-mode--emacs-defun-p node))))
935
925;;; Defun navigation 936;;; Defun navigation
926 937
927(defun c-ts-mode--defun-valid-p (node) 938(defun c-ts-mode--defun-valid-p (node)
@@ -1259,6 +1270,10 @@ BEG and END are described in `treesit-range-rules'."
1259 eos) 1270 eos)
1260 c-ts-mode--defun-for-class-in-imenu-p nil)))) 1271 c-ts-mode--defun-for-class-in-imenu-p nil))))
1261 1272
1273 ;; Outline minor mode
1274 (setq-local treesit-outline-predicate
1275 #'c-ts-mode--outline-predicate)
1276
1262 (setq-local treesit-font-lock-feature-list 1277 (setq-local treesit-font-lock-feature-list
1263 c-ts-mode--feature-list)) 1278 c-ts-mode--feature-list))
1264 1279
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."
2425 (error "Unknown base mode `%s'" base-mode)) 2425 (error "Unknown base mode `%s'" base-mode))
2426 (put mode 'c-fallback-mode base-mode)) 2426 (put mode 'c-fallback-mode base-mode))
2427 2427
2428(defvar c-lang-constants (make-vector 151 0)) 2428(defvar c-lang-constants (obarray-make 151))
2429;; Obarray used as a cache to keep track of the language constants. 2429;; Obarray used as a cache to keep track of the language constants.
2430;; The constants stored are those defined by `c-lang-defconst' and the values 2430;; The constants stored are those defined by `c-lang-defconst' and the values
2431;; computed by `c-lang-const'. It's mostly used at compile time but it's not 2431;; 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."
2579 ;; dependencies on the `c-lang-const's in VAL.) 2579 ;; dependencies on the `c-lang-const's in VAL.)
2580 (setq val (c--macroexpand-all val)) 2580 (setq val (c--macroexpand-all val))
2581 2581
2582 (setq bindings `(cons (cons ',assigned-mode (lambda () ,val)) ,bindings) 2582 (setq bindings `(cons (cons ',assigned-mode (lambda () nil ,val))
2583 ,bindings)
2583 args (cdr args)))) 2584 args (cdr args))))
2584 2585
2585 ;; Compile in the other files that have provided source 2586 ;; Compile in the other files that have provided source
@@ -2630,7 +2631,7 @@ constant. A file is identified by its base name."
2630 2631
2631 ;; Clear the evaluated values that depend on this source. 2632 ;; Clear the evaluated values that depend on this source.
2632 (let ((agenda (get sym 'dependents)) 2633 (let ((agenda (get sym 'dependents))
2633 (visited (make-vector 101 0)) 2634 (visited (obarray-make 101))
2634 ptr) 2635 ptr)
2635 (while agenda 2636 (while agenda
2636 (setq sym (car agenda) 2637 (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
3511 3511
3512 (let* ((alist (c-lang-const c-keyword-member-alist)) 3512 (let* ((alist (c-lang-const c-keyword-member-alist))
3513 kwd lang-const-list 3513 kwd lang-const-list
3514 (obarray (make-vector (* (length alist) 2) 0))) 3514 (obarray (obarray-make (* (length alist) 2))))
3515 (while alist 3515 (while alist
3516 (setq kwd (caar alist) 3516 (setq kwd (caar alist)
3517 lang-const-list (cdar alist) 3517 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."
193 '((ERROR) @font-lock-warning-face)) 193 '((ERROR) @font-lock-warning-face))
194 "Tree-sitter font-lock settings for `cmake-ts-mode'.") 194 "Tree-sitter font-lock settings for `cmake-ts-mode'.")
195 195
196(defun cmake-ts-mode--function-name (node) 196(defun cmake-ts-mode--defun-name (node)
197 "Return the function name of NODE. 197 "Return the defun name of NODE.
198Return nil if there is no name or if NODE is not a function node." 198Return nil if there is no name or if NODE is not a defun node."
199 (pcase (treesit-node-type node) 199 (pcase (treesit-node-type node)
200 ("function_command" 200 ((or "function_def" "macro_def")
201 (treesit-node-text 201 (treesit-node-text
202 (treesit-search-subtree node "^argument$" nil nil 2) 202 (treesit-search-subtree node "^argument$" nil nil 3)
203 t)))) 203 t))))
204 204
205;;;###autoload 205;;;###autoload
@@ -216,9 +216,15 @@ Return nil if there is no name or if NODE is not a function node."
216 (setq-local comment-end "") 216 (setq-local comment-end "")
217 (setq-local comment-start-skip (rx "#" (* (syntax whitespace)))) 217 (setq-local comment-start-skip (rx "#" (* (syntax whitespace))))
218 218
219 ;; Defuns.
220 (setq-local treesit-defun-type-regexp (rx (or "function" "macro")
221 "_def"))
222 (setq-local treesit-defun-name-function #'cmake-ts-mode--defun-name)
223
219 ;; Imenu. 224 ;; Imenu.
220 (setq-local treesit-simple-imenu-settings 225 (setq-local treesit-simple-imenu-settings
221 `(("Function" "\\`function_command\\'" nil cmake-ts-mode--function-name))) 226 `(("Function" "^function_def$")
227 ("Macro" "^macro_def$")))
222 (setq-local which-func-functions nil) 228 (setq-local which-func-functions nil)
223 229
224 ;; Indent. 230 ;; 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."
1890(defvar-local compilation--start-time nil 1890(defvar-local compilation--start-time nil
1891 "The time when the compilation started as returned by `float-time'.") 1891 "The time when the compilation started as returned by `float-time'.")
1892 1892
1893(defun compilation--downcase-mode-name (mode)
1894 "Downcase the name of major MODE, even if MODE is not a string.
1895The function `downcase' will barf if passed the name of a `major-mode'
1896which is not a string, but instead a symbol or a list."
1897 (downcase (format-mode-line mode)))
1898
1893;;;###autoload 1899;;;###autoload
1894(defun compilation-start (command &optional mode name-function highlight-regexp 1900(defun compilation-start (command &optional mode name-function highlight-regexp
1895 continue) 1901 continue)
@@ -2081,11 +2087,12 @@ Returns the compilation buffer created."
2081 (get-buffer-process 2087 (get-buffer-process
2082 (with-no-warnings 2088 (with-no-warnings
2083 (comint-exec 2089 (comint-exec
2084 outbuf (downcase mode-name) 2090 outbuf (compilation--downcase-mode-name mode-name)
2085 shell-file-name 2091 shell-file-name
2086 nil `(,shell-command-switch ,command))))) 2092 nil `(,shell-command-switch ,command)))))
2087 (start-file-process-shell-command (downcase mode-name) 2093 (start-file-process-shell-command
2088 outbuf command)))) 2094 (compilation--downcase-mode-name mode-name)
2095 outbuf command))))
2089 ;; Make the buffer's mode line show process state. 2096 ;; Make the buffer's mode line show process state.
2090 (setq mode-line-process 2097 (setq mode-line-process
2091 '((:propertize ":%s" face compilation-mode-line-run) 2098 '((: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)."
2790 (let ((buffer (compilation-find-buffer))) 2797 (let ((buffer (compilation-find-buffer)))
2791 (if (get-buffer-process buffer) 2798 (if (get-buffer-process buffer)
2792 (interrupt-process (get-buffer-process buffer)) 2799 (interrupt-process (get-buffer-process buffer))
2793 (error "The %s process is not running" (downcase mode-name))))) 2800 (error "The %s process is not running"
2801 (compilation--downcase-mode-name mode-name)))))
2794 2802
2795(defalias 'compile-mouse-goto-error 'compile-goto-error) 2803(defalias 'compile-mouse-goto-error 'compile-goto-error)
2796 2804
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\"."
6557 (let ((option (car setting)) 6557 (let ((option (car setting))
6558 (value (cdr setting))) 6558 (value (cdr setting)))
6559 (set (make-local-variable option) value))) 6559 (set (make-local-variable option) value)))
6560 (set (make-local-variable 'cperl-file-style) style)) 6560 (setq-local cperl-file-style style))
6561 6561
6562(declare-function Info-find-node "info" 6562(declare-function Info-find-node "info"
6563 (filename nodename &optional no-going-back strict-case 6563 (filename nodename &optional no-going-back strict-case
@@ -6612,14 +6612,13 @@ and \"Whitesmith\"."
6612 read)))) 6612 read))))
6613 6613
6614 (let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" 6614 (let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"
6615 pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner 6615 pos isvar height iniheight frheight buf win iniwin not-loner
6616 max-height char-height buf-list) 6616 max-height char-height buf-list)
6617 (if (string-match "^-[a-zA-Z]$" command) 6617 (if (string-match "^-[a-zA-Z]$" command)
6618 (setq cmd-desc "^-X[ \t\n]")) 6618 (setq cmd-desc "^-X[ \t\n]"))
6619 (setq isvar (string-match "^[$@%]" command) 6619 (setq isvar (string-match "^[$@%]" command)
6620 buf (cperl-info-buffer isvar) 6620 buf (cperl-info-buffer isvar)
6621 iniwin (selected-window) 6621 iniwin (selected-window))
6622 fr1 (window-frame iniwin))
6623 (set-buffer buf) 6622 (set-buffer buf)
6624 (goto-char (point-min)) 6623 (goto-char (point-min))
6625 (or isvar 6624 (or isvar
@@ -6640,11 +6639,7 @@ and \"Whitesmith\"."
6640 (or (not win) 6639 (or (not win)
6641 (eq (window-buffer win) buf) 6640 (eq (window-buffer win) buf)
6642 (set-window-buffer win buf)) 6641 (set-window-buffer win buf))
6643 (and win (setq fr2 (window-frame win))) 6642 (pop-to-buffer buf)
6644 (if (or (not fr2) (eq fr1 fr2))
6645 (pop-to-buffer buf)
6646 (special-display-popup-frame buf) ; Make it visible
6647 (select-window win))
6648 (goto-char pos) ; Needed (?!). 6643 (goto-char pos) ; Needed (?!).
6649 ;; Resize 6644 ;; Resize
6650 (setq iniheight (window-height) 6645 (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)."
243 (typescript-mode :language-id "typescript")) 243 (typescript-mode :language-id "typescript"))
244 . ("typescript-language-server" "--stdio")) 244 . ("typescript-language-server" "--stdio"))
245 ((bash-ts-mode sh-mode) . ("bash-language-server" "start")) 245 ((bash-ts-mode sh-mode) . ("bash-language-server" "start"))
246 ((php-mode phps-mode) 246 ((php-mode phps-mode php-ts-mode)
247 . ,(eglot-alternatives 247 . ,(eglot-alternatives
248 '(("phpactor" "language-server") 248 '(("phpactor" "language-server")
249 ("php" "vendor/felixfbecker/language-server/bin/php-language-server.php")))) 249 ("php" "vendor/felixfbecker/language-server/bin/php-language-server.php"))))
@@ -259,7 +259,7 @@ automatically)."
259 . ("haskell-language-server-wrapper" "--lsp")) 259 . ("haskell-language-server-wrapper" "--lsp"))
260 (elm-mode . ("elm-language-server")) 260 (elm-mode . ("elm-language-server"))
261 (mint-mode . ("mint" "ls")) 261 (mint-mode . ("mint" "ls"))
262 (kotlin-mode . ("kotlin-language-server")) 262 ((kotlin-mode kotlin-ts-mode) . ("kotlin-language-server"))
263 ((go-mode go-dot-mod-mode go-dot-work-mode go-ts-mode go-mod-ts-mode) 263 ((go-mode go-dot-mod-mode go-dot-work-mode go-ts-mode go-mod-ts-mode)
264 . ("gopls")) 264 . ("gopls"))
265 ((R-mode ess-r-mode) . ("R" "--slave" "-e" 265 ((R-mode ess-r-mode) . ("R" "--slave" "-e"
@@ -284,6 +284,7 @@ automatically)."
284 ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio")) 284 ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio"))
285 (nix-mode . ,(eglot-alternatives '("nil" "rnix-lsp" "nixd"))) 285 (nix-mode . ,(eglot-alternatives '("nil" "rnix-lsp" "nixd")))
286 (nickel-mode . ("nls")) 286 (nickel-mode . ("nls"))
287 ((nushell-mode nushell-ts-mode) . ("nu" "--lsp"))
287 (gdscript-mode . ("localhost" 6008)) 288 (gdscript-mode . ("localhost" 6008))
288 ((fortran-mode f90-mode) . ("fortls")) 289 ((fortran-mode f90-mode) . ("fortls"))
289 (futhark-mode . ("futhark" "lsp")) 290 (futhark-mode . ("futhark" "lsp"))
@@ -309,7 +310,10 @@ automatically)."
309 ("vscode-markdown-language-server" "--stdio")))) 310 ("vscode-markdown-language-server" "--stdio"))))
310 (graphviz-dot-mode . ("dot-language-server" "--stdio")) 311 (graphviz-dot-mode . ("dot-language-server" "--stdio"))
311 (terraform-mode . ("terraform-ls" "serve")) 312 (terraform-mode . ("terraform-ls" "serve"))
312 ((uiua-ts-mode uiua-mode) . ("uiua" "lsp"))) 313 ((uiua-ts-mode uiua-mode) . ("uiua" "lsp"))
314 (sml-mode
315 . ,(lambda (_interactive project)
316 (list "millet-ls" (project-root project)))))
313 "How the command `eglot' guesses the server to start. 317 "How the command `eglot' guesses the server to start.
314An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE 318An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE
315identifies the buffers that are to be managed by a specific 319identifies the buffers that are to be managed by a specific
@@ -590,7 +594,7 @@ It is nil if Eglot is not byte-complied.")
590 (let ((vec (copy-sequence url-path-allowed-chars))) 594 (let ((vec (copy-sequence url-path-allowed-chars)))
591 (aset vec ?: nil) ;; see github#639 595 (aset vec ?: nil) ;; see github#639
592 vec) 596 vec)
593 "Like `url-path-allows-chars' but more restrictive.") 597 "Like `url-path-allowed-chars' but more restrictive.")
594 598
595 599
596;;; Message verification helpers 600;;; 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."
221 (load (byte-compile-dest-file buffer-file-name))) 221 (load (byte-compile-dest-file buffer-file-name)))
222 222
223(declare-function native-compile "comp") 223(declare-function native-compile "comp")
224(declare-function comp-write-bytecode-file "comp") 224(declare-function comp--write-bytecode-file "comp")
225 225
226(defun emacs-lisp-native-compile () 226(defun emacs-lisp-native-compile ()
227 "Native-compile the current buffer's file (if it has changed). 227 "Native-compile the current buffer's file (if it has changed).
@@ -233,7 +233,7 @@ visited by the current buffer."
233 (byte-to-native-output-buffer-file nil) 233 (byte-to-native-output-buffer-file nil)
234 (eln (native-compile buffer-file-name))) 234 (eln (native-compile buffer-file-name)))
235 (when eln 235 (when eln
236 (comp-write-bytecode-file eln)))) 236 (comp--write-bytecode-file eln))))
237 237
238(defun emacs-lisp-native-compile-and-load () 238(defun emacs-lisp-native-compile-and-load ()
239 "Native-compile the current buffer's file (if it has changed), then load it. 239 "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."
309INTERACTIVE non-nil means ask the user for confirmation; this 309INTERACTIVE non-nil means ask the user for confirmation; this
310happens in interactive invocations." 310happens in interactive invocations."
311 (interactive "p") 311 (interactive "p")
312 (if lexical-binding 312 (if (and (local-variable-p 'lexical-binding) lexical-binding)
313 (when interactive 313 (when interactive
314 (message "lexical-binding already enabled!") 314 (message "lexical-binding already enabled!")
315 (ding)) 315 (ding))
@@ -371,6 +371,12 @@ be used instead.
371 371
372;; Font-locking support. 372;; Font-locking support.
373 373
374(defun elisp--font-lock-shorthand (_limit)
375 ;; Add faces on shorthands between point and LIMIT.
376 ;; ...
377 ;; Return nil to tell font-lock, that there's nothing left to do.
378 nil)
379
374(defun elisp--font-lock-flush-elisp-buffers (&optional file) 380(defun elisp--font-lock-flush-elisp-buffers (&optional file)
375 ;; We're only ever called from after-load-functions, load-in-progress can 381 ;; We're only ever called from after-load-functions, load-in-progress can
376 ;; still be t in case of nested loads. 382 ;; still be t in case of nested loads.
@@ -1582,9 +1588,6 @@ character)."
1582 (buffer-substring-no-properties beg end)) 1588 (buffer-substring-no-properties beg end))
1583 )))) 1589 ))))
1584 1590
1585
1586(defvar elisp--eval-last-sexp-fake-value (make-symbol "t"))
1587
1588(defun eval-sexp-add-defvars (exp &optional pos) 1591(defun eval-sexp-add-defvars (exp &optional pos)
1589 "Prepend EXP with all the `defvar's that precede it in the buffer. 1592 "Prepend EXP with all the `defvar's that precede it in the buffer.
1590POS specifies the starting position where EXP was found and defaults to point." 1593POS 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.
1626If `eval-expression-debug-on-error' is non-nil, which is the default, 1629If `eval-expression-debug-on-error' is non-nil, which is the default,
1627this command arranges for all errors to enter the debugger." 1630this command arranges for all errors to enter the debugger."
1628 (interactive "P") 1631 (interactive "P")
1629 (if (null eval-expression-debug-on-error) 1632 (values--store-value
1630 (values--store-value 1633 (handler-bind ((error (if eval-expression-debug-on-error
1631 (elisp--eval-last-sexp eval-last-sexp-arg-internal)) 1634 #'eval-expression--debug #'ignore)))
1632 (let ((value 1635 (elisp--eval-last-sexp eval-last-sexp-arg-internal))))
1633 (let ((debug-on-error elisp--eval-last-sexp-fake-value))
1634 (cons (elisp--eval-last-sexp eval-last-sexp-arg-internal)
1635 debug-on-error))))
1636 (unless (eq (cdr value) elisp--eval-last-sexp-fake-value)
1637 (setq debug-on-error (cdr value)))
1638 (car value))))
1639 1636
1640(defun elisp--eval-defun-1 (form) 1637(defun elisp--eval-defun-1 (form)
1641 "Treat some expressions in FORM specially. 1638 "Treat some expressions in FORM specially.
@@ -1694,8 +1691,7 @@ Return the result of evaluation."
1694 ;; FIXME: the print-length/level bindings should only be applied while 1691 ;; FIXME: the print-length/level bindings should only be applied while
1695 ;; printing, not while evaluating. 1692 ;; printing, not while evaluating.
1696 (defvar elisp--eval-defun-result) 1693 (defvar elisp--eval-defun-result)
1697 (let ((debug-on-error eval-expression-debug-on-error) 1694 (let ((edebugging edebug-all-defs)
1698 (edebugging edebug-all-defs)
1699 elisp--eval-defun-result) 1695 elisp--eval-defun-result)
1700 (save-excursion 1696 (save-excursion
1701 ;; Arrange for eval-region to "read" the (possibly) altered form. 1697 ;; Arrange for eval-region to "read" the (possibly) altered form.
@@ -1774,15 +1770,9 @@ which see."
1774 (defvar edebug-all-defs) 1770 (defvar edebug-all-defs)
1775 (eval-defun (not edebug-all-defs))) 1771 (eval-defun (not edebug-all-defs)))
1776 (t 1772 (t
1777 (if (null eval-expression-debug-on-error) 1773 (handler-bind ((error (if eval-expression-debug-on-error
1778 (elisp--eval-defun) 1774 #'eval-expression--debug #'ignore)))
1779 (let (new-value value) 1775 (elisp--eval-defun)))))
1780 (let ((debug-on-error elisp--eval-last-sexp-fake-value))
1781 (setq value (elisp--eval-defun))
1782 (setq new-value debug-on-error))
1783 (unless (eq elisp--eval-last-sexp-fake-value new-value)
1784 (setq debug-on-error new-value))
1785 value)))))
1786 1776
1787;;; ElDoc Support 1777;;; ElDoc Support
1788 1778
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 @@
360(defvar elixir-ts--font-lock-settings 360(defvar elixir-ts--font-lock-settings
361 (treesit-font-lock-rules 361 (treesit-font-lock-rules
362 :language 'elixir 362 :language 'elixir
363 :feature 'elixir-function-name 363 :feature 'elixir-definition
364 `((call target: (identifier) @target-identifier 364 `((call target: (identifier) @target-identifier
365 (arguments
366 (call target: (identifier) @font-lock-function-name-face
367 (arguments)))
368 (:match ,elixir-ts--definition-keywords-re @target-identifier))
369 (call target: (identifier) @target-identifier
365 (arguments (identifier) @font-lock-function-name-face) 370 (arguments (identifier) @font-lock-function-name-face)
366 (:match ,elixir-ts--definition-keywords-re @target-identifier)) 371 (:match ,elixir-ts--definition-keywords-re @target-identifier))
367 (call target: (identifier) @target-identifier 372 (call target: (identifier) @target-identifier
368 (arguments 373 (arguments
369 (call target: (identifier) @font-lock-function-name-face)) 374 (call target: (identifier) @font-lock-function-name-face
375 (arguments ((identifier)) @font-lock-variable-name-face)))
370 (:match ,elixir-ts--definition-keywords-re @target-identifier)) 376 (:match ,elixir-ts--definition-keywords-re @target-identifier))
371 (call target: (identifier) @target-identifier 377 (call target: (identifier) @target-identifier
372 (arguments 378 (arguments
@@ -379,13 +385,15 @@
379 (:match ,elixir-ts--definition-keywords-re @target-identifier)) 385 (:match ,elixir-ts--definition-keywords-re @target-identifier))
380 (call target: (identifier) @target-identifier 386 (call target: (identifier) @target-identifier
381 (arguments 387 (arguments
382 (call target: (identifier) @font-lock-function-name-face)) 388 (call target: (identifier) @font-lock-function-name-face
389 (arguments ((identifier)) @font-lock-variable-name-face)))
383 (do_block) 390 (do_block)
384 (:match ,elixir-ts--definition-keywords-re @target-identifier)) 391 (:match ,elixir-ts--definition-keywords-re @target-identifier))
385 (call target: (identifier) @target-identifier 392 (call target: (identifier) @target-identifier
386 (arguments 393 (arguments
387 (binary_operator 394 (binary_operator
388 left: (call target: (identifier) @font-lock-function-name-face))) 395 left: (call target: (identifier) @font-lock-function-name-face
396 (arguments ((identifier)) @font-lock-variable-name-face))))
389 (do_block) 397 (do_block)
390 (:match ,elixir-ts--definition-keywords-re @target-identifier)) 398 (:match ,elixir-ts--definition-keywords-re @target-identifier))
391 (unary_operator 399 (unary_operator
@@ -521,8 +529,8 @@
521 operator: "/" right: (integer))) 529 operator: "/" right: (integer)))
522 (call 530 (call
523 target: (dot right: (identifier) @font-lock-function-call-face)) 531 target: (dot right: (identifier) @font-lock-function-call-face))
524 (unary_operator operator: "&" @font-lock-variable-name-face 532 (unary_operator operator: "&" @font-lock-variable-use-face
525 operand: (integer) @font-lock-variable-name-face) 533 operand: (integer) @font-lock-variable-use-face)
526 (unary_operator operator: "&" @font-lock-operator-face 534 (unary_operator operator: "&" @font-lock-operator-face
527 operand: (list))) 535 operand: (list)))
528 536
@@ -537,16 +545,18 @@
537 545
538 :language 'elixir 546 :language 'elixir
539 :feature 'elixir-variable 547 :feature 'elixir-variable
540 '((binary_operator left: (identifier) @font-lock-variable-name-face) 548 '((binary_operator left: (identifier) @font-lock-variable-use-face)
541 (binary_operator right: (identifier) @font-lock-variable-name-face) 549 (binary_operator right: (identifier) @font-lock-variable-use-face)
542 (arguments ( (identifier) @font-lock-variable-name-face)) 550 (arguments ( (identifier) @font-lock-variable-use-face))
543 (tuple (identifier) @font-lock-variable-name-face) 551 (tuple (identifier) @font-lock-variable-use-face)
544 (list (identifier) @font-lock-variable-name-face) 552 (list (identifier) @font-lock-variable-use-face)
545 (pair value: (identifier) @font-lock-variable-name-face) 553 (pair value: (identifier) @font-lock-variable-use-face)
546 (body (identifier) @font-lock-variable-name-face) 554 (body (identifier) @font-lock-variable-use-face)
547 (unary_operator operand: (identifier) @font-lock-variable-name-face) 555 (unary_operator operand: (identifier) @font-lock-variable-use-face)
548 (interpolation (identifier) @font-lock-variable-name-face) 556 (interpolation (identifier) @font-lock-variable-use-face)
549 (do_block (identifier) @font-lock-variable-name-face)) 557 (do_block (identifier) @font-lock-variable-use-face)
558 (access_call target: (identifier) @font-lock-variable-use-face)
559 (access_call "[" key: (identifier) @font-lock-variable-use-face "]"))
550 560
551 :language 'elixir 561 :language 'elixir
552 :feature 'elixir-builtin 562 :feature 'elixir-builtin
@@ -697,11 +707,10 @@ Return nil if NODE is not a defun node or doesn't have a name."
697 ;; Font-lock. 707 ;; Font-lock.
698 (setq-local treesit-font-lock-settings elixir-ts--font-lock-settings) 708 (setq-local treesit-font-lock-settings elixir-ts--font-lock-settings)
699 (setq-local treesit-font-lock-feature-list 709 (setq-local treesit-font-lock-feature-list
700 '(( elixir-comment elixir-doc elixir-function-name) 710 '(( elixir-comment elixir-doc elixir-definition)
701 ( elixir-string elixir-keyword elixir-data-type) 711 ( elixir-string elixir-keyword elixir-data-type)
702 ( elixir-sigil elixir-variable elixir-builtin 712 ( elixir-sigil elixir-builtin elixir-string-escape)
703 elixir-string-escape) 713 ( elixir-function-call elixir-variable elixir-operator elixir-number )))
704 ( elixir-function-call elixir-operator elixir-number )))
705 714
706 715
707 ;; Imenu. 716 ;; Imenu.
@@ -734,13 +743,12 @@ Return nil if NODE is not a defun node or doesn't have a name."
734 heex-ts--indent-rules)) 743 heex-ts--indent-rules))
735 744
736 (setq-local treesit-font-lock-feature-list 745 (setq-local treesit-font-lock-feature-list
737 '(( elixir-comment elixir-doc elixir-function-name 746 '(( elixir-comment elixir-doc elixir-definition
738 heex-comment heex-keyword heex-doctype ) 747 heex-comment heex-keyword heex-doctype )
739 ( elixir-string elixir-keyword elixir-data-type 748 ( elixir-string elixir-keyword elixir-data-type
740 heex-component heex-tag heex-attribute heex-string ) 749 heex-component heex-tag heex-attribute heex-string )
741 ( elixir-sigil elixir-variable elixir-builtin 750 ( elixir-sigil elixir-builtin elixir-string-escape)
742 elixir-string-escape) 751 ( elixir-function-call elixir-variable elixir-operator elixir-number ))))
743 ( elixir-function-call elixir-operator elixir-number ))))
744 752
745 (treesit-major-mode-setup) 753 (treesit-major-mode-setup)
746 (setq-local syntax-propertize-function #'elixir-ts--syntax-propertize))) 754 (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."
1488 (setq symbs (symbol-value symbs)) 1488 (setq symbs (symbol-value symbs))
1489 (insert (format-message "symbol `%s' has no value\n" symbs)) 1489 (insert (format-message "symbol `%s' has no value\n" symbs))
1490 (setq symbs nil))) 1490 (setq symbs nil)))
1491 (if (vectorp symbs) 1491 (if (obarrayp symbs)
1492 (mapatoms ins-symb symbs) 1492 (mapatoms ins-symb symbs)
1493 (dolist (sy symbs) 1493 (dolist (sy symbs)
1494 (funcall ins-symb (car sy)))) 1494 (funcall ins-symb (car sy))))
@@ -2183,7 +2183,7 @@ file name, add `tag-partial-file-name-match-p' to the list value.")
2183 (setq symbs (symbol-value symbs)) 2183 (setq symbs (symbol-value symbs))
2184 (warn "symbol `%s' has no value" symbs) 2184 (warn "symbol `%s' has no value" symbs)
2185 (setq symbs nil)) 2185 (setq symbs nil))
2186 (if (vectorp symbs) 2186 (if (obarrayp symbs)
2187 (mapatoms add-xref symbs) 2187 (mapatoms add-xref symbs)
2188 (dolist (sy symbs) 2188 (dolist (sy symbs)
2189 (funcall add-xref (car sy)))) 2189 (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.")
1569 ,flymake-mode-line-lighter 1569 ,flymake-mode-line-lighter
1570 mouse-face mode-line-highlight 1570 mouse-face mode-line-highlight
1571 help-echo 1571 help-echo
1572 ,(lambda (&rest _) 1572 ,(lambda (w &rest _)
1573 (concat 1573 (with-current-buffer (window-buffer w)
1574 (format "%s known backends\n" (hash-table-count flymake--state)) 1574 ;; Mouse can activate tool-tip without window being active.
1575 (format "%s running\n" (length (flymake-running-backends))) 1575 ;; `flymake--state' is buffer local and is null when line
1576 (format "%s disabled\n" (length (flymake-disabled-backends))) 1576 ;; lighter appears in *Help* `describe-mode'.
1577 "mouse-1: Display minor mode menu\n" 1577 (concat
1578 "mouse-2: Show help for minor mode")) 1578 (unless (null flymake--state)
1579 (concat
1580 (format "%s known backends\n" (hash-table-count flymake--state))
1581 (format "%s running\n" (length (flymake-running-backends)))
1582 (format "%s disabled\n" (length (flymake-disabled-backends)))))
1583 "mouse-1: Display minor mode menu\n"
1584 "mouse-2: Show help for minor mode")))
1579 keymap 1585 keymap
1580 ,(let ((map (make-sparse-keymap))) 1586 ,(let ((map (make-sparse-keymap)))
1581 (define-key map [mode-line down-mouse-1] 1587 (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")
243 :visible (eq gud-minor-mode 'gdbmi)] 243 :visible (eq gud-minor-mode 'gdbmi)]
244 ["Print Expression" gud-print 244 ["Print Expression" gud-print
245 :enable (not gud-running)] 245 :enable (not gud-running)]
246 ["Dump object-Derefenrece" gud-pstar 246 ["Dump object-Dereference" gud-pstar
247 :label (if (eq gud-minor-mode 'jdb) 247 :label (if (eq gud-minor-mode 'jdb)
248 "Dump object" 248 "Dump object"
249 "Print Dereference") 249 "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."
166 ("Slot" "\\`slot\\'" nil nil) 166 ("Slot" "\\`slot\\'" nil nil)
167 ("Tag" "\\`tag\\'" nil nil))) 167 ("Tag" "\\`tag\\'" nil nil)))
168 168
169 ;; Outline minor mode
170 ;; `heex-ts-mode' inherits from `html-mode' that sets
171 ;; regexp-based outline variables. So need to restore
172 ;; the default values of outline variables to be able
173 ;; to use `treesit-outline-predicate' derived
174 ;; from `treesit-simple-imenu-settings' above.
175 (kill-local-variable 'outline-heading-end-regexp)
176 (kill-local-variable 'outline-regexp)
177 (kill-local-variable 'outline-level)
178
169 (setq-local treesit-font-lock-settings heex-ts--font-lock-settings) 179 (setq-local treesit-font-lock-settings heex-ts--font-lock-settings)
170 180
171 (setq-local treesit-simple-indent-rules heex-ts--indent-rules) 181 (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."
390(defun hif-after-revert-function () 390(defun hif-after-revert-function ()
391 (and hide-ifdef-mode hide-ifdef-hiding 391 (and hide-ifdef-mode hide-ifdef-hiding
392 (hide-ifdefs nil nil t))) 392 (hide-ifdefs nil nil t)))
393(add-hook 'after-revert-hook 'hif-after-revert-function) 393(add-hook 'after-revert-hook #'hif-after-revert-function)
394 394
395(defun hif-end-of-line () 395(defun hif-end-of-line ()
396 "Find the end-point of line concatenation." 396 "Find the end-point of line concatenation."
@@ -474,7 +474,7 @@ Everything including these lines is made invisible."
474 474
475(defun hif-eval (form) 475(defun hif-eval (form)
476 "Evaluate hideif internal representation." 476 "Evaluate hideif internal representation."
477 (let ((val (eval form))) 477 (let ((val (eval form t)))
478 (if (stringp val) 478 (if (stringp val)
479 (or (get-text-property 0 'hif-value val) 479 (or (get-text-property 0 'hif-value val)
480 val) 480 val)
@@ -542,7 +542,7 @@ that form should be displayed.")
542(defconst hif-cpp-prefix "\\(^\\|\r\\)?[ \t]*#[ \t]*") 542(defconst hif-cpp-prefix "\\(^\\|\r\\)?[ \t]*#[ \t]*")
543(defconst hif-ifxdef-regexp (concat hif-cpp-prefix "if\\(n\\)?def")) 543(defconst hif-ifxdef-regexp (concat hif-cpp-prefix "if\\(n\\)?def"))
544(defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef")) 544(defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef"))
545(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\((\\|\\(n?def\\)?[ \t]+\\)")) 545(defvar hif-ifx-regexp (concat hif-cpp-prefix "if\\((\\|\\(n?def\\)?[ \t]+\\)"))
546(defconst hif-elif-regexp (concat hif-cpp-prefix "elif")) 546(defconst hif-elif-regexp (concat hif-cpp-prefix "elif"))
547(defconst hif-else-regexp (concat hif-cpp-prefix "else")) 547(defconst hif-else-regexp (concat hif-cpp-prefix "else"))
548(defconst hif-endif-regexp (concat hif-cpp-prefix "endif")) 548(defconst hif-endif-regexp (concat hif-cpp-prefix "endif"))
@@ -679,7 +679,7 @@ that form should be displayed.")
679 ("..." . hif-etc) 679 ("..." . hif-etc)
680 ("defined" . hif-defined))) 680 ("defined" . hif-defined)))
681 681
682(defconst hif-valid-token-list (mapcar 'cdr hif-token-alist)) 682(defconst hif-valid-token-list (mapcar #'cdr hif-token-alist))
683 683
684(defconst hif-token-regexp 684(defconst hif-token-regexp
685 ;; The ordering of regexp grouping is crucial to `hif-strtok' 685 ;; The ordering of regexp grouping is crucial to `hif-strtok'
@@ -690,7 +690,7 @@ that form should be displayed.")
690 ;; decimal/octal: 690 ;; decimal/octal:
691 "\\|\\(\\([+-]?[0-9']+\\(\\.[0-9']*\\)?\\)\\([eE][+-]?[0-9]+\\)?" 691 "\\|\\(\\([+-]?[0-9']+\\(\\.[0-9']*\\)?\\)\\([eE][+-]?[0-9]+\\)?"
692 hif-numtype-suffix-regexp "?\\)" 692 hif-numtype-suffix-regexp "?\\)"
693 "\\|" (regexp-opt (mapcar 'car hif-token-alist) t) 693 "\\|" (regexp-opt (mapcar #'car hif-token-alist) t)
694 "\\|\\(\\w+\\)")) 694 "\\|\\(\\w+\\)"))
695 695
696;; C++11 Unicode string literals (L"" u8"" u"" U"" R"" LR"" u8R"" uR"") 696;; 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."
867 867
868 (t 868 (t
869 (setq hif-simple-token-only nil) 869 (setq hif-simple-token-only nil)
870 (intern-safe string))))) 870 (hif--intern-safe string)))))
871 871
872(defun hif-backward-comment (&optional start end) 872(defun hif-backward-comment (&optional start end)
873 "If we're currently within a C(++) comment, skip them backwards." 873 "If we're currently within a C(++) comment, skip them backwards."
@@ -1448,7 +1448,7 @@ This macro cannot be evaluated alone without parameters input."
1448 (t 1448 (t
1449 (error "Invalid token to stringify")))) 1449 (error "Invalid token to stringify"))))
1450 1450
1451(defun intern-safe (str) 1451(defun hif--intern-safe (str)
1452 (if (stringp str) 1452 (if (stringp str)
1453 (intern str))) 1453 (intern str)))
1454 1454
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 @@
96 96
97(defcustom idlwave-shell-prompt-pattern "^\r? ?IDL> " 97(defcustom idlwave-shell-prompt-pattern "^\r? ?IDL> "
98 "Regexp to match IDL prompt at beginning of a line. 98 "Regexp to match IDL prompt at beginning of a line.
99For example, \"^\r?IDL> \" or \"^\r?WAVE> \". 99For example, \"^\\r?IDL> \" or \"^\\r?WAVE> \".
100The \"^\r?\" is needed, to indicate the beginning of the line, with 100The \"^\\r?\" is needed, to indicate the beginning of the line, with
101optional return character (which IDL seems to output randomly). 101optional return character (which IDL seems to output randomly).
102This variable is used to initialize `comint-prompt-regexp' in the 102This variable is used to initialize `comint-prompt-regexp' in the
103process buffer." 103process 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 @@
74 ((parent-is "program") column-0 0) 74 ((parent-is "program") column-0 0)
75 ((match "}" "element_value_array_initializer") 75 ((match "}" "element_value_array_initializer")
76 parent-bol 0) 76 parent-bol 0)
77 ((node-is "}") column-0 c-ts-common-statement-offset) 77 ((node-is
78 ,(format "\\`%s\\'"
79 (regexp-opt '("constructor_body" "class_body" "interface_body"
80 "block" "switch_block" "array_initializer"))))
81 parent-bol 0)
82 ((node-is "}") standalone-parent 0)
78 ((node-is ")") parent-bol 0) 83 ((node-is ")") parent-bol 0)
79 ((node-is "else") parent-bol 0) 84 ((node-is "else") parent-bol 0)
80 ((node-is "]") parent-bol 0) 85 ((node-is "]") parent-bol 0)
@@ -86,10 +91,10 @@
86 ((parent-is "array_initializer") parent-bol java-ts-mode-indent-offset) 91 ((parent-is "array_initializer") parent-bol java-ts-mode-indent-offset)
87 ((parent-is "annotation_type_body") column-0 c-ts-common-statement-offset) 92 ((parent-is "annotation_type_body") column-0 c-ts-common-statement-offset)
88 ((parent-is "interface_body") column-0 c-ts-common-statement-offset) 93 ((parent-is "interface_body") column-0 c-ts-common-statement-offset)
89 ((parent-is "constructor_body") column-0 c-ts-common-statement-offset) 94 ((parent-is "constructor_body") standalone-parent java-ts-mode-indent-offset)
90 ((parent-is "enum_body_declarations") parent-bol 0) 95 ((parent-is "enum_body_declarations") parent-bol 0)
91 ((parent-is "enum_body") column-0 c-ts-common-statement-offset) 96 ((parent-is "enum_body") column-0 c-ts-common-statement-offset)
92 ((parent-is "switch_block") column-0 c-ts-common-statement-offset) 97 ((parent-is "switch_block") standalone-parent java-ts-mode-indent-offset)
93 ((parent-is "record_declaration_body") column-0 c-ts-common-statement-offset) 98 ((parent-is "record_declaration_body") column-0 c-ts-common-statement-offset)
94 ((query "(method_declaration (block _ @indent))") parent-bol java-ts-mode-indent-offset) 99 ((query "(method_declaration (block _ @indent))") parent-bol java-ts-mode-indent-offset)
95 ((query "(method_declaration (block (_) @indent))") parent-bol java-ts-mode-indent-offset) 100 ((query "(method_declaration (block (_) @indent))") parent-bol java-ts-mode-indent-offset)
@@ -125,7 +130,7 @@
125 ((parent-is "case_statement") parent-bol java-ts-mode-indent-offset) 130 ((parent-is "case_statement") parent-bol java-ts-mode-indent-offset)
126 ((parent-is "labeled_statement") parent-bol java-ts-mode-indent-offset) 131 ((parent-is "labeled_statement") parent-bol java-ts-mode-indent-offset)
127 ((parent-is "do_statement") parent-bol java-ts-mode-indent-offset) 132 ((parent-is "do_statement") parent-bol java-ts-mode-indent-offset)
128 ((parent-is "block") column-0 c-ts-common-statement-offset))) 133 ((parent-is "block") standalone-parent java-ts-mode-indent-offset)))
129 "Tree-sitter indent rules.") 134 "Tree-sitter indent rules.")
130 135
131(defvar java-ts-mode--keywords 136(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'."
3418 3418
3419;;; Tree sitter integration 3419;;; Tree sitter integration
3420 3420
3421(defun js--treesit-font-lock-compatibility-definition-feature ()
3422 "Font lock helper, to handle different releases of tree-sitter-javascript.
3423Check if a node type is available, then return the right font lock rules
3424for \"definition\" feature."
3425 (condition-case nil
3426 (progn (treesit-query-capture 'javascript '((function_expression) @cap))
3427 ;; Starting from version 0.20.2 of the grammar.
3428 '((function_expression
3429 name: (identifier) @font-lock-function-name-face)
3430 (variable_declarator
3431 name: (identifier) @font-lock-function-name-face
3432 value: [(function_expression) (arrow_function)])))
3433 (error
3434 ;; An older version of the grammar.
3435 '((function
3436 name: (identifier) @font-lock-function-name-face)
3437 (variable_declarator
3438 name: (identifier) @font-lock-function-name-face
3439 value: [(function) (arrow_function)])))))
3440
3421(defun js-jsx--treesit-indent-compatibility-bb1f97b () 3441(defun js-jsx--treesit-indent-compatibility-bb1f97b ()
3422 "Indent rules helper, to handle different releases of tree-sitter-javascript. 3442 "Indent rules helper, to handle different releases of tree-sitter-javascript.
3423Check if a node type is available, then return the right indent rules." 3443Check 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."
3529 3549
3530 :language 'javascript 3550 :language 'javascript
3531 :feature 'definition 3551 :feature 'definition
3532 '((function 3552 `(,@(js--treesit-font-lock-compatibility-definition-feature)
3533 name: (identifier) @font-lock-function-name-face)
3534 3553
3535 (class_declaration 3554 (class_declaration
3536 name: (identifier) @font-lock-type-face) 3555 name: (identifier) @font-lock-type-face)
@@ -3550,10 +3569,6 @@ Check if a node type is available, then return the right indent rules."
3550 name: (identifier) @font-lock-variable-name-face) 3569 name: (identifier) @font-lock-variable-name-face)
3551 3570
3552 (variable_declarator 3571 (variable_declarator
3553 name: (identifier) @font-lock-function-name-face
3554 value: [(function) (arrow_function)])
3555
3556 (variable_declarator
3557 name: [(array_pattern (identifier) @font-lock-variable-name-face) 3572 name: [(array_pattern (identifier) @font-lock-variable-name-face)
3558 (object_pattern 3573 (object_pattern
3559 (shorthand_property_identifier_pattern) @font-lock-variable-name-face)]) 3574 (shorthand_property_identifier_pattern) @font-lock-variable-name-face)])
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 @@
26;; This package provides `lua-ts-mode' which is a major mode for Lua 26;; This package provides `lua-ts-mode' which is a major mode for Lua
27;; files that uses Tree Sitter to parse the language. 27;; files that uses Tree Sitter to parse the language.
28;; 28;;
29;; This package is compatible with and tested against the grammar 29;; This package is compatible with and tested against the grammar for
30;; for Lua found at https://github.com/MunifTanjim/tree-sitter-lua 30;; Lua found at https://github.com/tree-sitter-grammars/tree-sitter-lua
31 31
32;;; Code: 32;;; Code:
33 33
@@ -317,6 +317,8 @@ values of OVERRIDE."
317 (node-is ")") 317 (node-is ")")
318 (node-is "}")) 318 (node-is "}"))
319 standalone-parent 0) 319 standalone-parent 0)
320 ((match null "table_constructor")
321 standalone-parent lua-ts-indent-offset)
320 ((or (and (parent-is "arguments") lua-ts--first-child-matcher) 322 ((or (and (parent-is "arguments") lua-ts--first-child-matcher)
321 (and (parent-is "parameters") lua-ts--first-child-matcher) 323 (and (parent-is "parameters") lua-ts--first-child-matcher)
322 (and (parent-is "table_constructor") lua-ts--first-child-matcher)) 324 (and (parent-is "table_constructor") lua-ts--first-child-matcher))
@@ -774,7 +776,7 @@ Calls REPORT-FN directly."
774 "vararg_expression")))) 776 "vararg_expression"))))
775 (text "comment")))) 777 (text "comment"))))
776 778
777 ;; Imenu. 779 ;; Imenu/Outline.
778 (setq-local treesit-simple-imenu-settings 780 (setq-local treesit-simple-imenu-settings
779 `(("Requires" 781 `(("Requires"
780 "\\`function_call\\'" 782 "\\`function_call\\'"
@@ -789,16 +791,6 @@ Calls REPORT-FN directly."
789 ;; Which-function. 791 ;; Which-function.
790 (setq-local which-func-functions (treesit-defun-at-point)) 792 (setq-local which-func-functions (treesit-defun-at-point))
791 793
792 ;; Outline.
793 (setq-local outline-regexp
794 (rx (seq (0+ space)
795 (or (seq "--[[" (0+ space) eol)
796 (seq symbol-start
797 (or "do" "for" "if" "repeat" "while"
798 (seq (? (seq "local" (1+ space)))
799 "function"))
800 symbol-end)))))
801
802 ;; Align. 794 ;; Align.
803 (setq-local align-indent-before-aligning t) 795 (setq-local align-indent-before-aligning t)
804 796
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.
325 ;; 325 ;;
326 ;; Module definitions. 326 ;; Module definitions.
327 ("\\<\\(INTERFACE\\|MODULE\\|PROCEDURE\\)\\>[ \t]*\\(\\sw+\\)?" 327 ("\\<\\(INTERFACE\\|MODULE\\|PROCEDURE\\)\\>[ \t]*\\(\\sw+\\)?"
328 (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) 328 (1 'font-lock-keyword-face) (2 'font-lock-function-name-face nil t))
329 ;; 329 ;;
330 ;; Import directives. 330 ;; Import directives.
331 ("\\<\\(EXPORTS\\|FROM\\|IMPORT\\)\\>" 331 ("\\<\\(EXPORTS\\|FROM\\|IMPORT\\)\\>"
332 (1 font-lock-keyword-face) 332 (1 'font-lock-keyword-face)
333 (font-lock-match-c-style-declaration-item-and-skip-to-next 333 (font-lock-match-c-style-declaration-item-and-skip-to-next
334 nil (goto-char (match-end 0)) 334 nil (goto-char (match-end 0))
335 (1 font-lock-constant-face))) 335 (1 'font-lock-constant-face)))
336 ;; 336 ;;
337 ;; Pragmas as warnings. 337 ;; Pragmas as warnings.
338 ;; Spencer Allain <sallain@teknowledge.com> says do them as comments... 338 ;; Spencer Allain <sallain@teknowledge.com> says do them as comments...
339 ;; ("<\\*.*\\*>" . font-lock-warning-face) 339 ;; ("<\\*.*\\*>" . font-lock-warning-face)
340 ;; ... but instead we fontify the first word. 340 ;; ... but instead we fontify the first word.
341 ("<\\*[ \t]*\\(\\sw+\\)" 1 font-lock-warning-face prepend) 341 ("<\\*[ \t]*\\(\\sw+\\)" 1 'font-lock-warning-face prepend)
342 ) 342 )
343 "Subdued level highlighting for Modula-3 modes.") 343 "Subdued level highlighting for Modula-3 modes.")
344 344
@@ -366,26 +366,29 @@ followed by the first character of the construct.
366 "LOOPHOLE" "MAX" "MIN" "NARROW" "NEW" "NUMBER" "ORD" 366 "LOOPHOLE" "MAX" "MIN" "NARROW" "NEW" "NUMBER" "ORD"
367 "ROUND" "SUBARRAY" "TRUNC" "TYPECODE" "VAL"))) 367 "ROUND" "SUBARRAY" "TRUNC" "TYPECODE" "VAL")))
368 ) 368 )
369 (list 369 `(
370 ;; 370 ;;
371 ;; Keywords except those fontified elsewhere. 371 ;; Keywords except those fontified elsewhere.
372 (concat "\\<\\(" m3-keywords "\\)\\>") 372 ,(concat "\\<\\(" m3-keywords "\\)\\>")
373 ;; 373 ;;
374 ;; Builtins. 374 ;; Builtins.
375 (cons (concat "\\<\\(" m3-builtins "\\)\\>") 'font-lock-builtin-face) 375 (,(concat "\\<\\(" m3-builtins "\\)\\>")
376 ;; 376 (0 'font-lock-builtin-face))
377 ;; Type names. 377 ;;
378 (cons (concat "\\<\\(" m3-types "\\)\\>") 'font-lock-type-face) 378 ;; Type names.
379 ;; 379 (,(concat "\\<\\(" m3-types "\\)\\>")
380 ;; Fontify tokens as function names. 380 (0 'font-lock-type-face))
381 '("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*" 381 ;;
382 (1 font-lock-keyword-face) 382 ;; Fontify tokens as function names.
383 ("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*"
384 (1 'font-lock-keyword-face)
383 (font-lock-match-c-style-declaration-item-and-skip-to-next 385 (font-lock-match-c-style-declaration-item-and-skip-to-next
384 nil (goto-char (match-end 0)) 386 nil (goto-char (match-end 0))
385 (1 font-lock-function-name-face))) 387 (1 'font-lock-function-name-face)))
386 ;; 388 ;;
387 ;; Fontify constants as references. 389 ;; Fontify constants as references.
388 '("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>" . font-lock-constant-face) 390 ("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>"
391 (0 'font-lock-constant-face))
389 )))) 392 ))))
390 "Gaudy level highlighting for Modula-3 modes.") 393 "Gaudy level highlighting for Modula-3 modes.")
391 394
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.")
281 281
282(eval-when-compile 282(eval-when-compile
283 (pcase-defmacro opascal--in (set) 283 (pcase-defmacro opascal--in (set)
284 `(pred (pcase--flip memq ,set)))) 284 `(pred (memq _ ,set))))
285 285
286(defun opascal-string-of (start end) 286(defun opascal-string-of (start end)
287 ;; Returns the buffer string from start to end. 287 ;; 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>'."
992 992
993;;;###autoload 993;;;###autoload
994(defun project-or-external-find-regexp (regexp) 994(defun project-or-external-find-regexp (regexp)
995 "Find all matches for REGEXP in the project roots or external roots. 995 "Find all matches for REGEXP in the project roots or external roots."
996With \\[universal-argument] prefix, you can specify the file name
997pattern to search for."
998 (interactive (list (project--read-regexp))) 996 (interactive (list (project--read-regexp)))
999 (require 'xref) 997 (require 'xref)
1000 (let* ((pr (project-current t)) 998 (let* ((pr (project-current t))
@@ -1515,7 +1513,8 @@ ARG, show only buffers that are visiting files."
1515 (lambda (buffer) 1513 (lambda (buffer)
1516 (let ((name (buffer-name buffer)) 1514 (let ((name (buffer-name buffer))
1517 (file (buffer-file-name buffer))) 1515 (file (buffer-file-name buffer)))
1518 (and (or (not (string= (substring name 0 1) " ")) 1516 (and (or Buffer-menu-show-internal
1517 (not (string= (substring name 0 1) " "))
1519 file) 1518 file)
1520 (not (eq buffer (current-buffer))) 1519 (not (eq buffer (current-buffer)))
1521 (or file (not Buffer-menu-files-only))))) 1520 (or file (not Buffer-menu-files-only)))))
@@ -1525,6 +1524,7 @@ ARG, show only buffers that are visiting files."
1525 (let ((buf (list-buffers-noselect 1524 (let ((buf (list-buffers-noselect
1526 arg (with-current-buffer 1525 arg (with-current-buffer
1527 (get-buffer-create "*Buffer List*") 1526 (get-buffer-create "*Buffer List*")
1527 (setq-local Buffer-menu-show-internal nil)
1528 (let ((Buffer-menu-files-only arg)) 1528 (let ((Buffer-menu-files-only arg))
1529 (funcall buffer-list-function)))))) 1529 (funcall buffer-list-function))))))
1530 (with-current-buffer buf 1530 (with-current-buffer buf
@@ -1866,12 +1866,12 @@ Otherwise, `default-directory' is temporarily set to the current
1866project's root. 1866project's root.
1867 1867
1868If OVERRIDING-MAP is non-nil, it will be used as 1868If OVERRIDING-MAP is non-nil, it will be used as
1869`overriding-local-map' to provide shorter bindings from that map 1869`overriding-terminal-local-map' to provide shorter bindings
1870which will take priority over the global ones." 1870from that map which will take priority over the global ones."
1871 (interactive) 1871 (interactive)
1872 (let* ((pr (project-current t)) 1872 (let* ((pr (project-current t))
1873 (prompt-format (or prompt-format "[execute in %s]:")) 1873 (prompt-format (or prompt-format "[execute in %s]:"))
1874 (command (let ((overriding-local-map overriding-map)) 1874 (command (let ((overriding-terminal-local-map overriding-map))
1875 (key-binding (read-key-sequence 1875 (key-binding (read-key-sequence
1876 (format prompt-format (project-root pr))) 1876 (format prompt-format (project-root pr)))
1877 t))) 1877 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 @@
5;; Author: Fabián E. Gallina <fgallina@gnu.org> 5;; Author: Fabián E. Gallina <fgallina@gnu.org>
6;; URL: https://github.com/fgallina/python.el 6;; URL: https://github.com/fgallina/python.el
7;; Version: 0.28 7;; Version: 0.28
8;; Package-Requires: ((emacs "24.4") (compat "28.1.2.1") (seq "2.23")) 8;; Package-Requires: ((emacs "24.4") (compat "29.1.1.0") (seq "2.23"))
9;; Maintainer: emacs-devel@gnu.org 9;; Maintainer: emacs-devel@gnu.org
10;; Created: Jul 2010 10;; Created: Jul 2010
11;; Keywords: languages 11;; Keywords: languages
@@ -128,9 +128,9 @@
128;; receiving escape sequences (with some limitations, i.e. completion 128;; receiving escape sequences (with some limitations, i.e. completion
129;; in blocks does not work). The code executed for the "fallback" 129;; in blocks does not work). The code executed for the "fallback"
130;; completion can be found in `python-shell-completion-setup-code' and 130;; completion can be found in `python-shell-completion-setup-code' and
131;; `python-shell-completion-string-code' variables. Their default 131;; `python-shell-completion-get-completions'. Their default values
132;; values enable completion for both CPython and IPython, and probably 132;; enable completion for both CPython and IPython, and probably any
133;; any readline based shell (it's known to work with PyPy). If your 133;; readline based shell (it's known to work with PyPy). If your
134;; Python installation lacks readline (like CPython for Windows), 134;; Python installation lacks readline (like CPython for Windows),
135;; installing pyreadline (URL `https://ipython.org/pyreadline.html') 135;; installing pyreadline (URL `https://ipython.org/pyreadline.html')
136;; should suffice. To troubleshoot why you are not getting any 136;; should suffice. To troubleshoot why you are not getting any
@@ -141,6 +141,12 @@
141;; If you see an error, then you need to either install pyreadline or 141;; If you see an error, then you need to either install pyreadline or
142;; setup custom code that avoids that dependency. 142;; setup custom code that avoids that dependency.
143 143
144;; By default, the "native" completion uses the built-in rlcompleter.
145;; To use other readline completer (e.g. Jedi) or a custom one, you just
146;; need to set it in the PYTHONSTARTUP file. You can set an
147;; Emacs-specific completer by testing the environment variable
148;; INSIDE_EMACS.
149
144;; Shell virtualenv support: The shell also contains support for 150;; Shell virtualenv support: The shell also contains support for
145;; virtualenvs and other special environment modifications thanks to 151;; virtualenvs and other special environment modifications thanks to
146;; `python-shell-process-environment' and `python-shell-exec-path'. 152;; `python-shell-process-environment' and `python-shell-exec-path'.
@@ -267,7 +273,7 @@
267(eval-when-compile (require 'subr-x)) ;For `string-empty-p' and `string-join'. 273(eval-when-compile (require 'subr-x)) ;For `string-empty-p' and `string-join'.
268(require 'treesit) 274(require 'treesit)
269(require 'pcase) 275(require 'pcase)
270(require 'compat nil 'noerror) 276(require 'compat)
271(require 'project nil 'noerror) 277(require 'project nil 'noerror)
272(require 'seq) 278(require 'seq)
273 279
@@ -3515,6 +3521,16 @@ eventually provide a shell."
3515 :version "25.1" 3521 :version "25.1"
3516 :type 'hook) 3522 :type 'hook)
3517 3523
3524(defconst python-shell-setup-code
3525 "\
3526try:
3527 import tty
3528except ImportError:
3529 pass
3530else:
3531 tty.setraw(0)"
3532 "Code used to setup the inferior Python processes.")
3533
3518(defconst python-shell-eval-setup-code 3534(defconst python-shell-eval-setup-code
3519 "\ 3535 "\
3520def __PYTHON_EL_eval(source, filename): 3536def __PYTHON_EL_eval(source, filename):
@@ -3580,6 +3596,7 @@ The coding cookie regexp is specified in PEP 263.")
3580 (format "exec(%s)\n" (python-shell--encode-string string)))))) 3596 (format "exec(%s)\n" (python-shell--encode-string string))))))
3581 ;; Bootstrap: the normal definition of `python-shell-send-string' 3597 ;; Bootstrap: the normal definition of `python-shell-send-string'
3582 ;; depends on the Python code sent here. 3598 ;; depends on the Python code sent here.
3599 (python-shell-send-string-no-output python-shell-setup-code)
3583 (python-shell-send-string-no-output python-shell-eval-setup-code) 3600 (python-shell-send-string-no-output python-shell-eval-setup-code)
3584 (python-shell-send-string-no-output python-shell-eval-file-setup-code)) 3601 (python-shell-send-string-no-output python-shell-eval-file-setup-code))
3585 (with-current-buffer (current-buffer) 3602 (with-current-buffer (current-buffer)
@@ -3604,7 +3621,6 @@ interpreter is run. Variables
3604`python-shell-prompt-block-regexp', 3621`python-shell-prompt-block-regexp',
3605`python-shell-font-lock-enable', 3622`python-shell-font-lock-enable',
3606`python-shell-completion-setup-code', 3623`python-shell-completion-setup-code',
3607`python-shell-completion-string-code',
3608`python-eldoc-setup-code', 3624`python-eldoc-setup-code',
3609`python-ffap-setup-code' can 3625`python-ffap-setup-code' can
3610customize this mode for different Python interpreters. 3626customize this mode for different Python interpreters.
@@ -4244,8 +4260,9 @@ def __PYTHON_EL_get_completions(text):
4244 completions = [] 4260 completions = []
4245 completer = None 4261 completer = None
4246 4262
4263 import json
4247 try: 4264 try:
4248 import readline 4265 import readline, re
4249 4266
4250 try: 4267 try:
4251 import __builtin__ 4268 import __builtin__
@@ -4256,16 +4273,29 @@ def __PYTHON_EL_get_completions(text):
4256 4273
4257 is_ipython = ('__IPYTHON__' in builtins or 4274 is_ipython = ('__IPYTHON__' in builtins or
4258 '__IPYTHON__active' in builtins) 4275 '__IPYTHON__active' in builtins)
4259 splits = text.split() 4276
4260 is_module = splits and splits[0] in ('from', 'import') 4277 if is_ipython and 'get_ipython' in builtins:
4261 4278 def filter_c(prefix, c):
4262 if is_ipython and is_module: 4279 if re.match('_+(i?[0-9]+)?$', c):
4263 from IPython.core.completerlib import module_completion 4280 return False
4264 completions = module_completion(text.strip()) 4281 elif c[0] == '%' and not re.match('[%a-zA-Z]+$', prefix):
4265 elif is_ipython and '__IP' in builtins: 4282 return False
4266 completions = __IP.complete(text) 4283 return True
4267 elif is_ipython and 'get_ipython' in builtins: 4284
4268 completions = get_ipython().Completer.all_completions(text) 4285 import IPython
4286 try:
4287 if IPython.version_info[0] >= 6:
4288 from IPython.core.completer import provisionalcompleter
4289 with provisionalcompleter():
4290 completions = [
4291 [c.text, c.start, c.end, c.type or '?', c.signature or '']
4292 for c in get_ipython().Completer.completions(text, len(text))
4293 if filter_c(text, c.text)]
4294 else:
4295 part, matches = get_ipython().Completer.complete(line_buffer=text)
4296 completions = [text + m[len(part):] for m in matches if filter_c(text, m)]
4297 except:
4298 pass
4269 else: 4299 else:
4270 # Try to reuse current completer. 4300 # Try to reuse current completer.
4271 completer = readline.get_completer() 4301 completer = readline.get_completer()
@@ -4288,7 +4318,7 @@ def __PYTHON_EL_get_completions(text):
4288 finally: 4318 finally:
4289 if getattr(completer, 'PYTHON_EL_WRAPPED', False): 4319 if getattr(completer, 'PYTHON_EL_WRAPPED', False):
4290 completer.print_mode = True 4320 completer.print_mode = True
4291 return completions" 4321 return json.dumps(completions)"
4292 "Code used to setup completion in inferior Python processes." 4322 "Code used to setup completion in inferior Python processes."
4293 :type 'string) 4323 :type 'string)
4294 4324
@@ -4329,6 +4359,10 @@ When a match is found, native completion is disabled."
4329 :version "25.1" 4359 :version "25.1"
4330 :type 'float) 4360 :type 'float)
4331 4361
4362(defvar python-shell-readline-completer-delims nil
4363 "Word delimiters used by the readline completer.
4364It is automatically set by Python shell.")
4365
4332(defvar python-shell-completion-native-redirect-buffer 4366(defvar python-shell-completion-native-redirect-buffer
4333 " *Python completions redirect*" 4367 " *Python completions redirect*"
4334 "Buffer to be used to redirect output of readline commands.") 4368 "Buffer to be used to redirect output of readline commands.")
@@ -4467,6 +4501,10 @@ def __PYTHON_EL_native_completion_setup():
4467__PYTHON_EL_native_completion_setup()" process))) 4501__PYTHON_EL_native_completion_setup()" process)))
4468 (when (string-match-p "python\\.el: native completion setup loaded" 4502 (when (string-match-p "python\\.el: native completion setup loaded"
4469 output) 4503 output)
4504 (setq-local python-shell-readline-completer-delims
4505 (string-trim-right
4506 (python-shell-send-string-no-output
4507 "import readline; print(readline.get_completer_delims())")))
4470 (python-shell-completion-native-try)))) 4508 (python-shell-completion-native-try))))
4471 4509
4472(defun python-shell-completion-native-turn-off (&optional msg) 4510(defun python-shell-completion-native-turn-off (&optional msg)
@@ -4498,18 +4536,11 @@ With argument MSG show activation/deactivation message."
4498 ((python-shell-completion-native-setup) 4536 ((python-shell-completion-native-setup)
4499 (when msg 4537 (when msg
4500 (message "Shell native completion is enabled."))) 4538 (message "Shell native completion is enabled.")))
4501 (t (lwarn 4539 (t
4502 '(python python-shell-completion-native-turn-on-maybe) 4540 (when msg
4503 :warning 4541 (message (concat "Python does not use GNU readline;"
4504 (concat 4542 " no completion in multi-line commands.")))
4505 "Your `python-shell-interpreter' doesn't seem to " 4543 (python-shell-completion-native-turn-off nil))))))
4506 "support readline, yet `python-shell-completion-native-enable' "
4507 (format "was t and %S is not part of the "
4508 (file-name-nondirectory python-shell-interpreter))
4509 "`python-shell-completion-native-disabled-interpreters' "
4510 "list. Native completions have been disabled locally. "
4511 "Consider installing the python package \"readline\". "))
4512 (python-shell-completion-native-turn-off msg))))))
4513 4544
4514(defun python-shell-completion-native-turn-on-maybe-with-msg () 4545(defun python-shell-completion-native-turn-on-maybe-with-msg ()
4515 "Like `python-shell-completion-native-turn-on-maybe' but force messages." 4546 "Like `python-shell-completion-native-turn-on-maybe' but force messages."
@@ -4534,6 +4565,8 @@ With argument MSG show activation/deactivation message."
4534 (let* ((original-filter-fn (process-filter process)) 4565 (let* ((original-filter-fn (process-filter process))
4535 (redirect-buffer (get-buffer-create 4566 (redirect-buffer (get-buffer-create
4536 python-shell-completion-native-redirect-buffer)) 4567 python-shell-completion-native-redirect-buffer))
4568 (sep (if (string= python-shell-readline-completer-delims "")
4569 "[\n\r]+" "[ \f\t\n\r\v()]+"))
4537 (trigger "\t") 4570 (trigger "\t")
4538 (new-input (concat input trigger)) 4571 (new-input (concat input trigger))
4539 (input-length 4572 (input-length
@@ -4576,28 +4609,80 @@ With argument MSG show activation/deactivation message."
4576 process python-shell-completion-native-output-timeout 4609 process python-shell-completion-native-output-timeout
4577 comint-redirect-finished-regexp) 4610 comint-redirect-finished-regexp)
4578 (re-search-backward "0__dummy_completion__" nil t) 4611 (re-search-backward "0__dummy_completion__" nil t)
4579 (cl-remove-duplicates 4612 (let ((str (buffer-substring-no-properties
4580 (split-string 4613 (line-beginning-position) (point-min))))
4581 (buffer-substring-no-properties 4614 ;; The readline completer is allowed to return a list
4582 (line-beginning-position) (point-min)) 4615 ;; of (text start end type signature) as a JSON
4583 "[ \f\t\n\r\v()]+" t) 4616 ;; string. See the return value for IPython in
4584 :test #'string=)))) 4617 ;; `python-shell-completion-setup-code'.
4618 (if (string= "[" (substring str 0 1))
4619 (condition-case nil
4620 (python--parse-json-array str)
4621 (t (cl-remove-duplicates (split-string str sep t)
4622 :test #'string=)))
4623 (cl-remove-duplicates (split-string str sep t)
4624 :test #'string=))))))
4585 (set-process-filter process original-filter-fn))))) 4625 (set-process-filter process original-filter-fn)))))
4586 4626
4587(defun python-shell-completion-get-completions (process input) 4627(defun python-shell-completion-get-completions (process input)
4588 "Get completions of INPUT using PROCESS." 4628 "Get completions of INPUT using PROCESS."
4589 (with-current-buffer (process-buffer process) 4629 (with-current-buffer (process-buffer process)
4590 (let ((completions 4630 (python--parse-json-array
4591 (python-util-strip-string 4631 (python-shell-send-string-no-output
4592 (python-shell-send-string-no-output 4632 (format "%s\nprint(__PYTHON_EL_get_completions(%s))"
4593 (format
4594 "%s\nprint(';'.join(__PYTHON_EL_get_completions(%s)))"
4595 python-shell-completion-setup-code 4633 python-shell-completion-setup-code
4596 (python-shell--encode-string input)) 4634 (python-shell--encode-string input))
4597 process)))) 4635 process))))
4598 (when (> (length completions) 2) 4636
4599 (split-string completions 4637(defun python-shell--get-multiline-input ()
4600 "^'\\|^\"\\|;\\|'$\\|\"$" t))))) 4638 "Return lines at a multi-line input in Python shell."
4639 (save-excursion
4640 (let ((p (point)) lines)
4641 (when (progn
4642 (beginning-of-line)
4643 (looking-back python-shell-prompt-block-regexp (pos-bol)))
4644 (push (buffer-substring-no-properties (point) p) lines)
4645 (while (progn (comint-previous-prompt 1)
4646 (looking-back python-shell-prompt-block-regexp (pos-bol)))
4647 (push (buffer-substring-no-properties (point) (pos-eol)) lines))
4648 (push (buffer-substring-no-properties (point) (pos-eol)) lines))
4649 lines)))
4650
4651(defun python-shell--extra-completion-context ()
4652 "Get extra completion context of current input in Python shell."
4653 (let ((lines (python-shell--get-multiline-input))
4654 (python-indent-guess-indent-offset nil))
4655 (when (not (zerop (length lines)))
4656 (with-temp-buffer
4657 (delay-mode-hooks
4658 (insert (string-join lines "\n"))
4659 (python-mode)
4660 (python-shell-completion-extra-context))))))
4661
4662(defun python-shell-completion-extra-context (&optional pos)
4663 "Get extra completion context at position POS in Python buffer.
4664If optional argument POS is nil, use current position.
4665
4666Readline completers could use current line as the completion
4667context, which may be insufficient. In this function, extra
4668context (e.g. multi-line function call) is found and reformatted
4669as one line, which is required by native completion."
4670 (let (bound p)
4671 (save-excursion
4672 (and pos (goto-char pos))
4673 (setq bound (pos-bol))
4674 (python-nav-up-list -1)
4675 (when (and (< (point) bound)
4676 (or
4677 (looking-back
4678 (python-rx (group (+ (or "." symbol-name)))) (pos-bol) t)
4679 (progn
4680 (forward-line 0)
4681 (looking-at "^[ \t]*\\(from \\)"))))
4682 (setq p (match-beginning 1))))
4683 (when p
4684 (replace-regexp-in-string
4685 "\n[ \t]*" "" (buffer-substring-no-properties p (1- bound))))))
4601 4686
4602(defvar-local python-shell--capf-cache nil 4687(defvar-local python-shell--capf-cache nil
4603 "Variable to store cached completions and invalidation keys.") 4688 "Variable to store cached completions and invalidation keys.")
@@ -4612,21 +4697,26 @@ using that one instead of current buffer's process."
4612 ;; Working on a shell buffer: use prompt end. 4697 ;; Working on a shell buffer: use prompt end.
4613 (cdr (python-util-comint-last-prompt)) 4698 (cdr (python-util-comint-last-prompt))
4614 (line-beginning-position))) 4699 (line-beginning-position)))
4615 (import-statement 4700 (no-delims
4616 (when (string-match-p 4701 (and (not (if is-shell-buffer
4617 (rx (* space) word-start (or "from" "import") word-end space) 4702 (eq 'font-lock-comment-face
4618 (buffer-substring-no-properties line-start (point))) 4703 (get-text-property (1- (point)) 'face))
4619 (buffer-substring-no-properties line-start (point)))) 4704 (python-syntax-context 'comment)))
4705 (with-current-buffer (process-buffer process)
4706 (if python-shell-completion-native-enable
4707 (string= python-shell-readline-completer-delims "")
4708 (string-match-p "ipython[23]?\\'" python-shell-interpreter)))))
4620 (start 4709 (start
4621 (if (< (point) line-start) 4710 (if (< (point) line-start)
4622 (point) 4711 (point)
4623 (save-excursion 4712 (save-excursion
4624 (if (not (re-search-backward 4713 (if (or no-delims
4625 (python-rx 4714 (not (re-search-backward
4626 (or whitespace open-paren close-paren 4715 (python-rx
4627 string-delimiter simple-operator)) 4716 (or whitespace open-paren close-paren
4628 line-start 4717 string-delimiter simple-operator))
4629 t 1)) 4718 line-start
4719 t 1)))
4630 line-start 4720 line-start
4631 (forward-char (length (match-string-no-properties 0))) 4721 (forward-char (length (match-string-no-properties 0)))
4632 (point))))) 4722 (point)))))
@@ -4666,18 +4756,56 @@ using that one instead of current buffer's process."
4666 (t #'python-shell-completion-native-get-completions)))) 4756 (t #'python-shell-completion-native-get-completions))))
4667 (prev-prompt (car python-shell--capf-cache)) 4757 (prev-prompt (car python-shell--capf-cache))
4668 (re (or (cadr python-shell--capf-cache) regexp-unmatchable)) 4758 (re (or (cadr python-shell--capf-cache) regexp-unmatchable))
4669 (prefix (buffer-substring-no-properties start end))) 4759 (prefix (buffer-substring-no-properties start end))
4760 (prefix-offset 0)
4761 (extra-context (when no-delims
4762 (if is-shell-buffer
4763 (python-shell--extra-completion-context)
4764 (python-shell-completion-extra-context))))
4765 (extra-offset (length extra-context)))
4766 (unless (zerop extra-offset)
4767 (setq prefix (concat extra-context prefix)))
4670 ;; To invalidate the cache, we check if the prompt position or the 4768 ;; To invalidate the cache, we check if the prompt position or the
4671 ;; completion prefix changed. 4769 ;; completion prefix changed.
4672 (unless (and (equal prev-prompt (car prompt-boundaries)) 4770 (unless (and (equal prev-prompt (car prompt-boundaries))
4673 (string-match re prefix)) 4771 (string-match re prefix)
4772 (setq prefix-offset (- (length prefix) (match-end 1))))
4674 (setq python-shell--capf-cache 4773 (setq python-shell--capf-cache
4675 `(,(car prompt-boundaries) 4774 `(,(car prompt-boundaries)
4676 ,(if (string-empty-p prefix) 4775 ,(if (string-empty-p prefix)
4677 regexp-unmatchable 4776 regexp-unmatchable
4678 (concat "\\`" (regexp-quote prefix) "\\(?:\\sw\\|\\s_\\)*\\'")) 4777 (concat "\\`\\(" (regexp-quote prefix) "\\)\\(?:\\sw\\|\\s_\\)*\\'"))
4679 ,@(funcall completion-fn process (or import-statement prefix))))) 4778 ,@(funcall completion-fn process prefix))))
4680 (list start end (cddr python-shell--capf-cache)))) 4779 (let ((cands (cddr python-shell--capf-cache)))
4780 (cond
4781 ((stringp (car cands))
4782 (if no-delims
4783 ;; Reduce completion candidates due to long prefix.
4784 (if-let ((Lp (length prefix))
4785 ((string-match "\\(\\sw\\|\\s_\\)+\\'" prefix))
4786 (L (match-beginning 0)))
4787 ;; If extra-offset is not zero:
4788 ;; start end
4789 ;; o------------------o---------o-------o
4790 ;; |<- extra-offset ->|
4791 ;; |<----------- L ------------>|
4792 ;; new-start
4793 (list (+ start L (- extra-offset)) end
4794 (mapcar (lambda (s) (substring s L)) cands))
4795 (list end end (mapcar (lambda (s) (substring s Lp)) cands)))
4796 (list start end cands)))
4797 ;; python-shell-completion(-native)-get-completions may produce a
4798 ;; list of (text start end type signature) for completion.
4799 ((consp (car cands))
4800 (list (+ start (nth 1 (car cands)) (- extra-offset))
4801 ;; Candidates may be cached, so the end position should
4802 ;; be adjusted according to current completion prefix.
4803 (+ start (nth 2 (car cands)) (- extra-offset) prefix-offset)
4804 cands
4805 :annotation-function
4806 (lambda (c) (concat " " (nth 3 (assoc c cands))))
4807 :company-docsig
4808 (lambda (c) (nth 4 (assoc c cands)))))))))
4681 4809
4682(define-obsolete-function-alias 4810(define-obsolete-function-alias
4683 'python-shell-completion-complete-at-point 4811 '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."
1133 "singleton_class" 1133 "singleton_class"
1134 "module" 1134 "module"
1135 "method" 1135 "method"
1136 "singleton_method"
1136 "array" 1137 "array"
1137 "hash" 1138 "hash"
1138 "parenthesized_statements" 1139 "parenthesized_statements"
@@ -1178,6 +1179,19 @@ leading double colon is not added."
1178 ;; Imenu. 1179 ;; Imenu.
1179 (setq-local imenu-create-index-function #'ruby-ts--imenu) 1180 (setq-local imenu-create-index-function #'ruby-ts--imenu)
1180 1181
1182 ;; Outline minor mode.
1183 (setq-local treesit-outline-predicate
1184 (rx bos (or "singleton_method"
1185 "method"
1186 "alias"
1187 "class"
1188 "module")
1189 eos))
1190 ;; Restore default values of outline variables
1191 ;; to use `treesit-outline-predicate'.
1192 (kill-local-variable 'outline-regexp)
1193 (kill-local-variable 'outline-level)
1194
1181 (setq-local treesit-simple-indent-rules (ruby-ts--indent-rules)) 1195 (setq-local treesit-simple-indent-rules (ruby-ts--indent-rules))
1182 1196
1183 ;; Font-lock. 1197 ;; 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'."
199 [(nested_identifier (identifier)) (identifier)] 199 [(nested_identifier (identifier)) (identifier)]
200 @typescript-ts-jsx-tag-face))))) 200 @typescript-ts-jsx-tag-face)))))
201 201
202(defun tsx-ts-mode--font-lock-compatibility-function-expression (language)
203 "Handle tree-sitter grammar breaking change for `function' expression.
204
205LANGUAGE can be `typescript' or `tsx'. Starting from version 0.20.4 of the
206typescript/tsx grammar, `function' becomes `function_expression'."
207 (condition-case nil
208 (progn (treesit-query-capture language '((function_expression) @cap))
209 ;; New version of the grammar
210 'function_expression)
211 (treesit-query-error
212 ;; Old version of the grammar
213 'function)))
214
202(defun typescript-ts-mode--font-lock-settings (language) 215(defun typescript-ts-mode--font-lock-settings (language)
203 "Tree-sitter font-lock settings. 216 "Tree-sitter font-lock settings.
204Argument LANGUAGE is either `typescript' or `tsx'." 217Argument LANGUAGE is either `typescript' or `tsx'."
205 (treesit-font-lock-rules 218 (let ((func-exp (tsx-ts-mode--font-lock-compatibility-function-expression language)))
206 :language language 219 (treesit-font-lock-rules
207 :feature 'comment 220 :language language
208 `([(comment) (hash_bang_line)] @font-lock-comment-face) 221 :feature 'comment
209 222 `([(comment) (hash_bang_line)] @font-lock-comment-face)
210 :language language 223
211 :feature 'constant 224 :language language
212 `(((identifier) @font-lock-constant-face 225 :feature 'constant
213 (:match "\\`[A-Z_][0-9A-Z_]*\\'" @font-lock-constant-face)) 226 `(((identifier) @font-lock-constant-face
214 [(true) (false) (null)] @font-lock-constant-face) 227 (:match "\\`[A-Z_][0-9A-Z_]*\\'" @font-lock-constant-face))
215 228 [(true) (false) (null)] @font-lock-constant-face)
216 :language language 229
217 :feature 'keyword 230 :language language
218 `([,@typescript-ts-mode--keywords] @font-lock-keyword-face 231 :feature 'keyword
219 [(this) (super)] @font-lock-keyword-face) 232 `([,@typescript-ts-mode--keywords] @font-lock-keyword-face
220 233 [(this) (super)] @font-lock-keyword-face)
221 :language language 234
222 :feature 'string 235 :language language
223 `((regex pattern: (regex_pattern)) @font-lock-regexp-face 236 :feature 'string
224 (string) @font-lock-string-face 237 `((regex pattern: (regex_pattern)) @font-lock-regexp-face
225 (template_string) @js--fontify-template-string 238 (string) @font-lock-string-face
226 (template_substitution ["${" "}"] @font-lock-misc-punctuation-face)) 239 (template_string) @js--fontify-template-string
227 240 (template_substitution ["${" "}"] @font-lock-misc-punctuation-face))
228 :language language 241
229 :override t ;; for functions assigned to variables 242 :language language
230 :feature 'declaration 243 :override t ;; for functions assigned to variables
231 `((function 244 :feature 'declaration
232 name: (identifier) @font-lock-function-name-face) 245 `((,func-exp
233 (function_declaration 246 name: (identifier) @font-lock-function-name-face)
234 name: (identifier) @font-lock-function-name-face) 247 (function_declaration
235 (function_signature 248 name: (identifier) @font-lock-function-name-face)
236 name: (identifier) @font-lock-function-name-face) 249 (function_signature
237 250 name: (identifier) @font-lock-function-name-face)
238 (method_definition 251
239 name: (property_identifier) @font-lock-function-name-face) 252 (method_definition
240 (method_signature 253 name: (property_identifier) @font-lock-function-name-face)
241 name: (property_identifier) @font-lock-function-name-face) 254 (method_signature
242 (required_parameter (identifier) @font-lock-variable-name-face) 255 name: (property_identifier) @font-lock-function-name-face)
243 (optional_parameter (identifier) @font-lock-variable-name-face) 256 (required_parameter (identifier) @font-lock-variable-name-face)
244 257 (optional_parameter (identifier) @font-lock-variable-name-face)
245 (variable_declarator 258
246 name: (identifier) @font-lock-function-name-face 259 (variable_declarator
247 value: [(function) (arrow_function)]) 260 name: (identifier) @font-lock-function-name-face
248 261 value: [(,func-exp) (arrow_function)])
249 (variable_declarator 262
250 name: (identifier) @font-lock-variable-name-face) 263 (variable_declarator
251 264 name: (identifier) @font-lock-variable-name-face)
252 (enum_declaration (identifier) @font-lock-type-face) 265
253 266 (enum_declaration (identifier) @font-lock-type-face)
254 (extends_clause value: (identifier) @font-lock-type-face) 267
255 ;; extends React.Component<T> 268 (extends_clause value: (identifier) @font-lock-type-face)
256 (extends_clause value: (member_expression 269 ;; extends React.Component<T>
257 object: (identifier) @font-lock-type-face 270 (extends_clause value: (member_expression
258 property: (property_identifier) @font-lock-type-face)) 271 object: (identifier) @font-lock-type-face
259 272 property: (property_identifier) @font-lock-type-face))
260 (arrow_function 273
261 parameter: (identifier) @font-lock-variable-name-face) 274 (arrow_function
262 275 parameter: (identifier) @font-lock-variable-name-face)
263 (variable_declarator 276
264 name: (array_pattern 277 (variable_declarator
265 (identifier) 278 name: (array_pattern
266 (identifier) @font-lock-function-name-face) 279 (identifier)
267 value: (array (number) (function))) 280 (identifier) @font-lock-function-name-face)
268 281 value: (array (number) (,func-exp)))
269 (catch_clause 282
270 parameter: (identifier) @font-lock-variable-name-face) 283 (catch_clause
271 284 parameter: (identifier) @font-lock-variable-name-face)
272 ;; full module imports 285
273 (import_clause (identifier) @font-lock-variable-name-face) 286 ;; full module imports
274 ;; named imports with aliasing 287 (import_clause (identifier) @font-lock-variable-name-face)
275 (import_clause (named_imports (import_specifier 288 ;; named imports with aliasing
276 alias: (identifier) @font-lock-variable-name-face))) 289 (import_clause (named_imports (import_specifier
277 ;; named imports without aliasing 290 alias: (identifier) @font-lock-variable-name-face)))
278 (import_clause (named_imports (import_specifier 291 ;; named imports without aliasing
279 !alias 292 (import_clause (named_imports (import_specifier
280 name: (identifier) @font-lock-variable-name-face))) 293 !alias
281 294 name: (identifier) @font-lock-variable-name-face)))
282 ;; full namespace import (* as alias) 295
283 (import_clause (namespace_import (identifier) @font-lock-variable-name-face))) 296 ;; full namespace import (* as alias)
284 297 (import_clause (namespace_import (identifier) @font-lock-variable-name-face)))
285 :language language 298
286 :feature 'identifier 299 :language language
287 `((nested_type_identifier 300 :feature 'identifier
288 module: (identifier) @font-lock-type-face) 301 `((nested_type_identifier
289 302 module: (identifier) @font-lock-type-face)
290 (type_identifier) @font-lock-type-face 303
291 304 (type_identifier) @font-lock-type-face
292 (predefined_type) @font-lock-type-face 305
293 306 (predefined_type) @font-lock-type-face
294 (new_expression 307
295 constructor: (identifier) @font-lock-type-face) 308 (new_expression
296 309 constructor: (identifier) @font-lock-type-face)
297 (enum_body (property_identifier) @font-lock-type-face) 310
298 311 (enum_body (property_identifier) @font-lock-type-face)
299 (enum_assignment name: (property_identifier) @font-lock-type-face) 312
300 313 (enum_assignment name: (property_identifier) @font-lock-type-face)
301 (variable_declarator 314
302 name: (identifier) @font-lock-variable-name-face) 315 (variable_declarator
303 316 name: (identifier) @font-lock-variable-name-face)
304 (for_in_statement 317
305 left: (identifier) @font-lock-variable-name-face) 318 (for_in_statement
306 319 left: (identifier) @font-lock-variable-name-face)
307 (arrow_function 320
308 parameters: 321 (arrow_function
309 [(_ (identifier) @font-lock-variable-name-face) 322 parameters:
310 (_ (_ (identifier) @font-lock-variable-name-face)) 323 [(_ (identifier) @font-lock-variable-name-face)
311 (_ (_ (_ (identifier) @font-lock-variable-name-face)))])) 324 (_ (_ (identifier) @font-lock-variable-name-face))
312 325 (_ (_ (_ (identifier) @font-lock-variable-name-face)))]))
313 :language language 326
314 :feature 'property 327 :language language
315 `((property_signature 328 :feature 'property
316 name: (property_identifier) @font-lock-property-name-face) 329 `((property_signature
317 (public_field_definition 330 name: (property_identifier) @font-lock-property-name-face)
318 name: (property_identifier) @font-lock-property-name-face) 331 (public_field_definition
319 332 name: (property_identifier) @font-lock-property-name-face)
320 (pair key: (property_identifier) @font-lock-property-use-face) 333
321 334 (pair key: (property_identifier) @font-lock-property-use-face)
322 ((shorthand_property_identifier) @font-lock-property-use-face)) 335
323 336 ((shorthand_property_identifier) @font-lock-property-use-face))
324 :language language 337
325 :feature 'expression 338 :language language
326 '((assignment_expression 339 :feature 'expression
327 left: [(identifier) @font-lock-function-name-face 340 `((assignment_expression
328 (member_expression 341 left: [(identifier) @font-lock-function-name-face
329 property: (property_identifier) @font-lock-function-name-face)] 342 (member_expression
330 right: [(function) (arrow_function)])) 343 property: (property_identifier) @font-lock-function-name-face)]
331 344 right: [(,func-exp) (arrow_function)]))
332 :language language 345
333 :feature 'function 346 :language language
334 '((call_expression 347 :feature 'function
335 function: 348 '((call_expression
336 [(identifier) @font-lock-function-call-face 349 function:
337 (member_expression 350 [(identifier) @font-lock-function-call-face
338 property: (property_identifier) @font-lock-function-call-face)])) 351 (member_expression
339 352 property: (property_identifier) @font-lock-function-call-face)]))
340 :language language 353
341 :feature 'pattern 354 :language language
342 `((pair_pattern 355 :feature 'pattern
343 key: (property_identifier) @font-lock-property-use-face 356 `((pair_pattern
344 value: [(identifier) @font-lock-variable-name-face 357 key: (property_identifier) @font-lock-property-use-face
345 (assignment_pattern left: (identifier) @font-lock-variable-name-face)]) 358 value: [(identifier) @font-lock-variable-name-face
346 359 (assignment_pattern left: (identifier) @font-lock-variable-name-face)])
347 (array_pattern (identifier) @font-lock-variable-name-face) 360
348 361 (array_pattern (identifier) @font-lock-variable-name-face)
349 ((shorthand_property_identifier_pattern) @font-lock-variable-name-face)) 362
350 363 ((shorthand_property_identifier_pattern) @font-lock-variable-name-face))
351 :language language 364
352 :feature 'jsx 365 :language language
353 (append (tsx-ts-mode--font-lock-compatibility-bb1f97b language) 366 :feature 'jsx
354 `((jsx_attribute (property_identifier) @typescript-ts-jsx-attribute-face))) 367 (append (tsx-ts-mode--font-lock-compatibility-bb1f97b language)
355 368 `((jsx_attribute (property_identifier) @typescript-ts-jsx-attribute-face)))
356 :language language 369
357 :feature 'number 370 :language language
358 `((number) @font-lock-number-face 371 :feature 'number
359 ((identifier) @font-lock-number-face 372 `((number) @font-lock-number-face
360 (:match "\\`\\(?:NaN\\|Infinity\\)\\'" @font-lock-number-face))) 373 ((identifier) @font-lock-number-face
361 374 (:match "\\`\\(?:NaN\\|Infinity\\)\\'" @font-lock-number-face)))
362 :language language 375
363 :feature 'operator 376 :language language
364 `([,@typescript-ts-mode--operators] @font-lock-operator-face 377 :feature 'operator
365 (ternary_expression ["?" ":"] @font-lock-operator-face)) 378 `([,@typescript-ts-mode--operators] @font-lock-operator-face
366 379 (ternary_expression ["?" ":"] @font-lock-operator-face))
367 :language language 380
368 :feature 'bracket 381 :language language
369 '((["(" ")" "[" "]" "{" "}"]) @font-lock-bracket-face) 382 :feature 'bracket
370 383 '((["(" ")" "[" "]" "{" "}"]) @font-lock-bracket-face)
371 :language language 384
372 :feature 'delimiter 385 :language language
373 '((["," "." ";" ":"]) @font-lock-delimiter-face) 386 :feature 'delimiter
374 387 '((["," "." ";" ":"]) @font-lock-delimiter-face)
375 :language language 388
376 :feature 'escape-sequence 389 :language language
377 :override t 390 :feature 'escape-sequence
378 '((escape_sequence) @font-lock-escape-face))) 391 :override t
392 '((escape_sequence) @font-lock-escape-face))))
379 393
380(defvar typescript-ts-mode--sentence-nodes 394(defvar typescript-ts-mode--sentence-nodes
381 '("import_statement" 395 '("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."
8398 (message "Updating sensitivity lists...done"))) 8398 (message "Updating sensitivity lists...done")))
8399 (when noninteractive (save-buffer))) 8399 (when noninteractive (save-buffer)))
8400 8400
8401(defun vhdl--re2-region (beg-re end-re)
8402 "Return a function searching for a region delimited by a pair of regexps.
8403BEG-RE and END-RE are the regexps delimiting the region to search for."
8404 (lambda (proc-end)
8405 (when (vhdl-re-search-forward beg-re proc-end t)
8406 (save-excursion
8407 (vhdl-re-search-forward end-re proc-end t)))))
8408
8409(defconst vhdl--signal-regions-functions
8410 (list
8411 ;; right-hand side of signal/variable assignment
8412 ;; (special case: "<=" is relational operator in a condition)
8413 (vhdl--re2-region "[<:]="
8414 ";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>")
8415 ;; if condition
8416 (vhdl--re2-region "^\\s-*if\\>" "\\<then\\>")
8417 ;; elsif condition
8418 (vhdl--re2-region "\\<elsif\\>" "\\<then\\>")
8419 ;; while loop condition
8420 (vhdl--re2-region "^\\s-*while\\>" "\\<loop\\>")
8421 ;; exit/next condition
8422 (vhdl--re2-region "\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" ";")
8423 ;; assert condition
8424 (vhdl--re2-region "\\<assert\\>" "\\(\\<report\\>\\|\\<severity\\>\\|;\\)")
8425 ;; case expression
8426 (vhdl--re2-region "^\\s-*case\\>" "\\<is\\>")
8427 ;; parameter list of procedure call, array index
8428 (lambda (proc-end)
8429 (when (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*(" proc-end t)
8430 (forward-char -1)
8431 (save-excursion
8432 (forward-sexp)
8433 (while (looking-at "(") (forward-sexp)) (point)))))
8434 "Define syntactic regions where signals are read.
8435Each function is called with one arg (a limit for the (forward) search) and
8436should return either nil or the end position of the region (in which case
8437point will be set to its beginning).")
8438
8401(defun vhdl-update-sensitivity-list () 8439(defun vhdl-update-sensitivity-list ()
8402 "Update sensitivity list." 8440 "Update sensitivity list."
8403 (let ((proc-beg (point)) 8441 (let ((proc-beg (point))
@@ -8418,35 +8456,6 @@ buffer."
8418 (let 8456 (let
8419 ;; scan for visible signals 8457 ;; scan for visible signals
8420 ((visible-list (vhdl-get-visible-signals)) 8458 ((visible-list (vhdl-get-visible-signals))
8421 ;; define syntactic regions where signals are read
8422 (scan-regions-list
8423 `(;; right-hand side of signal/variable assignment
8424 ;; (special case: "<=" is relational operator in a condition)
8425 ((vhdl-re-search-forward "[<:]=" ,proc-end t)
8426 (vhdl-re-search-forward ";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>" ,proc-end t))
8427 ;; if condition
8428 ((vhdl-re-search-forward "^\\s-*if\\>" ,proc-end t)
8429 (vhdl-re-search-forward "\\<then\\>" ,proc-end t))
8430 ;; elsif condition
8431 ((vhdl-re-search-forward "\\<elsif\\>" ,proc-end t)
8432 (vhdl-re-search-forward "\\<then\\>" ,proc-end t))
8433 ;; while loop condition
8434 ((vhdl-re-search-forward "^\\s-*while\\>" ,proc-end t)
8435 (vhdl-re-search-forward "\\<loop\\>" ,proc-end t))
8436 ;; exit/next condition
8437 ((vhdl-re-search-forward "\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" ,proc-end t)
8438 (vhdl-re-search-forward ";" ,proc-end t))
8439 ;; assert condition
8440 ((vhdl-re-search-forward "\\<assert\\>" ,proc-end t)
8441 (vhdl-re-search-forward "\\(\\<report\\>\\|\\<severity\\>\\|;\\)" ,proc-end t))
8442 ;; case expression
8443 ((vhdl-re-search-forward "^\\s-*case\\>" ,proc-end t)
8444 (vhdl-re-search-forward "\\<is\\>" ,proc-end t))
8445 ;; parameter list of procedure call, array index
8446 ((and (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*(" ,proc-end t)
8447 (1- (point)))
8448 (progn (backward-char) (forward-sexp)
8449 (while (looking-at "(") (forward-sexp)) (point)))))
8450 name field read-list sens-list signal-list tmp-list 8459 name field read-list sens-list signal-list tmp-list
8451 sens-beg sens-end beg end margin) 8460 sens-beg sens-end beg end margin)
8452 ;; scan for signals in old sensitivity list 8461 ;; scan for signals in old sensitivity list
@@ -8475,11 +8484,9 @@ buffer."
8475 (push (cons end (point)) seq-region-list) 8484 (push (cons end (point)) seq-region-list)
8476 (beginning-of-line))) 8485 (beginning-of-line)))
8477 ;; scan for signals read in process 8486 ;; scan for signals read in process
8478 (while scan-regions-list 8487 (dolist (scan-fun vhdl--signal-regions-functions)
8479 (goto-char proc-mid) 8488 (goto-char proc-mid)
8480 (while (and (setq beg (eval (nth 0 (car scan-regions-list)))) 8489 (while (setq end (funcall scan-fun proc-end))
8481 (setq end (eval (nth 1 (car scan-regions-list)))))
8482 (goto-char beg)
8483 (unless (or (vhdl-in-literal) 8490 (unless (or (vhdl-in-literal)
8484 (and seq-region-list 8491 (and seq-region-list
8485 (let ((tmp-list seq-region-list)) 8492 (let ((tmp-list seq-region-list))
@@ -8518,8 +8525,7 @@ buffer."
8518 (car tmp-list)) 8525 (car tmp-list))
8519 (setq read-list (delete (car tmp-list) read-list))) 8526 (setq read-list (delete (car tmp-list) read-list)))
8520 (setq tmp-list (cdr tmp-list))))) 8527 (setq tmp-list (cdr tmp-list)))))
8521 (goto-char (match-end 1))))) 8528 (goto-char (match-end 1))))))
8522 (setq scan-regions-list (cdr scan-regions-list)))
8523 ;; update sensitivity list 8529 ;; update sensitivity list
8524 (goto-char sens-beg) 8530 (goto-char sens-beg)
8525 (if sens-end 8531 (if sens-end
@@ -14978,9 +14984,9 @@ otherwise use cached data."
14978 (vhdl-aput 'vhdl-directory-alist directory (list (list directory)))) 14984 (vhdl-aput 'vhdl-directory-alist directory (list (list directory))))
14979 14985
14980(defun vhdl-speedbar-insert-hierarchy ( ent-alist-arg conf-alist-arg 14986(defun vhdl-speedbar-insert-hierarchy ( ent-alist-arg conf-alist-arg
14981 package-alist ent-inst-list depth) 14987 pkg-alist ent-inst-list depth)
14982 "Insert hierarchy of ENT-ALIST-ARG, CONF-ALIST-ARG, and PACKAGE-ALIST." 14988 "Insert hierarchy of ENT-ALIST-ARG, CONF-ALIST-ARG, and PKG-ALIST."
14983 (if (not (or ent-alist-arg conf-alist-arg package-alist)) 14989 (if (not (or ent-alist-arg conf-alist-arg pkg-alist))
14984 (vhdl-speedbar-make-title-line "No VHDL design units!" depth) 14990 (vhdl-speedbar-make-title-line "No VHDL design units!" depth)
14985 (let ((ent-alist ent-alist-arg) 14991 (let ((ent-alist ent-alist-arg)
14986 (conf-alist conf-alist-arg) 14992 (conf-alist conf-alist-arg)
@@ -15010,15 +15016,15 @@ otherwise use cached data."
15010 'vhdl-speedbar-configuration-face depth) 15016 'vhdl-speedbar-configuration-face depth)
15011 (setq conf-alist (cdr conf-alist))) 15017 (setq conf-alist (cdr conf-alist)))
15012 ;; insert packages 15018 ;; insert packages
15013 (when package-alist (vhdl-speedbar-make-title-line "Packages:" depth)) 15019 (when pkg-alist (vhdl-speedbar-make-title-line "Packages:" depth))
15014 (while package-alist 15020 (while pkg-alist
15015 (setq pack-entry (car package-alist)) 15021 (setq pack-entry (car pkg-alist))
15016 (vhdl-speedbar-make-pack-line 15022 (vhdl-speedbar-make-pack-line
15017 (nth 0 pack-entry) (nth 1 pack-entry) 15023 (nth 0 pack-entry) (nth 1 pack-entry)
15018 (cons (nth 2 pack-entry) (nth 3 pack-entry)) 15024 (cons (nth 2 pack-entry) (nth 3 pack-entry))
15019 (cons (nth 7 pack-entry) (nth 8 pack-entry)) 15025 (cons (nth 7 pack-entry) (nth 8 pack-entry))
15020 depth) 15026 depth)
15021 (setq package-alist (cdr package-alist)))))) 15027 (setq pkg-alist (cdr pkg-alist))))))
15022 15028
15023(declare-function speedbar-line-directory "speedbar" (&optional depth)) 15029(declare-function speedbar-line-directory "speedbar" (&optional depth))
15024 15030
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.")
211 (when which-function-mode 211 (when which-function-mode
212 (unless (local-variable-p 'which-func-mode) 212 (unless (local-variable-p 'which-func-mode)
213 (setq which-func-mode (or (eq which-func-modes t) 213 (setq which-func-mode (or (eq which-func-modes t)
214 (member major-mode which-func-modes))) 214 (derived-mode-p which-func-modes)))
215 (setq which-func--use-mode-line 215 (setq which-func--use-mode-line
216 (member which-func-display '(mode mode-and-header))) 216 (member which-func-display '(mode mode-and-header)))
217 (setq which-func--use-header-line 217 (setq which-func--use-header-line
@@ -239,7 +239,7 @@ It creates the Imenu index for the buffer, if necessary."
239 239
240 (condition-case err 240 (condition-case err
241 (if (and which-func-mode 241 (if (and which-func-mode
242 (not (member major-mode which-func-non-auto-modes)) 242 (not (derived-mode-p which-func-non-auto-modes))
243 (or (null which-func-maxout) 243 (or (null which-func-maxout)
244 (< buffer-saved-size which-func-maxout) 244 (< buffer-saved-size which-func-maxout)
245 (= which-func-maxout 0))) 245 (= 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\".")
1439 ;; including code that needs to wait. 1439 ;; including code that needs to wait.
1440 (with-local-quit 1440 (with-local-quit
1441 (condition-case err 1441 (condition-case err
1442 (let ((buffers (server-visit-files files proc nowait))) 1442 (let ((buffers (server-visit-files files proc nowait))
1443 ;; On Android, the Emacs server generally can't provide
1444 ;; feedback to the user except by means of dialog boxes,
1445 ;; which are displayed in the GUI emacsclient wrapper.
1446 (use-dialog-box-override (featurep 'android)))
1443 (mapc 'funcall (nreverse commands)) 1447 (mapc 'funcall (nreverse commands))
1444 (let ((server-eval-args-left (nreverse evalexprs))) 1448 (let ((server-eval-args-left (nreverse evalexprs)))
1445 (while server-eval-args-left 1449 (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."
6419 0 (length s) 6419 0 (length s)
6420 '( 6420 '(
6421 keymap local-map action mouse-action 6421 keymap local-map action mouse-action
6422 button category help-args) 6422 read-only button category help-args)
6423 s) 6423 s)
6424 s) 6424 s)
6425 kill-ring)) 6425 kill-ring))
@@ -10858,6 +10858,87 @@ and setting it to nil."
10858 (setq-local vis-mode-saved-buffer-invisibility-spec 10858 (setq-local vis-mode-saved-buffer-invisibility-spec
10859 buffer-invisibility-spec) 10859 buffer-invisibility-spec)
10860 (setq buffer-invisibility-spec nil))) 10860 (setq buffer-invisibility-spec nil)))
10861
10862
10863(defvar read-passwd--mode-line-buffer nil
10864 "Buffer to modify `mode-line-format' for showing/hiding passwords.")
10865
10866(defvar read-passwd--mode-line-icon nil
10867 "Propertized mode line icon for showing/hiding passwords.")
10868
10869(defun read-passwd-toggle-visibility ()
10870 "Toggle minibuffer contents visibility.
10871Adapt also mode line."
10872 (interactive)
10873 (setq read-passwd--hide-password (not read-passwd--hide-password))
10874 (with-current-buffer read-passwd--mode-line-buffer
10875 (setq read-passwd--mode-line-icon
10876 `(:propertize
10877 ,(if icon-preference
10878 (icon-string
10879 (if read-passwd--hide-password
10880 'read-passwd--show-password-icon
10881 'read-passwd--hide-password-icon))
10882 "")
10883 mouse-face mode-line-highlight
10884 local-map
10885 (keymap
10886 (mode-line keymap (mouse-1 . read-passwd-toggle-visibility)))))
10887 (force-mode-line-update))
10888 (read-passwd--hide-password))
10889
10890(define-minor-mode read-passwd-mode
10891 "Toggle visibility of password in minibuffer."
10892 :group 'mode-line
10893 :group 'minibuffer
10894 :keymap read-passwd-map
10895 :version "30.1"
10896
10897 (require 'icons)
10898 ;; It would be preferable to use "👁" ("\N{EYE}"). However, there is
10899 ;; no corresponding Unicode char with a slash. So we use symbols as
10900 ;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for
10901 ;; hiding the password.
10902 (define-icon read-passwd--show-password-icon nil
10903 '((image "reveal.svg" "reveal.pbm" :height (0.8 . em))
10904 (symbol "👁")
10905 (text "<o>"))
10906 "Mode line icon to show a hidden password."
10907 :group mode-line-faces
10908 :version "30.1"
10909 :help-echo "mouse-1: Toggle password visibility")
10910 (define-icon read-passwd--hide-password-icon nil
10911 '((image "conceal.svg" "conceal.pbm" :height (0.8 . em))
10912 (symbol "⦵")
10913 (text "<\\>"))
10914 "Mode line icon to hide a visible password."
10915 :group mode-line-faces
10916 :version "30.1"
10917 :help-echo "mouse-1: Toggle password visibility")
10918
10919 (setq read-passwd--hide-password nil
10920 ;; Stolen from `eldoc-minibuffer-message'.
10921 read-passwd--mode-line-buffer
10922 (window-buffer
10923 (or (window-in-direction 'above (minibuffer-window))
10924 (minibuffer-selected-window)
10925 (get-largest-window))))
10926
10927 (if read-passwd-mode
10928 (with-current-buffer read-passwd--mode-line-buffer
10929 ;; Add `read-passwd--mode-line-icon'.
10930 (when (listp mode-line-format)
10931 (setq mode-line-format
10932 (cons '(:eval read-passwd--mode-line-icon)
10933 mode-line-format))))
10934 (with-current-buffer read-passwd--mode-line-buffer
10935 ;; Remove `read-passwd--mode-line-icon'.
10936 (when (listp mode-line-format)
10937 (setq mode-line-format (cdr mode-line-format)))))
10938
10939 (when read-passwd-mode
10940 (read-passwd-toggle-visibility)))
10941
10861 10942
10862(defvar messages-buffer-mode-map 10943(defvar messages-buffer-mode-map
10863 (let ((map (make-sparse-keymap))) 10944 (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")
478 ;; if there was no such register 478 ;; if there was no such register
479 (error (throw 'key nil)))))))))) 479 (error (throw 'key nil))))))))))
480 480
481;;;###autoload
482(defun sort-on (sequence predicate accessor)
483 "Sort SEQUENCE by calling PREDICATE on sort keys produced by ACCESSOR.
484SEQUENCE should be the input sequence to sort.
485Elements of SEQUENCE are sorted by keys which are obtained by
486calling ACCESSOR on each element. ACCESSOR should be a function of
487one argument, an element of SEQUENCE, and should return the key
488value to be compared by PREDICATE for sorting the element.
489PREDICATE is the function for comparing keys; it is called with two
490arguments, the keys to compare, and should return non-nil if the
491first key should sort before the second key.
492The return value is always a new list.
493This function has the performance advantage of evaluating
494ACCESSOR only once for each element in the input SEQUENCE, and is
495therefore appropriate when computing the key by ACCESSOR is an
496expensive operation. This is known as the \"decorate-sort-undecorate\"
497paradigm, or the Schwartzian transform."
498 (mapcar #'car
499 (sort (mapcar #'(lambda (x) (cons x (funcall accessor x))) sequence)
500 #'(lambda (x y) (funcall predicate (cdr x) (cdr y))))))
501
481 502
482(defvar sort-columns-subprocess t) 503(defvar sort-columns-subprocess t)
483 504
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."
3488 3488
3489 nil 3489 nil
3490 3490
3491(eval-when-compile (condition-case nil (require 'imenu) (error nil))) 3491(eval-when-compile (require 'imenu))
3492(declare-function imenu--make-index-alist "imenu" (&optional no-error)) 3492(declare-function imenu--make-index-alist "imenu" (&optional no-error))
3493 3493
3494(defun speedbar-fetch-dynamic-imenu (file) 3494(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."
556 (setq startup--original-eln-load-path 556 (setq startup--original-eln-load-path
557 (copy-sequence native-comp-eln-load-path)))) 557 (copy-sequence native-comp-eln-load-path))))
558 558
559(defun startup--rescale-elt-match-p (font-pattern font-object)
560 "Test whether FONT-OBJECT matches an element of `face-font-rescale-alist'.
561FONT-OBJECT is a font-object that specifies a font to test.
562FONT-PATTERN is the car of an element of `face-font-rescale-alist',
563which can be either a regexp matching a font name or a font-spec."
564 (if (stringp font-pattern)
565 ;; FONT-PATTERN is a regexp, we need the name of FONT-OBJECT to match.
566 (string-match-p font-pattern (font-xlfd-name font-object))
567 ;; FONT-PATTERN is a font-spec.
568 (font-match-p font-pattern font-object)))
569
559(defvar android-fonts-enumerated nil 570(defvar android-fonts-enumerated nil
560 "Whether or not fonts have been enumerated already. 571 "Whether or not fonts have been enumerated already.
561On Android, Emacs uses this variable internally at startup.") 572On Android, Emacs uses this variable internally at startup.")
@@ -816,8 +827,9 @@ It is the default value of the variable `top-level'."
816 (when (and (display-multi-font-p) 827 (when (and (display-multi-font-p)
817 (not (eq face-font-rescale-alist 828 (not (eq face-font-rescale-alist
818 old-face-font-rescale-alist)) 829 old-face-font-rescale-alist))
819 (assoc (font-xlfd-name (face-attribute 'default :font)) 830 (assoc (face-attribute 'default :font)
820 face-font-rescale-alist #'string-match-p)) 831 face-font-rescale-alist
832 #'startup--rescale-elt-match-p))
821 (set-face-attribute 'default nil :font (font-spec))) 833 (set-face-attribute 'default nil :font (font-spec)))
822 834
823 ;; Modify the initial frame based on what .emacs puts into 835 ;; Modify the initial frame based on what .emacs puts into
@@ -1627,7 +1639,9 @@ Consider using a subdirectory instead, e.g.: %s"
1627 (let ((dn (daemonp))) 1639 (let ((dn (daemonp)))
1628 (when dn 1640 (when dn
1629 (when (stringp dn) (setq server-name dn)) 1641 (when (stringp dn) (setq server-name dn))
1630 (server-start) 1642 (condition-case err
1643 (server-start)
1644 (error (error "Unable to start daemon: %s; exiting" (error-message-string err))))
1631 (if server-process 1645 (if server-process
1632 (daemon-initialized) 1646 (daemon-initialized)
1633 (if (stringp dn) 1647 (if (stringp dn)
@@ -1758,7 +1772,7 @@ If this is nil, no message will be displayed."
1758 "\n")) 1772 "\n"))
1759 "A list of texts to show in the middle part of splash screens. 1773 "A list of texts to show in the middle part of splash screens.
1760Each element in the list should be a list of strings or pairs 1774Each element in the list should be a list of strings or pairs
1761`:face FACE', like `fancy-splash-insert' accepts them.") 1775`:KEYWORD VALUE', like what `fancy-splash-insert' accepts.")
1762 1776
1763(defconst fancy-about-text 1777(defconst fancy-about-text
1764 `((:face (variable-pitch font-lock-comment-face) 1778 `((:face (variable-pitch font-lock-comment-face)
@@ -1851,7 +1865,7 @@ Each element in the list should be a list of strings or pairs
1851 "\tDisplay the Emacs manual in Info mode")) 1865 "\tDisplay the Emacs manual in Info mode"))
1852 "A list of texts to show in the middle part of the About screen. 1866 "A list of texts to show in the middle part of the About screen.
1853Each element in the list should be a list of strings or pairs 1867Each element in the list should be a list of strings or pairs
1854`:face FACE', like `fancy-splash-insert' accepts them.") 1868`:KEYWORD VALUE', like what `fancy-splash-insert' accepts.")
1855 1869
1856 1870
1857(defgroup fancy-splash-screen () 1871(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 @@
1;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*- 1;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2024 Free Software 3;; Copyright (C) 1985-2024 Free Software Foundation, Inc.
4;; Foundation, Inc.
5 4
6;; Maintainer: emacs-devel@gnu.org 5;; Maintainer: emacs-devel@gnu.org
7;; Keywords: internal 6;; Keywords: internal
@@ -2023,6 +2022,8 @@ instead; it will indirectly limit the specpdl stack size as well.")
2023 2022
2024(defvaralias 'native-comp-deferred-compilation 'native-comp-jit-compilation) 2023(defvaralias 'native-comp-deferred-compilation 'native-comp-jit-compilation)
2025 2024
2025(define-obsolete-function-alias 'fetch-bytecode #'ignore "30.1")
2026
2026 2027
2027;;;; Alternate names for functions - these are not being phased out. 2028;;;; Alternate names for functions - these are not being phased out.
2028 2029
@@ -2579,6 +2580,8 @@ Affects only hooks run in the current buffer."
2579 (list binding binding)) 2580 (list binding binding))
2580 ((null (cdr binding)) 2581 ((null (cdr binding))
2581 (list (make-symbol "s") (car binding))) 2582 (list (make-symbol "s") (car binding)))
2583 ((eq '_ (car binding))
2584 (list (make-symbol "s") (cadr binding)))
2582 (t binding))) 2585 (t binding)))
2583 (when (> (length binding) 2) 2586 (when (> (length binding) 2)
2584 (signal 'error 2587 (signal 'error
@@ -2619,7 +2622,7 @@ This is like `when-let' but doesn't handle a VARLIST of the form
2619(defmacro and-let* (varlist &rest body) 2622(defmacro and-let* (varlist &rest body)
2620 "Bind variables according to VARLIST and conditionally evaluate BODY. 2623 "Bind variables according to VARLIST and conditionally evaluate BODY.
2621Like `when-let*', except if BODY is empty and all the bindings 2624Like `when-let*', except if BODY is empty and all the bindings
2622are non-nil, then the result is non-nil." 2625are non-nil, then the result is the value of the last binding."
2623 (declare (indent 1) (debug if-let*)) 2626 (declare (indent 1) (debug if-let*))
2624 (let (res) 2627 (let (res)
2625 (if varlist 2628 (if varlist
@@ -2632,7 +2635,8 @@ are non-nil, then the result is non-nil."
2632 "Bind variables according to SPEC and evaluate THEN or ELSE. 2635 "Bind variables according to SPEC and evaluate THEN or ELSE.
2633Evaluate each binding in turn, as in `let*', stopping if a 2636Evaluate each binding in turn, as in `let*', stopping if a
2634binding value is nil. If all are non-nil return the value of 2637binding value is nil. If all are non-nil return the value of
2635THEN, otherwise the last form in ELSE. 2638THEN, otherwise the value of the last form in ELSE, or nil if
2639there are none.
2636 2640
2637Each element of SPEC is a list (SYMBOL VALUEFORM) that binds 2641Each element of SPEC is a list (SYMBOL VALUEFORM) that binds
2638SYMBOL to the value of VALUEFORM. An element can additionally be 2642SYMBOL 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."
3374 (let ((map (make-sparse-keymap))) 3378 (let ((map (make-sparse-keymap)))
3375 (set-keymap-parent map minibuffer-local-map) 3379 (set-keymap-parent map minibuffer-local-map)
3376 (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 3380 (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570
3381 (define-key map "\t" #'read-passwd-toggle-visibility)
3377 map) 3382 map)
3378 "Keymap used while reading passwords.") 3383 "Keymap used while reading passwords.")
3379 3384
3380(defun read-password--hide-password () 3385(defvar read-passwd--hide-password t)
3386
3387(defun read-passwd--hide-password ()
3388 "Make password in minibuffer hidden or visible."
3381 (let ((beg (minibuffer-prompt-end))) 3389 (let ((beg (minibuffer-prompt-end)))
3382 (dotimes (i (1+ (- (buffer-size) beg))) 3390 (dotimes (i (1+ (- (buffer-size) beg)))
3383 (put-text-property (+ i beg) (+ 1 i beg) 3391 (if read-passwd--hide-password
3384 'display (string (or read-hide-char ?*)))))) 3392 (put-text-property
3393 (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*)))
3394 (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display)))
3395 (put-text-property
3396 (+ i beg) (+ 1 i beg)
3397 'help-echo "C-u: Clear password\nTAB: Toggle password visibility"))))
3385 3398
3386(defun read-passwd (prompt &optional confirm default) 3399(defun read-passwd (prompt &optional confirm default)
3387 "Read a password, prompting with PROMPT, and return it. 3400 "Read a password, prompting with PROMPT, and return it.
@@ -3419,18 +3432,20 @@ by doing (clear-string STRING)."
3419 (setq-local inhibit-modification-hooks nil) ;bug#15501. 3432 (setq-local inhibit-modification-hooks nil) ;bug#15501.
3420 (setq-local show-paren-mode nil) ;bug#16091. 3433 (setq-local show-paren-mode nil) ;bug#16091.
3421 (setq-local inhibit--record-char t) 3434 (setq-local inhibit--record-char t)
3422 (add-hook 'post-command-hook #'read-password--hide-password nil t)) 3435 (read-passwd-mode 1)
3436 (add-hook 'post-command-hook #'read-passwd--hide-password nil t))
3423 (unwind-protect 3437 (unwind-protect
3424 (let ((enable-recursive-minibuffers t) 3438 (let ((enable-recursive-minibuffers t)
3425 (read-hide-char (or read-hide-char ?*))) 3439 (read-hide-char (or read-hide-char ?*)))
3426 (read-string prompt nil t default)) ; t = "no history" 3440 (read-string prompt nil t default)) ; t = "no history"
3427 (when (buffer-live-p minibuf) 3441 (when (buffer-live-p minibuf)
3428 (with-current-buffer minibuf 3442 (with-current-buffer minibuf
3443 (read-passwd-mode -1)
3429 ;; Not sure why but it seems that there might be cases where the 3444 ;; Not sure why but it seems that there might be cases where the
3430 ;; minibuffer is not always properly reset later on, so undo 3445 ;; minibuffer is not always properly reset later on, so undo
3431 ;; whatever we've done here (bug#11392). 3446 ;; whatever we've done here (bug#11392).
3432 (remove-hook 'after-change-functions 3447 (remove-hook 'after-change-functions
3433 #'read-password--hide-password 'local) 3448 #'read-passwd--hide-password 'local)
3434 (kill-local-variable 'post-self-insert-hook) 3449 (kill-local-variable 'post-self-insert-hook)
3435 ;; And of course, don't keep the sensitive data around. 3450 ;; And of course, don't keep the sensitive data around.
3436 (erase-buffer)))))))) 3451 (erase-buffer))))))))
@@ -3725,10 +3740,10 @@ There is no need to explicitly add `help-char' to CHARS;
3725 (this-command this-command) 3740 (this-command this-command)
3726 (result (minibuffer-with-setup-hook 3741 (result (minibuffer-with-setup-hook
3727 (lambda () 3742 (lambda ()
3743 (setq-local post-self-insert-hook nil)
3728 (add-hook 'post-command-hook 3744 (add-hook 'post-command-hook
3729 (lambda () 3745 (lambda ()
3730 ;; FIXME: Should we use `<='? 3746 (if (<= (1+ (minibuffer-prompt-end))
3731 (if (= (1+ (minibuffer-prompt-end))
3732 (point-max)) 3747 (point-max))
3733 (exit-minibuffer))) 3748 (exit-minibuffer)))
3734 nil 'local)) 3749 nil 'local))
@@ -3828,15 +3843,25 @@ confusing to some users.")
3828 3843
3829(defvar from--tty-menu-p nil 3844(defvar from--tty-menu-p nil
3830 "Non-nil means the current command was invoked from a TTY menu.") 3845 "Non-nil means the current command was invoked from a TTY menu.")
3846
3847(declare-function android-detect-keyboard "androidfns.c")
3848
3849(defvar use-dialog-box-override nil
3850 "Whether `use-dialog-box-p' should always return t.")
3851
3831(defun use-dialog-box-p () 3852(defun use-dialog-box-p ()
3832 "Return non-nil if the current command should prompt the user via a dialog box." 3853 "Return non-nil if the current command should prompt the user via a dialog box."
3833 (and last-input-event ; not during startup 3854 (or use-dialog-box-override
3834 (or (consp last-nonmenu-event) ; invoked by a mouse event 3855 (and last-input-event ; not during startup
3835 (and (null last-nonmenu-event) 3856 (or (consp last-nonmenu-event) ; invoked by a mouse event
3836 (consp last-input-event)) 3857 (and (null last-nonmenu-event)
3837 (featurep 'android) ; Prefer dialog boxes on Android. 3858 (consp last-input-event))
3838 from--tty-menu-p) ; invoked via TTY menu 3859 (and (featurep 'android) ; Prefer dialog boxes on
3839 use-dialog-box)) 3860 ; Android.
3861 (not (android-detect-keyboard))) ; If no keyboard is
3862 ; connected.
3863 from--tty-menu-p) ; invoked via TTY menu
3864 use-dialog-box)))
3840 3865
3841;; Actually in textconv.c. 3866;; Actually in textconv.c.
3842(defvar overriding-text-conversion-style) 3867(defvar overriding-text-conversion-style)
@@ -5014,7 +5039,7 @@ read-only, and scans it for function and variable names to make them into
5014clickable cross-references. 5039clickable cross-references.
5015 5040
5016See the related form `with-temp-buffer-window'." 5041See the related form `with-temp-buffer-window'."
5017 (declare (debug t)) 5042 (declare (debug t) (indent 1))
5018 (let ((old-dir (make-symbol "old-dir")) 5043 (let ((old-dir (make-symbol "old-dir"))
5019 (buf (make-symbol "buf"))) 5044 (buf (make-symbol "buf")))
5020 `(let* ((,old-dir default-directory) 5045 `(let* ((,old-dir default-directory)
@@ -6734,6 +6759,8 @@ effectively rounded up."
6734 (progress-reporter-update reporter (or current-value min-value)) 6759 (progress-reporter-update reporter (or current-value min-value))
6735 reporter)) 6760 reporter))
6736 6761
6762(defalias 'progress-reporter-make #'make-progress-reporter)
6763
6737(defun progress-reporter-force-update (reporter &optional value new-message suffix) 6764(defun progress-reporter-force-update (reporter &optional value new-message suffix)
6738 "Report progress of an operation in the echo area unconditionally. 6765 "Report progress of an operation in the echo area unconditionally.
6739 6766
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."
480 (concat locale-base locale-modifier))) 480 (concat locale-base locale-modifier)))
481 481
482 482
483;; Miscellaneous functions.
484
485(declare-function android-browse-url-internal "androidselect.c")
486
487(defun android-browse-url (url &optional send)
488 "Open URL in an external application.
489
490URL should be a URL-encoded URL with a scheme specified unless
491SEND is non-nil. Signal an error upon failure.
492
493If SEND is nil, start a program that is able to display the URL,
494such as a web browser. Otherwise, try to share URL using
495programs such as email clients.
496
497If URL is a file URI, convert it into a `content' address
498accessible to other programs."
499 (when-let* ((uri (url-generic-parse-url url))
500 (filename (url-filename uri))
501 ;; If `uri' is a file URI and the file resides in /content
502 ;; or /assets, copy it to a temporary file before
503 ;; providing it to other programs.
504 (replacement-url (and (string-match-p
505 "/\\(content\\|assets\\)[/$]"
506 filename)
507 (prog1 t
508 (copy-file
509 filename
510 (setq filename
511 (make-temp-file
512 "local"
513 nil
514 (let ((extension
515 (file-name-extension
516 filename)))
517 (if extension
518 (concat "."
519 extension)
520 nil))))
521 t))
522 (concat "file://" filename))))
523 (setq url replacement-url))
524 (android-browse-url-internal url send))
525
526
483(provide 'android-win) 527(provide 'android-win)
484;; android-win.el ends here. 528;; 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."
121 ;; Imenu. 121 ;; Imenu.
122 (setq-local treesit-simple-imenu-settings 122 (setq-local treesit-simple-imenu-settings
123 '(("Element" "\\`tag_name\\'" nil nil))) 123 '(("Element" "\\`tag_name\\'" nil nil)))
124
125 ;; Outline minor mode.
126 (setq-local treesit-outline-predicate "\\`element\\'")
127 ;; `html-ts-mode' inherits from `html-mode' that sets
128 ;; regexp-based outline variables. So need to restore
129 ;; the default values of outline variables to be able
130 ;; to use `treesit-outline-predicate' above.
131 (kill-local-variable 'outline-regexp)
132 (kill-local-variable 'outline-heading-end-regexp)
133 (kill-local-variable 'outline-level)
134
124 (treesit-major-mode-setup)) 135 (treesit-major-mode-setup))
125 136
126(if (treesit-ready-p 'html) 137(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.
73If START isn't at the start of a line, the horizontal position of 73If START isn't at the start of a line, the horizontal position of
74START, converted to pixel units, will be used as the indentation 74START, converted to pixel units, will be used as the indentation
75prefix on subsequent lines." 75prefix on subsequent lines."
76 (save-excursion 76 (save-window-excursion
77 (goto-char start) 77 (set-window-buffer nil (current-buffer))
78 (let ((indentation 78 (save-excursion
79 (car (window-text-pixel-size nil (line-beginning-position) 79 (goto-char start)
80 (point)))) 80 (let ((indentation
81 (newline-end nil)) 81 (car (window-text-pixel-size nil (line-beginning-position)
82 (when (> indentation pixel-width) 82 (point))))
83 (error "The indentation (%s) is wider than the fill width (%s)" 83 (newline-end nil))
84 indentation pixel-width)) 84 (when (> indentation pixel-width)
85 (save-restriction 85 (error "The indentation (%s) is wider than the fill width (%s)"
86 (narrow-to-region start end) 86 indentation pixel-width))
87 (goto-char (point-max)) 87 (save-restriction
88 (when (looking-back "\n[ \t]*" (point-min)) 88 (narrow-to-region start end)
89 (setq newline-end t)) 89 (goto-char (point-max))
90 (goto-char (point-min)) 90 (when (looking-back "\n[ \t]*" (point-min))
91 ;; First replace all whitespace with space. 91 (setq newline-end t))
92 (while (re-search-forward "[ \t\n]+" nil t) 92 (goto-char (point-min))
93 (cond 93 ;; First replace all whitespace with space.
94 ((or (= (match-beginning 0) start) 94 (while (re-search-forward "[ \t\n]+" nil t)
95 (= (match-end 0) end)) 95 (cond
96 (delete-region (match-beginning 0) (match-end 0))) 96 ((or (= (match-beginning 0) start)
97 ;; If there's just a single space here, don't replace. 97 (= (match-end 0) end))
98 ((not (and (= (- (match-end 0) (match-beginning 0)) 1) 98 (delete-region (match-beginning 0) (match-end 0)))
99 (= (char-after (match-beginning 0)) ?\s))) 99 ;; If there's just a single space here, don't replace.
100 (replace-match 100 ((not (and (= (- (match-end 0) (match-beginning 0)) 1)
101 ;; We need to use a space that has an appropriate width. 101 (= (char-after (match-beginning 0)) ?\s)))
102 (propertize " " 'face 102 (replace-match
103 (get-text-property (match-beginning 0) 'face)))))) 103 ;; We need to use a space that has an appropriate width.
104 (goto-char start) 104 (propertize " " 'face
105 (pixel-fill--fill-line pixel-width indentation) 105 (get-text-property (match-beginning 0) 'face))))))
106 (goto-char (point-max)) 106 (goto-char start)
107 (when newline-end 107 (pixel-fill--fill-line pixel-width indentation)
108 (insert "\n")))))) 108 (goto-char (point-max))
109 (when newline-end
110 (insert "\n")))))))
109 111
110(defun pixel-fill--goto-pixel (width) 112(defun pixel-fill--goto-pixel (width)
111 (vertical-motion (cons (/ width (frame-char-width)) 0))) 113 (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.")
235 "ConTeXt bib module" 235 "ConTeXt bib module"
236 ((?\C-m . "\\cite[%l]") 236 ((?\C-m . "\\cite[%l]")
237 (?s . "\\cite[][%l]") 237 (?s . "\\cite[][%l]")
238 (?n . "\\nocite[%l]"))) 238 (?n . "\\nocite[%l]"))))
239 )
240 "Builtin versions of the citation format. 239 "Builtin versions of the citation format.
241The following conventions are valid for all alist entries: 240The following conventions are valid for all alist entries:
242`?\C-m' should always point to a straight \\cite{%l} macro. 241`?\\C-m' should always point to a straight \\cite{%l} macro.
243`?t' should point to a textual citation (citation as a noun). 242`?t' should point to a textual citation (citation as a noun).
244`?p' should point to a parenthetical citation.") 243`?p' should point to a parenthetical citation.")
245 244
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."
1147 (unless (fboundp forwarder-function) 1147 (unless (fboundp forwarder-function)
1148 (defalias forwarder-function 1148 (defalias forwarder-function
1149 (lambda () 1149 (lambda ()
1150 (:documentation
1151 (format "Deprecated binding for %s, use \\[%s] instead."
1152 def def))
1150 (interactive) 1153 (interactive)
1151 (call-interactively def) 1154 (call-interactively def)
1152 (message "[Deprecated use of key %s; use key %s instead]" 1155 (message "[Deprecated use of key %s; use key %s instead]"
1153 (key-description (this-command-keys)) 1156 (key-description (this-command-keys))
1154 (key-description key))) 1157 (key-description key)))))
1155 ;; FIXME: In Emacs-25 we could use (:documentation ...) instead.
1156 (format "Deprecated binding for %s, use \\[%s] instead."
1157 def def)))
1158 (dolist (dep-key deprecated) 1158 (dolist (dep-key deprecated)
1159 (define-key keymap dep-key forwarder-function))))) 1159 (define-key keymap dep-key forwarder-function)))))
1160 1160
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."
511 ;; This would allow highlighting \newcommand\CMD but requires 511 ;; This would allow highlighting \newcommand\CMD but requires
512 ;; adapting subgroup numbers below. 512 ;; adapting subgroup numbers below.
513 ;; (arg "\\(?:{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)\\|\\\\[a-z*]+\\)")) 513 ;; (arg "\\(?:{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)\\|\\\\[a-z*]+\\)"))
514 (inbraces-re (lambda (re) 514 (inbraces-re
515 (concat "\\(?:[^{}\\]\\|\\\\.\\|" re "\\)"))) 515 (lambda (n) ;; Level of nesting of braces we should support.
516 (arg (concat "{\\(" (funcall inbraces-re "{[^}]*}") "+\\)"))) 516 (let ((re "[^}]"))
517 `( ;; Highlight $$math$$ and $math$. 517 (dotimes (_ n)
518 (setq re
519 (concat "\\(?:[^{}\\]\\|\\\\.\\|{" re "*}\\)")))
520 re)))
521 (arg (concat "{\\(" (funcall inbraces-re 2) "+\\)")))
522 `(;; Verbatim-like args.
523 ;; Do it first, because we don't want to highlight them
524 ;; in comments (bug#68827), but we do want to highlight them
525 ;; in $math$.
526 (,(concat slash verbish opt arg) 3 'tex-verbatim keep)
527 ;; Highlight $$math$$ and $math$.
518 ;; This is done at the very beginning so as to interact with the other 528 ;; This is done at the very beginning so as to interact with the other
519 ;; keywords in the same way as comments and strings. 529 ;; keywords in the same way as comments and strings.
520 (,(concat "\\$\\$?\\(?:[^$\\{}]\\|\\\\.\\|{" 530 (,(concat "\\$\\$?\\(?:[^$\\{}]\\|\\\\.\\|{"
521 (funcall inbraces-re 531 (funcall inbraces-re 6)
522 (concat "{" (funcall inbraces-re "{[^}]*}") "*}"))
523 "*}\\)+\\$?\\$") 532 "*}\\)+\\$?\\$")
524 (0 'tex-math)) 533 (0 'tex-math keep))
525 ;; Heading args. 534 ;; Heading args.
526 (,(concat slash headings "\\*?" opt arg) 535 (,(concat slash headings "\\*?" opt arg)
527 ;; If ARG ends up matching too much (if the {} don't match, e.g.) 536 ;; 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."
543 (,(concat slash variables " *" arg) 2 font-lock-variable-name-face) 552 (,(concat slash variables " *" arg) 2 font-lock-variable-name-face)
544 ;; Include args. 553 ;; Include args.
545 (,(concat slash includes opt arg) 3 font-lock-builtin-face) 554 (,(concat slash includes opt arg) 3 font-lock-builtin-face)
546 ;; Verbatim-like args.
547 (,(concat slash verbish opt arg) 3 'tex-verbatim t)
548 ;; Definitions. I think. 555 ;; Definitions. I think.
549 ("^[ \t]*\\\\def *\\\\\\(\\(\\w\\|@\\)+\\)" 556 ("^[ \t]*\\\\def *\\\\\\(\\(\\w\\|@\\)+\\)"
550 1 font-lock-function-name-face)))) 557 1 font-lock-function-name-face))))
@@ -602,14 +609,14 @@ An alternative value is \" . \", if you use a font with a narrow period."
602 (list (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t) 609 (list (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t)
603 "\\(\\(.\\|\n\\)+?\\)" 610 "\\(\\(.\\|\n\\)+?\\)"
604 (regexp-opt `("''" "\">" "\"'" ">>" "»") t)) 611 (regexp-opt `("''" "\">" "\"'" ">>" "»") t))
605 '(1 font-lock-keyword-face) 612 '(1 'font-lock-keyword-face)
606 '(2 font-lock-string-face) 613 '(2 'font-lock-string-face)
607 '(4 font-lock-keyword-face)) 614 '(4 'font-lock-keyword-face))
608 ;; 615 ;;
609 ;; Command names, special and general. 616 ;; Command names, special and general.
610 (cons (concat slash specials-1) 'font-lock-warning-face) 617 (cons (concat slash specials-1) 'font-lock-warning-face)
611 (list (concat "\\(" slash specials-2 "\\)\\([^a-zA-Z@]\\|\\'\\)") 618 (list (concat "\\(" slash specials-2 "\\)\\([^a-zA-Z@]\\|\\'\\)")
612 1 'font-lock-warning-face) 619 '(1 'font-lock-warning-face))
613 (concat slash general) 620 (concat slash general)
614 ;; 621 ;;
615 ;; Font environments. It seems a bit dubious to use `bold' etc. faces 622 ;; 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."
677(eval-when-compile 684(eval-when-compile
678 (defconst tex-syntax-propertize-rules 685 (defconst tex-syntax-propertize-rules
679 (syntax-propertize-precompile-rules 686 (syntax-propertize-precompile-rules
680 ("\\\\verb\\**\\([^a-z@*]\\)" 687 ("\\\\verb\\**\\([^a-z@*]\\)"
681 (1 (prog1 "\"" 688 (1 (prog1 "\""
682 (tex-font-lock-verb 689 (tex-font-lock-verb
683 (match-beginning 0) (char-after (match-beginning 1)))))))) 690 (match-beginning 0) (char-after (match-beginning 1))))))))
@@ -761,7 +768,7 @@ automatically inserts its partner."
761 (regexp-quote (buffer-substring arg-start arg-end))) 768 (regexp-quote (buffer-substring arg-start arg-end)))
762 (text-clone-create arg-start arg-end)))))))) 769 (text-clone-create arg-start arg-end))))))))
763 (scan-error nil) 770 (scan-error nil)
764 (error (message "Error in latex-env-before-change: %s" err))))) 771 (error (message "Error in latex-env-before-change: %S" err)))))
765 772
766(defun tex-font-lock-unfontify-region (beg end) 773(defun tex-font-lock-unfontify-region (beg end)
767 (font-lock-default-unfontify-region beg end) 774 (font-lock-default-unfontify-region beg end)
@@ -849,7 +856,7 @@ START is the position of the \\ and DELIM is the delimiter char."
849 (let ((char (nth 3 state))) 856 (let ((char (nth 3 state)))
850 (cond 857 (cond
851 ((not char) 858 ((not char)
852 (if (eq 2 (nth 7 state)) 'tex-verbatim font-lock-comment-face)) 859 (if (eq 2 (nth 7 state)) 'tex-verbatim 'font-lock-comment-face))
853 ((eq char ?$) 'tex-math) 860 ((eq char ?$) 'tex-math)
854 ;; A \verb element. 861 ;; A \verb element.
855 (t 'tex-verbatim)))) 862 (t 'tex-verbatim))))
@@ -1262,8 +1269,8 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook
1262 (setq-local facemenu-end-add-face "}") 1269 (setq-local facemenu-end-add-face "}")
1263 (setq-local facemenu-remove-face-function t) 1270 (setq-local facemenu-remove-face-function t)
1264 (setq-local font-lock-defaults 1271 (setq-local font-lock-defaults
1265 '((tex-font-lock-keywords tex-font-lock-keywords-1 1272 '(( tex-font-lock-keywords tex-font-lock-keywords-1
1266 tex-font-lock-keywords-2 tex-font-lock-keywords-3) 1273 tex-font-lock-keywords-2 tex-font-lock-keywords-3)
1267 nil nil nil nil 1274 nil nil nil nil
1268 ;; Who ever uses that anyway ??? 1275 ;; Who ever uses that anyway ???
1269 (font-lock-mark-block-function . mark-paragraph) 1276 (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'.
88This user option only takes effect when you customize it in 88This user option only takes effect when you customize it in
89Custom or with `setopt', not with `setq'." 89Custom or with `setopt', not with `setq'."
90 :group 'text 90 :group 'text
91 :type 'boolean 91 :type '(choice (const completion-at-point) boolean)
92 :version "30.1" 92 :version "30.1"
93 :set (lambda (sym val) 93 :set (lambda (sym val)
94 (if (and (set sym val) 94 (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'."
128 (save-restriction 128 (save-restriction
129 (widen) 129 (widen)
130 (let ((node (treesit-node-at (point)))) 130 (let ((node (treesit-node-at (point))))
131 (when (string= "block_scalar" (treesit-node-type node)) 131 (if (member (treesit-node-type node) '("block_scalar" "comment"))
132 (let* ((start (treesit-node-start node)) 132 (let* ((start (treesit-node-start node))
133 (end (treesit-node-end node)) 133 (end (treesit-node-end node))
134 (start-marker (point-marker)) 134 (start-marker (point-marker))
@@ -138,7 +138,8 @@ boundaries. JUSTIFY is passed to `fill-paragraph'."
138 (forward-line) 138 (forward-line)
139 (move-marker start-marker (point)) 139 (move-marker start-marker (point))
140 (narrow-to-region (point) end)) 140 (narrow-to-region (point) end))
141 (fill-region start-marker end justify)))))) 141 (fill-region start-marker end justify))
142 t))))
142 143
143;;;###autoload 144;;;###autoload
144(define-derived-mode yaml-ts-mode text-mode "YAML" 145(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.
619 619
620Optional argument DISTANCE limits search for REGEXP forward and 620Optional argument DISTANCE limits search for REGEXP forward and
621back from point." 621back from point."
622 (save-excursion 622 (let* ((old (point))
623 (let ((old-point (point)) 623 (beg (if distance (max (point-min) (- old distance)) (point-min)))
624 (forward-bound (and distance (+ (point) distance))) 624 (end (if distance (min (point-max) (+ old distance))))
625 (backward-bound (and distance (- (point) distance))) 625 prev match)
626 match prev-pos new-pos) 626 (save-excursion
627 (and (looking-at regexp) 627 (goto-char beg)
628 (>= (match-end 0) old-point) 628 (while (and (setq prev (point)
629 (setq match (point))) 629 match (re-search-forward regexp end t))
630 ;; Search back repeatedly from end of next match. 630 (< (match-end 0) old))
631 ;; This may fail if next match ends before this match does. 631 (goto-char (match-beginning 0))
632 (re-search-forward regexp forward-bound 'limit) 632 ;; Avoid inflooping when `regexp' matches the empty string.
633 (setq prev-pos (point)) 633 (unless (< prev (point)) (forward-char))))
634 (while (and (setq new-pos (re-search-backward regexp backward-bound t)) 634 (and match (<= (match-beginning 0) old (match-end 0)))))
635 ;; Avoid inflooping with some regexps, such as "^", 635
636 ;; matching which never moves point.
637 (< new-pos prev-pos)
638 (or (> (match-beginning 0) old-point)
639 (and (looking-at regexp) ; Extend match-end past search start
640 (>= (match-end 0) old-point)
641 (setq match (point))))))
642 (if (not match) nil
643 (goto-char match)
644 ;; Back up a char at a time in case search skipped
645 ;; intermediate match straddling search start pos.
646 (while (and (not (bobp))
647 (progn (backward-char 1) (looking-at regexp))
648 (>= (match-end 0) old-point)
649 (setq match (point))))
650 (goto-char match)
651 (looking-at regexp)))))
652 636
653;; Email addresses 637;; Email addresses
654(defvar thing-at-point-email-regexp 638(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.")
87(defgroup touch-screen nil 87(defgroup touch-screen nil
88 "Interact with Emacs from touch screen devices." 88 "Interact with Emacs from touch screen devices."
89 :group 'mouse 89 :group 'mouse
90 :version "30.0") 90 :version "30.1")
91 91
92(defcustom touch-screen-display-keyboard nil 92(defcustom touch-screen-display-keyboard nil
93 "If non-nil, always display the on screen keyboard. 93 "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.")
855 855
856;;; Define 856;;; Define
857 857
858;;;###autoload
859(defmacro transient-define-prefix (name arglist &rest args) 858(defmacro transient-define-prefix (name arglist &rest args)
860 "Define NAME as a transient prefix command. 859 "Define NAME as a transient prefix command.
861 860
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
344returns that ancestor node. It returns nil if no ancestor 344returns that ancestor node. It returns nil if no ancestor
345node was found that satisfies PRED. 345node was found that satisfies PRED.
346 346
347PRED should be a function that takes one argument, the node to 347PRED can be a predicate function, a regexp matching node type,
348examine, and returns a boolean value indicating whether that 348and more; see docstring of `treesit-thing-settings'.
349node is a match.
350 349
351If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED." 350If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED."
352 (let ((node (if include-node node 351 (let ((node (if include-node node
353 (treesit-node-parent node)))) 352 (treesit-node-parent node))))
354 (while (and node (not (funcall pred node))) 353 (while (and node (not (treesit-node-match-p node pred)))
355 (setq node (treesit-node-parent node))) 354 (setq node (treesit-node-parent node)))
356 node)) 355 node))
357 356
@@ -364,11 +363,10 @@ no longer satisfies the predicate PRED; it returns the last
364examined node that satisfies PRED. If no node satisfies PRED, it 363examined node that satisfies PRED. If no node satisfies PRED, it
365returns nil. 364returns nil.
366 365
367PRED should be a function that takes one argument, the node to 366PRED can be a predicate function, a regexp matching node type,
368examine, and returns a boolean value indicating whether that 367and more; see docstring of `treesit-thing-settings'."
369node is a match."
370 (let ((last nil)) 368 (let ((last nil))
371 (while (and node (funcall pred node)) 369 (while (and node (treesit-node-match-p node pred))
372 (setq last node 370 (setq last node
373 node (treesit-node-parent node))) 371 node (treesit-node-parent node)))
374 last)) 372 last))
@@ -655,37 +653,47 @@ those inside are kept."
655 if (<= start (car range) (cdr range) end) 653 if (<= start (car range) (cdr range) end)
656 collect range)) 654 collect range))
657 655
658(defun treesit-local-parsers-at (&optional pos language) 656(defun treesit-local-parsers-at (&optional pos language with-host)
659 "Return all the local parsers at POS. 657 "Return all the local parsers at POS.
660 658
661POS defaults to point. 659POS defaults to point.
662Local parsers are those which only parse a limited region marked 660Local parsers are those which only parse a limited region marked
663by an overlay with non-nil `treesit-parser' property. 661by an overlay with non-nil `treesit-parser' property.
664If LANGUAGE is non-nil, only return parsers for LANGUAGE." 662If LANGUAGE is non-nil, only return parsers for LANGUAGE.
663
664If WITH-HOST is non-nil, return a list of (PARSER . HOST-PARSER)
665instead. HOST-PARSER is the host parser which created the local
666PARSER."
665 (let ((res nil)) 667 (let ((res nil))
666 (dolist (ov (overlays-at (or pos (point)))) 668 (dolist (ov (overlays-at (or pos (point))))
667 (when-let ((parser (overlay-get ov 'treesit-parser))) 669 (when-let ((parser (overlay-get ov 'treesit-parser))
670 (host-parser (overlay-get ov 'treesit-host-parser)))
668 (when (or (null language) 671 (when (or (null language)
669 (eq (treesit-parser-language parser) 672 (eq (treesit-parser-language parser)
670 language)) 673 language))
671 (push parser res)))) 674 (push (if with-host (cons parser host-parser) parser) res))))
672 (nreverse res))) 675 (nreverse res)))
673 676
674(defun treesit-local-parsers-on (&optional beg end language) 677(defun treesit-local-parsers-on (&optional beg end language with-host)
675 "Return all the local parsers between BEG END. 678 "Return all the local parsers between BEG END.
676 679
677BEG and END default to the beginning and end of the buffer's 680BEG and END default to the beginning and end of the buffer's
678accessible portion. 681accessible portion.
679Local parsers are those which have an `embedded' tag, and only parse 682Local parsers are those which have an `embedded' tag, and only parse
680a limited region marked by an overlay with a non-nil `treesit-parser' 683a limited region marked by an overlay with a non-nil `treesit-parser'
681property. If LANGUAGE is non-nil, only return parsers for LANGUAGE." 684property. If LANGUAGE is non-nil, only return parsers for LANGUAGE.
685
686If WITH-HOST is non-nil, return a list of (PARSER . HOST-PARSER)
687instead. HOST-PARSER is the host parser which created the local
688PARSER."
682 (let ((res nil)) 689 (let ((res nil))
683 (dolist (ov (overlays-in (or beg (point-min)) (or end (point-max)))) 690 (dolist (ov (overlays-in (or beg (point-min)) (or end (point-max))))
684 (when-let ((parser (overlay-get ov 'treesit-parser))) 691 (when-let ((parser (overlay-get ov 'treesit-parser))
692 (host-parser (overlay-get ov 'treesit-host-parser)))
685 (when (or (null language) 693 (when (or (null language)
686 (eq (treesit-parser-language parser) 694 (eq (treesit-parser-language parser)
687 language)) 695 language))
688 (push parser res)))) 696 (push (if with-host (cons parser host-parser) parser) res))))
689 (nreverse res))) 697 (nreverse res)))
690 698
691(defun treesit--update-ranges-local 699(defun treesit--update-ranges-local
@@ -701,7 +709,8 @@ parser for EMBEDDED-LANG."
701 (treesit-parser-delete parser)))) 709 (treesit-parser-delete parser))))
702 ;; Update range. 710 ;; Update range.
703 (let* ((host-lang (treesit-query-language query)) 711 (let* ((host-lang (treesit-query-language query))
704 (ranges (treesit-query-range host-lang query beg end))) 712 (host-parser (treesit-parser-create host-lang))
713 (ranges (treesit-query-range host-parser query beg end)))
705 (pcase-dolist (`(,beg . ,end) ranges) 714 (pcase-dolist (`(,beg . ,end) ranges)
706 (let ((has-parser nil)) 715 (let ((has-parser nil))
707 (dolist (ov (overlays-in beg end)) 716 (dolist (ov (overlays-in beg end))
@@ -719,6 +728,7 @@ parser for EMBEDDED-LANG."
719 embedded-lang nil t 'embedded)) 728 embedded-lang nil t 'embedded))
720 (ov (make-overlay beg end nil nil t))) 729 (ov (make-overlay beg end nil nil t)))
721 (overlay-put ov 'treesit-parser embedded-parser) 730 (overlay-put ov 'treesit-parser embedded-parser)
731 (overlay-put ov 'treesit-host-parser host-parser)
722 (treesit-parser-set-included-ranges 732 (treesit-parser-set-included-ranges
723 embedded-parser `((,beg . ,end))))))))) 733 embedded-parser `((,beg . ,end)))))))))
724 734
@@ -1372,7 +1382,15 @@ as comment due to incomplete parse tree."
1372 ;; `treesit-update-ranges' will force the host language's parser to 1382 ;; `treesit-update-ranges' will force the host language's parser to
1373 ;; reparse and set correct ranges for embedded parsers. Then 1383 ;; reparse and set correct ranges for embedded parsers. Then
1374 ;; `treesit-parser-root-node' will force those parsers to reparse. 1384 ;; `treesit-parser-root-node' will force those parsers to reparse.
1375 (treesit-update-ranges) 1385 (let ((len (+ (* (window-body-height) (window-body-width)) 800)))
1386 ;; FIXME: As a temporary fix, this prevents Emacs from updating
1387 ;; every single local parsers in the buffer every time there's an
1388 ;; edit. Moving forward, we need some way to properly track the
1389 ;; regions which need update on parser ranges, like what jit-lock
1390 ;; and syntax-ppss does.
1391 (treesit-update-ranges
1392 (max (point-min) (- (point) len))
1393 (min (point-max) (+ (point) len))))
1376 ;; Force repase on _all_ the parsers might not be necessary, but 1394 ;; Force repase on _all_ the parsers might not be necessary, but
1377 ;; this is probably the most robust way. 1395 ;; this is probably the most robust way.
1378 (dolist (parser (treesit-parser-list)) 1396 (dolist (parser (treesit-parser-list))
@@ -1800,11 +1818,17 @@ Return (ANCHOR . OFFSET). This function is used by
1800 (forward-line 0) 1818 (forward-line 0)
1801 (skip-chars-forward " \t") 1819 (skip-chars-forward " \t")
1802 (point))) 1820 (point)))
1803 (local-parsers (treesit-local-parsers-at bol)) 1821 (local-parsers (treesit-local-parsers-at bol nil t))
1804 (smallest-node 1822 (smallest-node
1805 (cond ((null (treesit-parser-list)) nil) 1823 (cond ((car local-parsers)
1806 (local-parsers (treesit-node-at 1824 (let ((local-parser (caar local-parsers))
1807 bol (car local-parsers))) 1825 (host-parser (cdar local-parsers)))
1826 (if (eq (treesit-node-start
1827 (treesit-parser-root-node local-parser))
1828 bol)
1829 (treesit-node-at bol host-parser)
1830 (treesit-node-at bol local-parser))))
1831 ((null (treesit-parser-list)) nil)
1808 ((eq 1 (length (treesit-parser-list nil nil t))) 1832 ((eq 1 (length (treesit-parser-list nil nil t)))
1809 (treesit-node-at bol)) 1833 (treesit-node-at bol))
1810 ((treesit-language-at bol) 1834 ((treesit-language-at bol)
@@ -2644,9 +2668,17 @@ function is called recursively."
2644 (setq parent (treesit-node-top-level parent thing t) 2668 (setq parent (treesit-node-top-level parent thing t)
2645 prev nil 2669 prev nil
2646 next nil)) 2670 next nil))
2647 ;; If TACTIC is `restricted', the implementation is very simple. 2671 ;; If TACTIC is `restricted', the implementation is simple.
2672 ;; In principle we don't go to parent's beg/end for
2673 ;; `restricted' tactic, but if the parent is a "leaf thing"
2674 ;; (doesn't have any child "thing" inside it), then we can
2675 ;; move to the beg/end of it (bug#68899).
2648 (if (eq tactic 'restricted) 2676 (if (eq tactic 'restricted)
2649 (setq pos (funcall advance (if (> arg 0) next prev))) 2677 (setq pos (funcall
2678 advance
2679 (cond ((and (null next) (null prev)) parent)
2680 ((> arg 0) next)
2681 (t prev))))
2650 ;; For `nested', it's a bit more work: 2682 ;; For `nested', it's a bit more work:
2651 ;; Move... 2683 ;; Move...
2652 (if (> arg 0) 2684 (if (> arg 0)
@@ -2836,6 +2868,71 @@ ENTRY. MARKER marks the start of each tree-sitter node."
2836 index)))) 2868 index))))
2837 treesit-simple-imenu-settings))) 2869 treesit-simple-imenu-settings)))
2838 2870
2871;;; Outline minor mode
2872
2873(defvar-local treesit-outline-predicate nil
2874 "Predicate used to find outline headings in the syntax tree.
2875The predicate can be a function, a regexp matching node type,
2876and more; see docstring of `treesit-thing-settings'.
2877It matches the nodes located on lines with outline headings.
2878Intended to be set by a major mode. When nil, the predicate
2879is constructed from the value of `treesit-simple-imenu-settings'
2880when a major mode sets it.")
2881
2882(defun treesit-outline-predicate--from-imenu (node)
2883 ;; Return an outline searching predicate created from Imenu.
2884 ;; Return the value suitable to set `treesit-outline-predicate'.
2885 ;; Create this predicate from the value `treesit-simple-imenu-settings'
2886 ;; that major modes set to find Imenu entries. The assumption here
2887 ;; is that the positions of Imenu entries most of the time coincide
2888 ;; with the lines of outline headings. When this assumption fails,
2889 ;; you can directly set a proper value to `treesit-outline-predicate'.
2890 (seq-some
2891 (lambda (setting)
2892 (and (string-match-p (nth 1 setting) (treesit-node-type node))
2893 (or (null (nth 2 setting))
2894 (funcall (nth 2 setting) node))))
2895 treesit-simple-imenu-settings))
2896
2897(defun treesit-outline-search (&optional bound move backward looking-at)
2898 "Search for the next outline heading in the syntax tree.
2899See the descriptions of arguments in `outline-search-function'."
2900 (if looking-at
2901 (when-let* ((node (or (treesit--thing-at (pos-eol) treesit-outline-predicate)
2902 (treesit--thing-at (pos-bol) treesit-outline-predicate)))
2903 (start (treesit-node-start node)))
2904 (eq (pos-bol) (save-excursion (goto-char start) (pos-bol))))
2905
2906 (let* ((pos
2907 ;; When function wants to find the current outline, point
2908 ;; is at the beginning of the current line. When it wants
2909 ;; to find the next outline, point is at the second column.
2910 (if (eq (point) (pos-bol))
2911 (if (bobp) (point) (1- (point)))
2912 (pos-eol)))
2913 (found (treesit--navigate-thing pos (if backward -1 1) 'beg
2914 treesit-outline-predicate)))
2915 (if found
2916 (if (or (not bound) (if backward (>= found bound) (<= found bound)))
2917 (progn
2918 (goto-char found)
2919 (goto-char (pos-bol))
2920 (set-match-data (list (point) (pos-eol)))
2921 t)
2922 (when move (goto-char bound))
2923 nil)
2924 (when move (goto-char (or bound (if backward (point-min) (point-max)))))
2925 nil))))
2926
2927(defun treesit-outline-level ()
2928 "Return the depth of the current outline heading."
2929 (let* ((node (treesit-node-at (point) nil t))
2930 (level (if (treesit-node-match-p node treesit-outline-predicate)
2931 1 0)))
2932 (while (setq node (treesit-parent-until node treesit-outline-predicate))
2933 (setq level (1+ level)))
2934 (if (zerop level) 1 level)))
2935
2839;;; Activating tree-sitter 2936;;; Activating tree-sitter
2840 2937
2841(defun treesit-ready-p (language &optional quiet) 2938(defun treesit-ready-p (language &optional quiet)
@@ -2966,6 +3063,17 @@ before calling this function."
2966 (setq-local imenu-create-index-function 3063 (setq-local imenu-create-index-function
2967 #'treesit-simple-imenu)) 3064 #'treesit-simple-imenu))
2968 3065
3066 ;; Outline minor mode.
3067 (when (and (or treesit-outline-predicate treesit-simple-imenu-settings)
3068 (not (seq-some #'local-variable-p
3069 '(outline-search-function
3070 outline-regexp outline-level))))
3071 (unless treesit-outline-predicate
3072 (setq treesit-outline-predicate
3073 #'treesit-outline-predicate--from-imenu))
3074 (setq-local outline-search-function #'treesit-outline-search
3075 outline-level #'treesit-outline-level))
3076
2969 ;; Remove existing local parsers. 3077 ;; Remove existing local parsers.
2970 (dolist (ov (overlays-in (point-min) (point-max))) 3078 (dolist (ov (overlays-in (point-min) (point-max)))
2971 (when-let ((parser (overlay-get ov 'treesit-parser))) 3079 (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 @@
1;;; url-cid.el --- Content-ID URL loader -*- lexical-binding: t; -*- 1;;; url-cid.el --- Content-ID URL loader -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1998-1999, 2004-2024 Free Software Foundation, Inc. 3;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
4 4
5;; Keywords: comm, data, processes 5;; Keywords: comm, data, processes
6 6
@@ -52,12 +52,7 @@
52 52
53;;;###autoload 53;;;###autoload
54(defun url-cid (url) 54(defun url-cid (url)
55 (cond 55 (with-current-buffer (generate-new-buffer " *url-cid*")
56 ((fboundp 'mm-get-content-id) 56 (url-cid-gnus (url-filename url))))
57 ;; Using Pterodactyl Gnus or later
58 (with-current-buffer (generate-new-buffer " *url-cid*")
59 (url-cid-gnus (url-filename url))))
60 (t
61 (message "Unable to handle CID URL: %s" url))))
62 57
63;;; url-cid.el ends here 58;;; 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')."
427 427
428;; Parsing routines 428;; Parsing routines
429(defun url-http-clean-headers () 429(defun url-http-clean-headers ()
430 "Remove trailing \r from header lines. 430 "Remove trailing \\r from header lines.
431This allows us to use `mail-fetch-field', etc. 431This allows us to use `mail-fetch-field', etc.
432Return the number of characters removed." 432Return the number of characters removed."
433 (let ((end (marker-position url-http-end-of-headers))) 433 (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 @@
1;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code -*- lexical-binding: t; -*- 1;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1998-1999, 2004-2024 Free Software Foundation, Inc. 3;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
4 4
5;; Keywords: comm, data, processes 5;; Keywords: comm, data, processes
6 6
@@ -92,12 +92,8 @@
92 "'>" dn "</a>")) 92 "'>" dn "</a>"))
93 93
94(defun url-ldap-certificate-formatter (data) 94(defun url-ldap-certificate-formatter (data)
95 (condition-case () 95 ;; FIXME: tls.el is obsolete.
96 (require 'ssl) 96 (let ((vals (tls-certificate-information data)))
97 (error nil))
98 (let ((vals (if (fboundp 'ssl-certificate-information)
99 (ssl-certificate-information data)
100 (tls-certificate-information data))))
101 (if (not vals) 97 (if (not vals)
102 "<b>Unable to parse certificate</b>" 98 "<b>Unable to parse certificate</b>"
103 (concat "<table border=0>\n" 99 (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 @@
1;;; url-mailto.el --- Mail Uniform Resource Locator retrieval code -*- lexical-binding: t; -*- 1;;; url-mailto.el --- Mail Uniform Resource Locator retrieval code -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1996-1999, 2004-2024 Free Software Foundation, Inc. 3;; Copyright (C) 1996-2024 Free Software Foundation, Inc.
4 4
5;; Keywords: comm, data, processes 5;; Keywords: comm, data, processes
6 6
@@ -28,12 +28,7 @@
28(require 'url-util) 28(require 'url-util)
29 29
30;;;###autoload 30;;;###autoload
31(defun url-mail (&rest args) 31(defalias 'url-mail #'message-mail)
32 (interactive "P")
33 (if (fboundp 'message-mail)
34 (apply 'message-mail args)
35 (or (apply 'mail args)
36 (error "Mail aborted"))))
37 32
38(defun url-mail-goto-field (field) 33(defun url-mail-goto-field (field)
39 (if (not field) 34 (if (not field)
@@ -57,8 +52,6 @@
57 (save-excursion 52 (save-excursion
58 (insert "\n")))))) 53 (insert "\n"))))))
59 54
60(declare-function mail-send-and-exit "sendmail")
61
62;;;###autoload 55;;;###autoload
63(defun url-mailto (url) 56(defun url-mailto (url)
64 "Handle the mailto: URL syntax." 57 "Handle the mailto: URL syntax."
@@ -111,8 +104,6 @@
111 ;; (setq func (intern-soft (concat "mail-" (caar args)))) 104 ;; (setq func (intern-soft (concat "mail-" (caar args))))
112 (insert (mapconcat 'identity (cdar args) ", "))) 105 (insert (mapconcat 'identity (cdar args) ", ")))
113 (setq args (cdr args))) 106 (setq args (cdr args)))
114 ;; (url-mail-goto-field "User-Agent")
115;; (insert url-package-name "/" url-package-version " URL/" url-version)
116 (if (not url-request-data) 107 (if (not url-request-data)
117 (progn 108 (progn
118 (set-buffer-modified-p nil) 109 (set-buffer-modified-p nil)
@@ -128,8 +119,8 @@
128 (goto-char (point-max)) 119 (goto-char (point-max))
129 (insert url-request-data) 120 (insert url-request-data)
130 ;; It seems Microsoft-ish to send without warning. 121 ;; It seems Microsoft-ish to send without warning.
131 ;; Fixme: presumably this should depend on a privacy setting. 122 ;; FIXME: presumably this should depend on a privacy setting.
132 (if (y-or-n-p "Send this auto-generated mail? ") 123 (if (y-or-n-p "Send this auto-generated mail?")
133 (let ((buffer (current-buffer))) 124 (let ((buffer (current-buffer)))
134 (cond ((eq url-mail-command 'compose-mail) 125 (cond ((eq url-mail-command 'compose-mail)
135 (funcall (get mail-user-agent 'sendfunc) nil)) 126 (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
517 ("^Only in .*\n" . 'diff-nonexistent) 517 ("^Only in .*\n" . 'diff-nonexistent)
518 ("^Binary files .* differ\n" . 'diff-file-header) 518 ("^Binary files .* differ\n" . 'diff-file-header)
519 ("^\\(#\\)\\(.*\\)" 519 ("^\\(#\\)\\(.*\\)"
520 (1 font-lock-comment-delimiter-face) 520 (1 'font-lock-comment-delimiter-face)
521 (2 font-lock-comment-face)) 521 (2 'font-lock-comment-face))
522 ("^diff: .*" (0 'diff-error)) 522 ("^diff: .*" (0 'diff-error))
523 ("^[^-=+*!<>#].*\n" (0 'diff-context)) 523 ("^[^-=+*!<>#].*\n" (0 'diff-context))
524 (,#'diff--font-lock-syntax) 524 (,#'diff--font-lock-syntax)
@@ -944,7 +944,8 @@ like \(diff-merge-strings \"b/foo\" \"b/bar\" \"/a/c/foo\")."
944 (when (and (string-match (concat 944 (when (and (string-match (concat
945 "\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n" 945 "\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n"
946 "\\1\\(.*\\)\\3\n" 946 "\\1\\(.*\\)\\3\n"
947 "\\(.*\\(\\2\\).*\\)\\'") str) 947 "\\(.*\\(\\2\\).*\\)\\'")
948 str)
948 (equal to (match-string 5 str))) 949 (equal to (match-string 5 str)))
949 (concat (substring str (match-beginning 5) (match-beginning 6)) 950 (concat (substring str (match-beginning 5) (match-beginning 6))
950 (match-string 4 str) 951 (match-string 4 str)
@@ -1999,7 +2000,7 @@ With a prefix argument, REVERSE the hunk."
1999 (diff-find-source-location nil reverse))) 2000 (diff-find-source-location nil reverse)))
2000 (cond 2001 (cond
2001 ((null line-offset) 2002 ((null line-offset)
2002 (error "Can't find the text to patch")) 2003 (user-error "Can't find the text to patch"))
2003 ((with-current-buffer buf 2004 ((with-current-buffer buf
2004 (and buffer-file-name 2005 (and buffer-file-name
2005 (backup-file-name-p buffer-file-name) 2006 (backup-file-name-p buffer-file-name)
@@ -2008,7 +2009,7 @@ With a prefix argument, REVERSE the hunk."
2008 (yes-or-no-p (format "Really apply this hunk to %s? " 2009 (yes-or-no-p (format "Really apply this hunk to %s? "
2009 (file-name-nondirectory 2010 (file-name-nondirectory
2010 buffer-file-name))))))) 2011 buffer-file-name)))))))
2011 (error "%s" 2012 (user-error "%s"
2012 (substitute-command-keys 2013 (substitute-command-keys
2013 (format "Use %s\\[diff-apply-hunk] to apply it to the other file" 2014 (format "Use %s\\[diff-apply-hunk] to apply it to the other file"
2014 (if (not reverse) "\\[universal-argument] "))))) 2015 (if (not reverse) "\\[universal-argument] ")))))
@@ -2275,6 +2276,24 @@ Return new point, if it was moved."
2275 (end (progn (diff-end-of-hunk) (point)))) 2276 (end (progn (diff-end-of-hunk) (point))))
2276 (diff--refine-hunk beg end))))) 2277 (diff--refine-hunk beg end)))))
2277 2278
2279(defun diff--refine-propertize (beg end face)
2280 (let ((ol (make-overlay beg end)))
2281 (overlay-put ol 'diff-mode 'fine)
2282 (overlay-put ol 'evaporate t)
2283 (overlay-put ol 'face face)))
2284
2285(defcustom diff-refine-nonmodified nil
2286 "If non-nil, also highlight the added/removed lines as \"refined\".
2287The lines highlighted when this is non-nil are those that were
2288added or removed in their entirety, as opposed to lines some
2289parts of which were modified. The added lines are highlighted
2290using the `diff-refine-added' face, while the removed lines are
2291highlighted using the `diff-refine-removed' face.
2292This is currently implemented only for diff formats supported
2293by `diff-refine-hunk'."
2294 :version "30.1"
2295 :type 'boolean)
2296
2278(defun diff--refine-hunk (start end) 2297(defun diff--refine-hunk (start end)
2279 (require 'smerge-mode) 2298 (require 'smerge-mode)
2280 (goto-char start) 2299 (goto-char start)
@@ -2289,41 +2308,68 @@ Return new point, if it was moved."
2289 (goto-char beg) 2308 (goto-char beg)
2290 (pcase style 2309 (pcase style
2291 ('unified 2310 ('unified
2292 (while (re-search-forward "^-" end t) 2311 (while (re-search-forward "^[-+]" end t)
2293 (let ((beg-del (progn (beginning-of-line) (point))) 2312 (let ((beg-del (progn (beginning-of-line) (point)))
2294 beg-add end-add) 2313 beg-add end-add)
2295 (when (and (diff--forward-while-leading-char ?- end) 2314 (cond
2296 ;; Allow for "\ No newline at end of file". 2315 ((eq (char-after) ?+)
2297 (progn (diff--forward-while-leading-char ?\\ end) 2316 (diff--forward-while-leading-char ?+ end)
2298 (setq beg-add (point))) 2317 (when diff-refine-nonmodified
2299 (diff--forward-while-leading-char ?+ end) 2318 (diff--refine-propertize beg-del (point) 'diff-refine-added)))
2300 (progn (diff--forward-while-leading-char ?\\ end) 2319 ((and (diff--forward-while-leading-char ?- end)
2301 (setq end-add (point)))) 2320 ;; Allow for "\ No newline at end of file".
2321 (progn (diff--forward-while-leading-char ?\\ end)
2322 (setq beg-add (point)))
2323 (diff--forward-while-leading-char ?+ end)
2324 (progn (diff--forward-while-leading-char ?\\ end)
2325 (setq end-add (point))))
2302 (smerge-refine-regions beg-del beg-add beg-add end-add 2326 (smerge-refine-regions beg-del beg-add beg-add end-add
2303 nil #'diff-refine-preproc props-r props-a))))) 2327 nil #'diff-refine-preproc props-r props-a))
2328 (t ;; If we're here, it's because
2329 ;; (diff--forward-while-leading-char ?+ end) failed.
2330 (when diff-refine-nonmodified
2331 (diff--refine-propertize beg-del (point)
2332 'diff-refine-removed)))))))
2304 ('context 2333 ('context
2305 (let* ((middle (save-excursion (re-search-forward "^---" end t))) 2334 (let* ((middle (save-excursion (re-search-forward "^---" end t)))
2306 (other middle)) 2335 (other middle))
2307 (while (and middle 2336 (when middle
2308 (re-search-forward "^\\(?:!.*\n\\)+" middle t)) 2337 (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
2309 (smerge-refine-regions (match-beginning 0) (match-end 0) 2338 (smerge-refine-regions (match-beginning 0) (match-end 0)
2310 (save-excursion 2339 (save-excursion
2311 (goto-char other) 2340 (goto-char other)
2312 (re-search-forward "^\\(?:!.*\n\\)+" end) 2341 (re-search-forward "^\\(?:!.*\n\\)+" end)
2313 (setq other (match-end 0)) 2342 (setq other (match-end 0))
2314 (match-beginning 0)) 2343 (match-beginning 0))
2315 other 2344 other
2316 (if diff-use-changed-face props-c) 2345 (if diff-use-changed-face props-c)
2317 #'diff-refine-preproc 2346 #'diff-refine-preproc
2318 (unless diff-use-changed-face props-r) 2347 (unless diff-use-changed-face props-r)
2319 (unless diff-use-changed-face props-a))))) 2348 (unless diff-use-changed-face props-a)))
2349 (when diff-refine-nonmodified
2350 (goto-char beg)
2351 (while (re-search-forward "^\\(?:-.*\n\\)+" middle t)
2352 (diff--refine-propertize (match-beginning 0)
2353 (match-end 0)
2354 'diff-refine-removed))
2355 (goto-char middle)
2356 (while (re-search-forward "^\\(?:+.*\n\\)+" end t)
2357 (diff--refine-propertize (match-beginning 0)
2358 (match-end 0)
2359 'diff-refine-added))))))
2320 (_ ;; Normal diffs. 2360 (_ ;; Normal diffs.
2321 (let ((beg1 (1+ (point)))) 2361 (let ((beg1 (1+ (point))))
2322 (when (re-search-forward "^---.*\n" end t) 2362 (cond
2363 ((re-search-forward "^---.*\n" end t)
2323 ;; It's a combined add&remove, so there's something to do. 2364 ;; It's a combined add&remove, so there's something to do.
2324 (smerge-refine-regions beg1 (match-beginning 0) 2365 (smerge-refine-regions beg1 (match-beginning 0)
2325 (match-end 0) end 2366 (match-end 0) end
2326 nil #'diff-refine-preproc props-r props-a))))))) 2367 nil #'diff-refine-preproc props-r props-a))
2368 (diff-refine-nonmodified
2369 (diff--refine-propertize
2370 beg1 end
2371 (if (eq (char-after beg1) ?<)
2372 'diff-refine-removed 'diff-refine-added)))))))))
2327 2373
2328(defun diff--iterate-hunks (max fun) 2374(defun diff--iterate-hunks (max fun)
2329 "Iterate over all hunks between point and MAX. 2375 "Iterate over all hunks between point and MAX.
@@ -2817,6 +2863,57 @@ and the position in MAX."
2817(defvar-local diff--syntax-file-attributes nil) 2863(defvar-local diff--syntax-file-attributes nil)
2818(put 'diff--syntax-file-attributes 'permanent-local t) 2864(put 'diff--syntax-file-attributes 'permanent-local t)
2819 2865
2866(defvar diff--cached-revision-buffers nil
2867 "List of ((FILE . REVISION) . BUFFER) in MRU order.")
2868
2869(defvar diff--cache-clean-timer nil)
2870(defconst diff--cache-clean-interval 3600) ; seconds
2871
2872(defun diff--cache-clean ()
2873 "Discard the least recently used half of the cache."
2874 (let ((n (/ (length diff--cached-revision-buffers) 2)))
2875 (mapc #'kill-buffer (mapcar #'cdr (nthcdr n diff--cached-revision-buffers)))
2876 (setq diff--cached-revision-buffers
2877 (ntake n diff--cached-revision-buffers)))
2878 (diff--cache-schedule-clean))
2879
2880(defun diff--cache-schedule-clean ()
2881 (setq diff--cache-clean-timer
2882 (and diff--cached-revision-buffers
2883 (run-with-timer diff--cache-clean-interval nil
2884 #'diff--cache-clean))))
2885
2886(defun diff--get-revision-properties (file revision text line-nb)
2887 "Get font-lock properties from FILE at REVISION for TEXT at LINE-NB."
2888 (let* ((file-rev (cons file revision))
2889 (entry (assoc file-rev diff--cached-revision-buffers))
2890 (buffer (cdr entry)))
2891 (if (buffer-live-p buffer)
2892 (progn
2893 ;; Don't re-initialize the buffer (which would throw
2894 ;; away the previous fontification work).
2895 (setq file nil)
2896 (setq diff--cached-revision-buffers
2897 (cons entry
2898 (delq entry diff--cached-revision-buffers))))
2899 ;; Cache miss: create a new entry.
2900 (setq buffer (get-buffer-create (format " *diff-syntax:%s.~%s~*"
2901 file revision)))
2902 (condition-case nil
2903 (vc-find-revision-no-save file revision diff-vc-backend buffer)
2904 (error
2905 (kill-buffer buffer)
2906 (setq buffer nil))
2907 (:success
2908 (push (cons file-rev buffer)
2909 diff--cached-revision-buffers))))
2910 (when diff--cache-clean-timer
2911 (cancel-timer diff--cache-clean-timer))
2912 (diff--cache-schedule-clean)
2913 (and buffer
2914 (with-current-buffer buffer
2915 (diff-syntax-fontify-props file text line-nb)))))
2916
2820(defun diff-syntax-fontify-hunk (beg end old) 2917(defun diff-syntax-fontify-hunk (beg end old)
2821 "Highlight source language syntax in diff hunk between BEG and END. 2918 "Highlight source language syntax in diff hunk between BEG and END.
2822When OLD is non-nil, highlight the hunk from the old source." 2919When 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."
2867 (insert-file-contents file) 2964 (insert-file-contents file)
2868 (setq diff--syntax-file-attributes attrs))) 2965 (setq diff--syntax-file-attributes attrs)))
2869 (diff-syntax-fontify-props file text line-nb))))) 2966 (diff-syntax-fontify-props file text line-nb)))))
2870 ;; Get properties from a cached revision 2967 (diff--get-revision-properties file revision
2871 (let* ((buffer-name (format " *diff-syntax:%s.~%s~*" 2968 text line-nb)))))
2872 file revision))
2873 (buffer (get-buffer buffer-name)))
2874 (if buffer
2875 ;; Don't re-initialize the buffer (which would throw
2876 ;; away the previous fontification work).
2877 (setq file nil)
2878 (setq buffer (ignore-errors
2879 (vc-find-revision-no-save
2880 file revision
2881 diff-vc-backend
2882 (get-buffer-create buffer-name)))))
2883 (when buffer
2884 (with-current-buffer buffer
2885 (diff-syntax-fontify-props file text line-nb))))))))
2886 (let ((file (car (diff-hunk-file-names old)))) 2969 (let ((file (car (diff-hunk-file-names old))))
2887 (cond 2970 (cond
2888 ((and file diff-default-directory 2971 ((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."
1411 (vc-message-unresolved-conflicts buffer-file-name))) 1411 (vc-message-unresolved-conflicts buffer-file-name)))
1412 1412
1413(defun vc-git-clone (remote directory rev) 1413(defun vc-git-clone (remote directory rev)
1414 (if rev 1414 "Attempt to clone REMOTE repository into DIRECTORY at revision REV."
1415 (vc-git--out-ok "clone" "--branch" rev remote directory) 1415 (cond
1416 ((null rev)
1416 (vc-git--out-ok "clone" remote directory)) 1417 (vc-git--out-ok "clone" remote directory))
1418 ((ignore-errors
1419 (vc-git--out-ok "clone" "--branch" rev remote directory)))
1420 ((vc-git--out-ok "clone" remote directory)
1421 (let ((default-directory directory))
1422 (vc-git--out-ok "checkout" rev)))
1423 ((error "Failed to check out %s at %s" remote rev)))
1417 directory) 1424 directory)
1418 1425
1419;;; HISTORY FUNCTIONS 1426;;; 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."
186This minor mode is automatically activated whenever you visit a file under 186This minor mode is automatically activated whenever you visit a file under
187control of one of the revision control systems in `vc-handled-backends'. 187control of one of the revision control systems in `vc-handled-backends'.
188VC commands are globally reachable under the prefix \\[vc-prefix-map]: 188VC commands are globally reachable under the prefix \\[vc-prefix-map]:
189\\{vc-prefix-map}") 189\\{vc-prefix-map}"
190 nil)
190 191
191(defmacro vc-error-occurred (&rest body) 192(defmacro vc-error-occurred (&rest body)
192 `(condition-case nil (progn ,@body nil) (error t))) 193 `(condition-case nil (progn ,@body nil) (error t)))
@@ -197,7 +198,7 @@ VC commands are globally reachable under the prefix \\[vc-prefix-map]:
197;; during any subsequent VC operations, and forget them when 198;; during any subsequent VC operations, and forget them when
198;; the buffer is killed. 199;; the buffer is killed.
199 200
200(defvar vc-file-prop-obarray (make-vector 17 0) 201(defvar vc-file-prop-obarray (obarray-make 17)
201 "Obarray for per-file properties.") 202 "Obarray for per-file properties.")
202 203
203(defvar vc-touched-properties nil) 204(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."
935(defun vc-clear-context () 935(defun vc-clear-context ()
936 "Clear all cached file properties." 936 "Clear all cached file properties."
937 (interactive) 937 (interactive)
938 (fillarray vc-file-prop-obarray 0)) 938 (obarray-clear vc-file-prop-obarray))
939 939
940(defmacro with-vc-properties (files form settings) 940(defmacro with-vc-properties (files form settings)
941 "Execute FORM, then maybe set per-file properties for FILES. 941 "Execute FORM, then maybe set per-file properties for FILES.
@@ -3623,7 +3623,15 @@ revisions.
3623When invoked interactively in a Log View buffer with 3623When invoked interactively in a Log View buffer with
3624marked revisions, use those." 3624marked revisions, use those."
3625 (interactive 3625 (interactive
3626 (let ((revs (vc-prepare-patch-prompt-revisions)) to) 3626 (let* ((revs (vc-prepare-patch-prompt-revisions))
3627 (subject
3628 (and (length= revs 1)
3629 (plist-get
3630 (vc-call-backend
3631 (vc-responsible-backend default-directory)
3632 'prepare-patch (car revs))
3633 :subject)))
3634 to)
3627 (require 'message) 3635 (require 'message)
3628 (while (null (setq to (completing-read-multiple 3636 (while (null (setq to (completing-read-multiple
3629 (format-prompt 3637 (format-prompt
@@ -3636,10 +3644,9 @@ marked revisions, use those."
3636 (sit-for blink-matching-delay)) 3644 (sit-for blink-matching-delay))
3637 (list (string-join to ", ") 3645 (list (string-join to ", ")
3638 (and (not vc-prepare-patches-separately) 3646 (and (not vc-prepare-patches-separately)
3639 (read-string "Subject: " "[PATCH] " nil nil t)) 3647 (read-string "Subject: " (or subject "[PATCH] ") nil nil t))
3640 revs))) 3648 revs)))
3641 (save-current-buffer 3649 (save-current-buffer
3642 (vc-ensure-vc-buffer)
3643 (let ((patches (mapcar (lambda (rev) 3650 (let ((patches (mapcar (lambda (rev)
3644 (vc-call-backend 3651 (vc-call-backend
3645 (vc-responsible-backend default-directory) 3652 (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."
433(defcustom vcursor-interpret-input nil 433(defcustom vcursor-interpret-input nil
434 "If non-nil, input from the vcursor is treated as interactive input. 434 "If non-nil, input from the vcursor is treated as interactive input.
435This will cause text insertion to be much slower. Note that no special 435This will cause text insertion to be much slower. Note that no special
436interpretation of strings is done: \"\C-x\" is a string of four 436interpretation of strings is done: \"\\C-x\" is a string of four
437characters. The default is simply to copy strings." 437characters. The default is simply to copy strings."
438 :type 'boolean 438 :type 'boolean
439 :version "20.3") 439 :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'."
173 173
174;;;###autoload 174;;;###autoload
175(define-minor-mode visual-wrap-prefix-mode 175(define-minor-mode visual-wrap-prefix-mode
176 "Display continuation lines with prefixes from surrounding context." 176 "Display continuation lines with prefixes from surrounding context.
177To enable this minor mode across all buffers, enable
178`global-visual-wrap-prefix-mode'."
177 :lighter "" 179 :lighter ""
178 :group 'visual-line 180 :group 'visual-line
179 (if visual-wrap-prefix-mode 181 (if visual-wrap-prefix-mode
@@ -192,5 +194,11 @@ by `visual-wrap-extra-indent'."
192 (widen) 194 (widen)
193 (remove-text-properties (point-min) (point-max) '(wrap-prefix nil)))))) 195 (remove-text-properties (point-min) (point-max) '(wrap-prefix nil))))))
194 196
197;;;###autoload
198(define-globalized-minor-mode global-visual-wrap-prefix-mode
199 visual-wrap-prefix-mode visual-wrap-prefix-mode
200 :init-value nil
201 :group 'visual-line)
202
195(provide 'visual-wrap) 203(provide 'visual-wrap)
196;;; visual-wrap.el ends here 204;;; 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*,
178 (setq winner-last-frames nil) 178 (setq winner-last-frames nil)
179 (setq winner-last-command this-command)) 179 (setq winner-last-command this-command))
180 (dolist (frame winner-modified-list) 180 (dolist (frame winner-modified-list)
181 (winner-insert-if-new frame)) 181 (if (frame-live-p frame)
182 (winner-insert-if-new frame)))
182 (setq winner-modified-list nil) 183 (setq winner-modified-list nil)
183 (winner-remember))) 184 (winner-remember)))
184 185
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."
2566 ;; "\\(\\\\{\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*" 2566 ;; "\\(\\\\{\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*"
2567 ;; Interpret bogus `el \}' as `el \{', 2567 ;; Interpret bogus `el \}' as `el \{',
2568 ;; especially for Tcl/Tk man pages: 2568 ;; especially for Tcl/Tk man pages:
2569 "\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*") 2569 "\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*"
2570 nil t)
2570 (match-beginning 1)) 2571 (match-beginning 1))
2571 (re-search-forward "\\\\}")) 2572 (re-search-forward "\\\\}"))
2572 (delete-region (if delete from (match-beginning 0)) (point)) 2573 (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 @@
1# copy-file-range.m4 1# copy-file-range.m4 serial 5
2dnl Copyright 2019-2024 Free Software Foundation, Inc. 2dnl Copyright 2019-2024 Free Software Foundation, Inc.
3dnl This file is free software; the Free Software Foundation 3dnl This file is free software; the Free Software Foundation
4dnl gives unlimited permission to copy and/or distribute it, 4dnl gives unlimited permission to copy and/or distribute it,
@@ -17,22 +17,33 @@ AC_DEFUN([gl_FUNC_COPY_FILE_RANGE],
17 dnl Programs that use copy_file_range must fall back on read+write 17 dnl Programs that use copy_file_range must fall back on read+write
18 dnl anyway, and there's little point to substituting the Gnulib stub 18 dnl anyway, and there's little point to substituting the Gnulib stub
19 dnl for a glibc stub. 19 dnl for a glibc stub.
20 AC_CACHE_CHECK([for copy_file_range], [gl_cv_func_copy_file_range], 20 case "$host_os" in
21 [AC_LINK_IFELSE( 21 *-gnu* | gnu*)
22 [AC_LANG_PROGRAM( 22 AC_CACHE_CHECK([for copy_file_range], [gl_cv_func_copy_file_range],
23 [[#include <unistd.h> 23 [AC_LINK_IFELSE(
24 ]], 24 [AC_LANG_PROGRAM(
25 [[ssize_t (*func) (int, off_t *, int, off_t *, size_t, unsigned) 25 [[#include <unistd.h>
26 = copy_file_range; 26 ]],
27 return func (0, 0, 0, 0, 0, 0) & 127; 27 [[ssize_t (*func) (int, off_t *, int, off_t *, size_t, unsigned)
28 ]]) 28 = copy_file_range;
29 ], 29 return func (0, 0, 0, 0, 0, 0) & 127;
30 [gl_cv_func_copy_file_range=yes], 30 ]])
31 [gl_cv_func_copy_file_range=no]) 31 ],
32 ]) 32 [gl_cv_func_copy_file_range=yes],
33 33 [gl_cv_func_copy_file_range=no])
34 ])
35 gl_cv_onwards_func_copy_file_range="$gl_cv_func_copy_file_range"
36 ;;
37 *)
38 gl_CHECK_FUNCS_ANDROID([copy_file_range], [[#include <unistd.h>]])
39 gl_cv_func_copy_file_range="$ac_cv_func_copy_file_range"
40 ;;
41 esac
34 if test "$gl_cv_func_copy_file_range" != yes; then 42 if test "$gl_cv_func_copy_file_range" != yes; then
35 HAVE_COPY_FILE_RANGE=0 43 HAVE_COPY_FILE_RANGE=0
44 case "$gl_cv_onwards_func_copy_file_range" in
45 future*) REPLACE_COPY_FILE_RANGE=1 ;;
46 esac
36 else 47 else
37 AC_DEFINE([HAVE_COPY_FILE_RANGE], 1, 48 AC_DEFINE([HAVE_COPY_FILE_RANGE], 1,
38 [Define to 1 if the function copy_file_range exists.]) 49 [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 @@
1# gettime.m4 serial 14 1# gettime.m4 serial 15
2dnl Copyright (C) 2002, 2004-2006, 2009-2024 Free Software Foundation, Inc. 2dnl Copyright (C) 2002, 2004-2006, 2009-2024 Free Software Foundation, Inc.
3dnl This file is free software; the Free Software Foundation 3dnl This file is free software; the Free Software Foundation
4dnl gives unlimited permission to copy and/or distribute it, 4dnl gives unlimited permission to copy and/or distribute it,
@@ -64,5 +64,5 @@ AC_DEFUN([gl_GETTIME_RES],
64 dnl Prerequisites of lib/gettime-res.c. 64 dnl Prerequisites of lib/gettime-res.c.
65 AC_REQUIRE([gl_CLOCK_TIME]) 65 AC_REQUIRE([gl_CLOCK_TIME])
66 AC_REQUIRE([gl_TIMESPEC]) 66 AC_REQUIRE([gl_TIMESPEC])
67 AC_CHECK_FUNCS_ONCE([timespec_getres]) 67 gl_CHECK_FUNCS_ANDROID([timespec_getres], [[#include <time.h>]])
68]) 68])
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 @@
1# gnulib-common.m4 serial 90 1# gnulib-common.m4 serial 92
2dnl Copyright (C) 2007-2024 Free Software Foundation, Inc. 2dnl Copyright (C) 2007-2024 Free Software Foundation, Inc.
3dnl This file is free software; the Free Software Foundation 3dnl This file is free software; the Free Software Foundation
4dnl gives unlimited permission to copy and/or distribute it, 4dnl gives unlimited permission to copy and/or distribute it,
@@ -76,42 +76,48 @@ AC_DEFUN([gl_COMMON_BODY], [
76#endif]) 76#endif])
77 AH_VERBATIM([attribute], 77 AH_VERBATIM([attribute],
78[/* Attributes. */ 78[/* Attributes. */
79#if (defined __has_attribute \ 79/* Define _GL_HAS_ATTRIBUTE only once, because on FreeBSD, with gcc < 5, if
80 && (!defined __clang_minor__ \ 80 <config.h> gets included once again after <sys/cdefs.h>, __has_attribute(x)
81 || (defined __apple_build_version__ \ 81 expands to 0 always, and redefining _GL_HAS_ATTRIBUTE would turn off all
82 ? 6000000 <= __apple_build_version__ \ 82 attributes. */
83 : 5 <= __clang_major__))) 83#ifndef _GL_HAS_ATTRIBUTE
84# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__) 84# if (defined __has_attribute \
85#else 85 && (!defined __clang_minor__ \
86# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr 86 || (defined __apple_build_version__ \
87# define _GL_ATTR_alloc_size _GL_GNUC_PREREQ (4, 3) 87 ? 7000000 <= __apple_build_version__ \
88# define _GL_ATTR_always_inline _GL_GNUC_PREREQ (3, 2) 88 : 5 <= __clang_major__)))
89# define _GL_ATTR_artificial _GL_GNUC_PREREQ (4, 3) 89# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__)
90# define _GL_ATTR_cold _GL_GNUC_PREREQ (4, 3)
91# define _GL_ATTR_const _GL_GNUC_PREREQ (2, 95)
92# define _GL_ATTR_deprecated _GL_GNUC_PREREQ (3, 1)
93# define _GL_ATTR_diagnose_if 0
94# define _GL_ATTR_error _GL_GNUC_PREREQ (4, 3)
95# define _GL_ATTR_externally_visible _GL_GNUC_PREREQ (4, 1)
96# define _GL_ATTR_fallthrough _GL_GNUC_PREREQ (7, 0)
97# define _GL_ATTR_format _GL_GNUC_PREREQ (2, 7)
98# define _GL_ATTR_leaf _GL_GNUC_PREREQ (4, 6)
99# define _GL_ATTR_malloc _GL_GNUC_PREREQ (3, 0)
100# ifdef _ICC
101# define _GL_ATTR_may_alias 0
102# else 90# else
103# define _GL_ATTR_may_alias _GL_GNUC_PREREQ (3, 3) 91# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr
92# define _GL_ATTR_alloc_size _GL_GNUC_PREREQ (4, 3)
93# define _GL_ATTR_always_inline _GL_GNUC_PREREQ (3, 2)
94# define _GL_ATTR_artificial _GL_GNUC_PREREQ (4, 3)
95# define _GL_ATTR_cold _GL_GNUC_PREREQ (4, 3)
96# define _GL_ATTR_const _GL_GNUC_PREREQ (2, 95)
97# define _GL_ATTR_deprecated _GL_GNUC_PREREQ (3, 1)
98# define _GL_ATTR_diagnose_if 0
99# define _GL_ATTR_error _GL_GNUC_PREREQ (4, 3)
100# define _GL_ATTR_externally_visible _GL_GNUC_PREREQ (4, 1)
101# define _GL_ATTR_fallthrough _GL_GNUC_PREREQ (7, 0)
102# define _GL_ATTR_format _GL_GNUC_PREREQ (2, 7)
103# define _GL_ATTR_leaf _GL_GNUC_PREREQ (4, 6)
104# define _GL_ATTR_malloc _GL_GNUC_PREREQ (3, 0)
105# ifdef _ICC
106# define _GL_ATTR_may_alias 0
107# else
108# define _GL_ATTR_may_alias _GL_GNUC_PREREQ (3, 3)
109# endif
110# define _GL_ATTR_noinline _GL_GNUC_PREREQ (3, 1)
111# define _GL_ATTR_nonnull _GL_GNUC_PREREQ (3, 3)
112# define _GL_ATTR_nonstring _GL_GNUC_PREREQ (8, 0)
113# define _GL_ATTR_nothrow _GL_GNUC_PREREQ (3, 3)
114# define _GL_ATTR_packed _GL_GNUC_PREREQ (2, 7)
115# define _GL_ATTR_pure _GL_GNUC_PREREQ (2, 96)
116# define _GL_ATTR_returns_nonnull _GL_GNUC_PREREQ (4, 9)
117# define _GL_ATTR_sentinel _GL_GNUC_PREREQ (4, 0)
118# define _GL_ATTR_unused _GL_GNUC_PREREQ (2, 7)
119# define _GL_ATTR_warn_unused_result _GL_GNUC_PREREQ (3, 4)
104# endif 120# endif
105# define _GL_ATTR_noinline _GL_GNUC_PREREQ (3, 1)
106# define _GL_ATTR_nonnull _GL_GNUC_PREREQ (3, 3)
107# define _GL_ATTR_nonstring _GL_GNUC_PREREQ (8, 0)
108# define _GL_ATTR_nothrow _GL_GNUC_PREREQ (3, 3)
109# define _GL_ATTR_packed _GL_GNUC_PREREQ (2, 7)
110# define _GL_ATTR_pure _GL_GNUC_PREREQ (2, 96)
111# define _GL_ATTR_returns_nonnull _GL_GNUC_PREREQ (4, 9)
112# define _GL_ATTR_sentinel _GL_GNUC_PREREQ (4, 0)
113# define _GL_ATTR_unused _GL_GNUC_PREREQ (2, 7)
114# define _GL_ATTR_warn_unused_result _GL_GNUC_PREREQ (3, 4)
115#endif 121#endif
116 122
117/* Use __has_c_attribute if available. However, do not use with 123/* 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],
432 ]) 432 ])
433 gl_STRING_MODULE_INDICATOR([memrchr]) 433 gl_STRING_MODULE_INDICATOR([memrchr])
434 gl_FUNC_MEMSET_EXPLICIT 434 gl_FUNC_MEMSET_EXPLICIT
435 gl_CONDITIONAL([GL_COND_OBJ_MEMSET_EXPLICIT], [test $HAVE_MEMSET_EXPLICIT = 0]) 435 gl_CONDITIONAL([GL_COND_OBJ_MEMSET_EXPLICIT],
436 [test $HAVE_MEMSET_EXPLICIT = 0 || test $REPLACE_MEMSET_EXPLICIT = 1])
436 AM_COND_IF([GL_COND_OBJ_MEMSET_EXPLICIT], [ 437 AM_COND_IF([GL_COND_OBJ_MEMSET_EXPLICIT], [
437 gl_PREREQ_MEMSET_EXPLICIT 438 gl_PREREQ_MEMSET_EXPLICIT
438 ]) 439 ])
@@ -1023,7 +1024,7 @@ AC_DEFUN([gl_INIT],
1023 if test $ac_use_included_regex = yes; then 1024 if test $ac_use_included_regex = yes; then
1024 func_gl_gnulib_m4code_fd38c7e463b54744b77b98aeafb4fa7c 1025 func_gl_gnulib_m4code_fd38c7e463b54744b77b98aeafb4fa7c
1025 fi 1026 fi
1026 if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then 1027 if test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; then
1027 func_gl_gnulib_m4code_strtoll 1028 func_gl_gnulib_m4code_strtoll
1028 fi 1029 fi
1029 if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then 1030 if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then
@@ -1421,6 +1422,7 @@ AC_DEFUN([gl_FILE_LIST], [
1421 lib/stdlib.in.h 1422 lib/stdlib.in.h
1422 lib/stpcpy.c 1423 lib/stpcpy.c
1423 lib/str-two-way.h 1424 lib/str-two-way.h
1425 lib/strftime.c
1424 lib/strftime.h 1426 lib/strftime.h
1425 lib/string.in.h 1427 lib/string.in.h
1426 lib/strnlen.c 1428 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 @@
1# memset_explicit.m4 serial 2
1dnl Copyright 2022-2024 Free Software Foundation, Inc. 2dnl Copyright 2022-2024 Free Software Foundation, Inc.
2dnl This file is free software; the Free Software Foundation 3dnl This file is free software; the Free Software Foundation
3dnl gives unlimited permission to copy and/or distribute it, 4dnl gives unlimited permission to copy and/or distribute it,
@@ -7,9 +8,12 @@ AC_DEFUN([gl_FUNC_MEMSET_EXPLICIT],
7[ 8[
8 AC_REQUIRE([gl_STRING_H_DEFAULTS]) 9 AC_REQUIRE([gl_STRING_H_DEFAULTS])
9 10
10 AC_CHECK_FUNCS_ONCE([memset_explicit]) 11 gl_CHECK_FUNCS_ANDROID([memset_explicit], [[#include <string.h>]])
11 if test $ac_cv_func_memset_explicit = no; then 12 if test $ac_cv_func_memset_explicit = no; then
12 HAVE_MEMSET_EXPLICIT=0 13 HAVE_MEMSET_EXPLICIT=0
14 case "$gl_cv_onwards_func_memset_explicit" in
15 future*) REPLACE_MEMSET_EXPLICIT=1 ;;
16 esac
13 fi 17 fi
14]) 18])
15 19
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 @@
1# serial 46 1# serial 47
2 2
3dnl From Jim Meyering. 3dnl From Jim Meyering.
4dnl Check for the nanosleep function. 4dnl Check for the nanosleep function.
@@ -119,6 +119,10 @@ AC_DEFUN([gl_FUNC_NANOSLEEP],
119 # Guess it halfway works when the kernel is Linux. 119 # Guess it halfway works when the kernel is Linux.
120 linux*) 120 linux*)
121 gl_cv_func_nanosleep='guessing no (mishandles large arguments)' ;; 121 gl_cv_func_nanosleep='guessing no (mishandles large arguments)' ;;
122 # Midipix generally emulates the Linux system calls,
123 # but here it handles large arguments correctly.
124 midipix*)
125 gl_cv_func_nanosleep='guessing yes' ;;
122 # Guess no on native Windows. 126 # Guess no on native Windows.
123 mingw* | windows*) 127 mingw* | windows*)
124 gl_cv_func_nanosleep='guessing no' ;; 128 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 @@
1# serial 37 1# serial 38
2 2
3# Copyright (C) 1996-1997, 1999-2007, 2009-2024 Free Software Foundation, Inc. 3# Copyright (C) 1996-1997, 1999-2007, 2009-2024 Free Software Foundation, Inc.
4# 4#
@@ -16,7 +16,4 @@ AC_DEFUN([gl_FUNC_GNU_STRFTIME],
16 AC_REQUIRE([AC_STRUCT_TIMEZONE]) 16 AC_REQUIRE([AC_STRUCT_TIMEZONE])
17 17
18 AC_REQUIRE([gl_TM_GMTOFF]) 18 AC_REQUIRE([gl_TM_GMTOFF])
19
20 AC_DEFINE([my_strftime], [nstrftime],
21 [Define to the name of the strftime replacement function.])
22]) 19])
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 @@
5# gives unlimited permission to copy and/or distribute it, 5# gives unlimited permission to copy and/or distribute it,
6# with or without modifications, as long as this notice is preserved. 6# with or without modifications, as long as this notice is preserved.
7 7
8# serial 38 8# serial 39
9 9
10# Written by Paul Eggert. 10# Written by Paul Eggert.
11 11
@@ -132,6 +132,7 @@ AC_DEFUN([gl_STRING_H_DEFAULTS],
132 REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR]) 132 REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR])
133 REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM]) 133 REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM])
134 REPLACE_MEMPCPY=0; AC_SUBST([REPLACE_MEMPCPY]) 134 REPLACE_MEMPCPY=0; AC_SUBST([REPLACE_MEMPCPY])
135 REPLACE_MEMSET_EXPLICIT=0; AC_SUBST([REPLACE_MEMSET_EXPLICIT])
135 REPLACE_STPCPY=0; AC_SUBST([REPLACE_STPCPY]) 136 REPLACE_STPCPY=0; AC_SUBST([REPLACE_STPCPY])
136 REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY]) 137 REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY])
137 REPLACE_STRCHRNUL=0; AC_SUBST([REPLACE_STRCHRNUL]) 138 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 @@
2 2
3# Copyright (C) 2000-2001, 2003-2007, 2009-2024 Free Software Foundation, Inc. 3# Copyright (C) 2000-2001, 2003-2007, 2009-2024 Free Software Foundation, Inc.
4 4
5# serial 24 5# serial 25
6 6
7# This file is free software; the Free Software Foundation 7# This file is free software; the Free Software Foundation
8# gives unlimited permission to copy and/or distribute it, 8# gives unlimited permission to copy and/or distribute it,
@@ -175,5 +175,6 @@ AC_DEFUN([gl_TIME_H_DEFAULTS],
175 REPLACE_TIME=0; AC_SUBST([REPLACE_TIME]) 175 REPLACE_TIME=0; AC_SUBST([REPLACE_TIME])
176 REPLACE_TIMEGM=0; AC_SUBST([REPLACE_TIMEGM]) 176 REPLACE_TIMEGM=0; AC_SUBST([REPLACE_TIMEGM])
177 REPLACE_TIMESPEC_GET=0; AC_SUBST([REPLACE_TIMESPEC_GET]) 177 REPLACE_TIMESPEC_GET=0; AC_SUBST([REPLACE_TIMESPEC_GET])
178 REPLACE_TIMESPEC_GETRES=0; AC_SUBST([REPLACE_TIMESPEC_GETRES])
178 REPLACE_TZSET=0; AC_SUBST([REPLACE_TZSET]) 179 REPLACE_TZSET=0; AC_SUBST([REPLACE_TZSET])
179]) 180])
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
3dnl gives unlimited permission to copy and/or distribute it, 3dnl gives unlimited permission to copy and/or distribute it,
4dnl with or without modifications, as long as this notice is preserved. 4dnl with or without modifications, as long as this notice is preserved.
5 5
6dnl serial 15 6dnl serial 16
7 7
8AC_DEFUN([gl_UTIMENS], 8AC_DEFUN([gl_UTIMENS],
9[ 9[
@@ -36,12 +36,13 @@ AC_DEFUN([gl_UTIMENS],
36 [gl_cv_func_futimesat_works=yes], 36 [gl_cv_func_futimesat_works=yes],
37 [gl_cv_func_futimesat_works=no], 37 [gl_cv_func_futimesat_works=no],
38 [case "$host_os" in 38 [case "$host_os" in
39 # Guess yes on Linux systems. 39 # Guess yes on Linux systems
40 linux-* | linux) gl_cv_func_futimesat_works="guessing yes" ;; 40 # and on systems that emulate the Linux system calls.
41 # Guess yes on glibc systems. 41 linux* | midipix*) gl_cv_func_futimesat_works="guessing yes" ;;
42 *-gnu*) gl_cv_func_futimesat_works="guessing yes" ;; 42 # Guess yes on glibc systems.
43 # If we don't know, obey --enable-cross-guesses. 43 *-gnu*) gl_cv_func_futimesat_works="guessing yes" ;;
44 *) gl_cv_func_futimesat_works="$gl_cross_guess_normal" ;; 44 # If we don't know, obey --enable-cross-guesses.
45 *) gl_cv_func_futimesat_works="$gl_cross_guess_normal" ;;
45 esac 46 esac
46 ]) 47 ])
47 rm -f conftest.file]) 48 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 @@
1# serial 11 1# serial 12
2# See if we need to provide utimensat replacement. 2# See if we need to provide utimensat replacement.
3 3
4dnl Copyright (C) 2009-2024 Free Software Foundation, Inc. 4dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
@@ -83,6 +83,9 @@ AC_DEFUN([gl_FUNC_UTIMENSAT],
83 # Guess yes on Linux or glibc systems. 83 # Guess yes on Linux or glibc systems.
84 linux-* | linux | *-gnu* | gnu*) 84 linux-* | linux | *-gnu* | gnu*)
85 gl_cv_func_utimensat_works="guessing yes" ;; 85 gl_cv_func_utimensat_works="guessing yes" ;;
86 # Guess yes on systems that emulate the Linux system calls.
87 midipix*)
88 gl_cv_func_utimensat_works="guessing yes" ;;
86 # Guess 'nearly' on AIX. 89 # Guess 'nearly' on AIX.
87 aix*) 90 aix*)
88 gl_cv_func_utimensat_works="guessing nearly" ;; 91 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/>. */
38#include <string.h> /* strlen */ 38#include <string.h> /* strlen */
39#include <ctype.h> /* isspace, isalpha */ 39#include <ctype.h> /* isspace, isalpha */
40 40
41/* UCRT has a C99-compatible snprintf, and _snprintf is defined inline
42 in stdio.h, which we don't want to include here. Since the
43 differences in behavior between snprintf and _snprintf don't matter
44 in this file, we take the easy way out. */
45#ifdef _UCRT
46# define _snprintf snprintf
47#endif
48
41/* We don't want to include stdio.h because we are already duplicating 49/* We don't want to include stdio.h because we are already duplicating
42 lots of it here */ 50 lots of it here */
43extern int _snprintf (char *buffer, size_t count, const char *format, ...); 51extern 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
46OMIT_GNULIB_MODULE_at-internal = true 46OMIT_GNULIB_MODULE_at-internal = true
47OMIT_GNULIB_MODULE_canonicalize-lgpl = true 47OMIT_GNULIB_MODULE_canonicalize-lgpl = true
48OMIT_GNULIB_MODULE_careadlinkat = true 48OMIT_GNULIB_MODULE_careadlinkat = true
49OMIT_GNULIB_MODULE_copy-file-range = true
49OMIT_GNULIB_MODULE_dirent = true 50OMIT_GNULIB_MODULE_dirent = true
50OMIT_GNULIB_MODULE_dirfd = true 51OMIT_GNULIB_MODULE_dirfd = true
51OMIT_GNULIB_MODULE_fchmodat = true 52OMIT_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
360 object_ct total_intervals, total_free_intervals; 360 object_ct total_intervals, total_free_intervals;
361 object_ct total_buffers; 361 object_ct total_buffers;
362 362
363 /* Size of the ancillary arrays of live hash-table objects. 363 /* Size of the ancillary arrays of live hash-table and obarray objects.
364 The objects themselves are not included (counted as vectors above). */ 364 The objects themselves are not included (counted as vectors above). */
365 byte_ct total_hash_table_bytes; 365 byte_ct total_hash_table_bytes;
366} gcstat; 366} gcstat;
367 367
368/* Total size of ancillary arrays of all allocated hash-table objects, 368/* Total size of ancillary arrays of all allocated hash-table and obarray
369 both dead and alive. This number is always kept up-to-date. */ 369 objects, both dead and alive. This number is always kept up-to-date. */
370static ptrdiff_t hash_table_allocated_bytes = 0; 370static ptrdiff_t hash_table_allocated_bytes = 0;
371 371
372/* Points to memory space allocated as "spare", to be freed if we run 372/* Points to memory space allocated as "spare", to be freed if we run
@@ -3443,7 +3443,7 @@ cleanup_vector (struct Lisp_Vector *vector)
3443 struct Lisp_Hash_Table *h = PSEUDOVEC_STRUCT (vector, Lisp_Hash_Table); 3443 struct Lisp_Hash_Table *h = PSEUDOVEC_STRUCT (vector, Lisp_Hash_Table);
3444 if (h->table_size > 0) 3444 if (h->table_size > 0)
3445 { 3445 {
3446 eassert (h->index_size > 1); 3446 eassert (h->index_bits > 0);
3447 xfree (h->index); 3447 xfree (h->index);
3448 xfree (h->key_and_value); 3448 xfree (h->key_and_value);
3449 xfree (h->next); 3449 xfree (h->next);
@@ -3451,10 +3451,19 @@ cleanup_vector (struct Lisp_Vector *vector)
3451 ptrdiff_t bytes = (h->table_size * (2 * sizeof *h->key_and_value 3451 ptrdiff_t bytes = (h->table_size * (2 * sizeof *h->key_and_value
3452 + sizeof *h->hash 3452 + sizeof *h->hash
3453 + sizeof *h->next) 3453 + sizeof *h->next)
3454 + h->index_size * sizeof *h->index); 3454 + hash_table_index_size (h) * sizeof *h->index);
3455 hash_table_allocated_bytes -= bytes; 3455 hash_table_allocated_bytes -= bytes;
3456 } 3456 }
3457 } 3457 }
3458 break;
3459 case PVEC_OBARRAY:
3460 {
3461 struct Lisp_Obarray *o = PSEUDOVEC_STRUCT (vector, Lisp_Obarray);
3462 xfree (o->buckets);
3463 ptrdiff_t bytes = obarray_size (o) * sizeof *o->buckets;
3464 hash_table_allocated_bytes -= bytes;
3465 }
3466 break;
3458 /* Keep the switch exhaustive. */ 3467 /* Keep the switch exhaustive. */
3459 case PVEC_NORMAL_VECTOR: 3468 case PVEC_NORMAL_VECTOR:
3460 case PVEC_FREE: 3469 case PVEC_FREE:
@@ -3951,7 +3960,7 @@ Its value is void, and its function definition and property list are nil. */)
3951 if (symbol_free_list) 3960 if (symbol_free_list)
3952 { 3961 {
3953 ASAN_UNPOISON_SYMBOL (symbol_free_list); 3962 ASAN_UNPOISON_SYMBOL (symbol_free_list);
3954 XSETSYMBOL (val, symbol_free_list); 3963 val = make_lisp_symbol (symbol_free_list);
3955 symbol_free_list = symbol_free_list->u.s.next; 3964 symbol_free_list = symbol_free_list->u.s.next;
3956 } 3965 }
3957 else 3966 else
@@ -3967,7 +3976,7 @@ Its value is void, and its function definition and property list are nil. */)
3967 } 3976 }
3968 3977
3969 ASAN_UNPOISON_SYMBOL (&symbol_block->symbols[symbol_block_index]); 3978 ASAN_UNPOISON_SYMBOL (&symbol_block->symbols[symbol_block_index]);
3970 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]); 3979 val = make_lisp_symbol (&symbol_block->symbols[symbol_block_index]);
3971 symbol_block_index++; 3980 symbol_block_index++;
3972 } 3981 }
3973 3982
@@ -5632,7 +5641,8 @@ valid_lisp_object_p (Lisp_Object obj)
5632 return 0; 5641 return 0;
5633} 5642}
5634 5643
5635/* Like xmalloc, but makes allocation count toward the total consing. 5644/* Like xmalloc, but makes allocation count toward the total consing
5645 and hash table or obarray usage.
5636 Return NULL for a zero-sized allocation. */ 5646 Return NULL for a zero-sized allocation. */
5637void * 5647void *
5638hash_table_alloc_bytes (ptrdiff_t nbytes) 5648hash_table_alloc_bytes (ptrdiff_t nbytes)
@@ -5959,7 +5969,8 @@ purecopy_hash_table (struct Lisp_Hash_Table *table)
5959 for (ptrdiff_t i = 0; i < nvalues; i++) 5969 for (ptrdiff_t i = 0; i < nvalues; i++)
5960 pure->key_and_value[i] = purecopy (table->key_and_value[i]); 5970 pure->key_and_value[i] = purecopy (table->key_and_value[i]);
5961 5971
5962 ptrdiff_t index_bytes = table->index_size * sizeof *table->index; 5972 ptrdiff_t index_bytes = hash_table_index_size (table)
5973 * sizeof *table->index;
5963 pure->index = pure_alloc (index_bytes, -(int)sizeof *table->index); 5974 pure->index = pure_alloc (index_bytes, -(int)sizeof *table->index);
5964 memcpy (pure->index, table->index, index_bytes); 5975 memcpy (pure->index, table->index, index_bytes);
5965 } 5976 }
@@ -6033,8 +6044,7 @@ purecopy (Lisp_Object obj)
6033 return obj; /* Don't hash cons it. */ 6044 return obj; /* Don't hash cons it. */
6034 } 6045 }
6035 6046
6036 struct Lisp_Hash_Table *h = purecopy_hash_table (table); 6047 obj = make_lisp_hash_table (purecopy_hash_table (table));
6037 XSET_HASH_TABLE (obj, h);
6038 } 6048 }
6039 else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj)) 6049 else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj))
6040 { 6050 {
@@ -7310,6 +7320,14 @@ process_mark_stack (ptrdiff_t base_sp)
7310 break; 7320 break;
7311 } 7321 }
7312 7322
7323 case PVEC_OBARRAY:
7324 {
7325 struct Lisp_Obarray *o = (struct Lisp_Obarray *)ptr;
7326 set_vector_marked (ptr);
7327 mark_stack_push_values (o->buckets, obarray_size (o));
7328 break;
7329 }
7330
7313 case PVEC_CHAR_TABLE: 7331 case PVEC_CHAR_TABLE:
7314 case PVEC_SUB_CHAR_TABLE: 7332 case PVEC_SUB_CHAR_TABLE:
7315 mark_char_table (ptr, (enum pvec_type) pvectype); 7333 mark_char_table (ptr, (enum pvec_type) pvectype);
@@ -7380,12 +7398,8 @@ process_mark_stack (ptrdiff_t base_sp)
7380 mark_stack_push_value (SYMBOL_VAL (ptr)); 7398 mark_stack_push_value (SYMBOL_VAL (ptr));
7381 break; 7399 break;
7382 case SYMBOL_VARALIAS: 7400 case SYMBOL_VARALIAS:
7383 { 7401 mark_stack_push_value (make_lisp_symbol (SYMBOL_ALIAS (ptr)));
7384 Lisp_Object tem; 7402 break;
7385 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
7386 mark_stack_push_value (tem);
7387 break;
7388 }
7389 case SYMBOL_LOCALIZED: 7403 case SYMBOL_LOCALIZED:
7390 { 7404 {
7391 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr); 7405 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/>. */
40 40
41#include <sys/param.h> 41#include <sys/param.h>
42#include <sys/stat.h> 42#include <sys/stat.h>
43#include <sys/select.h>
43 44
44/* Old NDK versions lack MIN and MAX. */ 45/* Old NDK versions lack MIN and MAX. */
45#include <minmax.h> 46#include <minmax.h>
@@ -112,6 +113,8 @@ struct android_emacs_window
112 jmethodID define_cursor; 113 jmethodID define_cursor;
113 jmethodID damage_rect; 114 jmethodID damage_rect;
114 jmethodID recreate_activity; 115 jmethodID recreate_activity;
116 jmethodID clear_window;
117 jmethodID clear_area;
115}; 118};
116 119
117struct android_emacs_cursor 120struct android_emacs_cursor
@@ -152,6 +155,13 @@ static char *android_files_dir;
152/* The Java environment being used for the main thread. */ 155/* The Java environment being used for the main thread. */
153JNIEnv *android_java_env; 156JNIEnv *android_java_env;
154 157
158#ifdef THREADS_ENABLED
159
160/* The Java VM new threads attach to. */
161JavaVM *android_jvm;
162
163#endif /* THREADS_ENABLED */
164
155/* The EmacsGC class. */ 165/* The EmacsGC class. */
156static jclass emacs_gc_class; 166static jclass emacs_gc_class;
157 167
@@ -496,6 +506,9 @@ android_handle_sigusr1 (int sig, siginfo_t *siginfo, void *arg)
496 This should ideally be defined further down. */ 506 This should ideally be defined further down. */
497static sem_t android_query_sem; 507static sem_t android_query_sem;
498 508
509/* ID of the Emacs thread. */
510static pthread_t main_thread_id;
511
499/* Set up the global event queue by initializing the mutex and two 512/* Set up the global event queue by initializing the mutex and two
500 condition variables, and the linked list of events. This must be 513 condition variables, and the linked list of events. This must be
501 called before starting the Emacs thread. Also, initialize the 514 called before starting the Emacs thread. Also, initialize the
@@ -531,6 +544,8 @@ android_init_events (void)
531 event_queue.events.next = &event_queue.events; 544 event_queue.events.next = &event_queue.events;
532 event_queue.events.last = &event_queue.events; 545 event_queue.events.last = &event_queue.events;
533 546
547 main_thread_id = pthread_self ();
548
534#if __ANDROID_API__ >= 16 549#if __ANDROID_API__ >= 16
535 550
536 /* Before starting the select thread, make sure the disposition for 551 /* Before starting the select thread, make sure the disposition for
@@ -579,10 +594,6 @@ android_pending (void)
579 return i; 594 return i;
580} 595}
581 596
582/* Forward declaration. */
583
584static void android_check_query (void);
585
586/* Wait for events to become available synchronously. Return once an 597/* Wait for events to become available synchronously. Return once an
587 event arrives. Also, reply to the UI thread whenever it requires a 598 event arrives. Also, reply to the UI thread whenever it requires a
588 response. */ 599 response. */
@@ -732,6 +743,12 @@ android_select (int nfds, fd_set *readfds, fd_set *writefds,
732 static char byte; 743 static char byte;
733#endif 744#endif
734 745
746#ifdef THREADS_ENABLED
747 if (!pthread_equal (pthread_self (), main_thread_id))
748 return pselect (nfds, readfds, writefds, exceptfds, timeout,
749 NULL);
750#endif /* THREADS_ENABLED */
751
735 /* Since Emacs is reading keyboard input again, signify that queries 752 /* Since Emacs is reading keyboard input again, signify that queries
736 from input methods are no longer ``urgent''. */ 753 from input methods are no longer ``urgent''. */
737 754
@@ -837,9 +854,11 @@ android_select (int nfds, fd_set *readfds, fd_set *writefds,
837 if (nfds_return < 0) 854 if (nfds_return < 0)
838 errno = EINTR; 855 errno = EINTR;
839 856
857#ifndef THREADS_ENABLED
840 /* Now check for and run anything the UI thread wants to run in the 858 /* Now check for and run anything the UI thread wants to run in the
841 main thread. */ 859 main thread. */
842 android_check_query (); 860 android_check_query ();
861#endif /* THREADS_ENABLED */
843 862
844 return nfds_return; 863 return nfds_return;
845} 864}
@@ -1315,12 +1334,17 @@ NATIVE_NAME (setEmacsParams) (JNIEnv *env, jobject object,
1315 const char *java_string; 1334 const char *java_string;
1316 struct stat statb; 1335 struct stat statb;
1317 1336
1337#ifdef THREADS_ENABLED
1338 /* Save the Java VM. */
1339 if ((*env)->GetJavaVM (env, &android_jvm))
1340 emacs_abort ();
1341#endif /* THREADS_ENABLED */
1342
1318 /* Set the Android API level early, as it is used by 1343 /* Set the Android API level early, as it is used by
1319 `android_vfs_init'. */ 1344 `android_vfs_init'. */
1320 android_api_level = api_level; 1345 android_api_level = api_level;
1321 1346
1322 /* This function should only be called from the main thread. */ 1347 /* This function should only be called from the main thread. */
1323
1324 android_pixel_density_x = pixel_density_x; 1348 android_pixel_density_x = pixel_density_x;
1325 android_pixel_density_y = pixel_density_y; 1349 android_pixel_density_y = pixel_density_y;
1326 android_scaled_pixel_density = scaled_density; 1350 android_scaled_pixel_density = scaled_density;
@@ -1583,16 +1607,13 @@ android_init_emacs_service (void)
1583 FIND_METHOD (draw_point, "drawPoint", 1607 FIND_METHOD (draw_point, "drawPoint",
1584 "(Lorg/gnu/emacs/EmacsDrawable;" 1608 "(Lorg/gnu/emacs/EmacsDrawable;"
1585 "Lorg/gnu/emacs/EmacsGC;II)V"); 1609 "Lorg/gnu/emacs/EmacsGC;II)V");
1586 FIND_METHOD (clear_window, "clearWindow",
1587 "(Lorg/gnu/emacs/EmacsWindow;)V");
1588 FIND_METHOD (clear_area, "clearArea",
1589 "(Lorg/gnu/emacs/EmacsWindow;IIII)V");
1590 FIND_METHOD (ring_bell, "ringBell", "(I)V"); 1610 FIND_METHOD (ring_bell, "ringBell", "(I)V");
1591 FIND_METHOD (query_tree, "queryTree", 1611 FIND_METHOD (query_tree, "queryTree",
1592 "(Lorg/gnu/emacs/EmacsWindow;)[S"); 1612 "(Lorg/gnu/emacs/EmacsWindow;)[S");
1593 FIND_METHOD (get_screen_width, "getScreenWidth", "(Z)I"); 1613 FIND_METHOD (get_screen_width, "getScreenWidth", "(Z)I");
1594 FIND_METHOD (get_screen_height, "getScreenHeight", "(Z)I"); 1614 FIND_METHOD (get_screen_height, "getScreenHeight", "(Z)I");
1595 FIND_METHOD (detect_mouse, "detectMouse", "()Z"); 1615 FIND_METHOD (detect_mouse, "detectMouse", "()Z");
1616 FIND_METHOD (detect_keyboard, "detectKeyboard", "()Z");
1596 FIND_METHOD (name_keysym, "nameKeysym", "(I)Ljava/lang/String;"); 1617 FIND_METHOD (name_keysym, "nameKeysym", "(I)Ljava/lang/String;");
1597 FIND_METHOD (browse_url, "browseUrl", "(Ljava/lang/String;Z)" 1618 FIND_METHOD (browse_url, "browseUrl", "(Ljava/lang/String;Z)"
1598 "Ljava/lang/String;"); 1619 "Ljava/lang/String;");
@@ -1809,6 +1830,8 @@ android_init_emacs_window (void)
1809 android_damage_window. */ 1830 android_damage_window. */
1810 FIND_METHOD (damage_rect, "damageRect", "(IIII)V"); 1831 FIND_METHOD (damage_rect, "damageRect", "(IIII)V");
1811 FIND_METHOD (recreate_activity, "recreateActivity", "()V"); 1832 FIND_METHOD (recreate_activity, "recreateActivity", "()V");
1833 FIND_METHOD (clear_window, "clearWindow", "()V");
1834 FIND_METHOD (clear_area, "clearArea", "(IIII)V");
1812#undef FIND_METHOD 1835#undef FIND_METHOD
1813} 1836}
1814 1837
@@ -2496,6 +2519,8 @@ JNIEXPORT jboolean JNICALL
2496NATIVE_NAME (shouldForwardMultimediaButtons) (JNIEnv *env, 2519NATIVE_NAME (shouldForwardMultimediaButtons) (JNIEnv *env,
2497 jobject object) 2520 jobject object)
2498{ 2521{
2522 JNI_STACK_ALIGNMENT_PROLOGUE;
2523
2499 /* Yes, android_pass_multimedia_buttons_to_system is being 2524 /* Yes, android_pass_multimedia_buttons_to_system is being
2500 read from the UI thread. */ 2525 read from the UI thread. */
2501 return !android_pass_multimedia_buttons_to_system; 2526 return !android_pass_multimedia_buttons_to_system;
@@ -2504,6 +2529,8 @@ NATIVE_NAME (shouldForwardMultimediaButtons) (JNIEnv *env,
2504JNIEXPORT jboolean JNICALL 2529JNIEXPORT jboolean JNICALL
2505NATIVE_NAME (shouldForwardCtrlSpace) (JNIEnv *env, jobject object) 2530NATIVE_NAME (shouldForwardCtrlSpace) (JNIEnv *env, jobject object)
2506{ 2531{
2532 JNI_STACK_ALIGNMENT_PROLOGUE;
2533
2507 return !android_intercept_control_space; 2534 return !android_intercept_control_space;
2508} 2535}
2509 2536
@@ -2607,6 +2634,8 @@ JNIEXPORT void JNICALL
2607NATIVE_NAME (notifyPixelsChanged) (JNIEnv *env, jobject object, 2634NATIVE_NAME (notifyPixelsChanged) (JNIEnv *env, jobject object,
2608 jobject bitmap) 2635 jobject bitmap)
2609{ 2636{
2637 JNI_STACK_ALIGNMENT_PROLOGUE;
2638
2610 void *data; 2639 void *data;
2611 2640
2612 /* Lock and unlock the bitmap. This calls 2641 /* Lock and unlock the bitmap. This calls
@@ -2660,6 +2689,8 @@ NATIVE_NAME (answerQuerySpin) (JNIEnv *env, jobject object)
2660JNIEXPORT void JNICALL 2689JNIEXPORT void JNICALL
2661NATIVE_NAME (setupSystemThread) (void) 2690NATIVE_NAME (setupSystemThread) (void)
2662{ 2691{
2692 JNI_STACK_ALIGNMENT_PROLOGUE;
2693
2663 sigset_t sigset; 2694 sigset_t sigset;
2664 2695
2665 /* Block everything except for SIGSEGV and SIGBUS; those two are 2696 /* Block everything except for SIGSEGV and SIGBUS; those two are
@@ -3408,10 +3439,9 @@ android_clear_window (android_window handle)
3408 window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); 3439 window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
3409 3440
3410 (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, 3441 (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
3411 emacs_service, 3442 window,
3412 service_class.class, 3443 window_class.class,
3413 service_class.clear_window, 3444 window_class.clear_window);
3414 window);
3415 android_exception_check (); 3445 android_exception_check ();
3416} 3446}
3417 3447
@@ -4722,10 +4752,10 @@ android_clear_area (android_window handle, int x, int y,
4722 window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); 4752 window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
4723 4753
4724 (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, 4754 (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
4725 emacs_service, 4755 window,
4726 service_class.class, 4756 window_class.class,
4727 service_class.clear_area, 4757 window_class.clear_area,
4728 window, (jint) x, (jint) y, 4758 (jint) x, (jint) y,
4729 (jint) width, (jint) height); 4759 (jint) width, (jint) height);
4730} 4760}
4731 4761
@@ -5626,6 +5656,21 @@ android_detect_mouse (void)
5626 return rc; 5656 return rc;
5627} 5657}
5628 5658
5659bool
5660android_detect_keyboard (void)
5661{
5662 bool rc;
5663 jmethodID method;
5664
5665 method = service_class.detect_keyboard;
5666 rc = (*android_java_env)->CallNonvirtualBooleanMethod (android_java_env,
5667 emacs_service,
5668 service_class.class,
5669 method);
5670 android_exception_check ();
5671 return rc;
5672}
5673
5629void 5674void
5630android_set_dont_focus_on_map (android_window handle, 5675android_set_dont_focus_on_map (android_window handle,
5631 bool no_focus_on_map) 5676 bool no_focus_on_map)
@@ -6701,7 +6746,7 @@ static void *android_query_context;
6701/* Run any function that the UI thread has asked to run, and then 6746/* Run any function that the UI thread has asked to run, and then
6702 signal its completion. */ 6747 signal its completion. */
6703 6748
6704static void 6749void
6705android_check_query (void) 6750android_check_query (void)
6706{ 6751{
6707 void (*proc) (void *); 6752 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/>. */
24 a table of function pointers. */ 24 a table of function pointers. */
25 25
26#ifndef _ANDROID_H_ 26#ifndef _ANDROID_H_
27#define _ANDROID_H_
28
27#ifndef ANDROID_STUBIFY 29#ifndef ANDROID_STUBIFY
28#include <jni.h> 30#include <jni.h>
29#include <pwd.h> 31#include <pwd.h>
@@ -103,6 +105,7 @@ extern int android_get_screen_height (void);
103extern int android_get_mm_width (void); 105extern int android_get_mm_width (void);
104extern int android_get_mm_height (void); 106extern int android_get_mm_height (void);
105extern bool android_detect_mouse (void); 107extern bool android_detect_mouse (void);
108extern bool android_detect_keyboard (void);
106 109
107extern void android_set_dont_focus_on_map (android_window, bool); 110extern void android_set_dont_focus_on_map (android_window, bool);
108extern void android_set_dont_accept_focus (android_window, bool); 111extern void android_set_dont_accept_focus (android_window, bool);
@@ -225,6 +228,7 @@ extern void android_display_toast (const char *);
225 228
226/* Event loop functions. */ 229/* Event loop functions. */
227 230
231extern void android_check_query (void);
228extern void android_check_query_urgent (void); 232extern void android_check_query_urgent (void);
229extern int android_run_in_emacs_thread (void (*) (void *), void *); 233extern int android_run_in_emacs_thread (void (*) (void *), void *);
230extern void android_write_event (union android_event *); 234extern void android_write_event (union android_event *);
@@ -265,6 +269,7 @@ struct android_emacs_service
265 jmethodID get_screen_width; 269 jmethodID get_screen_width;
266 jmethodID get_screen_height; 270 jmethodID get_screen_height;
267 jmethodID detect_mouse; 271 jmethodID detect_mouse;
272 jmethodID detect_keyboard;
268 jmethodID name_keysym; 273 jmethodID name_keysym;
269 jmethodID browse_url; 274 jmethodID browse_url;
270 jmethodID restart_emacs; 275 jmethodID restart_emacs;
@@ -297,6 +302,10 @@ struct android_emacs_service
297 302
298extern JNIEnv *android_java_env; 303extern JNIEnv *android_java_env;
299 304
305#ifdef THREADS_ENABLED
306extern JavaVM *android_jvm;
307#endif /* THREADS_ENABLED */
308
300/* The EmacsService object. */ 309/* The EmacsService object. */
301extern jobject emacs_service; 310extern jobject emacs_service;
302 311
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,
2287 2287
2288 goto start_timer; 2288 goto start_timer;
2289 } 2289 }
2290 else if (tooltip_reuse_hidden_frame && BASE_EQ (frame, tip_last_frame))
2291 {
2292 bool delete = false;
2293 Lisp_Object tail, elt, parm, last;
2294
2295 /* Check if every parameter in PARMS has the same value in
2296 tip_last_parms. This may destruct tip_last_parms which,
2297 however, will be recreated below. */
2298 for (tail = parms; CONSP (tail); tail = XCDR (tail))
2299 {
2300 elt = XCAR (tail);
2301 parm = CAR (elt);
2302 /* The left, top, right and bottom parameters are handled
2303 by compute_tip_xy so they can be ignored here. */
2304 if (!EQ (parm, Qleft) && !EQ (parm, Qtop)
2305 && !EQ (parm, Qright) && !EQ (parm, Qbottom))
2306 {
2307 last = Fassq (parm, tip_last_parms);
2308 if (NILP (Fequal (CDR (elt), CDR (last))))
2309 {
2310 /* We lost, delete the old tooltip. */
2311 delete = true;
2312 break;
2313 }
2314 else
2315 tip_last_parms
2316 = call2 (Qassq_delete_all, parm, tip_last_parms);
2317 }
2318 else
2319 tip_last_parms
2320 = call2 (Qassq_delete_all, parm, tip_last_parms);
2321 }
2322
2323 /* Now check if every parameter in what is left of
2324 tip_last_parms with a non-nil value has an association in
2325 PARMS. */
2326 for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail))
2327 {
2328 elt = XCAR (tail);
2329 parm = CAR (elt);
2330 if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright)
2331 && !EQ (parm, Qbottom) && !NILP (CDR (elt)))
2332 {
2333 /* We lost, delete the old tooltip. */
2334 delete = true;
2335 break;
2336 }
2337 }
2338
2339 android_hide_tip (delete);
2340 }
2290 else 2341 else
2291 android_hide_tip (true); 2342 android_hide_tip (true);
2292 } 2343 }
@@ -2453,7 +2504,7 @@ DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
2453#endif /* 0 */ 2504#endif /* 0 */
2454 return Qnil; 2505 return Qnil;
2455#else /* !ANDROID_STUBIFY */ 2506#else /* !ANDROID_STUBIFY */
2456 return android_hide_tip (true); 2507 return android_hide_tip (!tooltip_reuse_hidden_frame);
2457#endif /* ANDROID_STUBIFY */ 2508#endif /* ANDROID_STUBIFY */
2458} 2509}
2459 2510
@@ -2476,6 +2527,25 @@ there is no mouse. */)
2476#endif 2527#endif
2477} 2528}
2478 2529
2530DEFUN ("android-detect-keyboard", Fandroid_detect_keyboard,
2531 Sandroid_detect_keyboard, 0, 0, 0,
2532 doc: /* Return whether a keyboard is connected.
2533Return non-nil if a key is connected to this computer, or nil
2534if there is no keyboard. */)
2535 (void)
2536{
2537#ifndef ANDROID_STUBIFY
2538 /* If no display connection is present, just return nil. */
2539
2540 if (!android_init_gui)
2541 return Qnil;
2542
2543 return android_detect_keyboard () ? Qt : Qnil;
2544#else /* ANDROID_STUBIFY */
2545 return Qt;
2546#endif /* ANDROID_STUBIFY */
2547}
2548
2479DEFUN ("android-toggle-on-screen-keyboard", 2549DEFUN ("android-toggle-on-screen-keyboard",
2480 Fandroid_toggle_on_screen_keyboard, 2550 Fandroid_toggle_on_screen_keyboard,
2481 Sandroid_toggle_on_screen_keyboard, 2, 2, 0, 2551 Sandroid_toggle_on_screen_keyboard, 2, 2, 0,
@@ -3197,6 +3267,10 @@ syms_of_androidfns_for_pdumper (void)
3197 jstring string; 3267 jstring string;
3198 Lisp_Object language, country, script, variant; 3268 Lisp_Object language, country, script, variant;
3199 const char *data; 3269 const char *data;
3270 FILE *fd;
3271 char *line;
3272 size_t size;
3273 long pid;
3200 3274
3201 /* Find the Locale class. */ 3275 /* Find the Locale class. */
3202 3276
@@ -3367,6 +3441,35 @@ syms_of_androidfns_for_pdumper (void)
3367 3441
3368 /* Set Vandroid_os_language. */ 3442 /* Set Vandroid_os_language. */
3369 Vandroid_os_language = list4 (language, country, script, variant); 3443 Vandroid_os_language = list4 (language, country, script, variant);
3444
3445 /* Detect whether Emacs is running under libloader.so or another
3446 process tracing mechanism, and disable `android_use_exec_loader' if
3447 so, leaving subprocesses started by Emacs to the care of that
3448 loader instance. */
3449
3450 if (android_get_current_api_level () >= 29) /* Q */
3451 {
3452 fd = fopen ("/proc/self/status", "r");
3453 if (!fd)
3454 return;
3455
3456 line = NULL;
3457 while (getline (&line, &size, fd) != -1)
3458 {
3459 if (strncmp (line, "TracerPid:", sizeof "TracerPid:" - 1))
3460 continue;
3461
3462 pid = atol (line + sizeof "TracerPid:" - 1);
3463
3464 if (pid)
3465 android_use_exec_loader = false;
3466
3467 break;
3468 }
3469
3470 free (line);
3471 fclose (fd);
3472 }
3370} 3473}
3371 3474
3372#endif /* ANDROID_STUBIFY */ 3475#endif /* ANDROID_STUBIFY */
@@ -3560,6 +3663,7 @@ language to be US English if LANGUAGE is empty. */);
3560 defsubr (&Sx_show_tip); 3663 defsubr (&Sx_show_tip);
3561 defsubr (&Sx_hide_tip); 3664 defsubr (&Sx_hide_tip);
3562 defsubr (&Sandroid_detect_mouse); 3665 defsubr (&Sandroid_detect_mouse);
3666 defsubr (&Sandroid_detect_keyboard);
3563 defsubr (&Sandroid_toggle_on_screen_keyboard); 3667 defsubr (&Sandroid_toggle_on_screen_keyboard);
3564 defsubr (&Sx_server_vendor); 3668 defsubr (&Sx_server_vendor);
3565 defsubr (&Sx_server_version); 3669 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,
237 return rc ? Qt : Qnil; 237 return rc ? Qt : Qnil;
238} 238}
239 239
240DEFUN ("android-browse-url", Fandroid_browse_url, 240DEFUN ("android-browse-url-internal", Fandroid_browse_url_internal,
241 Sandroid_browse_url, 1, 2, 0, 241 Sandroid_browse_url_internal, 1, 2, 0,
242 doc: /* Open URL in an external application. URL should be a 242 doc: /* Open URL in an external application.
243URL-encoded URL with a scheme specified unless SEND is non-nil. 243
244Signal an error upon failure. 244URL should be a URL-encoded URL with a scheme specified unless SEND is
245non-nil. Signal an error upon failure.
245 246
246If SEND is nil, start a program that is able to display the URL, such 247If SEND is nil, start a program that is able to display the URL, such
247as a web browser. Otherwise, try to share URL using programs such as 248as a web browser. Otherwise, try to share URL using programs such as
248email clients. */) 249email clients.
250
251If URL is a file URI, convert it into a `content' address accessible to
252other programs. Files inside the /content or /assets directories cannot
253be opened through such addresses, which this function does not provide
254for. Use `android-browse-url' instead. */)
249 (Lisp_Object url, Lisp_Object send) 255 (Lisp_Object url, Lisp_Object send)
250{ 256{
251 Lisp_Object value; 257 Lisp_Object value;
@@ -803,7 +809,7 @@ syms_of_androidselect (void)
803 defsubr (&Sandroid_set_clipboard); 809 defsubr (&Sandroid_set_clipboard);
804 defsubr (&Sandroid_get_clipboard); 810 defsubr (&Sandroid_get_clipboard);
805 defsubr (&Sandroid_clipboard_exists_p); 811 defsubr (&Sandroid_clipboard_exists_p);
806 defsubr (&Sandroid_browse_url); 812 defsubr (&Sandroid_browse_url_internal);
807 defsubr (&Sandroid_get_clipboard_targets); 813 defsubr (&Sandroid_get_clipboard_targets);
808 defsubr (&Sandroid_get_clipboard_data); 814 defsubr (&Sandroid_get_clipboard_data);
809 815
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,
495 /* Has the mouse moved off the glyph it was on at the last sighting? */ 495 /* Has the mouse moved off the glyph it was on at the last sighting? */
496 r = &dpyinfo->last_mouse_glyph; 496 r = &dpyinfo->last_mouse_glyph;
497 if (frame != dpyinfo->last_mouse_glyph_frame 497 if (frame != dpyinfo->last_mouse_glyph_frame
498 || event->x < r->x || event->x >= r->x + r->width 498 || event->x < r->x || event->x >= r->x + (int) r->width
499 || event->y < r->y || event->y >= r->y + r->height) 499 || event->y < r->y || event->y >= r->y + (int) r->height)
500 { 500 {
501 frame->mouse_moved = true; 501 frame->mouse_moved = true;
502 note_mouse_highlight (frame, event->x, event->y); 502 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)
1018static const char * 1018static const char *
1019android_scan_directory_tree (char *file, size_t *limit_return) 1019android_scan_directory_tree (char *file, size_t *limit_return)
1020{ 1020{
1021 char *token, *saveptr, *copy, *copy1, *start, *max, *limit; 1021 char *token, *saveptr, *copy, *start, *max, *limit;
1022 size_t token_length, ntokens, i; 1022 size_t token_length, ntokens, i, len;
1023 char *tokens[10]; 1023 char *tokens[10];
1024 1024
1025 USE_SAFE_ALLOCA; 1025 USE_SAFE_ALLOCA;
@@ -1031,11 +1031,14 @@ android_scan_directory_tree (char *file, size_t *limit_return)
1031 limit = (char *) directory_tree + directory_tree_size; 1031 limit = (char *) directory_tree + directory_tree_size;
1032 1032
1033 /* Now, split `file' into tokens, with the delimiter being the file 1033 /* Now, split `file' into tokens, with the delimiter being the file
1034 name separator. Look for the file and seek past it. */ 1034 name separator. Look for the file and seek past it. Create a copy
1035 of FILE for the enjoyment of `strtok_r'. */
1035 1036
1036 ntokens = 0; 1037 ntokens = 0;
1037 saveptr = NULL; 1038 saveptr = NULL;
1038 copy = copy1 = xstrdup (file); 1039 len = strlen (file) + 1;
1040 copy = SAFE_ALLOCA (len);
1041 memcpy (copy, file, len);
1039 memset (tokens, 0, sizeof tokens); 1042 memset (tokens, 0, sizeof tokens);
1040 1043
1041 while ((token = strtok_r (copy, "/", &saveptr))) 1044 while ((token = strtok_r (copy, "/", &saveptr)))
@@ -1044,19 +1047,14 @@ android_scan_directory_tree (char *file, size_t *limit_return)
1044 1047
1045 /* Make sure ntokens is within bounds. */ 1048 /* Make sure ntokens is within bounds. */
1046 if (ntokens == ARRAYELTS (tokens)) 1049 if (ntokens == ARRAYELTS (tokens))
1047 { 1050 goto fail;
1048 xfree (copy1);
1049 goto fail;
1050 }
1051 1051
1052 tokens[ntokens] = SAFE_ALLOCA (strlen (token) + 1); 1052 len = strlen (token) + 1;
1053 memcpy (tokens[ntokens], token, strlen (token) + 1); 1053 tokens[ntokens] = SAFE_ALLOCA (len);
1054 memcpy (tokens[ntokens], token, len);
1054 ntokens++; 1055 ntokens++;
1055 } 1056 }
1056 1057
1057 /* Free the copy created for strtok_r. */
1058 xfree (copy1);
1059
1060 /* If there are no tokens, just return the start of the directory 1058 /* If there are no tokens, just return the start of the directory
1061 tree. */ 1059 tree. */
1062 1060
@@ -6319,6 +6317,8 @@ static sem_t saf_completion_sem;
6319JNIEXPORT jint JNICALL 6317JNIEXPORT jint JNICALL
6320NATIVE_NAME (safSyncAndReadInput) (JNIEnv *env, jobject object) 6318NATIVE_NAME (safSyncAndReadInput) (JNIEnv *env, jobject object)
6321{ 6319{
6320 JNI_STACK_ALIGNMENT_PROLOGUE;
6321
6322 while (sem_wait (&saf_completion_sem) < 0) 6322 while (sem_wait (&saf_completion_sem) < 0)
6323 { 6323 {
6324 if (input_blocked_p ()) 6324 if (input_blocked_p ())
@@ -6340,6 +6340,8 @@ NATIVE_NAME (safSyncAndReadInput) (JNIEnv *env, jobject object)
6340JNIEXPORT void JNICALL 6340JNIEXPORT void JNICALL
6341NATIVE_NAME (safSync) (JNIEnv *env, jobject object) 6341NATIVE_NAME (safSync) (JNIEnv *env, jobject object)
6342{ 6342{
6343 JNI_STACK_ALIGNMENT_PROLOGUE;
6344
6343 while (sem_wait (&saf_completion_sem) < 0) 6345 while (sem_wait (&saf_completion_sem) < 0)
6344 process_pending_signals (); 6346 process_pending_signals ();
6345} 6347}
@@ -6347,12 +6349,16 @@ NATIVE_NAME (safSync) (JNIEnv *env, jobject object)
6347JNIEXPORT void JNICALL 6349JNIEXPORT void JNICALL
6348NATIVE_NAME (safPostRequest) (JNIEnv *env, jobject object) 6350NATIVE_NAME (safPostRequest) (JNIEnv *env, jobject object)
6349{ 6351{
6352 JNI_STACK_ALIGNMENT_PROLOGUE;
6353
6350 sem_post (&saf_completion_sem); 6354 sem_post (&saf_completion_sem);
6351} 6355}
6352 6356
6353JNIEXPORT jboolean JNICALL 6357JNIEXPORT jboolean JNICALL
6354NATIVE_NAME (ftruncate) (JNIEnv *env, jobject object, jint fd) 6358NATIVE_NAME (ftruncate) (JNIEnv *env, jobject object, jint fd)
6355{ 6359{
6360 JNI_STACK_ALIGNMENT_PROLOGUE;
6361
6356 if (ftruncate (fd, 0) < 0) 6362 if (ftruncate (fd, 0) < 0)
6357 return false; 6363 return false;
6358 6364
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)
1334 case SYMBOL_LOCALIZED: 1334 case SYMBOL_LOCALIZED:
1335 { /* Look in local_var_alist. */ 1335 { /* Look in local_var_alist. */
1336 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); 1336 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1337 XSETSYMBOL (variable, sym); /* Update In case of aliasing. */ 1337 variable = make_lisp_symbol (sym); /* Update In case of aliasing. */
1338 result = assq_no_quit (variable, BVAR (buf, local_var_alist)); 1338 result = assq_no_quit (variable, BVAR (buf, local_var_alist));
1339 if (!NILP (result)) 1339 if (!NILP (result))
1340 { 1340 {
@@ -3002,7 +3002,7 @@ the normal hook `change-major-mode-hook'. */)
3002 But still return the total number of overlays. 3002 But still return the total number of overlays.
3003*/ 3003*/
3004 3004
3005ptrdiff_t 3005static ptrdiff_t
3006overlays_in (ptrdiff_t beg, ptrdiff_t end, bool extend, 3006overlays_in (ptrdiff_t beg, ptrdiff_t end, bool extend,
3007 Lisp_Object **vec_ptr, ptrdiff_t *len_ptr, 3007 Lisp_Object **vec_ptr, ptrdiff_t *len_ptr,
3008 bool empty, bool trailing, 3008 bool empty, bool trailing,
@@ -3125,56 +3125,38 @@ mouse_face_overlay_overlaps (Lisp_Object overlay)
3125{ 3125{
3126 ptrdiff_t start = OVERLAY_START (overlay); 3126 ptrdiff_t start = OVERLAY_START (overlay);
3127 ptrdiff_t end = OVERLAY_END (overlay); 3127 ptrdiff_t end = OVERLAY_END (overlay);
3128 ptrdiff_t n, i, size; 3128 Lisp_Object tem;
3129 Lisp_Object *v, tem; 3129 struct itree_node *node;
3130 Lisp_Object vbuf[10];
3131 USE_SAFE_ALLOCA;
3132 3130
3133 size = ARRAYELTS (vbuf); 3131 ITREE_FOREACH (node, current_buffer->overlays,
3134 v = vbuf; 3132 start, min (end, ZV) + 1,
3135 n = overlays_in (start, end, 0, &v, &size, true, false, NULL); 3133 ASCENDING)
3136 if (n > size)
3137 { 3134 {
3138 SAFE_NALLOCA (v, 1, n); 3135 if (node->begin < end && node->end > start
3139 overlays_in (start, end, 0, &v, &n, true, false, NULL); 3136 && node->begin < node->end
3137 && !EQ (node->data, overlay)
3138 && (tem = Foverlay_get (overlay, Qmouse_face),
3139 !NILP (tem)))
3140 return true;
3140 } 3141 }
3141 3142 return false;
3142 for (i = 0; i < n; ++i)
3143 if (!EQ (v[i], overlay)
3144 && (tem = Foverlay_get (overlay, Qmouse_face),
3145 !NILP (tem)))
3146 break;
3147
3148 SAFE_FREE ();
3149 return i < n;
3150} 3143}
3151 3144
3152/* Return the value of the 'display-line-numbers-disable' property at 3145/* Return the value of the 'display-line-numbers-disable' property at
3153 EOB, if there's an overlay at ZV with a non-nil value of that property. */ 3146 EOB, if there's an overlay at ZV with a non-nil value of that property. */
3154Lisp_Object 3147bool
3155disable_line_numbers_overlay_at_eob (void) 3148disable_line_numbers_overlay_at_eob (void)
3156{ 3149{
3157 ptrdiff_t n, i, size; 3150 Lisp_Object tem = Qnil;
3158 Lisp_Object *v, tem = Qnil; 3151 struct itree_node *node;
3159 Lisp_Object vbuf[10];
3160 USE_SAFE_ALLOCA;
3161 3152
3162 size = ARRAYELTS (vbuf); 3153 ITREE_FOREACH (node, current_buffer->overlays, ZV, ZV, ASCENDING)
3163 v = vbuf;
3164 n = overlays_in (ZV, ZV, 0, &v, &size, false, false, NULL);
3165 if (n > size)
3166 { 3154 {
3167 SAFE_NALLOCA (v, 1, n); 3155 if ((tem = Foverlay_get (node->data, Qdisplay_line_numbers_disable),
3168 overlays_in (ZV, ZV, 0, &v, &n, false, false, NULL); 3156 !NILP (tem)))
3157 return true;
3169 } 3158 }
3170 3159 return false;
3171 for (i = 0; i < n; ++i)
3172 if ((tem = Foverlay_get (v[i], Qdisplay_line_numbers_disable),
3173 !NILP (tem)))
3174 break;
3175
3176 SAFE_FREE ();
3177 return tem;
3178} 3160}
3179 3161
3180 3162
@@ -4989,7 +4971,7 @@ defvar_per_buffer (struct Lisp_Buffer_Objfwd *bo_fwd, const char *namestring,
4989 sym->u.s.declared_special = true; 4971 sym->u.s.declared_special = true;
4990 sym->u.s.redirect = SYMBOL_FORWARDED; 4972 sym->u.s.redirect = SYMBOL_FORWARDED;
4991 SET_SYMBOL_FWD (sym, bo_fwd); 4973 SET_SYMBOL_FWD (sym, bo_fwd);
4992 XSETSYMBOL (PER_BUFFER_SYMBOL (offset), sym); 4974 PER_BUFFER_SYMBOL (offset) = make_lisp_symbol (sym);
4993 4975
4994 if (PER_BUFFER_IDX (offset) == 0) 4976 if (PER_BUFFER_IDX (offset) == 0)
4995 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding 4977 /* 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 *);
1174extern void reset_buffer (struct buffer *); 1174extern void reset_buffer (struct buffer *);
1175extern void compact_buffer (struct buffer *); 1175extern void compact_buffer (struct buffer *);
1176extern ptrdiff_t overlays_at (ptrdiff_t, bool, Lisp_Object **, ptrdiff_t *, ptrdiff_t *); 1176extern ptrdiff_t overlays_at (ptrdiff_t, bool, Lisp_Object **, ptrdiff_t *, ptrdiff_t *);
1177extern ptrdiff_t overlays_in (ptrdiff_t, ptrdiff_t, bool, Lisp_Object **,
1178 ptrdiff_t *, bool, bool, ptrdiff_t *);
1179extern ptrdiff_t previous_overlay_change (ptrdiff_t); 1177extern ptrdiff_t previous_overlay_change (ptrdiff_t);
1180extern ptrdiff_t next_overlay_change (ptrdiff_t); 1178extern ptrdiff_t next_overlay_change (ptrdiff_t);
1181extern ptrdiff_t sort_overlays (Lisp_Object *, ptrdiff_t, struct window *); 1179extern 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,
625 varref: 625 varref:
626 { 626 {
627 Lisp_Object v1 = vectorp[op], v2; 627 Lisp_Object v1 = vectorp[op], v2;
628 if (!SYMBOLP (v1) 628 if (!BARE_SYMBOL_P (v1)
629 || XSYMBOL (v1)->u.s.redirect != SYMBOL_PLAINVAL 629 || XBARE_SYMBOL (v1)->u.s.redirect != SYMBOL_PLAINVAL
630 || (v2 = SYMBOL_VAL (XSYMBOL (v1)), BASE_EQ (v2, Qunbound))) 630 || (v2 = XBARE_SYMBOL (v1)->u.s.val.value,
631 BASE_EQ (v2, Qunbound)))
631 v2 = Fsymbol_value (v1); 632 v2 = Fsymbol_value (v1);
632 PUSH (v2); 633 PUSH (v2);
633 NEXT; 634 NEXT;
@@ -699,11 +700,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
699 Lisp_Object val = POP; 700 Lisp_Object val = POP;
700 701
701 /* Inline the most common case. */ 702 /* Inline the most common case. */
702 if (SYMBOLP (sym) 703 if (BARE_SYMBOL_P (sym)
703 && !BASE_EQ (val, Qunbound) 704 && !BASE_EQ (val, Qunbound)
704 && XSYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL 705 && XBARE_SYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL
705 && !SYMBOL_TRAPPED_WRITE_P (sym)) 706 && !XBARE_SYMBOL (sym)->u.s.trapped_write)
706 SET_SYMBOL_VAL (XSYMBOL (sym), val); 707 SET_SYMBOL_VAL (XBARE_SYMBOL (sym), val);
707 else 708 else
708 set_internal (sym, val, Qnil, SET_INTERNAL_SET); 709 set_internal (sym, val, Qnil, SET_INTERNAL_SET);
709 } 710 }
@@ -790,24 +791,22 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
790 do_debug_on_call (Qlambda, count1); 791 do_debug_on_call (Qlambda, count1);
791 792
792 Lisp_Object original_fun = call_fun; 793 Lisp_Object original_fun = call_fun;
793 if (SYMBOLP (call_fun)) 794 /* Calls to symbols-with-pos don't need to be on the fast path. */
794 call_fun = XSYMBOL (call_fun)->u.s.function; 795 if (BARE_SYMBOL_P (call_fun))
795 Lisp_Object template; 796 call_fun = XBARE_SYMBOL (call_fun)->u.s.function;
796 Lisp_Object bytecode; 797 if (COMPILEDP (call_fun))
797 if (COMPILEDP (call_fun)
798 /* Lexical binding only. */
799 && (template = AREF (call_fun, COMPILED_ARGLIST),
800 FIXNUMP (template))
801 /* No autoloads. */
802 && (bytecode = AREF (call_fun, COMPILED_BYTECODE),
803 !CONSP (bytecode)))
804 { 798 {
805 fun = call_fun; 799 Lisp_Object template = AREF (call_fun, COMPILED_ARGLIST);
806 bytestr = bytecode; 800 if (FIXNUMP (template))
807 args_template = XFIXNUM (template); 801 {
808 nargs = call_nargs; 802 /* Fast path for lexbound functions. */
809 args = call_args; 803 fun = call_fun;
810 goto setup_frame; 804 bytestr = AREF (call_fun, COMPILED_BYTECODE),
805 args_template = XFIXNUM (template);
806 nargs = call_nargs;
807 args = call_args;
808 goto setup_frame;
809 }
811 } 810 }
812 811
813 Lisp_Object val; 812 Lisp_Object val;
@@ -1738,28 +1737,29 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
1738 if (BYTE_CODE_SAFE && !HASH_TABLE_P (jmp_table)) 1737 if (BYTE_CODE_SAFE && !HASH_TABLE_P (jmp_table))
1739 emacs_abort (); 1738 emacs_abort ();
1740 Lisp_Object v1 = POP; 1739 Lisp_Object v1 = POP;
1741 ptrdiff_t i;
1742 struct Lisp_Hash_Table *h = XHASH_TABLE (jmp_table); 1740 struct Lisp_Hash_Table *h = XHASH_TABLE (jmp_table);
1743 1741 /* Do a linear search if there are few cases and the test is `eq'.
1744 /* h->count is a faster approximation for HASH_TABLE_SIZE (h) 1742 (The table is assumed to be sized exactly; all entries are
1745 here. */ 1743 consecutive at the beginning.)
1746 if (h->count <= 5 && !h->test->cmpfn) 1744 FIXME: 5 is arbitrarily chosen. */
1747 { /* Do a linear search if there are not many cases 1745 if (h->count <= 5 && !h->test->cmpfn && !symbols_with_pos_enabled)
1748 FIXME: 5 is arbitrarily chosen. */ 1746 {
1749 for (i = h->count; 0 <= --i; ) 1747 eassume (h->count >= 2);
1750 if (EQ (v1, HASH_KEY (h, i))) 1748 for (ptrdiff_t i = h->count - 1; i >= 0; i--)
1751 break; 1749 if (BASE_EQ (v1, HASH_KEY (h, i)))
1750 {
1751 op = XFIXNUM (HASH_VALUE (h, i));
1752 goto op_branch;
1753 }
1752 } 1754 }
1753 else 1755 else
1754 i = hash_lookup (h, v1);
1755
1756 if (i >= 0)
1757 { 1756 {
1758 Lisp_Object val = HASH_VALUE (h, i); 1757 ptrdiff_t i = hash_lookup (h, v1);
1759 if (BYTE_CODE_SAFE && !FIXNUMP (val)) 1758 if (i >= 0)
1760 emacs_abort (); 1759 {
1761 op = XFIXNUM (val); 1760 op = XFIXNUM (HASH_VALUE (h, i));
1762 goto op_branch; 1761 goto op_branch;
1762 }
1763 } 1763 }
1764 } 1764 }
1765 NEXT; 1765 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/>. */
35#include "coding.h" 35#include "coding.h"
36#include "keyboard.h" 36#include "keyboard.h"
37 37
38/* Avoid GCC 12 bug <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=105784>. */
39#if GNUC_PREREQ (12, 0, 0)
40# pragma GCC diagnostic ignored "-Wanalyzer-use-of-uninitialized-value"
41#endif
42
43/* Table of registered CCL programs. Each element is a vector of 38/* Table of registered CCL programs. Each element is a vector of
44 NAME, CCL_PROG, RESOLVEDP, and UPDATEDP, where NAME (symbol) is the 39 NAME, CCL_PROG, RESOLVEDP, and UPDATEDP, where NAME (symbol) is the
45 name of the program, CCL_PROG (vector) is the compiled code of the 40 name of the program, CCL_PROG (vector) is the compiled code of the
@@ -609,7 +604,7 @@ while (0)
609 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109579 604 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109579
610 which causes GCC to mistakenly complain about 605 which causes GCC to mistakenly complain about
611 popping the mapping stack. */ 606 popping the mapping stack. */
612#if GNUC_PREREQ (13, 0, 0) 607#if __GNUC__ == 13
613# pragma GCC diagnostic ignored "-Wanalyzer-out-of-bounds" 608# pragma GCC diagnostic ignored "-Wanalyzer-out-of-bounds"
614#endif 609#endif
615 610
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)
4859#endif 4859#endif
4860} 4860}
4861 4861
4862DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, 4862DEFUN ("comp--compile-ctxt-to-file0", Fcomp__compile_ctxt_to_file0,
4863 Scomp__compile_ctxt_to_file, 4863 Scomp__compile_ctxt_to_file0,
4864 1, 1, 0, 4864 1, 1, 0,
4865 doc: /* Compile the current context as native code to file FILENAME. */) 4865 doc: /* Compile the current context as native code to file FILENAME. */)
4866 (Lisp_Object filename) 4866 (Lisp_Object filename)
@@ -5789,7 +5789,7 @@ natively-compiled one. */);
5789 defsubr (&Scomp__install_trampoline); 5789 defsubr (&Scomp__install_trampoline);
5790 defsubr (&Scomp__init_ctxt); 5790 defsubr (&Scomp__init_ctxt);
5791 defsubr (&Scomp__release_ctxt); 5791 defsubr (&Scomp__release_ctxt);
5792 defsubr (&Scomp__compile_ctxt_to_file); 5792 defsubr (&Scomp__compile_ctxt_to_file0);
5793 defsubr (&Scomp_libgccjit_version); 5793 defsubr (&Scomp_libgccjit_version);
5794 defsubr (&Scomp__register_lambda); 5794 defsubr (&Scomp__register_lambda);
5795 defsubr (&Scomp__register_subr); 5795 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 *);
471#undef MB_CUR_MAX 471#undef MB_CUR_MAX
472#define MB_CUR_MAX REPLACEMENT_MB_CUR_MAX 472#define MB_CUR_MAX REPLACEMENT_MB_CUR_MAX
473#endif /* REPLACEMENT_MB_CUR_MAX */ 473#endif /* REPLACEMENT_MB_CUR_MAX */
474
475/* Emacs does not need glibc strftime behavior for AM and PM
476 indicators. */
477#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'. */)
231 case PVEC_BOOL_VECTOR: return Qbool_vector; 231 case PVEC_BOOL_VECTOR: return Qbool_vector;
232 case PVEC_FRAME: return Qframe; 232 case PVEC_FRAME: return Qframe;
233 case PVEC_HASH_TABLE: return Qhash_table; 233 case PVEC_HASH_TABLE: return Qhash_table;
234 case PVEC_OBARRAY: return Qobarray;
234 case PVEC_FONT: 235 case PVEC_FONT:
235 if (FONT_SPEC_P (object)) 236 if (FONT_SPEC_P (object))
236 return Qfont_spec; 237 return Qfont_spec;
@@ -791,18 +792,16 @@ DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
791 doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */) 792 doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */)
792 (register Lisp_Object sym) 793 (register Lisp_Object sym)
793{ 794{
794 if (BARE_SYMBOL_P (sym)) 795 CHECK_SYMBOL (sym);
795 return sym; 796 return BARE_SYMBOL_P (sym) ? sym : XSYMBOL_WITH_POS_SYM (sym);
796 /* Type checking is done in the following macro. */
797 return SYMBOL_WITH_POS_SYM (sym);
798} 797}
799 798
800DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0, 799DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0,
801 doc: /* Extract the position from a symbol with position. */) 800 doc: /* Extract the position from a symbol with position. */)
802 (register Lisp_Object ls) 801 (register Lisp_Object ls)
803{ 802{
804 /* Type checking is done in the following macro. */ 803 CHECK_TYPE (SYMBOL_WITH_POS_P (ls), Qsymbol_with_pos_p, ls);
805 return SYMBOL_WITH_POS_POS (ls); 804 return XSYMBOL_WITH_POS_POS (ls);
806} 805}
807 806
808DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol, 807DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol,
@@ -812,7 +811,7 @@ Otherwise, return ARG unchanged. Compare with `bare-symbol'. */)
812 (register Lisp_Object arg) 811 (register Lisp_Object arg)
813{ 812{
814 if (SYMBOL_WITH_POS_P (arg)) 813 if (SYMBOL_WITH_POS_P (arg))
815 return (SYMBOL_WITH_POS_SYM (arg)); 814 return XSYMBOL_WITH_POS_SYM (arg);
816 return arg; 815 return arg;
817} 816}
818 817
@@ -823,20 +822,13 @@ POS, the position, is either a fixnum or a symbol with position from which
823the position will be taken. */) 822the position will be taken. */)
824 (register Lisp_Object sym, register Lisp_Object pos) 823 (register Lisp_Object sym, register Lisp_Object pos)
825{ 824{
826 Lisp_Object bare; 825 Lisp_Object bare = Fbare_symbol (sym);
827 Lisp_Object position; 826 Lisp_Object position;
828 827
829 if (BARE_SYMBOL_P (sym))
830 bare = sym;
831 else if (SYMBOL_WITH_POS_P (sym))
832 bare = XSYMBOL_WITH_POS (sym)->sym;
833 else
834 wrong_type_argument (Qsymbolp, sym);
835
836 if (FIXNUMP (pos)) 828 if (FIXNUMP (pos))
837 position = pos; 829 position = pos;
838 else if (SYMBOL_WITH_POS_P (pos)) 830 else if (SYMBOL_WITH_POS_P (pos))
839 position = XSYMBOL_WITH_POS (pos)->pos; 831 position = XSYMBOL_WITH_POS_POS (pos);
840 else 832 else
841 wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos); 833 wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos);
842 834
@@ -1264,7 +1256,7 @@ If OBJECT is not a symbol, just return it. */)
1264 struct Lisp_Symbol *sym = XSYMBOL (object); 1256 struct Lisp_Symbol *sym = XSYMBOL (object);
1265 while (sym->u.s.redirect == SYMBOL_VARALIAS) 1257 while (sym->u.s.redirect == SYMBOL_VARALIAS)
1266 sym = SYMBOL_ALIAS (sym); 1258 sym = SYMBOL_ALIAS (sym);
1267 XSETSYMBOL (object, sym); 1259 object = make_lisp_symbol (sym);
1268 } 1260 }
1269 return object; 1261 return object;
1270} 1262}
@@ -1514,12 +1506,9 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_
1514 if (blv->fwd.fwdptr) 1506 if (blv->fwd.fwdptr)
1515 set_blv_value (blv, do_symval_forwarding (blv->fwd)); 1507 set_blv_value (blv, do_symval_forwarding (blv->fwd));
1516 /* Choose the new binding. */ 1508 /* Choose the new binding. */
1517 { 1509 tem1 = assq_no_quit (make_lisp_symbol (symbol),
1518 Lisp_Object var; 1510 BVAR (current_buffer, local_var_alist));
1519 XSETSYMBOL (var, symbol); 1511 set_blv_where (blv, Fcurrent_buffer ());
1520 tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
1521 set_blv_where (blv, Fcurrent_buffer ());
1522 }
1523 if (!(blv->found = !NILP (tem1))) 1512 if (!(blv->found = !NILP (tem1)))
1524 tem1 = blv->defcell; 1513 tem1 = blv->defcell;
1525 1514
@@ -1663,7 +1652,8 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
1663 set_blv_value (blv, do_symval_forwarding (blv->fwd)); 1652 set_blv_value (blv, do_symval_forwarding (blv->fwd));
1664 1653
1665 /* Find the new binding. */ 1654 /* Find the new binding. */
1666 XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */ 1655 /* May have changed via aliasing. */
1656 symbol = make_lisp_symbol (sym);
1667 Lisp_Object tem1 1657 Lisp_Object tem1
1668 = assq_no_quit (symbol, 1658 = assq_no_quit (symbol,
1669 BVAR (XBUFFER (where), local_var_alist)); 1659 BVAR (XBUFFER (where), local_var_alist));
@@ -2067,13 +2057,10 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded,
2067 union Lisp_Val_Fwd valcontents) 2057 union Lisp_Val_Fwd valcontents)
2068{ 2058{
2069 struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv); 2059 struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
2070 Lisp_Object symbol; 2060 Lisp_Object tem = Fcons (make_lisp_symbol (sym),
2071 Lisp_Object tem; 2061 forwarded
2072 2062 ? do_symval_forwarding (valcontents.fwd)
2073 XSETSYMBOL (symbol, sym); 2063 : valcontents.value);
2074 tem = Fcons (symbol, (forwarded
2075 ? do_symval_forwarding (valcontents.fwd)
2076 : valcontents.value));
2077 2064
2078 /* Buffer_Local_Values cannot have as realval a buffer-local 2065 /* Buffer_Local_Values cannot have as realval a buffer-local
2079 or keyboard-local forwarding. */ 2066 or keyboard-local forwarding. */
@@ -2229,7 +2216,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
2229 } 2216 }
2230 2217
2231 /* Make sure this buffer has its own value of symbol. */ 2218 /* Make sure this buffer has its own value of symbol. */
2232 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */ 2219 variable = make_lisp_symbol (sym); /* Update in case of aliasing. */
2233 tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist)); 2220 tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist));
2234 if (NILP (tem)) 2221 if (NILP (tem))
2235 { 2222 {
@@ -2309,7 +2296,7 @@ From now on the default value will apply in this buffer. Return VARIABLE. */)
2309 notify_variable_watchers (variable, Qnil, Qmakunbound, Fcurrent_buffer ()); 2296 notify_variable_watchers (variable, Qnil, Qmakunbound, Fcurrent_buffer ());
2310 2297
2311 /* Get rid of this buffer's alist element, if any. */ 2298 /* Get rid of this buffer's alist element, if any. */
2312 XSETSYMBOL (variable, sym); /* Propagate variable indirection. */ 2299 variable = make_lisp_symbol (sym); /* Propagate variable indirection. */
2313 tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist)); 2300 tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist));
2314 if (!NILP (tem)) 2301 if (!NILP (tem))
2315 bset_local_var_alist 2302 bset_local_var_alist
@@ -2354,7 +2341,7 @@ Also see `buffer-local-boundp'.*/)
2354 Lisp_Object tmp; 2341 Lisp_Object tmp;
2355 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); 2342 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
2356 XSETBUFFER (tmp, buf); 2343 XSETBUFFER (tmp, buf);
2357 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */ 2344 variable = make_lisp_symbol (sym); /* Update in case of aliasing. */
2358 2345
2359 if (EQ (blv->where, tmp)) /* The binding is already loaded. */ 2346 if (EQ (blv->where, tmp)) /* The binding is already loaded. */
2360 return blv_found (blv) ? Qt : Qnil; 2347 return blv_found (blv) ? Qt : Qnil;
@@ -2404,7 +2391,7 @@ value in BUFFER, or if VARIABLE is automatically buffer-local (see
2404 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); 2391 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
2405 if (blv->local_if_set) 2392 if (blv->local_if_set)
2406 return Qt; 2393 return Qt;
2407 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */ 2394 variable = make_lisp_symbol (sym); /* Update in case of aliasing. */
2408 return Flocal_variable_p (variable, buffer); 2395 return Flocal_variable_p (variable, buffer);
2409 } 2396 }
2410 case SYMBOL_FORWARDED: 2397 case SYMBOL_FORWARDED:
@@ -4238,6 +4225,7 @@ syms_of_data (void)
4238 DEFSYM (Qtreesit_parser, "treesit-parser"); 4225 DEFSYM (Qtreesit_parser, "treesit-parser");
4239 DEFSYM (Qtreesit_node, "treesit-node"); 4226 DEFSYM (Qtreesit_node, "treesit-node");
4240 DEFSYM (Qtreesit_compiled_query, "treesit-compiled-query"); 4227 DEFSYM (Qtreesit_compiled_query, "treesit-compiled-query");
4228 DEFSYM (Qobarray, "obarray");
4241 4229
4242 DEFSYM (Qdefun, "defun"); 4230 DEFSYM (Qdefun, "defun");
4243 4231
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
2752 pixel_width with each call to produce_glyphs. */ 2752 pixel_width with each call to produce_glyphs. */
2753 int current_x; 2753 int current_x;
2754 2754
2755 /* Pixel position within a display line with a wrap prefix. Updated
2756 to reflect current_x in produce_glyphs when producing glyphs from
2757 a prefix string and continuation_lines_width > 0, which is to
2758 say, from a wrap prefix.
2759
2760 Such updates are unnecessary where it is impossible for a wrap
2761 prefix to be active, e.g. when continuation lines are being
2762 produced. */
2763 int wrap_prefix_width;
2764
2755 /* Accumulated width of continuation lines. If > 0, this means we 2765 /* Accumulated width of continuation lines. If > 0, this means we
2756 are currently in a continuation line. This is initially zero and 2766 are currently in a continuation line. This is initially zero and
2757 incremented/reset by display_line, move_it_to etc. */ 2767 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)
357 return 1; 357 return 1;
358} 358}
359 359
360DEFUN ("documentation-stringp", Fdocumentation_stringp, Sdocumentation_stringp,
361 1, 1, 0,
362 doc: /* Return non-nil if OBJECT is a well-formed docstring object.
363OBJECT can be either a string or a reference if it's kept externally. */)
364 (Lisp_Object object)
365{
366 return (STRINGP (object)
367 || FIXNUMP (object) /* Reference to DOC. */
368 || (CONSP (object) /* Reference to .elc. */
369 && STRINGP (XCAR (object))
370 && FIXNUMP (XCDR (object)))
371 ? Qt : Qnil);
372}
373
360DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0, 374DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
361 doc: /* Return the documentation string of FUNCTION. 375 doc: /* Return the documentation string of FUNCTION.
362Unless a non-nil second argument RAW is given, the 376Unless a non-nil second argument RAW is given, the
@@ -502,46 +516,13 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
502 /* If it's a lisp form, stick it in the form. */ 516 /* If it's a lisp form, stick it in the form. */
503 if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) 517 if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
504 fun = XCDR (fun); 518 fun = XCDR (fun);
505 if (CONSP (fun))
506 {
507 Lisp_Object tem = XCAR (fun);
508 if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
509 || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
510 {
511 tem = Fcdr (Fcdr (fun));
512 if (CONSP (tem) && FIXNUMP (XCAR (tem)))
513 /* FIXME: This modifies typically pure hash-cons'd data, so its
514 correctness is quite delicate. */
515 XSETCAR (tem, make_fixnum (offset));
516 }
517 }
518 /* Lisp_Subrs have a slot for it. */ 519 /* Lisp_Subrs have a slot for it. */
519 else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun)) 520 if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
520 { 521 XSUBR (fun)->doc = offset;
521 XSUBR (fun)->doc = offset; 522 else
522 }
523
524 /* Bytecode objects sometimes have slots for it. */
525 else if (COMPILEDP (fun))
526 { 523 {
527 /* This bytecode object must have a slot for the 524 AUTO_STRING (format, "Ignoring DOC string on non-subr: %S");
528 docstring, since we've found a docstring for it. */ 525 CALLN (Fmessage, format, obj);
529 if (PVSIZE (fun) > COMPILED_DOC_STRING
530 /* Don't overwrite a non-docstring value placed there,
531 * such as the symbols used for Oclosures. */
532 && VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING)))
533 ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
534 else
535 {
536 AUTO_STRING (format,
537 (PVSIZE (fun) > COMPILED_DOC_STRING
538 ? "Docstring slot busy for %s"
539 : "No docstring slot for %s"));
540 CALLN (Fmessage, format,
541 (SYMBOLP (obj)
542 ? SYMBOL_NAME (obj)
543 : build_string ("<anonymous>")));
544 }
545 } 526 }
546} 527}
547 528
@@ -776,6 +757,7 @@ compute the correct value for the current terminal in the nil case. */);
776 doc: /* If nil, a nil `text-quoting-style' is treated as `grave'. */); 757 doc: /* If nil, a nil `text-quoting-style' is treated as `grave'. */);
777 /* Initialized by ‘main’. */ 758 /* Initialized by ‘main’. */
778 759
760 defsubr (&Sdocumentation_stringp);
779 defsubr (&Sdocumentation); 761 defsubr (&Sdocumentation);
780 defsubr (&Ssubr_documentation); 762 defsubr (&Ssubr_documentation);
781 defsubr (&Sdocumentation_property); 763 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. */)
272} 272}
273 273
274 274
275/* Find all the overlays in the current buffer that touch position POS.
276 Return the number found, and store them in a vector in VEC
277 of length LEN.
278
279 Note: this can return overlays that do not touch POS. The caller
280 should filter these out. */
281
282static ptrdiff_t
283overlays_around (ptrdiff_t pos, Lisp_Object *vec, ptrdiff_t len)
284{
285 /* Find all potentially rear-advance overlays at (POS - 1). Find
286 all overlays at POS, so end at (POS + 1). Find even empty
287 overlays, which due to the way 'overlays-in' works implies that
288 we might also fetch empty overlays starting at (POS + 1). */
289 return overlays_in (pos - 1, pos + 1, false, &vec, &len,
290 true, false, NULL);
291}
292
293DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0, 275DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
294 doc: /* Return the value of POSITION's property PROP, in OBJECT. 276 doc: /* Return the value of POSITION's property PROP, in OBJECT.
295Almost identical to `get-char-property' except for the following difference: 277Almost identical to `get-char-property' except for the following difference:
@@ -315,53 +297,44 @@ at POSITION. */)
315 else 297 else
316 { 298 {
317 EMACS_INT posn = XFIXNUM (position); 299 EMACS_INT posn = XFIXNUM (position);
318 ptrdiff_t noverlays; 300 Lisp_Object tem;
319 Lisp_Object *overlay_vec, tem;
320 struct buffer *obuf = current_buffer; 301 struct buffer *obuf = current_buffer;
321 USE_SAFE_ALLOCA; 302 struct itree_node *node;
322 303 struct sortvec items[2];
323 set_buffer_temp (XBUFFER (object)); 304 struct buffer *b = XBUFFER (object);
305 struct sortvec *result = NULL;
306 Lisp_Object res = Qnil;
324 307
325 /* First try with room for 40 overlays. */ 308 set_buffer_temp (b);
326 Lisp_Object overlay_vecbuf[40];
327 noverlays = ARRAYELTS (overlay_vecbuf);
328 overlay_vec = overlay_vecbuf;
329 noverlays = overlays_around (posn, overlay_vec, noverlays);
330 309
331 /* If there are more than 40, 310 ITREE_FOREACH (node, b->overlays, posn - 1, posn + 1, ASCENDING)
332 make enough space for all, and try again. */
333 if (ARRAYELTS (overlay_vecbuf) < noverlays)
334 { 311 {
335 SAFE_ALLOCA_LISP (overlay_vec, noverlays); 312 Lisp_Object ol = node->data;
336 noverlays = overlays_around (posn, overlay_vec, noverlays);
337 }
338 noverlays = sort_overlays (overlay_vec, noverlays, NULL);
339
340 set_buffer_temp (obuf);
341
342 /* Now check the overlays in order of decreasing priority. */
343 while (--noverlays >= 0)
344 {
345 Lisp_Object ol = overlay_vec[noverlays];
346 tem = Foverlay_get (ol, prop); 313 tem = Foverlay_get (ol, prop);
347 if (!NILP (tem)) 314 if (NILP (tem)
348 {
349 /* Check the overlay is indeed active at point. */ 315 /* Check the overlay is indeed active at point. */
350 if ((OVERLAY_START (ol) == posn 316 || ((node->begin == posn
351 && OVERLAY_FRONT_ADVANCE_P (ol)) 317 && OVERLAY_FRONT_ADVANCE_P (ol))
352 || (OVERLAY_END (ol) == posn 318 || (node->end == posn
353 && ! OVERLAY_REAR_ADVANCE_P (ol)) 319 && ! OVERLAY_REAR_ADVANCE_P (ol))
354 || OVERLAY_START (ol) > posn 320 || node->begin > posn
355 || OVERLAY_END (ol) < posn) 321 || node->end < posn))
356 ; /* The overlay will not cover a char inserted at point. */ 322 /* The overlay will not cover a char inserted at point. */
357 else 323 continue;
358 { 324
359 SAFE_FREE (); 325 struct sortvec *this = (result == items ? items + 1 : items);
360 return tem; 326 if (NILP (res)
361 } 327 || (make_sortvec_item (this, node->data),
362 } 328 compare_overlays (result, this) < 0))
329 {
330 result = this;
331 res = tem;
332 }
363 } 333 }
364 SAFE_FREE (); 334 set_buffer_temp (obuf);
335
336 if (!NILP (res))
337 return res;
365 338
366 { /* Now check the text properties. */ 339 { /* Now check the text properties. */
367 int stickiness = text_property_stickiness (prop, position, object); 340 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)
3116 check_message_stack (); 3116 check_message_stack ();
3117 } 3117 }
3118 3118
3119#ifdef HAVE_NATIVE_COMP
3120 eln_load_path_final_clean_up ();
3121#endif
3122
3123#ifdef MSDOS 3119#ifdef MSDOS
3124 dos_cleanup (); 3120 dos_cleanup ();
3125#endif 3121#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)
3122 xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (numargs)); 3122 xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (numargs));
3123} 3123}
3124 3124
3125/* Call the compiled Lisp function FUN. If we have not yet read FUN's
3126 bytecode string and constants vector, fetch them from the file first. */
3127
3128static Lisp_Object
3129fetch_and_exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
3130 ptrdiff_t nargs, Lisp_Object *args)
3131{
3132 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3133 Ffetch_bytecode (fun);
3134
3135 return exec_byte_code (fun, args_template, nargs, args);
3136}
3137
3138static Lisp_Object 3125static Lisp_Object
3139apply_lambda (Lisp_Object fun, Lisp_Object args, specpdl_ref count) 3126apply_lambda (Lisp_Object fun, Lisp_Object args, specpdl_ref count)
3140{ 3127{
@@ -3204,8 +3191,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
3204 ARGLIST slot value: pass the arguments to the byte-code 3191 ARGLIST slot value: pass the arguments to the byte-code
3205 engine directly. */ 3192 engine directly. */
3206 if (FIXNUMP (syms_left)) 3193 if (FIXNUMP (syms_left))
3207 return fetch_and_exec_byte_code (fun, XFIXNUM (syms_left), 3194 return exec_byte_code (fun, XFIXNUM (syms_left), nargs, arg_vector);
3208 nargs, arg_vector);
3209 /* Otherwise the bytecode object uses dynamic binding and the 3195 /* Otherwise the bytecode object uses dynamic binding and the
3210 ARGLIST slot contains a standard formal argument list whose 3196 ARGLIST slot contains a standard formal argument list whose
3211 variables are bound dynamically below. */ 3197 variables are bound dynamically below. */
@@ -3293,7 +3279,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
3293 val = XSUBR (fun)->function.a0 (); 3279 val = XSUBR (fun)->function.a0 ();
3294 } 3280 }
3295 else 3281 else
3296 val = fetch_and_exec_byte_code (fun, 0, 0, NULL); 3282 val = exec_byte_code (fun, 0, 0, NULL);
3297 3283
3298 return unbind_to (count, val); 3284 return unbind_to (count, val);
3299} 3285}
@@ -3411,46 +3397,6 @@ lambda_arity (Lisp_Object fun)
3411 return Fcons (make_fixnum (minargs), make_fixnum (maxargs)); 3397 return Fcons (make_fixnum (minargs), make_fixnum (maxargs));
3412} 3398}
3413 3399
3414DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
3415 1, 1, 0,
3416 doc: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3417 (Lisp_Object object)
3418{
3419 Lisp_Object tem;
3420
3421 if (COMPILEDP (object))
3422 {
3423 if (CONSP (AREF (object, COMPILED_BYTECODE)))
3424 {
3425 tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
3426 if (! (CONSP (tem) && STRINGP (XCAR (tem))
3427 && VECTORP (XCDR (tem))))
3428 {
3429 tem = AREF (object, COMPILED_BYTECODE);
3430 if (CONSP (tem) && STRINGP (XCAR (tem)))
3431 error ("Invalid byte code in %s", SDATA (XCAR (tem)));
3432 else
3433 error ("Invalid byte code");
3434 }
3435
3436 Lisp_Object bytecode = XCAR (tem);
3437 if (STRING_MULTIBYTE (bytecode))
3438 {
3439 /* BYTECODE must have been produced by Emacs 20.2 or earlier
3440 because it produced a raw 8-bit string for byte-code and now
3441 such a byte-code string is loaded as multibyte with raw 8-bit
3442 characters converted to multibyte form. Convert them back to
3443 the original unibyte form. */
3444 bytecode = Fstring_as_unibyte (bytecode);
3445 }
3446
3447 pin_string (bytecode);
3448 ASET (object, COMPILED_BYTECODE, bytecode);
3449 ASET (object, COMPILED_CONSTANTS, XCDR (tem));
3450 }
3451 }
3452 return object;
3453}
3454 3400
3455/* Return true if SYMBOL's default currently has a let-binding 3401/* Return true if SYMBOL's default currently has a let-binding
3456 which was made in the buffer that is now current. */ 3402 which was made in the buffer that is now current. */
@@ -3529,7 +3475,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3529 switch (sym->u.s.redirect) 3475 switch (sym->u.s.redirect)
3530 { 3476 {
3531 case SYMBOL_VARALIAS: 3477 case SYMBOL_VARALIAS:
3532 sym = SYMBOL_ALIAS (sym); XSETSYMBOL (symbol, sym); goto start; 3478 sym = SYMBOL_ALIAS (sym); symbol = make_lisp_symbol (sym); goto start;
3533 case SYMBOL_PLAINVAL: 3479 case SYMBOL_PLAINVAL:
3534 /* The most common case is that of a non-constant symbol with a 3480 /* The most common case is that of a non-constant symbol with a
3535 trivial value. Make that as fast as we can. */ 3481 trivial value. Make that as fast as we can. */
@@ -4512,7 +4458,6 @@ alist of active lexical bindings. */);
4512 defsubr (&Srun_hook_with_args_until_success); 4458 defsubr (&Srun_hook_with_args_until_success);
4513 defsubr (&Srun_hook_with_args_until_failure); 4459 defsubr (&Srun_hook_with_args_until_failure);
4514 defsubr (&Srun_hook_wrapped); 4460 defsubr (&Srun_hook_wrapped);
4515 defsubr (&Sfetch_bytecode);
4516 defsubr (&Sbacktrace_debug); 4461 defsubr (&Sbacktrace_debug);
4517 DEFSYM (QCdebug_on_exit, ":debug-on-exit"); 4462 DEFSYM (QCdebug_on_exit, ":debug-on-exit");
4518 defsubr (&Smapbacktrace); 4463 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,
5628 changed to a call to `stat'. */ 5628 changed to a call to `stat'. */
5629 5629
5630 if (emacs_fstatat (AT_FDCWD, fn, &st1, 0) == 0 5630 if (emacs_fstatat (AT_FDCWD, fn, &st1, 0) == 0
5631 && st.st_dev == st1.st_dev && st.st_ino == st1.st_ino) 5631 && st.st_dev == st1.st_dev
5632 && (st.st_ino == st1.st_ino
5633#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
5634 /* `st1.st_ino' == 0 indicates that the inode number
5635 cannot be extracted from this document file, despite
5636 `st' potentially being backed by a real file. */
5637 || st1.st_ino == 0
5638#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
5639 ))
5632 { 5640 {
5633 /* Use the heuristic if it appears to be valid. With neither 5641 /* Use the heuristic if it appears to be valid. With neither
5634 O_EXCL nor O_TRUNC, if Emacs happened to write nothing to the 5642 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,
2782 2782
2783 /* A symbol with position compares the contained symbol, and is 2783 /* A symbol with position compares the contained symbol, and is
2784 `equal' to the corresponding ordinary symbol. */ 2784 `equal' to the corresponding ordinary symbol. */
2785 if (symbols_with_pos_enabled) 2785 o1 = maybe_remove_pos_from_symbol (o1);
2786 { 2786 o2 = maybe_remove_pos_from_symbol (o2);
2787 if (SYMBOL_WITH_POS_P (o1))
2788 o1 = SYMBOL_WITH_POS_SYM (o1);
2789 if (SYMBOL_WITH_POS_P (o2))
2790 o2 = SYMBOL_WITH_POS_SYM (o2);
2791 }
2792 2787
2793 if (BASE_EQ (o1, o2)) 2788 if (BASE_EQ (o1, o2))
2794 return true; 2789 return true;
@@ -2869,11 +2864,14 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
2869 if (TS_NODEP (o1)) 2864 if (TS_NODEP (o1))
2870 return treesit_node_eq (o1, o2); 2865 return treesit_node_eq (o1, o2);
2871#endif 2866#endif
2872 if (SYMBOL_WITH_POS_P(o1)) /* symbols_with_pos_enabled is false. */ 2867 if (SYMBOL_WITH_POS_P (o1))
2873 return (BASE_EQ (XSYMBOL_WITH_POS (o1)->sym, 2868 {
2874 XSYMBOL_WITH_POS (o2)->sym) 2869 eassert (!symbols_with_pos_enabled);
2875 && BASE_EQ (XSYMBOL_WITH_POS (o1)->pos, 2870 return (BASE_EQ (XSYMBOL_WITH_POS_SYM (o1),
2876 XSYMBOL_WITH_POS (o2)->pos)); 2871 XSYMBOL_WITH_POS_SYM (o2))
2872 && BASE_EQ (XSYMBOL_WITH_POS_POS (o1),
2873 XSYMBOL_WITH_POS_POS (o2)));
2874 }
2877 2875
2878 /* Aside from them, only true vectors, char-tables, compiled 2876 /* Aside from them, only true vectors, char-tables, compiled
2879 functions, and fonts (font-spec, font-entity, font-object) 2877 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. */)
3211Lisp_Object 3209Lisp_Object
3212do_yes_or_no_p (Lisp_Object prompt) 3210do_yes_or_no_p (Lisp_Object prompt)
3213{ 3211{
3214 return call1 (intern ("yes-or-no-p"), prompt); 3212 return call1 (Qyes_or_no_p, prompt);
3215} 3213}
3216 3214
3217DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0, 3215DEFUN ("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. */)
3256 } 3254 }
3257 3255
3258 if (use_short_answers) 3256 if (use_short_answers)
3259 return call1 (intern ("y-or-n-p"), prompt); 3257 return call1 (Qy_or_n_p, prompt);
3260 3258
3261 { 3259 {
3262 char *s = SSDATA (prompt); 3260 char *s = SSDATA (prompt);
@@ -4291,7 +4289,7 @@ set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, hash_hash_t val)
4291static void 4289static void
4292set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val) 4290set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
4293{ 4291{
4294 eassert (idx >= 0 && idx < h->index_size); 4292 eassert (idx >= 0 && idx < hash_table_index_size (h));
4295 h->index[idx] = val; 4293 h->index[idx] = val;
4296} 4294}
4297 4295
@@ -4392,7 +4390,7 @@ HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
4392static ptrdiff_t 4390static ptrdiff_t
4393HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx) 4391HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
4394{ 4392{
4395 eassert (idx >= 0 && idx < h->index_size); 4393 eassert (idx >= 0 && idx < hash_table_index_size (h));
4396 return h->index[idx]; 4394 return h->index[idx];
4397} 4395}
4398 4396
@@ -4452,22 +4450,11 @@ cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2,
4452 return hash_table_user_defined_call (ARRAYELTS (args), args, h); 4450 return hash_table_user_defined_call (ARRAYELTS (args), args, h);
4453} 4451}
4454 4452
4455/* Reduce an EMACS_UINT hash value to hash_hash_t. */
4456static inline hash_hash_t
4457reduce_emacs_uint_to_hash_hash (EMACS_UINT x)
4458{
4459 verify (sizeof x <= 2 * sizeof (hash_hash_t));
4460 return (sizeof x == sizeof (hash_hash_t)
4461 ? x
4462 : x ^ (x >> (8 * (sizeof x - sizeof (hash_hash_t)))));
4463}
4464
4465static EMACS_INT 4453static EMACS_INT
4466sxhash_eq (Lisp_Object key) 4454sxhash_eq (Lisp_Object key)
4467{ 4455{
4468 if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (key)) 4456 Lisp_Object k = maybe_remove_pos_from_symbol (key);
4469 key = SYMBOL_WITH_POS_SYM (key); 4457 return XHASH (k) ^ XTYPE (k);
4470 return XHASH (key) ^ XTYPE (key);
4471} 4458}
4472 4459
4473static EMACS_INT 4460static EMACS_INT
@@ -4527,26 +4514,19 @@ allocate_hash_table (void)
4527 return ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Hash_Table, PVEC_HASH_TABLE); 4514 return ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Hash_Table, PVEC_HASH_TABLE);
4528} 4515}
4529 4516
4530/* Compute the size of the index from the table capacity. */ 4517/* Compute the size of the index (as log2) from the table capacity. */
4531static ptrdiff_t 4518static int
4532hash_index_size (ptrdiff_t size) 4519compute_hash_index_bits (hash_idx_t size)
4533{ 4520{
4534 /* An upper bound on the size of a hash table index. It must fit in 4521 /* An upper bound on the size of a hash table index index. */
4535 ptrdiff_t and be a valid Emacs fixnum. */ 4522 hash_idx_t upper_bound = min (MOST_POSITIVE_FIXNUM,
4536 ptrdiff_t upper_bound = min (MOST_POSITIVE_FIXNUM, 4523 min (TYPE_MAXIMUM (hash_idx_t),
4537 min (TYPE_MAXIMUM (hash_idx_t), 4524 PTRDIFF_MAX / sizeof (hash_idx_t)));
4538 PTRDIFF_MAX / sizeof (ptrdiff_t))); 4525 /* Use next higher power of 2. This works even for size=0. */
4539 /* Single-element index vectors are used iff size=0. */ 4526 int bits = elogb (size) + 1;
4540 eassert (size > 0); 4527 if (bits >= TYPE_WIDTH (uintmax_t) || ((uintmax_t)1 << bits) > upper_bound)
4541 ptrdiff_t lower_bound = 2;
4542 ptrdiff_t index_size = size + max (size >> 2, 1); /* 1.25x larger */
4543 if (index_size < upper_bound)
4544 index_size = (index_size < lower_bound
4545 ? lower_bound
4546 : next_almost_prime (index_size));
4547 if (index_size > upper_bound)
4548 error ("Hash table too large"); 4528 error ("Hash table too large");
4549 return index_size; 4529 return bits;
4550} 4530}
4551 4531
4552/* Constant hash index vector used when the table size is zero. 4532/* 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,
4587 h->key_and_value = NULL; 4567 h->key_and_value = NULL;
4588 h->hash = NULL; 4568 h->hash = NULL;
4589 h->next = NULL; 4569 h->next = NULL;
4590 h->index_size = 1; 4570 h->index_bits = 0;
4591 h->index = (hash_idx_t *)empty_hash_index_vector; 4571 h->index = (hash_idx_t *)empty_hash_index_vector;
4592 h->next_free = -1; 4572 h->next_free = -1;
4593 } 4573 }
@@ -4605,8 +4585,9 @@ make_hash_table (const struct hash_table_test *test, EMACS_INT size,
4605 h->next[i] = i + 1; 4585 h->next[i] = i + 1;
4606 h->next[size - 1] = -1; 4586 h->next[size - 1] = -1;
4607 4587
4608 int index_size = hash_index_size (size); 4588 int index_bits = compute_hash_index_bits (size);
4609 h->index_size = index_size; 4589 h->index_bits = index_bits;
4590 ptrdiff_t index_size = hash_table_index_size (h);
4610 h->index = hash_table_alloc_bytes (index_size * sizeof *h->index); 4591 h->index = hash_table_alloc_bytes (index_size * sizeof *h->index);
4611 for (ptrdiff_t i = 0; i < index_size; i++) 4592 for (ptrdiff_t i = 0; i < index_size; i++)
4612 h->index[i] = -1; 4593 h->index[i] = -1;
@@ -4617,13 +4598,7 @@ make_hash_table (const struct hash_table_test *test, EMACS_INT size,
4617 h->next_weak = NULL; 4598 h->next_weak = NULL;
4618 h->purecopy = purecopy; 4599 h->purecopy = purecopy;
4619 h->mutable = true; 4600 h->mutable = true;
4620 4601 return make_lisp_hash_table (h);
4621 Lisp_Object table;
4622 XSET_HASH_TABLE (table, h);
4623 eassert (HASH_TABLE_P (table));
4624 eassert (XHASH_TABLE (table) == h);
4625
4626 return table;
4627} 4602}
4628 4603
4629 4604
@@ -4633,7 +4608,6 @@ make_hash_table (const struct hash_table_test *test, EMACS_INT size,
4633static Lisp_Object 4608static Lisp_Object
4634copy_hash_table (struct Lisp_Hash_Table *h1) 4609copy_hash_table (struct Lisp_Hash_Table *h1)
4635{ 4610{
4636 Lisp_Object table;
4637 struct Lisp_Hash_Table *h2; 4611 struct Lisp_Hash_Table *h2;
4638 4612
4639 h2 = allocate_hash_table (); 4613 h2 = allocate_hash_table ();
@@ -4654,22 +4628,18 @@ copy_hash_table (struct Lisp_Hash_Table *h1)
4654 h2->next = hash_table_alloc_bytes (next_bytes); 4628 h2->next = hash_table_alloc_bytes (next_bytes);
4655 memcpy (h2->next, h1->next, next_bytes); 4629 memcpy (h2->next, h1->next, next_bytes);
4656 4630
4657 ptrdiff_t index_bytes = h1->index_size * sizeof *h1->index; 4631 ptrdiff_t index_bytes = hash_table_index_size (h1) * sizeof *h1->index;
4658 h2->index = hash_table_alloc_bytes (index_bytes); 4632 h2->index = hash_table_alloc_bytes (index_bytes);
4659 memcpy (h2->index, h1->index, index_bytes); 4633 memcpy (h2->index, h1->index, index_bytes);
4660 } 4634 }
4661 XSET_HASH_TABLE (table, h2); 4635 return make_lisp_hash_table (h2);
4662
4663 return table;
4664} 4636}
4665 4637
4666
4667/* Compute index into the index vector from a hash value. */ 4638/* Compute index into the index vector from a hash value. */
4668static inline ptrdiff_t 4639static inline ptrdiff_t
4669hash_index_index (struct Lisp_Hash_Table *h, hash_hash_t hash) 4640hash_index_index (struct Lisp_Hash_Table *h, hash_hash_t hash)
4670{ 4641{
4671 eassert (h->index_size > 0); 4642 return knuth_hash (hash, h->index_bits);
4672 return hash % h->index_size;
4673} 4643}
4674 4644
4675/* Resize hash table H if it's too full. If H cannot be resized 4645/* 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)
4681 if (h->next_free < 0) 4651 if (h->next_free < 0)
4682 { 4652 {
4683 ptrdiff_t old_size = HASH_TABLE_SIZE (h); 4653 ptrdiff_t old_size = HASH_TABLE_SIZE (h);
4684 ptrdiff_t min_size = 8; 4654 ptrdiff_t min_size = 6;
4685 ptrdiff_t base_size = min (max (old_size, min_size), PTRDIFF_MAX / 2); 4655 ptrdiff_t base_size = min (max (old_size, min_size), PTRDIFF_MAX / 2);
4686 /* Grow aggressively at small sizes, then just double. */ 4656 /* Grow aggressively at small sizes, then just double. */
4687 ptrdiff_t new_size = 4657 ptrdiff_t new_size =
@@ -4706,13 +4676,14 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
4706 hash_hash_t *hash = hash_table_alloc_bytes (new_size * sizeof *hash); 4676 hash_hash_t *hash = hash_table_alloc_bytes (new_size * sizeof *hash);
4707 memcpy (hash, h->hash, old_size * sizeof *hash); 4677 memcpy (hash, h->hash, old_size * sizeof *hash);
4708 4678
4709 ptrdiff_t old_index_size = h->index_size; 4679 ptrdiff_t old_index_size = hash_table_index_size (h);
4710 ptrdiff_t index_size = hash_index_size (new_size); 4680 ptrdiff_t index_bits = compute_hash_index_bits (new_size);
4681 ptrdiff_t index_size = (ptrdiff_t)1 << index_bits;
4711 hash_idx_t *index = hash_table_alloc_bytes (index_size * sizeof *index); 4682 hash_idx_t *index = hash_table_alloc_bytes (index_size * sizeof *index);
4712 for (ptrdiff_t i = 0; i < index_size; i++) 4683 for (ptrdiff_t i = 0; i < index_size; i++)
4713 index[i] = -1; 4684 index[i] = -1;
4714 4685
4715 h->index_size = index_size; 4686 h->index_bits = index_bits;
4716 h->table_size = new_size; 4687 h->table_size = new_size;
4717 h->next_free = old_size; 4688 h->next_free = old_size;
4718 4689
@@ -4778,18 +4749,19 @@ hash_table_thaw (Lisp_Object hash_table)
4778 h->key_and_value = NULL; 4749 h->key_and_value = NULL;
4779 h->hash = NULL; 4750 h->hash = NULL;
4780 h->next = NULL; 4751 h->next = NULL;
4781 h->index_size = 1; 4752 h->index_bits = 0;
4782 h->index = (hash_idx_t *)empty_hash_index_vector; 4753 h->index = (hash_idx_t *)empty_hash_index_vector;
4783 } 4754 }
4784 else 4755 else
4785 { 4756 {
4786 ptrdiff_t index_size = hash_index_size (size); 4757 ptrdiff_t index_bits = compute_hash_index_bits (size);
4787 h->index_size = index_size; 4758 h->index_bits = index_bits;
4788 4759
4789 h->hash = hash_table_alloc_bytes (size * sizeof *h->hash); 4760 h->hash = hash_table_alloc_bytes (size * sizeof *h->hash);
4790 4761
4791 h->next = hash_table_alloc_bytes (size * sizeof *h->next); 4762 h->next = hash_table_alloc_bytes (size * sizeof *h->next);
4792 4763
4764 ptrdiff_t index_size = hash_table_index_size (h);
4793 h->index = hash_table_alloc_bytes (index_size * sizeof *h->index); 4765 h->index = hash_table_alloc_bytes (index_size * sizeof *h->index);
4794 for (ptrdiff_t i = 0; i < index_size; i++) 4766 for (ptrdiff_t i = 0; i < index_size; i++)
4795 h->index[i] = -1; 4767 h->index[i] = -1;
@@ -4937,7 +4909,8 @@ hash_clear (struct Lisp_Hash_Table *h)
4937 set_hash_value_slot (h, i, Qnil); 4909 set_hash_value_slot (h, i, Qnil);
4938 } 4910 }
4939 4911
4940 for (ptrdiff_t i = 0; i < h->index_size; i++) 4912 ptrdiff_t index_size = hash_table_index_size (h);
4913 for (ptrdiff_t i = 0; i < index_size; i++)
4941 h->index[i] = -1; 4914 h->index[i] = -1;
4942 4915
4943 h->next_free = 0; 4916 h->next_free = 0;
@@ -4976,7 +4949,7 @@ keep_entry_p (hash_table_weakness_t weakness,
4976bool 4949bool
4977sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p) 4950sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
4978{ 4951{
4979 ptrdiff_t n = h->index_size; 4952 ptrdiff_t n = hash_table_index_size (h);
4980 bool marked = false; 4953 bool marked = false;
4981 4954
4982 for (ptrdiff_t bucket = 0; bucket < n; ++bucket) 4955 for (ptrdiff_t bucket = 0; bucket < n; ++bucket)
@@ -5072,24 +5045,52 @@ hash_string (char const *ptr, ptrdiff_t len)
5072 EMACS_UINT hash = len; 5045 EMACS_UINT hash = len;
5073 /* At most 8 steps. We could reuse SXHASH_MAX_LEN, of course, 5046 /* At most 8 steps. We could reuse SXHASH_MAX_LEN, of course,
5074 * but dividing by 8 is cheaper. */ 5047 * but dividing by 8 is cheaper. */
5075 ptrdiff_t step = sizeof hash + ((end - p) >> 3); 5048 ptrdiff_t step = max (sizeof hash, ((end - p) >> 3));
5076 5049
5077 while (p + sizeof hash <= end) 5050 if (p + sizeof hash <= end)
5078 { 5051 {
5052 do
5053 {
5054 EMACS_UINT c;
5055 /* We presume that the compiler will replace this `memcpy` with
5056 a single load/move instruction when applicable. */
5057 memcpy (&c, p, sizeof hash);
5058 p += step;
5059 hash = sxhash_combine (hash, c);
5060 }
5061 while (p + sizeof hash <= end);
5062 /* Hash the last wordful of bytes in the string, because that is
5063 is often the part where strings differ. This may cause some
5064 bytes to be hashed twice but we assume that's not a big problem. */
5079 EMACS_UINT c; 5065 EMACS_UINT c;
5080 /* We presume that the compiler will replace this `memcpy` with 5066 memcpy (&c, end - sizeof c, sizeof c);
5081 a single load/move instruction when applicable. */
5082 memcpy (&c, p, sizeof hash);
5083 p += step;
5084 hash = sxhash_combine (hash, c); 5067 hash = sxhash_combine (hash, c);
5085 } 5068 }
5086 /* A few last bytes may remain (smaller than an EMACS_UINT). */ 5069 else
5087 /* FIXME: We could do this without a loop, but it'd require
5088 endian-dependent code :-( */
5089 while (p < end)
5090 { 5070 {
5091 unsigned char c = *p++; 5071 /* String is shorter than an EMACS_UINT. Use smaller loads. */
5092 hash = sxhash_combine (hash, c); 5072 eassume (p <= end && end - p < sizeof (EMACS_UINT));
5073 EMACS_UINT tail = 0;
5074 verify (sizeof tail <= 8);
5075#if EMACS_INT_MAX > INT32_MAX
5076 if (end - p >= 4)
5077 {
5078 uint32_t c;
5079 memcpy (&c, p, sizeof c);
5080 tail = (tail << (8 * sizeof c)) + c;
5081 p += sizeof c;
5082 }
5083#endif
5084 if (end - p >= 2)
5085 {
5086 uint16_t c;
5087 memcpy (&c, p, sizeof c);
5088 tail = (tail << (8 * sizeof c)) + c;
5089 p += sizeof c;
5090 }
5091 if (p < end)
5092 tail = (tail << 8) + (unsigned char)*p;
5093 hash = sxhash_combine (hash, tail);
5093 } 5094 }
5094 5095
5095 return hash; 5096 return hash;
@@ -5177,7 +5178,7 @@ sxhash_bignum (Lisp_Object bignum)
5177{ 5178{
5178 mpz_t const *n = xbignum_val (bignum); 5179 mpz_t const *n = xbignum_val (bignum);
5179 size_t i, nlimbs = mpz_size (*n); 5180 size_t i, nlimbs = mpz_size (*n);
5180 EMACS_UINT hash = 0; 5181 EMACS_UINT hash = mpz_sgn(*n) < 0;
5181 5182
5182 for (i = 0; i < nlimbs; ++i) 5183 for (i = 0; i < nlimbs; ++i)
5183 hash = sxhash_combine (hash, mpz_getlimbn (*n, i)); 5184 hash = sxhash_combine (hash, mpz_getlimbn (*n, i));
@@ -5247,12 +5248,15 @@ sxhash_obj (Lisp_Object obj, int depth)
5247 hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth)); 5248 hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth));
5248 return hash; 5249 return hash;
5249 } 5250 }
5250 else if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS)
5251 return sxhash_obj (XSYMBOL_WITH_POS (obj)->sym, depth + 1);
5252 else 5251 else
5253 /* Others are 'equal' if they are 'eq', so take their 5252 {
5254 address as hash. */ 5253 if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS)
5255 return XHASH (obj); 5254 obj = XSYMBOL_WITH_POS_SYM (obj);
5255
5256 /* Others are 'equal' if they are 'eq', so take their
5257 address as hash. */
5258 return XHASH (obj);
5259 }
5256 } 5260 }
5257 5261
5258 case Lisp_Cons: 5262 case Lisp_Cons:
@@ -5374,6 +5378,8 @@ mark_fns (void)
5374 } 5378 }
5375} 5379}
5376 5380
5381/* Find the hash_table_test object corresponding to the (bare) symbol TEST,
5382 creating one if none existed. */
5377static struct hash_table_test * 5383static struct hash_table_test *
5378get_hash_table_user_test (Lisp_Object test) 5384get_hash_table_user_test (Lisp_Object test)
5379{ 5385{
@@ -5384,7 +5390,8 @@ get_hash_table_user_test (Lisp_Object test)
5384 Lisp_Object equal_fn = XCAR (prop); 5390 Lisp_Object equal_fn = XCAR (prop);
5385 Lisp_Object hash_fn = XCAR (XCDR (prop)); 5391 Lisp_Object hash_fn = XCAR (XCDR (prop));
5386 struct hash_table_user_test *ut = hash_table_user_tests; 5392 struct hash_table_user_test *ut = hash_table_user_tests;
5387 while (ut && !(EQ (equal_fn, ut->test.user_cmp_function) 5393 while (ut && !(BASE_EQ (test, ut->test.name)
5394 && EQ (equal_fn, ut->test.user_cmp_function)
5388 && EQ (hash_fn, ut->test.user_hash_function))) 5395 && EQ (hash_fn, ut->test.user_hash_function)))
5389 ut = ut->next; 5396 ut = ut->next;
5390 if (!ut) 5397 if (!ut)
@@ -5444,9 +5451,7 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
5444 5451
5445 /* See if there's a `:test TEST' among the arguments. */ 5452 /* See if there's a `:test TEST' among the arguments. */
5446 ptrdiff_t i = get_key_arg (QCtest, nargs, args, used); 5453 ptrdiff_t i = get_key_arg (QCtest, nargs, args, used);
5447 Lisp_Object test = i ? args[i] : Qeql; 5454 Lisp_Object test = i ? maybe_remove_pos_from_symbol (args[i]) : Qeql;
5448 if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (test))
5449 test = SYMBOL_WITH_POS_SYM (test);
5450 const struct hash_table_test *testdesc; 5455 const struct hash_table_test *testdesc;
5451 if (BASE_EQ (test, Qeq)) 5456 if (BASE_EQ (test, Qeq))
5452 testdesc = &hashtest_eq; 5457 testdesc = &hashtest_eq;
@@ -5698,7 +5703,7 @@ DEFUN ("internal--hash-table-histogram",
5698 struct Lisp_Hash_Table *h = check_hash_table (hash_table); 5703 struct Lisp_Hash_Table *h = check_hash_table (hash_table);
5699 ptrdiff_t size = HASH_TABLE_SIZE (h); 5704 ptrdiff_t size = HASH_TABLE_SIZE (h);
5700 ptrdiff_t *freq = xzalloc (size * sizeof *freq); 5705 ptrdiff_t *freq = xzalloc (size * sizeof *freq);
5701 ptrdiff_t index_size = h->index_size; 5706 ptrdiff_t index_size = hash_table_index_size (h);
5702 for (ptrdiff_t i = 0; i < index_size; i++) 5707 for (ptrdiff_t i = 0; i < index_size; i++)
5703 { 5708 {
5704 ptrdiff_t n = 0; 5709 ptrdiff_t n = 0;
@@ -5726,7 +5731,7 @@ Internal use only. */)
5726{ 5731{
5727 struct Lisp_Hash_Table *h = check_hash_table (hash_table); 5732 struct Lisp_Hash_Table *h = check_hash_table (hash_table);
5728 Lisp_Object ret = Qnil; 5733 Lisp_Object ret = Qnil;
5729 ptrdiff_t index_size = h->index_size; 5734 ptrdiff_t index_size = hash_table_index_size (h);
5730 for (ptrdiff_t i = 0; i < index_size; i++) 5735 for (ptrdiff_t i = 0; i < index_size; i++)
5731 { 5736 {
5732 Lisp_Object bucket = Qnil; 5737 Lisp_Object bucket = Qnil;
@@ -5747,7 +5752,7 @@ DEFUN ("internal--hash-table-index-size",
5747 (Lisp_Object hash_table) 5752 (Lisp_Object hash_table)
5748{ 5753{
5749 struct Lisp_Hash_Table *h = check_hash_table (hash_table); 5754 struct Lisp_Hash_Table *h = check_hash_table (hash_table);
5750 return make_int (h->index_size); 5755 return make_int (hash_table_index_size (h));
5751} 5756}
5752 5757
5753 5758
@@ -6615,4 +6620,6 @@ For best results this should end in a space. */);
6615 6620
6616 DEFSYM (Qreal_this_command, "real-this-command"); 6621 DEFSYM (Qreal_this_command, "real-this-command");
6617 DEFSYM (Qfrom__tty_menu_p, "from--tty-menu-p"); 6622 DEFSYM (Qfrom__tty_menu_p, "from--tty-menu-p");
6623 DEFSYM (Qyes_or_no_p, "yes-or-no-p");
6624 DEFSYM (Qy_or_n_p, "y-or-n-p");
6618} 6625}
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/>. */
26#include "termhooks.h" 26#include "termhooks.h"
27 27
28#include <errno.h> 28#include <errno.h>
29#include <fcntl.h>
30
29#include <sys/inotify.h> 31#include <sys/inotify.h>
30#include <sys/ioctl.h> 32#include <sys/ioctl.h>
31 33
@@ -434,7 +436,15 @@ IN_ONESHOT */)
434 436
435 if (inotifyfd < 0) 437 if (inotifyfd < 0)
436 { 438 {
439#ifdef HAVE_INOTIFY_INIT1
437 inotifyfd = inotify_init1 (IN_NONBLOCK | IN_CLOEXEC); 440 inotifyfd = inotify_init1 (IN_NONBLOCK | IN_CLOEXEC);
441#else /* !HAVE_INOTIFY_INIT1 */
442 /* This is prey to race conditions with other threads calling
443 exec. */
444 inotifyfd = inotify_init ();
445 fcntl (inotifyfd, F_SETFL, O_NONBLOCK);
446 fcntl (inotifyfd, F_SETFD, O_CLOEXEC);
447#endif /* HAVE_INOTIFY_INIT1 */
438 if (inotifyfd < 0) 448 if (inotifyfd < 0)
439 report_file_notify_error ("File watching is not available", Qnil); 449 report_file_notify_error ("File watching is not available", Qnil);
440 watch_list = Qnil; 450 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)
580 idx = make_fixnum (SCHARS (KVAR (current_kboard, echo_string)) - 1); 580 idx = make_fixnum (SCHARS (KVAR (current_kboard, echo_string)) - 1);
581 last_char = Faref (KVAR (current_kboard, echo_string), idx); 581 last_char = Faref (KVAR (current_kboard, echo_string), idx);
582 582
583 if (XFIXNUM (last_char) == '-' && XFIXNUM (prev_char) != ' ') 583 if ((XFIXNUM (last_char) == '-' && XFIXNUM (prev_char) != ' ')
584 /* Or a keystroke help message. */
585 || (echo_keystrokes_help
586 && XFIXNUM (last_char) == ')' && XFIXNUM (prev_char) == 'p'))
584 return; 587 return;
585 } 588 }
586 589
@@ -589,6 +592,12 @@ echo_dash (void)
589 AUTO_STRING (dash, "-"); 592 AUTO_STRING (dash, "-");
590 kset_echo_string (current_kboard, 593 kset_echo_string (current_kboard,
591 concat2 (KVAR (current_kboard, echo_string), dash)); 594 concat2 (KVAR (current_kboard, echo_string), dash));
595
596 if (echo_keystrokes_help)
597 kset_echo_string (current_kboard,
598 calln (Qhelp__append_keystrokes_help,
599 KVAR (current_kboard, echo_string)));
600
592 echo_now (); 601 echo_now ();
593} 602}
594 603
@@ -1067,8 +1076,9 @@ Default value of `command-error-function'. */)
1067 write to stderr and quit. In daemon mode, there are 1076 write to stderr and quit. In daemon mode, there are
1068 many other potential errors that do not prevent frames 1077 many other potential errors that do not prevent frames
1069 from being created, so continuing as normal is better in 1078 from being created, so continuing as normal is better in
1070 that case. */ 1079 that case, as long as the daemon has actually finished
1071 || (!IS_DAEMON && FRAME_INITIAL_P (sf)) 1080 initialization. */
1081 || (!(IS_DAEMON && !DAEMON_RUNNING) && FRAME_INITIAL_P (sf))
1072 || noninteractive)) 1082 || noninteractive))
1073 { 1083 {
1074 print_error_message (data, Qexternal_debugging_output, 1084 print_error_message (data, Qexternal_debugging_output,
@@ -12948,6 +12958,8 @@ syms_of_keyboard (void)
12948 12958
12949 DEFSYM (Qhelp_key_binding, "help-key-binding"); 12959 DEFSYM (Qhelp_key_binding, "help-key-binding");
12950 12960
12961 DEFSYM (Qhelp__append_keystrokes_help, "help--append-keystrokes-help");
12962
12951 DEFSYM (Qecho_keystrokes, "echo-keystrokes"); 12963 DEFSYM (Qecho_keystrokes, "echo-keystrokes");
12952 12964
12953 Fset (Qinput_method_exit_on_first_char, Qnil); 12965 Fset (Qinput_method_exit_on_first_char, Qnil);
@@ -13223,11 +13235,17 @@ Emacs also does a garbage collection if that seems to be warranted. */);
13223 XSETFASTINT (Vauto_save_timeout, 30); 13235 XSETFASTINT (Vauto_save_timeout, 30);
13224 13236
13225 DEFVAR_LISP ("echo-keystrokes", Vecho_keystrokes, 13237 DEFVAR_LISP ("echo-keystrokes", Vecho_keystrokes,
13226 doc: /* Nonzero means echo unfinished commands after this many seconds of pause. 13238 doc: /* Nonzero means echo unfinished commands after this many seconds of pause.
13227The value may be integer or floating point. 13239The value may be integer or floating point.
13228If the value is zero, don't echo at all. */); 13240If the value is zero, don't echo at all. */);
13229 Vecho_keystrokes = make_fixnum (1); 13241 Vecho_keystrokes = make_fixnum (1);
13230 13242
13243 DEFVAR_BOOL ("echo-keystrokes-help", echo_keystrokes_help,
13244 doc: /* Whether to append help text to echoed commands.
13245When non-nil, a reference to `C-h' is printed after echoed
13246keystrokes. */);
13247 echo_keystrokes_help = true;
13248
13231 DEFVAR_LISP ("polling-period", Vpolling_period, 13249 DEFVAR_LISP ("polling-period", Vpolling_period,
13232 doc: /* Interval between polling for input during Lisp execution. 13250 doc: /* Interval between polling for input during Lisp execution.
13233The reason for polling is to make C-g work to stop a running program. 13251The 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;
330 without worrying about the implementations diverging, since 330 without worrying about the implementations diverging, since
331 lisp_h_OP defines the actual implementation. The lisp_h_OP macros 331 lisp_h_OP defines the actual implementation. The lisp_h_OP macros
332 are intended to be private to this include file, and should not be 332 are intended to be private to this include file, and should not be
333 used elsewhere. 333 used elsewhere. They should evaluate each argument exactly once,
334 so that they behave like their functional counterparts.
334 335
335 FIXME: Remove the lisp_h_OP macros, and define just the inline OP 336 FIXME: Remove the lisp_h_OP macros, and define just the inline OP
336 functions, once "gcc -Og" (new to GCC 4.8) or equivalent works well 337 functions, once "gcc -Og" (new to GCC 4.8) or equivalent works well
@@ -372,39 +373,12 @@ typedef EMACS_INT Lisp_Word;
372# define lisp_h_Qnil {0} 373# define lisp_h_Qnil {0}
373#endif 374#endif
374 375
375#define lisp_h_PSEUDOVECTORP(a,code) \
376 (lisp_h_VECTORLIKEP (a) \
377 && ((XUNTAG (a, Lisp_Vectorlike, union vectorlike_header)->size \
378 & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \
379 == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS))))
380
381#define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x) 376#define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x)
382#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) 377#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
383#define lisp_h_CHECK_TYPE(ok, predicate, x) \ 378#define lisp_h_CHECK_TYPE(ok, predicate, x) \
384 ((ok) ? (void) 0 : wrong_type_argument (predicate, x)) 379 ((ok) ? (void) 0 : wrong_type_argument (predicate, x))
385#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons) 380#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons)
386#define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y)) 381#define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y))
387#define lisp_h_BASE2_EQ(x, y) \
388 (BASE_EQ (x, y) \
389 || (symbols_with_pos_enabled \
390 && SYMBOL_WITH_POS_P (x) \
391 && BASE_EQ (XSYMBOL_WITH_POS (x)->sym, y)))
392
393/* FIXME: Do we really need to inline the whole thing?
394 * What about keeping the part after `symbols_with_pos_enabled` in
395 * a separate function? */
396#define lisp_h_EQ(x, y) \
397 (XLI (x) == XLI (y) \
398 || (symbols_with_pos_enabled \
399 && (SYMBOL_WITH_POS_P (x) \
400 ? (BARE_SYMBOL_P (y) \
401 ? XLI (XSYMBOL_WITH_POS (x)->sym) == XLI (y) \
402 : (SYMBOL_WITH_POS_P (y) \
403 && (XLI (XSYMBOL_WITH_POS (x)->sym) \
404 == XLI (XSYMBOL_WITH_POS (y)->sym)))) \
405 : (SYMBOL_WITH_POS_P (y) \
406 && BARE_SYMBOL_P (x) \
407 && (XLI (x) == XLI (XSYMBOL_WITH_POS (y)->sym))))))
408 382
409#define lisp_h_FIXNUMP(x) \ 383#define lisp_h_FIXNUMP(x) \
410 (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ 384 (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
@@ -412,18 +386,11 @@ typedef EMACS_INT Lisp_Word;
412 & ((1 << INTTYPEBITS) - 1))) 386 & ((1 << INTTYPEBITS) - 1)))
413#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float) 387#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float)
414#define lisp_h_NILP(x) BASE_EQ (x, Qnil) 388#define lisp_h_NILP(x) BASE_EQ (x, Qnil)
415#define lisp_h_SET_SYMBOL_VAL(sym, v) \
416 (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \
417 (sym)->u.s.val.value = (v))
418#define lisp_h_SYMBOL_CONSTANT_P(sym) \ 389#define lisp_h_SYMBOL_CONSTANT_P(sym) \
419 (XSYMBOL (sym)->u.s.trapped_write == SYMBOL_NOWRITE) 390 (XSYMBOL (sym)->u.s.trapped_write == SYMBOL_NOWRITE)
420#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write) 391#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write)
421#define lisp_h_SYMBOL_VAL(sym) \
422 (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value)
423#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP (x, PVEC_SYMBOL_WITH_POS) 392#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP (x, PVEC_SYMBOL_WITH_POS)
424#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP (x, Lisp_Symbol) 393#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP (x, Lisp_Symbol)
425#define lisp_h_SYMBOLP(x) \
426 (BARE_SYMBOL_P (x) || (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)))
427#define lisp_h_TAGGEDP(a, tag) \ 394#define lisp_h_TAGGEDP(a, tag) \
428 (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ 395 (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
429 - (unsigned) (tag)) \ 396 - (unsigned) (tag)) \
@@ -431,8 +398,6 @@ typedef EMACS_INT Lisp_Word;
431#define lisp_h_VECTORLIKEP(x) TAGGEDP (x, Lisp_Vectorlike) 398#define lisp_h_VECTORLIKEP(x) TAGGEDP (x, Lisp_Vectorlike)
432#define lisp_h_XCAR(c) XCONS (c)->u.s.car 399#define lisp_h_XCAR(c) XCONS (c)->u.s.car
433#define lisp_h_XCDR(c) XCONS (c)->u.s.u.cdr 400#define lisp_h_XCDR(c) XCONS (c)->u.s.u.cdr
434#define lisp_h_XCONS(a) \
435 (eassert (CONSP (a)), XUNTAG (a, Lisp_Cons, struct Lisp_Cons))
436#define lisp_h_XHASH(a) XUFIXNUM_RAW (a) 401#define lisp_h_XHASH(a) XUFIXNUM_RAW (a)
437#if USE_LSB_TAG 402#if USE_LSB_TAG
438# define lisp_h_make_fixnum_wrap(n) \ 403# define lisp_h_make_fixnum_wrap(n) \
@@ -474,20 +439,15 @@ typedef EMACS_INT Lisp_Word;
474# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) 439# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
475# define CONSP(x) lisp_h_CONSP (x) 440# define CONSP(x) lisp_h_CONSP (x)
476# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y) 441# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y)
477# define BASE2_EQ(x, y) lisp_h_BASE2_EQ (x, y)
478# define FLOATP(x) lisp_h_FLOATP (x) 442# define FLOATP(x) lisp_h_FLOATP (x)
479# define FIXNUMP(x) lisp_h_FIXNUMP (x) 443# define FIXNUMP(x) lisp_h_FIXNUMP (x)
480# define NILP(x) lisp_h_NILP (x) 444# define NILP(x) lisp_h_NILP (x)
481# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v)
482# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) 445# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
483# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym) 446# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym)
484# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
485/* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than once. */
486# define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag) 447# define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag)
487# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) 448# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
488# define XCAR(c) lisp_h_XCAR (c) 449# define XCAR(c) lisp_h_XCAR (c)
489# define XCDR(c) lisp_h_XCDR (c) 450# define XCDR(c) lisp_h_XCDR (c)
490# define XCONS(a) lisp_h_XCONS (a)
491# define XHASH(a) lisp_h_XHASH (a) 451# define XHASH(a) lisp_h_XHASH (a)
492# if USE_LSB_TAG 452# if USE_LSB_TAG
493# define make_fixnum(n) lisp_h_make_fixnum (n) 453# define make_fixnum(n) lisp_h_make_fixnum (n)
@@ -518,6 +478,16 @@ typedef EMACS_INT Lisp_Word;
518#endif 478#endif
519 479
520 480
481/* Lisp_Object tagging scheme:
482 Tag location
483 Upper bits Lower bits Type Payload
484 000....... .......000 symbol offset from lispsym to struct Lisp_Symbol
485 001....... .......001 unused
486 01........ ........10 fixnum signed integer of FIXNUM_BITS
487 110....... .......011 cons pointer to struct Lisp_Cons
488 100....... .......100 string pointer to struct Lisp_String
489 101....... .......101 vectorlike pointer to union vectorlike_header
490 111....... .......111 float pointer to struct Lisp_Float */
521enum Lisp_Type 491enum Lisp_Type
522 { 492 {
523 /* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */ 493 /* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */
@@ -1062,6 +1032,7 @@ enum pvec_type
1062 PVEC_BOOL_VECTOR, 1032 PVEC_BOOL_VECTOR,
1063 PVEC_BUFFER, 1033 PVEC_BUFFER,
1064 PVEC_HASH_TABLE, 1034 PVEC_HASH_TABLE,
1035 PVEC_OBARRAY,
1065 PVEC_TERMINAL, 1036 PVEC_TERMINAL,
1066 PVEC_WINDOW_CONFIGURATION, 1037 PVEC_WINDOW_CONFIGURATION,
1067 PVEC_SUBR, 1038 PVEC_SUBR,
@@ -1121,7 +1092,10 @@ enum More_Lisp_Bits
1121INLINE bool 1092INLINE bool
1122PSEUDOVECTORP (Lisp_Object a, int code) 1093PSEUDOVECTORP (Lisp_Object a, int code)
1123{ 1094{
1124 return lisp_h_PSEUDOVECTORP (a, code); 1095 return (lisp_h_VECTORLIKEP (a)
1096 && ((XUNTAG (a, Lisp_Vectorlike, union vectorlike_header)->size
1097 & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK))
1098 == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))));
1125} 1099}
1126 1100
1127INLINE bool 1101INLINE bool
@@ -1137,9 +1111,10 @@ INLINE bool
1137} 1111}
1138 1112
1139INLINE bool 1113INLINE bool
1140(SYMBOLP) (Lisp_Object x) 1114SYMBOLP (Lisp_Object x)
1141{ 1115{
1142 return lisp_h_SYMBOLP (x); 1116 return (BARE_SYMBOL_P (x)
1117 || (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)));
1143} 1118}
1144 1119
1145INLINE struct Lisp_Symbol_With_Pos * 1120INLINE struct Lisp_Symbol_With_Pos *
@@ -1149,6 +1124,27 @@ XSYMBOL_WITH_POS (Lisp_Object a)
1149 return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); 1124 return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
1150} 1125}
1151 1126
1127INLINE Lisp_Object
1128XSYMBOL_WITH_POS_SYM (Lisp_Object a)
1129{
1130 Lisp_Object sym = XSYMBOL_WITH_POS (a)->sym;
1131 eassume (BARE_SYMBOL_P (sym));
1132 return sym;
1133}
1134
1135INLINE Lisp_Object
1136XSYMBOL_WITH_POS_POS (Lisp_Object a)
1137{
1138 return XSYMBOL_WITH_POS (a)->pos;
1139}
1140
1141INLINE Lisp_Object
1142maybe_remove_pos_from_symbol (Lisp_Object x)
1143{
1144 return (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)
1145 ? XSYMBOL_WITH_POS_SYM (x) : x);
1146}
1147
1152INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED 1148INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
1153XBARE_SYMBOL (Lisp_Object a) 1149XBARE_SYMBOL (Lisp_Object a)
1154{ 1150{
@@ -1163,8 +1159,8 @@ XSYMBOL (Lisp_Object a)
1163{ 1159{
1164 if (!BARE_SYMBOL_P (a)) 1160 if (!BARE_SYMBOL_P (a))
1165 { 1161 {
1166 eassert (symbols_with_pos_enabled); 1162 eassume (symbols_with_pos_enabled);
1167 a = XSYMBOL_WITH_POS (a)->sym; 1163 a = XSYMBOL_WITH_POS_SYM (a);
1168 } 1164 }
1169 return XBARE_SYMBOL (a); 1165 return XBARE_SYMBOL (a);
1170} 1166}
@@ -1352,20 +1348,15 @@ INLINE bool
1352 return lisp_h_BASE_EQ (x, y); 1348 return lisp_h_BASE_EQ (x, y);
1353} 1349}
1354 1350
1355/* Return true if X and Y are the same object, reckoning X to be the
1356 same as a bare symbol Y if X is Y with position. */
1357INLINE bool
1358(BASE2_EQ) (Lisp_Object x, Lisp_Object y)
1359{
1360 return lisp_h_BASE2_EQ (x, y);
1361}
1362
1363/* Return true if X and Y are the same object, reckoning a symbol with 1351/* Return true if X and Y are the same object, reckoning a symbol with
1364 position as being the same as the bare symbol. */ 1352 position as being the same as the bare symbol. */
1365INLINE bool 1353INLINE bool
1366(EQ) (Lisp_Object x, Lisp_Object y) 1354EQ (Lisp_Object x, Lisp_Object y)
1367{ 1355{
1368 return lisp_h_EQ (x, y); 1356 return BASE_EQ ((symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)
1357 ? XSYMBOL_WITH_POS_SYM (x) : x),
1358 (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (y)
1359 ? XSYMBOL_WITH_POS_SYM (y) : y));
1369} 1360}
1370 1361
1371INLINE intmax_t 1362INLINE intmax_t
@@ -1389,7 +1380,6 @@ make_lisp_ptr (void *ptr, enum Lisp_Type type)
1389#define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons)) 1380#define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons))
1390#define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike)) 1381#define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike))
1391#define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String)) 1382#define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String))
1392#define XSETSYMBOL(a, b) ((a) = make_lisp_symbol (b))
1393#define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float)) 1383#define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float))
1394 1384
1395/* Return a Lisp_Object value that does not correspond to any object. 1385/* Return a Lisp_Object value that does not correspond to any object.
@@ -1510,9 +1500,10 @@ CHECK_CONS (Lisp_Object x)
1510} 1500}
1511 1501
1512INLINE struct Lisp_Cons * 1502INLINE struct Lisp_Cons *
1513(XCONS) (Lisp_Object a) 1503XCONS (Lisp_Object a)
1514{ 1504{
1515 return lisp_h_XCONS (a); 1505 eassert (CONSP (a));
1506 return XUNTAG (a, Lisp_Cons, struct Lisp_Cons);
1516} 1507}
1517 1508
1518/* Take the car or cdr of something known to be a cons cell. */ 1509/* Take the car or cdr of something known to be a cons cell. */
@@ -2297,9 +2288,10 @@ typedef jmp_buf sys_jmp_buf;
2297/* Value is name of symbol. */ 2288/* Value is name of symbol. */
2298 2289
2299INLINE Lisp_Object 2290INLINE Lisp_Object
2300(SYMBOL_VAL) (struct Lisp_Symbol *sym) 2291SYMBOL_VAL (struct Lisp_Symbol *sym)
2301{ 2292{
2302 return lisp_h_SYMBOL_VAL (sym); 2293 eassert (sym->u.s.redirect == SYMBOL_PLAINVAL);
2294 return sym->u.s.val.value;
2303} 2295}
2304 2296
2305INLINE struct Lisp_Symbol * 2297INLINE struct Lisp_Symbol *
@@ -2322,9 +2314,10 @@ SYMBOL_FWD (struct Lisp_Symbol *sym)
2322} 2314}
2323 2315
2324INLINE void 2316INLINE void
2325(SET_SYMBOL_VAL) (struct Lisp_Symbol *sym, Lisp_Object v) 2317SET_SYMBOL_VAL (struct Lisp_Symbol *sym, Lisp_Object v)
2326{ 2318{
2327 lisp_h_SET_SYMBOL_VAL (sym, v); 2319 eassert (sym->u.s.redirect == SYMBOL_PLAINVAL);
2320 sym->u.s.val.value = v;
2328} 2321}
2329 2322
2330INLINE void 2323INLINE void
@@ -2393,6 +2386,118 @@ INLINE int
2393 definition is done by lread.c's define_symbol. */ 2386 definition is done by lread.c's define_symbol. */
2394#define DEFSYM(sym, name) /* empty */ 2387#define DEFSYM(sym, name) /* empty */
2395 2388
2389
2390struct Lisp_Obarray
2391{
2392 union vectorlike_header header;
2393
2394 /* Array of 2**size_bits values, each being either a (bare) symbol or
2395 the fixnum 0. The symbols for each bucket are chained via
2396 their s.next field. */
2397 Lisp_Object *buckets;
2398
2399 unsigned size_bits; /* log2(size of buckets vector) */
2400 unsigned count; /* number of symbols in obarray */
2401};
2402
2403INLINE bool
2404OBARRAYP (Lisp_Object a)
2405{
2406 return PSEUDOVECTORP (a, PVEC_OBARRAY);
2407}
2408
2409INLINE struct Lisp_Obarray *
2410XOBARRAY (Lisp_Object a)
2411{
2412 eassert (OBARRAYP (a));
2413 return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Obarray);
2414}
2415
2416INLINE void
2417CHECK_OBARRAY (Lisp_Object x)
2418{
2419 CHECK_TYPE (OBARRAYP (x), Qobarrayp, x);
2420}
2421
2422INLINE Lisp_Object
2423make_lisp_obarray (struct Lisp_Obarray *o)
2424{
2425 eassert (PSEUDOVECTOR_TYPEP (&o->header, PVEC_OBARRAY));
2426 return make_lisp_ptr (o, Lisp_Vectorlike);
2427}
2428
2429INLINE ptrdiff_t
2430obarray_size (const struct Lisp_Obarray *o)
2431{
2432 return (ptrdiff_t)1 << o->size_bits;
2433}
2434
2435Lisp_Object check_obarray_slow (Lisp_Object);
2436
2437/* Return an obarray object from OBARRAY or signal an error. */
2438INLINE Lisp_Object
2439check_obarray (Lisp_Object obarray)
2440{
2441 return OBARRAYP (obarray) ? obarray : check_obarray_slow (obarray);
2442}
2443
2444/* Obarray iterator state. Don't access these members directly.
2445 The iterator functions must be called in the order followed by DOOBARRAY. */
2446typedef struct {
2447 struct Lisp_Obarray *o;
2448 ptrdiff_t idx; /* Current bucket index. */
2449 struct Lisp_Symbol *symbol; /* Current symbol, or NULL if at end
2450 of current bucket. */
2451} obarray_iter_t;
2452
2453INLINE obarray_iter_t
2454make_obarray_iter (struct Lisp_Obarray *oa)
2455{
2456 return (obarray_iter_t){.o = oa, .idx = -1, .symbol = NULL};
2457}
2458
2459/* Whether IT has reached the end and there are no more symbols.
2460 If true, IT is dead and cannot be used any more. */
2461INLINE bool
2462obarray_iter_at_end (obarray_iter_t *it)
2463{
2464 if (it->symbol)
2465 return false;
2466 ptrdiff_t size = obarray_size (it->o);
2467 while (++it->idx < size)
2468 {
2469 Lisp_Object obj = it->o->buckets[it->idx];
2470 if (!BASE_EQ (obj, make_fixnum (0)))
2471 {
2472 it->symbol = XBARE_SYMBOL (obj);
2473 return false;
2474 }
2475 }
2476 return true;
2477}
2478
2479/* Advance IT to the next symbol if any. */
2480INLINE void
2481obarray_iter_step (obarray_iter_t *it)
2482{
2483 it->symbol = it->symbol->u.s.next;
2484}
2485
2486/* The Lisp symbol at IT, if obarray_iter_at_end returned false. */
2487INLINE Lisp_Object
2488obarray_iter_symbol (obarray_iter_t *it)
2489{
2490 return make_lisp_symbol (it->symbol);
2491}
2492
2493/* Iterate IT over the symbols of the obarray OA.
2494 The body shouldn't add or remove symbols in OA, but disobeying that rule
2495 only risks symbols to be iterated more than once or not at all,
2496 not crashes or data corruption. */
2497#define DOOBARRAY(oa, it) \
2498 for (obarray_iter_t it = make_obarray_iter (oa); \
2499 !obarray_iter_at_end (&it); obarray_iter_step (&it))
2500
2396 2501
2397/*********************************************************************** 2502/***********************************************************************
2398 Hash Tables 2503 Hash Tables
@@ -2475,14 +2580,11 @@ struct Lisp_Hash_Table
2475 The table is physically split into three vectors (hash, next, 2580 The table is physically split into three vectors (hash, next,
2476 key_and_value) which may or may not be beneficial. */ 2581 key_and_value) which may or may not be beneficial. */
2477 2582
2478 hash_idx_t index_size; /* Size of the index vector. */
2479 hash_idx_t table_size; /* Size of the next and hash vectors. */
2480
2481 /* Bucket vector. An entry of -1 indicates no item is present, 2583 /* Bucket vector. An entry of -1 indicates no item is present,
2482 and a nonnegative entry is the index of the first item in 2584 and a nonnegative entry is the index of the first item in
2483 a collision chain. 2585 a collision chain.
2484 This vector is index_size entries long. 2586 This vector is 2**index_bits entries long.
2485 If index_size is 1 (and table_size is 0), then this is the 2587 If index_bits is 0 (and table_size is 0), then this is the
2486 constant read-only vector {-1}, shared between all instances. 2588 constant read-only vector {-1}, shared between all instances.
2487 Otherwise it is heap-allocated. */ 2589 Otherwise it is heap-allocated. */
2488 hash_idx_t *index; 2590 hash_idx_t *index;
@@ -2514,20 +2616,24 @@ struct Lisp_Hash_Table
2514 /* Index of first free entry in free list, or -1 if none. */ 2616 /* Index of first free entry in free list, or -1 if none. */
2515 hash_idx_t next_free; 2617 hash_idx_t next_free;
2516 2618
2619 hash_idx_t table_size; /* Size of the next and hash vectors. */
2620
2621 unsigned char index_bits; /* log2 (size of the index vector). */
2622
2517 /* Weakness of the table. */ 2623 /* Weakness of the table. */
2518 hash_table_weakness_t weakness : 8; 2624 hash_table_weakness_t weakness : 3;
2519 2625
2520 /* Hash table test (only used when frozen in dump) */ 2626 /* Hash table test (only used when frozen in dump) */
2521 hash_table_std_test_t frozen_test : 8; 2627 hash_table_std_test_t frozen_test : 2;
2522 2628
2523 /* True if the table can be purecopied. The table cannot be 2629 /* True if the table can be purecopied. The table cannot be
2524 changed afterwards. */ 2630 changed afterwards. */
2525 bool purecopy; 2631 bool_bf purecopy : 1;
2526 2632
2527 /* True if the table is mutable. Ordinarily tables are mutable, but 2633 /* True if the table is mutable. Ordinarily tables are mutable, but
2528 pure tables are not, and while a table is being mutated it is 2634 pure tables are not, and while a table is being mutated it is
2529 immutable for recursive attempts to mutate it. */ 2635 immutable for recursive attempts to mutate it. */
2530 bool mutable; 2636 bool_bf mutable : 1;
2531 2637
2532 /* Next weak hash table if this is a weak hash table. The head of 2638 /* Next weak hash table if this is a weak hash table. The head of
2533 the list is in weak_hash_tables. Used only during garbage 2639 the list is in weak_hash_tables. Used only during garbage
@@ -2563,8 +2669,12 @@ XHASH_TABLE (Lisp_Object a)
2563 return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Hash_Table); 2669 return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Hash_Table);
2564} 2670}
2565 2671
2566#define XSET_HASH_TABLE(VAR, PTR) \ 2672INLINE Lisp_Object
2567 XSETPSEUDOVECTOR (VAR, PTR, PVEC_HASH_TABLE) 2673make_lisp_hash_table (struct Lisp_Hash_Table *h)
2674{
2675 eassert (PSEUDOVECTOR_TYPEP (&h->header, PVEC_HASH_TABLE));
2676 return make_lisp_ptr (h, Lisp_Vectorlike);
2677}
2568 2678
2569/* Value is the key part of entry IDX in hash table H. */ 2679/* Value is the key part of entry IDX in hash table H. */
2570INLINE Lisp_Object 2680INLINE Lisp_Object
@@ -2597,6 +2707,13 @@ HASH_TABLE_SIZE (const struct Lisp_Hash_Table *h)
2597 return h->table_size; 2707 return h->table_size;
2598} 2708}
2599 2709
2710/* Size of the index vector in hash table H. */
2711INLINE ptrdiff_t
2712hash_table_index_size (const struct Lisp_Hash_Table *h)
2713{
2714 return (ptrdiff_t)1 << h->index_bits;
2715}
2716
2600/* Hash value for KEY in hash table H. */ 2717/* Hash value for KEY in hash table H. */
2601INLINE hash_hash_t 2718INLINE hash_hash_t
2602hash_from_key (struct Lisp_Hash_Table *h, Lisp_Object key) 2719hash_from_key (struct Lisp_Hash_Table *h, Lisp_Object key)
@@ -2661,6 +2778,28 @@ SXHASH_REDUCE (EMACS_UINT x)
2661 return (x ^ x >> (EMACS_INT_WIDTH - FIXNUM_BITS)) & INTMASK; 2778 return (x ^ x >> (EMACS_INT_WIDTH - FIXNUM_BITS)) & INTMASK;
2662} 2779}
2663 2780
2781/* Reduce an EMACS_UINT hash value to hash_hash_t. */
2782INLINE hash_hash_t
2783reduce_emacs_uint_to_hash_hash (EMACS_UINT x)
2784{
2785 verify (sizeof x <= 2 * sizeof (hash_hash_t));
2786 return (sizeof x == sizeof (hash_hash_t)
2787 ? x
2788 : x ^ (x >> (8 * (sizeof x - sizeof (hash_hash_t)))));
2789}
2790
2791/* Reduce HASH to a value BITS wide. */
2792INLINE ptrdiff_t
2793knuth_hash (hash_hash_t hash, unsigned bits)
2794{
2795 /* Knuth multiplicative hashing, tailored for 32-bit indices
2796 (avoiding a 64-bit multiply). */
2797 uint32_t alpha = 2654435769; /* 2**32/phi */
2798 /* Note the cast to uint64_t, to make it work for bits=0. */
2799 return (uint64_t)((uint32_t)hash * alpha) >> (32 - bits);
2800}
2801
2802
2664struct Lisp_Marker 2803struct Lisp_Marker
2665{ 2804{
2666 union vectorlike_header header; 2805 union vectorlike_header header;
@@ -2839,22 +2978,6 @@ XOVERLAY (Lisp_Object a)
2839 return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay); 2978 return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
2840} 2979}
2841 2980
2842INLINE Lisp_Object
2843SYMBOL_WITH_POS_SYM (Lisp_Object a)
2844{
2845 if (!SYMBOL_WITH_POS_P (a))
2846 wrong_type_argument (Qsymbol_with_pos_p, a);
2847 return XSYMBOL_WITH_POS (a)->sym;
2848}
2849
2850INLINE Lisp_Object
2851SYMBOL_WITH_POS_POS (Lisp_Object a)
2852{
2853 if (!SYMBOL_WITH_POS_P (a))
2854 wrong_type_argument (Qsymbol_with_pos_p, a);
2855 return XSYMBOL_WITH_POS (a)->pos;
2856}
2857
2858INLINE bool 2981INLINE bool
2859USER_PTRP (Lisp_Object x) 2982USER_PTRP (Lisp_Object x)
2860{ 2983{
@@ -4596,7 +4719,6 @@ extern ptrdiff_t evxprintf (char **, ptrdiff_t *, char *, ptrdiff_t,
4596 ATTRIBUTE_FORMAT_PRINTF (5, 0); 4719 ATTRIBUTE_FORMAT_PRINTF (5, 0);
4597 4720
4598/* Defined in lread.c. */ 4721/* Defined in lread.c. */
4599extern Lisp_Object check_obarray (Lisp_Object);
4600extern Lisp_Object intern_1 (const char *, ptrdiff_t); 4722extern Lisp_Object intern_1 (const char *, ptrdiff_t);
4601extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t); 4723extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t);
4602extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object); 4724extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object);
@@ -4802,7 +4924,7 @@ extern void syms_of_editfns (void);
4802 4924
4803/* Defined in buffer.c. */ 4925/* Defined in buffer.c. */
4804extern bool mouse_face_overlay_overlaps (Lisp_Object); 4926extern bool mouse_face_overlay_overlaps (Lisp_Object);
4805extern Lisp_Object disable_line_numbers_overlay_at_eob (void); 4927extern bool disable_line_numbers_overlay_at_eob (void);
4806extern AVOID nsberror (Lisp_Object); 4928extern AVOID nsberror (Lisp_Object);
4807extern void adjust_overlays_for_insert (ptrdiff_t, ptrdiff_t, bool); 4929extern void adjust_overlays_for_insert (ptrdiff_t, ptrdiff_t, bool);
4808extern void adjust_overlays_for_delete (ptrdiff_t, ptrdiff_t); 4930extern void adjust_overlays_for_delete (ptrdiff_t, ptrdiff_t);
@@ -5030,6 +5152,7 @@ extern bool build_details;
5030/* 0 not a daemon, 1 foreground daemon, 2 background daemon. */ 5152/* 0 not a daemon, 1 foreground daemon, 2 background daemon. */
5031extern int daemon_type; 5153extern int daemon_type;
5032#define IS_DAEMON (daemon_type != 0) 5154#define IS_DAEMON (daemon_type != 0)
5155/* Non-zero means daemon-initialized has not yet been called. */
5033#define DAEMON_RUNNING (daemon_type >= 0) 5156#define DAEMON_RUNNING (daemon_type >= 0)
5034#else /* WINDOWSNT */ 5157#else /* WINDOWSNT */
5035extern void *w32_daemon_event; 5158extern void *w32_daemon_event;
@@ -5550,7 +5673,7 @@ safe_free_unbind_to (specpdl_ref count, specpdl_ref sa_count, Lisp_Object val)
5550 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109577 5673 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109577
5551 which causes GCC to mistakenly complain about the 5674 which causes GCC to mistakenly complain about the
5552 memory allocation in SAFE_ALLOCA_LISP_EXTRA. */ 5675 memory allocation in SAFE_ALLOCA_LISP_EXTRA. */
5553#if GNUC_PREREQ (13, 0, 0) 5676#if GNUC_PREREQ (13, 0, 0) && !GNUC_PREREQ (14, 0, 0)
5554# pragma GCC diagnostic ignored "-Wanalyzer-allocation-size" 5677# pragma GCC diagnostic ignored "-Wanalyzer-allocation-size"
5555#endif 5678#endif
5556 5679
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)
2369 front of load-history, the most-recently-loaded position. Also 2369 front of load-history, the most-recently-loaded position. Also
2370 do this if we didn't find an existing member for the file. */ 2370 do this if we didn't find an existing member for the file. */
2371 if (entire || !foundit) 2371 if (entire || !foundit)
2372 Vload_history = Fcons (Fnreverse (Vcurrent_load_list), 2372 {
2373 Vload_history); 2373 Lisp_Object tem = Fnreverse (Vcurrent_load_list);
2374 eassert (EQ (filename, Fcar (tem)));
2375 Vload_history = Fcons (tem, Vload_history);
2376 /* FIXME: There should be an unbind_to right after calling us which
2377 should re-establish the previous value of Vcurrent_load_list. */
2378 Vcurrent_load_list = Qt;
2379 }
2374} 2380}
2375 2381
2376static void 2382static void
@@ -2437,11 +2443,13 @@ readevalloop (Lisp_Object readcharfun,
2437 bool whole_buffer = 0; 2443 bool whole_buffer = 0;
2438 /* True on the first time around. */ 2444 /* True on the first time around. */
2439 bool first_sexp = 1; 2445 bool first_sexp = 1;
2440 Lisp_Object macroexpand = intern ("internal-macroexpand-for-load"); 2446 Lisp_Object macroexpand;
2441 2447
2442 if (!NILP (sourcename)) 2448 if (!NILP (sourcename))
2443 CHECK_STRING (sourcename); 2449 CHECK_STRING (sourcename);
2444 2450
2451 macroexpand = Qinternal_macroexpand_for_load;
2452
2445 if (NILP (Ffboundp (macroexpand)) 2453 if (NILP (Ffboundp (macroexpand))
2446 || (STRINGP (sourcename) && suffix_p (sourcename, ".elc"))) 2454 || (STRINGP (sourcename) && suffix_p (sourcename, ".elc")))
2447 /* Don't macroexpand before the corresponding function is defined 2455 /* Don't macroexpand before the corresponding function is defined
@@ -3481,6 +3489,8 @@ vector_from_rev_list (Lisp_Object elems)
3481 return obj; 3489 return obj;
3482} 3490}
3483 3491
3492static Lisp_Object get_lazy_string (Lisp_Object val);
3493
3484static Lisp_Object 3494static Lisp_Object
3485bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun) 3495bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun)
3486{ 3496{
@@ -3488,49 +3498,50 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun)
3488 Lisp_Object *vec = XVECTOR (obj)->contents; 3498 Lisp_Object *vec = XVECTOR (obj)->contents;
3489 ptrdiff_t size = ASIZE (obj); 3499 ptrdiff_t size = ASIZE (obj);
3490 3500
3501 if (infile && size >= COMPILED_CONSTANTS)
3502 {
3503 /* Always read 'lazily-loaded' bytecode (generated by the
3504 `byte-compile-dynamic' feature prior to Emacs 30) eagerly, to
3505 avoid code in the fast path during execution. */
3506 if (CONSP (vec[COMPILED_BYTECODE])
3507 && FIXNUMP (XCDR (vec[COMPILED_BYTECODE])))
3508 vec[COMPILED_BYTECODE] = get_lazy_string (vec[COMPILED_BYTECODE]);
3509
3510 /* Lazily-loaded bytecode is represented by the constant slot being nil
3511 and the bytecode slot a (lazily loaded) string containing the
3512 print representation of (BYTECODE . CONSTANTS). Unpack the
3513 pieces by coerceing the string to unibyte and reading the result. */
3514 if (NILP (vec[COMPILED_CONSTANTS]) && STRINGP (vec[COMPILED_BYTECODE]))
3515 {
3516 Lisp_Object enc = vec[COMPILED_BYTECODE];
3517 Lisp_Object pair = Fread (Fcons (enc, readcharfun));
3518 if (!CONSP (pair))
3519 invalid_syntax ("Invalid byte-code object", readcharfun);
3520
3521 vec[COMPILED_BYTECODE] = XCAR (pair);
3522 vec[COMPILED_CONSTANTS] = XCDR (pair);
3523 }
3524 }
3525
3491 if (!(size >= COMPILED_STACK_DEPTH + 1 && size <= COMPILED_INTERACTIVE + 1 3526 if (!(size >= COMPILED_STACK_DEPTH + 1 && size <= COMPILED_INTERACTIVE + 1
3492 && (FIXNUMP (vec[COMPILED_ARGLIST]) 3527 && (FIXNUMP (vec[COMPILED_ARGLIST])
3493 || CONSP (vec[COMPILED_ARGLIST]) 3528 || CONSP (vec[COMPILED_ARGLIST])
3494 || NILP (vec[COMPILED_ARGLIST])) 3529 || NILP (vec[COMPILED_ARGLIST]))
3530 && STRINGP (vec[COMPILED_BYTECODE])
3531 && VECTORP (vec[COMPILED_CONSTANTS])
3495 && FIXNATP (vec[COMPILED_STACK_DEPTH]))) 3532 && FIXNATP (vec[COMPILED_STACK_DEPTH])))
3496 invalid_syntax ("Invalid byte-code object", readcharfun); 3533 invalid_syntax ("Invalid byte-code object", readcharfun);
3497 3534
3498 if (load_force_doc_strings 3535 if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE]))
3499 && NILP (vec[COMPILED_CONSTANTS]) 3536 /* BYTESTR must have been produced by Emacs 20.2 or earlier
3500 && STRINGP (vec[COMPILED_BYTECODE])) 3537 because it produced a raw 8-bit string for byte-code and
3501 { 3538 now such a byte-code string is loaded as multibyte with
3502 /* Lazily-loaded bytecode is represented by the constant slot being nil 3539 raw 8-bit characters converted to multibyte form.
3503 and the bytecode slot a (lazily loaded) string containing the 3540 Convert them back to the original unibyte form. */
3504 print representation of (BYTECODE . CONSTANTS). Unpack the 3541 vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
3505 pieces by coerceing the string to unibyte and reading the result. */
3506 Lisp_Object enc = vec[COMPILED_BYTECODE];
3507 Lisp_Object pair = Fread (Fcons (enc, readcharfun));
3508 if (!CONSP (pair))
3509 invalid_syntax ("Invalid byte-code object", readcharfun);
3510
3511 vec[COMPILED_BYTECODE] = XCAR (pair);
3512 vec[COMPILED_CONSTANTS] = XCDR (pair);
3513 }
3514
3515 if (!((STRINGP (vec[COMPILED_BYTECODE])
3516 && VECTORP (vec[COMPILED_CONSTANTS]))
3517 || CONSP (vec[COMPILED_BYTECODE])))
3518 invalid_syntax ("Invalid byte-code object", readcharfun);
3519 3542
3520 if (STRINGP (vec[COMPILED_BYTECODE])) 3543 /* Bytecode must be immovable. */
3521 { 3544 pin_string (vec[COMPILED_BYTECODE]);
3522 if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE]))
3523 {
3524 /* BYTESTR must have been produced by Emacs 20.2 or earlier
3525 because it produced a raw 8-bit string for byte-code and
3526 now such a byte-code string is loaded as multibyte with
3527 raw 8-bit characters converted to multibyte form.
3528 Convert them back to the original unibyte form. */
3529 vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
3530 }
3531 /* Bytecode must be immovable. */
3532 pin_string (vec[COMPILED_BYTECODE]);
3533 }
3534 3545
3535 XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED); 3546 XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED);
3536 return obj; 3547 return obj;
@@ -4469,7 +4480,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
4469 &longhand_chars, 4480 &longhand_chars,
4470 &longhand_bytes); 4481 &longhand_bytes);
4471 4482
4472 if (SYMBOLP (found)) 4483 if (BARE_SYMBOL_P (found))
4473 result = found; 4484 result = found;
4474 else if (longhand) 4485 else if (longhand)
4475 { 4486 {
@@ -4875,49 +4886,65 @@ static Lisp_Object initial_obarray;
4875 4886
4876static size_t oblookup_last_bucket_number; 4887static size_t oblookup_last_bucket_number;
4877 4888
4878/* Get an error if OBARRAY is not an obarray. 4889static Lisp_Object make_obarray (unsigned bits);
4879 If it is one, return it. */
4880 4890
4891/* Slow path obarray check: return the obarray to use or signal an error. */
4881Lisp_Object 4892Lisp_Object
4882check_obarray (Lisp_Object obarray) 4893check_obarray_slow (Lisp_Object obarray)
4883{ 4894{
4884 /* We don't want to signal a wrong-type-argument error when we are 4895 /* For compatibility, we accept vectors whose first element is 0,
4885 shutting down due to a fatal error, and we don't want to hit 4896 and store an obarray object there. */
4886 assertions in VECTORP and ASIZE if the fatal error was during GC. */ 4897 if (VECTORP (obarray) && ASIZE (obarray) > 0)
4887 if (!fatal_error_in_progress
4888 && (!VECTORP (obarray) || ASIZE (obarray) == 0))
4889 { 4898 {
4890 /* If Vobarray is now invalid, force it to be valid. */ 4899 Lisp_Object obj = AREF (obarray, 0);
4891 if (EQ (Vobarray, obarray)) Vobarray = initial_obarray; 4900 if (OBARRAYP (obj))
4892 wrong_type_argument (Qvectorp, obarray); 4901 return obj;
4902 if (BASE_EQ (obj, make_fixnum (0)))
4903 {
4904 /* Put an actual obarray object in the first slot.
4905 The rest of the vector remains unused. */
4906 obj = make_obarray (0);
4907 ASET (obarray, 0, obj);
4908 return obj;
4909 }
4893 } 4910 }
4894 return obarray; 4911 /* Reset Vobarray to the standard obarray for nicer error handling. */
4912 if (BASE_EQ (Vobarray, obarray)) Vobarray = initial_obarray;
4913
4914 wrong_type_argument (Qobarrayp, obarray);
4895} 4915}
4896 4916
4917static void grow_obarray (struct Lisp_Obarray *o);
4918
4897/* Intern symbol SYM in OBARRAY using bucket INDEX. */ 4919/* Intern symbol SYM in OBARRAY using bucket INDEX. */
4898 4920
4921/* FIXME: retype arguments as pure C types */
4899static Lisp_Object 4922static Lisp_Object
4900intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index) 4923intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index)
4901{ 4924{
4902 Lisp_Object *ptr; 4925 eassert (BARE_SYMBOL_P (sym) && OBARRAYP (obarray) && FIXNUMP (index));
4926 struct Lisp_Symbol *s = XBARE_SYMBOL (sym);
4927 s->u.s.interned = (BASE_EQ (obarray, initial_obarray)
4928 ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
4929 : SYMBOL_INTERNED);
4903 4930
4904 XSYMBOL (sym)->u.s.interned = (EQ (obarray, initial_obarray) 4931 if (SREF (s->u.s.name, 0) == ':' && BASE_EQ (obarray, initial_obarray))
4905 ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
4906 : SYMBOL_INTERNED);
4907
4908 if (SREF (SYMBOL_NAME (sym), 0) == ':' && EQ (obarray, initial_obarray))
4909 { 4932 {
4910 make_symbol_constant (sym); 4933 s->u.s.trapped_write = SYMBOL_NOWRITE;
4911 XSYMBOL (sym)->u.s.redirect = SYMBOL_PLAINVAL; 4934 s->u.s.redirect = SYMBOL_PLAINVAL;
4912 /* Mark keywords as special. This makes (let ((:key 'foo)) ...) 4935 /* Mark keywords as special. This makes (let ((:key 'foo)) ...)
4913 in lexically bound elisp signal an error, as documented. */ 4936 in lexically bound elisp signal an error, as documented. */
4914 XSYMBOL (sym)->u.s.declared_special = true; 4937 s->u.s.declared_special = true;
4915 SET_SYMBOL_VAL (XSYMBOL (sym), sym); 4938 SET_SYMBOL_VAL (s, sym);
4916 } 4939 }
4917 4940
4918 ptr = aref_addr (obarray, XFIXNUM (index)); 4941 struct Lisp_Obarray *o = XOBARRAY (obarray);
4919 set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL); 4942 Lisp_Object *ptr = o->buckets + XFIXNUM (index);
4943 s->u.s.next = BARE_SYMBOL_P (*ptr) ? XBARE_SYMBOL (*ptr) : NULL;
4920 *ptr = sym; 4944 *ptr = sym;
4945 o->count++;
4946 if (o->count > obarray_size (o))
4947 grow_obarray (o);
4921 return sym; 4948 return sym;
4922} 4949}
4923 4950
@@ -4926,7 +4953,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index)
4926Lisp_Object 4953Lisp_Object
4927intern_driver (Lisp_Object string, Lisp_Object obarray, Lisp_Object index) 4954intern_driver (Lisp_Object string, Lisp_Object obarray, Lisp_Object index)
4928{ 4955{
4929 SET_SYMBOL_VAL (XSYMBOL (Qobarray_cache), Qnil); 4956 SET_SYMBOL_VAL (XBARE_SYMBOL (Qobarray_cache), Qnil);
4930 return intern_sym (Fmake_symbol (string), obarray, index); 4957 return intern_sym (Fmake_symbol (string), obarray, index);
4931} 4958}
4932 4959
@@ -4939,7 +4966,7 @@ intern_1 (const char *str, ptrdiff_t len)
4939 Lisp_Object obarray = check_obarray (Vobarray); 4966 Lisp_Object obarray = check_obarray (Vobarray);
4940 Lisp_Object tem = oblookup (obarray, str, len, len); 4967 Lisp_Object tem = oblookup (obarray, str, len, len);
4941 4968
4942 return (SYMBOLP (tem) ? tem 4969 return (BARE_SYMBOL_P (tem) ? tem
4943 /* The above `oblookup' was done on the basis of nchars==nbytes, so 4970 /* The above `oblookup' was done on the basis of nchars==nbytes, so
4944 the string has to be unibyte. */ 4971 the string has to be unibyte. */
4945 : intern_driver (make_unibyte_string (str, len), 4972 : intern_driver (make_unibyte_string (str, len),
@@ -4952,7 +4979,7 @@ intern_c_string_1 (const char *str, ptrdiff_t len)
4952 Lisp_Object obarray = check_obarray (Vobarray); 4979 Lisp_Object obarray = check_obarray (Vobarray);
4953 Lisp_Object tem = oblookup (obarray, str, len, len); 4980 Lisp_Object tem = oblookup (obarray, str, len, len);
4954 4981
4955 if (!SYMBOLP (tem)) 4982 if (!BARE_SYMBOL_P (tem))
4956 { 4983 {
4957 Lisp_Object string; 4984 Lisp_Object string;
4958 4985
@@ -5004,7 +5031,7 @@ it defaults to the value of `obarray'. */)
5004 &longhand, &longhand_chars, 5031 &longhand, &longhand_chars,
5005 &longhand_bytes); 5032 &longhand_bytes);
5006 5033
5007 if (!SYMBOLP (tem)) 5034 if (!BARE_SYMBOL_P (tem))
5008 { 5035 {
5009 if (longhand) 5036 if (longhand)
5010 { 5037 {
@@ -5053,10 +5080,11 @@ it defaults to the value of `obarray'. */)
5053 { 5080 {
5054 /* If already a symbol, we don't do shorthand-longhand translation, 5081 /* If already a symbol, we don't do shorthand-longhand translation,
5055 as promised in the docstring. */ 5082 as promised in the docstring. */
5056 string = SYMBOL_NAME (name); 5083 Lisp_Object sym = maybe_remove_pos_from_symbol (name);
5084 string = XSYMBOL (name)->u.s.name;
5057 tem 5085 tem
5058 = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string)); 5086 = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
5059 return EQ (name, tem) ? name : Qnil; 5087 return BASE_EQ (sym, tem) ? name : Qnil;
5060 } 5088 }
5061} 5089}
5062 5090
@@ -5071,13 +5099,16 @@ usage: (unintern NAME OBARRAY) */)
5071{ 5099{
5072 register Lisp_Object tem; 5100 register Lisp_Object tem;
5073 Lisp_Object string; 5101 Lisp_Object string;
5074 size_t hash;
5075 5102
5076 if (NILP (obarray)) obarray = Vobarray; 5103 if (NILP (obarray)) obarray = Vobarray;
5077 obarray = check_obarray (obarray); 5104 obarray = check_obarray (obarray);
5078 5105
5079 if (SYMBOLP (name)) 5106 if (SYMBOLP (name))
5080 string = SYMBOL_NAME (name); 5107 {
5108 if (!BARE_SYMBOL_P (name))
5109 name = XSYMBOL_WITH_POS (name)->sym;
5110 string = SYMBOL_NAME (name);
5111 }
5081 else 5112 else
5082 { 5113 {
5083 CHECK_STRING (name); 5114 CHECK_STRING (name);
@@ -5097,7 +5128,7 @@ usage: (unintern NAME OBARRAY) */)
5097 if (FIXNUMP (tem)) 5128 if (FIXNUMP (tem))
5098 return Qnil; 5129 return Qnil;
5099 /* If arg was a symbol, don't delete anything but that symbol itself. */ 5130 /* If arg was a symbol, don't delete anything but that symbol itself. */
5100 if (SYMBOLP (name) && !EQ (name, tem)) 5131 if (BARE_SYMBOL_P (name) && !BASE_EQ (name, tem))
5101 return Qnil; 5132 return Qnil;
5102 5133
5103 /* There are plenty of other symbols which will screw up the Emacs 5134 /* There are plenty of other symbols which will screw up the Emacs
@@ -5107,41 +5138,42 @@ usage: (unintern NAME OBARRAY) */)
5107 /* if (NILP (tem) || EQ (tem, Qt)) 5138 /* if (NILP (tem) || EQ (tem, Qt))
5108 error ("Attempt to unintern t or nil"); */ 5139 error ("Attempt to unintern t or nil"); */
5109 5140
5110 XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED; 5141 struct Lisp_Symbol *sym = XBARE_SYMBOL (tem);
5142 sym->u.s.interned = SYMBOL_UNINTERNED;
5111 5143
5112 hash = oblookup_last_bucket_number; 5144 ptrdiff_t idx = oblookup_last_bucket_number;
5145 Lisp_Object *loc = &XOBARRAY (obarray)->buckets[idx];
5113 5146
5114 if (EQ (AREF (obarray, hash), tem)) 5147 eassert (BARE_SYMBOL_P (*loc));
5115 { 5148 struct Lisp_Symbol *prev = XBARE_SYMBOL (*loc);
5116 if (XSYMBOL (tem)->u.s.next) 5149 if (sym == prev)
5117 { 5150 *loc = sym->u.s.next ? make_lisp_symbol (sym->u.s.next) : make_fixnum (0);
5118 Lisp_Object sym;
5119 XSETSYMBOL (sym, XSYMBOL (tem)->u.s.next);
5120 ASET (obarray, hash, sym);
5121 }
5122 else
5123 ASET (obarray, hash, make_fixnum (0));
5124 }
5125 else 5151 else
5126 { 5152 while (1)
5127 Lisp_Object tail, following; 5153 {
5154 struct Lisp_Symbol *next = prev->u.s.next;
5155 if (next == sym)
5156 {
5157 prev->u.s.next = next->u.s.next;
5158 break;
5159 }
5160 prev = next;
5161 }
5128 5162
5129 for (tail = AREF (obarray, hash); 5163 XOBARRAY (obarray)->count--;
5130 XSYMBOL (tail)->u.s.next;
5131 tail = following)
5132 {
5133 XSETSYMBOL (following, XSYMBOL (tail)->u.s.next);
5134 if (EQ (following, tem))
5135 {
5136 set_symbol_next (tail, XSYMBOL (following)->u.s.next);
5137 break;
5138 }
5139 }
5140 }
5141 5164
5142 return Qt; 5165 return Qt;
5143} 5166}
5144 5167
5168
5169/* Bucket index of the string STR of length SIZE_BYTE bytes in obarray OA. */
5170static ptrdiff_t
5171obarray_index (struct Lisp_Obarray *oa, const char *str, ptrdiff_t size_byte)
5172{
5173 EMACS_UINT hash = hash_string (str, size_byte);
5174 return knuth_hash (reduce_emacs_uint_to_hash_hash (hash), oa->size_bits);
5175}
5176
5145/* Return the symbol in OBARRAY whose names matches the string 5177/* Return the symbol in OBARRAY whose names matches the string
5146 of SIZE characters (SIZE_BYTE bytes) at PTR. 5178 of SIZE characters (SIZE_BYTE bytes) at PTR.
5147 If there is no such symbol, return the integer bucket number of 5179 If there is no such symbol, return the integer bucket number of
@@ -5152,35 +5184,27 @@ usage: (unintern NAME OBARRAY) */)
5152Lisp_Object 5184Lisp_Object
5153oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff_t size_byte) 5185oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff_t size_byte)
5154{ 5186{
5155 size_t hash; 5187 struct Lisp_Obarray *o = XOBARRAY (obarray);
5156 size_t obsize; 5188 ptrdiff_t idx = obarray_index (o, ptr, size_byte);
5157 register Lisp_Object tail; 5189 Lisp_Object bucket = o->buckets[idx];
5158 Lisp_Object bucket, tem;
5159 5190
5160 obarray = check_obarray (obarray); 5191 oblookup_last_bucket_number = idx;
5161 /* This is sometimes needed in the middle of GC. */ 5192 if (!BASE_EQ (bucket, make_fixnum (0)))
5162 obsize = gc_asize (obarray); 5193 {
5163 hash = hash_string (ptr, size_byte) % obsize; 5194 Lisp_Object sym = bucket;
5164 bucket = AREF (obarray, hash); 5195 while (1)
5165 oblookup_last_bucket_number = hash; 5196 {
5166 if (BASE_EQ (bucket, make_fixnum (0))) 5197 struct Lisp_Symbol *s = XBARE_SYMBOL (sym);
5167 ; 5198 Lisp_Object name = s->u.s.name;
5168 else if (!SYMBOLP (bucket)) 5199 if (SBYTES (name) == size_byte && SCHARS (name) == size
5169 /* Like CADR error message. */ 5200 && memcmp (SDATA (name), ptr, size_byte) == 0)
5170 xsignal2 (Qwrong_type_argument, Qobarrayp, 5201 return sym;
5171 build_string ("Bad data in guts of obarray")); 5202 if (s->u.s.next == NULL)
5172 else 5203 break;
5173 for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next)) 5204 sym = make_lisp_symbol(s->u.s.next);
5174 { 5205 }
5175 if (SBYTES (SYMBOL_NAME (tail)) == size_byte 5206 }
5176 && SCHARS (SYMBOL_NAME (tail)) == size 5207 return make_fixnum (idx);
5177 && !memcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
5178 return tail;
5179 else if (XSYMBOL (tail)->u.s.next == 0)
5180 break;
5181 }
5182 XSETINT (tem, hash);
5183 return tem;
5184} 5208}
5185 5209
5186/* Like 'oblookup', but considers 'Vread_symbol_shorthands', 5210/* Like 'oblookup', but considers 'Vread_symbol_shorthands',
@@ -5247,24 +5271,134 @@ oblookup_considering_shorthand (Lisp_Object obarray, const char *in,
5247} 5271}
5248 5272
5249 5273
5250void 5274static struct Lisp_Obarray *
5251map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg) 5275allocate_obarray (void)
5276{
5277 return ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Obarray, PVEC_OBARRAY);
5278}
5279
5280static Lisp_Object
5281make_obarray (unsigned bits)
5282{
5283 struct Lisp_Obarray *o = allocate_obarray ();
5284 o->count = 0;
5285 o->size_bits = bits;
5286 ptrdiff_t size = (ptrdiff_t)1 << bits;
5287 o->buckets = hash_table_alloc_bytes (size * sizeof *o->buckets);
5288 for (ptrdiff_t i = 0; i < size; i++)
5289 o->buckets[i] = make_fixnum (0);
5290 return make_lisp_obarray (o);
5291}
5292
5293enum {
5294 obarray_default_bits = 3,
5295 word_size_log2 = word_size < 8 ? 5 : 6, /* good enough */
5296 obarray_max_bits = min (8 * sizeof (int),
5297 8 * sizeof (ptrdiff_t) - word_size_log2) - 1,
5298};
5299
5300static void
5301grow_obarray (struct Lisp_Obarray *o)
5252{ 5302{
5253 ptrdiff_t i; 5303 ptrdiff_t old_size = obarray_size (o);
5254 register Lisp_Object tail; 5304 eassert (o->count > old_size);
5255 CHECK_VECTOR (obarray); 5305 Lisp_Object *old_buckets = o->buckets;
5256 for (i = ASIZE (obarray) - 1; i >= 0; i--) 5306
5307 int new_bits = o->size_bits + 1;
5308 if (new_bits > obarray_max_bits)
5309 error ("Obarray too big");
5310 ptrdiff_t new_size = (ptrdiff_t)1 << new_bits;
5311 o->buckets = hash_table_alloc_bytes (new_size * sizeof *o->buckets);
5312 for (ptrdiff_t i = 0; i < new_size; i++)
5313 o->buckets[i] = make_fixnum (0);
5314 o->size_bits = new_bits;
5315
5316 /* Rehash symbols.
5317 FIXME: this is expensive since we need to recompute the hash for every
5318 symbol name. Would it be reasonable to store it in the symbol? */
5319 for (ptrdiff_t i = 0; i < old_size; i++)
5257 { 5320 {
5258 tail = AREF (obarray, i); 5321 Lisp_Object obj = old_buckets[i];
5259 if (SYMBOLP (tail)) 5322 if (BARE_SYMBOL_P (obj))
5260 while (1) 5323 {
5261 { 5324 struct Lisp_Symbol *s = XBARE_SYMBOL (obj);
5262 (*fn) (tail, arg); 5325 while (1)
5263 if (XSYMBOL (tail)->u.s.next == 0) 5326 {
5264 break; 5327 Lisp_Object name = s->u.s.name;
5265 XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next); 5328 ptrdiff_t idx = obarray_index (o, SSDATA (name), SBYTES (name));
5266 } 5329 Lisp_Object *loc = o->buckets + idx;
5330 struct Lisp_Symbol *next = s->u.s.next;
5331 s->u.s.next = BARE_SYMBOL_P (*loc) ? XBARE_SYMBOL (*loc) : NULL;
5332 *loc = make_lisp_symbol (s);
5333 if (next == NULL)
5334 break;
5335 s = next;
5336 }
5337 }
5338 }
5339
5340 hash_table_free_bytes (old_buckets, old_size * sizeof *old_buckets);
5341}
5342
5343DEFUN ("obarray-make", Fobarray_make, Sobarray_make, 0, 1, 0,
5344 doc: /* Return a new obarray of size SIZE.
5345The obarray will grow to accommodate any number of symbols; the size, if
5346given, is only a hint for the expected number. */)
5347 (Lisp_Object size)
5348{
5349 int bits;
5350 if (NILP (size))
5351 bits = obarray_default_bits;
5352 else
5353 {
5354 CHECK_FIXNAT (size);
5355 EMACS_UINT n = XFIXNUM (size);
5356 bits = elogb (n) + 1;
5357 if (bits > obarray_max_bits)
5358 xsignal (Qargs_out_of_range, size);
5267 } 5359 }
5360 return make_obarray (bits);
5361}
5362
5363DEFUN ("obarrayp", Fobarrayp, Sobarrayp, 1, 1, 0,
5364 doc: /* Return t iff OBJECT is an obarray. */)
5365 (Lisp_Object object)
5366{
5367 return OBARRAYP (object) ? Qt : Qnil;
5368}
5369
5370DEFUN ("obarray-clear", Fobarray_clear, Sobarray_clear, 1, 1, 0,
5371 doc: /* Remove all symbols from OBARRAY. */)
5372 (Lisp_Object obarray)
5373{
5374 CHECK_OBARRAY (obarray);
5375 struct Lisp_Obarray *o = XOBARRAY (obarray);
5376
5377 /* This function does not bother setting the status of its contained symbols
5378 to uninterned. It doesn't matter very much. */
5379 int new_bits = obarray_default_bits;
5380 int new_size = (ptrdiff_t)1 << new_bits;
5381 Lisp_Object *new_buckets
5382 = hash_table_alloc_bytes (new_size * sizeof *new_buckets);
5383 for (ptrdiff_t i = 0; i < new_size; i++)
5384 new_buckets[i] = make_fixnum (0);
5385
5386 int old_size = obarray_size (o);
5387 hash_table_free_bytes (o->buckets, old_size * sizeof *o->buckets);
5388 o->buckets = new_buckets;
5389 o->size_bits = new_bits;
5390 o->count = 0;
5391
5392 return Qnil;
5393}
5394
5395void
5396map_obarray (Lisp_Object obarray,
5397 void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
5398{
5399 CHECK_OBARRAY (obarray);
5400 DOOBARRAY (XOBARRAY (obarray), it)
5401 (*fn) (obarray_iter_symbol (&it), arg);
5268} 5402}
5269 5403
5270static void 5404static void
@@ -5285,12 +5419,37 @@ OBARRAY defaults to the value of `obarray'. */)
5285 return Qnil; 5419 return Qnil;
5286} 5420}
5287 5421
5288#define OBARRAY_SIZE 15121 5422DEFUN ("internal--obarray-buckets",
5423 Finternal__obarray_buckets, Sinternal__obarray_buckets, 1, 1, 0,
5424 doc: /* Symbols in each bucket of OBARRAY. Internal use only. */)
5425 (Lisp_Object obarray)
5426{
5427 obarray = check_obarray (obarray);
5428 ptrdiff_t size = obarray_size (XOBARRAY (obarray));
5429
5430 Lisp_Object ret = Qnil;
5431 for (ptrdiff_t i = 0; i < size; i++)
5432 {
5433 Lisp_Object bucket = Qnil;
5434 Lisp_Object sym = XOBARRAY (obarray)->buckets[i];
5435 if (BARE_SYMBOL_P (sym))
5436 while (1)
5437 {
5438 bucket = Fcons (sym, bucket);
5439 struct Lisp_Symbol *s = XBARE_SYMBOL (sym)->u.s.next;
5440 if (!s)
5441 break;
5442 sym = make_lisp_symbol (s);
5443 }
5444 ret = Fcons (Fnreverse (bucket), ret);
5445 }
5446 return Fnreverse (ret);
5447}
5289 5448
5290void 5449void
5291init_obarray_once (void) 5450init_obarray_once (void)
5292{ 5451{
5293 Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0)); 5452 Vobarray = make_obarray (15);
5294 initial_obarray = Vobarray; 5453 initial_obarray = Vobarray;
5295 staticpro (&initial_obarray); 5454 staticpro (&initial_obarray);
5296 5455
@@ -5300,14 +5459,14 @@ init_obarray_once (void)
5300 DEFSYM (Qunbound, "unbound"); 5459 DEFSYM (Qunbound, "unbound");
5301 5460
5302 DEFSYM (Qnil, "nil"); 5461 DEFSYM (Qnil, "nil");
5303 SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil); 5462 SET_SYMBOL_VAL (XBARE_SYMBOL (Qnil), Qnil);
5304 make_symbol_constant (Qnil); 5463 make_symbol_constant (Qnil);
5305 XSYMBOL (Qnil)->u.s.declared_special = true; 5464 XBARE_SYMBOL (Qnil)->u.s.declared_special = true;
5306 5465
5307 DEFSYM (Qt, "t"); 5466 DEFSYM (Qt, "t");
5308 SET_SYMBOL_VAL (XSYMBOL (Qt), Qt); 5467 SET_SYMBOL_VAL (XBARE_SYMBOL (Qt), Qt);
5309 make_symbol_constant (Qt); 5468 make_symbol_constant (Qt);
5310 XSYMBOL (Qt)->u.s.declared_special = true; 5469 XBARE_SYMBOL (Qt)->u.s.declared_special = true;
5311 5470
5312 /* Qt is correct even if not dumping. loadup.el will set to nil at end. */ 5471 /* Qt is correct even if not dumping. loadup.el will set to nil at end. */
5313 Vpurify_flag = Qt; 5472 Vpurify_flag = Qt;
@@ -5331,16 +5490,6 @@ defsubr (union Aligned_Lisp_Subr *aname)
5331#endif 5490#endif
5332} 5491}
5333 5492
5334#ifdef NOTDEF /* Use fset in subr.el now! */
5335void
5336defalias (struct Lisp_Subr *sname, char *string)
5337{
5338 Lisp_Object sym;
5339 sym = intern (string);
5340 XSETSUBR (XSYMBOL (sym)->u.s.function, sname);
5341}
5342#endif /* NOTDEF */
5343
5344/* Define an "integer variable"; a symbol whose value is forwarded to a 5493/* Define an "integer variable"; a symbol whose value is forwarded to a
5345 C variable of type intmax_t. Sample call (with "xx" to fool make-docfile): 5494 C variable of type intmax_t. Sample call (with "xx" to fool make-docfile):
5346 DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */ 5495 DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
@@ -5348,9 +5497,9 @@ void
5348defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring) 5497defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring)
5349{ 5498{
5350 Lisp_Object sym = intern_c_string (namestring); 5499 Lisp_Object sym = intern_c_string (namestring);
5351 XSYMBOL (sym)->u.s.declared_special = true; 5500 XBARE_SYMBOL (sym)->u.s.declared_special = true;
5352 XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; 5501 XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
5353 SET_SYMBOL_FWD (XSYMBOL (sym), i_fwd); 5502 SET_SYMBOL_FWD (XBARE_SYMBOL (sym), i_fwd);
5354} 5503}
5355 5504
5356/* Similar but define a variable whose value is t if 1, nil if 0. */ 5505/* Similar but define a variable whose value is t if 1, nil if 0. */
@@ -5358,9 +5507,9 @@ void
5358defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring) 5507defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring)
5359{ 5508{
5360 Lisp_Object sym = intern_c_string (namestring); 5509 Lisp_Object sym = intern_c_string (namestring);
5361 XSYMBOL (sym)->u.s.declared_special = true; 5510 XBARE_SYMBOL (sym)->u.s.declared_special = true;
5362 XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; 5511 XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
5363 SET_SYMBOL_FWD (XSYMBOL (sym), b_fwd); 5512 SET_SYMBOL_FWD (XBARE_SYMBOL (sym), b_fwd);
5364 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars); 5513 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
5365} 5514}
5366 5515
@@ -5373,9 +5522,9 @@ void
5373defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring) 5522defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring)
5374{ 5523{
5375 Lisp_Object sym = intern_c_string (namestring); 5524 Lisp_Object sym = intern_c_string (namestring);
5376 XSYMBOL (sym)->u.s.declared_special = true; 5525 XBARE_SYMBOL (sym)->u.s.declared_special = true;
5377 XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; 5526 XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
5378 SET_SYMBOL_FWD (XSYMBOL (sym), o_fwd); 5527 SET_SYMBOL_FWD (XBARE_SYMBOL (sym), o_fwd);
5379} 5528}
5380 5529
5381void 5530void
@@ -5392,9 +5541,9 @@ void
5392defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd, char const *namestring) 5541defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd, char const *namestring)
5393{ 5542{
5394 Lisp_Object sym = intern_c_string (namestring); 5543 Lisp_Object sym = intern_c_string (namestring);
5395 XSYMBOL (sym)->u.s.declared_special = true; 5544 XBARE_SYMBOL (sym)->u.s.declared_special = true;
5396 XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; 5545 XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
5397 SET_SYMBOL_FWD (XSYMBOL (sym), ko_fwd); 5546 SET_SYMBOL_FWD (XBARE_SYMBOL (sym), ko_fwd);
5398} 5547}
5399 5548
5400/* Check that the elements of lpath exist. */ 5549/* Check that the elements of lpath exist. */
@@ -5682,6 +5831,10 @@ syms_of_lread (void)
5682 defsubr (&Sget_file_char); 5831 defsubr (&Sget_file_char);
5683 defsubr (&Smapatoms); 5832 defsubr (&Smapatoms);
5684 defsubr (&Slocate_file_internal); 5833 defsubr (&Slocate_file_internal);
5834 defsubr (&Sinternal__obarray_buckets);
5835 defsubr (&Sobarray_make);
5836 defsubr (&Sobarrayp);
5837 defsubr (&Sobarray_clear);
5685 5838
5686 DEFVAR_LISP ("obarray", Vobarray, 5839 DEFVAR_LISP ("obarray", Vobarray,
5687 doc: /* Symbol table for use by `intern' and `read'. 5840 doc: /* Symbol table for use by `intern' and `read'.
@@ -5693,7 +5846,7 @@ to find all the symbols in an obarray, use `mapatoms'. */);
5693 doc: /* List of values of all expressions which were read, evaluated and printed. 5846 doc: /* List of values of all expressions which were read, evaluated and printed.
5694Order is reverse chronological. 5847Order is reverse chronological.
5695This variable is obsolete as of Emacs 28.1 and should not be used. */); 5848This variable is obsolete as of Emacs 28.1 and should not be used. */);
5696 XSYMBOL (intern ("values"))->u.s.declared_special = false; 5849 XBARE_SYMBOL (intern ("values"))->u.s.declared_special = false;
5697 5850
5698 DEFVAR_LISP ("standard-input", Vstandard_input, 5851 DEFVAR_LISP ("standard-input", Vstandard_input,
5699 doc: /* Stream for read to get input from. 5852 doc: /* Stream for read to get input from.
@@ -6007,4 +6160,7 @@ See Info node `(elisp)Shorthands' for more details. */);
6007 doc: /* List of variables declared dynamic in the current scope. 6160 doc: /* List of variables declared dynamic in the current scope.
6008Only valid during macro-expansion. Internal use only. */); 6161Only valid during macro-expansion. Internal use only. */);
6009 Vmacroexp__dynvars = Qnil; 6162 Vmacroexp__dynvars = Qnil;
6163
6164 DEFSYM (Qinternal_macroexpand_for_load,
6165 "internal-macroexpand-for-load");
6010} 6166}
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,
855 struct { 855 struct {
856 enum font_property_index index; 856 enum font_property_index index;
857 CFStringRef trait; 857 CFStringRef trait;
858 CGPoint points[6]; 858 CGPoint points[12];
859 CGFloat (*adjust_func) (CTFontDescriptorRef, CGFloat); 859 CGFloat (*adjust_func) (CTFontDescriptorRef, CGFloat);
860 } numeric_traits[] = 860 } numeric_traits[] = {
861 {{FONT_WEIGHT_INDEX, kCTFontWeightTrait, 861 { FONT_WEIGHT_INDEX,
862 {{-0.4, 50}, /* light */ 862 kCTFontWeightTrait,
863 {-0.24, 87.5}, /* (semi-light + normal) / 2 */ 863 { { -0.6, 0 }, /* thin */
864 {0, 80}, /* normal */ 864 { -0.4, 40 }, /* ultra-light, ultralight, extra-light, extralight */
865 {0.24, 140}, /* (semi-bold + normal) / 2 */ 865 { -0.23, 50 }, /* light */
866 {0.4, 200}, /* bold */ 866 { -0.115, 55 }, /* semi-light, semilight, demilight */
867 {CGFLOAT_MAX, CGFLOAT_MAX}}, 867 { 0, 80 }, /* regular, normal, unspecified, book */
868 mac_font_descriptor_get_adjusted_weight}, 868 { 0.2, 100 }, /* medium */
869 {FONT_SLANT_INDEX, kCTFontSlantTrait, 869 { 0.3, 180 }, /* semi-bold, semibold, demibold, demi-bold, demi */
870 {{0, 100}, {0.1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}, NULL}, 870 { 0.4, 200 }, /* bold */
871 {FONT_WIDTH_INDEX, kCTFontWidthTrait, 871 { 0.6, 205 }, /* extra-bold, extrabold, ultra-bold, ultrabold */
872 {{0, 100}, {1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}, NULL}}; 872 { 0.8, 210 }, /* black, heavy */
873 { 1, 250 }, /* ultra-heavy, ultraheavy */
874 { CGFLOAT_MAX, CGFLOAT_MAX } },
875 mac_font_descriptor_get_adjusted_weight },
876 { FONT_SLANT_INDEX,
877 kCTFontSlantTrait,
878 { { 0, 100 }, { 0.1, 200 }, { CGFLOAT_MAX, CGFLOAT_MAX } },
879 NULL },
880 { FONT_WIDTH_INDEX,
881 kCTFontWidthTrait,
882 { { -0.4, 50 }, /* ultra-condensed, ultracondensed */
883 { -0.3, 63 }, /* extra-condensed, extracondensed */
884 { -0.2, 75 }, /* condensed, compressed, narrow */
885 { -0.1, 87 }, /* semi-condensed, semicondensed, demicondensed */
886 { 0, 100 }, /* normal, medium, regular, unspecified */
887 { 0.1, 113 }, /* semi-expanded, semiexpanded, demiexpanded */
888 { 0.2, 125 }, /* expanded */
889 { 0.3, 150 }, /* extra-expanded, extraexpanded */
890 { 0.4, 200 }, /* ultra-expanded, ultraexpanded, wide */
891 { CGFLOAT_MAX, CGFLOAT_MAX } },
892 NULL }
893 };
873 int i; 894 int i;
874 895
875 for (i = 0; i < ARRAYELTS (numeric_traits); i++) 896 for (i = 0; i < ARRAYELTS (numeric_traits); i++)
@@ -1941,19 +1962,38 @@ macfont_create_attributes_with_spec (Lisp_Object spec)
1941 struct { 1962 struct {
1942 enum font_property_index index; 1963 enum font_property_index index;
1943 CFStringRef trait; 1964 CFStringRef trait;
1944 CGPoint points[6]; 1965 CGPoint points[12];
1945 } numeric_traits[] = 1966 } numeric_traits[] = {
1946 {{FONT_WEIGHT_INDEX, kCTFontWeightTrait, 1967 { FONT_WEIGHT_INDEX,
1947 {{-0.4, 50}, /* light */ 1968 kCTFontWeightTrait,
1948 {-0.24, 87.5}, /* (semi-light + normal) / 2 */ 1969 { { -0.6, 0 }, /* thin */
1949 {0, 100}, /* normal */ 1970 { -0.4, 40 }, /* ultra-light, ultralight, extra-light, extralight */
1950 {0.24, 140}, /* (semi-bold + normal) / 2 */ 1971 { -0.23, 50 }, /* light */
1951 {0.4, 200}, /* bold */ 1972 { -0.115, 55 }, /* semi-light, semilight, demilight */
1952 {CGFLOAT_MAX, CGFLOAT_MAX}}}, 1973 { 0, 80 }, /* regular, normal, unspecified, book */
1953 {FONT_SLANT_INDEX, kCTFontSlantTrait, 1974 { 0.2, 100 }, /* medium */
1954 {{0, 100}, {0.1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}}, 1975 { 0.3, 180 }, /* semi-bold, semibold, demibold, demi-bold, demi */
1955 {FONT_WIDTH_INDEX, kCTFontWidthTrait, 1976 { 0.4, 200 }, /* bold */
1956 {{0, 100}, {1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}}}; 1977 { 0.6, 205 }, /* extra-bold, extrabold, ultra-bold, ultrabold */
1978 { 0.8, 210 }, /* black, heavy */
1979 { 1, 250 }, /* ultra-heavy, ultraheavy */
1980 { CGFLOAT_MAX, CGFLOAT_MAX } } },
1981 { FONT_SLANT_INDEX,
1982 kCTFontSlantTrait,
1983 { { 0, 100 }, { 0.1, 200 }, { CGFLOAT_MAX, CGFLOAT_MAX } } },
1984 { FONT_WIDTH_INDEX,
1985 kCTFontWidthTrait,
1986 { { -0.4, 50 }, /* ultra-condensed, ultracondensed */
1987 { -0.3, 63 }, /* extra-condensed, extracondensed */
1988 { -0.2, 75 }, /* condensed, compressed, narrow */
1989 { -0.1, 87 }, /* semi-condensed, semicondensed, demicondensed */
1990 { 0, 100 }, /* normal, medium, regular, unspecified */
1991 { 0.1, 113 }, /* semi-expanded, semiexpanded, demiexpanded */
1992 { 0.2, 125 }, /* expanded */
1993 { 0.3, 150 }, /* extra-expanded, extraexpanded */
1994 { 0.4, 200 }, /* ultra-expanded, ultraexpanded, wide */
1995 { CGFLOAT_MAX, CGFLOAT_MAX } } }
1996 };
1957 1997
1958 registry = AREF (spec, FONT_REGISTRY_INDEX); 1998 registry = AREF (spec, FONT_REGISTRY_INDEX);
1959 if (NILP (registry) 1999 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/>. */
21#include <config.h> 21#include <config.h>
22 22
23/* Work around GCC bug 113253. */ 23/* Work around GCC bug 113253. */
24#if 13 <= __GNUC__ 24#if __GNUC__ == 13
25# pragma GCC diagnostic ignored "-Wanalyzer-deref-before-check" 25# pragma GCC diagnostic ignored "-Wanalyzer-deref-before-check"
26#endif 26#endif
27 27
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. */)
1615 ptrdiff_t bestmatchsize = 0; 1615 ptrdiff_t bestmatchsize = 0;
1616 /* These are in bytes, too. */ 1616 /* These are in bytes, too. */
1617 ptrdiff_t compare, matchsize; 1617 ptrdiff_t compare, matchsize;
1618 if (VECTORP (collection))
1619 collection = check_obarray (collection);
1618 enum { function_table, list_table, obarray_table, hash_table} 1620 enum { function_table, list_table, obarray_table, hash_table}
1619 type = (HASH_TABLE_P (collection) ? hash_table 1621 type = (HASH_TABLE_P (collection) ? hash_table
1620 : VECTORP (collection) ? obarray_table 1622 : OBARRAYP (collection) ? obarray_table
1621 : ((NILP (collection) 1623 : ((NILP (collection)
1622 || (CONSP (collection) && !FUNCTIONP (collection))) 1624 || (CONSP (collection) && !FUNCTIONP (collection)))
1623 ? list_table : function_table)); 1625 ? list_table : function_table));
1624 ptrdiff_t idx = 0, obsize = 0; 1626 ptrdiff_t idx = 0;
1625 int matchcount = 0; 1627 int matchcount = 0;
1626 Lisp_Object bucket, zero, end, tem; 1628 Lisp_Object bucket, zero, end, tem;
1627 1629
@@ -1634,12 +1636,9 @@ or from one of the possible completions. */)
1634 1636
1635 /* If COLLECTION is not a list, set TAIL just for gc pro. */ 1637 /* If COLLECTION is not a list, set TAIL just for gc pro. */
1636 tail = collection; 1638 tail = collection;
1639 obarray_iter_t obit;
1637 if (type == obarray_table) 1640 if (type == obarray_table)
1638 { 1641 obit = make_obarray_iter (XOBARRAY (collection));
1639 collection = check_obarray (collection);
1640 obsize = ASIZE (collection);
1641 bucket = AREF (collection, idx);
1642 }
1643 1642
1644 while (1) 1643 while (1)
1645 { 1644 {
@@ -1658,24 +1657,10 @@ or from one of the possible completions. */)
1658 } 1657 }
1659 else if (type == obarray_table) 1658 else if (type == obarray_table)
1660 { 1659 {
1661 if (!EQ (bucket, zero)) 1660 if (obarray_iter_at_end (&obit))
1662 {
1663 if (!SYMBOLP (bucket))
1664 error ("Bad data in guts of obarray");
1665 elt = bucket;
1666 eltstring = elt;
1667 if (XSYMBOL (bucket)->u.s.next)
1668 XSETSYMBOL (bucket, XSYMBOL (bucket)->u.s.next);
1669 else
1670 XSETFASTINT (bucket, 0);
1671 }
1672 else if (++idx >= obsize)
1673 break; 1661 break;
1674 else 1662 elt = eltstring = obarray_iter_symbol (&obit);
1675 { 1663 obarray_iter_step (&obit);
1676 bucket = AREF (collection, idx);
1677 continue;
1678 }
1679 } 1664 }
1680 else /* if (type == hash_table) */ 1665 else /* if (type == hash_table) */
1681 { 1666 {
@@ -1858,10 +1843,12 @@ with a space are ignored unless STRING itself starts with a space. */)
1858{ 1843{
1859 Lisp_Object tail, elt, eltstring; 1844 Lisp_Object tail, elt, eltstring;
1860 Lisp_Object allmatches; 1845 Lisp_Object allmatches;
1846 if (VECTORP (collection))
1847 collection = check_obarray (collection);
1861 int type = HASH_TABLE_P (collection) ? 3 1848 int type = HASH_TABLE_P (collection) ? 3
1862 : VECTORP (collection) ? 2 1849 : OBARRAYP (collection) ? 2
1863 : NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection)); 1850 : NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection));
1864 ptrdiff_t idx = 0, obsize = 0; 1851 ptrdiff_t idx = 0;
1865 Lisp_Object bucket, tem, zero; 1852 Lisp_Object bucket, tem, zero;
1866 1853
1867 CHECK_STRING (string); 1854 CHECK_STRING (string);
@@ -1872,12 +1859,9 @@ with a space are ignored unless STRING itself starts with a space. */)
1872 1859
1873 /* If COLLECTION is not a list, set TAIL just for gc pro. */ 1860 /* If COLLECTION is not a list, set TAIL just for gc pro. */
1874 tail = collection; 1861 tail = collection;
1862 obarray_iter_t obit;
1875 if (type == 2) 1863 if (type == 2)
1876 { 1864 obit = make_obarray_iter (XOBARRAY (collection));
1877 collection = check_obarray (collection);
1878 obsize = ASIZE (collection);
1879 bucket = AREF (collection, idx);
1880 }
1881 1865
1882 while (1) 1866 while (1)
1883 { 1867 {
@@ -1896,24 +1880,10 @@ with a space are ignored unless STRING itself starts with a space. */)
1896 } 1880 }
1897 else if (type == 2) 1881 else if (type == 2)
1898 { 1882 {
1899 if (!EQ (bucket, zero)) 1883 if (obarray_iter_at_end (&obit))
1900 {
1901 if (!SYMBOLP (bucket))
1902 error ("Bad data in guts of obarray");
1903 elt = bucket;
1904 eltstring = elt;
1905 if (XSYMBOL (bucket)->u.s.next)
1906 XSETSYMBOL (bucket, XSYMBOL (bucket)->u.s.next);
1907 else
1908 XSETFASTINT (bucket, 0);
1909 }
1910 else if (++idx >= obsize)
1911 break; 1884 break;
1912 else 1885 elt = eltstring = obarray_iter_symbol (&obit);
1913 { 1886 obarray_iter_step (&obit);
1914 bucket = AREF (collection, idx);
1915 continue;
1916 }
1917 } 1887 }
1918 else /* if (type == 3) */ 1888 else /* if (type == 3) */
1919 { 1889 {
@@ -2059,7 +2029,7 @@ If COLLECTION is a function, it is called with three arguments:
2059the values STRING, PREDICATE and `lambda'. */) 2029the values STRING, PREDICATE and `lambda'. */)
2060 (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate) 2030 (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate)
2061{ 2031{
2062 Lisp_Object tail, tem = Qnil, arg = Qnil; 2032 Lisp_Object tem = Qnil, arg = Qnil;
2063 2033
2064 CHECK_STRING (string); 2034 CHECK_STRING (string);
2065 2035
@@ -2069,38 +2039,30 @@ the values STRING, PREDICATE and `lambda'. */)
2069 if (NILP (tem)) 2039 if (NILP (tem))
2070 return Qnil; 2040 return Qnil;
2071 } 2041 }
2072 else if (VECTORP (collection)) 2042 else if (OBARRAYP (collection) || VECTORP (collection))
2073 { 2043 {
2044 collection = check_obarray (collection);
2074 /* Bypass intern-soft as that loses for nil. */ 2045 /* Bypass intern-soft as that loses for nil. */
2075 tem = oblookup (collection, 2046 tem = oblookup (collection,
2076 SSDATA (string), 2047 SSDATA (string),
2077 SCHARS (string), 2048 SCHARS (string),
2078 SBYTES (string)); 2049 SBYTES (string));
2079 if (completion_ignore_case && !SYMBOLP (tem)) 2050 if (completion_ignore_case && !BARE_SYMBOL_P (tem))
2080 { 2051 DOOBARRAY (XOBARRAY (collection), it)
2081 for (ptrdiff_t i = ASIZE (collection) - 1; i >= 0; i--) 2052 {
2082 { 2053 Lisp_Object obj = obarray_iter_symbol (&it);
2083 tail = AREF (collection, i); 2054 if (BASE_EQ (Fcompare_strings (string, make_fixnum (0),
2084 if (SYMBOLP (tail)) 2055 Qnil,
2085 while (1) 2056 Fsymbol_name (obj),
2086 { 2057 make_fixnum (0) , Qnil, Qt),
2087 if (BASE_EQ (Fcompare_strings (string, make_fixnum (0), 2058 Qt))
2088 Qnil, 2059 {
2089 Fsymbol_name (tail), 2060 tem = obj;
2090 make_fixnum (0) , Qnil, Qt), 2061 break;
2091 Qt)) 2062 }
2092 { 2063 }
2093 tem = tail;
2094 break;
2095 }
2096 if (XSYMBOL (tail)->u.s.next == 0)
2097 break;
2098 XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next);
2099 }
2100 }
2101 }
2102 2064
2103 if (!SYMBOLP (tem)) 2065 if (!BARE_SYMBOL_P (tem))
2104 return Qnil; 2066 return Qnil;
2105 } 2067 }
2106 else if (HASH_TABLE_P (collection)) 2068 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)
2688 h->hash = NULL; 2688 h->hash = NULL;
2689 h->index = NULL; 2689 h->index = NULL;
2690 h->table_size = 0; 2690 h->table_size = 0;
2691 h->index_size = 0; 2691 h->index_bits = 0;
2692 h->frozen_test = hash_table_std_test (h->test); 2692 h->frozen_test = hash_table_std_test (h->test);
2693 h->test = NULL; 2693 h->test = NULL;
2694} 2694}
@@ -2719,7 +2719,7 @@ dump_hash_table_contents (struct dump_context *ctx, struct Lisp_Hash_Table *h)
2719static dump_off 2719static dump_off
2720dump_hash_table (struct dump_context *ctx, Lisp_Object object) 2720dump_hash_table (struct dump_context *ctx, Lisp_Object object)
2721{ 2721{
2722#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_313A489F0A 2722#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_0360833954
2723# error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment in config.h." 2723# error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment in config.h."
2724#endif 2724#endif
2725 const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object); 2725 const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object);
@@ -2749,6 +2749,51 @@ dump_hash_table (struct dump_context *ctx, Lisp_Object object)
2749} 2749}
2750 2750
2751static dump_off 2751static dump_off
2752dump_obarray_buckets (struct dump_context *ctx, const struct Lisp_Obarray *o)
2753{
2754 dump_align_output (ctx, DUMP_ALIGNMENT);
2755 dump_off start_offset = ctx->offset;
2756 ptrdiff_t n = obarray_size (o);
2757
2758 struct dump_flags old_flags = ctx->flags;
2759 ctx->flags.pack_objects = true;
2760
2761 for (ptrdiff_t i = 0; i < n; i++)
2762 {
2763 Lisp_Object out;
2764 const Lisp_Object *slot = &o->buckets[i];
2765 dump_object_start (ctx, &out, sizeof out);
2766 dump_field_lv (ctx, &out, slot, slot, WEIGHT_STRONG);
2767 dump_object_finish (ctx, &out, sizeof out);
2768 }
2769
2770 ctx->flags = old_flags;
2771 return start_offset;
2772}
2773
2774static dump_off
2775dump_obarray (struct dump_context *ctx, Lisp_Object object)
2776{
2777#if CHECK_STRUCTS && !defined HASH_Lisp_Obarray_D2757E61AD
2778# error "Lisp_Obarray changed. See CHECK_STRUCTS comment in config.h."
2779#endif
2780 const struct Lisp_Obarray *in_oa = XOBARRAY (object);
2781 struct Lisp_Obarray munged_oa = *in_oa;
2782 struct Lisp_Obarray *oa = &munged_oa;
2783 START_DUMP_PVEC (ctx, &oa->header, struct Lisp_Obarray, out);
2784 dump_pseudovector_lisp_fields (ctx, &out->header, &oa->header);
2785 DUMP_FIELD_COPY (out, oa, count);
2786 DUMP_FIELD_COPY (out, oa, size_bits);
2787 dump_field_fixup_later (ctx, out, oa, &oa->buckets);
2788 dump_off offset = finish_dump_pvec (ctx, &out->header);
2789 dump_remember_fixup_ptr_raw
2790 (ctx,
2791 offset + dump_offsetof (struct Lisp_Obarray, buckets),
2792 dump_obarray_buckets (ctx, oa));
2793 return offset;
2794}
2795
2796static dump_off
2752dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) 2797dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer)
2753{ 2798{
2754#if CHECK_STRUCTS && !defined HASH_buffer_EBBA38AEFA 2799#if CHECK_STRUCTS && !defined HASH_buffer_EBBA38AEFA
@@ -2912,17 +2957,17 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
2912 dump_object_start (ctx, &out, sizeof (out)); 2957 dump_object_start (ctx, &out, sizeof (out));
2913 DUMP_FIELD_COPY (&out, subr, header.size); 2958 DUMP_FIELD_COPY (&out, subr, header.size);
2914#ifdef HAVE_NATIVE_COMP 2959#ifdef HAVE_NATIVE_COMP
2915 bool native_comp = !NILP (subr->native_comp_u); 2960 bool non_primitive = !NILP (subr->native_comp_u);
2916#else 2961#else
2917 bool native_comp = false; 2962 bool non_primitive = false;
2918#endif 2963#endif
2919 if (native_comp) 2964 if (non_primitive)
2920 out.function.a0 = NULL; 2965 out.function.a0 = NULL;
2921 else 2966 else
2922 dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); 2967 dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
2923 DUMP_FIELD_COPY (&out, subr, min_args); 2968 DUMP_FIELD_COPY (&out, subr, min_args);
2924 DUMP_FIELD_COPY (&out, subr, max_args); 2969 DUMP_FIELD_COPY (&out, subr, max_args);
2925 if (native_comp) 2970 if (non_primitive)
2926 { 2971 {
2927 dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name); 2972 dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name);
2928 dump_remember_cold_op (ctx, 2973 dump_remember_cold_op (ctx,
@@ -2947,7 +2992,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
2947 dump_field_lv (ctx, &out, subr, &subr->type, WEIGHT_NORMAL); 2992 dump_field_lv (ctx, &out, subr, &subr->type, WEIGHT_NORMAL);
2948#endif 2993#endif
2949 dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); 2994 dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out));
2950 if (native_comp && ctx->flags.dump_object_contents) 2995 if (non_primitive && ctx->flags.dump_object_contents)
2951 /* We'll do the final addr relocation during VERY_LATE_RELOCS time 2996 /* We'll do the final addr relocation during VERY_LATE_RELOCS time
2952 after the compilation units has been loaded. */ 2997 after the compilation units has been loaded. */
2953 dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS], 2998 dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS],
@@ -3004,7 +3049,7 @@ dump_vectorlike (struct dump_context *ctx,
3004 Lisp_Object lv, 3049 Lisp_Object lv,
3005 dump_off offset) 3050 dump_off offset)
3006{ 3051{
3007#if CHECK_STRUCTS && !defined HASH_pvec_type_D8A254BC70 3052#if CHECK_STRUCTS && !defined HASH_pvec_type_2D583AC566
3008# error "pvec_type changed. See CHECK_STRUCTS comment in config.h." 3053# error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
3009#endif 3054#endif
3010 const struct Lisp_Vector *v = XVECTOR (lv); 3055 const struct Lisp_Vector *v = XVECTOR (lv);
@@ -3031,6 +3076,8 @@ dump_vectorlike (struct dump_context *ctx,
3031 return dump_bool_vector(ctx, v); 3076 return dump_bool_vector(ctx, v);
3032 case PVEC_HASH_TABLE: 3077 case PVEC_HASH_TABLE:
3033 return dump_hash_table (ctx, lv); 3078 return dump_hash_table (ctx, lv);
3079 case PVEC_OBARRAY:
3080 return dump_obarray (ctx, lv);
3034 case PVEC_BUFFER: 3081 case PVEC_BUFFER:
3035 return dump_buffer (ctx, XBUFFER (lv)); 3082 return dump_buffer (ctx, XBUFFER (lv));
3036 case PVEC_SUBR: 3083 case PVEC_SUBR:
@@ -5593,10 +5640,7 @@ pdumper_load (const char *dump_filename, char *argv0)
5593 5640
5594 struct dump_header header_buf = { 0 }; 5641 struct dump_header header_buf = { 0 };
5595 struct dump_header *header = &header_buf; 5642 struct dump_header *header = &header_buf;
5596 struct dump_memory_map sections[NUMBER_DUMP_SECTIONS]; 5643 struct dump_memory_map sections[NUMBER_DUMP_SECTIONS] = { 0 };
5597
5598 /* Use memset instead of "= { 0 }" to work around GCC bug 105961. */
5599 memset (sections, 0, sizeof sections);
5600 5644
5601 const struct timespec start_time = current_timespec (); 5645 const struct timespec start_time = current_timespec ();
5602 char *dump_filename_copy; 5646 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,
5825 /* Has the mouse moved off the glyph it was on at the last sighting? */ 5825 /* Has the mouse moved off the glyph it was on at the last sighting? */
5826 r = &dpyinfo->last_mouse_glyph; 5826 r = &dpyinfo->last_mouse_glyph;
5827 if (frame != dpyinfo->last_mouse_glyph_frame 5827 if (frame != dpyinfo->last_mouse_glyph_frame
5828 || event->x < r->x || event->x >= r->x + r->width 5828 || event->x < r->x || event->x >= r->x + (int) r->width
5829 || event->y < r->y || event->y >= r->y + r->height) 5829 || event->y < r->y || event->y >= r->y + (int) r->height)
5830 { 5830 {
5831 frame->mouse_moved = true; 5831 frame->mouse_moved = true;
5832 dpyinfo->last_mouse_scroll_bar = NULL; 5832 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)
1412 && SYMBOLP (obj) 1412 && SYMBOLP (obj)
1413 && !SYMBOL_INTERNED_P (obj))) 1413 && !SYMBOL_INTERNED_P (obj)))
1414 { /* OBJ appears more than once. Let's remember that. */ 1414 { /* OBJ appears more than once. Let's remember that. */
1415 if (!FIXNUMP (num)) 1415 if (SYMBOLP (num)) /* In practice, nil or t. */
1416 { 1416 {
1417 print_number_index++; 1417 print_number_index++;
1418 /* Negative number indicates it hasn't been printed yet. */ 1418 /* Negative number indicates it hasn't been printed yet. */
@@ -2078,6 +2078,16 @@ print_vectorlike_unreadable (Lisp_Object obj, Lisp_Object printcharfun,
2078 } 2078 }
2079 return; 2079 return;
2080 2080
2081 case PVEC_OBARRAY:
2082 {
2083 struct Lisp_Obarray *o = XOBARRAY (obj);
2084 /* FIXME: Would it make sense to print the actual symbols (up to
2085 a limit)? */
2086 int i = sprintf (buf, "#<obarray n=%u>", o->count);
2087 strout (buf, i, i, printcharfun);
2088 return;
2089 }
2090
2081 /* Types handled earlier. */ 2091 /* Types handled earlier. */
2082 case PVEC_NORMAL_VECTOR: 2092 case PVEC_NORMAL_VECTOR:
2083 case PVEC_RECORD: 2093 case PVEC_RECORD:
@@ -2265,6 +2275,11 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
2265 goto next_obj; 2275 goto next_obj;
2266 } 2276 }
2267 } 2277 }
2278 else if (STRINGP (num))
2279 {
2280 strout (SSDATA (num), SCHARS (num), SBYTES (num), printcharfun);
2281 goto next_obj;
2282 }
2268 } 2283 }
2269 2284
2270 print_depth++; 2285 print_depth++;
@@ -2554,11 +2569,6 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
2554 goto next_obj; 2569 goto next_obj;
2555 case PVEC_SUB_CHAR_TABLE: 2570 case PVEC_SUB_CHAR_TABLE:
2556 { 2571 {
2557 /* Make each lowest sub_char_table start a new line.
2558 Otherwise we'll make a line extremely long, which
2559 results in slow redisplay. */
2560 if (XSUB_CHAR_TABLE (obj)->depth == 3)
2561 printchar ('\n', printcharfun);
2562 print_c_string ("#^^[", printcharfun); 2572 print_c_string ("#^^[", printcharfun);
2563 int n = sprintf (buf, "%d %d", 2573 int n = sprintf (buf, "%d %d",
2564 XSUB_CHAR_TABLE (obj)->depth, 2574 XSUB_CHAR_TABLE (obj)->depth,
@@ -2664,7 +2674,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
2664 /* With the print-circle feature. */ 2674 /* With the print-circle feature. */
2665 Lisp_Object num = Fgethash (next, Vprint_number_table, 2675 Lisp_Object num = Fgethash (next, Vprint_number_table,
2666 Qnil); 2676 Qnil);
2667 if (FIXNUMP (num)) 2677 if (!(NILP (num) || EQ (num, Qt)))
2668 { 2678 {
2669 print_c_string (" . ", printcharfun); 2679 print_c_string (" . ", printcharfun);
2670 obj = next; 2680 obj = next;
@@ -2928,7 +2938,10 @@ This variable should not be set with `setq'; bind it with a `let' instead. */);
2928 DEFVAR_LISP ("print-number-table", Vprint_number_table, 2938 DEFVAR_LISP ("print-number-table", Vprint_number_table,
2929 doc: /* A vector used internally to produce `#N=' labels and `#N#' references. 2939 doc: /* A vector used internally to produce `#N=' labels and `#N#' references.
2930The Lisp printer uses this vector to detect Lisp objects referenced more 2940The Lisp printer uses this vector to detect Lisp objects referenced more
2931than once. 2941than once. If an entry contains a number, then the corresponding key is
2942referenced more than once: a positive sign indicates that it's already been
2943printed, and the absolute value indicates the number to use when printing.
2944If an entry contains a string, that string is printed instead.
2932 2945
2933When you bind `print-continuous-numbering' to t, you should probably 2946When you bind `print-continuous-numbering' to t, you should probably
2934also bind `print-number-table' to nil. This ensures that the value of 2947also 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)
5209{ 5209{
5210} 5210}
5211 5211
5212#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY \
5213 && defined THREADS_ENABLED
5214
5215/* Wrapper around `android_select' that exposes a calling interface with
5216 an extra argument for compatibility with `thread_pselect'. */
5217
5218static int
5219android_select_wrapper (int nfds, fd_set *readfds, fd_set *writefds,
5220 fd_set *exceptfds, const struct timespec *timeout,
5221 const sigset_t *sigmask)
5222{
5223 /* sigmask is not supported. */
5224 if (sigmask)
5225 emacs_abort ();
5226
5227 return android_select (nfds, readfds, writefds, exceptfds,
5228 (struct timespec *) timeout);
5229}
5230
5231#endif /* HAVE_ANDROID && !ANDROID_STUBIFY && THREADS_ENABLED */
5232
5212/* Read and dispose of subprocess output while waiting for timeout to 5233/* Read and dispose of subprocess output while waiting for timeout to
5213 elapse and/or keyboard input to be available. 5234 elapse and/or keyboard input to be available.
5214 5235
@@ -5701,13 +5722,19 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5701 timeout = short_timeout; 5722 timeout = short_timeout;
5702#endif 5723#endif
5703 5724
5704 /* Android doesn't support threads and requires using a 5725 /* Android requires using a replacement for pselect in
5705 replacement for pselect in android.c to poll for 5726 android.c to poll for events. */
5706 events. */
5707#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY 5727#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
5728#ifndef THREADS_ENABLED
5708 nfds = android_select (max_desc + 1, 5729 nfds = android_select (max_desc + 1,
5709 &Available, (check_write ? &Writeok : 0), 5730 &Available, (check_write ? &Writeok : 0),
5710 NULL, &timeout); 5731 NULL, &timeout);
5732#else /* THREADS_ENABLED */
5733 nfds = thread_select (android_select_wrapper,
5734 max_desc + 1,
5735 &Available, (check_write ? &Writeok : 0),
5736 NULL, &timeout, NULL);
5737#endif /* THREADS_ENABLED */
5711#else 5738#else
5712 5739
5713 /* Non-macOS HAVE_GLIB builds call thread_select in 5740 /* 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,
2798 if (component->flags & 04000) /* SCALED_COMPONENT_OFFSET */ 2798 if (component->flags & 04000) /* SCALED_COMPONENT_OFFSET */
2799 sfnt_transform_coordinates (component, &x, &y, 1, 2799 sfnt_transform_coordinates (component, &x, &y, 1,
2800 0, 0); 2800 0, 0);
2801
2802 if (component->flags & 04) /* ROUND_XY_TO_GRID */
2803 {
2804 x = sfnt_round_fixed (x);
2805 y = sfnt_round_fixed (y);
2806 }
2807 } 2801 }
2808 else 2802 else
2809 { 2803 {
@@ -20800,8 +20794,8 @@ main (int argc, char **argv)
20800 return 1; 20794 return 1;
20801 } 20795 }
20802 20796
20803#define FANCY_PPEM 12 20797#define FANCY_PPEM 18
20804#define EASY_PPEM 12 20798#define EASY_PPEM 18
20805 20799
20806 interpreter = NULL; 20800 interpreter = NULL;
20807 head = sfnt_read_head_table (fd, font); 20801 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
248 SFNT_MACINTOSH_GREEK = 6, 248 SFNT_MACINTOSH_GREEK = 6,
249 SFNT_MACINTOSH_RUSSIAN = 7, 249 SFNT_MACINTOSH_RUSSIAN = 7,
250 SFNT_MACINTOSH_RSYMBOL = 8, 250 SFNT_MACINTOSH_RSYMBOL = 8,
251 SFNT_MACINTOSH_DEVANGARI = 9, 251 SFNT_MACINTOSH_DEVANAGARI = 9,
252 SFNT_MACINTOSH_GURMUKHI = 10, 252 SFNT_MACINTOSH_GURMUKHI = 10,
253 SFNT_MACINTOSH_GUJARATI = 11, 253 SFNT_MACINTOSH_GUJARATI = 11,
254 SFNT_MACINTOSH_ORIYA = 12, 254 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,
3308 ASET (font_object, FONT_TYPE_INDEX, sfnt_vendor_name); 3308 ASET (font_object, FONT_TYPE_INDEX, sfnt_vendor_name);
3309 ASET (font_object, FONT_FOUNDRY_INDEX, desc->designer); 3309 ASET (font_object, FONT_FOUNDRY_INDEX, desc->designer);
3310 ASET (font_object, FONT_FAMILY_INDEX, Fintern (desc->family, Qnil)); 3310 ASET (font_object, FONT_FAMILY_INDEX, Fintern (desc->family, Qnil));
3311 ASET (font_object, FONT_ADSTYLE_INDEX, Qnil); 3311 ASET (font_object, FONT_ADSTYLE_INDEX, desc->adstyle);
3312 ASET (font_object, FONT_REGISTRY_INDEX, 3312 ASET (font_object, FONT_REGISTRY_INDEX,
3313 sfntfont_registry_for_desc (desc)); 3313 sfntfont_registry_for_desc (desc));
3314 3314
@@ -3326,8 +3326,6 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity,
3326 FONT_SET_STYLE (font_object, FONT_SLANT_INDEX, 3326 FONT_SET_STYLE (font_object, FONT_SLANT_INDEX,
3327 make_fixnum (desc->slant)); 3327 make_fixnum (desc->slant));
3328 3328
3329 ASET (font_object, FONT_ADSTYLE_INDEX, Qnil);
3330
3331 /* Clear various offsets. */ 3329 /* Clear various offsets. */
3332 font_info->font.baseline_offset = 0; 3330 font_info->font.baseline_offset = 0;
3333 font_info->font.relative_compose = 0; 3331 font_info->font.relative_compose = 0;
@@ -3412,7 +3410,7 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity,
3412 AREF (tem, 3)); 3410 AREF (tem, 3));
3413 FONT_SET_STYLE (font_object, FONT_SLANT_INDEX, 3411 FONT_SET_STYLE (font_object, FONT_SLANT_INDEX,
3414 AREF (tem, 4)); 3412 AREF (tem, 4));
3415 ASET (font_object, FONT_ADSTYLE_INDEX, Qnil); 3413 ASET (font_object, FONT_ADSTYLE_INDEX, AREF (tem, 1));
3416 } 3414 }
3417 } 3415 }
3418 3416
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)
1631 it->pixel_width = it->nglyphs = 0; 1631 it->pixel_width = it->nglyphs = 0;
1632 else if (it->char_to_display == '\t') 1632 else if (it->char_to_display == '\t')
1633 { 1633 {
1634 /* wrap-prefix strings are prepended to continuation lines, so
1635 the width of tab characters inside should be computed from
1636 the start of this screen line rather than as a product of the
1637 total width of the physical line being wrapped. */
1634 int absolute_x = (it->current_x 1638 int absolute_x = (it->current_x
1635 + it->continuation_lines_width); 1639 + (it->string_from_prefix_prop_p
1640 /* Subtract the width of the
1641 prefix from it->current_x if
1642 it exists. */
1643 ? 0 : (it->continuation_lines_width
1644 ? (it->continuation_lines_width
1645 - it->wrap_prefix_width)
1646 : 0)));
1636 int x0 = absolute_x; 1647 int x0 = absolute_x;
1637 /* Adjust for line numbers. */ 1648 /* Adjust for line numbers. */
1638 if (!NILP (Vdisplay_line_numbers) && it->line_number_produced_p) 1649 if (!NILP (Vdisplay_line_numbers) && it->line_number_produced_p)
@@ -1704,7 +1715,13 @@ produce_glyphs (struct it *it)
1704 /* Advance current_x by the pixel width as a convenience for 1715 /* Advance current_x by the pixel width as a convenience for
1705 the caller. */ 1716 the caller. */
1706 if (it->area == TEXT_AREA) 1717 if (it->area == TEXT_AREA)
1707 it->current_x += it->pixel_width; 1718 {
1719 it->current_x += it->pixel_width;
1720
1721 if (it->continuation_lines_width
1722 && it->string_from_prefix_prop_p)
1723 it->wrap_prefix_width = it->current_x;
1724 }
1708 it->ascent = it->max_ascent = it->phys_ascent = it->max_phys_ascent = 0; 1725 it->ascent = it->max_ascent = it->phys_ascent = it->max_phys_ascent = 0;
1709 it->descent = it->max_descent = it->phys_descent = it->max_phys_descent = 1; 1726 it->descent = it->max_descent = it->phys_descent = it->max_phys_descent = 1;
1710#endif 1727#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,
1705{ 1705{
1706 struct text_conversion_action *action, **last; 1706 struct text_conversion_action *action, **last;
1707 1707
1708 if (start > MOST_POSITIVE_FIXNUM) 1708 start = min (start, MOST_POSITIVE_FIXNUM);
1709 start = MOST_POSITIVE_FIXNUM; 1709 end = min (end, MOST_POSITIVE_FIXNUM);
1710
1711 if (end > MOST_POSITIVE_FIXNUM)
1712 end = MOST_POSITIVE_FIXNUM;
1713 1710
1714 action = xmalloc (sizeof *action); 1711 action = xmalloc (sizeof *action);
1715 action->operation = TEXTCONV_SET_COMPOSING_REGION; 1712 action->operation = TEXTCONV_SET_COMPOSING_REGION;
@@ -1734,8 +1731,7 @@ textconv_set_point_and_mark (struct frame *f, ptrdiff_t point,
1734{ 1731{
1735 struct text_conversion_action *action, **last; 1732 struct text_conversion_action *action, **last;
1736 1733
1737 if (point > MOST_POSITIVE_FIXNUM) 1734 point = min (point, MOST_POSITIVE_FIXNUM);
1738 point = MOST_POSITIVE_FIXNUM;
1739 1735
1740 action = xmalloc (sizeof *action); 1736 action = xmalloc (sizeof *action);
1741 action->operation = TEXTCONV_SET_POINT_AND_MARK; 1737 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)
106{ 106{
107 struct thread_state *prev_thread = current_thread; 107 struct thread_state *prev_thread = current_thread;
108 108
109 /* Switch the JNI interface pointer to the environment assigned to the
110 current thread. */
111#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
112 android_java_env = self->java_env;
113#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
114
109 /* Do this early on, so that code below could signal errors (e.g., 115 /* Do this early on, so that code below could signal errors (e.g.,
110 unbind_for_thread_switch might) correctly, because we are already 116 unbind_for_thread_switch might) correctly, because we are already
111 running in the context of the thread pointed by SELF. */ 117 running in the context of the thread pointed by SELF. */
@@ -126,6 +132,12 @@ post_acquire_global_lock (struct thread_state *self)
126 set_buffer_internal_2 (current_buffer); 132 set_buffer_internal_2 (current_buffer);
127 } 133 }
128 134
135#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
136 /* This step is performed in android_select when built without
137 threads. */
138 android_check_query ();
139#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
140
129 /* We could have been signaled while waiting to grab the global lock 141 /* We could have been signaled while waiting to grab the global lock
130 for the first time since this thread was created, in which case 142 for the first time since this thread was created, in which case
131 we didn't yet have the opportunity to set up the handlers. Delay 143 we didn't yet have the opportunity to set up the handlers. Delay
@@ -756,6 +768,11 @@ run_thread (void *state)
756 768
757 struct thread_state *self = state; 769 struct thread_state *self = state;
758 struct thread_state **iter; 770 struct thread_state **iter;
771#ifdef THREADS_ENABLED
772#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
773 jint rc;
774#endif /* #if defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
775#endif /* THREADS_ENABLED */
759 776
760#ifdef HAVE_NS 777#ifdef HAVE_NS
761 /* Allocate an autorelease pool in case this thread calls any 778 /* Allocate an autorelease pool in case this thread calls any
@@ -766,6 +783,16 @@ run_thread (void *state)
766 void *pool = ns_alloc_autorelease_pool (); 783 void *pool = ns_alloc_autorelease_pool ();
767#endif 784#endif
768 785
786#ifdef THREADS_ENABLED
787#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
788 rc
789 = (*android_jvm)->AttachCurrentThread (android_jvm, &self->java_env,
790 NULL);
791 if (rc != JNI_OK)
792 emacs_abort ();
793#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
794#endif /* THREADS_ENABLED */
795
769 self->m_stack_bottom = self->stack_top = &stack_pos.c; 796 self->m_stack_bottom = self->stack_top = &stack_pos.c;
770 self->thread_id = sys_thread_self (); 797 self->thread_id = sys_thread_self ();
771 798
@@ -812,6 +839,14 @@ run_thread (void *state)
812 ns_release_autorelease_pool (pool); 839 ns_release_autorelease_pool (pool);
813#endif 840#endif
814 841
842#ifdef THREADS_ENABLED
843#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
844 rc = (*android_jvm)->DetachCurrentThread (android_jvm);
845 if (rc != JNI_OK)
846 emacs_abort ();
847#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
848#endif /* THREADS_ENABLED */
849
815 /* Unlink this thread from the list of all threads. Note that we 850 /* Unlink this thread from the list of all threads. Note that we
816 have to do this very late, after broadcasting our death. 851 have to do this very late, after broadcasting our death.
817 Otherwise the GC may decide to reap the thread_state object, 852 Otherwise the GC may decide to reap the thread_state object,
@@ -1131,6 +1166,10 @@ init_threads (void)
1131 sys_mutex_init (&global_lock); 1166 sys_mutex_init (&global_lock);
1132 sys_mutex_lock (&global_lock); 1167 sys_mutex_lock (&global_lock);
1133 current_thread = &main_thread.s; 1168 current_thread = &main_thread.s;
1169#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
1170 current_thread->java_env = android_java_env;
1171#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
1172
1134 main_thread.s.thread_id = sys_thread_self (); 1173 main_thread.s.thread_id = sys_thread_self ();
1135 init_bc_thread (&main_thread.s.bc); 1174 init_bc_thread (&main_thread.s.bc);
1136} 1175}
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/>. */
30#include <signal.h> /* sigset_t */ 30#include <signal.h> /* sigset_t */
31#endif 31#endif
32 32
33#ifdef HAVE_ANDROID
34#ifndef ANDROID_STUBIFY
35#include "android.h"
36#endif /* ANDROID_STUBIFY */
37#endif /* HAVE_ANDROID */
38
33#include "sysselect.h" /* FIXME */ 39#include "sysselect.h" /* FIXME */
34#include "systhread.h" 40#include "systhread.h"
35 41
@@ -84,6 +90,11 @@ struct thread_state
84 Lisp_Object event_object; 90 Lisp_Object event_object;
85 /* event_object must be the last Lisp field. */ 91 /* event_object must be the last Lisp field. */
86 92
93#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
94 /* Pointer to an object to call Java functions through. */
95 JNIEnv *java_env;
96#endif /* HAVE_ANDROID && !ANDROID_STUBIFY */
97
87 /* An address near the bottom of the stack. 98 /* An address near the bottom of the stack.
88 Tells GC how to save a copy of the stack. */ 99 Tells GC how to save a copy of the stack. */
89 char const *m_stack_bottom; 100 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)
225 225
226 if (NILP (zone)) 226 if (NILP (zone))
227 return local_tz; 227 return local_tz;
228 else if (BASE_EQ (zone, make_fixnum (0)) || BASE2_EQ (zone, Qt)) 228 else if (BASE_EQ (zone, make_fixnum (0)) || EQ (zone, Qt))
229 { 229 {
230 zone_string = "UTC0"; 230 zone_string = "UTC0";
231 new_tz = utc_tz; 231 new_tz = utc_tz;
@@ -234,7 +234,7 @@ tzlookup (Lisp_Object zone, bool settz)
234 { 234 {
235 bool plain_integer = FIXNUMP (zone); 235 bool plain_integer = FIXNUMP (zone);
236 236
237 if (BASE2_EQ (zone, Qwall)) 237 if (EQ (zone, Qwall))
238 zone_string = 0; 238 zone_string = 0;
239 else if (STRINGP (zone)) 239 else if (STRINGP (zone))
240 zone_string = SSDATA (ENCODE_SYSTEM (zone)); 240 zone_string = SSDATA (ENCODE_SYSTEM (zone));
@@ -1548,7 +1548,7 @@ usage: (decode-time &optional TIME ZONE FORM) */)
1548 1548
1549 /* Compute SEC from LOCAL_TM.tm_sec and HZ. */ 1549 /* Compute SEC from LOCAL_TM.tm_sec and HZ. */
1550 Lisp_Object hz = lt.hz, sec; 1550 Lisp_Object hz = lt.hz, sec;
1551 if (BASE_EQ (hz, make_fixnum (1)) || !BASE2_EQ (form, Qt)) 1551 if (BASE_EQ (hz, make_fixnum (1)) || !EQ (form, Qt))
1552 sec = make_fixnum (local_tm.tm_sec); 1552 sec = make_fixnum (local_tm.tm_sec);
1553 else 1553 else
1554 { 1554 {
@@ -1765,10 +1765,8 @@ but new code should not rely on it. */)
1765 well, since we accept it as input? */ 1765 well, since we accept it as input? */
1766 struct lisp_time t; 1766 struct lisp_time t;
1767 enum timeform input_form = decode_lisp_time (time, false, &t, 0); 1767 enum timeform input_form = decode_lisp_time (time, false, &t, 0);
1768 if (NILP (form)) 1768 form = (!NILP (form) ? maybe_remove_pos_from_symbol (form)
1769 form = current_time_list ? Qlist : Qt; 1769 : current_time_list ? Qlist : Qt);
1770 if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (form))
1771 form = SYMBOL_WITH_POS_SYM (form);
1772 if (BASE_EQ (form, Qlist)) 1770 if (BASE_EQ (form, Qlist))
1773 return ticks_hz_list4 (t.ticks, t.hz); 1771 return ticks_hz_list4 (t.ticks, t.hz);
1774 if (BASE_EQ (form, Qinteger)) 1772 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,
3275static Lisp_Object 3275static Lisp_Object
3276treesit_traverse_get_predicate (Lisp_Object thing, Lisp_Object language) 3276treesit_traverse_get_predicate (Lisp_Object thing, Lisp_Object language)
3277{ 3277{
3278 Lisp_Object cons = assq_no_quit (language, Vtreesit_thing_settings); 3278 Lisp_Object cons = assq_no_signal (language, Vtreesit_thing_settings);
3279 if (NILP (cons)) 3279 if (NILP (cons))
3280 return Qnil; 3280 return Qnil;
3281 Lisp_Object definitions = XCDR (cons); 3281 Lisp_Object definitions = XCDR (cons);
3282 Lisp_Object entry = assq_no_quit (thing, definitions); 3282 Lisp_Object entry = assq_no_signal (thing, definitions);
3283 if (NILP (entry)) 3283 if (NILP (entry))
3284 return Qnil; 3284 return Qnil;
3285 /* ENTRY looks like (THING PRED). */ 3285 /* 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))
53# The workaround is done only for AM_V_ELC and AM_V_ELN, 53# The workaround is done only for AM_V_ELC and AM_V_ELN,
54# since the bug is not annoying elsewhere. 54# since the bug is not annoying elsewhere.
55 55
56AM_V_AR = @$(info $ AR $@) 56. :=
57AM_V_AR = @$(info $. AR $@)
57AM_V_at = @ 58AM_V_at = @
58AM_V_CC = @$(info $ CC $@) 59AM_V_CC = @$(info $. CC $@)
59AM_V_CXX = @$(info $ CXX $@) 60AM_V_CXX = @$(info $. CXX $@)
60AM_V_CCLD = @$(info $ CCLD $@) 61AM_V_CCLD = @$(info $. CCLD $@)
61AM_V_CXXLD = @$(info $ CXXLD $@) 62AM_V_CXXLD = @$(info $. CXXLD $@)
62 63
63ifeq ($(HAVE_NATIVE_COMP)-$(NATIVE_DISABLED)-$(ANCIENT),yes--) 64ifeq ($(HAVE_NATIVE_COMP)-$(NATIVE_DISABLED)-$(ANCIENT),yes--)
64ifneq (,$(have_working_info)) 65ifneq (,$(have_working_info))
65AM_V_ELC = @$(info $ ELC+ELN $@) 66AM_V_ELC = @$(info $. ELC+ELN $@)
66AM_V_ELN = @$(info $ ELN $@) 67AM_V_ELN = @$(info $. ELN $@)
67else 68else
68AM_V_ELC = @echo " ELC+ELN " $@; 69AM_V_ELC = @echo " ELC+ELN " $@;
69AM_V_ELN = @echo " ELN " $@; 70AM_V_ELN = @echo " ELN " $@;
70endif 71endif
71else 72else
72ifneq (,$(have_working_info)) 73ifneq (,$(have_working_info))
73AM_V_ELC = @$(info $ ELC $@) 74AM_V_ELC = @$(info $. ELC $@)
74else 75else
75AM_V_ELC = @echo " ELC " $@; 76AM_V_ELC = @echo " ELC " $@;
76endif 77endif
77AM_V_ELN = 78AM_V_ELN =
78endif 79endif
79 80
80AM_V_GEN = @$(info $ GEN $@) 81AM_V_GEN = @$(info $. GEN $@)
81AM_V_GLOBALS = @$(info $ GEN globals.h) 82AM_V_GLOBALS = @$(info $. GEN globals.h)
82AM_V_NO_PD = --no-print-directory 83AM_V_NO_PD = --no-print-directory
83AM_V_RC = @$(info $ RC $@) 84AM_V_RC = @$(info $. RC $@)
84 85
85# These are used for the Android port. 86# These are used for the Android port.
86AM_V_JAVAC = @$(info $ JAVAC $@) 87AM_V_JAVAC = @$(info $. JAVAC $@)
87AM_V_D8 = @$(info $ D8 $@) 88AM_V_D8 = @$(info $. D8 $@)
88AM_V_AAPT = @$(info $ AAPT $@) 89AM_V_AAPT = @$(info $. AAPT $@)
89AM_V_SILENT = @ 90AM_V_SILENT = @
90endif 91endif
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,
4151 buffer); 4151 buffer);
4152 w->start_at_line_beg = false; 4152 w->start_at_line_beg = false;
4153 w->force_start = false; 4153 w->force_start = false;
4154 /* Flush the base_line cache since it applied to another buffer. */
4155 w->base_line_number = 0;
4154 } 4156 }
4155 4157
4156 wset_redisplay (w); 4158 wset_redisplay (w);
@@ -5378,7 +5380,14 @@ grow_mini_window (struct window *w, int delta)
5378 grow = call3 (Qwindow__resize_root_window_vertically, 5380 grow = call3 (Qwindow__resize_root_window_vertically,
5379 root, make_fixnum (- delta), Qt); 5381 root, make_fixnum (- delta), Qt);
5380 5382
5381 if (FIXNUMP (grow) && window_resize_check (r, false)) 5383 if (FIXNUMP (grow)
5384 /* It might be impossible to resize the window, in which case
5385 calling resize_mini_window_apply will set off an infinite
5386 loop where the redisplay cycle so forced returns to
5387 resize_mini_window, making endless attempts to expand the
5388 minibuffer window to this impossible size. (bug#69140) */
5389 && XFIXNUM (grow) != 0
5390 && window_resize_check (r, false))
5382 resize_mini_window_apply (w, -XFIXNUM (grow)); 5391 resize_mini_window_apply (w, -XFIXNUM (grow));
5383 } 5392 }
5384} 5393}
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
2508 r.x = s->clip_head->x; 2508 r.x = s->clip_head->x;
2509 } 2509 }
2510 if (s->clip_tail) 2510 if (s->clip_tail)
2511 if (r.x + r.width > s->clip_tail->x + s->clip_tail->background_width) 2511 if (r.x + (int) r.width > s->clip_tail->x + s->clip_tail->background_width)
2512 { 2512 {
2513 if (s->clip_tail->x + s->clip_tail->background_width >= r.x) 2513 if (s->clip_tail->x + s->clip_tail->background_width >= r.x)
2514 r.width = s->clip_tail->x + s->clip_tail->background_width - r.x; 2514 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
2588 height = max (FRAME_LINE_HEIGHT (s->f), glyph->ascent + glyph->descent); 2588 height = max (FRAME_LINE_HEIGHT (s->f), glyph->ascent + glyph->descent);
2589 if (height < r.height) 2589 if (height < r.height)
2590 { 2590 {
2591 max_y = r.y + r.height; 2591 max_y = r.y + (int) r.height;
2592 r.y = min (max_y, max (r.y, s->ybase + glyph->descent - height)); 2592 r.y = min (max_y, max (r.y, s->ybase + glyph->descent - height));
2593 r.height = min (max_y - r.y, height); 2593 r.height = min (max_y - r.y, height);
2594 } 2594 }
@@ -2629,7 +2629,7 @@ get_glyph_string_clip_rects (struct glyph_string *s, NativeRectangle *rects, int
2629 if (s->for_overlaps & OVERLAPS_PRED) 2629 if (s->for_overlaps & OVERLAPS_PRED)
2630 { 2630 {
2631 rs[i] = r; 2631 rs[i] = r;
2632 if (r.y + r.height > row_y) 2632 if (r.y + (int) r.height > row_y)
2633 { 2633 {
2634 if (r.y < row_y) 2634 if (r.y < row_y)
2635 rs[i].height = row_y - r.y; 2635 rs[i].height = row_y - r.y;
@@ -2643,10 +2643,10 @@ get_glyph_string_clip_rects (struct glyph_string *s, NativeRectangle *rects, int
2643 rs[i] = r; 2643 rs[i] = r;
2644 if (r.y < row_y + s->row->visible_height) 2644 if (r.y < row_y + s->row->visible_height)
2645 { 2645 {
2646 if (r.y + r.height > row_y + s->row->visible_height) 2646 if (r.y + (int) r.height > row_y + s->row->visible_height)
2647 { 2647 {
2648 rs[i].y = row_y + s->row->visible_height; 2648 rs[i].y = row_y + s->row->visible_height;
2649 rs[i].height = r.y + r.height - rs[i].y; 2649 rs[i].height = r.y + (int) r.height - rs[i].y;
2650 } 2650 }
2651 else 2651 else
2652 rs[i].height = 0; 2652 rs[i].height = 0;
@@ -2831,7 +2831,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect)
2831 text_glyph: 2831 text_glyph:
2832 gr = 0; gy = 0; 2832 gr = 0; gy = 0;
2833 for (; r <= end_row && r->enabled_p; ++r) 2833 for (; r <= end_row && r->enabled_p; ++r)
2834 if (r->y + r->height > y) 2834 if (r->y + (int) r->height > y)
2835 { 2835 {
2836 gr = r; gy = r->y; 2836 gr = r; gy = r->y;
2837 break; 2837 break;
@@ -2931,7 +2931,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect)
2931 row_glyph: 2931 row_glyph:
2932 gr = 0, gy = 0; 2932 gr = 0, gy = 0;
2933 for (; r <= end_row && r->enabled_p; ++r) 2933 for (; r <= end_row && r->enabled_p; ++r)
2934 if (r->y + r->height > y) 2934 if (r->y + (int) r->height > y)
2935 { 2935 {
2936 gr = r; gy = r->y; 2936 gr = r; gy = r->y;
2937 break; 2937 break;
@@ -3821,7 +3821,7 @@ start_display (struct it *it, struct window *w, struct text_pos pos)
3821 3821
3822 it->current_y = first_y; 3822 it->current_y = first_y;
3823 it->vpos = 0; 3823 it->vpos = 0;
3824 it->current_x = it->hpos = 0; 3824 it->current_x = it->hpos = it->wrap_prefix_width = 0;
3825 } 3825 }
3826 } 3826 }
3827} 3827}
@@ -4345,10 +4345,7 @@ compute_stop_pos (struct it *it)
4345 } 4345 }
4346 } 4346 }
4347 4347
4348 if (it->cmp_it.id < 0 4348 if (it->cmp_it.id < 0)
4349 && (STRINGP (it->string)
4350 || ((!it->bidi_p || it->bidi_it.scan_dir >= 0)
4351 && it->cmp_it.stop_pos <= IT_CHARPOS (*it))))
4352 { 4349 {
4353 ptrdiff_t stoppos = it->end_charpos; 4350 ptrdiff_t stoppos = it->end_charpos;
4354 4351
@@ -4357,7 +4354,9 @@ compute_stop_pos (struct it *it)
4357 characters to that position. */ 4354 characters to that position. */
4358 if (it->bidi_p && it->bidi_it.scan_dir < 0) 4355 if (it->bidi_p && it->bidi_it.scan_dir < 0)
4359 stoppos = -1; 4356 stoppos = -1;
4360 else if (cmp_limit_pos > 0) 4357 else if (!STRINGP (it->string)
4358 && it->cmp_it.stop_pos <= IT_CHARPOS (*it)
4359 && cmp_limit_pos > 0)
4361 stoppos = cmp_limit_pos; 4360 stoppos = cmp_limit_pos;
4362 /* Force composition_compute_stop_pos avoid the costly search 4361 /* Force composition_compute_stop_pos avoid the costly search
4363 for static compositions, since those were already found by 4362 for static compositions, since those were already found by
@@ -5062,31 +5061,169 @@ handle_invisible_prop (struct it *it)
5062{ 5061{
5063 enum prop_handled handled = HANDLED_NORMALLY; 5062 enum prop_handled handled = HANDLED_NORMALLY;
5064 int invis; 5063 int invis;
5065 Lisp_Object prop; 5064 ptrdiff_t curpos, endpos;
5065 Lisp_Object prop, pos, overlay;
5066 5066
5067 /* Get the value of the invisible text property at the current
5068 position. Value will be nil if there is no such property. */
5067 if (STRINGP (it->string)) 5069 if (STRINGP (it->string))
5068 { 5070 {
5069 Lisp_Object end_charpos, limit; 5071 curpos = IT_STRING_CHARPOS (*it);
5072 endpos = SCHARS (it->string);
5073 pos = make_fixnum (curpos);
5074 prop = Fget_text_property (pos, Qinvisible, it->string);
5075 }
5076 else /* buffer */
5077 {
5078 curpos = IT_CHARPOS (*it);
5079 endpos = ZV;
5080 pos = make_fixnum (curpos);
5081 prop = get_char_property_and_overlay (pos, Qinvisible, it->window,
5082 &overlay);
5083 }
5070 5084
5071 /* Get the value of the invisible text property at the 5085 /* Do we have anything to do here? */
5072 current position. Value will be nil if there is no such 5086 invis = TEXT_PROP_MEANS_INVISIBLE (prop);
5073 property. */ 5087 if (invis == 0 || curpos >= it->end_charpos)
5074 end_charpos = make_fixnum (IT_STRING_CHARPOS (*it)); 5088 return handled;
5075 prop = Fget_text_property (end_charpos, Qinvisible, it->string);
5076 invis = TEXT_PROP_MEANS_INVISIBLE (prop);
5077 5089
5078 if (invis != 0 && IT_STRING_CHARPOS (*it) < it->end_charpos) 5090 /* If not bidi, or the bidi iteration is at base paragraph level, we
5091 can use a faster method; otherwise we need to check invisibility
5092 of every character while bidi-iterating out of invisible text. */
5093 bool slow = it->bidi_p && !BIDI_AT_BASE_LEVEL (it->bidi_it);
5094 /* Record whether we have to display an ellipsis for the
5095 invisible text. */
5096 bool display_ellipsis_p = (invis == 2);
5097
5098 handled = HANDLED_RECOMPUTE_PROPS;
5099
5100 if (slow)
5101 {
5102 if (it->bidi_it.first_elt && it->bidi_it.charpos < endpos)
5103 bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it, true);
5104
5105 if (STRINGP (it->string))
5106 {
5107 bool done = false;
5108 /* Bidi-iterate out of the invisible part of the string. */
5109 do
5110 {
5111 bidi_move_to_visually_next (&it->bidi_it);
5112 if (it->bidi_it.charpos < 0 || it->bidi_it.charpos >= endpos)
5113 done = true;
5114 else
5115 {
5116 pos = make_fixnum (it->bidi_it.charpos);
5117 prop = Fget_text_property (pos, Qinvisible, it->string);
5118 invis = TEXT_PROP_MEANS_INVISIBLE (prop);
5119 /* If there are adjacent invisible texts, don't lose
5120 the second one's ellipsis. */
5121 if (invis == 2)
5122 display_ellipsis_p = true;
5123 }
5124 }
5125 while (!done && invis != 0);
5126
5127 if (display_ellipsis_p)
5128 it->ellipsis_p = true;
5129 IT_STRING_CHARPOS (*it) = it->bidi_it.charpos;
5130 IT_STRING_BYTEPOS (*it) = it->bidi_it.bytepos;
5131 if (IT_STRING_BYTEPOS (*it) >= endpos)
5132 {
5133 /* The rest of the string is invisible. If this is an
5134 overlay string, proceed with the next overlay string
5135 or whatever comes and return a character from there. */
5136 if (it->current.overlay_string_index >= 0
5137 && !display_ellipsis_p)
5138 {
5139 next_overlay_string (it);
5140 /* Don't check for overlay strings when we just
5141 finished processing them. */
5142 handled = HANDLED_OVERLAY_STRING_CONSUMED;
5143 }
5144 }
5145 }
5146 else
5079 { 5147 {
5080 /* Record whether we have to display an ellipsis for the 5148 bool done = false;
5081 invisible text. */ 5149 /* Bidi-iterate out of the invisible text. */
5082 bool display_ellipsis_p = (invis == 2); 5150 do
5083 ptrdiff_t len, endpos; 5151 {
5152 bidi_move_to_visually_next (&it->bidi_it);
5153 if (it->bidi_it.charpos < BEGV || it->bidi_it.charpos >= endpos)
5154 done = true;
5155 else
5156 {
5157 pos = make_fixnum (it->bidi_it.charpos);
5158 prop = Fget_char_property (pos, Qinvisible, it->window);
5159 invis = TEXT_PROP_MEANS_INVISIBLE (prop);
5160 /* If there are adjacent invisible texts, don't lose
5161 the second one's ellipsis. */
5162 if (invis == 2)
5163 display_ellipsis_p = true;
5164 }
5165 }
5166 while (!done && invis != 0);
5167
5168 IT_CHARPOS (*it) = it->bidi_it.charpos;
5169 IT_BYTEPOS (*it) = it->bidi_it.bytepos;
5170 if (display_ellipsis_p)
5171 {
5172 /* Make sure that the glyphs of the ellipsis will get
5173 correct `charpos' values. See below for detailed
5174 explanation why this is needed. */
5175 it->position.charpos = IT_CHARPOS (*it) - 1;
5176 it->position.bytepos = CHAR_TO_BYTE (it->position.charpos);
5177 }
5178 /* If there are before-strings at the start of invisible
5179 text, and the text is invisible because of a text
5180 property, arrange to show before-strings because 20.x did
5181 it that way. (If the text is invisible because of an
5182 overlay property instead of a text property, this is
5183 already handled in the overlay code.) */
5184 if (NILP (overlay)
5185 && get_overlay_strings (it, it->stop_charpos))
5186 {
5187 handled = HANDLED_RECOMPUTE_PROPS;
5188 if (it->sp > 0)
5189 {
5190 it->stack[it->sp - 1].display_ellipsis_p = display_ellipsis_p;
5191 /* The call to get_overlay_strings above recomputes
5192 it->stop_charpos, but it only considers changes
5193 in properties and overlays beyond iterator's
5194 current position. This causes us to miss changes
5195 that happen exactly where the invisible property
5196 ended. So we play it safe here and force the
5197 iterator to check for potential stop positions
5198 immediately after the invisible text. Note that
5199 if get_overlay_strings returns true, it
5200 normally also pushed the iterator stack, so we
5201 need to update the stop position in the slot
5202 below the current one. */
5203 it->stack[it->sp - 1].stop_charpos
5204 = CHARPOS (it->stack[it->sp - 1].current.pos);
5205 }
5206 }
5207 else if (display_ellipsis_p)
5208 {
5209 it->ellipsis_p = true;
5210 /* Let the ellipsis display before
5211 considering any properties of the following char.
5212 Fixes jasonr@gnu.org 01 Oct 07 bug. */
5213 handled = HANDLED_RETURN;
5214 }
5215 }
5216 }
5217 else if (STRINGP (it->string))
5218 {
5219 Lisp_Object end_charpos = pos, limit;
5084 5220
5085 handled = HANDLED_RECOMPUTE_PROPS; 5221 if (invis != 0 && IT_STRING_CHARPOS (*it) < it->end_charpos)
5222 {
5223 ptrdiff_t len = endpos;
5086 5224
5087 /* Get the position at which the next visible text can be 5225 /* Get the position at which the next visible text can be
5088 found in IT->string, if any. */ 5226 found in IT->string, if any. */
5089 endpos = len = SCHARS (it->string);
5090 XSETINT (limit, len); 5227 XSETINT (limit, len);
5091 do 5228 do
5092 { 5229 {
@@ -5137,7 +5274,7 @@ handle_invisible_prop (struct it *it)
5137 5274
5138 IT_STRING_CHARPOS (*it) = it->bidi_it.charpos; 5275 IT_STRING_CHARPOS (*it) = it->bidi_it.charpos;
5139 IT_STRING_BYTEPOS (*it) = it->bidi_it.bytepos; 5276 IT_STRING_BYTEPOS (*it) = it->bidi_it.bytepos;
5140 if (IT_CHARPOS (*it) >= endpos) 5277 if (IT_STRING_CHARPOS (*it) >= endpos)
5141 it->prev_stop = endpos; 5278 it->prev_stop = endpos;
5142 } 5279 }
5143 else 5280 else
@@ -5167,27 +5304,14 @@ handle_invisible_prop (struct it *it)
5167 } 5304 }
5168 } 5305 }
5169 } 5306 }
5170 else 5307 else /* we are iterating over buffer text at base paragraph level */
5171 { 5308 {
5172 ptrdiff_t newpos, next_stop, start_charpos, tem; 5309 ptrdiff_t newpos, next_stop, tem = curpos;
5173 Lisp_Object pos, overlay; 5310 Lisp_Object pos;
5174
5175 /* First of all, is there invisible text at this position? */
5176 tem = start_charpos = IT_CHARPOS (*it);
5177 pos = make_fixnum (tem);
5178 prop = get_char_property_and_overlay (pos, Qinvisible, it->window,
5179 &overlay);
5180 invis = TEXT_PROP_MEANS_INVISIBLE (prop);
5181 5311
5182 /* If we are on invisible text, skip over it. */ 5312 /* If we are on invisible text, skip over it. */
5183 if (invis != 0 && start_charpos < it->end_charpos) 5313 if (invis != 0 && curpos < it->end_charpos)
5184 { 5314 {
5185 /* Record whether we have to display an ellipsis for the
5186 invisible text. */
5187 bool display_ellipsis_p = invis == 2;
5188
5189 handled = HANDLED_RECOMPUTE_PROPS;
5190
5191 /* Loop skipping over invisible text. The loop is left at 5315 /* Loop skipping over invisible text. The loop is left at
5192 ZV or with IT on the first char being visible again. */ 5316 ZV or with IT on the first char being visible again. */
5193 do 5317 do
@@ -5487,9 +5611,6 @@ display_min_width (struct it *it, ptrdiff_t bufpos,
5487 if (!NILP (it->min_width_property) 5611 if (!NILP (it->min_width_property)
5488 && !EQ (width_spec, it->min_width_property)) 5612 && !EQ (width_spec, it->min_width_property))
5489 { 5613 {
5490 if (!it->glyph_row)
5491 return;
5492
5493 /* When called from display_string (i.e., the mode line), 5614 /* When called from display_string (i.e., the mode line),
5494 we're being called with a string as the object, and we 5615 we're being called with a string as the object, and we
5495 may be called with many sub-strings belonging to the same 5616 may be called with many sub-strings belonging to the same
@@ -5532,7 +5653,13 @@ display_min_width (struct it *it, ptrdiff_t bufpos,
5532 it->object = list3 (Qspace, QCwidth, w); 5653 it->object = list3 (Qspace, QCwidth, w);
5533 produce_stretch_glyph (it); 5654 produce_stretch_glyph (it);
5534 if (it->area == TEXT_AREA) 5655 if (it->area == TEXT_AREA)
5535 it->current_x += it->pixel_width; 5656 {
5657 it->current_x += it->pixel_width;
5658
5659 if (it->continuation_lines_width
5660 && it->string_from_prefix_prop_p)
5661 it->wrap_prefix_width = it->current_x;
5662 }
5536 it->min_width_property = Qnil; 5663 it->min_width_property = Qnil;
5537 } 5664 }
5538 } 5665 }
@@ -9733,6 +9860,13 @@ move_it_in_display_line_to (struct it *it,
9733 ptrdiff_t prev_pos = IT_CHARPOS (*it); 9860 ptrdiff_t prev_pos = IT_CHARPOS (*it);
9734 bool saw_smaller_pos = prev_pos < to_charpos; 9861 bool saw_smaller_pos = prev_pos < to_charpos;
9735 bool line_number_pending = false; 9862 bool line_number_pending = false;
9863 int this_line_subject_to_line_prefix = 0;
9864
9865#ifdef GLYPH_DEBUG
9866 /* atx_flag, atpos_flag and wrap_flag are assigned but never used;
9867 these hold information useful while debugging. */
9868 int atx_flag, atpos_flag, wrap_flag;
9869#endif /* GLYPH_DEBUG */
9736 9870
9737 /* Don't produce glyphs in produce_glyphs. */ 9871 /* Don't produce glyphs in produce_glyphs. */
9738 saved_glyph_row = it->glyph_row; 9872 saved_glyph_row = it->glyph_row;
@@ -9798,6 +9932,11 @@ move_it_in_display_line_to (struct it *it,
9798 /* If there's a line-/wrap-prefix, handle it, if we didn't already. */ 9932 /* If there's a line-/wrap-prefix, handle it, if we didn't already. */
9799 if (it->area == TEXT_AREA && !it->string_from_prefix_prop_p) 9933 if (it->area == TEXT_AREA && !it->string_from_prefix_prop_p)
9800 handle_line_prefix (it); 9934 handle_line_prefix (it);
9935
9936 /* Save whether this line has received a wrap prefix, as this
9937 affects whether Emacs attempts to move glyphs into
9938 continuation lines. */
9939 this_line_subject_to_line_prefix = it->string_from_prefix_prop_p;
9801 } 9940 }
9802 9941
9803 if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos)) 9942 if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos))
@@ -9841,10 +9980,15 @@ move_it_in_display_line_to (struct it *it,
9841 break; 9980 break;
9842 } 9981 }
9843 else if (it->line_wrap == WORD_WRAP && atpos_it.sp < 0) 9982 else if (it->line_wrap == WORD_WRAP && atpos_it.sp < 0)
9844 /* If wrap_it is valid, the current position might be in a 9983 {
9845 word that is wrapped. So, save the iterator in 9984 /* If wrap_it is valid, the current position might be in
9846 atpos_it and continue to see if wrapping happens. */ 9985 a word that is wrapped. So, save the iterator in
9847 SAVE_IT (atpos_it, *it, atpos_data); 9986 atpos_it and continue to see if wrapping happens. */
9987 SAVE_IT (atpos_it, *it, atpos_data);
9988#ifdef GLYPH_DEBUG
9989 atpos_flag = this_line_subject_to_line_prefix;
9990#endif /* GLYPH_DEBUG */
9991 }
9848 } 9992 }
9849 9993
9850 /* Stop when ZV reached. 9994 /* Stop when ZV reached.
@@ -9906,6 +10050,9 @@ move_it_in_display_line_to (struct it *it,
9906 } 10050 }
9907 /* Otherwise, we can wrap here. */ 10051 /* Otherwise, we can wrap here. */
9908 SAVE_IT (wrap_it, *it, wrap_data); 10052 SAVE_IT (wrap_it, *it, wrap_data);
10053#ifdef GLYPH_DEBUG
10054 wrap_flag = this_line_subject_to_line_prefix;
10055#endif /* GLYPH_DEBUG */
9909 } 10056 }
9910 /* Update may_wrap for the next iteration. */ 10057 /* Update may_wrap for the next iteration. */
9911 may_wrap = next_may_wrap; 10058 may_wrap = next_may_wrap;
@@ -9984,6 +10131,9 @@ move_it_in_display_line_to (struct it *it,
9984 { 10131 {
9985 SAVE_IT (atpos_it, *it, atpos_data); 10132 SAVE_IT (atpos_it, *it, atpos_data);
9986 IT_RESET_X_ASCENT_DESCENT (&atpos_it); 10133 IT_RESET_X_ASCENT_DESCENT (&atpos_it);
10134#ifdef GLYPH_DEBUG
10135 atpos_flag = this_line_subject_to_line_prefix;
10136#endif /* GLYPH_DEBUG */
9987 } 10137 }
9988 } 10138 }
9989 else 10139 else
@@ -9998,6 +10148,9 @@ move_it_in_display_line_to (struct it *it,
9998 { 10148 {
9999 SAVE_IT (atx_it, *it, atx_data); 10149 SAVE_IT (atx_it, *it, atx_data);
10000 IT_RESET_X_ASCENT_DESCENT (&atx_it); 10150 IT_RESET_X_ASCENT_DESCENT (&atx_it);
10151#ifdef GLYPH_DEBUG
10152 atx_flag = this_line_subject_to_line_prefix;
10153#endif /* GLYPH_DEBUG */
10001 } 10154 }
10002 } 10155 }
10003 } 10156 }
@@ -10012,12 +10165,27 @@ move_it_in_display_line_to (struct it *it,
10012 && FRAME_WINDOW_P (it->f) 10165 && FRAME_WINDOW_P (it->f)
10013 && ((it->bidi_p && it->bidi_it.paragraph_dir == R2L) 10166 && ((it->bidi_p && it->bidi_it.paragraph_dir == R2L)
10014 ? WINDOW_LEFT_FRINGE_WIDTH (it->w) 10167 ? WINDOW_LEFT_FRINGE_WIDTH (it->w)
10015 : WINDOW_RIGHT_FRINGE_WIDTH (it->w))))) 10168 : WINDOW_RIGHT_FRINGE_WIDTH (it->w))))
10169 /* There is no line prefix, next to which the
10170 iterator _must_ produce a minimum of one actual
10171 glyph. */
10172 && (!this_line_subject_to_line_prefix
10173 /* Or this is the second glyph to be produced
10174 beyond the confines of the line. */
10175 || (i != 0
10176 && (x > it->last_visible_x
10177 || (x == it->last_visible_x
10178 && FRAME_WINDOW_P (it->f)
10179 && ((it->bidi_p
10180 && it->bidi_it.paragraph_dir == R2L)
10181 ? WINDOW_LEFT_FRINGE_WIDTH (it->w)
10182 : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))))
10016 { 10183 {
10017 bool moved_forward = false; 10184 bool moved_forward = false;
10018 10185
10019 if (/* IT->hpos == 0 means the very first glyph 10186 if (/* IT->hpos == 0 means the very first glyph
10020 doesn't fit on the line, e.g. a wide image. */ 10187 doesn't fit on the line, e.g. a wide
10188 image. */
10021 it->hpos == 0 10189 it->hpos == 0
10022 || (new_x == it->last_visible_x 10190 || (new_x == it->last_visible_x
10023 && FRAME_WINDOW_P (it->f))) 10191 && FRAME_WINDOW_P (it->f)))
@@ -10078,6 +10246,9 @@ move_it_in_display_line_to (struct it *it,
10078 SAVE_IT (atpos_it, *it, atpos_data); 10246 SAVE_IT (atpos_it, *it, atpos_data);
10079 atpos_it.current_x = x_before_this_char; 10247 atpos_it.current_x = x_before_this_char;
10080 atpos_it.hpos = hpos_before_this_char; 10248 atpos_it.hpos = hpos_before_this_char;
10249#ifdef GLYPH_DEBUG
10250 atpos_flag = this_line_subject_to_line_prefix;
10251#endif /* GLYPH_DEBUG */
10081 } 10252 }
10082 } 10253 }
10083 10254
@@ -10175,6 +10346,9 @@ move_it_in_display_line_to (struct it *it,
10175 if (it->line_wrap == WORD_WRAP && atpos_it.sp < 0) 10346 if (it->line_wrap == WORD_WRAP && atpos_it.sp < 0)
10176 { 10347 {
10177 SAVE_IT (atpos_it, *it, atpos_data); 10348 SAVE_IT (atpos_it, *it, atpos_data);
10349#ifdef GLYPH_DEBUG
10350 atpos_flag = this_line_subject_to_line_prefix;
10351#endif /* GLYPH_DEBUG */
10178 IT_RESET_X_ASCENT_DESCENT (&atpos_it); 10352 IT_RESET_X_ASCENT_DESCENT (&atpos_it);
10179 } 10353 }
10180 } 10354 }
@@ -10273,24 +10447,24 @@ move_it_in_display_line_to (struct it *it,
10273 if (it->method == GET_FROM_BUFFER) 10447 if (it->method == GET_FROM_BUFFER)
10274 prev_pos = IT_CHARPOS (*it); 10448 prev_pos = IT_CHARPOS (*it);
10275 10449
10276 /* Detect overly-wide wrap-prefixes made of (space ...) display 10450 /* The current display element has been consumed. Advance to
10277 properties. When such a wrap prefix reaches past the right 10451 the next. */
10278 margin of the window, we need to avoid the call to 10452 set_iterator_to_next (it, true);
10279 set_iterator_to_next below, so that it->line_wrap is left at 10453
10280 its TRUNCATE value wisely set by handle_line_prefix. 10454 /* If IT has just finished producing glyphs for the wrap prefix
10281 Otherwise, set_iterator_to_next will pop the iterator stack, 10455 and is proceeding to the next method, there might not be
10282 restore it->line_wrap, and we might miss the opportunity to 10456 sufficient space remaining in this line to accommodate its
10283 exit the loop and return. */ 10457 glyphs, and one real glyph must be produced to prevent an
10284 bool overwide_wrap_prefix = 10458 infinite loop. Next, clear this flag if such a glyph has
10285 CONSP (it->object) && EQ (XCAR (it->object), Qspace) 10459 already been produced. */
10286 && it->sp > 0 && it->method == GET_FROM_STRETCH 10460
10287 && it->current_x >= it->last_visible_x 10461 if (this_line_subject_to_line_prefix == 1
10288 && it->continuation_lines_width > 0 10462 && !it->string_from_prefix_prop_p)
10289 && it->line_wrap == TRUNCATE && it->stack[0].line_wrap != TRUNCATE; 10463 this_line_subject_to_line_prefix = 2;
10290 /* The current display element has been consumed. Advance 10464 else if (this_line_subject_to_line_prefix == 2
10291 to the next. */ 10465 && !it->string_from_prefix_prop_p)
10292 if (!overwide_wrap_prefix) 10466 this_line_subject_to_line_prefix = 0;
10293 set_iterator_to_next (it, true); 10467
10294 if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos)) 10468 if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos))
10295 SET_TEXT_POS (this_line_min_pos, IT_CHARPOS (*it), IT_BYTEPOS (*it)); 10469 SET_TEXT_POS (this_line_min_pos, IT_CHARPOS (*it), IT_BYTEPOS (*it));
10296 if (IT_CHARPOS (*it) < to_charpos) 10470 if (IT_CHARPOS (*it) < to_charpos)
@@ -10374,11 +10548,26 @@ move_it_in_display_line_to (struct it *it,
10374 && wrap_it.sp >= 0 10548 && wrap_it.sp >= 0
10375 && ((atpos_it.sp >= 0 && wrap_it.current_x < atpos_it.current_x) 10549 && ((atpos_it.sp >= 0 && wrap_it.current_x < atpos_it.current_x)
10376 || (atx_it.sp >= 0 && wrap_it.current_x < atx_it.current_x))) 10550 || (atx_it.sp >= 0 && wrap_it.current_x < atx_it.current_x)))
10377 RESTORE_IT (it, &wrap_it, wrap_data); 10551 {
10552#ifdef GLYPH_DEBUG
10553 this_line_subject_to_line_prefix = wrap_flag;
10554#endif /* GLYPH_DEBUG */
10555 RESTORE_IT (it, &wrap_it, wrap_data);
10556 }
10378 else if (atpos_it.sp >= 0) 10557 else if (atpos_it.sp >= 0)
10379 RESTORE_IT (it, &atpos_it, atpos_data); 10558 {
10559#ifdef GLYPH_DEBUG
10560 this_line_subject_to_line_prefix = atpos_flag;
10561#endif /* GLYPH_DEBUG */
10562 RESTORE_IT (it, &atpos_it, atpos_data);
10563 }
10380 else if (atx_it.sp >= 0) 10564 else if (atx_it.sp >= 0)
10381 RESTORE_IT (it, &atx_it, atx_data); 10565 {
10566#ifdef GLYPH_DEBUG
10567 this_line_subject_to_line_prefix = atx_flag;
10568#endif /* GLYPH_DEBUG */
10569 RESTORE_IT (it, &atx_it, atx_data);
10570 }
10382 10571
10383 done: 10572 done:
10384 10573
@@ -10452,13 +10641,9 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos
10452 int line_height, line_start_x = 0, reached = 0; 10641 int line_height, line_start_x = 0, reached = 0;
10453 int max_current_x = 0; 10642 int max_current_x = 0;
10454 void *backup_data = NULL; 10643 void *backup_data = NULL;
10455 ptrdiff_t orig_charpos = -1;
10456 enum it_method orig_method = NUM_IT_METHODS;
10457 10644
10458 for (;;) 10645 for (;;)
10459 { 10646 {
10460 orig_charpos = IT_CHARPOS (*it);
10461 orig_method = it->method;
10462 if (op & MOVE_TO_VPOS) 10647 if (op & MOVE_TO_VPOS)
10463 { 10648 {
10464 /* If no TO_CHARPOS and no TO_X specified, stop at the 10649 /* 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
10730 } 10915 }
10731 } 10916 }
10732 else 10917 else
10733 { 10918 it->continuation_lines_width += it->current_x;
10734 /* Make sure we do advance, otherwise we might infloop.
10735 This could happen when the first display element is
10736 wider than the window, or if we have a wrap-prefix
10737 that doesn't leave enough space after it to display
10738 even a single character. We only do this for moving
10739 through buffer text, as with display/overlay strings
10740 we'd need to also compare it->object's, and this is
10741 unlikely to happen in that case anyway. */
10742 if (IT_CHARPOS (*it) == orig_charpos
10743 && it->method == orig_method
10744 && orig_method == GET_FROM_BUFFER)
10745 set_iterator_to_next (it, false);
10746 it->continuation_lines_width += it->current_x;
10747 }
10748 break; 10919 break;
10749 10920
10750 default: 10921 default:
@@ -10753,6 +10924,7 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos
10753 10924
10754 /* Reset/increment for the next run. */ 10925 /* Reset/increment for the next run. */
10755 it->current_x = line_start_x; 10926 it->current_x = line_start_x;
10927 it->wrap_prefix_width = 0;
10756 line_start_x = 0; 10928 line_start_x = 0;
10757 it->hpos = 0; 10929 it->hpos = 0;
10758 it->line_number_produced_p = false; 10930 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
10783 { 10955 {
10784 it->continuation_lines_width += it->current_x; 10956 it->continuation_lines_width += it->current_x;
10785 it->current_x = it->hpos = it->max_ascent = it->max_descent = 0; 10957 it->current_x = it->hpos = it->max_ascent = it->max_descent = 0;
10958 it->wrap_prefix_width = 0;
10786 it->current_y += it->max_ascent + it->max_descent; 10959 it->current_y += it->max_ascent + it->max_descent;
10787 ++it->vpos; 10960 ++it->vpos;
10788 last_height = it->max_ascent + it->max_descent; 10961 last_height = it->max_ascent + it->max_descent;
@@ -10842,6 +11015,7 @@ move_it_vertically_backward (struct it *it, int dy)
10842 reseat_1 (it, it->current.pos, true); 11015 reseat_1 (it, it->current.pos, true);
10843 11016
10844 /* We are now surely at a line start. */ 11017 /* We are now surely at a line start. */
11018 it->wrap_prefix_width = 0;
10845 it->current_x = it->hpos = 0; /* FIXME: this is incorrect when bidi 11019 it->current_x = it->hpos = 0; /* FIXME: this is incorrect when bidi
10846 reordering is in effect. */ 11020 reordering is in effect. */
10847 it->continuation_lines_width = 0; 11021 it->continuation_lines_width = 0;
@@ -11120,7 +11294,7 @@ move_it_by_lines (struct it *it, ptrdiff_t dvpos)
11120 dvpos--; 11294 dvpos--;
11121 } 11295 }
11122 11296
11123 it->current_x = it->hpos = 0; 11297 it->current_x = it->hpos = it->wrap_prefix_width = 0;
11124 11298
11125 /* Above call may have moved too far if continuation lines 11299 /* Above call may have moved too far if continuation lines
11126 are involved. Scan forward and see if it did. */ 11300 are involved. Scan forward and see if it did. */
@@ -11129,7 +11303,7 @@ move_it_by_lines (struct it *it, ptrdiff_t dvpos)
11129 move_it_to (&it2, start_charpos, -1, -1, -1, MOVE_TO_POS); 11303 move_it_to (&it2, start_charpos, -1, -1, -1, MOVE_TO_POS);
11130 it->vpos -= it2.vpos; 11304 it->vpos -= it2.vpos;
11131 it->current_y -= it2.current_y; 11305 it->current_y -= it2.current_y;
11132 it->current_x = it->hpos = 0; 11306 it->current_x = it->hpos = it->wrap_prefix_width = 0;
11133 11307
11134 /* If we moved too far back, move IT some lines forward. */ 11308 /* If we moved too far back, move IT some lines forward. */
11135 if (it2.vpos > -dvpos) 11309 if (it2.vpos > -dvpos)
@@ -11408,7 +11582,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
11408 IT.current_x will be incorrectly set to zero at some arbitrary 11582 IT.current_x will be incorrectly set to zero at some arbitrary
11409 non-zero X coordinate. */ 11583 non-zero X coordinate. */
11410 move_it_by_lines (&it, 0); 11584 move_it_by_lines (&it, 0);
11411 it.current_x = it.hpos = 0; 11585 it.current_x = it.hpos = it.wrap_prefix_width = 0;
11412 if (IT_CHARPOS (it) != start) 11586 if (IT_CHARPOS (it) != start)
11413 { 11587 {
11414 void *it1data = NULL; 11588 void *it1data = NULL;
@@ -11461,7 +11635,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
11461 /* If FROM is on a newline, pretend that we start at the beginning 11635 /* If FROM is on a newline, pretend that we start at the beginning
11462 of the next line, because the newline takes no place on display. */ 11636 of the next line, because the newline takes no place on display. */
11463 if (FETCH_BYTE (start) == '\n') 11637 if (FETCH_BYTE (start) == '\n')
11464 it.current_x = 0; 11638 it.current_x = 0, it.wrap_prefix_width = 0;
11465 if (!NILP (x_limit)) 11639 if (!NILP (x_limit))
11466 { 11640 {
11467 it.last_visible_x = max_x; 11641 it.last_visible_x = max_x;
@@ -14373,7 +14547,7 @@ display_tab_bar_line (struct it *it, int height)
14373 row->truncated_on_left_p = false; 14547 row->truncated_on_left_p = false;
14374 row->truncated_on_right_p = false; 14548 row->truncated_on_right_p = false;
14375 14549
14376 it->current_x = it->hpos = 0; 14550 it->current_x = it->hpos = it->wrap_prefix_width = 0;
14377 it->current_y += row->height; 14551 it->current_y += row->height;
14378 ++it->vpos; 14552 ++it->vpos;
14379 ++it->glyph_row; 14553 ++it->glyph_row;
@@ -15397,7 +15571,7 @@ display_tool_bar_line (struct it *it, int height)
15397 row->truncated_on_left_p = false; 15571 row->truncated_on_left_p = false;
15398 row->truncated_on_right_p = false; 15572 row->truncated_on_right_p = false;
15399 15573
15400 it->current_x = it->hpos = 0; 15574 it->current_x = it->hpos = it->wrap_prefix_width = 0;
15401 it->current_y += row->height; 15575 it->current_y += row->height;
15402 ++it->vpos; 15576 ++it->vpos;
15403 ++it->glyph_row; 15577 ++it->glyph_row;
@@ -17097,6 +17271,7 @@ redisplay_internal (void)
17097 NULL, DEFAULT_FACE_ID); 17271 NULL, DEFAULT_FACE_ID);
17098 it.current_x = this_line_start_x; 17272 it.current_x = this_line_start_x;
17099 it.current_y = this_line_y; 17273 it.current_y = this_line_y;
17274 it.wrap_prefix_width = 0;
17100 it.vpos = this_line_vpos; 17275 it.vpos = this_line_vpos;
17101 17276
17102 if (current_buffer->long_line_optimizations_p 17277 if (current_buffer->long_line_optimizations_p
@@ -18682,6 +18857,14 @@ enum
18682 `scroll-conservatively' and the Emacs manual. */ 18857 `scroll-conservatively' and the Emacs manual. */
18683#define SCROLL_LIMIT 100 18858#define SCROLL_LIMIT 100
18684 18859
18860/* The freshness of the w->base_line_number cache is only ensured at every
18861 redisplay cycle, so the cache can be used only if there's been
18862 no relevant changes to the buffer since the last redisplay. */
18863#define BASE_LINE_NUMBER_VALID_P(w) \
18864 (eassert (current_buffer == XBUFFER ((w)->contents)), \
18865 !current_buffer->clip_changed \
18866 && BEG_UNCHANGED >= (w)->base_line_pos)
18867
18685static int 18868static int
18686try_scrolling (Lisp_Object window, bool just_this_one_p, 18869try_scrolling (Lisp_Object window, bool just_this_one_p,
18687 intmax_t arg_scroll_conservatively, intmax_t scroll_step, 18870 intmax_t arg_scroll_conservatively, intmax_t scroll_step,
@@ -18982,9 +19165,10 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
18982 else 19165 else
18983 { 19166 {
18984 /* Maybe forget recorded base line for line number display. */ 19167 /* Maybe forget recorded base line for line number display. */
18985 if (!just_this_one_p 19168 /* FIXME: Why do we need this? `try_scrolling` can only be called from
18986 || current_buffer->clip_changed 19169 `redisplay_window` which should have flushed this cache already when
18987 || BEG_UNCHANGED < CHARPOS (startp)) 19170 eeded. */
19171 if (!BASE_LINE_NUMBER_VALID_P (w))
18988 w->base_line_number = 0; 19172 w->base_line_number = 0;
18989 19173
18990 /* If cursor ends up on a partially visible line, 19174 /* If cursor ends up on a partially visible line,
@@ -19754,9 +19938,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
19754 /* Record it now because it's overwritten. */ 19938 /* Record it now because it's overwritten. */
19755 bool current_matrix_up_to_date_p = false; 19939 bool current_matrix_up_to_date_p = false;
19756 bool used_current_matrix_p = false; 19940 bool used_current_matrix_p = false;
19757 /* This is less strict than current_matrix_up_to_date_p.
19758 It indicates that the buffer contents and narrowing are unchanged. */
19759 bool buffer_unchanged_p = false;
19760 bool temp_scroll_step = false; 19941 bool temp_scroll_step = false;
19761 specpdl_ref count = SPECPDL_INDEX (); 19942 specpdl_ref count = SPECPDL_INDEX ();
19762 int rc; 19943 int rc;
@@ -19862,11 +20043,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
19862 20043
19863 specbind (Qinhibit_point_motion_hooks, Qt); 20044 specbind (Qinhibit_point_motion_hooks, Qt);
19864 20045
19865 buffer_unchanged_p
19866 = (w->window_end_valid
19867 && !current_buffer->clip_changed
19868 && !window_outdated (w));
19869
19870 /* When windows_or_buffers_changed is non-zero, we can't rely 20046 /* When windows_or_buffers_changed is non-zero, we can't rely
19871 on the window end being valid, so set it to zero there. */ 20047 on the window end being valid, so set it to zero there. */
19872 if (windows_or_buffers_changed) 20048 if (windows_or_buffers_changed)
@@ -20006,6 +20182,10 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
20006 } 20182 }
20007 } 20183 }
20008 20184
20185 if (!BASE_LINE_NUMBER_VALID_P (w))
20186 /* Forget any recorded base line for line number display. */
20187 w->base_line_number = 0;
20188
20009 force_start: 20189 force_start:
20010 20190
20011 /* Handle case where place to start displaying has been specified, 20191 /* Handle case where place to start displaying has been specified,
@@ -20026,10 +20206,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
20026 w->preserve_vscroll_p = false; 20206 w->preserve_vscroll_p = false;
20027 w->window_end_valid = false; 20207 w->window_end_valid = false;
20028 20208
20029 /* Forget any recorded base line for line number display. */
20030 if (!buffer_unchanged_p)
20031 w->base_line_number = 0;
20032
20033 /* Redisplay the mode line. Select the buffer properly for that. 20209 /* Redisplay the mode line. Select the buffer properly for that.
20034 Also, run the hook window-scroll-functions 20210 Also, run the hook window-scroll-functions
20035 because we have scrolled. */ 20211 because we have scrolled. */
@@ -20358,12 +20534,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
20358 20534
20359 if (w->cursor.vpos >= 0) 20535 if (w->cursor.vpos >= 0)
20360 { 20536 {
20361 if (!just_this_one_p
20362 || current_buffer->clip_changed
20363 || BEG_UNCHANGED < CHARPOS (startp))
20364 /* Forget any recorded base line for line number display. */
20365 w->base_line_number = 0;
20366
20367 if (!cursor_row_fully_visible_p (w, true, false, false)) 20537 if (!cursor_row_fully_visible_p (w, true, false, false))
20368 { 20538 {
20369 clear_glyph_matrix (w->desired_matrix); 20539 clear_glyph_matrix (w->desired_matrix);
@@ -20434,10 +20604,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
20434 debug_method_add (w, "recenter"); 20604 debug_method_add (w, "recenter");
20435#endif 20605#endif
20436 20606
20437 /* Forget any previously recorded base line for line number display. */
20438 if (!buffer_unchanged_p)
20439 w->base_line_number = 0;
20440
20441 /* Determine the window start relative to point. */ 20607 /* Determine the window start relative to point. */
20442 init_iterator (&it, w, PT, PT_BYTE, NULL, DEFAULT_FACE_ID); 20608 init_iterator (&it, w, PT, PT_BYTE, NULL, DEFAULT_FACE_ID);
20443 it.current_y = it.last_visible_y; 20609 it.current_y = it.last_visible_y;
@@ -20543,7 +20709,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
20543 it.current_y = 0; 20709 it.current_y = 0;
20544 } 20710 }
20545 20711
20546 it.current_x = it.hpos = 0; 20712 it.current_x = it.wrap_prefix_width = it.hpos = 0;
20547 20713
20548 /* Set the window start position here explicitly, to avoid an 20714 /* Set the window start position here explicitly, to avoid an
20549 infinite loop in case the functions in window-scroll-functions 20715 infinite loop in case the functions in window-scroll-functions
@@ -22511,7 +22677,7 @@ try_window_id (struct window *w)
22511 /* We may start in a continuation line. If so, we have to 22677 /* We may start in a continuation line. If so, we have to
22512 get the right continuation_lines_width and current_x. */ 22678 get the right continuation_lines_width and current_x. */
22513 it.continuation_lines_width = last_row->continuation_lines_width; 22679 it.continuation_lines_width = last_row->continuation_lines_width;
22514 it.hpos = it.current_x = 0; 22680 it.hpos = it.current_x = it.wrap_prefix_width = 0;
22515 22681
22516 /* Display the rest of the lines at the window end. */ 22682 /* Display the rest of the lines at the window end. */
22517 it.glyph_row = MATRIX_ROW (desired_matrix, it.vpos); 22683 it.glyph_row = MATRIX_ROW (desired_matrix, it.vpos);
@@ -23116,6 +23282,7 @@ insert_left_trunc_glyphs (struct it *it)
23116 /* Get the truncation glyphs. */ 23282 /* Get the truncation glyphs. */
23117 truncate_it = *it; 23283 truncate_it = *it;
23118 truncate_it.current_x = 0; 23284 truncate_it.current_x = 0;
23285 truncate_it.wrap_prefix_width = 0;
23119 truncate_it.face_id = DEFAULT_FACE_ID; 23286 truncate_it.face_id = DEFAULT_FACE_ID;
23120 truncate_it.glyph_row = &scratch_glyph_row; 23287 truncate_it.glyph_row = &scratch_glyph_row;
23121 truncate_it.area = TEXT_AREA; 23288 truncate_it.area = TEXT_AREA;
@@ -23878,6 +24045,10 @@ extend_face_to_end_of_line (struct it *it)
23878 for (it->current_x = 0; g < e; g++) 24045 for (it->current_x = 0; g < e; g++)
23879 it->current_x += g->pixel_width; 24046 it->current_x += g->pixel_width;
23880 24047
24048 if (it->continuation_lines_width
24049 && it->string_from_prefix_prop_p)
24050 it->wrap_prefix_width = it->current_x;
24051
23881 it->area = LEFT_MARGIN_AREA; 24052 it->area = LEFT_MARGIN_AREA;
23882 it->face_id = default_face->id; 24053 it->face_id = default_face->id;
23883 while (it->glyph_row->used[LEFT_MARGIN_AREA] 24054 while (it->glyph_row->used[LEFT_MARGIN_AREA]
@@ -24599,6 +24770,13 @@ maybe_produce_line_number (struct it *it)
24599 if (!last_line) 24770 if (!last_line)
24600 { 24771 {
24601 /* If possible, reuse data cached by line-number-mode. */ 24772 /* If possible, reuse data cached by line-number-mode. */
24773 /* NOTE: We use `base_line_number` without checking
24774 BASE_LINE_NUMBER_VALID_P because we assume that `redisplay_window`
24775 has already flushed this cache for us when needed.
24776 NOTE2: Checking BASE_LINE_NUMBER_VALID_P here would be
24777 overly pessimistic because it might say that the cache
24778 was invalid before entering `redisplay_window` yet the
24779 value has just been refreshed. */
24602 if (it->w->base_line_number > 0 24780 if (it->w->base_line_number > 0
24603 && it->w->base_line_pos > 0 24781 && it->w->base_line_pos > 0
24604 && it->w->base_line_pos <= IT_CHARPOS (*it) 24782 && it->w->base_line_pos <= IT_CHARPOS (*it)
@@ -24878,7 +25056,7 @@ should_produce_line_number (struct it *it)
24878 because get-char-property always returns nil for ZV, except if 25056 because get-char-property always returns nil for ZV, except if
24879 the property is in 'default-text-properties'. */ 25057 the property is in 'default-text-properties'. */
24880 if (NILP (val) && IT_CHARPOS (*it) >= ZV) 25058 if (NILP (val) && IT_CHARPOS (*it) >= ZV)
24881 val = disable_line_numbers_overlay_at_eob (); 25059 return !disable_line_numbers_overlay_at_eob ();
24882 return NILP (val) ? true : false; 25060 return NILP (val) ? true : false;
24883} 25061}
24884 25062
@@ -24943,6 +25121,7 @@ display_line (struct it *it, int cursor_vpos)
24943 int first_visible_x = it->first_visible_x; 25121 int first_visible_x = it->first_visible_x;
24944 int last_visible_x = it->last_visible_x; 25122 int last_visible_x = it->last_visible_x;
24945 int x_incr = 0; 25123 int x_incr = 0;
25124 int this_line_subject_to_line_prefix = 0;
24946 25125
24947 /* We always start displaying at hpos zero even if hscrolled. */ 25126 /* We always start displaying at hpos zero even if hscrolled. */
24948 eassert (it->hpos == 0 && it->current_x == 0); 25127 eassert (it->hpos == 0 && it->current_x == 0);
@@ -25019,7 +25198,10 @@ display_line (struct it *it, int cursor_vpos)
25019 if (it->current_x < it->first_visible_x 25198 if (it->current_x < it->first_visible_x
25020 && (move_result == MOVE_NEWLINE_OR_CR 25199 && (move_result == MOVE_NEWLINE_OR_CR
25021 || move_result == MOVE_POS_MATCH_OR_ZV)) 25200 || move_result == MOVE_POS_MATCH_OR_ZV))
25022 it->current_x = it->first_visible_x; 25201 {
25202 it->current_x = it->first_visible_x;
25203 it->wrap_prefix_width = 0;
25204 }
25023 25205
25024 /* In case move_it_in_display_line_to above "produced" the line 25206 /* In case move_it_in_display_line_to above "produced" the line
25025 number. */ 25207 number. */
@@ -25048,6 +25230,7 @@ display_line (struct it *it, int cursor_vpos)
25048 /* We only do this when not calling move_it_in_display_line_to 25230 /* We only do this when not calling move_it_in_display_line_to
25049 above, because that function calls itself handle_line_prefix. */ 25231 above, because that function calls itself handle_line_prefix. */
25050 handle_line_prefix (it); 25232 handle_line_prefix (it);
25233 this_line_subject_to_line_prefix = it->string_from_prefix_prop_p;
25051 } 25234 }
25052 else 25235 else
25053 { 25236 {
@@ -25214,12 +25397,15 @@ display_line (struct it *it, int cursor_vpos)
25214 process the prefix now. */ 25397 process the prefix now. */
25215 if (it->area == TEXT_AREA && pending_handle_line_prefix) 25398 if (it->area == TEXT_AREA && pending_handle_line_prefix)
25216 { 25399 {
25217 /* Line numbers should precede the line-prefix or wrap-prefix. */ 25400 /* Line numbers should precede the line-prefix or
25401 wrap-prefix. */
25218 if (line_number_needed) 25402 if (line_number_needed)
25219 maybe_produce_line_number (it); 25403 maybe_produce_line_number (it);
25220 25404
25221 pending_handle_line_prefix = false; 25405 pending_handle_line_prefix = false;
25222 handle_line_prefix (it); 25406 handle_line_prefix (it);
25407 this_line_subject_to_line_prefix
25408 = it->string_from_prefix_prop_p;
25223 } 25409 }
25224 continue; 25410 continue;
25225 } 25411 }
@@ -25240,7 +25426,16 @@ display_line (struct it *it, int cursor_vpos)
25240 if (/* Not a newline. */ 25426 if (/* Not a newline. */
25241 nglyphs > 0 25427 nglyphs > 0
25242 /* Glyphs produced fit entirely in the line. */ 25428 /* Glyphs produced fit entirely in the line. */
25243 && it->current_x < it->last_visible_x) 25429 && (it->current_x < it->last_visible_x
25430 /* Or a line or wrap prefix is in effect, and not
25431 truncating the glyph produced immediately after it
25432 would cause an infinite cycle. */
25433 || (it->line_wrap != TRUNCATE
25434 /* This code is not valid if multiple glyphs were
25435 produced, as some of these glyphs might remain
25436 within this line. */
25437 && nglyphs == 1
25438 && this_line_subject_to_line_prefix)))
25244 { 25439 {
25245 it->hpos += nglyphs; 25440 it->hpos += nglyphs;
25246 row->ascent = max (row->ascent, it->max_ascent); 25441 row->ascent = max (row->ascent, it->max_ascent);
@@ -25291,7 +25486,20 @@ display_line (struct it *it, int cursor_vpos)
25291 && FRAME_WINDOW_P (it->f) 25486 && FRAME_WINDOW_P (it->f)
25292 && (row->reversed_p 25487 && (row->reversed_p
25293 ? WINDOW_LEFT_FRINGE_WIDTH (it->w) 25488 ? WINDOW_LEFT_FRINGE_WIDTH (it->w)
25294 : WINDOW_RIGHT_FRINGE_WIDTH (it->w))))) 25489 : WINDOW_RIGHT_FRINGE_WIDTH (it->w))))
25490 /* There is no line prefix, next to which the
25491 iterator _must_ produce a minimum of one actual
25492 glyph. */
25493 && (!this_line_subject_to_line_prefix
25494 /* Or this is the second glyph to be produced
25495 beyond the confines of the line. */
25496 || (i != 0
25497 && (x > it->last_visible_x
25498 || (x == it->last_visible_x
25499 && FRAME_WINDOW_P (it->f)
25500 && (row->reversed_p
25501 ? WINDOW_LEFT_FRINGE_WIDTH (it->w)
25502 : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))))
25295 { 25503 {
25296 /* End of a continued line. */ 25504 /* End of a continued line. */
25297 25505
@@ -25588,24 +25796,23 @@ display_line (struct it *it, int cursor_vpos)
25588 break; 25796 break;
25589 } 25797 }
25590 25798
25591 /* Detect overly-wide wrap-prefixes made of (space ...) display
25592 properties. When such a wrap prefix reaches past the right
25593 margin of the window, we need to avoid the call to
25594 set_iterator_to_next below, so that it->line_wrap is left at
25595 its TRUNCATE value wisely set by handle_line_prefix.
25596 Otherwise, set_iterator_to_next will pop the iterator stack,
25597 restore it->line_wrap, and redisplay might infloop. */
25598 bool overwide_wrap_prefix =
25599 CONSP (it->object) && EQ (XCAR (it->object), Qspace)
25600 && it->sp > 0 && it->method == GET_FROM_STRETCH
25601 && it->current_x >= it->last_visible_x
25602 && it->continuation_lines_width > 0
25603 && it->line_wrap == TRUNCATE && it->stack[0].line_wrap != TRUNCATE;
25604
25605 /* Proceed with next display element. Note that this skips 25799 /* Proceed with next display element. Note that this skips
25606 over lines invisible because of selective display. */ 25800 over lines invisible because of selective display. */
25607 if (!overwide_wrap_prefix) 25801 set_iterator_to_next (it, true);
25608 set_iterator_to_next (it, true); 25802
25803 /* If IT has just finished producing glyphs for the wrap prefix
25804 and is proceeding to the next method, there might not be
25805 sufficient space remaining in this line to accommodate its
25806 glyphs, and one real glyph must be produced to prevent an
25807 infinite loop. Next, clear this flag if such a glyph has
25808 already been produced. */
25809
25810 if (this_line_subject_to_line_prefix == 1
25811 && !it->string_from_prefix_prop_p)
25812 this_line_subject_to_line_prefix = 2;
25813 else if (this_line_subject_to_line_prefix == 2
25814 && !it->string_from_prefix_prop_p)
25815 this_line_subject_to_line_prefix = 0;
25609 25816
25610 /* If we truncate lines, we are done when the last displayed 25817 /* If we truncate lines, we are done when the last displayed
25611 glyphs reach past the right margin of the window. */ 25818 glyphs reach past the right margin of the window. */
@@ -25851,7 +26058,7 @@ display_line (struct it *it, int cursor_vpos)
25851 HPOS) = (0 0). Vertical positions are incremented. As a 26058 HPOS) = (0 0). Vertical positions are incremented. As a
25852 convenience for the caller, IT->glyph_row is set to the next 26059 convenience for the caller, IT->glyph_row is set to the next
25853 row to be used. */ 26060 row to be used. */
25854 it->current_x = it->hpos = 0; 26061 it->wrap_prefix_width = it->current_x = it->hpos = 0;
25855 it->current_y += row->height; 26062 it->current_y += row->height;
25856 /* Restore the first and last visible X if we adjusted them for 26063 /* Restore the first and last visible X if we adjusted them for
25857 current-line hscrolling. */ 26064 current-line hscrolling. */
@@ -26330,7 +26537,7 @@ Value is the new character position of point. */)
26330 { 26537 {
26331 struct text_pos pt; 26538 struct text_pos pt;
26332 struct it it; 26539 struct it it;
26333 int pt_x, target_x, pixel_width, pt_vpos; 26540 int pt_x, pt_wrap_prefix_x, target_x, pixel_width, pt_vpos;
26334 bool at_eol_p; 26541 bool at_eol_p;
26335 bool overshoot_expected = false; 26542 bool overshoot_expected = false;
26336 bool target_is_eol_p = false; 26543 bool target_is_eol_p = false;
@@ -26362,6 +26569,7 @@ Value is the new character position of point. */)
26362 reseat: 26569 reseat:
26363 reseat_at_previous_visible_line_start (&it); 26570 reseat_at_previous_visible_line_start (&it);
26364 it.current_x = it.hpos = it.current_y = it.vpos = 0; 26571 it.current_x = it.hpos = it.current_y = it.vpos = 0;
26572 it.wrap_prefix_width = 0;
26365 if (IT_CHARPOS (it) != PT) 26573 if (IT_CHARPOS (it) != PT)
26366 { 26574 {
26367 move_it_to (&it, overshoot_expected ? PT - 1 : PT, 26575 move_it_to (&it, overshoot_expected ? PT - 1 : PT,
@@ -26380,6 +26588,7 @@ Value is the new character position of point. */)
26380 move_it_in_display_line (&it, PT, -1, MOVE_TO_POS); 26588 move_it_in_display_line (&it, PT, -1, MOVE_TO_POS);
26381 } 26589 }
26382 pt_x = it.current_x; 26590 pt_x = it.current_x;
26591 pt_wrap_prefix_x = it.wrap_prefix_width;
26383 pt_vpos = it.vpos; 26592 pt_vpos = it.vpos;
26384 if (dir > 0 || overshoot_expected) 26593 if (dir > 0 || overshoot_expected)
26385 { 26594 {
@@ -26394,10 +26603,11 @@ Value is the new character position of point. */)
26394 it.glyph_row = NULL; 26603 it.glyph_row = NULL;
26395 PRODUCE_GLYPHS (&it); /* compute it.pixel_width */ 26604 PRODUCE_GLYPHS (&it); /* compute it.pixel_width */
26396 it.glyph_row = row; 26605 it.glyph_row = row;
26397 /* PRODUCE_GLYPHS advances it.current_x, so we must restore 26606 /* PRODUCE_GLYPHS advances it.current_x, so it must be
26398 it, lest it will become out of sync with it's buffer 26607 restored, lest it become out of sync with its buffer
26399 position. */ 26608 position. */
26400 it.current_x = pt_x; 26609 it.current_x = pt_x;
26610 it.wrap_prefix_width = pt_wrap_prefix_x;
26401 } 26611 }
26402 else 26612 else
26403 at_eol_p = ITERATOR_AT_END_OF_LINE_P (&it); 26613 at_eol_p = ITERATOR_AT_END_OF_LINE_P (&it);
@@ -26442,6 +26652,7 @@ Value is the new character position of point. */)
26442 it.last_visible_x = DISP_INFINITY; 26652 it.last_visible_x = DISP_INFINITY;
26443 reseat_at_previous_visible_line_start (&it); 26653 reseat_at_previous_visible_line_start (&it);
26444 it.current_x = it.current_y = it.hpos = 0; 26654 it.current_x = it.current_y = it.hpos = 0;
26655 it.wrap_prefix_width = 0;
26445 if (pt_vpos != 0) 26656 if (pt_vpos != 0)
26446 move_it_by_lines (&it, pt_vpos); 26657 move_it_by_lines (&it, pt_vpos);
26447 } 26658 }
@@ -27958,6 +28169,11 @@ are the selected window and the WINDOW's buffer). */)
27958 28169
27959 init_iterator (&it, w, -1, -1, NULL, face_id); 28170 init_iterator (&it, w, -1, -1, NULL, face_id);
27960 28171
28172 /* Make sure `base_line_number` is fresh in case we encounter a `%l`. */
28173 if (current_buffer == XBUFFER ((w)->contents)
28174 && !BASE_LINE_NUMBER_VALID_P (w))
28175 w->base_line_number = 0;
28176
27961 if (no_props) 28177 if (no_props)
27962 { 28178 {
27963 mode_line_target = MODE_LINE_NOPROP; 28179 mode_line_target = MODE_LINE_NOPROP;
@@ -28410,30 +28626,29 @@ decode_mode_spec (struct window *w, register int c, int field_width,
28410 when the buffer's restriction was changed, but the window 28626 when the buffer's restriction was changed, but the window
28411 wasn't yet redisplayed after that. If that happens, we 28627 wasn't yet redisplayed after that. If that happens, we
28412 need to determine a new base line. */ 28628 need to determine a new base line. */
28413 if (!(BUF_BEGV_BYTE (b) <= startpos_byte 28629 if (current_buffer != XBUFFER (w->contents)
28630 || !(BUF_BEGV_BYTE (b) <= startpos_byte
28414 && startpos_byte <= BUF_ZV_BYTE (b))) 28631 && startpos_byte <= BUF_ZV_BYTE (b)))
28415 { 28632 {
28416 startpos = BUF_BEGV (b); 28633 startpos = BUF_BEGV (b);
28417 startpos_byte = BUF_BEGV_BYTE (b); 28634 startpos_byte = BUF_BEGV_BYTE (b);
28418 w->base_line_pos = 0;
28419 w->base_line_number = 0;
28420 } 28635 }
28421 28636
28422 /* If we decided that this buffer isn't suitable for line numbers, 28637 /* If we decided that this buffer isn't suitable for line numbers,
28423 don't forget that too fast. */ 28638 don't forget that too fast.
28639 FIXME: What if `current_buffer != w->contents`? */
28424 if (w->base_line_pos == -1) 28640 if (w->base_line_pos == -1)
28425 goto no_value; 28641 goto no_value;
28426 28642
28427 /* If the buffer is very big, don't waste time. */ 28643 /* If the buffer is very big, don't waste time. */
28428 if (FIXNUMP (Vline_number_display_limit) 28644 if (FIXNUMP (Vline_number_display_limit)
28429 && BUF_ZV (b) - BUF_BEGV (b) > XFIXNUM (Vline_number_display_limit)) 28645 && BUF_ZV (b) - BUF_BEGV (b) > XFIXNUM (Vline_number_display_limit))
28430 { 28646 goto no_value;
28431 w->base_line_pos = 0;
28432 w->base_line_number = 0;
28433 goto no_value;
28434 }
28435 28647
28436 if (w->base_line_number > 0 28648 /* Callers of `display_mode_element` are in charge of flushing
28649 any stale `base_line_number` cache. */
28650 if (current_buffer == XBUFFER ((w)->contents)
28651 && w->base_line_number > 0
28437 && w->base_line_pos > 0 28652 && w->base_line_pos > 0
28438 && w->base_line_pos <= startpos) 28653 && w->base_line_pos <= startpos)
28439 { 28654 {
@@ -28459,7 +28674,9 @@ decode_mode_spec (struct window *w, register int c, int field_width,
28459 or too far away, or if we did not have one. 28674 or too far away, or if we did not have one.
28460 "Too close" means it's plausible a scroll-down would 28675 "Too close" means it's plausible a scroll-down would
28461 go back past it. */ 28676 go back past it. */
28462 if (startpos == BUF_BEGV (b)) 28677 if (current_buffer != XBUFFER (w->contents))
28678 ; /* The base line is for another buffer, don't touch it! */
28679 else if (startpos == BUF_BEGV (b))
28463 { 28680 {
28464 w->base_line_number = topline; 28681 w->base_line_number = topline;
28465 w->base_line_pos = BUF_BEGV (b); 28682 w->base_line_pos = BUF_BEGV (b);
@@ -28496,6 +28713,12 @@ decode_mode_spec (struct window *w, register int c, int field_width,
28496 goto no_value; 28713 goto no_value;
28497 } 28714 }
28498 28715
28716 /* NOTE: if `clip_changed` is set or if `BEG_UNCHANGED` is
28717 before `position`, this new cached value may get flushed
28718 soon needlessly, because we can't reset `BEG_UNCHANGED` or
28719 `clip_changed` from here (since they reflect the changes
28720 since the last redisplay so they can only be reset from
28721 `mark_window_display_accurate_1`). :-( */
28499 w->base_line_number = topline - nlines; 28722 w->base_line_number = topline - nlines;
28500 w->base_line_pos = BYTE_TO_CHAR (position); 28723 w->base_line_pos = BYTE_TO_CHAR (position);
28501 } 28724 }
@@ -32589,7 +32812,19 @@ gui_produce_glyphs (struct it *it)
32589 if (font->space_width > 0) 32812 if (font->space_width > 0)
32590 { 32813 {
32591 int tab_width = it->tab_width * font->space_width; 32814 int tab_width = it->tab_width * font->space_width;
32592 int x = it->current_x + it->continuation_lines_width; 32815 /* wrap-prefix strings are prepended to continuation
32816 lines, so the width of tab characters inside should
32817 be computed from the start of this screen line rather
32818 than as a product of the total width of the physical
32819 line being wrapped. */
32820 int x = it->current_x + (it->string_from_prefix_prop_p
32821 /* Subtract the width of the
32822 prefix from it->current_x if
32823 it exists. */
32824 ? 0 : (it->continuation_lines_width
32825 ? (it->continuation_lines_width
32826 - it->wrap_prefix_width)
32827 : 0));
32593 int x0 = x; 32828 int x0 = x;
32594 /* Adjust for line numbers, if needed. */ 32829 /* Adjust for line numbers, if needed. */
32595 if (!NILP (Vdisplay_line_numbers) && it->line_number_produced_p) 32830 if (!NILP (Vdisplay_line_numbers) && it->line_number_produced_p)
@@ -33060,7 +33295,13 @@ gui_produce_glyphs (struct it *it)
33060 because this isn't true for images with `:ascent 100'. */ 33295 because this isn't true for images with `:ascent 100'. */
33061 eassert (it->ascent >= 0 && it->descent >= 0); 33296 eassert (it->ascent >= 0 && it->descent >= 0);
33062 if (it->area == TEXT_AREA) 33297 if (it->area == TEXT_AREA)
33063 it->current_x += it->pixel_width; 33298 {
33299 it->current_x += it->pixel_width;
33300
33301 if (it->continuation_lines_width
33302 && it->string_from_prefix_prop_p)
33303 it->wrap_prefix_width = it->current_x;
33304 }
33064 33305
33065 if (extra_line_spacing > 0) 33306 if (extra_line_spacing > 0)
33066 { 33307 {
@@ -36219,7 +36460,7 @@ expose_area (struct window *w, struct glyph_row *row, const Emacs_Rectangle *r,
36219 /* Use a signed int intermediate value to avoid catastrophic 36460 /* Use a signed int intermediate value to avoid catastrophic
36220 failures due to comparison between signed and unsigned, when 36461 failures due to comparison between signed and unsigned, when
36221 x is negative (can happen for wide images that are hscrolled). */ 36462 x is negative (can happen for wide images that are hscrolled). */
36222 int r_end = r->x + r->width; 36463 int r_end = r->x + (int) r->width;
36223 while (last < end && x < r_end) 36464 while (last < end && x < r_end)
36224 { 36465 {
36225 x += last->pixel_width; 36466 x += last->pixel_width;
@@ -36518,7 +36759,7 @@ expose_window (struct window *w, const Emacs_Rectangle *fr)
36518 /* Use a signed int intermediate value to avoid catastrophic 36759 /* Use a signed int intermediate value to avoid catastrophic
36519 failures due to comparison between signed and unsigned, when 36760 failures due to comparison between signed and unsigned, when
36520 y0 or y1 is negative (can happen for tall images). */ 36761 y0 or y1 is negative (can happen for tall images). */
36521 int r_bottom = r.y + r.height; 36762 int r_bottom = r.y + (int) r.height;
36522 36763
36523 /* We must temporarily switch to the window's buffer, in case 36764 /* We must temporarily switch to the window's buffer, in case
36524 the fringe face has been remapped in that buffer's 36765 the fringe face has been remapped in that buffer's
@@ -36565,7 +36806,7 @@ expose_window (struct window *w, const Emacs_Rectangle *fr)
36565 /* We must redraw a row overlapping the exposed area. */ 36806 /* We must redraw a row overlapping the exposed area. */
36566 if (y0 < r.y 36807 if (y0 < r.y
36567 ? y0 + row->phys_height > r.y 36808 ? y0 + row->phys_height > r.y
36568 : y0 + row->ascent - row->phys_ascent < r.y +r.height) 36809 : y0 + row->ascent - row->phys_ascent < r.y + (int) r.height)
36569 { 36810 {
36570 if (first_overlapping_row == NULL) 36811 if (first_overlapping_row == NULL)
36571 first_overlapping_row = row; 36812 first_overlapping_row = row;
@@ -36744,7 +36985,7 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1, const Emacs_Rectangle *r2,
36744 const Emacs_Rectangle *upper, *lower; 36985 const Emacs_Rectangle *upper, *lower;
36745 bool intersection_p = false; 36986 bool intersection_p = false;
36746 36987
36747 /* Rearrange so that R1 is the left-most rectangle. */ 36988 /* Rearrange so that left is the left-most rectangle. */
36748 if (r1->x < r2->x) 36989 if (r1->x < r2->x)
36749 left = r1, right = r2; 36990 left = r1, right = r2;
36750 else 36991 else
@@ -36752,13 +36993,14 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1, const Emacs_Rectangle *r2,
36752 36993
36753 /* X0 of the intersection is right.x0, if this is inside R1, 36994 /* X0 of the intersection is right.x0, if this is inside R1,
36754 otherwise there is no intersection. */ 36995 otherwise there is no intersection. */
36755 if (right->x <= left->x + left->width) 36996 if (right->x <= left->x + (int) left->width)
36756 { 36997 {
36757 result->x = right->x; 36998 result->x = right->x;
36758 36999
36759 /* The right end of the intersection is the minimum of 37000 /* The right end of the intersection is the minimum of
36760 the right ends of left and right. */ 37001 the right ends of left and right. */
36761 result->width = (min (left->x + left->width, right->x + right->width) 37002 result->width = (min (left->x + (int) left->width,
37003 right->x + (int) right->width)
36762 - result->x); 37004 - result->x);
36763 37005
36764 /* Same game for Y. */ 37006 /* Same game for Y. */
@@ -36769,14 +37011,14 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1, const Emacs_Rectangle *r2,
36769 37011
36770 /* The upper end of the intersection is lower.y0, if this is inside 37012 /* The upper end of the intersection is lower.y0, if this is inside
36771 of upper. Otherwise, there is no intersection. */ 37013 of upper. Otherwise, there is no intersection. */
36772 if (lower->y <= upper->y + upper->height) 37014 if (lower->y <= upper->y + (int) upper->height)
36773 { 37015 {
36774 result->y = lower->y; 37016 result->y = lower->y;
36775 37017
36776 /* The lower end of the intersection is the minimum of the lower 37018 /* The lower end of the intersection is the minimum of the lower
36777 ends of upper and lower. */ 37019 ends of upper and lower. */
36778 result->height = (min (lower->y + lower->height, 37020 result->height = (min (lower->y + (int) lower->height,
36779 upper->y + upper->height) 37021 upper->y + (int) upper->height)
36780 - result->y); 37022 - result->y);
36781 intersection_p = true; 37023 intersection_p = true;
36782 } 37024 }
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)
2245 2245
2246/* Merge two Lisp face attribute vectors on frame F, FROM and TO, and 2246/* Merge two Lisp face attribute vectors on frame F, FROM and TO, and
2247 store the resulting attributes in TO, which must be already be 2247 store the resulting attributes in TO, which must be already be
2248 completely specified and contain only absolute attributes. 2248 completely specified and contain only absolute attributes. Every
2249 Every specified attribute of FROM overrides the corresponding 2249 specified attribute of FROM overrides the corresponding attribute of
2250 attribute of TO; relative attributes in FROM are merged with the 2250 TO; merge relative attributes in FROM with the absolute value in TO,
2251 absolute value in TO and replace it. NAMED_MERGE_POINTS is used 2251 which attributes also replace it. Use NAMED_MERGE_POINTS internally
2252 internally to detect loops in face inheritance/remapping; it should 2252 to detect loops in face inheritance/remapping; it should be 0 when
2253 be 0 when called from other places. If window W is non-NULL, use W 2253 called from other places. If window W is non-NULL, use W to
2254 to interpret face specifications. */ 2254 interpret face specifications. */
2255static void 2255static void
2256merge_face_vectors (struct window *w, 2256merge_face_vectors (struct window *w,
2257 struct frame *f, const Lisp_Object *from, Lisp_Object *to, 2257 struct frame *f, const Lisp_Object *from, Lisp_Object *to,
2258 struct named_merge_point *named_merge_points) 2258 struct named_merge_point *named_merge_points)
2259{ 2259{
2260 int i; 2260 int i;
2261 Lisp_Object font = Qnil; 2261 Lisp_Object font = Qnil, tospec, adstyle;
2262 2262
2263 /* If FROM inherits from some other faces, merge their attributes into 2263 /* If FROM inherits from some other faces, merge their attributes into
2264 TO before merging FROM's direct attributes. Note that an :inherit 2264 TO before merging FROM's direct attributes. Note that an :inherit
@@ -2318,6 +2318,25 @@ merge_face_vectors (struct window *w,
2318 to[LFACE_SLANT_INDEX] = FONT_SLANT_FOR_FACE (font); 2318 to[LFACE_SLANT_INDEX] = FONT_SLANT_FOR_FACE (font);
2319 if (! NILP (AREF (font, FONT_WIDTH_INDEX))) 2319 if (! NILP (AREF (font, FONT_WIDTH_INDEX)))
2320 to[LFACE_SWIDTH_INDEX] = FONT_WIDTH_FOR_FACE (font); 2320 to[LFACE_SWIDTH_INDEX] = FONT_WIDTH_FOR_FACE (font);
2321
2322 if (!NILP (AREF (font, FONT_ADSTYLE_INDEX)))
2323 {
2324 /* If an adstyle is specified in FROM's font spec, create a
2325 font spec for TO if none exists, and transfer the adstyle
2326 there. */
2327
2328 tospec = to[LFACE_FONT_INDEX];
2329 adstyle = AREF (font, FONT_ADSTYLE_INDEX);
2330
2331 if (!NILP (tospec))
2332 tospec = copy_font_spec (tospec);
2333 else
2334 tospec = Ffont_spec (0, NULL);
2335
2336 to[LFACE_FONT_INDEX] = tospec;
2337 ASET (tospec, FONT_ADSTYLE_INDEX, adstyle);
2338 }
2339
2321 ASET (font, FONT_SIZE_INDEX, Qnil); 2340 ASET (font, FONT_SIZE_INDEX, Qnil);
2322 } 2341 }
2323 2342
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 ?= \
92# Additional settings for ert. 92# Additional settings for ert.
93ert_opts = 93ert_opts =
94 94
95# Supply a path to local tree-sitter installations, as we run tests
96# without a valid HOME.
97ert_opts += --eval "(setq treesit-extra-load-path '(\"$(HOME)/.emacs.d/tree-sitter\"))"
98
95# Maximum length of lines in ert backtraces; nil for no limit. 99# Maximum length of lines in ert backtraces; nil for no limit.
96# (if empty, use the default ert-batch-backtrace-right-margin). 100# (if empty, use the default ert-batch-backtrace-right-margin).
97TEST_BACKTRACE_LINE_LENGTH = 101TEST_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 \
126 (java "https://github.com/tree-sitter/tree-sitter-java") \ 126 (java "https://github.com/tree-sitter/tree-sitter-java") \
127 (javascript "https://github.com/tree-sitter/tree-sitter-javascript") \ 127 (javascript "https://github.com/tree-sitter/tree-sitter-javascript") \
128 (json "https://github.com/tree-sitter/tree-sitter-json") \ 128 (json "https://github.com/tree-sitter/tree-sitter-json") \
129 (lua "https://github.com/MunifTanjim/tree-sitter-lua") \ 129 (lua "https://github.com/tree-sitter-grammars/tree-sitter-lua") \
130 (python "https://github.com/tree-sitter/tree-sitter-python") \ 130 (python "https://github.com/tree-sitter/tree-sitter-python") \
131 (ruby "https://github.com/tree-sitter/tree-sitter-ruby") \ 131 (ruby "https://github.com/tree-sitter/tree-sitter-ruby") \
132 (tsx "https://github.com/tree-sitter/tree-sitter-typescript" "master" "tsx/src") \ 132 (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 @@
57(ert-deftest abbrev-make-abbrev-table-test () 57(ert-deftest abbrev-make-abbrev-table-test ()
58 ;; Table without properties: 58 ;; Table without properties:
59 (let ((table (make-abbrev-table))) 59 (let ((table (make-abbrev-table)))
60 (should (abbrev-table-p table)) 60 (should (abbrev-table-p table)))
61 (should (= (length table) obarray-default-size)))
62 ;; Table with one property 'foo with value 'bar: 61 ;; Table with one property 'foo with value 'bar:
63 (let ((table (make-abbrev-table '(foo bar)))) 62 (let ((table (make-abbrev-table '(foo bar))))
64 (should (abbrev-table-p table)) 63 (should (abbrev-table-p table))
65 (should (= (length table) obarray-default-size))
66 (should (eq (abbrev-table-get table 'foo) 'bar)))) 64 (should (eq (abbrev-table-get table 'foo) 'bar))))
67 65
68(ert-deftest abbrev--table-symbols-test () 66(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 @@
33(require 'secrets) 33(require 'secrets)
34 34
35(defun auth-source-ensure-ignored-backend (source) 35(defun auth-source-ensure-ignored-backend (source)
36 (auth-source-validate-backend source '((:source . "") 36 (auth-source-validate-backend source '((source . "")
37 (:type . ignore)))) 37 (type . ignore))))
38 38
39(defun auth-source-validate-backend (source validation-alist) 39(defun auth-source-validate-backend (source validation-alist)
40 (let ((backend (auth-source-backend-parse source))) 40 (let ((backend (auth-source-backend-parse source)))
@@ -44,84 +44,101 @@
44 44
45(ert-deftest auth-source-backend-parse-macos-keychain () 45(ert-deftest auth-source-backend-parse-macos-keychain ()
46 (auth-source-validate-backend '(:source (:macos-keychain-generic foobar)) 46 (auth-source-validate-backend '(:source (:macos-keychain-generic foobar))
47 '((:source . "foobar") 47 '((source . "foobar")
48 (:type . macos-keychain-generic) 48 (type . macos-keychain-generic)
49 (:search-function . auth-source-macos-keychain-search) 49 (search-function . auth-source-macos-keychain-search)
50 (:create-function . auth-source-macos-keychain-create)))) 50 (create-function . auth-source-macos-keychain-create))))
51 51
52(ert-deftest auth-source-backend-parse-macos-keychain-generic-string () 52(ert-deftest auth-source-backend-parse-macos-keychain-generic-string ()
53 (auth-source-validate-backend "macos-keychain-generic:foobar" 53 (auth-source-validate-backend "macos-keychain-generic:foobar"
54 '((:source . "foobar") 54 '((source . "foobar")
55 (:type . macos-keychain-generic) 55 (type . macos-keychain-generic)
56 (:search-function . auth-source-macos-keychain-search) 56 (search-function
57 (:create-function . auth-source-macos-keychain-create)))) 57 . auth-source-macos-keychain-search)
58 (create-function
59 . auth-source-macos-keychain-create))))
58 60
59(ert-deftest auth-source-backend-parse-macos-keychain-internet-string () 61(ert-deftest auth-source-backend-parse-macos-keychain-internet-string ()
60 (auth-source-validate-backend "macos-keychain-internet:foobar" 62 (auth-source-validate-backend "macos-keychain-internet:foobar"
61 '((:source . "foobar") 63 '((source . "foobar")
62 (:type . macos-keychain-internet) 64 (type . macos-keychain-internet)
63 (:search-function . auth-source-macos-keychain-search) 65 (search-function
64 (:create-function . auth-source-macos-keychain-create)))) 66 . auth-source-macos-keychain-search)
67 (create-function
68 . auth-source-macos-keychain-create))))
65 69
66(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol () 70(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol ()
67 (auth-source-validate-backend 'macos-keychain-internet 71 (auth-source-validate-backend 'macos-keychain-internet
68 '((:source . "default") 72 '((source . "default")
69 (:type . macos-keychain-internet) 73 (type . macos-keychain-internet)
70 (:search-function . auth-source-macos-keychain-search) 74 (search-function
71 (:create-function . auth-source-macos-keychain-create)))) 75 . auth-source-macos-keychain-search)
76 (create-function
77 . auth-source-macos-keychain-create))))
72 78
73(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol () 79(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol ()
74 (auth-source-validate-backend 'macos-keychain-generic 80 (auth-source-validate-backend 'macos-keychain-generic
75 '((:source . "default") 81 '((source . "default")
76 (:type . macos-keychain-generic) 82 (type . macos-keychain-generic)
77 (:search-function . auth-source-macos-keychain-search) 83 (search-function
78 (:create-function . auth-source-macos-keychain-create)))) 84 . auth-source-macos-keychain-search)
85 (create-function
86 . auth-source-macos-keychain-create))))
79 87
80(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string () 88(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string ()
81 (auth-source-validate-backend 'macos-keychain-internet 89 (auth-source-validate-backend 'macos-keychain-internet
82 '((:source . "default") 90 '((source . "default")
83 (:type . macos-keychain-internet) 91 (type . macos-keychain-internet)
84 (:search-function . auth-source-macos-keychain-search) 92 (search-function
85 (:create-function . auth-source-macos-keychain-create)))) 93 . auth-source-macos-keychain-search)
94 (create-function
95 . auth-source-macos-keychain-create))))
86 96
87(ert-deftest auth-source-backend-parse-plstore () 97(ert-deftest auth-source-backend-parse-plstore ()
88 (auth-source-validate-backend '(:source "foo.plist") 98 (auth-source-validate-backend '(:source "foo.plist")
89 '((:source . "foo.plist") 99 '((source . "foo.plist")
90 (:type . plstore) 100 (type . plstore)
91 (:search-function . auth-source-plstore-search) 101 (search-function . auth-source-plstore-search)
92 (:create-function . auth-source-plstore-create)))) 102 (create-function
103 . auth-source-plstore-create))))
93 104
94(ert-deftest auth-source-backend-parse-netrc () 105(ert-deftest auth-source-backend-parse-netrc ()
95 (auth-source-validate-backend '(:source "foo") 106 (auth-source-validate-backend '(:source "foo")
96 '((:source . "foo") 107 '((source . "foo")
97 (:type . netrc) 108 (type . netrc)
98 (:search-function . auth-source-netrc-search) 109 (search-function . auth-source-netrc-search)
99 (:create-function . auth-source-netrc-create)))) 110 (create-function
111 . auth-source-netrc-create))))
100 112
101(ert-deftest auth-source-backend-parse-netrc-string () 113(ert-deftest auth-source-backend-parse-netrc-string ()
102 (auth-source-validate-backend "foo" 114 (auth-source-validate-backend "foo"
103 '((:source . "foo") 115 '((source . "foo")
104 (:type . netrc) 116 (type . netrc)
105 (:search-function . auth-source-netrc-search) 117 (search-function . auth-source-netrc-search)
106 (:create-function . auth-source-netrc-create)))) 118 (create-function
119 . auth-source-netrc-create))))
107 120
108(ert-deftest auth-source-backend-parse-secrets () 121(ert-deftest auth-source-backend-parse-secrets ()
109 (provide 'secrets) ; simulates the presence of the `secrets' package 122 (provide 'secrets) ; simulates the presence of the `secrets' package
110 (let ((secrets-enabled t)) 123 (let ((secrets-enabled t))
111 (auth-source-validate-backend '(:source (:secrets "foo")) 124 (auth-source-validate-backend '(:source (:secrets "foo"))
112 '((:source . "foo") 125 '((source . "foo")
113 (:type . secrets) 126 (type . secrets)
114 (:search-function . auth-source-secrets-search) 127 (search-function
115 (:create-function . auth-source-secrets-create))))) 128 . auth-source-secrets-search)
129 (create-function
130 . auth-source-secrets-create)))))
116 131
117(ert-deftest auth-source-backend-parse-secrets-strings () 132(ert-deftest auth-source-backend-parse-secrets-strings ()
118 (provide 'secrets) ; simulates the presence of the `secrets' package 133 (provide 'secrets) ; simulates the presence of the `secrets' package
119 (let ((secrets-enabled t)) 134 (let ((secrets-enabled t))
120 (auth-source-validate-backend "secrets:foo" 135 (auth-source-validate-backend "secrets:foo"
121 '((:source . "foo") 136 '((source . "foo")
122 (:type . secrets) 137 (type . secrets)
123 (:search-function . auth-source-secrets-search) 138 (search-function
124 (:create-function . auth-source-secrets-create))))) 139 . auth-source-secrets-search)
140 (create-function
141 . auth-source-secrets-create)))))
125 142
126(ert-deftest auth-source-backend-parse-secrets-alias () 143(ert-deftest auth-source-backend-parse-secrets-alias ()
127 (provide 'secrets) ; simulates the presence of the `secrets' package 144 (provide 'secrets) ; simulates the presence of the `secrets' package
@@ -129,10 +146,12 @@
129 ;; Redefine `secrets-get-alias' to map 'foo to "foo" 146 ;; Redefine `secrets-get-alias' to map 'foo to "foo"
130 (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) 147 (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo")))
131 (auth-source-validate-backend '(:source (:secrets foo)) 148 (auth-source-validate-backend '(:source (:secrets foo))
132 '((:source . "foo") 149 '((source . "foo")
133 (:type . secrets) 150 (type . secrets)
134 (:search-function . auth-source-secrets-search) 151 (search-function
135 (:create-function . auth-source-secrets-create)))))) 152 . auth-source-secrets-search)
153 (create-function
154 . auth-source-secrets-create))))))
136 155
137(ert-deftest auth-source-backend-parse-secrets-symbol () 156(ert-deftest auth-source-backend-parse-secrets-symbol ()
138 (provide 'secrets) ; simulates the presence of the `secrets' package 157 (provide 'secrets) ; simulates the presence of the `secrets' package
@@ -140,10 +159,12 @@
140 ;; Redefine `secrets-get-alias' to map 'default to "foo" 159 ;; Redefine `secrets-get-alias' to map 'default to "foo"
141 (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) 160 (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo")))
142 (auth-source-validate-backend 'default 161 (auth-source-validate-backend 'default
143 '((:source . "foo") 162 '((source . "foo")
144 (:type . secrets) 163 (type . secrets)
145 (:search-function . auth-source-secrets-search) 164 (search-function
146 (:create-function . auth-source-secrets-create)))))) 165 . auth-source-secrets-search)
166 (create-function
167 . auth-source-secrets-create))))))
147 168
148(ert-deftest auth-source-backend-parse-secrets-no-alias () 169(ert-deftest auth-source-backend-parse-secrets-no-alias ()
149 (provide 'secrets) ; simulates the presence of the `secrets' package 170 (provide 'secrets) ; simulates the presence of the `secrets' package
@@ -152,10 +173,12 @@
152 ;; "Login" is used by default 173 ;; "Login" is used by default
153 (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil))) 174 (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil)))
154 (auth-source-validate-backend '(:source (:secrets foo)) 175 (auth-source-validate-backend '(:source (:secrets foo))
155 '((:source . "Login") 176 '((source . "Login")
156 (:type . secrets) 177 (type . secrets)
157 (:search-function . auth-source-secrets-search) 178 (search-function
158 (:create-function . auth-source-secrets-create)))))) 179 . auth-source-secrets-search)
180 (create-function
181 . auth-source-secrets-create))))))
159 182
160(ert-deftest auth-source-backend-parse-invalid-or-nil-source () 183(ert-deftest auth-source-backend-parse-invalid-or-nil-source ()
161 (provide 'secrets) ; simulates the presence of the `secrets' package 184 (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."
181 (completion-preview--post-command)) 181 (completion-preview--post-command))
182 (completion-preview-tests--check-preview "barbaz" 'exact))) 182 (completion-preview-tests--check-preview "barbaz" 'exact)))
183 183
184(ert-deftest completion-preview-mid-symbol-cycle ()
185 "Test cycling the completion preview with point at the middle of a symbol."
186 (with-temp-buffer
187 (setq-local completion-at-point-functions
188 (list
189 (completion-preview-tests--capf
190 '("foobar" "foobaz"))))
191 (insert "fooba")
192 (forward-char -2)
193 (let ((this-command 'self-insert-command))
194 (completion-preview--post-command))
195 (completion-preview-tests--check-preview "r")
196 (completion-preview-next-candidate 1)
197 (completion-preview-tests--check-preview "z")))
198
184;;; completion-preview-tests.el ends here 199;;; 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."
848 (should (equal (bytecomp-tests--eval-interpreted form) 848 (should (equal (bytecomp-tests--eval-interpreted form)
849 (bytecomp-tests--eval-compiled form))))))) 849 (bytecomp-tests--eval-compiled form)))))))
850 850
851(ert-deftest bytecomp--fun-value-as-head ()
852 ;; Check that (FUN-VALUE ...) is a valid call, for compatibility (bug#68931).
853 ;; (There is also a warning but this test does not check that.)
854 (dolist (lb '(nil t))
855 (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ")
856 (let* ((lexical-binding lb)
857 (s-int '(lambda (x) (1+ x)))
858 (s-comp (byte-compile s-int))
859 (v-int (lambda (x) (1+ x)))
860 (v-comp (byte-compile v-int))
861 (comp (lambda (f) (funcall (byte-compile `(lambda () (,f 3)))))))
862 (should (equal (funcall comp s-int) 4))
863 (should (equal (funcall comp s-comp) 4))
864 (should (equal (funcall comp v-int) 4))
865 (should (equal (funcall comp v-comp) 4))))))
866
851(defmacro bytecomp-tests--with-fresh-warnings (&rest body) 867(defmacro bytecomp-tests--with-fresh-warnings (&rest body)
852 `(let ((macroexp--warned ; oh dear 868 `(let ((macroexp--warned ; oh dear
853 (make-hash-table :test #'equal :weakness 'key))) 869 (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)."
319 (and (eq 'error (car err)) 319 (and (eq 'error (car err))
320 (string-match "Stray.*declare" (cadr err))))))) 320 (string-match "Stray.*declare" (cadr err)))))))
321 321
322(cl-defmethod cl-generic-tests--print-quoted-method ((function (eql '4)))
323 (+ function 1))
324
325(ert-deftest cl-generic-tests--print-quoted ()
326 (with-temp-buffer
327 (cl--generic-describe 'cl-generic-tests--print-quoted-method)
328 (goto-char (point-min))
329 ;; Bug#54628: We don't want (function (eql '4)) to turn into #'(eql '4)
330 (should-not (re-search-forward "#'" nil t))
331 (goto-char (point-min))
332 ;; But we don't want (eql '4) to turn into (eql (quote 4)) either.
333 (should (re-search-forward "(eql '4)" nil t))))
334
335
322(provide 'cl-generic-tests) 336(provide 'cl-generic-tests)
323;;; cl-generic-tests.el ends here 337;;; 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."
860 (let ((inhibit-read-only t)) 860 (let ((inhibit-read-only t))
861 (delete-region (point-min) (point-max)) 861 (delete-region (point-min) (point-max))
862 (insert "`1")) 862 (insert "`1"))
863 (with-suppressed-warnings ((obsolete edebug-eval-defun)) 863 (eval-defun nil)
864 (edebug-eval-defun nil))
865 ;; `eval-defun' outputs its message to the echo area in a rather 864 ;; `eval-defun' outputs its message to the echo area in a rather
866 ;; funny way, so the "1" and the " (#o1, #x1, ?\C-a)" end up placed 865 ;; funny way, so the "1" and the " (#o1, #x1, ?\C-a)" end up placed
867 ;; there in separate pieces (via `print' rather than via `message'). 866 ;; there in separate pieces (via `print' rather than via `message').
@@ -871,18 +870,21 @@ test and possibly others should be updated."
871 870
872 (setq edebug-initial-mode 'go) 871 (setq edebug-initial-mode 'go)
873 ;; In Bug#23651 Edebug would hang reading `1. 872 ;; In Bug#23651 Edebug would hang reading `1.
874 (with-suppressed-warnings ((obsolete edebug-eval-defun)) 873 (eval-defun t)
875 (edebug-eval-defun t)))) 874 (should (string-match-p (regexp-quote " (#o1, #x1, ?\\C-a)")
875 edebug-tests-messages))))
876 876
877(ert-deftest edebug-tests-trivial-comma () 877(ert-deftest edebug-tests-trivial-comma ()
878 "Edebug can read a trivial comma expression (Bug#23651)." 878 "Edebug can read a trivial comma expression (Bug#23651)."
879 (edebug-tests-with-normal-env 879 (edebug-tests-with-normal-env
880 (read-only-mode -1) 880 (let ((inhibit-read-only t))
881 (delete-region (point-min) (point-max)) 881 (delete-region (point-min) (point-max))
882 (insert ",1") 882 (insert ",1"))
883 (read-only-mode) 883 ;; FIXME: This currently signals a "Source has changed" error, which is
884 (with-suppressed-warnings ((obsolete edebug-eval-defun)) 884 ;; itself a bug (the source hasn't changed). All we're testing here
885 (should-error (edebug-eval-defun t))))) 885 ;; is that the Edebug gets past the step of reading the sexp.
886 (should-error (let ((eval-expression-debug-on-error nil))
887 (eval-defun t)))))
886 888
887(ert-deftest edebug-tests-circular-read-syntax () 889(ert-deftest edebug-tests-circular-read-syntax ()
888 "Edebug can instrument code using circular read object syntax (Bug#23660)." 890 "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."))
1011 (B (clone A :b "bb")) 1011 (B (clone A :b "bb"))
1012 (C (clone B :a "aa"))) 1012 (C (clone B :a "aa")))
1013 1013
1014 (should (string= "aa" (oref C :a))) 1014 (should (string= "aa" (oref C a)))
1015 (should (string= "bb" (oref C :b))) 1015 (should (string= "bb" (oref C b)))
1016 1016
1017 (should (slot-boundp A :a)) 1017 (should (slot-boundp A 'a))
1018 (should-not (slot-boundp A :b)) 1018 (should-not (slot-boundp A 'b))
1019 (should-not (slot-boundp A :c)) 1019 (should-not (slot-boundp A 'c))
1020 1020
1021 (should-not (slot-boundp B :a)) 1021 (should-not (slot-boundp B 'a))
1022 (should (slot-boundp B :b)) 1022 (should (slot-boundp B 'b))
1023 (should-not (slot-boundp A :c)) 1023 (should-not (slot-boundp A 'c))
1024 1024
1025 (should (slot-boundp C :a)) 1025 (should (slot-boundp C 'a))
1026 (should-not (slot-boundp C :b)) 1026 (should-not (slot-boundp C 'b))
1027 (should-not (slot-boundp C :c)) 1027 (should-not (slot-boundp C 'c))
1028 1028
1029 (should (eieio-instance-inheritor-slot-boundp C :a)) 1029 (should (eieio-instance-inheritor-slot-boundp C 'a))
1030 (should (eieio-instance-inheritor-slot-boundp C :b)) 1030 (should (eieio-instance-inheritor-slot-boundp C 'b))
1031 (should-not (eieio-instance-inheritor-slot-boundp C :c)))) 1031 (should-not (eieio-instance-inheritor-slot-boundp C 'c))))
1032 1032
1033;;;; Interaction with defstruct 1033;;;; Interaction with defstruct
1034 1034
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."
570 570
571(defun hierarchy-examples-delayed--childrenfn (hier-elem) 571(defun hierarchy-examples-delayed--childrenfn (hier-elem)
572 "Return the children of HIER-ELEM. 572 "Return the children of HIER-ELEM.
573Basically, feed the number, minus 1, to `hierarchy-examples-delayed--find-number' 573Basically, feed the number, minus 1, to
574and then create a list of the number plus 0.0–0.9." 574`hierarchy-examples-delayed--find-number' and then create a list of the
575number plus 0.0–0.9."
575 576
576 (when (> hier-elem 1) 577 (when (> hier-elem 1)
577 (let ((next (hierarchy-examples-delayed--find-number (1- hier-elem)))) 578 (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 @@
25 (if (macroexp--dynamic-variable-p var) ''dyn ''lex)) 25 (if (macroexp--dynamic-variable-p var) ''dyn ''lex))
26 26
27(defvar vk-a 1) 27(defvar vk-a 1)
28(defconst vk-b 2) 28(defvar vk-b 2)
29(defvar vk-c) 29(defvar vk-c)
30 30
31(defun vk-f1 (x) 31(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 @@
20;;; Commentary: 20;;; Commentary:
21 21
22;;; Code: 22;;; Code:
23(require 'erc-button)
23 24
24(require 'ert-x) ; cl-lib 25(require 'ert-x) ; cl-lib
25(eval-and-compile 26(eval-and-compile
26 (let ((load-path (cons (ert-resource-directory) load-path))) 27 (let ((load-path (cons (ert-resource-directory) load-path)))
27 (require 'erc-tests-common))) 28 (require 'erc-tests-common)))
28 29
29(require 'erc-button)
30
31(ert-deftest erc-button-alist--url () 30(ert-deftest erc-button-alist--url ()
32 (erc-tests-common-init-server-proc "sleep" "1") 31 (erc-tests-common-init-server-proc "sleep" "1")
33 (with-current-buffer (erc--open-target "#chan") 32 (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 @@
23;; scenarios. 23;; scenarios.
24 24
25;;; Code: 25;;; Code:
26(require 'erc-fill)
27
26(require 'ert-x) 28(require 'ert-x)
27(eval-and-compile 29(eval-and-compile
28 (let ((load-path (cons (ert-resource-directory) load-path))) 30 (let ((load-path (cons (ert-resource-directory) load-path)))
29 (require 'erc-tests-common))) 31 (require 'erc-tests-common)))
30 32
31(require 'erc-fill)
32
33(defvar erc-fill-tests--buffers nil) 33(defvar erc-fill-tests--buffers nil)
34(defvar erc-fill-tests--current-time-value nil) 34(defvar erc-fill-tests--current-time-value nil)
35 35
@@ -52,6 +52,7 @@
52 52
53(defun erc-fill-tests--wrap-populate (test) 53(defun erc-fill-tests--wrap-populate (test)
54 (let ((original-window-buffer (window-buffer (selected-window))) 54 (let ((original-window-buffer (window-buffer (selected-window)))
55 (erc--fill-wrap-scrolltobottom-exempt-p t)
55 (erc-stamp--tz t) 56 (erc-stamp--tz t)
56 (erc-fill-function 'erc-fill-wrap) 57 (erc-fill-function 'erc-fill-wrap)
57 (pre-command-hook pre-command-hook) 58 (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 @@
19 19
20;;; Commentary: 20;;; Commentary:
21;;; Code: 21;;; Code:
22(require 'erc-goodies)
23
22(require 'ert-x) 24(require 'ert-x)
23(eval-and-compile 25(eval-and-compile
24 (let ((load-path (cons (ert-resource-directory) load-path))) 26 (let ((load-path (cons (ert-resource-directory) load-path)))
25 (require 'erc-tests-common))) 27 (require 'erc-tests-common)))
26 28
27(require 'erc-goodies)
28
29(defun erc-goodies-tests--assert-face (beg end-str present &optional absent) 29(defun erc-goodies-tests--assert-face (beg end-str present &optional absent)
30 (setq beg (+ beg (point-min))) 30 (setq beg (+ beg (point-min)))
31 (let ((end (+ beg (1- (length end-str))))) 31 (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 @@
18;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 18;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
19 19
20;;; Code: 20;;; Code:
21(require 'erc-compat)
21 22
22(require 'ert-x) ; cl-lib 23(require 'ert-x) ; cl-lib
23(eval-and-compile 24(eval-and-compile
@@ -1761,4 +1762,50 @@
1761 (should (equal (erc-ports-list (nth 4 srv)) 1762 (should (equal (erc-ports-list (nth 4 srv))
1762 '(6697 9999)))))) 1763 '(6697 9999))))))
1763 1764
1765(ert-deftest erc-networks--examine-targets ()
1766 (with-current-buffer (erc-tests-common-make-server-buf "foonet")
1767 (erc--open-target "#chan")
1768 (erc--open-target "#spam"))
1769
1770 (with-current-buffer (erc-tests-common-make-server-buf "barnet")
1771 (with-current-buffer (erc--open-target "*query")
1772 (setq erc-networks--id nil))
1773 (with-current-buffer (erc--open-target "#chan")
1774 (let ((calls ())
1775 (snap (lambda (parameter)
1776 (list parameter
1777 (erc-target)
1778 (erc-networks--id-symbol erc-networks--id)))))
1779
1780 ;; Search for "#chan" dupes among targets of all servers.
1781 (should (equal
1782 (erc-networks--examine-targets erc-networks--id erc--target
1783 (lambda () (push (funcall snap 'ON-DUPE) calls))
1784 (lambda () (push (funcall snap 'ON-COLL) calls)))
1785 (list (get-buffer "#chan@foonet")
1786 (get-buffer "#chan@barnet"))))
1787
1788 (should (equal (pop calls) '(ON-DUPE "#chan" barnet)))
1789 (should (equal (pop calls) '(ON-COLL "#chan" foonet)))
1790 (should-not calls)
1791 (should-not (get-buffer "#chan"))
1792 (should (get-buffer "#chan@barnet"))
1793 (should (get-buffer "#chan@foonet"))
1794
1795 ;; Search for "*query" dupes among targets of all servers.
1796 (should (equal (erc-networks--examine-targets erc-networks--id
1797 (buffer-local-value 'erc--target
1798 (get-buffer "*query"))
1799 (lambda () (push (funcall snap 'ON-DUPE) calls))
1800 (lambda () (push (funcall snap 'ON-COLL) calls)))
1801 (list (get-buffer "*query"))))
1802
1803 (should (equal (pop calls) '(ON-DUPE "*query" barnet)))
1804 (should-not calls)))
1805
1806 (goto-char (point-min))
1807 (should (search-forward "Missing network session" nil t)))
1808
1809 (erc-tests-common-kill-buffers))
1810
1764;;; erc-networks-tests.el ends here 1811;;; 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 @@
281 (should-not (get-buffer "rando@barnet")) 281 (should-not (get-buffer "rando@barnet"))
282 282
283 (with-current-buffer "frenemy@foonet" 283 (with-current-buffer "frenemy@foonet"
284 (funcall expect 1 "now known as") 284 (funcall expect 10 "now known as")
285 (funcall expect 1 "doubly so")) 285 (funcall expect 10 "doubly so"))
286 286
287 (with-current-buffer "frenemy@barnet" 287 (with-current-buffer "frenemy@barnet"
288 (funcall expect 1 "now known as") 288 (funcall expect 10 "now known as")
289 (funcall expect 1 "reality picture")) 289 (funcall expect 10 "reality picture"))
290 290
291 (when noninteractive 291 (when noninteractive
292 (with-current-buffer "frenemy@barnet" (kill-buffer)) 292 (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 @@
42 'znc-foonet 42 'znc-foonet
43 'znc-barnet)) 43 'znc-barnet))
44 44
45;; Here, the upstream connection is already severed when first
46;; connecting. The bouncer therefore sends query messages from an
47;; administrative bot before the first numerics burst, which results
48;; in a target buffer not being associated with an `erc-networks--id'.
49;; The problem only manifests later, when the buffer-association
50;; machinery checks the names of all target buffers and assumes a
51;; non-nil `erc-networks--id'.
52(ert-deftest erc-scenarios-upstream-recon--znc/severed ()
53 (erc-scenarios-common-with-cleanup
54 ((erc-scenarios-common-dialog "base/upstream-reconnect")
55 (erc-d-t-cleanup-sleep-secs 1)
56 (erc-server-flood-penalty 0.1)
57 (dumb-server (erc-d-run "localhost" t 'znc-severed))
58 (port (process-contact dumb-server :service))
59 (expect (erc-d-t-make-expecter)))
60
61 (ert-info ("Connect to foonet")
62 (with-current-buffer (erc :server "127.0.0.1"
63 :port port
64 :nick "tester"
65 :user "tester@vanilla/foonet"
66 :password "changeme"
67 :full-name "tester")
68 (erc-scenarios-common-assert-initial-buf-name nil port)
69 (erc-d-t-wait-for 6 (eq (erc-network) 'foonet))))
70
71 (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "*status"))
72 (funcall expect 10 "Connection Refused. Reconnecting...")
73 (funcall expect 10 "Connected!"))
74
75 (ert-info ("Join #chan")
76 (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
77 (funcall expect 10 "<alice> tester, welcome!")
78 (funcall expect 10 "<bob> alice: And see a fearful sight")
79 (funcall expect 10 "<eve> hola")
80 (funcall expect 10 "<Evel> hell o")
81 ;;
82 (funcall expect 10 "<alice> bob: Or to drown my clothes")))
83
84 (ert-info ("Buffer not renamed with net id")
85 (should (get-buffer "*status")))
86
87 (ert-info ("No error")
88 (with-current-buffer (messages-buffer)
89 (funcall expect -0.1 "error in process filter")))))
90
45;;; erc-scenarios-base-upstream-recon-znc.el ends here 91;;; 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 @@
123 (should (string= (erc-server-user-host (erc-get-server-user "tester")) 123 (should (string= (erc-server-user-host (erc-get-server-user "tester"))
124 "some.host.test.cc")))))) 124 "some.host.test.cc"))))))
125 125
126;; This tests four related slash commands, /AMSG, /GMSG, /AME, /GME,
127;; the latter three introduced by bug#68401. It mainly asserts
128;; correct routing behavior, especially not sending or inserting
129;; messages in buffers belonging to disconnected sessions. Left
130;; unaddressed are interactions with the `command-indicator' module
131;; (`erc-noncommands-list') and whatever future `echo-message'
132;; implementation manifests out of bug#49860.
133(ert-deftest erc-scenarios-misc-commands--AMSG-GMSG-AME-GME ()
134 (erc-scenarios-common-with-cleanup
135 ((erc-scenarios-common-dialog "commands")
136 (erc-server-flood-penalty 0.1)
137 (dumb-server-foonet (erc-d-run "localhost" t "srv-foonet" 'amsg-foonet))
138 (dumb-server-barnet (erc-d-run "localhost" t "srv-barnet" 'amsg-barnet))
139 (expect (erc-d-t-make-expecter)))
140
141 (ert-info ("Connect to foonet and join #foo")
142 (with-current-buffer
143 (erc :server "127.0.0.1"
144 :port (process-contact dumb-server-foonet :service)
145 :nick "tester")
146 (funcall expect 10 "debug mode")
147 (erc-cmd-JOIN "#foo")))
148
149 (ert-info ("Connect to barnet and join #bar")
150 (with-current-buffer
151 (erc :server "127.0.0.1"
152 :port (process-contact dumb-server-barnet :service)
153 :nick "tester")
154 (funcall expect 10 "debug mode")
155 (erc-cmd-JOIN "#bar")))
156
157 (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#foo"))
158 (funcall expect 10 "welcome"))
159 (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#bar"))
160 (funcall expect 10 "welcome"))
161
162 (ert-info ("/AMSG only sent to issuing context's server")
163 (with-current-buffer "foonet"
164 (erc-scenarios-common-say "/amsg 1 foonet only"))
165 (with-current-buffer "barnet"
166 (erc-scenarios-common-say "/amsg 2 barnet only"))
167 (with-current-buffer "#foo"
168 (funcall expect 10 "<tester> 1 foonet only")
169 (funcall expect 10 "<alice> bob: Our queen and all"))
170 (with-current-buffer "#bar"
171 (funcall expect 10 "<tester> 2 barnet only")
172 (funcall expect 10 "<joe> mike: And secretly to greet")))
173
174 (ert-info ("/AME only sent to issuing context's server")
175 (with-current-buffer "foonet"
176 (erc-scenarios-common-say "/ame 3 foonet only"))
177 (with-current-buffer "barnet"
178 (erc-scenarios-common-say "/ame 4 barnet only"))
179 (with-current-buffer "#foo"
180 (funcall expect 10 "* tester 3 foonet only")
181 (funcall expect 10 "<alice> bob: You have discharged this"))
182 (with-current-buffer "#bar"
183 (funcall expect 10 "* tester 4 barnet only")
184 (funcall expect 10 "<joe> mike: That same Berowne")))
185
186 (ert-info ("/GMSG and /GME sent to all servers")
187 (with-current-buffer "foonet"
188 (erc-scenarios-common-say "/gmsg 5 all nets")
189 (erc-scenarios-common-say "/gme 6 all nets"))
190 (with-current-buffer "#bar"
191 (funcall expect 10 "<tester> 5 all nets")
192 (funcall expect 10 "* tester 6 all nets")
193 (funcall expect 10 "<joe> mike: Mehercle! if their sons")))
194
195 (ert-info ("/GMSG and /GME only sent to connected servers")
196 (with-current-buffer "barnet"
197 (erc-cmd-QUIT "")
198 (funcall expect 10 "ERC finished"))
199 (with-current-buffer "#foo"
200 (funcall expect 10 "<tester> 5 all nets")
201 (funcall expect 10 "* tester 6 all nets")
202 (funcall expect 10 "<alice> bob: Stand you!"))
203 (with-current-buffer "foonet"
204 (erc-scenarios-common-say "/gmsg 7 all live nets")
205 (erc-scenarios-common-say "/gme 8 all live nets"))
206 ;; Message *not* inserted in disconnected buffer.
207 (with-current-buffer "#bar"
208 (funcall expect -0.1 "<tester> 7 all live nets")
209 (funcall expect -0.1 "* tester 8 all live nets")))
210
211 (with-current-buffer "#foo"
212 (funcall expect 10 "<tester> 7 all live nets")
213 (funcall expect 10 "* tester 8 all live nets")
214 (funcall expect 10 "<bob> alice: Live, and be prosperous;"))))
215
126;;; erc-scenarios-misc-commands.el ends here 216;;; 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 @@
126 (erc-d-t-wait-for 10 (get-buffer "foonet")) 126 (erc-d-t-wait-for 10 (get-buffer "foonet"))
127 127
128 (ert-info ("Channel buffer #foo playback received") 128 (ert-info ("Channel buffer #foo playback received")
129 (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#foo")) 129 (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#foo"))
130 (funcall expect 10 "Excellent workman"))) 130 (funcall expect 10 "Excellent workman")))
131 131
132 (ert-info ("Global notices routed to server buffer") 132 (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 @@
20;;; Commentary: 20;;; Commentary:
21 21
22;;; Code: 22;;; Code:
23(require 'erc-stamp)
24(require 'erc-goodies) ; for `erc-make-read-only'
25
23(require 'ert-x) 26(require 'ert-x)
24(eval-and-compile 27(eval-and-compile
25 (let ((load-path (cons (ert-resource-directory) load-path))) 28 (let ((load-path (cons (ert-resource-directory) load-path)))
26 (require 'erc-tests-common))) 29 (require 'erc-tests-common)))
27 30
28(require 'erc-stamp)
29(require 'erc-goodies) ; for `erc-make-read-only'
30
31;; These display-oriented tests are brittle because many factors 31;; These display-oriented tests are brittle because many factors
32;; influence how text properties are applied. We should just 32;; influence how text properties are applied. We should just
33;; rework these into full scenarios. 33;; rework these into full scenarios.
@@ -46,7 +46,7 @@
46 46
47 (with-current-buffer (get-buffer-create "*erc-stamp-tests--insert-right*") 47 (with-current-buffer (get-buffer-create "*erc-stamp-tests--insert-right*")
48 (erc-mode) 48 (erc-mode)
49 (erc-munge-invisibility-spec) 49 (erc-stamp--manage-local-options-state)
50 (erc--initialize-markers (point) nil) 50 (erc--initialize-markers (point) nil)
51 (erc-tests-common-init-server-proc "sleep" "1") 51 (erc-tests-common-init-server-proc "sleep" "1")
52 52
@@ -235,7 +235,7 @@
235 (with-current-buffer (get-buffer-create "*erc-timestamp-intangible*") 235 (with-current-buffer (get-buffer-create "*erc-timestamp-intangible*")
236 (erc-mode) 236 (erc-mode)
237 (erc--initialize-markers (point) nil) 237 (erc--initialize-markers (point) nil)
238 (erc-munge-invisibility-spec) 238 (erc-stamp--manage-local-options-state)
239 (erc-display-message nil 'notice (current-buffer) "Welcome") 239 (erc-display-message nil 'notice (current-buffer) "Welcome")
240 ;; 240 ;;
241 ;; Pretend `fill' is active and that these lines are 241 ;; 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 @@
20;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 20;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
21 21
22;;; Code: 22;;; Code:
23(require 'erc-ring)
23 24
24(require 'ert-x) 25(require 'ert-x)
25(eval-and-compile 26(eval-and-compile
26 (let ((load-path (cons (ert-resource-directory) load-path))) 27 (let ((load-path (cons (ert-resource-directory) load-path)))
27 (require 'erc-tests-common))) 28 (require 'erc-tests-common)))
28 29
29(require 'erc-ring)
30 30
31(ert-deftest erc--read-time-period () 31(ert-deftest erc--read-time-period ()
32 (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) 32 (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "")))
@@ -302,6 +302,7 @@
302 (cl-incf counter)))) 302 (cl-incf counter))))
303 erc-accidental-paste-threshold-seconds 303 erc-accidental-paste-threshold-seconds
304 erc-insert-modify-hook 304 erc-insert-modify-hook
305 (erc-last-input-time 0)
305 (erc-modules (remq 'stamp erc-modules)) 306 (erc-modules (remq 'stamp erc-modules))
306 (erc-send-input-line-function #'ignore) 307 (erc-send-input-line-function #'ignore)
307 (erc--input-review-functions erc--input-review-functions) 308 (erc--input-review-functions erc--input-review-functions)
@@ -1053,7 +1054,8 @@
1053 1054
1054(ert-deftest erc--get-isupport-entry () 1055(ert-deftest erc--get-isupport-entry ()
1055 (let ((erc--isupport-params (make-hash-table)) 1056 (let ((erc--isupport-params (make-hash-table))
1056 (erc-server-parameters '(("FOO" . "1") ("BAR") ("BAZ" . "A,B,C"))) 1057 (erc-server-parameters '(("FOO" . "1") ("BAR") ("BAZ" . "A,B,C")
1058 ("SPAM" . "")))
1057 (items (lambda () 1059 (items (lambda ()
1058 (cl-loop for k being the hash-keys of erc--isupport-params 1060 (cl-loop for k being the hash-keys of erc--isupport-params
1059 using (hash-values v) collect (cons k v))))) 1061 using (hash-values v) collect (cons k v)))))
@@ -1074,7 +1076,9 @@
1074 (should (equal (erc--get-isupport-entry 'FOO) '(FOO "1"))) 1076 (should (equal (erc--get-isupport-entry 'FOO) '(FOO "1")))
1075 1077
1076 (should (equal (funcall items) 1078 (should (equal (funcall items)
1077 '((BAR . --empty--) (BAZ "A" "B" "C") (FOO "1")))))) 1079 '((BAR . --empty--) (BAZ "A" "B" "C") (FOO "1"))))
1080 (should (equal (erc--get-isupport-entry 'SPAM) '(SPAM)))
1081 (should-not (erc--get-isupport-entry 'SPAM 'single))))
1078 1082
1079(ert-deftest erc-server-005 () 1083(ert-deftest erc-server-005 ()
1080 (let* ((hooked 0) 1084 (let* ((hooked 0)
@@ -1092,34 +1096,41 @@
1092 (lambda (_ _ _ line) (push line calls)))) 1096 (lambda (_ _ _ line) (push line calls))))
1093 1097
1094 (ert-info ("Baseline") 1098 (ert-info ("Baseline")
1095 (setq args '("tester" "BOT=B" "EXCEPTS" "PREFIX=(ov)@+" "are supp...") 1099 (setq args '("tester" "BOT=B" "CHANTYPES=" "EXCEPTS" "PREFIX=(ov)@+"
1100 "are supp...")
1096 parsed (make-erc-response :command-args args :command "005")) 1101 parsed (make-erc-response :command-args args :command "005"))
1097 1102
1098 (setq verify 1103 (setq verify
1099 (lambda () 1104 (lambda ()
1100 (should (equal erc-server-parameters 1105 (should (equal erc-server-parameters
1101 '(("PREFIX" . "(ov)@+") ("EXCEPTS") 1106 '(("PREFIX" . "(ov)@+") ("EXCEPTS")
1107 ;; Should be ("CHANTYPES") but
1108 ;; retained for compatibility.
1109 ("CHANTYPES" . "")
1102 ("BOT" . "B")))) 1110 ("BOT" . "B"))))
1103 (should (zerop (hash-table-count erc--isupport-params))) 1111 (should (zerop (hash-table-count erc--isupport-params)))
1104 (should (equal "(ov)@+" (erc--get-isupport-entry 'PREFIX t))) 1112 (should (equal "(ov)@+" (erc--get-isupport-entry 'PREFIX t)))
1105 (should (equal '(EXCEPTS) (erc--get-isupport-entry 'EXCEPTS))) 1113 (should (equal '(EXCEPTS) (erc--get-isupport-entry 'EXCEPTS)))
1106 (should (equal "B" (erc--get-isupport-entry 'BOT t))) 1114 (should (equal "B" (erc--get-isupport-entry 'BOT t)))
1107 (should (string= (pop calls) 1115 (should (string=
1108 "BOT=B EXCEPTS PREFIX=(ov)@+ are supp...")) 1116 (pop calls)
1117 "BOT=B CHANTYPES= EXCEPTS PREFIX=(ov)@+ are supp..."))
1109 (should (equal args (erc-response.command-args parsed))))) 1118 (should (equal args (erc-response.command-args parsed)))))
1110 1119
1111 (erc-call-hooks nil parsed)) 1120 (erc-call-hooks nil parsed))
1112 1121
1113 (ert-info ("Negated, updated") 1122 (ert-info ("Negated, updated")
1114 (setq args '("tester" "-EXCEPTS" "-FAKE" "PREFIX=(ohv)@%+" "are su...") 1123 (setq args '("tester" "-EXCEPTS" "-CHANTYPES" "-FAKE" "PREFIX=(ohv)@%+"
1124 "are su...")
1115 parsed (make-erc-response :command-args args :command "005")) 1125 parsed (make-erc-response :command-args args :command "005"))
1116 1126
1117 (setq verify 1127 (setq verify
1118 (lambda () 1128 (lambda ()
1119 (should (equal erc-server-parameters 1129 (should (equal erc-server-parameters
1120 '(("PREFIX" . "(ohv)@%+") ("BOT" . "B")))) 1130 '(("PREFIX" . "(ohv)@%+") ("BOT" . "B"))))
1121 (should (string= (pop calls) 1131 (should (string-prefix-p
1122 "-EXCEPTS -FAKE PREFIX=(ohv)@%+ are su...")) 1132 "-EXCEPTS -CHANTYPES -FAKE PREFIX=(ohv)@%+ "
1133 (pop calls)))
1123 (should (equal "(ohv)@%+" (erc--get-isupport-entry 'PREFIX t))) 1134 (should (equal "(ohv)@%+" (erc--get-isupport-entry 'PREFIX t)))
1124 (should (equal "B" (erc--get-isupport-entry 'BOT t))) 1135 (should (equal "B" (erc--get-isupport-entry 'BOT t)))
1125 (should-not (erc--get-isupport-entry 'EXCEPTS)) 1136 (should-not (erc--get-isupport-entry 'EXCEPTS))
@@ -1156,25 +1167,37 @@
1156 (should (equal (erc-downcase "\\O/") "|o/" ))))) 1167 (should (equal (erc-downcase "\\O/") "|o/" )))))
1157 1168
1158(ert-deftest erc-channel-p () 1169(ert-deftest erc-channel-p ()
1159 (let ((erc--isupport-params (make-hash-table)) 1170 (erc-tests-common-make-server-buf)
1160 erc-server-parameters)
1161
1162 (should (erc-channel-p "#chan"))
1163 (should (erc-channel-p "##chan"))
1164 (should (erc-channel-p "&chan"))
1165 (should (erc-channel-p "+chan"))
1166 (should (erc-channel-p "!chan"))
1167 (should-not (erc-channel-p "@chan"))
1168
1169 (push '("CHANTYPES" . "#&@+!") erc-server-parameters)
1170 1171
1171 (should (erc-channel-p "!chan")) 1172 (should (erc-channel-p "#chan"))
1172 (should (erc-channel-p "#chan")) 1173 (should (erc-channel-p "##chan"))
1174 (should (erc-channel-p "&chan"))
1175 (should-not (erc-channel-p "+chan"))
1176 (should-not (erc-channel-p "!chan"))
1177 (should-not (erc-channel-p "@chan"))
1178
1179 ;; Server sends "CHANTYPES=#&+!"
1180 (should-not erc-server-parameters)
1181 (setq erc-server-parameters '(("CHANTYPES" . "#&+!")))
1182 (should (erc-channel-p "#chan"))
1183 (should (erc-channel-p "&chan"))
1184 (should (erc-channel-p "+chan"))
1185 (should (erc-channel-p "!chan"))
1186
1187 (with-current-buffer (erc--open-target "#chan")
1188 (should (erc-channel-p (current-buffer))))
1189 (with-current-buffer (erc--open-target "+chan")
1190 (should (erc-channel-p (current-buffer))))
1191 (should (erc-channel-p (get-buffer "#chan")))
1192 (should (erc-channel-p (get-buffer "+chan")))
1193
1194 ;; Server sends "CHANTYPES=" because it's query only.
1195 (puthash 'CHANTYPES '("CHANTYPES") erc--isupport-params)
1196 (should-not (erc-channel-p "#spam"))
1197 (should-not (erc-channel-p "&spam"))
1198 (should-not (erc-channel-p (save-excursion (erc--open-target "#spam"))))
1173 1199
1174 (with-current-buffer (get-buffer-create "#chan") 1200 (erc-tests-common-kill-buffers))
1175 (setq erc--target (erc--target-from-string "#chan")))
1176 (should (erc-channel-p (get-buffer "#chan"))))
1177 (kill-buffer "#chan"))
1178 1201
1179(ert-deftest erc--valid-local-channel-p () 1202(ert-deftest erc--valid-local-channel-p ()
1180 (ert-info ("Local channels not supported") 1203 (ert-info ("Local channels not supported")
@@ -1189,12 +1212,16 @@
1189 (should (erc--valid-local-channel-p "&local"))))) 1212 (should (erc--valid-local-channel-p "&local")))))
1190 1213
1191(ert-deftest erc--restore-initialize-priors () 1214(ert-deftest erc--restore-initialize-priors ()
1215 (unless (>= emacs-major-version 28)
1216 (ert-skip "Lisp nesting exceeds `max-lisp-eval-depth'"))
1192 (should (pcase (macroexpand-1 '(erc--restore-initialize-priors erc-my-mode 1217 (should (pcase (macroexpand-1 '(erc--restore-initialize-priors erc-my-mode
1193 foo (ignore 1 2 3) 1218 foo (ignore 1 2 3)
1194 bar #'spam 1219 bar #'spam
1195 baz nil)) 1220 baz nil))
1196 (`(let* ((,p (or erc--server-reconnecting erc--target-priors)) 1221 (`(let* ((,p (or erc--server-reconnecting erc--target-priors))
1197 (,q (and ,p (alist-get 'erc-my-mode ,p)))) 1222 (,q (and ,p (alist-get 'erc-my-mode ,p))))
1223 (unless (local-variable-if-set-p 'erc-my-mode)
1224 (error "Not a local minor mode var: %s" 'erc-my-mode))
1198 (setq foo (if ,q (alist-get 'foo ,p) (ignore 1 2 3)) 1225 (setq foo (if ,q (alist-get 'foo ,p) (ignore 1 2 3))
1199 bar (if ,q (alist-get 'bar ,p) #'spam) 1226 bar (if ,q (alist-get 'bar ,p) #'spam)
1200 baz (if ,q (alist-get 'baz ,p) nil))) 1227 baz (if ,q (alist-get 'baz ,p) nil)))
@@ -1273,7 +1300,7 @@
1273 (setq erc-server-current-nick "tester") 1300 (setq erc-server-current-nick "tester")
1274 (setq-local erc-last-input-time 0) 1301 (setq-local erc-last-input-time 0)
1275 (should-not (local-variable-if-set-p 'erc-send-completed-hook)) 1302 (should-not (local-variable-if-set-p 'erc-send-completed-hook))
1276 (set (make-local-variable 'erc-send-completed-hook) nil) ; skip t (globals) 1303 (setq-local erc-send-completed-hook nil) ; skip t (globals)
1277 ;; Just in case erc-ring-mode is already on 1304 ;; Just in case erc-ring-mode is already on
1278 (setq-local erc--input-review-functions erc--input-review-functions) 1305 (setq-local erc--input-review-functions erc--input-review-functions)
1279 (add-hook 'erc--input-review-functions #'erc-add-to-input-ring) 1306 (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 @@
1;; -*- mode: lisp-data; -*-
2((pass 10 "PASS :changeme"))
3((nick 10 "NICK tester"))
4((user 10 "USER tester@vanilla/foonet 0 * :tester")
5 (0.00 ":irc.znc.in 001 tester :Welcome to ZNC")
6 (0.03 ":*status!znc@znc.in PRIVMSG tester :Connection Refused. Reconnecting...")
7 (0.01 ":*status!znc@znc.in PRIVMSG tester :Connection Refused. Reconnecting...")
8 (0.00 ":*status!znc@znc.in PRIVMSG tester :Connection Refused. Reconnecting...")
9 (0.01 ":*status!znc@znc.in PRIVMSG tester :Connected!")
10 (0.02 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
11 (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
12 (0.01 ":irc.foonet.org 003 tester :This server was created Wed, 31 Jan 2024 10:58:16 UTC")
13 (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
14 (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")
15 (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")
16 (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
17 (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
18 (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
19 (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
20 (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
21 (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
22 (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
23 (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
24 (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")
25 (0.00 ":irc.foonet.org 221 tester +Zi")
26 (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."))
27
28((mode 10 "MODE tester +i")
29 (0.01 ":irc.foonet.org 352 tester * ~u pfa3tpa5ig5ty.irc irc.foonet.org tester H :0 ZNC - https://znc.in")
30 (0.01 ":irc.foonet.org 315 tester tester :End of WHO list")
31
32 (0.02 ":tester!~u@pfa3tpa5ig5ty.irc JOIN #chan")
33 (0.03 ":irc.foonet.org 353 tester = #chan :bob tester @alice eve"))
34
35((mode 10 "MODE #chan")
36 (0.00 ":irc.foonet.org 366 tester #chan :End of NAMES list")
37 (0.00 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
38 (0.01 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
39 (0.01 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: And see how he will take it at your hands.")
40 (0.02 ":irc.foonet.org 221 tester +Zi")
41 (0.01 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Fear not, my lord, your servant shall do so.")
42 (0.02 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: If I thrive well, I'll visit thee again.")
43 (0.01 ":irc.foonet.org 324 tester #chan +Cnt")
44 (0.03 ":irc.foonet.org 329 tester #chan 1706698713")
45 (0.05 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Let it be forbid, sir; so should I be a great deal of his act.")
46 (0.04 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: And see a fearful sight of blood and death.")
47 (0.00 ":eve!~u@euegh6mj3y8r2.irc PRIVMSG #chan :hola")
48 (0.01 ":eve!~u@euegh6mj3y8r2.irc NICK :Evel")
49 (0.01 ":Evel!~u@euegh6mj3y8r2.irc PRIVMSG #chan :hell o")
50 (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.")
51 (0.03 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: See, by good hap, yonder's my lord; I have sweat to see his honour.")
52 (0.02 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: With the rich worth of your virginity.")
53
54 (0.02 ":*status!znc@znc.in PRIVMSG tester :Disconnected from IRC. Reconnecting...")
55 (0.05 ":*status!znc@znc.in PRIVMSG tester :Connection Refused. Reconnecting...")
56 (0.03 ":*status!znc@znc.in PRIVMSG tester :Connected!")
57 (0.01 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
58 (0.04 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
59 (0.01 ":irc.foonet.org 003 tester :This server was created Wed, 31 Jan 2024 10:58:16 UTC")
60 (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
61 (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")
62 (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")
63 (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
64 (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
65 (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
66 (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
67 (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
68 (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
69 (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
70 (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
71 (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")
72 (0.02 ":irc.foonet.org 221 tester +i")
73 (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.")
74 (0.02 ":irc.foonet.org 352 tester * ~u hrn2ea3rpeyck.irc irc.foonet.org tester H :0 ZNC - https://znc.in")
75 (0.01 ":irc.foonet.org 315 tester tester :End of WHO list")
76 (0.02 ":tester!~u@hrn2ea3rpeyck.irc JOIN #chan"))
77
78((mode 10 "MODE #chan")
79 (0.00 ":irc.foonet.org 353 tester = #chan :tester @alice bob")
80 (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list")
81 (0.00 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
82 (0.01 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
83 (0.02 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Nay, I assure you, a peace concluded.")
84 (0.03 ":irc.foonet.org 324 tester #chan +Cnt")
85 (0.01 ":irc.foonet.org 329 tester #chan 1706698713")
86 (0.05 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: But, in defence, by mercy, 'tis most just.")
87 (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 @@
1;; -*- mode: lisp-data; -*-
2((nick 10 "NICK tester"))
3((user 10 "USER user 0 * :unknown")
4 (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester")
5 (0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16")
6 (0 ":irc.barnet.org 003 tester :This server was created Tue, 04 May 2021 05:06:19 UTC")
7 (0 ":irc.barnet.org 004 tester irc.barnet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
8 (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")
9 (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")
10 (0 ":irc.barnet.org 005 tester draft/CHATHISTORY=100 :are supported by this server")
11 (0 ":irc.barnet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
12 (0 ":irc.barnet.org 252 tester 0 :IRC Operators online")
13 (0 ":irc.barnet.org 253 tester 0 :unregistered connections")
14 (0 ":irc.barnet.org 254 tester 1 :channels formed")
15 (0 ":irc.barnet.org 255 tester :I have 3 clients and 0 servers")
16 (0 ":irc.barnet.org 265 tester 3 3 :Current local users 3, max 3")
17 (0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3")
18 (0 ":irc.barnet.org 422 tester :MOTD File is missing"))
19
20((mode-user 10 "MODE tester +i")
21 (0 ":irc.barnet.org 221 tester +i")
22 (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."))
23
24((join 10 "JOIN #bar")
25 (0 ":tester!~u@jnu48g2wrycbw.irc JOIN #bar")
26 (0 ":irc.barnet.org 353 tester = #bar :@mike joe tester")
27 (0 ":irc.barnet.org 366 tester #bar :End of NAMES list"))
28
29((mode-bar 10 "MODE #bar")
30 (0 ":irc.barnet.org 324 tester #bar +nt")
31 (0 ":irc.barnet.org 329 tester #bar 1620104779")
32 (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :tester, welcome!")
33 (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :tester, welcome!")
34 (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: Whipp'd first, sir, and hang'd after.")
35 (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."))
36
37((privmsg-2 10 "PRIVMSG #bar :2 barnet only")
38 (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.")
39 (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: And secretly to greet the empress' friends."))
40
41((privmsg-4 10 "PRIVMSG #bar :\1ACTION 4 barnet only\1")
42 (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: You have not been inquired after: I have sat here all day.")
43 (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: That same Berowne I'll torture ere I go."))
44
45((privmsg-5 10 "PRIVMSG #bar :5 all nets"))
46
47((privmsg-6 10 "PRIVMSG #bar :\1ACTION 6 all nets\1")
48 (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.")
49 (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."))
50
51((quit 5 "QUIT :\2ERC\2")
52 (0 ":tester!~u@jnu48g2wrycbw.irc QUIT :Quit"))
53
54((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 @@
1;; -*- mode: lisp-data; -*-
2((nick 10 "NICK tester"))
3((user 10 "USER user 0 * :unknown")
4 (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
5 (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
6 (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC")
7 (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
8 (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")
9 (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")
10 (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server")
11 (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
12 (0 ":irc.foonet.org 252 tester 0 :IRC Operators online")
13 (0 ":irc.foonet.org 253 tester 0 :unregistered connections")
14 (0 ":irc.foonet.org 254 tester 1 :channels formed")
15 (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
16 (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
17 (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
18 (0 ":irc.foonet.org 422 tester :MOTD File is missing"))
19
20((mode-user 10 "MODE tester +i")
21 (0 ":irc.foonet.org 221 tester +i")
22 (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."))
23
24((join 10 "JOIN #foo")
25 (0 ":tester!~u@9g6b728983yd2.irc JOIN #foo")
26 (0 ":irc.foonet.org 353 tester = #foo :alice tester @bob")
27 (0 ":irc.foonet.org 366 tester #foo :End of NAMES list"))
28
29((mode-foo 10 "MODE #foo")
30 (0 ":irc.foonet.org 324 tester #foo +nt")
31 (0 ":irc.foonet.org 329 tester #foo 1620104779")
32 (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :tester, welcome!")
33 (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :tester, welcome!")
34 (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: But, as it seems, did violence on herself.")
35 (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: Well, this is the forest of Arden."))
36
37((privmsg-1 10 "PRIVMSG #foo :1 foonet only")
38 (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Signior Iachimo will not from it. Pray, let us follow 'em.")
39 (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: Our queen and all her elves come here anon."))
40
41((privmsg-3 10 "PRIVMSG #foo :\1ACTION 3 foonet only\1")
42 (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: The ground is bloody; search about the churchyard.")
43 (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."))
44
45((privmsg-5 10 "PRIVMSG #foo :5 all nets"))
46
47((privmsg-6 10 "PRIVMSG #foo :\1ACTION 6 all nets\1")
48 (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Give me that mattock, and the wrenching iron.")
49 (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."))
50
51((privmsg-6 10 "PRIVMSG #foo :7 all live nets")
52 (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Excellent workman! Thou canst not paint a man so bad as is thyself."))
53
54((privmsg-6 10 "PRIVMSG #foo :\1ACTION 8 all live nets\1")
55 (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.")
56 (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 @@
94(require 'erc) 94(require 'erc)
95 95
96(eval-when-compile (require 'erc-join) 96(eval-when-compile (require 'erc-join)
97 (require 'erc-services)) 97 (require 'erc-services)
98 (require 'erc-fill))
98 99
99(declare-function erc-network "erc-networks") 100(declare-function erc-network "erc-networks")
100(defvar erc-network) 101(defvar erc-network)
@@ -148,9 +149,11 @@
148 (timer-list (copy-sequence timer-list)) 149 (timer-list (copy-sequence timer-list))
149 (timer-idle-list (copy-sequence timer-idle-list)) 150 (timer-idle-list (copy-sequence timer-idle-list))
150 (erc-auth-source-parameters-join-function nil) 151 (erc-auth-source-parameters-join-function nil)
152 (erc--fill-wrap-scrolltobottom-exempt-p t)
151 (erc-autojoin-channels-alist nil) 153 (erc-autojoin-channels-alist nil)
152 (erc-server-auto-reconnect nil) 154 (erc-server-auto-reconnect nil)
153 (erc-after-connect nil) 155 (erc-after-connect nil)
156 (erc-last-input-time 0)
154 (erc-d-linger-secs 10) 157 (erc-d-linger-secs 10)
155 ,@bindings))) 158 ,@bindings)))
156 159
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."
122 erc--isupport-params (make-hash-table) 122 erc--isupport-params (make-hash-table)
123 erc-session-port 6667 123 erc-session-port 6667
124 erc-network (intern name) 124 erc-network (intern name)
125 erc-networks--id (erc-networks--id-create nil)) 125 erc-networks--id (erc-networks--id-create name))
126 (current-buffer))) 126 (current-buffer)))
127 127
128(defun erc-tests-common-string-to-propertized-parts (string) 128(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 @@
29 (eshell--process-args 29 (eshell--process-args
30 "sudo" '("-a") 30 "sudo" '("-a")
31 '((?a "all" nil show-all 31 '((?a "all" nil show-all
32 "do not ignore entries starting with ."))))) 32 "do not ignore entries starting with ."))
33 '(show-all))))
33 (should 34 (should
34 (equal '("root" "world") 35 (equal '("root" "world")
35 (eshell--process-args 36 (eshell--process-args
36 "sudo" '("-u" "root" "world") 37 "sudo" '("-u" "root" "world")
37 '((?u "user" t user 38 '((?u "user" t user
38 "execute a command as another USER")))))) 39 "execute a command as another USER"))
40 '(user)))))
39 41
40(ert-deftest esh-opt-test/process-args-parse-leading-options-only () 42(ert-deftest esh-opt-test/process-args-parse-leading-options-only ()
41 "Test behavior of :parse-leading-options-only in `eshell--process-args'." 43 "Test behavior of :parse-leading-options-only in `eshell--process-args'."
@@ -45,20 +47,23 @@
45 "sudo" '("emerge" "-uDN" "world") 47 "sudo" '("emerge" "-uDN" "world")
46 '((?u "user" t user 48 '((?u "user" t user
47 "execute a command as another USER") 49 "execute a command as another USER")
48 :parse-leading-options-only)))) 50 :parse-leading-options-only)
51 '(user))))
49 (should 52 (should
50 (equal '("root" "emerge" "-uDN" "world") 53 (equal '("root" "emerge" "-uDN" "world")
51 (eshell--process-args 54 (eshell--process-args
52 "sudo" '("-u" "root" "emerge" "-uDN" "world") 55 "sudo" '("-u" "root" "emerge" "-uDN" "world")
53 '((?u "user" t user 56 '((?u "user" t user
54 "execute a command as another USER") 57 "execute a command as another USER")
55 :parse-leading-options-only)))) 58 :parse-leading-options-only)
59 '(user))))
56 (should 60 (should
57 (equal '("DN" "emerge" "world") 61 (equal '("DN" "emerge" "world")
58 (eshell--process-args 62 (eshell--process-args
59 "sudo" '("-u" "root" "emerge" "-uDN" "world") 63 "sudo" '("-u" "root" "emerge" "-uDN" "world")
60 '((?u "user" t user 64 '((?u "user" t user
61 "execute a command as another USER")))))) 65 "execute a command as another USER"))
66 '(user)))))
62 67
63(ert-deftest esh-opt-test/process-args-external () 68(ert-deftest esh-opt-test/process-args-external ()
64 "Test behavior of :external in `eshell--process-args'." 69 "Test behavior of :external in `eshell--process-args'."
@@ -69,7 +74,8 @@
69 "ls" '("/some/path") 74 "ls" '("/some/path")
70 '((?a "all" nil show-all 75 '((?a "all" nil show-all
71 "do not ignore entries starting with .") 76 "do not ignore entries starting with .")
72 :external "ls"))))) 77 :external "ls")
78 '(show-all)))))
73 (cl-letf (((symbol-function 'eshell-search-path) #'identity)) 79 (cl-letf (((symbol-function 'eshell-search-path) #'identity))
74 (should 80 (should
75 (equal '(no-catch eshell-ext-command "ls") 81 (equal '(no-catch eshell-ext-command "ls")
@@ -78,7 +84,8 @@
78 "ls" '("-u" "/some/path") 84 "ls" '("-u" "/some/path")
79 '((?a "all" nil show-all 85 '((?a "all" nil show-all
80 "do not ignore entries starting with .") 86 "do not ignore entries starting with .")
81 :external "ls")) 87 :external "ls")
88 '(show-all))
82 :type 'no-catch)))) 89 :type 'no-catch))))
83 (cl-letf (((symbol-function 'eshell-search-path) #'ignore)) 90 (cl-letf (((symbol-function 'eshell-search-path) #'ignore))
84 (should-error 91 (should-error
@@ -86,7 +93,8 @@
86 "ls" '("-u" "/some/path") 93 "ls" '("-u" "/some/path")
87 '((?a "all" nil show-all 94 '((?a "all" nil show-all
88 "do not ignore entries starting with .") 95 "do not ignore entries starting with .")
89 :external "ls")) 96 :external "ls")
97 '(show-all))
90 :type 'error))) 98 :type 'error)))
91 99
92(ert-deftest esh-opt-test/eval-using-options-short () 100(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."
153 "Test flushing of previous output" 153 "Test flushing of previous output"
154 (with-temp-eshell 154 (with-temp-eshell
155 (eshell-insert-command "echo alpha") 155 (eshell-insert-command "echo alpha")
156 (eshell-kill-output) 156 (eshell-delete-output)
157 (should (eshell-match-output 157 (should (eshell-match-output
158 (concat "^" (regexp-quote "*** output flushed ***\n") "$"))))) 158 (concat "^" (regexp-quote "*** output flushed ***\n") "$")))))
159 159
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 @@
74(defvar file-notify--test-events nil) 74(defvar file-notify--test-events nil)
75(defvar file-notify--test-monitors nil) 75(defvar file-notify--test-monitors nil)
76 76
77(defun file-notify--test-read-event () 77(defun file-notify--test-wait-event ()
78 "Read one event. 78 "Wait for one event.
79There are different timeouts for local and remote file notification libraries." 79There are different timeouts for local and remote file notification libraries."
80 (read-event 80 (read-event
81 nil nil 81 nil nil
@@ -87,7 +87,8 @@ There are different timeouts for local and remote file notification libraries."
87 ;; for any monitor. 87 ;; for any monitor.
88 ((file-notify--test-monitor) 7) 88 ((file-notify--test-monitor) 7)
89 ((file-remote-p temporary-file-directory) 0.1) 89 ((file-remote-p temporary-file-directory) 0.1)
90 (t 0.01)))) 90 (t 0.01)))
91 nil)
91 92
92(defun file-notify--test-timeout () 93(defun file-notify--test-timeout ()
93 "Timeout to wait for arriving a bunch of events, in seconds." 94 "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."
103TIMEOUT is the maximum time to wait for, in seconds." 104TIMEOUT is the maximum time to wait for, in seconds."
104 `(with-timeout (,timeout (ignore)) 105 `(with-timeout (,timeout (ignore))
105 (while (null ,until) 106 (while (null ,until)
106 (file-notify--test-read-event)))) 107 (file-notify--test-wait-event))))
107 108
108(defun file-notify--test-no-descriptors () 109(defun file-notify--test-no-descriptors ()
109 "Check that `file-notify-descriptors' is an empty hash table. 110 "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'."
452 ;; Check, that removing watch descriptors out of order do not 453 ;; Check, that removing watch descriptors out of order do not
453 ;; harm. This fails on cygwin because of timing issues unless a 454 ;; harm. This fails on cygwin because of timing issues unless a
454 ;; long `sit-for' is added before the call to 455 ;; long `sit-for' is added before the call to
455 ;; `file-notify--test-read-event'. 456 ;; `file-notify--test-wait-event'.
456 (unless (eq system-type 'cygwin) 457 (unless (eq system-type 'cygwin)
457 (let (results) 458 (let (results)
458 (cl-flet ((first-callback (event) 459 (cl-flet ((first-callback (event)
@@ -480,7 +481,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
480 ;; Remove first watch. 481 ;; Remove first watch.
481 (file-notify-rm-watch file-notify--test-desc) 482 (file-notify-rm-watch file-notify--test-desc)
482 ;; Only the second callback shall run. 483 ;; Only the second callback shall run.
483 (file-notify--test-read-event) 484 (file-notify--test-wait-event)
484 (delete-file file-notify--test-tmpfile) 485 (delete-file file-notify--test-tmpfile)
485 (file-notify--test-wait-for-events 486 (file-notify--test-wait-for-events
486 (file-notify--test-timeout) results) 487 (file-notify--test-timeout) results)
@@ -622,7 +623,7 @@ delivered."
622 (cons 'file-notify while-no-input-ignore-events)) 623 (cons 'file-notify while-no-input-ignore-events))
623 create-lockfiles) 624 create-lockfiles)
624 ;; Flush pending actions. 625 ;; Flush pending actions.
625 (file-notify--test-read-event) 626 (file-notify--test-wait-event)
626 (file-notify--test-wait-for-events 627 (file-notify--test-wait-for-events
627 (file-notify--test-timeout) 628 (file-notify--test-timeout)
628 (not (input-pending-p))) 629 (not (input-pending-p)))
@@ -671,7 +672,7 @@ delivered."
671 (t '(created changed deleted stopped))) 672 (t '(created changed deleted stopped)))
672 (write-region 673 (write-region
673 "another text" nil file-notify--test-tmpfile nil 'no-message) 674 "another text" nil file-notify--test-tmpfile nil 'no-message)
674 (file-notify--test-read-event) 675 (file-notify--test-wait-event)
675 (delete-file file-notify--test-tmpfile)) 676 (delete-file file-notify--test-tmpfile))
676 (file-notify-rm-watch file-notify--test-desc) 677 (file-notify-rm-watch file-notify--test-desc)
677 678
@@ -707,7 +708,7 @@ delivered."
707 (changed changed deleted stopped)))) 708 (changed changed deleted stopped))))
708 (write-region 709 (write-region
709 "another text" nil file-notify--test-tmpfile nil 'no-message) 710 "another text" nil file-notify--test-tmpfile nil 'no-message)
710 (file-notify--test-read-event) 711 (file-notify--test-wait-event)
711 (delete-file file-notify--test-tmpfile)) 712 (delete-file file-notify--test-tmpfile))
712 (file-notify-rm-watch file-notify--test-desc) 713 (file-notify-rm-watch file-notify--test-desc)
713 714
@@ -755,7 +756,7 @@ delivered."
755 (t '(created changed deleted deleted stopped))) 756 (t '(created changed deleted deleted stopped)))
756 (write-region 757 (write-region
757 "any text" nil file-notify--test-tmpfile nil 'no-message) 758 "any text" nil file-notify--test-tmpfile nil 'no-message)
758 (file-notify--test-read-event) 759 (file-notify--test-wait-event)
759 (delete-directory file-notify--test-tmpdir 'recursive)) 760 (delete-directory file-notify--test-tmpdir 'recursive))
760 (file-notify-rm-watch file-notify--test-desc) 761 (file-notify-rm-watch file-notify--test-desc)
761 762
@@ -805,14 +806,14 @@ delivered."
805 deleted deleted deleted stopped))) 806 deleted deleted deleted stopped)))
806 (write-region 807 (write-region
807 "any text" nil file-notify--test-tmpfile nil 'no-message) 808 "any text" nil file-notify--test-tmpfile nil 'no-message)
808 (file-notify--test-read-event) 809 (file-notify--test-wait-event)
809 (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) 810 (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1)
810 ;; The next two events shall not be visible. 811 ;; The next two events shall not be visible.
811 (file-notify--test-read-event) 812 (file-notify--test-wait-event)
812 (set-file-modes file-notify--test-tmpfile 000 'nofollow) 813 (set-file-modes file-notify--test-tmpfile 000 'nofollow)
813 (file-notify--test-read-event) 814 (file-notify--test-wait-event)
814 (set-file-times file-notify--test-tmpfile '(0 0) 'nofollow) 815 (set-file-times file-notify--test-tmpfile '(0 0) 'nofollow)
815 (file-notify--test-read-event) 816 (file-notify--test-wait-event)
816 (delete-directory file-notify--test-tmpdir 'recursive)) 817 (delete-directory file-notify--test-tmpdir 'recursive))
817 (file-notify-rm-watch file-notify--test-desc) 818 (file-notify-rm-watch file-notify--test-desc)
818 819
@@ -860,10 +861,10 @@ delivered."
860 (t '(created changed renamed deleted deleted stopped))) 861 (t '(created changed renamed deleted deleted stopped)))
861 (write-region 862 (write-region
862 "any text" nil file-notify--test-tmpfile nil 'no-message) 863 "any text" nil file-notify--test-tmpfile nil 'no-message)
863 (file-notify--test-read-event) 864 (file-notify--test-wait-event)
864 (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) 865 (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1)
865 ;; After the rename, we won't get events anymore. 866 ;; After the rename, we won't get events anymore.
866 (file-notify--test-read-event) 867 (file-notify--test-wait-event)
867 (delete-directory file-notify--test-tmpdir 'recursive)) 868 (delete-directory file-notify--test-tmpdir 'recursive))
868 (file-notify-rm-watch file-notify--test-desc) 869 (file-notify-rm-watch file-notify--test-desc)
869 870
@@ -912,11 +913,11 @@ delivered."
912 (t '(attribute-changed attribute-changed))) 913 (t '(attribute-changed attribute-changed)))
913 (write-region 914 (write-region
914 "any text" nil file-notify--test-tmpfile nil 'no-message) 915 "any text" nil file-notify--test-tmpfile nil 'no-message)
915 (file-notify--test-read-event) 916 (file-notify--test-wait-event)
916 (set-file-modes file-notify--test-tmpfile 000 'nofollow) 917 (set-file-modes file-notify--test-tmpfile 000 'nofollow)
917 (file-notify--test-read-event) 918 (file-notify--test-wait-event)
918 (set-file-times file-notify--test-tmpfile '(0 0) 'nofollow) 919 (set-file-times file-notify--test-tmpfile '(0 0) 'nofollow)
919 (file-notify--test-read-event) 920 (file-notify--test-wait-event)
920 (delete-file file-notify--test-tmpfile)) 921 (delete-file file-notify--test-tmpfile))
921 (file-notify-rm-watch file-notify--test-desc) 922 (file-notify-rm-watch file-notify--test-desc)
922 923
@@ -1087,7 +1088,7 @@ delivered."
1087 (changed changed deleted stopped)))) 1088 (changed changed deleted stopped))))
1088 (write-region 1089 (write-region
1089 "another text" nil file-notify--test-tmpfile nil 'no-message) 1090 "another text" nil file-notify--test-tmpfile nil 'no-message)
1090 (file-notify--test-read-event) 1091 (file-notify--test-wait-event)
1091 (delete-file file-notify--test-tmpfile)) 1092 (delete-file file-notify--test-tmpfile))
1092 ;; After deleting the file, the descriptor is not valid anymore. 1093 ;; After deleting the file, the descriptor is not valid anymore.
1093 (should-not (file-notify-valid-p file-notify--test-desc)) 1094 (should-not (file-notify-valid-p file-notify--test-desc))
@@ -1134,7 +1135,7 @@ delivered."
1134 (t '(created changed deleted deleted stopped))) 1135 (t '(created changed deleted deleted stopped)))
1135 (write-region 1136 (write-region
1136 "any text" nil file-notify--test-tmpfile nil 'no-message) 1137 "any text" nil file-notify--test-tmpfile nil 'no-message)
1137 (file-notify--test-read-event) 1138 (file-notify--test-wait-event)
1138 (delete-directory file-notify--test-tmpdir 'recursive)) 1139 (delete-directory file-notify--test-tmpdir 'recursive))
1139 ;; After deleting the parent directory, the descriptor must 1140 ;; After deleting the parent directory, the descriptor must
1140 ;; not be valid anymore. 1141 ;; not be valid anymore.
@@ -1247,9 +1248,9 @@ delivered."
1247 (let ((source-file-list source-file-list) 1248 (let ((source-file-list source-file-list)
1248 (target-file-list target-file-list)) 1249 (target-file-list target-file-list))
1249 (while (and source-file-list target-file-list) 1250 (while (and source-file-list target-file-list)
1250 (file-notify--test-read-event) 1251 (file-notify--test-wait-event)
1251 (write-region "" nil (pop source-file-list) nil 'no-message) 1252 (write-region "" nil (pop source-file-list) nil 'no-message)
1252 (file-notify--test-read-event) 1253 (file-notify--test-wait-event)
1253 (write-region "" nil (pop target-file-list) nil 'no-message)))) 1254 (write-region "" nil (pop target-file-list) nil 'no-message))))
1254 (file-notify--test-with-actions 1255 (file-notify--test-with-actions
1255 (cond 1256 (cond
@@ -1272,11 +1273,11 @@ delivered."
1272 (let ((source-file-list source-file-list) 1273 (let ((source-file-list source-file-list)
1273 (target-file-list target-file-list)) 1274 (target-file-list target-file-list))
1274 (while (and source-file-list target-file-list) 1275 (while (and source-file-list target-file-list)
1275 (file-notify--test-read-event) 1276 (file-notify--test-wait-event)
1276 (rename-file (pop source-file-list) (pop target-file-list) t)))) 1277 (rename-file (pop source-file-list) (pop target-file-list) t))))
1277 (file-notify--test-with-actions (make-list n 'deleted) 1278 (file-notify--test-with-actions (make-list n 'deleted)
1278 (dolist (file target-file-list) 1279 (dolist (file target-file-list)
1279 (file-notify--test-read-event) 1280 (file-notify--test-wait-event)
1280 (delete-file file))) 1281 (delete-file file)))
1281 (delete-directory file-notify--test-tmpfile) 1282 (delete-directory file-notify--test-tmpfile)
1282 (if (or (string-equal (file-notify--test-library) "w32notify") 1283 (if (or (string-equal (file-notify--test-library) "w32notify")
@@ -1464,7 +1465,7 @@ the file watch."
1464 ;; does not report the `changed' event. 1465 ;; does not report the `changed' event.
1465 (make-list (/ n 2) 'created))) 1466 (make-list (/ n 2) 'created)))
1466 (dotimes (i n) 1467 (dotimes (i n)
1467 (file-notify--test-read-event) 1468 (file-notify--test-wait-event)
1468 (if (zerop (mod i 2)) 1469 (if (zerop (mod i 2))
1469 (write-region 1470 (write-region
1470 "any text" nil file-notify--test-tmpfile1 t 'no-message) 1471 "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!
1656 (should (equal (file-name-base "foo") "foo")) 1656 (should (equal (file-name-base "foo") "foo"))
1657 (should (equal (file-name-base "foo/bar") "bar"))) 1657 (should (equal (file-name-base "foo/bar") "bar")))
1658 1658
1659(defun files-tests--check-shebang (shebang expected-mode) 1659(defvar sh-shell)
1660 "Assert that mode for SHEBANG derives from EXPECTED-MODE." 1660
1661 (let ((actual-mode 1661(defun files-tests--check-shebang (shebang expected-mode &optional expected-dialect)
1662 (ert-with-temp-file script-file 1662 "Assert that mode for SHEBANG derives from EXPECTED-MODE.
1663 :text shebang 1663
1664 (find-file script-file) 1664If EXPECTED-MODE is sh-base-mode, DIALECT says what `sh-shell' should be
1665 (if (derived-mode-p expected-mode) 1665set to."
1666 expected-mode 1666 (ert-with-temp-file script-file
1667 major-mode)))) 1667 :text shebang
1668 ;; Tuck all the information we need in the `should' form: input 1668 (find-file script-file)
1669 ;; shebang, expected mode vs actual. 1669 (let ((actual-mode (if (derived-mode-p expected-mode)
1670 (should 1670 expected-mode
1671 (equal (list shebang actual-mode) 1671 major-mode)))
1672 (list shebang expected-mode))))) 1672 ;; Tuck all the information we need in the `should' form: input
1673 ;; shebang, expected mode vs actual.
1674 (should
1675 (equal (list shebang actual-mode)
1676 (list shebang expected-mode)))
1677 (when (eq expected-mode 'sh-base-mode)
1678 (should (eq sh-shell expected-dialect))))))
1673 1679
1674(ert-deftest files-tests-auto-mode-interpreter () 1680(ert-deftest files-tests-auto-mode-interpreter ()
1675 "Test that `set-auto-mode' deduces correct modes from shebangs." 1681 "Test that `set-auto-mode' deduces correct modes from shebangs."
1676 (files-tests--check-shebang "#!/bin/bash" 'sh-mode) 1682 ;; Straightforward interpreter invocation.
1677 (files-tests--check-shebang "#!/usr/bin/env bash" 'sh-mode) 1683 (files-tests--check-shebang "#!/bin/bash" 'sh-base-mode 'bash)
1684 (files-tests--check-shebang "#!/usr/bin/make -f" 'makefile-mode)
1685 ;; Invocation through env.
1686 (files-tests--check-shebang "#!/usr/bin/env bash" 'sh-base-mode 'bash)
1678 (files-tests--check-shebang "#!/usr/bin/env python" 'python-base-mode) 1687 (files-tests--check-shebang "#!/usr/bin/env python" 'python-base-mode)
1679 (files-tests--check-shebang "#!/usr/bin/env python3" 'python-base-mode) 1688 (files-tests--check-shebang "#!/usr/bin/env python3" 'python-base-mode)
1689 ;; Invocation through env, with supplementary arguments.
1690 (files-tests--check-shebang "#!/usr/bin/env --split-string=bash -eux" 'sh-base-mode 'bash)
1691 (files-tests--check-shebang "#!/usr/bin/env --split-string=-iv --default-signal bash -eux" 'sh-base-mode 'bash)
1680 (files-tests--check-shebang "#!/usr/bin/env -S awk -v FS=\"\\t\" -v OFS=\"\\t\" -f" 'awk-mode) 1692 (files-tests--check-shebang "#!/usr/bin/env -S awk -v FS=\"\\t\" -v OFS=\"\\t\" -f" 'awk-mode)
1681 (files-tests--check-shebang "#!/usr/bin/env -S make -f" 'makefile-mode) 1693 (files-tests--check-shebang "#!/usr/bin/env -S make -f" 'makefile-mode)
1682 (files-tests--check-shebang "#!/usr/bin/make -f" 'makefile-mode)) 1694 (files-tests--check-shebang "#!/usr/bin/env -S-vi bash -eux" 'sh-base-mode 'bash)
1695 (files-tests--check-shebang "#!/usr/bin/env -ivS --default-signal=INT bash -eux" 'sh-base-mode 'bash)
1696 (files-tests--check-shebang "#!/usr/bin/env -ivS --default-signal bash -eux" 'sh-base-mode 'bash)
1697 (files-tests--check-shebang "#!/usr/bin/env -vS -uFOOBAR bash -eux" 'sh-base-mode 'bash)
1698 ;; Invocation through env, with modified environment.
1699 (files-tests--check-shebang "#!/usr/bin/env -S PYTHONPATH=/...:${PYTHONPATH} python" 'python-base-mode))
1683 1700
1684(ert-deftest files-test-dir-locals-auto-mode-alist () 1701(ert-deftest files-test-dir-locals-auto-mode-alist ()
1685 "Test an `auto-mode-alist' entry in `.dir-locals.el'" 1702 "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 @@
28(require 'ert-x) 28(require 'ert-x)
29 29
30(ert-deftest test-info-urls () 30(ert-deftest test-info-urls ()
31 (should (equal (Info-url-for-node "(tramp)Top")
32 "https://www.gnu.org/software/emacs/manual/html_node/tramp/"))
31 (should (equal (Info-url-for-node "(emacs)Minibuffer") 33 (should (equal (Info-url-for-node "(emacs)Minibuffer")
32 "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer")) 34 "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer.html"))
33 (should (equal (Info-url-for-node "(emacs)Minibuffer File") 35 (should (equal (Info-url-for-node "(emacs)Minibuffer File")
34 "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer-File")) 36 "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer-File.html"))
35 (should (equal (Info-url-for-node "(elisp)Backups and Auto-Saving") 37 (should (equal (Info-url-for-node "(elisp)Backups and Auto-Saving")
36 "https://www.gnu.org/software/emacs/manual/html_node/elisp/Backups-and-Auto_002dSaving")) 38 "https://www.gnu.org/software/emacs/manual/html_node/elisp/Backups-and-Auto_002dSaving.html"))
37 (should (equal (Info-url-for-node "(eintr)car & cdr") 39 (should (equal (Info-url-for-node "(eintr)car & cdr")
38 "https://www.gnu.org/software/emacs/manual/html_node/eintr/car-_0026-cdr")) 40 "https://www.gnu.org/software/emacs/manual/html_node/eintr/car-_0026-cdr.html"))
39 (should (equal (Info-url-for-node "(emacs-mime)\tIndex") 41 (should (equal (Info-url-for-node "(emacs-mime)\tIndex")
40 "https://www.gnu.org/software/emacs/manual/html_node/emacs-mime/Index")) 42 "https://www.gnu.org/software/emacs/manual/html_node/emacs-mime/Index.html"))
41 (should (equal (Info-url-for-node "(gnus) Don't Panic") 43 (should (equal (Info-url-for-node "(gnus) Don't Panic")
42 "https://www.gnu.org/software/emacs/manual/html_node/gnus/Don_0027t-Panic")) 44 "https://www.gnu.org/software/emacs/manual/html_node/gnus/Don_0027t-Panic.html"))
43 (should-error (Info-url-for-node "(nonexistent)Example"))) 45 (should-error (Info-url-for-node "(nonexistent)Example")))
44 46
45;;; info-tests.el ends here 47;;; 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 @@
96 96
97;;; Testing `sgml-html-meta-auto-coding-function'. 97;;; Testing `sgml-html-meta-auto-coding-function'.
98 98
99(defconst sgml-html-meta-pre "<!doctype html><html><head>" 99(defvar sgml-html-meta-pre "<!doctype html><html><head>"
100 "The beginning of a minimal HTML document.") 100 "The beginning of a minimal HTML document.")
101 101
102(defconst sgml-html-meta-post "</head></html>" 102(defvar sgml-html-meta-post "</head></html>"
103 "The end of a minimal HTML document.") 103 "The end of a minimal HTML document.")
104 104
105(defun sgml-html-meta-run (coding-system) 105(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 @@
201 'completions-first-difference) 201 'completions-first-difference)
202 return pos)) 202 return pos))
203 203
204(ert-deftest completion-test--pcm-bug38458 ()
205 (should (equal (let ((completion-ignore-case t))
206 (completion-pcm--merge-try '("tes" point "ing")
207 '("Testing" "testing")
208 "" ""))
209 '("testing" . 4))))
210
204(ert-deftest completion-pcm-test-1 () 211(ert-deftest completion-pcm-test-1 ()
205 ;; Point is at end, this does not match anything 212 ;; Point is at end, this does not match anything
206 (should (null 213 (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
77`ert-resource-directory'." 77`ert-resource-directory'."
78 `(expand-file-name ,file (ert-resource-directory))))) 78 `(expand-file-name ,file (ert-resource-directory)))))
79 79
80(defconst tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz") 80(defvar tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz")
81 "The test file archive.") 81 "The test file archive.")
82 82
83(defun tramp-archive-test-file-archive-hexlified () 83(defun tramp-archive-test-file-archive-hexlified ()
@@ -86,7 +86,7 @@ Do not hexlify \"/\". This hexlified string is used in `file:///' URLs."
86 (let* ((url-unreserved-chars (cons ?/ url-unreserved-chars))) 86 (let* ((url-unreserved-chars (cons ?/ url-unreserved-chars)))
87 (url-hexify-string tramp-archive-test-file-archive))) 87 (url-hexify-string tramp-archive-test-file-archive)))
88 88
89(defconst tramp-archive-test-archive 89(defvar tramp-archive-test-archive
90 (file-name-as-directory tramp-archive-test-file-archive) 90 (file-name-as-directory tramp-archive-test-file-archive)
91 "The test archive.") 91 "The test archive.")
92 92
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.
265 `(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) 265 `(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0)))
266 (debug-ignored-errors 266 (debug-ignored-errors
267 (append 267 (append
268 '("^make-symbolic-link not supported$" 268 '("\\`make-symbolic-link not supported\\'"
269 "^error with add-name-to-file") 269 "\\`error with add-name-to-file")
270 debug-ignored-errors)) 270 debug-ignored-errors))
271 inhibit-message) 271 inhibit-message)
272 (unwind-protect 272 (unwind-protect
@@ -379,7 +379,7 @@ is greater than 10.
379 (let (tramp-mode) 379 (let (tramp-mode)
380 (should-not (tramp-tramp-file-p "/method:user@host:"))) 380 (should-not (tramp-tramp-file-p "/method:user@host:")))
381 ;; `tramp-ignored-file-name-regexp' suppresses Tramp. 381 ;; `tramp-ignored-file-name-regexp' suppresses Tramp.
382 (let ((tramp-ignored-file-name-regexp "^/method:user@host:")) 382 (let ((tramp-ignored-file-name-regexp "\\`/method:user@host:"))
383 (should-not (tramp-tramp-file-p "/method:user@host:"))) 383 (should-not (tramp-tramp-file-p "/method:user@host:")))
384 ;; Methods shall be at least two characters, except the 384 ;; Methods shall be at least two characters, except the
385 ;; default method. 385 ;; default method.
@@ -3493,6 +3493,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
3493 (skip-unless (not (tramp--test-rsync-p))) 3493 (skip-unless (not (tramp--test-rsync-p)))
3494 ;; Wildcards are not supported in tramp-crypt.el. 3494 ;; Wildcards are not supported in tramp-crypt.el.
3495 (skip-unless (not (tramp--test-crypt-p))) 3495 (skip-unless (not (tramp--test-crypt-p)))
3496 ;; Wildcards are not supported with "docker cp ..." or "podman cp ...".
3497 (skip-unless (not (tramp--test-container-oob-p)))
3496 3498
3497 (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) 3499 (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
3498 (let* ((tmp-name1 3500 (let* ((tmp-name1
@@ -3815,15 +3817,24 @@ This tests also `access-file', `file-readable-p',
3815 (ignore-errors (delete-file tmp-name1)) 3817 (ignore-errors (delete-file tmp-name1))
3816 (ignore-errors (delete-file tmp-name2)))))) 3818 (ignore-errors (delete-file tmp-name2))))))
3817 3819
3820(defun tramp--test-set-ert-test-documentation (test command)
3821 "Set the documentation string for a derived test.
3822The test is derived from TEST and COMMAND."
3823 (let ((test-doc
3824 (split-string (ert-test-documentation (get test 'ert--test)) "\n")))
3825 ;; The first line must be extended.
3826 (setcar
3827 test-doc (format "%s Use the \"%s\" command." (car test-doc) command))
3828 (setf (ert-test-documentation
3829 (get (intern (format "%s-with-%s" test command)) 'ert--test))
3830 (string-join test-doc "\n"))))
3831
3818(defmacro tramp--test-deftest-with-stat (test) 3832(defmacro tramp--test-deftest-with-stat (test)
3819 "Define ert `TEST-with-stat'." 3833 "Define ert `TEST-with-stat'."
3820 (declare (indent 1)) 3834 (declare (indent 1))
3821 `(ert-deftest ,(intern (concat (symbol-name test) "-with-stat")) () 3835 `(ert-deftest ,(intern (concat (symbol-name test) "-with-stat")) ()
3822 ;; This is the docstring. However, it must be expanded to a
3823 ;; string inside the macro. No idea.
3824 ;; (concat (ert-test-documentation (get ',test 'ert--test))
3825 ;; "\nUse the \"stat\" command.")
3826 :tags '(:expensive-test) 3836 :tags '(:expensive-test)
3837 (tramp--test-set-ert-test-documentation ',test "stat")
3827 (skip-unless (tramp--test-enabled)) 3838 (skip-unless (tramp--test-enabled))
3828 (skip-unless (tramp--test-sh-p)) 3839 (skip-unless (tramp--test-sh-p))
3829 (skip-unless (tramp-get-remote-stat tramp-test-vec)) 3840 (skip-unless (tramp-get-remote-stat tramp-test-vec))
@@ -3842,11 +3853,8 @@ This tests also `access-file', `file-readable-p',
3842 "Define ert `TEST-with-perl'." 3853 "Define ert `TEST-with-perl'."
3843 (declare (indent 1)) 3854 (declare (indent 1))
3844 `(ert-deftest ,(intern (concat (symbol-name test) "-with-perl")) () 3855 `(ert-deftest ,(intern (concat (symbol-name test) "-with-perl")) ()
3845 ;; This is the docstring. However, it must be expanded to a
3846 ;; string inside the macro. No idea.
3847 ;; (concat (ert-test-documentation (get ',test 'ert--test))
3848 ;; "\nUse the \"perl\" command.")
3849 :tags '(:expensive-test) 3856 :tags '(:expensive-test)
3857 (tramp--test-set-ert-test-documentation ',test "perl")
3850 (skip-unless (tramp--test-enabled)) 3858 (skip-unless (tramp--test-enabled))
3851 (skip-unless (tramp--test-sh-p)) 3859 (skip-unless (tramp--test-sh-p))
3852 (skip-unless (tramp-get-remote-perl tramp-test-vec)) 3860 (skip-unless (tramp-get-remote-perl tramp-test-vec))
@@ -3870,11 +3878,8 @@ This tests also `access-file', `file-readable-p',
3870 "Define ert `TEST-with-ls'." 3878 "Define ert `TEST-with-ls'."
3871 (declare (indent 1)) 3879 (declare (indent 1))
3872 `(ert-deftest ,(intern (concat (symbol-name test) "-with-ls")) () 3880 `(ert-deftest ,(intern (concat (symbol-name test) "-with-ls")) ()
3873 ;; This is the docstring. However, it must be expanded to a
3874 ;; string inside the macro. No idea.
3875 ;; (concat (ert-test-documentation (get ',test 'ert--test))
3876 ;; "\nUse the \"ls\" command.")
3877 :tags '(:expensive-test) 3881 :tags '(:expensive-test)
3882 (tramp--test-set-ert-test-documentation ',test "ls")
3878 (skip-unless (tramp--test-enabled)) 3883 (skip-unless (tramp--test-enabled))
3879 (skip-unless (tramp--test-sh-p)) 3884 (skip-unless (tramp--test-sh-p))
3880 (if-let ((default-directory ert-remote-temporary-file-directory) 3885 (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'."
5155 (should-not (get-buffer-window (current-buffer) t)) 5160 (should-not (get-buffer-window (current-buffer) t))
5156 (delete-file tmp-name))) 5161 (delete-file tmp-name)))
5157 5162
5158 ;; Check remote and local DESTNATION file. This isn't 5163 ;; Check remote and local DESTINATION file. This isn't
5159 ;; implemented yet ina all file name handler backends. 5164 ;; implemented yet in all file name handler backends.
5160 ;; (dolist (local '(nil t)) 5165 ;; (dolist (local '(nil t))
5161 ;; (setq tmp-name (tramp--test-make-temp-name local quoted)) 5166 ;; (setq tmp-name (tramp--test-make-temp-name local quoted))
5162 ;; (should 5167 ;; (should
@@ -6376,33 +6381,35 @@ INPUT, if non-nil, is a string sent to the process."
6376 (setq tramp-remote-path orig-tramp-remote-path) 6381 (setq tramp-remote-path orig-tramp-remote-path)
6377 6382
6378 ;; We make a super long `tramp-remote-path'. 6383 ;; We make a super long `tramp-remote-path'.
6379 (make-directory tmp-name) 6384 (unless (tramp--test-container-oob-p)
6380 (should (file-directory-p tmp-name)) 6385 (make-directory tmp-name)
6381 (while (tramp-compat-length< (string-join orig-exec-path ":") 5000) 6386 (should (file-directory-p tmp-name))
6382 (let ((dir (make-temp-file (file-name-as-directory tmp-name) 'dir))) 6387 (while (tramp-compat-length< (string-join orig-exec-path ":") 5000)
6383 (should (file-directory-p dir)) 6388 (let ((dir (make-temp-file
6384 (setq tramp-remote-path 6389 (file-name-as-directory tmp-name) 'dir)))
6385 (append 6390 (should (file-directory-p dir))
6386 tramp-remote-path `(,(file-remote-p dir 'localname))) 6391 (setq tramp-remote-path
6387 orig-exec-path 6392 (append
6388 (append 6393 tramp-remote-path `(,(file-remote-p dir 'localname)))
6389 (butlast orig-exec-path) 6394 orig-exec-path
6390 `(,(file-remote-p dir 'localname)) 6395 (append
6391 (last orig-exec-path))))) 6396 (butlast orig-exec-path)
6392 (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) 6397 `(,(file-remote-p dir 'localname))
6393 (should (equal (exec-path) orig-exec-path)) 6398 (last orig-exec-path)))))
6394 ;; Ignore trailing newline. 6399 (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
6395 (setq path (substring (shell-command-to-string "echo $PATH") nil -1)) 6400 (should (equal (exec-path) orig-exec-path))
6396 ;; The shell doesn't handle such long strings. 6401 ;; Ignore trailing newline.
6397 (unless (tramp-compat-length> 6402 (setq path (substring (shell-command-to-string "echo $PATH") nil -1))
6398 path 6403 ;; The shell doesn't handle such long strings.
6399 (tramp-get-connection-property 6404 (unless (tramp-compat-length>
6400 tramp-test-vec "pipe-buf" 4096)) 6405 path
6401 ;; The last element of `exec-path' is `exec-directory'. 6406 (tramp-get-connection-property
6402 (should 6407 tramp-test-vec "pipe-buf" 4096))
6403 (string-equal path (string-join (butlast orig-exec-path) ":")))) 6408 ;; The last element of `exec-path' is `exec-directory'.
6404 ;; The shell "sh" shall always exist. 6409 (should
6405 (should (executable-find "sh" 'remote))) 6410 (string-equal path (string-join (butlast orig-exec-path) ":"))))
6411 ;; The shell "sh" shall always exist.
6412 (should (executable-find "sh" 'remote))))
6406 6413
6407 ;; Cleanup. 6414 ;; Cleanup.
6408 (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) 6415 (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
7053 (not (and (tramp--test-adb-p) 7060 (not (and (tramp--test-adb-p)
7054 (string-match-p (rx multibyte) default-directory))))) 7061 (string-match-p (rx multibyte) default-directory)))))
7055 7062
7056(defun tramp--test-crypt-p ()
7057 "Check, whether the remote directory is encrypted."
7058 (tramp-crypt-file-name-p ert-remote-temporary-file-directory))
7059
7060(defun tramp--test-container-p () 7063(defun tramp--test-container-p ()
7061 "Check, whether a container method is used. 7064 "Check, whether a container method is used.
7062This does not support some special file names." 7065This does not support some special file names."
7063 (string-match-p 7066 (string-match-p
7064 (rx bol (| "docker" "podman") eol) 7067 (rx bol (| "docker" "podman"))
7065 (file-remote-p ert-remote-temporary-file-directory 'method))) 7068 (file-remote-p ert-remote-temporary-file-directory 'method)))
7066 7069
7070(defun tramp--test-container-oob-p ()
7071 "Check, whether the dockercp or podmancp method is used.
7072They does not support wildcard copy."
7073 (string-match-p
7074 (rx bol (| "dockercp" "podmancp") eol)
7075 (file-remote-p ert-remote-temporary-file-directory 'method)))
7076
7077(defun tramp--test-crypt-p ()
7078 "Check, whether the remote directory is encrypted."
7079 (tramp-crypt-file-name-p ert-remote-temporary-file-directory))
7080
7067(defun tramp--test-expensive-test-p () 7081(defun tramp--test-expensive-test-p ()
7068 "Whether expensive tests are run. 7082 "Whether expensive tests are run.
7069This is used in tests which we don't want to tag `:expensive' 7083This is used in tests which we don't want to tag `:expensive'
@@ -7480,7 +7494,8 @@ This requires restrictions of file name syntax."
7480 (tramp--test-gvfs-p) 7494 (tramp--test-gvfs-p)
7481 (tramp--test-windows-nt-or-smb-p)) 7495 (tramp--test-windows-nt-or-smb-p))
7482 "?foo?bar?baz?") 7496 "?foo?bar?baz?")
7483 (unless (or (tramp--test-ftp-p) 7497 (unless (or (tramp--test-container-oob-p)
7498 (tramp--test-ftp-p)
7484 (tramp--test-gvfs-p) 7499 (tramp--test-gvfs-p)
7485 (tramp--test-windows-nt-or-smb-p)) 7500 (tramp--test-windows-nt-or-smb-p))
7486 "*foo+bar*baz+") 7501 "*foo+bar*baz+")
@@ -7500,7 +7515,10 @@ This requires restrictions of file name syntax."
7500 (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) 7515 (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
7501 "<foo>bar<baz>") 7516 "<foo>bar<baz>")
7502 "(foo)bar(baz)" 7517 "(foo)bar(baz)"
7503 (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]") 7518 (unless (or (tramp--test-container-oob-p)
7519 (tramp--test-ftp-p)
7520 (tramp--test-gvfs-p))
7521 "[foo]bar[baz]")
7504 "{foo}bar{baz}"))) 7522 "{foo}bar{baz}")))
7505 ;; Simplify test in order to speed up. 7523 ;; Simplify test in order to speed up.
7506 (apply #'tramp--test-check-files 7524 (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 @@
32 (should-not (obarrayp "aoeu")) 32 (should-not (obarrayp "aoeu"))
33 (should-not (obarrayp '())) 33 (should-not (obarrayp '()))
34 (should-not (obarrayp [])) 34 (should-not (obarrayp []))
35 (should (obarrayp (make-vector 7 0))))
36
37(ert-deftest obarrayp-unchecked-content-test ()
38 "Should fail to check content of passed obarray."
39 :expected-result :failed
40 (should-not (obarrayp ["a" "b" "c"])) 35 (should-not (obarrayp ["a" "b" "c"]))
41 (should-not (obarrayp [1 2 3]))) 36 (should-not (obarrayp [1 2 3]))
42 37 (should-not (obarrayp (make-vector 7 0)))
43(ert-deftest obarray-make-default-test () 38 (should-not (obarrayp (vector (obarray-make))))
44 (let ((table (obarray-make))) 39 (should (obarrayp (obarray-make)))
45 (should (obarrayp table)) 40 (should (obarrayp (obarray-make 7))))
46 (should (eq (obarray-size table) obarray-default-size))))
47 41
48(ert-deftest obarray-make-with-size-test () 42(ert-deftest obarray-make-with-size-test ()
49 ;; FIXME: Actually, `wrong-type-argument' is not the right error to signal, 43 ;; FIXME: Actually, `wrong-type-argument' is not the right error to signal,
50 ;; so we shouldn't enforce this misbehavior in tests! 44 ;; so we shouldn't enforce this misbehavior in tests!
51 (should-error (obarray-make -1) :type 'wrong-type-argument) 45 (should-error (obarray-make -1) :type 'wrong-type-argument)
52 (should-error (obarray-make 0) :type 'wrong-type-argument) 46 (should-error (obarray-make 'a) :type 'wrong-type-argument))
53 (let ((table (obarray-make 1)))
54 (should (obarrayp table))
55 (should (eq (obarray-size table) 1))))
56 47
57(ert-deftest obarray-get-test () 48(ert-deftest obarray-get-test ()
58 (let ((table (obarray-make 3))) 49 (let ((table (obarray-make 3)))
@@ -88,5 +79,15 @@
88 (obarray-map collect-names table) 79 (obarray-map collect-names table)
89 (should (equal (sort syms #'string<) '("a" "b" "c"))))) 80 (should (equal (sort syms #'string<) '("a" "b" "c")))))
90 81
82(ert-deftest obarray-clear ()
83 (let ((o (obarray-make)))
84 (intern "a" o)
85 (intern "b" o)
86 (intern "c" o)
87 (obarray-clear o)
88 (let ((n 0))
89 (mapatoms (lambda (_) (setq n (1+ n))) o)
90 (should (equal n 0)))))
91
91(provide 'obarray-tests) 92(provide 'obarray-tests)
92;;; obarray-tests.el ends here 93;;; 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 {
110 } 110 }
111} 111}
112=-=-= 112=-=-=
113
114Name: Opening bracket on separate line (bug#67556)
115
116=-=
117public class Java {
118 void foo(
119 String foo)
120 {
121 for (var f : rs)
122 return new String[]
123 {
124 "foo",
125 "bar"
126 };
127 if (a == 0)
128 {
129 return 0;
130 } else if (a == 1)
131 {
132 return 1;
133 }
134
135 switch(expr)
136 {
137 case x:
138 // code block
139 break;
140 }
141 }
142}
143=-=-=
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
55always located at the beginning of buffer. Native completion is 55always located at the beginning of buffer. Native completion is
56turned off. Shell buffer will be killed on exit." 56turned off. Shell buffer will be killed on exit."
57 (declare (indent 1) (debug t)) 57 (declare (indent 1) (debug t))
58 `(with-temp-buffer 58 (let ((dir (make-symbol "dir")))
59 (let ((python-indent-guess-indent-offset nil) 59 `(with-temp-buffer
60 (python-shell-completion-native-enable nil)) 60 (let ((python-indent-guess-indent-offset nil)
61 (python-mode) 61 (python-shell-completion-native-enable nil))
62 (unwind-protect 62 (python-mode)
63 (progn 63 (unwind-protect
64 (run-python nil t) 64 ;; Prevent test failures when Jedi is used as a completion
65 (insert ,contents) 65 ;; backend, either directly or indirectly (e.g., via
66 (goto-char (point-min)) 66 ;; IPython). Jedi needs to store cache, but the
67 (python-tests-shell-wait-for-prompt) 67 ;; "/nonexistent" HOME directory is not writable.
68 ,@body) 68 (ert-with-temp-directory ,dir
69 (when (python-shell-get-buffer) 69 (with-environment-variables (("XDG_CACHE_HOME" ,dir))
70 (python-shell-with-shell-buffer 70 (run-python nil t)
71 (let (kill-buffer-hook kill-buffer-query-functions) 71 (insert ,contents)
72 (kill-buffer)))))))) 72 (goto-char (point-min))
73 (python-tests-shell-wait-for-prompt)
74 ,@body))
75 (when (python-shell-get-buffer)
76 (python-shell-with-shell-buffer
77 (let (kill-buffer-hook kill-buffer-query-functions)
78 (kill-buffer)))))))))
73 79
74(defmacro python-tests-with-temp-file (contents &rest body) 80(defmacro python-tests-with-temp-file (contents &rest body)
75 "Create a `python-mode' enabled file with CONTENTS. 81 "Create a `python-mode' enabled file with CONTENTS.
@@ -4799,6 +4805,111 @@ def foo():
4799 (end-of-line 0) 4805 (end-of-line 0)
4800 (should-not (nth 2 (python-shell-completion-at-point)))))) 4806 (should-not (nth 2 (python-shell-completion-at-point))))))
4801 4807
4808(defun python-tests--completion-module ()
4809 "Check if modules can be completed in Python shell."
4810 (insert "import datet")
4811 (completion-at-point)
4812 (beginning-of-line)
4813 (should (looking-at-p "import datetime"))
4814 (kill-line)
4815 (insert "from datet")
4816 (completion-at-point)
4817 (beginning-of-line)
4818 (should (looking-at-p "from datetime"))
4819 (end-of-line)
4820 (insert " import timed")
4821 (completion-at-point)
4822 (beginning-of-line)
4823 (should (looking-at-p "from datetime import timedelta"))
4824 (kill-line))
4825
4826(defun python-tests--completion-parameters ()
4827 "Check if parameters can be completed in Python shell."
4828 (insert "import re")
4829 (comint-send-input)
4830 (python-tests-shell-wait-for-prompt)
4831 (insert "re.split('b', 'abc', maxs")
4832 (completion-at-point)
4833 (should (string= "re.split('b', 'abc', maxsplit="
4834 (buffer-substring (line-beginning-position) (point))))
4835 (insert "0, ")
4836 (should (python-shell-completion-at-point))
4837 ;; Test if cache is used.
4838 (cl-letf (((symbol-function 'python-shell-completion-get-completions)
4839 'ignore)
4840 ((symbol-function 'python-shell-completion-native-get-completions)
4841 'ignore))
4842 (insert "fla")
4843 (completion-at-point)
4844 (should (string= "re.split('b', 'abc', maxsplit=0, flags="
4845 (buffer-substring (line-beginning-position) (point)))))
4846 (beginning-of-line)
4847 (kill-line))
4848
4849(defun python-tests--completion-extra-context ()
4850 "Check if extra context is used for completion."
4851 (insert "re.split('b', 'abc',")
4852 (comint-send-input)
4853 (python-tests-shell-wait-for-prompt)
4854 (insert "maxs")
4855 (completion-at-point)
4856 (should (string= "maxsplit="
4857 (buffer-substring (line-beginning-position) (point))))
4858 (insert "0)")
4859 (comint-send-input)
4860 (python-tests-shell-wait-for-prompt)
4861 (insert "from re import (")
4862 (comint-send-input)
4863 (python-tests-shell-wait-for-prompt)
4864 (insert "IGN")
4865 (completion-at-point)
4866 (should (string= "IGNORECASE"
4867 (buffer-substring (line-beginning-position) (point)))))
4868
4869(defun python-tests--pythonstartup-file ()
4870 "Return Jedi readline setup file if PYTHONSTARTUP is not set."
4871 (or (getenv "PYTHONSTARTUP")
4872 (with-temp-buffer
4873 (if (eql 0 (call-process python-tests-shell-interpreter
4874 nil t nil "-m" "jedi" "repl"))
4875 (string-trim (buffer-string))
4876 ""))))
4877
4878(ert-deftest python-shell-completion-at-point-jedi-completer ()
4879 "Check if Python shell completion works when Jedi completer is used."
4880 (skip-unless (executable-find python-tests-shell-interpreter))
4881 (with-environment-variables
4882 (("PYTHONSTARTUP" (python-tests--pythonstartup-file)))
4883 (python-tests-with-temp-buffer-with-shell
4884 ""
4885 (python-shell-with-shell-buffer
4886 (python-shell-completion-native-turn-on)
4887 (skip-unless (string= python-shell-readline-completer-delims ""))
4888 (python-tests--completion-module)
4889 (python-tests--completion-parameters)
4890 (python-tests--completion-extra-context)))))
4891
4892(ert-deftest python-shell-completion-at-point-ipython ()
4893 "Check if Python shell completion works for IPython."
4894 (let ((python-shell-interpreter "ipython")
4895 (python-shell-interpreter-args "-i --simple-prompt"))
4896 (skip-unless
4897 (and
4898 (executable-find python-shell-interpreter)
4899 (eql (call-process python-shell-interpreter nil nil nil "--version") 0)))
4900 (with-environment-variables
4901 (("PYTHONSTARTUP" (python-tests--pythonstartup-file)))
4902 (python-tests-with-temp-buffer-with-shell
4903 ""
4904 (python-shell-with-shell-buffer
4905 (python-shell-completion-native-turn-off)
4906 (python-tests--completion-module)
4907 (python-tests--completion-parameters)
4908 (python-shell-completion-native-turn-on)
4909 (skip-unless (string= python-shell-readline-completer-delims ""))
4910 (python-tests--completion-module)
4911 (python-tests--completion-parameters)
4912 (python-tests--completion-extra-context))))))
4802 4913
4803 4914
4804;;; PDB Track integration 4915;;; PDB Track integration
@@ -4945,11 +5056,6 @@ import abc
4945 5056
4946(ert-deftest python-ffap-module-path-1 () 5057(ert-deftest python-ffap-module-path-1 ()
4947 (skip-unless (executable-find python-tests-shell-interpreter)) 5058 (skip-unless (executable-find python-tests-shell-interpreter))
4948 ;; Skip the test on macOS, since the standard Python installation uses
4949 ;; libedit rather than readline which confuses the running of an inferior
4950 ;; interpreter in this case (see bug#59477 and bug#25753).
4951 (skip-when (eq system-type 'darwin))
4952 (trace-function 'python-shell-output-filter)
4953 (python-tests-with-temp-buffer-with-shell 5059 (python-tests-with-temp-buffer-with-shell
4954 " 5060 "
4955import abc 5061import 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 @@
92 ("1@example.com" 1 email "1@example.com") 92 ("1@example.com" 1 email "1@example.com")
93 ;; email addresses user portion containing dots 93 ;; email addresses user portion containing dots
94 ("foo.bar@example.com" 1 email "foo.bar@example.com") 94 ("foo.bar@example.com" 1 email "foo.bar@example.com")
95 ("foo.bar@example.com" 5 email "foo.bar@example.com")
96 (" fo.ba@example.com" 6 email "fo.ba@example.com")
95 (".foobar@example.com" 1 email nil) 97 (".foobar@example.com" 1 email nil)
96 (".foobar@example.com" 2 email "foobar@example.com") 98 (".foobar@example.com" 2 email "foobar@example.com")
97 ;; email addresses domain portion containing dots and dashes 99 ;; email addresses domain portion containing dots and dashes
@@ -180,6 +182,13 @@ position to retrieve THING.")
180 (should (thing-at-point-looking-at "2abcd")) 182 (should (thing-at-point-looking-at "2abcd"))
181 (should (equal (match-data) m2))))) 183 (should (equal (match-data) m2)))))
182 184
185(ert-deftest thing-at-point-looking-at-overlapping-matches ()
186 (with-temp-buffer
187 (insert "foo.bar.baz")
188 (goto-char (point-max))
189 (should (thing-at-point-looking-at "[a-z]+\\.[a-z]+"))
190 (should (string= "bar.baz" (match-string 0)))))
191
183(ert-deftest test-symbol-thing-1 () 192(ert-deftest test-symbol-thing-1 ()
184 (with-temp-buffer 193 (with-temp-buffer
185 (insert "foo bar zot") 194 (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 @@
367 (while (consp insn) 367 (while (consp insn)
368 (let ((newcar (car insn))) 368 (let ((newcar (car insn)))
369 (if (or (consp (car insn)) (comp-mvar-p (car insn))) 369 (if (or (consp (car insn)) (comp-mvar-p (car insn)))
370 (setf newcar (comp-copy-insn (car insn)))) 370 (setf newcar (comp--copy-insn (car insn))))
371 (push newcar result)) 371 (push newcar result))
372 (setf insn (cdr insn))) 372 (setf insn (cdr insn)))
373 (nconc (nreverse result) 373 (nconc (nreverse result)
374 (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) 374 (if (comp-mvar-p insn) (comp--copy-insn insn) insn)))
375 (if (comp-mvar-p insn) 375 (if (comp-mvar-p insn)
376 (copy-comp-mvar insn) 376 (copy-comp-mvar insn)
377 insn))) 377 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."
904 (should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f))) 904 (should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f)))
905 (should (= (comp-tests-fw-prop-1-f) 6)))) 905 (should (= (comp-tests-fw-prop-1-f) 6))))
906 906
907(defun comp-tests--type-lists-equal (l1 l2)
908 (and (= (length l1) (length l2))
909 (cl-every #'comp-tests--types-equal l1 l2)))
910
907(defun comp-tests--types-equal (t1 t2) 911(defun comp-tests--types-equal (t1 t2)
908 "Whether the types T1 and T2 are equal." 912 "Whether the types T1 and T2 are equal."
909 (or (equal t1 t2) ; optimization for the common case 913 (or (equal t1 t2) ; for atoms, and optimization for the common case
910 (and (consp t1) (consp t2) 914 (and (consp t1) (consp t2)
911 (eq (car t1) (car t2)) 915 (eq (car t1) (car t2))
912 (if (memq (car t1) '(and or member)) 916 (cond ((memq (car t1) '(and or member))
913 (null (cl-set-exclusive-or (cdr t1) (cdr t2) 917 ;; Order or duplicates don't matter.
914 :test #'comp-tests--types-equal)) 918 (null (cl-set-exclusive-or (cdr t1) (cdr t2)
915 (and (= (length t1) (length t2)) 919 :test #'comp-tests--types-equal)))
916 (cl-every #'comp-tests--types-equal (cdr t1) (cdr t2))))))) 920 ((eq (car t1) 'function)
921 (and (comp-tests--type-lists-equal (nth 1 t1) (nth 1 t2))
922 (comp-tests--types-equal (nth 2 t1) (nth 2 t2))))
923 (t (comp-tests--type-lists-equal (cdr t1) (cdr t2)))))))
917 924
918(defun comp-tests-check-ret-type-spec (func-form ret-type) 925(defun comp-tests-check-ret-type-spec (func-form ret-type)
919 (let ((lexical-binding t) 926 (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."
282 (should-error (defvaralias 'eval-tests--my-c 'eval-tests--my-d) 282 (should-error (defvaralias 'eval-tests--my-c 'eval-tests--my-d)
283 :type 'cyclic-variable-indirection)) 283 :type 'cyclic-variable-indirection))
284 284
285(defvar eval-tests/global-var 'value) 285(defvar eval-tests/global-var 'global-value)
286(defvar-local eval-tests/buffer-local-var 'value) 286(defvar-local eval-tests/buffer-local-var 'default-value)
287(ert-deftest eval-tests/default-value () 287(ert-deftest eval-tests/default-value ()
288 ;; `let' overrides the default value for global variables. 288 ;; `let' overrides the default value for global variables.
289 (should (default-boundp 'eval-tests/global-var)) 289 (should (default-boundp 'eval-tests/global-var))
290 (should (eq 'value (default-value 'eval-tests/global-var))) 290 (should (eq 'global-value (default-value 'eval-tests/global-var)))
291 (should (eq 'value eval-tests/global-var)) 291 (should (eq 'global-value eval-tests/global-var))
292 (let ((eval-tests/global-var 'bar)) 292 (let ((eval-tests/global-var 'let-value))
293 (should (eq 'bar (default-value 'eval-tests/global-var))) 293 (should (eq 'let-value (default-value 'eval-tests/global-var)))
294 (should (eq 'bar eval-tests/global-var))) 294 (should (eq 'let-value eval-tests/global-var)))
295 ;; `let' overrides the default value everywhere, but leaves 295 ;; `let' overrides the default value everywhere, but leaves
296 ;; buffer-local values unchanged in current buffer and in the 296 ;; buffer-local values unchanged in current buffer and in the
297 ;; buffers where there is no explicitly set buffer-local value. 297 ;; buffers where there is no explicitly set buffer-local value.
298 (should (default-boundp 'eval-tests/buffer-local-var)) 298 (should (default-boundp 'eval-tests/buffer-local-var))
299 (should (eq 'value (default-value 'eval-tests/buffer-local-var))) 299 (should (eq 'default-value (default-value 'eval-tests/buffer-local-var)))
300 (should (eq 'value eval-tests/buffer-local-var)) 300 (should (eq 'default-value eval-tests/buffer-local-var))
301 (with-temp-buffer 301 (with-temp-buffer
302 (let ((eval-tests/buffer-local-var 'bar)) 302 (let ((eval-tests/buffer-local-var 'let-value))
303 (should (eq 'bar (default-value 'eval-tests/buffer-local-var))) 303 (should (eq 'let-value (default-value 'eval-tests/buffer-local-var)))
304 (should (eq 'bar eval-tests/buffer-local-var))))) 304 (should (eq 'let-value eval-tests/buffer-local-var))))
305 ;; When current buffer has explicit buffer-local binding, `let' does
306 ;; not alter the default binding.
307 (with-temp-buffer
308 (setq-local eval-tests/buffer-local-var 'local-value)
309 (let ((eval-tests/buffer-local-var 'let-value))
310 ;; Let in a buffer with local binding does not change the
311 ;; default value for variable.
312 (should (eq 'default-value (default-value 'eval-tests/buffer-local-var)))
313 (should (eq 'let-value eval-tests/buffer-local-var))
314 (with-temp-buffer
315 ;; We are in a new buffer - `eval-tests/buffer-local-var' has its global default value.
316 (should (eq 'default-value (default-value 'eval-tests/buffer-local-var)))
317 (should (eq 'default-value eval-tests/buffer-local-var))))))
305 318
306(ert-deftest eval-tests--handler-bind () 319(ert-deftest eval-tests--handler-bind ()
307 ;; A `handler-bind' has no effect if no error is signaled. 320 ;; 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 @@
1097 (should (= (sxhash-equal (record 'a (make-string 10 ?a))) 1097 (should (= (sxhash-equal (record 'a (make-string 10 ?a)))
1098 (sxhash-equal (record 'a (make-string 10 ?a)))))) 1098 (sxhash-equal (record 'a (make-string 10 ?a))))))
1099 1099
1100(ert-deftest fns--define-hash-table-test ()
1101 ;; Check that we can have two differently-named tests using the
1102 ;; same functions (bug#68668).
1103 (define-hash-table-test 'fns-tests--1 'my-cmp 'my-hash)
1104 (define-hash-table-test 'fns-tests--2 'my-cmp 'my-hash)
1105 (let ((h1 (make-hash-table :test 'fns-tests--1))
1106 (h2 (make-hash-table :test 'fns-tests--2)))
1107 (should (eq (hash-table-test h1) 'fns-tests--1))
1108 (should (eq (hash-table-test h2) 'fns-tests--2))))
1109
1100(ert-deftest test-secure-hash () 1110(ert-deftest test-secure-hash ()
1101 (should (equal (secure-hash 'md5 "foobar") 1111 (should (equal (secure-hash 'md5 "foobar")
1102 "3858f62230ac3c915f300c664312c63f")) 1112 "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 @@
34 (let ((num 0)) 34 (let ((num 0))
35 (mapcar (lambda (str) (cons str (cl-incf num))) list))) 35 (mapcar (lambda (str) (cons str (cl-incf num))) list)))
36(defun minibuf-tests--strings-to-obarray (list) 36(defun minibuf-tests--strings-to-obarray (list)
37 (let ((ob (make-vector 7 0))) 37 (let ((ob (obarray-make 7)))
38 (mapc (lambda (str) (intern str ob)) list) 38 (mapc (lambda (str) (intern str ob)) list)
39 ob)) 39 ob))
40(defun minibuf-tests--strings-to-string-hashtable (list) 40(defun minibuf-tests--strings-to-string-hashtable (list)
@@ -61,6 +61,9 @@
61 61
62;;; Testing functions that are agnostic to type of COLLECTION. 62;;; Testing functions that are agnostic to type of COLLECTION.
63 63
64(defun minibuf-tests--set-equal (a b)
65 (null (cl-set-exclusive-or a b :test #'equal)))
66
64(defun minibuf-tests--try-completion (xform-collection) 67(defun minibuf-tests--try-completion (xform-collection)
65 (let* ((abcdef (funcall xform-collection '("abc" "def"))) 68 (let* ((abcdef (funcall xform-collection '("abc" "def")))
66 (+abba (funcall xform-collection '("abc" "abba" "def")))) 69 (+abba (funcall xform-collection '("abc" "abba" "def"))))
@@ -101,7 +104,8 @@
101 (let* ((abcdef (funcall xform-collection '("abc" "def"))) 104 (let* ((abcdef (funcall xform-collection '("abc" "def")))
102 (+abba (funcall xform-collection '("abc" "abba" "def")))) 105 (+abba (funcall xform-collection '("abc" "abba" "def"))))
103 (should (equal (all-completions "a" abcdef) '("abc"))) 106 (should (equal (all-completions "a" abcdef) '("abc")))
104 (should (equal (all-completions "a" +abba) '("abc" "abba"))) 107 (should (minibuf-tests--set-equal (all-completions "a" +abba)
108 '("abc" "abba")))
105 (should (equal (all-completions "abc" +abba) '("abc"))) 109 (should (equal (all-completions "abc" +abba) '("abc")))
106 (should (equal (all-completions "abcd" +abba) nil)))) 110 (should (equal (all-completions "abcd" +abba) nil))))
107 111
@@ -111,7 +115,8 @@
111 (+abba (funcall xform-collection '("abc" "abba" "def"))) 115 (+abba (funcall xform-collection '("abc" "abba" "def")))
112 (+abba-member (funcall collection-member +abba))) 116 (+abba-member (funcall collection-member +abba)))
113 (should (equal (all-completions "a" abcdef abcdef-member) '("abc"))) 117 (should (equal (all-completions "a" abcdef abcdef-member) '("abc")))
114 (should (equal (all-completions "a" +abba +abba-member) '("abc" "abba"))) 118 (should (minibuf-tests--set-equal (all-completions "a" +abba +abba-member)
119 '("abc" "abba")))
115 (should (equal (all-completions "abc" +abba +abba-member) '("abc"))) 120 (should (equal (all-completions "abc" +abba +abba-member) '("abc")))
116 (should (equal (all-completions "abcd" +abba +abba-member) nil)) 121 (should (equal (all-completions "abcd" +abba +abba-member) nil))
117 (should-not (all-completions "a" abcdef #'ignore)) 122 (should-not (all-completions "a" abcdef #'ignore))
@@ -124,7 +129,8 @@
124 (+abba (funcall xform-collection '("abc" "abba" "def")))) 129 (+abba (funcall xform-collection '("abc" "abba" "def"))))
125 (let ((completion-regexp-list '("."))) 130 (let ((completion-regexp-list '(".")))
126 (should (equal (all-completions "a" abcdef) '("abc"))) 131 (should (equal (all-completions "a" abcdef) '("abc")))
127 (should (equal (all-completions "a" +abba) '("abc" "abba"))) 132 (should (minibuf-tests--set-equal (all-completions "a" +abba)
133 '("abc" "abba")))
128 (should (equal (all-completions "abc" +abba) '("abc"))) 134 (should (equal (all-completions "abc" +abba) '("abc")))
129 (should (equal (all-completions "abcd" +abba) nil))) 135 (should (equal (all-completions "abcd" +abba) nil)))
130 (let ((completion-regexp-list '("X"))) 136 (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 @@
254 (should (eq nil (treesit-node-text 254 (should (eq nil (treesit-node-text
255 (treesit-search-subtree 255 (treesit-search-subtree
256 subarray "\\[")))) 256 subarray "\\["))))
257 ;; If ALL=nil, searching for number should still find the 257 ;; If ALL=t, searching for number should still find the
258 ;; numbers. 258 ;; numbers.
259 (should (equal "1" (treesit-node-text 259 (should (equal "1" (treesit-node-text
260 (treesit-search-subtree 260 (treesit-search-subtree