aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorAndrea Corallo2021-01-24 21:05:33 +0100
committerAndrea Corallo2021-01-24 21:05:33 +0100
commitb8d3ae78c54db7c7bb65d367a80f9be3d8744c48 (patch)
tree982f190d1dd79685c43a9829dd66e6a7cbbd0c67
parent0ffb3dfaa483b0c5cf1f7f367efcb5e9c041ab53 (diff)
parente5aaa1251cfb9d6d18682a5eda137a2e12ca4213 (diff)
downloademacs-b8d3ae78c54db7c7bb65d367a80f9be3d8744c48.tar.gz
emacs-b8d3ae78c54db7c7bb65d367a80f9be3d8744c48.zip
Merge remote-tracking branch 'savannah/master' into native-comp
-rw-r--r--.clang-format2
-rw-r--r--.gitignore1
-rw-r--r--.gitlab-ci.yml4
-rwxr-xr-xbuild-aux/config.guess8
-rwxr-xr-xbuild-aux/config.sub10
-rw-r--r--configure.ac2
-rw-r--r--doc/lispref/control.texi5
-rw-r--r--doc/lispref/keymaps.texi5
-rw-r--r--doc/lispref/markers.texi4
-rw-r--r--doc/lispref/processes.texi27
-rw-r--r--doc/lispref/text.texi24
-rw-r--r--doc/misc/message.texi6
-rw-r--r--doc/misc/texinfo.tex163
-rw-r--r--doc/misc/tramp.texi35
-rw-r--r--etc/HELLO10
-rw-r--r--etc/NEWS52
-rw-r--r--etc/NEWS.192
-rw-r--r--lib/_Noreturn.h16
-rw-r--r--lib/canonicalize-lgpl.c25
-rw-r--r--lib/cdefs.h192
-rw-r--r--lib/dirent.in.h3
-rw-r--r--lib/dynarray.h31
-rw-r--r--lib/explicit_bzero.c16
-rw-r--r--lib/fchmodat.c17
-rw-r--r--lib/free.c14
-rw-r--r--lib/gnulib.mk.in27
-rw-r--r--lib/libc-config.h171
-rw-r--r--lib/malloc/dynarray-skeleton.c525
-rw-r--r--lib/malloc/dynarray.h178
-rw-r--r--lib/malloc/dynarray_at_failure.c35
-rw-r--r--lib/malloc/dynarray_emplace_enlarge.c73
-rw-r--r--lib/malloc/dynarray_finalize.c62
-rw-r--r--lib/malloc/dynarray_resize.c64
-rw-r--r--lib/malloc/dynarray_resize_clear.c35
-rw-r--r--lib/malloc/scratch_buffer_grow.c2
-rw-r--r--lib/malloc/scratch_buffer_grow_preserve.c2
-rw-r--r--lib/malloc/scratch_buffer_set_array_size.c2
-rw-r--r--lib/mini-gmp.c2
-rw-r--r--lib/mktime-internal.h2
-rw-r--r--lib/nstrftime.c6
-rw-r--r--lib/regex.c2
-rw-r--r--lib/regex_internal.h26
-rw-r--r--lib/regexec.c117
-rw-r--r--lib/scratch_buffer.h1
-rw-r--r--lib/stddef.in.h23
-rw-r--r--lib/string.in.h20
-rw-r--r--lib/sys_stat.in.h30
-rw-r--r--lib/tempname.c27
-rw-r--r--lib/time-internal.h2
-rw-r--r--lib/time.in.h19
-rw-r--r--lib/time_rz.c16
-rw-r--r--lib/timegm.c2
-rw-r--r--lib/utimens.c19
-rw-r--r--lib/utimensat.c101
-rw-r--r--lib/verify.h28
-rw-r--r--lisp/calc/calc-embed.el2
-rw-r--r--lisp/calc/calc-lang.el2
-rw-r--r--lisp/calc/calc.el2
-rw-r--r--lisp/calc/calccomp.el260
-rw-r--r--lisp/calendar/cal-bahai.el28
-rw-r--r--lisp/calendar/cal-china.el45
-rw-r--r--lisp/calendar/cal-coptic.el56
-rw-r--r--lisp/calendar/cal-french.el76
-rw-r--r--lisp/calendar/cal-hebrew.el68
-rw-r--r--lisp/calendar/cal-html.el19
-rw-r--r--lisp/calendar/cal-islam.el25
-rw-r--r--lisp/calendar/cal-iso.el21
-rw-r--r--lisp/calendar/cal-julian.el26
-rw-r--r--lisp/calendar/cal-mayan.el10
-rw-r--r--lisp/calendar/cal-menu.el4
-rw-r--r--lisp/calendar/cal-move.el17
-rw-r--r--lisp/calendar/cal-persia.el30
-rw-r--r--lisp/calendar/cal-tex.el85
-rw-r--r--lisp/calendar/cal-x.el2
-rw-r--r--lisp/calendar/calendar.el57
-rw-r--r--lisp/calendar/diary-lib.el4
-rw-r--r--lisp/calendar/holidays.el15
-rw-r--r--lisp/cedet/ede/base.el5
-rw-r--r--lisp/cedet/ede/proj.el2
-rw-r--r--lisp/comint.el6
-rw-r--r--lisp/cus-start.el2
-rw-r--r--lisp/custom.el12
-rw-r--r--lisp/dired-aux.el5
-rw-r--r--lisp/dired-x.el2
-rw-r--r--lisp/emacs-lisp/byte-opt.el1401
-rw-r--r--lisp/emacs-lisp/byte-run.el16
-rw-r--r--lisp/emacs-lisp/bytecomp.el3
-rw-r--r--lisp/emacs-lisp/checkdoc.el7
-rw-r--r--lisp/emacs-lisp/ert.el4
-rw-r--r--lisp/emacs-lisp/macroexp.el14
-rw-r--r--lisp/emacs-lisp/package.el2
-rw-r--r--lisp/emacs-lisp/pcase.el46
-rw-r--r--lisp/emacs-lisp/radix-tree.el7
-rw-r--r--lisp/emacs-lisp/subr-x.el22
-rw-r--r--lisp/emulation/cua-gmrk.el8
-rw-r--r--lisp/epa.el4
-rw-r--r--lisp/facemenu.el11
-rw-r--r--lisp/faces.el2
-rw-r--r--lisp/files.el2
-rw-r--r--lisp/font-lock.el2
-rw-r--r--lisp/frame.el16
-rw-r--r--lisp/gnus/gnus-agent.el383
-rw-r--r--lisp/gnus/gnus-async.el9
-rw-r--r--lisp/gnus/gnus-cache.el126
-rw-r--r--lisp/gnus/gnus-cloud.el16
-rw-r--r--lisp/gnus/gnus-search.el1
-rw-r--r--lisp/gnus/gnus-start.el10
-rw-r--r--lisp/gnus/gnus-sum.el65
-rw-r--r--lisp/gnus/gnus.el9
-rw-r--r--lisp/gnus/message.el98
-rw-r--r--lisp/gnus/nnml.el16
-rw-r--r--lisp/gnus/nntp.el2
-rw-r--r--lisp/gnus/nnvirtual.el172
-rw-r--r--lisp/help-fns.el3
-rw-r--r--lisp/hl-line.el58
-rw-r--r--lisp/ibuf-ext.el20
-rw-r--r--lisp/ibuffer.el9
-rw-r--r--lisp/image.el2
-rw-r--r--lisp/international/fontset.el1
-rw-r--r--lisp/isearch.el30
-rw-r--r--lisp/language/cham.el8
-rw-r--r--lisp/leim/quail/cham.el116
-rw-r--r--lisp/mail/flow-fill.el2
-rw-r--r--lisp/mail/footnote.el26
-rw-r--r--lisp/mail/rmailedit.el9
-rw-r--r--lisp/mail/rmailsum.el6
-rw-r--r--lisp/mh-e/mh-speed.el6
-rw-r--r--lisp/net/eww.el7
-rw-r--r--lisp/net/tramp-sh.el27
-rw-r--r--lisp/net/tramp-smb.el24
-rw-r--r--lisp/net/tramp.el21
-rw-r--r--lisp/net/webjump.el7
-rw-r--r--lisp/nxml/nxml-mode.el30
-rw-r--r--lisp/obsolete/nnir.el1
-rw-r--r--lisp/progmodes/perl-mode.el11
-rw-r--r--lisp/progmodes/project.el3
-rw-r--r--lisp/progmodes/sh-script.el4
-rw-r--r--lisp/progmodes/xref.el20
-rw-r--r--lisp/replace.el41
-rw-r--r--lisp/simple.el19
-rw-r--r--lisp/startup.el11
-rw-r--r--lisp/term/ns-win.el9
-rw-r--r--lisp/textmodes/remember.el37
-rw-r--r--lisp/thingatpt.el44
-rw-r--r--lisp/type-break.el4
-rw-r--r--lisp/vc/vc.el42
-rw-r--r--lisp/version.el6
-rw-r--r--lisp/wid-edit.el19
-rw-r--r--m4/canonicalize.m460
-rw-r--r--m4/extensions.m414
-rw-r--r--m4/fchmodat.m448
-rw-r--r--m4/gnulib-common.m415
-rw-r--r--m4/gnulib-comp.m420
-rw-r--r--m4/nstrftime.m44
-rw-r--r--m4/stddef_h.m416
-rw-r--r--m4/string_h.m43
-rw-r--r--m4/sys_stat_h.m44
-rw-r--r--m4/time_h.m420
-rw-r--r--m4/utimensat.m457
-rw-r--r--src/alloc.c6
-rw-r--r--src/conf_post.h4
-rw-r--r--src/emacs-module.h.in4
-rw-r--r--src/frame.c59
-rw-r--r--src/nsfns.m1
-rw-r--r--src/nsmenu.m1
-rw-r--r--src/nsselect.m15
-rw-r--r--src/nsterm.h9
-rw-r--r--src/nsterm.m52
-rw-r--r--src/process.c130
-rw-r--r--src/term.c43
-rw-r--r--src/termhooks.h2
-rw-r--r--src/window.c2
-rw-r--r--src/xdisp.c6
-rw-r--r--test/Makefile.in20
-rw-r--r--test/README13
-rw-r--r--test/file-organization.org16
-rw-r--r--test/infra/Dockerfile.emba2
-rw-r--r--test/infra/gitlab-ci.yml245
-rw-r--r--test/lisp/autorevert-tests.el25
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el6
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el17
-rw-r--r--test/lisp/emacs-lisp/bytecomp-tests.el8
-rw-r--r--test/lisp/emacs-lisp/cl-lib-tests.el9
-rw-r--r--test/lisp/emacs-lisp/pcase-tests.el4
-rw-r--r--test/lisp/emacs-lisp/seq-tests.el23
-rw-r--r--test/lisp/faces-tests.el8
-rw-r--r--test/lisp/net/tramp-tests.el70
-rw-r--r--test/lisp/progmodes/elisp-mode-tests.el65
-rw-r--r--test/lisp/replace-tests.el13
-rw-r--r--test/lisp/thingatpt-tests.el44
-rw-r--r--test/lisp/time-stamp-tests.el127
-rw-r--r--test/lisp/wid-edit-tests.el11
-rw-r--r--test/src/process-tests.el150
-rw-r--r--test/src/xdisp-tests.el33
194 files changed, 5187 insertions, 2655 deletions
diff --git a/.clang-format b/.clang-format
index 9ab09a86ff2..44200a39952 100644
--- a/.clang-format
+++ b/.clang-format
@@ -1,5 +1,5 @@
1Language: Cpp 1Language: Cpp
2BasedOnStyle: LLVM 2BasedOnStyle: GNU
3AlignEscapedNewlinesLeft: true 3AlignEscapedNewlinesLeft: true
4AlwaysBreakAfterReturnType: TopLevelDefinitions 4AlwaysBreakAfterReturnType: TopLevelDefinitions
5BreakBeforeBinaryOperators: All 5BreakBeforeBinaryOperators: All
diff --git a/.gitignore b/.gitignore
index 63fa4203b58..4c7c1ad61b7 100644
--- a/.gitignore
+++ b/.gitignore
@@ -299,4 +299,3 @@ nt/emacs.rc
299nt/emacsclient.rc 299nt/emacsclient.rc
300src/gdb.ini 300src/gdb.ini
301/var/ 301/var/
302src/fingerprint.c
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 1be92cff161..acc1649bdab 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -1,4 +1,4 @@
1# Copyright (C) 2017-2021 Free Software Foundation, Inc. 1# Copyright (C) 2021 Free Software Foundation, Inc.
2# 2#
3# This file is part of GNU Emacs. 3# This file is part of GNU Emacs.
4# 4#
@@ -194,3 +194,5 @@ test-all:
194 variables: 194 variables:
195 target: emacs-inotify 195 target: emacs-inotify
196 make_params: check-expensive 196 make_params: check-expensive
197# Just load from test/infra, to keep build automation files there.
198include: '/test/infra/gitlab-ci.yml'
diff --git a/build-aux/config.guess b/build-aux/config.guess
index 7f748177972..f7727026b70 100755
--- a/build-aux/config.guess
+++ b/build-aux/config.guess
@@ -1,8 +1,8 @@
1#! /bin/sh 1#! /bin/sh
2# Attempt to guess a canonical system name. 2# Attempt to guess a canonical system name.
3# Copyright 1992-2020 Free Software Foundation, Inc. 3# Copyright 1992-2021 Free Software Foundation, Inc.
4 4
5timestamp='2020-12-22' 5timestamp='2021-01-01'
6 6
7# This file is free software; you can redistribute it and/or modify it 7# This file is free software; you can redistribute it and/or modify it
8# under the terms of the GNU General Public License as published by 8# under the terms of the GNU General Public License as published by
@@ -50,7 +50,7 @@ version="\
50GNU config.guess ($timestamp) 50GNU config.guess ($timestamp)
51 51
52Originally written by Per Bothner. 52Originally written by Per Bothner.
53Copyright 1992-2020 Free Software Foundation, Inc. 53Copyright 1992-2021 Free Software Foundation, Inc.
54 54
55This is free software; see the source for copying conditions. There is NO 55This is free software; see the source for copying conditions. There is NO
56warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." 56warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
@@ -1087,7 +1087,7 @@ EOF
1087 ppcle:Linux:*:*) 1087 ppcle:Linux:*:*)
1088 echo powerpcle-unknown-linux-"$LIBC" 1088 echo powerpcle-unknown-linux-"$LIBC"
1089 exit ;; 1089 exit ;;
1090 riscv32:Linux:*:* | riscv64:Linux:*:*) 1090 riscv32:Linux:*:* | riscv32be:Linux:*:* | riscv64:Linux:*:* | riscv64be:Linux:*:*)
1091 echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" 1091 echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
1092 exit ;; 1092 exit ;;
1093 s390:Linux:*:* | s390x:Linux:*:*) 1093 s390:Linux:*:* | s390x:Linux:*:*)
diff --git a/build-aux/config.sub b/build-aux/config.sub
index 90bb8aeda63..b0f8492348d 100755
--- a/build-aux/config.sub
+++ b/build-aux/config.sub
@@ -1,8 +1,8 @@
1#! /bin/sh 1#! /bin/sh
2# Configuration validation subroutine script. 2# Configuration validation subroutine script.
3# Copyright 1992-2020 Free Software Foundation, Inc. 3# Copyright 1992-2021 Free Software Foundation, Inc.
4 4
5timestamp='2020-12-22' 5timestamp='2021-01-07'
6 6
7# This file is free software; you can redistribute it and/or modify it 7# This file is free software; you can redistribute it and/or modify it
8# under the terms of the GNU General Public License as published by 8# under the terms of the GNU General Public License as published by
@@ -67,7 +67,7 @@ Report bugs and patches to <config-patches@gnu.org>."
67version="\ 67version="\
68GNU config.sub ($timestamp) 68GNU config.sub ($timestamp)
69 69
70Copyright 1992-2020 Free Software Foundation, Inc. 70Copyright 1992-2021 Free Software Foundation, Inc.
71 71
72This is free software; see the source for copying conditions. There is NO 72This is free software; see the source for copying conditions. There is NO
73warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." 73warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
@@ -1230,7 +1230,7 @@ case $cpu-$vendor in
1230 | powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \ 1230 | powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \
1231 | pru \ 1231 | pru \
1232 | pyramid \ 1232 | pyramid \
1233 | riscv | riscv32 | riscv64 \ 1233 | riscv | riscv32 | riscv32be | riscv64 | riscv64be \
1234 | rl78 | romp | rs6000 | rx \ 1234 | rl78 | romp | rs6000 | rx \
1235 | s390 | s390x \ 1235 | s390 | s390x \
1236 | score \ 1236 | score \
@@ -1687,7 +1687,7 @@ case $os in
1687 musl* | newlib* | uclibc*) 1687 musl* | newlib* | uclibc*)
1688 ;; 1688 ;;
1689 # Likewise for "kernel-libc" 1689 # Likewise for "kernel-libc"
1690 eabi | eabihf | gnueabi | gnueabihf) 1690 eabi* | gnueabi*)
1691 ;; 1691 ;;
1692 # Now accept the basic system types. 1692 # Now accept the basic system types.
1693 # The portable systems comes first. 1693 # The portable systems comes first.
diff --git a/configure.ac b/configure.ac
index 1bff666ad50..4691d5785a6 100644
--- a/configure.ac
+++ b/configure.ac
@@ -6011,7 +6011,7 @@ if test $AUTO_DEPEND = yes; then
6011 AS_MKDIR_P([$dir/deps]) 6011 AS_MKDIR_P([$dir/deps])
6012 done 6012 done
6013fi 6013fi
6014if $gl_gnulib_enabled_scratch_buffer; then 6014if $gl_gnulib_enabled_dynarray || $gl_gnulib_enabled_scratch_buffer; then
6015 AS_MKDIR_P([lib/malloc]) 6015 AS_MKDIR_P([lib/malloc])
6016 if test $AUTO_DEPEND = yes; then 6016 if test $AUTO_DEPEND = yes; then
6017 AS_MKDIR_P([lib/deps/malloc]) 6017 AS_MKDIR_P([lib/deps/malloc])
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 55bcddb31aa..80e9eb7dd8e 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -557,8 +557,9 @@ Likewise, it makes no sense to bind keyword symbols
557 557
558@item (pred @var{function}) 558@item (pred @var{function})
559Matches if the predicate @var{function} returns non-@code{nil} 559Matches if the predicate @var{function} returns non-@code{nil}
560when called on @var{expval}. 560when called on @var{expval}. The test can be negated with the syntax
561the predicate @var{function} can have one of the following forms: 561@code{(pred (not @var{function}))}.
562The predicate @var{function} can have one of the following forms:
562 563
563@table @asis 564@table @asis
564@item function name (a symbol) 565@item function name (a symbol)
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index 37bab7ea9bc..55d179b8753 100644
--- a/doc/lispref/keymaps.texi
+++ b/doc/lispref/keymaps.texi
@@ -2852,9 +2852,8 @@ Here is how to insert an item called @samp{Work} in the @samp{Signals}
2852menu of Shell mode, after the item @code{break}: 2852menu of Shell mode, after the item @code{break}:
2853 2853
2854@example 2854@example
2855(define-key-after 2855(define-key-after shell-mode-map [menu-bar signals work]
2856 (lookup-key shell-mode-map [menu-bar signals]) 2856 '("Work" . work-command) 'break)
2857 [work] '("Work" . work-command) 'break)
2858@end example 2857@end example
2859@end defun 2858@end defun
2860 2859
diff --git a/doc/lispref/markers.texi b/doc/lispref/markers.texi
index cdd0938b458..b39373f0727 100644
--- a/doc/lispref/markers.texi
+++ b/doc/lispref/markers.texi
@@ -560,7 +560,9 @@ deactivate the mark. If the value is @w{@code{(only . @var{oldval})}},
560then @code{transient-mark-mode} is set to the value @var{oldval} after 560then @code{transient-mark-mode} is set to the value @var{oldval} after
561any subsequent command that moves point and is not shift-translated 561any subsequent command that moves point and is not shift-translated
562(@pxref{Key Sequence Input, shift-translation}), or after any other 562(@pxref{Key Sequence Input, shift-translation}), or after any other
563action that would normally deactivate the mark. 563action that would normally deactivate the mark. (Marking a region
564with the mouse will temporarily enable @code{transient-mark-mode} in
565this way.)
564@end defopt 566@end defopt
565 567
566@defopt mark-even-if-inactive 568@defopt mark-even-if-inactive
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 535cebed7a8..6dedaa31f2e 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -729,7 +729,9 @@ coding systems (@pxref{Default Coding Systems}). On the other hand,
729it will use @var{query-flag} as its query-on-exit flag (@pxref{Query 729it will use @var{query-flag} as its query-on-exit flag (@pxref{Query
730Before Exit}). It will be associated with the @var{stderr} buffer 730Before Exit}). It will be associated with the @var{stderr} buffer
731(@pxref{Process Buffers}) and send its output (which is the standard 731(@pxref{Process Buffers}) and send its output (which is the standard
732error of the main process) there. 732error of the main process) there. To get the process object for the
733standard error process, pass the @var{stderr} buffer to
734@code{get-buffer-process}.
733 735
734If @var{stderr} is a pipe process, Emacs will use it as standard error 736If @var{stderr} is a pipe process, Emacs will use it as standard error
735process for the new process. 737process for the new process.
@@ -1942,6 +1944,29 @@ code:
1942(while (accept-process-output stderr-process)) 1944(while (accept-process-output stderr-process))
1943@end example 1945@end example
1944 1946
1947If you passed a buffer to the @var{stderr} argument of
1948@code{make-process}, you still have to wait for the standard error
1949process, like so:
1950
1951@example
1952(let* ((stdout (generate-new-buffer "stdout"))
1953 (stderr (generate-new-buffer "stderr"))
1954 (process (make-process :name "test"
1955 :command '("my-program")
1956 :buffer stdout
1957 :stderr stderr))
1958 (stderr-process (get-buffer-process stderr)))
1959 (unless (and process stderr-process)
1960 (error "Process unexpectedly nil"))
1961 (while (accept-process-output process))
1962 (while (accept-process-output stderr-process)))
1963@end example
1964
1965@noindent
1966Only when both @code{accept-process-output} forms return @code{nil},
1967you can be sure that the process has exited and Emacs has read all its
1968output.
1969
1945Reading pending standard error from a process running on a remote host 1970Reading pending standard error from a process running on a remote host
1946is not possible this way. 1971is not possible this way.
1947 1972
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 0b567d82c61..14854a5aafa 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -334,6 +334,25 @@ but there is no peace.
334(thing-at-point 'whitespace) 334(thing-at-point 'whitespace)
335 @result{} nil 335 @result{} nil
336@end example 336@end example
337
338@defvar thing-at-point-provider-alist
339This variable allows users and modes to tweak how
340@code{thing-at-point} works. It's an association list of @var{thing}s
341and functions (called with zero parameters) to return that thing.
342Entries for @var{thing} will be evaluated in turn until a
343non-@code{nil} result is returned.
344
345For instance, a major mode could say:
346
347@lisp
348(setq-local thing-at-point-provider-alist
349 (append thing-at-point-provider-alist
350 '((url . my-mode--url-at-point))))
351@end lisp
352
353If no providers have a non-@code{nil} return, the @var{thing} will be
354computed the standard way.
355@end defvar
337@end defun 356@end defun
338 357
339@node Comparing Text 358@node Comparing Text
@@ -5610,6 +5629,11 @@ This function cancels and undoes all the changes in the change group
5610specified by @var{handle}. 5629specified by @var{handle}.
5611@end defun 5630@end defun
5612 5631
5632@defun undo-amalgamate-change-group
5633Amalgamate changes in change-group since @var{handle}. I.e., remove
5634all undo boundaries between the state of @var{handle} and now.
5635@end defun
5636
5613 Your code should use @code{unwind-protect} to make sure the group is 5637 Your code should use @code{unwind-protect} to make sure the group is
5614always finished. The call to @code{activate-change-group} should be 5638always finished. The call to @code{activate-change-group} should be
5615inside the @code{unwind-protect}, in case the user types @kbd{C-g} 5639inside the @code{unwind-protect}, in case the user types @kbd{C-g}
diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index f2680b4a797..be6c9a419b2 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -317,6 +317,12 @@ when forwarding a message.
317In non-@code{nil}, only headers that match this regexp will be kept 317In non-@code{nil}, only headers that match this regexp will be kept
318when forwarding a message. This can also be a list of regexps. 318when forwarding a message. This can also be a list of regexps.
319 319
320@item message-forward-included-mime-headers
321@vindex message-forward-included-mime-headers
322In non-@code{nil}, headers that match this regexp will be kept when
323forwarding a message as @acronym{MIME}, but @acronym{MML} isn't used.
324This can also be a list of regexps.
325
320@item message-make-forward-subject-function 326@item message-make-forward-subject-function
321@vindex message-make-forward-subject-function 327@vindex message-make-forward-subject-function
322A list of functions that are called to generate a subject header for 328A list of functions that are called to generate a subject header for
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex
index 3c7051d1c74..dac7ae3d199 100644
--- a/doc/misc/texinfo.tex
+++ b/doc/misc/texinfo.tex
@@ -3,7 +3,7 @@
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{2020-10-24.12} 6\def\texinfoversion{2020-11-25.18}
7% 7%
8% Copyright 1985, 1986, 1988, 1990-2020 Free Software Foundation, Inc. 8% Copyright 1985, 1986, 1988, 1990-2020 Free Software Foundation, Inc.
9% 9%
@@ -572,10 +572,9 @@
572 \fi 572 \fi
573} 573}
574 574
575% @end foo executes the definition of \Efoo. 575
576% But first, it executes a specialized version of \checkenv 576% @end foo calls \checkenv and executes the definition of \Efoo.
577% 577\parseargdef\end{
578\parseargdef\end{%
579 \if 1\csname iscond.#1\endcsname 578 \if 1\csname iscond.#1\endcsname
580 \else 579 \else
581 % The general wording of \badenverr may not be ideal. 580 % The general wording of \badenverr may not be ideal.
@@ -2673,8 +2672,6 @@ end
2673\definetextfontsizexi 2672\definetextfontsizexi
2674 2673
2675 2674
2676\message{markup,}
2677
2678% Check if we are currently using a typewriter font. Since all the 2675% Check if we are currently using a typewriter font. Since all the
2679% Computer Modern typewriter fonts have zero interword stretch (and 2676% Computer Modern typewriter fonts have zero interword stretch (and
2680% shrink), and it is reasonable to expect all typewriter fonts to have 2677% shrink), and it is reasonable to expect all typewriter fonts to have
@@ -2682,68 +2679,14 @@ end
2682% 2679%
2683\def\ifmonospace{\ifdim\fontdimen3\font=0pt } 2680\def\ifmonospace{\ifdim\fontdimen3\font=0pt }
2684 2681
2685% Markup style infrastructure. \defmarkupstylesetup\INITMACRO will
2686% define and register \INITMACRO to be called on markup style changes.
2687% \INITMACRO can check \currentmarkupstyle for the innermost
2688% style.
2689
2690\let\currentmarkupstyle\empty
2691
2692\def\setupmarkupstyle#1{%
2693 \def\currentmarkupstyle{#1}%
2694 \markupstylesetup
2695}
2696
2697\let\markupstylesetup\empty
2698
2699\def\defmarkupstylesetup#1{%
2700 \expandafter\def\expandafter\markupstylesetup
2701 \expandafter{\markupstylesetup #1}%
2702 \def#1%
2703}
2704
2705% Markup style setup for left and right quotes.
2706\defmarkupstylesetup\markupsetuplq{%
2707 \expandafter\let\expandafter \temp
2708 \csname markupsetuplq\currentmarkupstyle\endcsname
2709 \ifx\temp\relax \markupsetuplqdefault \else \temp \fi
2710}
2711
2712\defmarkupstylesetup\markupsetuprq{%
2713 \expandafter\let\expandafter \temp
2714 \csname markupsetuprq\currentmarkupstyle\endcsname
2715 \ifx\temp\relax \markupsetuprqdefault \else \temp \fi
2716}
2717
2718{ 2682{
2719\catcode`\'=\active 2683\catcode`\'=\active
2720\catcode`\`=\active 2684\catcode`\`=\active
2721 2685
2722\gdef\markupsetuplqdefault{\let`\lq} 2686\gdef\setcodequotes{\let`\codequoteleft \let'\codequoteright}
2723\gdef\markupsetuprqdefault{\let'\rq} 2687\gdef\setregularquotes{\let`\lq \let'\rq}
2724
2725\gdef\markupsetcodequoteleft{\let`\codequoteleft}
2726\gdef\markupsetcodequoteright{\let'\codequoteright}
2727} 2688}
2728 2689
2729\let\markupsetuplqcode \markupsetcodequoteleft
2730\let\markupsetuprqcode \markupsetcodequoteright
2731%
2732\let\markupsetuplqexample \markupsetcodequoteleft
2733\let\markupsetuprqexample \markupsetcodequoteright
2734%
2735\let\markupsetuplqkbd \markupsetcodequoteleft
2736\let\markupsetuprqkbd \markupsetcodequoteright
2737%
2738\let\markupsetuplqsamp \markupsetcodequoteleft
2739\let\markupsetuprqsamp \markupsetcodequoteright
2740%
2741\let\markupsetuplqverb \markupsetcodequoteleft
2742\let\markupsetuprqverb \markupsetcodequoteright
2743%
2744\let\markupsetuplqverbatim \markupsetcodequoteleft
2745\let\markupsetuprqverbatim \markupsetcodequoteright
2746
2747% Allow an option to not use regular directed right quote/apostrophe 2690% Allow an option to not use regular directed right quote/apostrophe
2748% (char 0x27), but instead the undirected quote from cmtt (char 0x0d). 2691% (char 0x27), but instead the undirected quote from cmtt (char 0x0d).
2749% The undirected quote is ugly, so don't make it the default, but it 2692% The undirected quote is ugly, so don't make it the default, but it
@@ -2906,7 +2849,7 @@ end
2906} 2849}
2907 2850
2908% @samp. 2851% @samp.
2909\def\samp#1{{\setupmarkupstyle{samp}\lq\tclose{#1}\rq\null}} 2852\def\samp#1{{\setcodequotes\lq\tclose{#1}\rq\null}}
2910 2853
2911% @indicateurl is \samp, that is, with quotes. 2854% @indicateurl is \samp, that is, with quotes.
2912\let\indicateurl=\samp 2855\let\indicateurl=\samp
@@ -2949,8 +2892,7 @@ end
2949 \global\let'=\rq \global\let`=\lq % default definitions 2892 \global\let'=\rq \global\let`=\lq % default definitions
2950 % 2893 %
2951 \global\def\code{\begingroup 2894 \global\def\code{\begingroup
2952 \setupmarkupstyle{code}% 2895 \setcodequotes
2953 % The following should really be moved into \setupmarkupstyle handlers.
2954 \catcode\dashChar=\active \catcode\underChar=\active 2896 \catcode\dashChar=\active \catcode\underChar=\active
2955 \ifallowcodebreaks 2897 \ifallowcodebreaks
2956 \let-\codedash 2898 \let-\codedash
@@ -3104,7 +3046,7 @@ end
3104 \urefcatcodes 3046 \urefcatcodes
3105 % 3047 %
3106 \global\def\urefcode{\begingroup 3048 \global\def\urefcode{\begingroup
3107 \setupmarkupstyle{code}% 3049 \setcodequotes
3108 \urefcatcodes 3050 \urefcatcodes
3109 \let&\urefcodeamp 3051 \let&\urefcodeamp
3110 \let.\urefcodedot 3052 \let.\urefcodedot
@@ -3225,8 +3167,8 @@ end
3225\def\kbdsub#1#2#3\par{% 3167\def\kbdsub#1#2#3\par{%
3226 \def\one{#1}\def\three{#3}\def\threex{??}% 3168 \def\one{#1}\def\three{#3}\def\threex{??}%
3227 \ifx\one\xkey\ifx\threex\three \key{#2}% 3169 \ifx\one\xkey\ifx\threex\three \key{#2}%
3228 \else{\tclose{\kbdfont\setupmarkupstyle{kbd}\look}}\fi 3170 \else{\tclose{\kbdfont\setcodequotes\look}}\fi
3229 \else{\tclose{\kbdfont\setupmarkupstyle{kbd}\look}}\fi 3171 \else{\tclose{\kbdfont\setcodequotes\look}}\fi
3230} 3172}
3231 3173
3232% definition of @key that produces a lozenge. Doesn't adjust to text size. 3174% definition of @key that produces a lozenge. Doesn't adjust to text size.
@@ -3243,7 +3185,7 @@ end
3243% monospace, don't change it; that way, we respect @kbdinputstyle. But 3185% monospace, don't change it; that way, we respect @kbdinputstyle. But
3244% if it isn't monospace, then use \tt. 3186% if it isn't monospace, then use \tt.
3245% 3187%
3246\def\key#1{{\setupmarkupstyle{key}% 3188\def\key#1{{\setregularquotes
3247 \nohyphenation 3189 \nohyphenation
3248 \ifmonospace\else\tt\fi 3190 \ifmonospace\else\tt\fi
3249 #1}\null} 3191 #1}\null}
@@ -3373,16 +3315,20 @@ end
3373{\obeylines 3315{\obeylines
3374\globaldefs=1 3316\globaldefs=1
3375\envdef\displaymath{% 3317\envdef\displaymath{%
3376\tex 3318\tex%
3377\def\thisenv{\displaymath}% 3319\def\thisenv{\displaymath}%
3320\begingroup\let\end\displaymathend%
3378$$% 3321$$%
3379} 3322}
3380 3323
3381\def\Edisplaymath{$$ 3324\def\displaymathend{$$\endgroup\end}%
3325
3326\def\Edisplaymath{%
3382\def\thisenv{\tex}% 3327\def\thisenv{\tex}%
3383\end tex 3328\end tex
3384}} 3329}}
3385 3330
3331
3386% @inlinefmt{FMTNAME,PROCESSED-TEXT} and @inlineraw{FMTNAME,RAW-TEXT}. 3332% @inlinefmt{FMTNAME,PROCESSED-TEXT} and @inlineraw{FMTNAME,RAW-TEXT}.
3387% Ignore unless FMTNAME == tex; then it is like @iftex and @tex, 3333% Ignore unless FMTNAME == tex; then it is like @iftex and @tex,
3388% except specified as a normal braced arg, so no newlines to worry about. 3334% except specified as a normal braced arg, so no newlines to worry about.
@@ -7144,7 +7090,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
7144% But \@ or @@ will get a plain @ character. 7090% But \@ or @@ will get a plain @ character.
7145 7091
7146\envdef\tex{% 7092\envdef\tex{%
7147 \setupmarkupstyle{tex}% 7093 \setregularquotes
7148 \catcode `\\=0 \catcode `\{=1 \catcode `\}=2 7094 \catcode `\\=0 \catcode `\{=1 \catcode `\}=2
7149 \catcode `\$=3 \catcode `\&=4 \catcode `\#=6 7095 \catcode `\$=3 \catcode `\&=4 \catcode `\#=6
7150 \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie 7096 \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie
@@ -7370,7 +7316,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
7370% If you want all examples etc. small: @set dispenvsize small. 7316% If you want all examples etc. small: @set dispenvsize small.
7371% If you want even small examples the full size: @set dispenvsize nosmall. 7317% If you want even small examples the full size: @set dispenvsize nosmall.
7372% This affects the following displayed environments: 7318% This affects the following displayed environments:
7373% @example, @display, @format, @lisp 7319% @example, @display, @format, @lisp, @verbatim
7374% 7320%
7375\def\smallword{small} 7321\def\smallword{small}
7376\def\nosmallword{nosmall} 7322\def\nosmallword{nosmall}
@@ -7416,9 +7362,9 @@ might help (with 'rm \jobname.?? \jobname.??s')%
7416% 7362%
7417\maketwodispenvdef{lisp}{example}{% 7363\maketwodispenvdef{lisp}{example}{%
7418 \nonfillstart 7364 \nonfillstart
7419 \tt\setupmarkupstyle{example}% 7365 \tt\setcodequotes
7420 \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special. 7366 \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special.
7421 \gobble % eat return 7367 \parsearg\gobble
7422} 7368}
7423% @display/@smalldisplay: same as @lisp except keep current font. 7369% @display/@smalldisplay: same as @lisp except keep current font.
7424% 7370%
@@ -7576,7 +7522,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
7576\def\setupverb{% 7522\def\setupverb{%
7577 \tt % easiest (and conventionally used) font for verbatim 7523 \tt % easiest (and conventionally used) font for verbatim
7578 \def\par{\leavevmode\endgraf}% 7524 \def\par{\leavevmode\endgraf}%
7579 \setupmarkupstyle{verb}% 7525 \setcodequotes
7580 \tabeightspaces 7526 \tabeightspaces
7581 % Respect line breaks, 7527 % Respect line breaks,
7582 % print special symbols as themselves, and 7528 % print special symbols as themselves, and
@@ -7617,7 +7563,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
7617 \tt % easiest (and conventionally used) font for verbatim 7563 \tt % easiest (and conventionally used) font for verbatim
7618 \def\par{\egroup\leavevmode\box\verbbox\endgraf\starttabbox}% 7564 \def\par{\egroup\leavevmode\box\verbbox\endgraf\starttabbox}%
7619 \tabexpand 7565 \tabexpand
7620 \setupmarkupstyle{verbatim}% 7566 \setcodequotes
7621 % Respect line breaks, 7567 % Respect line breaks,
7622 % print special symbols as themselves, and 7568 % print special symbols as themselves, and
7623 % make each space count. 7569 % make each space count.
@@ -8036,7 +7982,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
8036 % leave the code in, but it's strange for @var to lead to typewriter. 7982 % leave the code in, but it's strange for @var to lead to typewriter.
8037 % Nowadays we recommend @code, since the difference between a ttsl hyphen 7983 % Nowadays we recommend @code, since the difference between a ttsl hyphen
8038 % and a tt hyphen is pretty tiny. @code also disables ?` !`. 7984 % and a tt hyphen is pretty tiny. @code also disables ?` !`.
8039 \def\var##1{{\setupmarkupstyle{var}\ttslanted{##1}}}% 7985 \def\var##1{{\setregularquotes\ttslanted{##1}}}%
8040 #1% 7986 #1%
8041 \sl\hyphenchar\font=45 7987 \sl\hyphenchar\font=45
8042} 7988}
@@ -8145,11 +8091,18 @@ might help (with 'rm \jobname.?? \jobname.??s')%
8145 } 8091 }
8146\fi 8092\fi
8147 8093
8094\let\E=\expandafter
8095
8148% Used at the time of macro expansion. 8096% Used at the time of macro expansion.
8149% Argument is macro body with arguments substituted 8097% Argument is macro body with arguments substituted
8150\def\scanmacro#1{% 8098\def\scanmacro#1{%
8151 \newlinechar`\^^M 8099 \newlinechar`\^^M
8152 \def\xeatspaces{\eatspaces}% 8100 % expand the expansion of \eatleadingcr twice to maybe remove a leading
8101 % newline (and \else and \fi tokens), then call \eatspaces on the result.
8102 \def\xeatspaces##1{%
8103 \E\E\E\E\E\E\E\eatspaces\E\E\E\E\E\E\E{\eatleadingcr##1%
8104 }}%
8105 \def\xempty##1{}%
8153 % 8106 %
8154 % Process the macro body under the current catcode regime. 8107 % Process the macro body under the current catcode regime.
8155 \scantokens{#1@comment}% 8108 \scantokens{#1@comment}%
@@ -8202,6 +8155,11 @@ might help (with 'rm \jobname.?? \jobname.??s')%
8202\unbrace{\gdef\trim@@@ #1 } #2@{#1} 8155\unbrace{\gdef\trim@@@ #1 } #2@{#1}
8203} 8156}
8204 8157
8158{\catcode`\^^M=\other%
8159\gdef\eatleadingcr#1{\if\noexpand#1\noexpand^^M\else\E#1\fi}}%
8160% Warning: this won't work for a delimited argument
8161% or for an empty argument
8162
8205% Trim a single trailing ^^M off a string. 8163% Trim a single trailing ^^M off a string.
8206{\catcode`\^^M=\other \catcode`\Q=3% 8164{\catcode`\^^M=\other \catcode`\Q=3%
8207\gdef\eatcr #1{\eatcra #1Q^^MQ}% 8165\gdef\eatcr #1{\eatcra #1Q^^MQ}%
@@ -8368,6 +8326,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
8368 \let\hash\relax 8326 \let\hash\relax
8369 % \hash is redefined to `#' later to get it into definitions 8327 % \hash is redefined to `#' later to get it into definitions
8370 \let\xeatspaces\relax 8328 \let\xeatspaces\relax
8329 \let\xempty\relax
8371 \parsemargdefxxx#1,;,% 8330 \parsemargdefxxx#1,;,%
8372 \ifnum\paramno<10\relax\else 8331 \ifnum\paramno<10\relax\else
8373 \paramno0\relax 8332 \paramno0\relax
@@ -8379,9 +8338,11 @@ might help (with 'rm \jobname.?? \jobname.??s')%
8379 \else \let\next=\parsemargdefxxx 8338 \else \let\next=\parsemargdefxxx
8380 \advance\paramno by 1 8339 \advance\paramno by 1
8381 \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname 8340 \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname
8382 {\xeatspaces{\hash\the\paramno}}% 8341 {\xeatspaces{\hash\the\paramno\noexpand\xempty{}}}%
8383 \edef\paramlist{\paramlist\hash\the\paramno,}% 8342 \edef\paramlist{\paramlist\hash\the\paramno,}%
8384 \fi\next} 8343 \fi\next}
8344% the \xempty{} is to give \eatleadingcr an argument in the case of an
8345% empty macro argument.
8385 8346
8386% \parsemacbody, \parsermacbody 8347% \parsemacbody, \parsermacbody
8387% 8348%
@@ -9107,20 +9068,22 @@ might help (with 'rm \jobname.?? \jobname.??s')%
9107 % output the `[mynode]' via the macro below so it can be overridden. 9068 % output the `[mynode]' via the macro below so it can be overridden.
9108 \xrefprintnodename\printedrefname 9069 \xrefprintnodename\printedrefname
9109 % 9070 %
9110 % But we always want a comma and a space: 9071 \expandafter\ifx\csname SETtxiomitxrefpg\endcsname\relax
9111 ,\space 9072 % But we always want a comma and a space:
9112 % 9073 ,\space
9113 % output the `page 3'. 9074 %
9114 \turnoffactive \putwordpage\tie\refx{#1-pg}{}% 9075 % output the `page 3'.
9115 % Add a , if xref followed by a space 9076 \turnoffactive \putwordpage\tie\refx{#1-pg}{}%
9116 \if\space\noexpand\tokenafterxref ,% 9077 % Add a , if xref followed by a space
9117 \else\ifx\ \tokenafterxref ,% @TAB 9078 \if\space\noexpand\tokenafterxref ,%
9118 \else\ifx\*\tokenafterxref ,% @* 9079 \else\ifx\ \tokenafterxref ,% @TAB
9119 \else\ifx\ \tokenafterxref ,% @SPACE 9080 \else\ifx\*\tokenafterxref ,% @*
9120 \else\ifx\ 9081 \else\ifx\ \tokenafterxref ,% @SPACE
9121 \tokenafterxref ,% @NL 9082 \else\ifx\
9122 \else\ifx\tie\tokenafterxref ,% @tie 9083 \tokenafterxref ,% @NL
9123 \fi\fi\fi\fi\fi\fi 9084 \else\ifx\tie\tokenafterxref ,% @tie
9085 \fi\fi\fi\fi\fi\fi
9086 \fi
9124 \fi\fi 9087 \fi\fi
9125 \fi 9088 \fi
9126 \endlink 9089 \endlink
@@ -9550,7 +9513,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
9550\def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup 9513\def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup
9551 \catcode`\^^M = 5 % in case we're inside an example 9514 \catcode`\^^M = 5 % in case we're inside an example
9552 \normalturnoffactive % allow _ et al. in names 9515 \normalturnoffactive % allow _ et al. in names
9553 \def\xprocessmacroarg{\eatspaces}% in case we are being used via a macro 9516 \makevalueexpandable
9554 % If the image is by itself, center it. 9517 % If the image is by itself, center it.
9555 \ifvmode 9518 \ifvmode
9556 \imagevmodetrue 9519 \imagevmodetrue
@@ -11603,7 +11566,7 @@ directory should work if nowhere else does.}
11603 \let> = \activegtr 11566 \let> = \activegtr
11604 \let~ = \activetilde 11567 \let~ = \activetilde
11605 \let^ = \activehat 11568 \let^ = \activehat
11606 \markupsetuplqdefault \markupsetuprqdefault 11569 \setregularquotes
11607 \let\b = \strong 11570 \let\b = \strong
11608 \let\i = \smartitalic 11571 \let\i = \smartitalic
11609 % in principle, all other definitions in \tex have to be undone too. 11572 % in principle, all other definitions in \tex have to be undone too.
@@ -11662,8 +11625,7 @@ directory should work if nowhere else does.}
11662 @let|=@normalverticalbar 11625 @let|=@normalverticalbar
11663 @let~=@normaltilde 11626 @let~=@normaltilde
11664 @let\=@ttbackslash 11627 @let\=@ttbackslash
11665 @markupsetuplqdefault 11628 @setregularquotes
11666 @markupsetuprqdefault
11667 @unsepspaces 11629 @unsepspaces
11668 } 11630 }
11669} 11631}
@@ -11756,8 +11718,7 @@ directory should work if nowhere else does.}
11756@c Do this last of all since we use ` in the previous @catcode assignments. 11718@c Do this last of all since we use ` in the previous @catcode assignments.
11757@catcode`@'=@active 11719@catcode`@'=@active
11758@catcode`@`=@active 11720@catcode`@`=@active
11759@markupsetuplqdefault 11721@setregularquotes
11760@markupsetuprqdefault
11761 11722
11762@c Local variables: 11723@c Local variables:
11763@c eval: (add-hook 'before-save-hook 'time-stamp) 11724@c eval: (add-hook 'before-save-hook 'time-stamp)
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 2c4b792cc21..5d89b065882 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -810,9 +810,10 @@ behavior.
810@cindex @option{sshx} method 810@cindex @option{sshx} method
811 811
812Works like @option{ssh} but without the extra authentication prompts. 812Works like @option{ssh} but without the extra authentication prompts.
813@option{sshx} uses @samp{ssh -t -t @var{host} -l @var{user} /bin/sh} 813@option{sshx} uses @samp{ssh -t -t -l @var{user} -o
814to open a connection with a ``standard'' login shell. It supports 814RemoteCommand='/bin/sh -i' @var{host}} to open a connection with a
815changing the remote login shell @command{/bin/sh}. 815``standard'' login shell. It supports changing the remote login shell
816@command{/bin/sh}.
816 817
817@strong{Note} that @option{sshx} does not bypass authentication 818@strong{Note} that @option{sshx} does not bypass authentication
818questions. For example, if the host key of the remote host is not 819questions. For example, if the host key of the remote host is not
@@ -935,9 +936,10 @@ This method supports the @samp{-p} argument.
935@cindex @command{ssh} (with @option{scpx} method) 936@cindex @command{ssh} (with @option{scpx} method)
936 937
937@option{scpx} is useful to avoid login shell questions. It is similar 938@option{scpx} is useful to avoid login shell questions. It is similar
938in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t 939in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t -l
939@var{host} -l @var{user} /bin/sh} to open a connection. It supports 940@var{user} -o RemoteCommand='/bin/sh -i' @var{host}} to open a
940changing the remote login shell @command{/bin/sh}. 941connection. It supports changing the remote login shell
942@command{/bin/sh}.
941 943
942@option{scpx} is useful for MS Windows users when @command{ssh} 944@option{scpx} is useful for MS Windows users when @command{ssh}
943triggers an error about allocating a pseudo tty. This happens due to 945triggers an error about allocating a pseudo tty. This happens due to
@@ -2220,7 +2222,10 @@ This uses also the settings in @code{tramp-sh-extra-args}.
2220@vindex RemoteCommand@r{, ssh option} 2222@vindex RemoteCommand@r{, ssh option}
2221@strong{Note}: If you use an @option{ssh}-based method for connection, 2223@strong{Note}: If you use an @option{ssh}-based method for connection,
2222do @emph{not} set the @option{RemoteCommand} option in your 2224do @emph{not} set the @option{RemoteCommand} option in your
2223@command{ssh} configuration, for example to @command{screen}. 2225@command{ssh} configuration, for example to @command{screen}. On the
2226other hand, some @option{ssh}-based methods, like @option{sshx} or
2227@option{scpx}, silently overwrite a @option{RemoteCommand} option of
2228the configuration file.
2224 2229
2225 2230
2226@subsection Other remote shell setup hints 2231@subsection Other remote shell setup hints
@@ -2369,8 +2374,7 @@ that can identify such questions using
2369@lisp 2374@lisp
2370@group 2375@group
2371(defconst my-tramp-prompt-regexp 2376(defconst my-tramp-prompt-regexp
2372 (concat (regexp-opt '("Enter the birth date of your mother:") t) 2377 "Enter the birth date of your mother:\\s-*"
2373 "\\s-*")
2374 "Regular expression matching my login prompt question.") 2378 "Regular expression matching my login prompt question.")
2375@end group 2379@end group
2376 2380
@@ -2389,6 +2393,11 @@ that can identify such questions using
2389@end group 2393@end group
2390@end lisp 2394@end lisp
2391 2395
2396The regular expressions used in @code{tramp-actions-before-shell} must
2397match the end of the connection buffer. Due to performance reasons,
2398this search starts at the end of the buffer, and it is limited to 256
2399characters backwards.
2400
2392 2401
2393@item Conflicting names for users and variables in @file{.profile} 2402@item Conflicting names for users and variables in @file{.profile}
2394 2403
@@ -3576,7 +3585,6 @@ Furthermore, this approach has the following limitations:
3576It works only for connection methods defined in @file{tramp-sh.el} and 3585It works only for connection methods defined in @file{tramp-sh.el} and
3577@file{tramp-adb.el}. 3586@file{tramp-adb.el}.
3578 3587
3579@vindex ControlMaster@r{, ssh option}
3580@item 3588@item
3581It does not support interactive user authentication. With 3589It does not support interactive user authentication. With
3582@option{ssh}-based methods, this can be avoided by using a password 3590@option{ssh}-based methods, this can be avoided by using a password
@@ -3584,6 +3592,10 @@ agent like @command{ssh-agent}, using public key authentication, or
3584using @option{ControlMaster} options. 3592using @option{ControlMaster} options.
3585 3593
3586@item 3594@item
3595It cannot be applied for @option{ssh}-based methods, which use the
3596@option{RemoteCommand} option.
3597
3598@item
3587It cannot be killed via @code{interrupt-process}. 3599It cannot be killed via @code{interrupt-process}.
3588 3600
3589@item 3601@item
@@ -3593,8 +3605,7 @@ It does not report the remote terminal name via @code{process-tty-name}.
3593It does not set process property @code{remote-pid}. 3605It does not set process property @code{remote-pid}.
3594 3606
3595@item 3607@item
3596It does not use @code{tramp-remote-path} and 3608It does not use @code{tramp-remote-path}.
3597@code{tramp-remote-process-environment}.
3598@end itemize 3609@end itemize
3599 3610
3600In order to gain even more performance, it is recommended to bind 3611In order to gain even more performance, it is recommended to bind
diff --git a/etc/HELLO b/etc/HELLO
index dec3a775afb..0cebb2bb7c2 100644
--- a/etc/HELLO
+++ b/etc/HELLO
@@ -30,20 +30,16 @@ Bengali (বাংলা) নমস্কার
30Braille ⠓⠑⠇⠇⠕ 30Braille ⠓⠑⠇⠇⠕
31Burmese (မြန်မာ) မင်္ဂလာပါ 31Burmese (မြန်မာ) မင်္ဂလာပါ
32C printf ("Hello, world!\n"); 32C printf ("Hello, world!\n");
33Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨁꨰ
33Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ 34Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ
34Comanche /kəˈmæntʃiː/ Haa marʉ́awe 35Comanche /kəˈmæntʃiː/ Haa marʉ́awe
35
36Cree (ᓀᐦᐃᔭᐍᐏᐣ) ᑕᓂᓯ / ᐙᒋᔮ 36Cree (ᓀᐦᐃᔭᐍᐏᐣ) ᑕᓂᓯ / ᐙᒋᔮ
37
38Czech (čeština) Dobrý den 37Czech (čeština) Dobrý den
39Danish (dansk) Hej / Goddag / Halløj 38Danish (dansk) Hej / Goddag / Halløj
40Dutch (Nederlands) Hallo / Dag 39Dutch (Nederlands) Hallo / Dag
41Efik /ˈɛfɪk/ Mɔkɔm 40Efik /ˈɛfɪk/ Mɔkɔm
42
43Egyptian Hieroglyphs (𓂋𓐰𓏤𓈖𓆎𓅓𓏏𓐰𓊖) 𓅓𓊵𓐰𓐷𓏏𓊪𓐸, 𓇍𓇋𓂻𓍘𓇋 41Egyptian Hieroglyphs (𓂋𓐰𓏤𓈖𓆎𓅓𓏏𓐰𓊖) 𓅓𓊵𓐰𓐷𓏏𓊪𓐸, 𓇍𓇋𓂻𓍘𓇋
44
45Emacs emacs --no-splash -f view-hello-file 42Emacs emacs --no-splash -f view-hello-file
46
47Emoji 👋 43Emoji 👋
48English /ˈɪŋɡlɪʃ/ Hello 44English /ˈɪŋɡlɪʃ/ Hello
49Esperanto Saluton (Eĥoŝanĝo ĉiuĵaŭde) 45Esperanto Saluton (Eĥoŝanĝo ĉiuĵaŭde)
@@ -59,7 +55,6 @@ Hebrew (עִבְרִית) שָׁלוֹם
59Hungarian (magyar) Szép jó napot! 55Hungarian (magyar) Szép jó napot!
60Hindi (हिंदी) नमस्ते / नमस्कार । 56Hindi (हिंदी) नमस्ते / नमस्कार ।
61Inuktitut (ᐃᓄᒃᑎᑐᑦ) ᐊᐃ 57Inuktitut (ᐃᓄᒃᑎᑐᑦ) ᐊᐃ
62
63Italian (italiano) Ciao / Buon giorno 58Italian (italiano) Ciao / Buon giorno
64Javanese (ꦧꦱꦗꦮꦶ) console.log("ꦲꦭꦺꦴ"); 59Javanese (ꦧꦱꦗꦮꦶ) console.log("ꦲꦭꦺꦴ");
65Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ 60Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ
@@ -67,7 +62,6 @@ Khmer (ភាសាខ្មែរ) ជំរាបសួរ
67Lao (ພາສາລາວ) ສະບາຍດີ / ຂໍໃຫ້ໂຊກດີ 62Lao (ພາສາລາວ) ສະບາຍດີ / ຂໍໃຫ້ໂຊກດີ
68Malayalam (മലയാളം) നമസ്കാരം 63Malayalam (മലയാളം) നമസ്കാരം
69Maldivian (ދިވެހި) އައްސަލާމު ޢަލައިކުމް / ކިހިނެހް؟ 64Maldivian (ދިވެހި) އައްސަލާމު ޢަލައިކުމް / ކިހިނެހް؟
70
71Maltese (il-Malti) Bonġu / Saħħa 65Maltese (il-Malti) Bonġu / Saħħa
72Mathematics ∀ p ∈ world • hello p □ 66Mathematics ∀ p ∈ world • hello p □
73Mongolian (монгол хэл) Сайн байна уу? 67Mongolian (монгол хэл) Сайн байна уу?
@@ -83,7 +77,6 @@ Swedish (svenska) Hej / Goddag / Hallå
83Tamil (தமிழ்) வணக்கம் 77Tamil (தமிழ்) வணக்கம்
84Telugu (తెలుగు) నమస్కారం 78Telugu (తెలుగు) నమస్కారం
85TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ 79TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ
86
87Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ 80Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ
88Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎ 81Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎
89Tigrigna (ትግርኛ) ሰላማት 82Tigrigna (ትግርኛ) ሰላማት
@@ -97,7 +90,6 @@ Vietnamese (tiếng Việt) Chào bạn
97</x-charset><x-charset><param>chinese-gb2312</param>Chinese (中文,普通话,汉语) 你好 90</x-charset><x-charset><param>chinese-gb2312</param>Chinese (中文,普通话,汉语) 你好
98</x-charset><x-charset><param>chinese-big5-1</param>Cantonese (粵語,廣東話) 早晨, 你好 91</x-charset><x-charset><param>chinese-big5-1</param>Cantonese (粵語,廣東話) 早晨, 你好
99</x-charset><x-charset><param>korean-ksc5601</param>Korean (한글) 안녕하세요 / 안녕하십니까 92</x-charset><x-charset><param>korean-ksc5601</param>Korean (한글) 안녕하세요 / 안녕하십니까
100
101</x-charset> 93</x-charset>
102 94
103 95
diff --git a/etc/NEWS b/etc/NEWS
index 19ad35032a2..6b1cdaaf005 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -326,6 +326,16 @@ the buffer cycles the whole buffer between "only top-level headings",
326 326
327* Changes in Specialized Modes and Packages in Emacs 28.1 327* Changes in Specialized Modes and Packages in Emacs 28.1
328 328
329** 'blink-cursor-mode' is now enabled by default regardless of the UI.
330It used to be enabled when Emacs is started in GUI mode but not when started
331in text mode. The cursor still only actually blinks in GUI frames.
332
333** pcase
334+++
335*** The `pred` pattern can now take the form (pred (not FUN)).
336This is like (pred (lambda (x) (not (FUN x)))) but results
337in better code.
338
329+++ 339+++
330** profiler.el 340** profiler.el
331The results displayed by 'profiler-report' now have the usage figures 341The results displayed by 'profiler-report' now have the usage figures
@@ -346,6 +356,12 @@ When emacsclient connects, Emacs will (by default) output a message
346about how to exit the client frame. If 'server-client-instructions' 356about how to exit the client frame. If 'server-client-instructions'
347is set to nil, this message is inhibited. 357is set to nil, this message is inhibited.
348 358
359** Perl mode
360
361---
362*** New face 'perl-non-scalar-variable'.
363This is used to fontify non-scalar variables.
364
349** Python mode 365** Python mode
350 366
351*** 'python-shell-interpreter' now defaults to python3 on systems with python3. 367*** 'python-shell-interpreter' now defaults to python3 on systems with python3.
@@ -705,9 +721,11 @@ not.
705--- 721---
706*** Respect 'message-forward-ignored-headers' more. 722*** Respect 'message-forward-ignored-headers' more.
707Previously, this variable would not be consulted if 723Previously, this variable would not be consulted if
708'message-forward-show-mml' was nil. It's now always used, except if 724'message-forward-show-mml' was nil and forwarding as MIME.
709'message-forward-show-mml' is 'best', and we're forwarding an 725
710encrypted/signed message. 726+++
727*** New user option 'message-forward-included-mime-headers'.
728This is used when forwarding messages as MIME, but not using MML.
711 729
712+++ 730+++
713*** Message now supports the OpenPGP header. 731*** Message now supports the OpenPGP header.
@@ -821,6 +839,10 @@ so e.g. like 'C-x 8 [' inserts a left single quotation mark,
821Added a new Mozhi scheme. The inapplicable ITRANS scheme is now 839Added a new Mozhi scheme. The inapplicable ITRANS scheme is now
822deprecated. Errors in the Inscript method were corrected. 840deprecated. Errors in the Inscript method were corrected.
823 841
842---
843*** New input method 'cham'.
844There's also a Cham greeting in 'etc/HELLO'.
845
824** Ispell 846** Ispell
825 847
826+++ 848+++
@@ -1538,9 +1560,28 @@ buttons in it.
1538This function takes a string and returns a string propertized in a way 1560This function takes a string and returns a string propertized in a way
1539that makes it a valid button. 1561that makes it a valid button.
1540 1562
1563** subr-x
1564+++
1565*** A number of new string manipulation functions have been added.
1566'string-clean-whitespace', 'string-fill', 'string-limit',
1567'string-lines', 'string-pad' and 'string-chop-newline'.
1568
1569*** New macro `named-let` that provides Scheme's "named let" looping construct
1570
1571** thingatpt
1572
1573+++
1574*** New variable 'thing-at-point-provider-alist'.
1575This allows mode-specific alterations to how `thing-at-point' works.
1541 1576
1542** Miscellaneous 1577** Miscellaneous
1543 1578
1579---
1580*** New user option 'remember-diary-regexp'.
1581
1582---
1583*** New user option 'remember-text-format-function'.
1584
1544*** New function 'buffer-line-statistics'. 1585*** New function 'buffer-line-statistics'.
1545This function returns some statistics about the line lengths in a buffer. 1586This function returns some statistics about the line lengths in a buffer.
1546 1587
@@ -1572,11 +1613,6 @@ length to a number).
1572This can be set to nil to inhibit hiding passwords in ".authinfo" files. 1613This can be set to nil to inhibit hiding passwords in ".authinfo" files.
1573 1614
1574+++ 1615+++
1575*** A number of new string manipulation functions have been added.
1576'string-clean-whitespace', 'string-fill', 'string-limit',
1577'string-lines', 'string-pad' and 'string-chop-newline'.
1578
1579+++
1580*** New variable 'current-minibuffer-command'. 1616*** New variable 'current-minibuffer-command'.
1581This is like 'this-command', but it is bound recursively when entering 1617This is like 'this-command', but it is bound recursively when entering
1582the minibuffer. 1618the minibuffer.
diff --git a/etc/NEWS.19 b/etc/NEWS.19
index 43235e0e154..f2cef62971b 100644
--- a/etc/NEWS.19
+++ b/etc/NEWS.19
@@ -2824,6 +2824,8 @@ the text of the region according to the new value.
2824the fill-column has been exceeded; the function can determine on its 2824the fill-column has been exceeded; the function can determine on its
2825own whether filling (or justification) is necessary. 2825own whether filling (or justification) is necessary.
2826 2826
2827**** New helper function 'indent-line-to'
2828
2827** Processes 2829** Processes
2828 2830
2829*** process-tty-name is a new function that returns the name of the 2831*** process-tty-name is a new function that returns the name of the
diff --git a/lib/_Noreturn.h b/lib/_Noreturn.h
index 38afe1d5672..fb718bc0691 100644
--- a/lib/_Noreturn.h
+++ b/lib/_Noreturn.h
@@ -26,14 +26,16 @@
26 AIX system header files and several gnulib header files use precisely 26 AIX system header files and several gnulib header files use precisely
27 this syntax with 'extern'. */ 27 this syntax with 'extern'. */
28# define _Noreturn [[noreturn]] 28# define _Noreturn [[noreturn]]
29# elif ((!defined __cplusplus || defined __clang__) \ 29# elif ((!defined __cplusplus || defined __clang__) \
30 && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ 30 && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \
31 || 4 < __GNUC__ + (7 <= __GNUC_MINOR__) \ 31 || (!defined __STRICT_ANSI__ \
32 || (defined __apple_build_version__ \ 32 && (__4 < __GNUC__ + (7 <= __GNUC_MINOR__) \
33 ? 6000000 <= __apple_build_version__ \ 33 || (defined __apple_build_version__ \
34 : 3 < __clang_major__ + (5 <= __clang_minor__)))) 34 ? 6000000 <= __apple_build_version__ \
35 : 3 < __clang_major__ + (5 <= __clang_minor__))))))
35 /* _Noreturn works as-is. */ 36 /* _Noreturn works as-is. */
36# elif 2 < __GNUC__ + (8 <= __GNUC_MINOR__) || 0x5110 <= __SUNPRO_C 37# elif (2 < __GNUC__ + (8 <= __GNUC_MINOR__) || defined __clang__ \
38 || 0x5110 <= __SUNPRO_C)
37# define _Noreturn __attribute__ ((__noreturn__)) 39# define _Noreturn __attribute__ ((__noreturn__))
38# elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0) 40# elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0)
39# define _Noreturn __declspec (noreturn) 41# define _Noreturn __declspec (noreturn)
diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c
index b6dc3a447ab..b7dba08994d 100644
--- a/lib/canonicalize-lgpl.c
+++ b/lib/canonicalize-lgpl.c
@@ -85,10 +85,6 @@
85# define IF_LINT(Code) /* empty */ 85# define IF_LINT(Code) /* empty */
86#endif 86#endif
87 87
88/* True if adding two valid object sizes might overflow idx_t.
89 As a practical matter, this cannot happen on 64-bit machines. */
90enum { NARROW_ADDRESSES = IDX_MAX >> 31 >> 31 == 0 };
91
92#ifndef DOUBLE_SLASH_IS_DISTINCT_ROOT 88#ifndef DOUBLE_SLASH_IS_DISTINCT_ROOT
93# define DOUBLE_SLASH_IS_DISTINCT_ROOT false 89# define DOUBLE_SLASH_IS_DISTINCT_ROOT false
94#endif 90#endif
@@ -145,11 +141,11 @@ suffix_requires_dir_check (char const *end)
145 macOS 10.13 <https://bugs.gnu.org/30350>, and should also work on 141 macOS 10.13 <https://bugs.gnu.org/30350>, and should also work on
146 platforms like AIX 7.2 that need at least "/.". */ 142 platforms like AIX 7.2 that need at least "/.". */
147 143
148#if defined _LIBC || defined LSTAT_FOLLOWS_SLASHED_SYMLINK 144# if defined _LIBC || defined LSTAT_FOLLOWS_SLASHED_SYMLINK
149static char const dir_suffix[] = "/"; 145static char const dir_suffix[] = "/";
150#else 146# else
151static char const dir_suffix[] = "/./"; 147static char const dir_suffix[] = "/./";
152#endif 148# endif
153 149
154/* Return true if DIR is a searchable dir, false (setting errno) otherwise. 150/* Return true if DIR is a searchable dir, false (setting errno) otherwise.
155 DIREND points to the NUL byte at the end of the DIR string. 151 DIREND points to the NUL byte at the end of the DIR string.
@@ -191,13 +187,13 @@ get_path_max (void)
191 to pacify GCC is known; even an explicit #pragma does not pacify GCC. 187 to pacify GCC is known; even an explicit #pragma does not pacify GCC.
192 When the GCC bug is fixed this workaround should be limited to the 188 When the GCC bug is fixed this workaround should be limited to the
193 broken GCC versions. */ 189 broken GCC versions. */
194#if __GNUC_PREREQ (10, 1) 190# if __GNUC_PREREQ (10, 1)
195# if defined GCC_LINT || defined lint 191# if defined GCC_LINT || defined lint
196__attribute__ ((__noinline__)) 192__attribute__ ((__noinline__))
197# elif __OPTIMIZE__ && !__NO_INLINE__ 193# elif __OPTIMIZE__ && !__NO_INLINE__
198# define GCC_BOGUS_WRETURN_LOCAL_ADDR 194# define GCC_BOGUS_WRETURN_LOCAL_ADDR
195# endif
199# endif 196# endif
200#endif
201static char * 197static char *
202realpath_stk (const char *name, char *resolved, 198realpath_stk (const char *name, char *resolved,
203 struct scratch_buffer *rname_buf) 199 struct scratch_buffer *rname_buf)
@@ -343,7 +339,7 @@ realpath_stk (const char *name, char *resolved,
343 if (end_in_extra_buffer) 339 if (end_in_extra_buffer)
344 end_idx = end - extra_buf; 340 end_idx = end - extra_buf;
345 size_t len = strlen (end); 341 size_t len = strlen (end);
346 if (NARROW_ADDRESSES && INT_ADD_OVERFLOW (len, n)) 342 if (INT_ADD_OVERFLOW (len, n))
347 { 343 {
348 __set_errno (ENOMEM); 344 __set_errno (ENOMEM);
349 goto error_nomem; 345 goto error_nomem;
@@ -443,7 +439,8 @@ __realpath (const char *name, char *resolved)
443} 439}
444libc_hidden_def (__realpath) 440libc_hidden_def (__realpath)
445versioned_symbol (libc, __realpath, realpath, GLIBC_2_3); 441versioned_symbol (libc, __realpath, realpath, GLIBC_2_3);
446#endif /* !FUNC_REALPATH_WORKS || defined _LIBC */ 442
443#endif /* defined _LIBC || !FUNC_REALPATH_WORKS */
447 444
448 445
449#if SHLIB_COMPAT(libc, GLIBC_2_0, GLIBC_2_3) 446#if SHLIB_COMPAT(libc, GLIBC_2_0, GLIBC_2_3)
diff --git a/lib/cdefs.h b/lib/cdefs.h
index 2a3dc9666b9..17a0919cd83 100644
--- a/lib/cdefs.h
+++ b/lib/cdefs.h
@@ -25,7 +25,7 @@
25 25
26/* The GNU libc does not support any K&R compilers or the traditional mode 26/* The GNU libc does not support any K&R compilers or the traditional mode
27 of ISO C compilers anymore. Check for some of the combinations not 27 of ISO C compilers anymore. Check for some of the combinations not
28 anymore supported. */ 28 supported anymore. */
29#if defined __GNUC__ && !defined __STDC__ 29#if defined __GNUC__ && !defined __STDC__
30# error "You need a ISO C conforming compiler to use the glibc headers" 30# error "You need a ISO C conforming compiler to use the glibc headers"
31#endif 31#endif
@@ -34,31 +34,26 @@
34#undef __P 34#undef __P
35#undef __PMT 35#undef __PMT
36 36
37/* Compilers that are not clang may object to 37/* Compilers that lack __has_attribute may object to
38 #if defined __clang__ && __has_attribute(...) 38 #if defined __has_attribute && __has_attribute (...)
39 even though they do not need to evaluate the right-hand side of the &&. */ 39 even though they do not need to evaluate the right-hand side of the &&.
40#if defined __clang__ && defined __has_attribute 40 Similarly for __has_builtin, etc. */
41# define __glibc_clang_has_attribute(name) __has_attribute (name) 41#if (defined __has_attribute \
42 && (!defined __clang_minor__ \
43 || 3 < __clang_major__ + (5 <= __clang_minor__)))
44# define __glibc_has_attribute(attr) __has_attribute (attr)
42#else 45#else
43# define __glibc_clang_has_attribute(name) 0 46# define __glibc_has_attribute(attr) 0
44#endif 47#endif
45 48#ifdef __has_builtin
46/* Compilers that are not clang may object to 49# define __glibc_has_builtin(name) __has_builtin (name)
47 #if defined __clang__ && __has_builtin(...)
48 even though they do not need to evaluate the right-hand side of the &&. */
49#if defined __clang__ && defined __has_builtin
50# define __glibc_clang_has_builtin(name) __has_builtin (name)
51#else 50#else
52# define __glibc_clang_has_builtin(name) 0 51# define __glibc_has_builtin(name) 0
53#endif 52#endif
54 53#ifdef __has_extension
55/* Compilers that are not clang may object to 54# define __glibc_has_extension(ext) __has_extension (ext)
56 #if defined __clang__ && __has_extension(...)
57 even though they do not need to evaluate the right-hand side of the &&. */
58#if defined __clang__ && defined __has_extension
59# define __glibc_clang_has_extension(ext) __has_extension (ext)
60#else 55#else
61# define __glibc_clang_has_extension(ext) 0 56# define __glibc_has_extension(ext) 0
62#endif 57#endif
63 58
64#if defined __GNUC__ || defined __clang__ 59#if defined __GNUC__ || defined __clang__
@@ -74,22 +69,26 @@
74# endif 69# endif
75 70
76/* GCC can always grok prototypes. For C++ programs we add throw() 71/* GCC can always grok prototypes. For C++ programs we add throw()
77 to help it optimize the function calls. But this works only with 72 to help it optimize the function calls. But this only works with
78 gcc 2.8.x and egcs. For gcc 3.4 and up we even mark C functions 73 gcc 2.8.x and egcs. For gcc 3.4 and up we even mark C functions
79 as non-throwing using a function attribute since programs can use 74 as non-throwing using a function attribute since programs can use
80 the -fexceptions options for C code as well. */ 75 the -fexceptions options for C code as well. */
81# if !defined __cplusplus \ 76# if !defined __cplusplus \
82 && (__GNUC_PREREQ (3, 4) || __glibc_clang_has_attribute (__nothrow__)) 77 && (__GNUC_PREREQ (3, 4) || __glibc_has_attribute (__nothrow__))
83# define __THROW __attribute__ ((__nothrow__ __LEAF)) 78# define __THROW __attribute__ ((__nothrow__ __LEAF))
84# define __THROWNL __attribute__ ((__nothrow__)) 79# define __THROWNL __attribute__ ((__nothrow__))
85# define __NTH(fct) __attribute__ ((__nothrow__ __LEAF)) fct 80# define __NTH(fct) __attribute__ ((__nothrow__ __LEAF)) fct
86# define __NTHNL(fct) __attribute__ ((__nothrow__)) fct 81# define __NTHNL(fct) __attribute__ ((__nothrow__)) fct
87# else 82# else
88# if defined __cplusplus && (__GNUC_PREREQ (2,8) || __clang_major >= 4) 83# if defined __cplusplus && (__GNUC_PREREQ (2,8) || __clang_major >= 4)
89# define __THROW throw () 84# if __cplusplus >= 201103L
90# define __THROWNL throw () 85# define __THROW noexcept (true)
91# define __NTH(fct) __LEAF_ATTR fct throw () 86# else
92# define __NTHNL(fct) fct throw () 87# define __THROW throw ()
88# endif
89# define __THROWNL __THROW
90# define __NTH(fct) __LEAF_ATTR fct __THROW
91# define __NTHNL(fct) fct __THROW
93# else 92# else
94# define __THROW 93# define __THROW
95# define __THROWNL 94# define __THROWNL
@@ -142,24 +141,20 @@
142#define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1) 141#define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1)
143#define __bos0(ptr) __builtin_object_size (ptr, 0) 142#define __bos0(ptr) __builtin_object_size (ptr, 0)
144 143
144/* Use __builtin_dynamic_object_size at _FORTIFY_SOURCE=3 when available. */
145#if __USE_FORTIFY_LEVEL == 3 && __glibc_clang_prereq (9, 0)
146# define __glibc_objsize0(__o) __builtin_dynamic_object_size (__o, 0)
147# define __glibc_objsize(__o) __builtin_dynamic_object_size (__o, 1)
148#else
149# define __glibc_objsize0(__o) __bos0 (__o)
150# define __glibc_objsize(__o) __bos (__o)
151#endif
152
145#if __GNUC_PREREQ (4,3) 153#if __GNUC_PREREQ (4,3)
146# define __warndecl(name, msg) \
147 extern void name (void) __attribute__((__warning__ (msg)))
148# define __warnattr(msg) __attribute__((__warning__ (msg))) 154# define __warnattr(msg) __attribute__((__warning__ (msg)))
149# define __errordecl(name, msg) \ 155# define __errordecl(name, msg) \
150 extern void name (void) __attribute__((__error__ (msg))) 156 extern void name (void) __attribute__((__error__ (msg)))
151#elif __glibc_clang_has_attribute (__diagnose_if__) && 0
152/* These definitions are not enabled, because they produce bogus warnings
153 in the glibc Fortify functions. These functions are written in a style
154 that works with GCC. In order to work with clang, these functions would
155 need to be modified. */
156# define __warndecl(name, msg) \
157 extern void name (void) __attribute__((__diagnose_if__ (1, msg, "warning")))
158# define __warnattr(msg) __attribute__((__diagnose_if__ (1, msg, "warning")))
159# define __errordecl(name, msg) \
160 extern void name (void) __attribute__((__diagnose_if__ (1, msg, "error")))
161#else 157#else
162# define __warndecl(name, msg) extern void name (void)
163# define __warnattr(msg) 158# define __warnattr(msg)
164# define __errordecl(name, msg) extern void name (void) 159# define __errordecl(name, msg) extern void name (void)
165#endif 160#endif
@@ -233,7 +228,7 @@
233/* At some point during the gcc 2.96 development the `malloc' attribute 228/* At some point during the gcc 2.96 development the `malloc' attribute
234 for functions was introduced. We don't want to use it unconditionally 229 for functions was introduced. We don't want to use it unconditionally
235 (although this would be possible) since it generates warnings. */ 230 (although this would be possible) since it generates warnings. */
236#if __GNUC_PREREQ (2,96) || __glibc_clang_has_attribute (__malloc__) 231#if __GNUC_PREREQ (2,96) || __glibc_has_attribute (__malloc__)
237# define __attribute_malloc__ __attribute__ ((__malloc__)) 232# define __attribute_malloc__ __attribute__ ((__malloc__))
238#else 233#else
239# define __attribute_malloc__ /* Ignore */ 234# define __attribute_malloc__ /* Ignore */
@@ -251,23 +246,31 @@
251/* At some point during the gcc 2.96 development the `pure' attribute 246/* At some point during the gcc 2.96 development the `pure' attribute
252 for functions was introduced. We don't want to use it unconditionally 247 for functions was introduced. We don't want to use it unconditionally
253 (although this would be possible) since it generates warnings. */ 248 (although this would be possible) since it generates warnings. */
254#if __GNUC_PREREQ (2,96) || __glibc_clang_has_attribute (__pure__) 249#if __GNUC_PREREQ (2,96) || __glibc_has_attribute (__pure__)
255# define __attribute_pure__ __attribute__ ((__pure__)) 250# define __attribute_pure__ __attribute__ ((__pure__))
256#else 251#else
257# define __attribute_pure__ /* Ignore */ 252# define __attribute_pure__ /* Ignore */
258#endif 253#endif
259 254
260/* This declaration tells the compiler that the value is constant. */ 255/* This declaration tells the compiler that the value is constant. */
261#if __GNUC_PREREQ (2,5) || __glibc_clang_has_attribute (__const__) 256#if __GNUC_PREREQ (2,5) || __glibc_has_attribute (__const__)
262# define __attribute_const__ __attribute__ ((__const__)) 257# define __attribute_const__ __attribute__ ((__const__))
263#else 258#else
264# define __attribute_const__ /* Ignore */ 259# define __attribute_const__ /* Ignore */
265#endif 260#endif
266 261
262#if defined __STDC_VERSION__ && 201710L < __STDC_VERSION__
263# define __attribute_maybe_unused__ [[__maybe_unused__]]
264#elif __GNUC_PREREQ (2,7) || __glibc_has_attribute (__unused__)
265# define __attribute_maybe_unused__ __attribute__ ((__unused__))
266#else
267# define __attribute_maybe_unused__ /* Ignore */
268#endif
269
267/* At some point during the gcc 3.1 development the `used' attribute 270/* At some point during the gcc 3.1 development the `used' attribute
268 for functions was introduced. We don't want to use it unconditionally 271 for functions was introduced. We don't want to use it unconditionally
269 (although this would be possible) since it generates warnings. */ 272 (although this would be possible) since it generates warnings. */
270#if __GNUC_PREREQ (3,1) || __glibc_clang_has_attribute (__used__) 273#if __GNUC_PREREQ (3,1) || __glibc_has_attribute (__used__)
271# define __attribute_used__ __attribute__ ((__used__)) 274# define __attribute_used__ __attribute__ ((__used__))
272# define __attribute_noinline__ __attribute__ ((__noinline__)) 275# define __attribute_noinline__ __attribute__ ((__noinline__))
273#else 276#else
@@ -276,7 +279,7 @@
276#endif 279#endif
277 280
278/* Since version 3.2, gcc allows marking deprecated functions. */ 281/* Since version 3.2, gcc allows marking deprecated functions. */
279#if __GNUC_PREREQ (3,2) || __glibc_clang_has_attribute (__deprecated__) 282#if __GNUC_PREREQ (3,2) || __glibc_has_attribute (__deprecated__)
280# define __attribute_deprecated__ __attribute__ ((__deprecated__)) 283# define __attribute_deprecated__ __attribute__ ((__deprecated__))
281#else 284#else
282# define __attribute_deprecated__ /* Ignore */ 285# define __attribute_deprecated__ /* Ignore */
@@ -285,8 +288,8 @@
285/* Since version 4.5, gcc also allows one to specify the message printed 288/* Since version 4.5, gcc also allows one to specify the message printed
286 when a deprecated function is used. clang claims to be gcc 4.2, but 289 when a deprecated function is used. clang claims to be gcc 4.2, but
287 may also support this feature. */ 290 may also support this feature. */
288#if __GNUC_PREREQ (4,5) || \ 291#if __GNUC_PREREQ (4,5) \
289 __glibc_clang_has_extension (__attribute_deprecated_with_message__) 292 || __glibc_has_extension (__attribute_deprecated_with_message__)
290# define __attribute_deprecated_msg__(msg) \ 293# define __attribute_deprecated_msg__(msg) \
291 __attribute__ ((__deprecated__ (msg))) 294 __attribute__ ((__deprecated__ (msg)))
292#else 295#else
@@ -299,7 +302,7 @@
299 If several `format_arg' attributes are given for the same function, in 302 If several `format_arg' attributes are given for the same function, in
300 gcc-3.0 and older, all but the last one are ignored. In newer gccs, 303 gcc-3.0 and older, all but the last one are ignored. In newer gccs,
301 all designated arguments are considered. */ 304 all designated arguments are considered. */
302#if __GNUC_PREREQ (2,8) || __glibc_clang_has_attribute (__format_arg__) 305#if __GNUC_PREREQ (2,8) || __glibc_has_attribute (__format_arg__)
303# define __attribute_format_arg__(x) __attribute__ ((__format_arg__ (x))) 306# define __attribute_format_arg__(x) __attribute__ ((__format_arg__ (x)))
304#else 307#else
305# define __attribute_format_arg__(x) /* Ignore */ 308# define __attribute_format_arg__(x) /* Ignore */
@@ -309,7 +312,7 @@
309 attribute for functions was introduced. We don't want to use it 312 attribute for functions was introduced. We don't want to use it
310 unconditionally (although this would be possible) since it 313 unconditionally (although this would be possible) since it
311 generates warnings. */ 314 generates warnings. */
312#if __GNUC_PREREQ (2,97) || __glibc_clang_has_attribute (__format__) 315#if __GNUC_PREREQ (2,97) || __glibc_has_attribute (__format__)
313# define __attribute_format_strfmon__(a,b) \ 316# define __attribute_format_strfmon__(a,b) \
314 __attribute__ ((__format__ (__strfmon__, a, b))) 317 __attribute__ ((__format__ (__strfmon__, a, b)))
315#else 318#else
@@ -317,19 +320,21 @@
317#endif 320#endif
318 321
319/* The nonnull function attribute marks pointer parameters that 322/* The nonnull function attribute marks pointer parameters that
320 must not be NULL. Do not define __nonnull if it is already defined, 323 must not be NULL. */
321 for portability when this file is used in Gnulib. */
322#ifndef __nonnull 324#ifndef __nonnull
323# if __GNUC_PREREQ (3,3) || __glibc_clang_has_attribute (__nonnull__) 325# if __GNUC_PREREQ (3,3) || __glibc_has_attribute (__nonnull__)
324# define __nonnull(params) __attribute__ ((__nonnull__ params)) 326# define __nonnull(params) __attribute__ ((__nonnull__ params))
325# else 327# else
326# define __nonnull(params) 328# define __nonnull(params)
327# endif 329# endif
330#elif !defined __GLIBC__
331# undef __nonnull
332# define __nonnull(params) _GL_ATTRIBUTE_NONNULL (params)
328#endif 333#endif
329 334
330/* If fortification mode, we warn about unused results of certain 335/* If fortification mode, we warn about unused results of certain
331 function calls which can lead to problems. */ 336 function calls which can lead to problems. */
332#if __GNUC_PREREQ (3,4) || __glibc_clang_has_attribute (__warn_unused_result__) 337#if __GNUC_PREREQ (3,4) || __glibc_has_attribute (__warn_unused_result__)
333# define __attribute_warn_unused_result__ \ 338# define __attribute_warn_unused_result__ \
334 __attribute__ ((__warn_unused_result__)) 339 __attribute__ ((__warn_unused_result__))
335# if defined __USE_FORTIFY_LEVEL && __USE_FORTIFY_LEVEL > 0 340# if defined __USE_FORTIFY_LEVEL && __USE_FORTIFY_LEVEL > 0
@@ -343,7 +348,7 @@
343#endif 348#endif
344 349
345/* Forces a function to be always inlined. */ 350/* Forces a function to be always inlined. */
346#if __GNUC_PREREQ (3,2) || __glibc_clang_has_attribute (__always_inline__) 351#if __GNUC_PREREQ (3,2) || __glibc_has_attribute (__always_inline__)
347/* The Linux kernel defines __always_inline in stddef.h (283d7573), and 352/* The Linux kernel defines __always_inline in stddef.h (283d7573), and
348 it conflicts with this definition. Therefore undefine it first to 353 it conflicts with this definition. Therefore undefine it first to
349 allow either header to be included first. */ 354 allow either header to be included first. */
@@ -356,7 +361,7 @@
356 361
357/* Associate error messages with the source location of the call site rather 362/* Associate error messages with the source location of the call site rather
358 than with the source location inside the function. */ 363 than with the source location inside the function. */
359#if __GNUC_PREREQ (4,3) || __glibc_clang_has_attribute (__artificial__) 364#if __GNUC_PREREQ (4,3) || __glibc_has_attribute (__artificial__)
360# define __attribute_artificial__ __attribute__ ((__artificial__)) 365# define __attribute_artificial__ __attribute__ ((__artificial__))
361#else 366#else
362# define __attribute_artificial__ /* Ignore */ 367# define __attribute_artificial__ /* Ignore */
@@ -433,7 +438,7 @@
433# endif 438# endif
434#endif 439#endif
435 440
436#if (__GNUC__ >= 3) || __glibc_clang_has_builtin (__builtin_expect) 441#if (__GNUC__ >= 3) || __glibc_has_builtin (__builtin_expect)
437# define __glibc_unlikely(cond) __builtin_expect ((cond), 0) 442# define __glibc_unlikely(cond) __builtin_expect ((cond), 0)
438# define __glibc_likely(cond) __builtin_expect ((cond), 1) 443# define __glibc_likely(cond) __builtin_expect ((cond), 1)
439#else 444#else
@@ -441,12 +446,6 @@
441# define __glibc_likely(cond) (cond) 446# define __glibc_likely(cond) (cond)
442#endif 447#endif
443 448
444#ifdef __has_attribute
445# define __glibc_has_attribute(attr) __has_attribute (attr)
446#else
447# define __glibc_has_attribute(attr) 0
448#endif
449
450#if (!defined _Noreturn \ 449#if (!defined _Noreturn \
451 && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \ 450 && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \
452 && !(__GNUC_PREREQ (4,7) \ 451 && !(__GNUC_PREREQ (4,7) \
@@ -467,6 +466,16 @@
467# define __attribute_nonstring__ 466# define __attribute_nonstring__
468#endif 467#endif
469 468
469/* Undefine (also defined in libc-symbols.h). */
470#undef __attribute_copy__
471#if __GNUC_PREREQ (9, 0)
472/* Copies attributes from the declaration or type referenced by
473 the argument. */
474# define __attribute_copy__(arg) __attribute__ ((__copy__ (arg)))
475#else
476# define __attribute_copy__(arg)
477#endif
478
470#if (!defined _Static_assert && !defined __cplusplus \ 479#if (!defined _Static_assert && !defined __cplusplus \
471 && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \ 480 && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \
472 && (!(__GNUC_PREREQ (4, 6) || __clang_major__ >= 4) \ 481 && (!(__GNUC_PREREQ (4, 6) || __clang_major__ >= 4) \
@@ -483,7 +492,37 @@
483# include <bits/long-double.h> 492# include <bits/long-double.h>
484#endif 493#endif
485 494
486#if defined __LONG_DOUBLE_MATH_OPTIONAL && defined __NO_LONG_DOUBLE_MATH 495#if __LDOUBLE_REDIRECTS_TO_FLOAT128_ABI == 1
496# ifdef __REDIRECT
497
498/* Alias name defined automatically. */
499# define __LDBL_REDIR(name, proto) ... unused__ldbl_redir
500# define __LDBL_REDIR_DECL(name) \
501 extern __typeof (name) name __asm (__ASMNAME ("__" #name "ieee128"));
502
503/* Alias name defined automatically, with leading underscores. */
504# define __LDBL_REDIR2_DECL(name) \
505 extern __typeof (__##name) __##name \
506 __asm (__ASMNAME ("__" #name "ieee128"));
507
508/* Alias name defined manually. */
509# define __LDBL_REDIR1(name, proto, alias) ... unused__ldbl_redir1
510# define __LDBL_REDIR1_DECL(name, alias) \
511 extern __typeof (name) name __asm (__ASMNAME (#alias));
512
513# define __LDBL_REDIR1_NTH(name, proto, alias) \
514 __REDIRECT_NTH (name, proto, alias)
515# define __REDIRECT_NTH_LDBL(name, proto, alias) \
516 __LDBL_REDIR1_NTH (name, proto, __##alias##ieee128)
517
518/* Unused. */
519# define __REDIRECT_LDBL(name, proto, alias) ... unused__redirect_ldbl
520# define __LDBL_REDIR_NTH(name, proto) ... unused__ldbl_redir_nth
521
522# else
523_Static_assert (0, "IEEE 128-bits long double requires redirection on this platform");
524# endif
525#elif defined __LONG_DOUBLE_MATH_OPTIONAL && defined __NO_LONG_DOUBLE_MATH
487# define __LDBL_COMPAT 1 526# define __LDBL_COMPAT 1
488# ifdef __REDIRECT 527# ifdef __REDIRECT
489# define __LDBL_REDIR1(name, proto, alias) __REDIRECT (name, proto, alias) 528# define __LDBL_REDIR1(name, proto, alias) __REDIRECT (name, proto, alias)
@@ -492,6 +531,8 @@
492# define __LDBL_REDIR1_NTH(name, proto, alias) __REDIRECT_NTH (name, proto, alias) 531# define __LDBL_REDIR1_NTH(name, proto, alias) __REDIRECT_NTH (name, proto, alias)
493# define __LDBL_REDIR_NTH(name, proto) \ 532# define __LDBL_REDIR_NTH(name, proto) \
494 __LDBL_REDIR1_NTH (name, proto, __nldbl_##name) 533 __LDBL_REDIR1_NTH (name, proto, __nldbl_##name)
534# define __LDBL_REDIR2_DECL(name) \
535 extern __typeof (__##name) __##name __asm (__ASMNAME ("__nldbl___" #name));
495# define __LDBL_REDIR1_DECL(name, alias) \ 536# define __LDBL_REDIR1_DECL(name, alias) \
496 extern __typeof (name) name __asm (__ASMNAME (#alias)); 537 extern __typeof (name) name __asm (__ASMNAME (#alias));
497# define __LDBL_REDIR_DECL(name) \ 538# define __LDBL_REDIR_DECL(name) \
@@ -502,11 +543,13 @@
502 __LDBL_REDIR1_NTH (name, proto, __nldbl_##alias) 543 __LDBL_REDIR1_NTH (name, proto, __nldbl_##alias)
503# endif 544# endif
504#endif 545#endif
505#if !defined __LDBL_COMPAT || !defined __REDIRECT 546#if (!defined __LDBL_COMPAT && __LDOUBLE_REDIRECTS_TO_FLOAT128_ABI == 0) \
547 || !defined __REDIRECT
506# define __LDBL_REDIR1(name, proto, alias) name proto 548# define __LDBL_REDIR1(name, proto, alias) name proto
507# define __LDBL_REDIR(name, proto) name proto 549# define __LDBL_REDIR(name, proto) name proto
508# define __LDBL_REDIR1_NTH(name, proto, alias) name proto __THROW 550# define __LDBL_REDIR1_NTH(name, proto, alias) name proto __THROW
509# define __LDBL_REDIR_NTH(name, proto) name proto __THROW 551# define __LDBL_REDIR_NTH(name, proto) name proto __THROW
552# define __LDBL_REDIR2_DECL(name)
510# define __LDBL_REDIR_DECL(name) 553# define __LDBL_REDIR_DECL(name)
511# ifdef __REDIRECT 554# ifdef __REDIRECT
512# define __REDIRECT_LDBL(name, proto, alias) __REDIRECT (name, proto, alias) 555# define __REDIRECT_LDBL(name, proto, alias) __REDIRECT (name, proto, alias)
@@ -537,7 +580,7 @@
537 check is required to enable the use of generic selection. */ 580 check is required to enable the use of generic selection. */
538#if !defined __cplusplus \ 581#if !defined __cplusplus \
539 && (__GNUC_PREREQ (4, 9) \ 582 && (__GNUC_PREREQ (4, 9) \
540 || __glibc_clang_has_extension (c_generic_selections) \ 583 || __glibc_has_extension (c_generic_selections) \
541 || (!defined __GNUC__ && defined __STDC_VERSION__ \ 584 || (!defined __GNUC__ && defined __STDC_VERSION__ \
542 && __STDC_VERSION__ >= 201112L)) 585 && __STDC_VERSION__ >= 201112L))
543# define __HAVE_GENERIC_SELECTION 1 586# define __HAVE_GENERIC_SELECTION 1
@@ -545,4 +588,23 @@
545# define __HAVE_GENERIC_SELECTION 0 588# define __HAVE_GENERIC_SELECTION 0
546#endif 589#endif
547 590
591#if __GNUC_PREREQ (10, 0)
592/* Designates a 1-based positional argument ref-index of pointer type
593 that can be used to access size-index elements of the pointed-to
594 array according to access mode, or at least one element when
595 size-index is not provided:
596 access (access-mode, <ref-index> [, <size-index>]) */
597#define __attr_access(x) __attribute__ ((__access__ x))
598#else
599# define __attr_access(x)
600#endif
601
602/* Specify that a function such as setjmp or vfork may return
603 twice. */
604#if __GNUC_PREREQ (4, 1)
605# define __attribute_returns_twice__ __attribute__ ((__returns_twice__))
606#else
607# define __attribute_returns_twice__ /* Ignore. */
608#endif
609
548#endif /* sys/cdefs.h */ 610#endif /* sys/cdefs.h */
diff --git a/lib/dirent.in.h b/lib/dirent.in.h
index 2e2c5119a11..4666972b150 100644
--- a/lib/dirent.in.h
+++ b/lib/dirent.in.h
@@ -154,7 +154,8 @@ _GL_WARN_ON_USE (closedir, "closedir is not portable - "
154/* Return the file descriptor associated with the given directory stream, 154/* Return the file descriptor associated with the given directory stream,
155 or -1 if none exists. */ 155 or -1 if none exists. */
156# if @REPLACE_DIRFD@ 156# if @REPLACE_DIRFD@
157# if !(defined __cplusplus && defined GNULIB_NAMESPACE) 157/* On kLIBC, dirfd() is a macro that does not work. Undefine it. */
158# if !(defined __cplusplus && defined GNULIB_NAMESPACE) || defined dirfd
158# undef dirfd 159# undef dirfd
159# define dirfd rpl_dirfd 160# define dirfd rpl_dirfd
160# endif 161# endif
diff --git a/lib/dynarray.h b/lib/dynarray.h
new file mode 100644
index 00000000000..6da3e87e55f
--- /dev/null
+++ b/lib/dynarray.h
@@ -0,0 +1,31 @@
1/* Type-safe arrays which grow dynamically.
2 Copyright 2021 Free Software Foundation, Inc.
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation; either version 3 of the License, or
7 (at your option) any later version.
8
9 This program 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 General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <https://www.gnu.org/licenses/>. */
16
17/* Written by Paul Eggert, 2021. */
18
19#ifndef _GL_DYNARRAY_H
20#define _GL_DYNARRAY_H
21
22#include <libc-config.h>
23
24#define __libc_dynarray_at_failure gl_dynarray_at_failure
25#define __libc_dynarray_emplace_enlarge gl_dynarray_emplace_enlarge
26#define __libc_dynarray_finalize gl_dynarray_finalize
27#define __libc_dynarray_resize_clear gl_dynarray_resize_clear
28#define __libc_dynarray_resize gl_dynarray_resize
29#include <malloc/dynarray.h>
30
31#endif /* _GL_DYNARRAY_H */
diff --git a/lib/explicit_bzero.c b/lib/explicit_bzero.c
index feea4446c06..f50ed0875d7 100644
--- a/lib/explicit_bzero.c
+++ b/lib/explicit_bzero.c
@@ -54,11 +54,21 @@ explicit_bzero (void *s, size_t len)
54 explicit_memset (s, '\0', len); 54 explicit_memset (s, '\0', len);
55#elif HAVE_MEMSET_S 55#elif HAVE_MEMSET_S
56 (void) memset_s (s, len, '\0', len); 56 (void) memset_s (s, len, '\0', len);
57#else 57#elif defined __GNUC__ && !defined __clang__
58 memset (s, '\0', len); 58 memset (s, '\0', len);
59# if defined __GNUC__ && !defined __clang__
60 /* Compiler barrier. */ 59 /* Compiler barrier. */
61 asm volatile ("" ::: "memory"); 60 asm volatile ("" ::: "memory");
62# endif 61#elif defined __clang__
62 memset (s, '\0', len);
63 /* Compiler barrier. */
64 /* With asm ("" ::: "memory") LLVM analyzes uses of 's' and finds that the
65 whole thing is dead and eliminates it. Use 'g' to work around this
66 problem. See <https://bugs.llvm.org/show_bug.cgi?id=15495#c11>. */
67 __asm__ volatile ("" : : "g"(s) : "memory");
68#else
69 /* Invoke memset through a volatile function pointer. This defeats compiler
70 optimizations. */
71 void * (* const volatile volatile_memset) (void *, int, size_t) = memset;
72 (void) volatile_memset (s, '\0', len);
63#endif 73#endif
64} 74}
diff --git a/lib/fchmodat.c b/lib/fchmodat.c
index d27c0d7734a..eb6e2242fdd 100644
--- a/lib/fchmodat.c
+++ b/lib/fchmodat.c
@@ -38,6 +38,7 @@ orig_fchmodat (int dir, char const *file, mode_t mode, int flags)
38#include <fcntl.h> 38#include <fcntl.h>
39#include <stdio.h> 39#include <stdio.h>
40#include <stdlib.h> 40#include <stdlib.h>
41#include <string.h>
41#include <unistd.h> 42#include <unistd.h>
42 43
43#ifdef __osf__ 44#ifdef __osf__
@@ -63,6 +64,22 @@ orig_fchmodat (int dir, char const *file, mode_t mode, int flags)
63int 64int
64fchmodat (int dir, char const *file, mode_t mode, int flags) 65fchmodat (int dir, char const *file, mode_t mode, int flags)
65{ 66{
67# if HAVE_NEARLY_WORKING_FCHMODAT
68 /* Correct the trailing slash handling. */
69 size_t len = strlen (file);
70 if (len && file[len - 1] == '/')
71 {
72 struct stat st;
73 if (fstatat (dir, file, &st, flags & AT_SYMLINK_NOFOLLOW) < 0)
74 return -1;
75 if (!S_ISDIR (st.st_mode))
76 {
77 errno = ENOTDIR;
78 return -1;
79 }
80 }
81# endif
82
66# if NEED_FCHMODAT_NONSYMLINK_FIX 83# if NEED_FCHMODAT_NONSYMLINK_FIX
67 if (flags == AT_SYMLINK_NOFOLLOW) 84 if (flags == AT_SYMLINK_NOFOLLOW)
68 { 85 {
diff --git a/lib/free.c b/lib/free.c
index 135c3eb16bc..5c89787aba1 100644
--- a/lib/free.c
+++ b/lib/free.c
@@ -27,7 +27,21 @@ void
27rpl_free (void *p) 27rpl_free (void *p)
28#undef free 28#undef free
29{ 29{
30#if defined __GNUC__ && !defined __clang__
31 /* An invalid GCC optimization
32 <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98396>
33 would optimize away the assignments in the code below, when link-time
34 optimization (LTO) is enabled. Make the code more complicated, so that
35 GCC does not grok how to optimize it. */
36 int err[2];
37 err[0] = errno;
38 err[1] = errno;
39 errno = 0;
40 free (p);
41 errno = err[errno == 0];
42#else
30 int err = errno; 43 int err = errno;
31 free (p); 44 free (p);
32 errno = err; 45 errno = err;
46#endif
33} 47}
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index c457ac61209..07736f9b8bc 100644
--- a/lib/gnulib.mk.in
+++ b/lib/gnulib.mk.in
@@ -516,6 +516,7 @@ GNULIB_SYMLINK = @GNULIB_SYMLINK@
516GNULIB_SYMLINKAT = @GNULIB_SYMLINKAT@ 516GNULIB_SYMLINKAT = @GNULIB_SYMLINKAT@
517GNULIB_SYSTEM_POSIX = @GNULIB_SYSTEM_POSIX@ 517GNULIB_SYSTEM_POSIX = @GNULIB_SYSTEM_POSIX@
518GNULIB_TIMEGM = @GNULIB_TIMEGM@ 518GNULIB_TIMEGM = @GNULIB_TIMEGM@
519GNULIB_TIMESPEC_GET = @GNULIB_TIMESPEC_GET@
519GNULIB_TIME_R = @GNULIB_TIME_R@ 520GNULIB_TIME_R = @GNULIB_TIME_R@
520GNULIB_TIME_RZ = @GNULIB_TIME_RZ@ 521GNULIB_TIME_RZ = @GNULIB_TIME_RZ@
521GNULIB_TMPFILE = @GNULIB_TMPFILE@ 522GNULIB_TMPFILE = @GNULIB_TMPFILE@
@@ -746,6 +747,7 @@ HAVE_SYS_SELECT_H = @HAVE_SYS_SELECT_H@
746HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@ 747HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@
747HAVE_SYS_TYPES_H = @HAVE_SYS_TYPES_H@ 748HAVE_SYS_TYPES_H = @HAVE_SYS_TYPES_H@
748HAVE_TIMEGM = @HAVE_TIMEGM@ 749HAVE_TIMEGM = @HAVE_TIMEGM@
750HAVE_TIMESPEC_GET = @HAVE_TIMESPEC_GET@
749HAVE_TIMEZONE_T = @HAVE_TIMEZONE_T@ 751HAVE_TIMEZONE_T = @HAVE_TIMEZONE_T@
750HAVE_TYPE_VOLATILE_SIG_ATOMIC_T = @HAVE_TYPE_VOLATILE_SIG_ATOMIC_T@ 752HAVE_TYPE_VOLATILE_SIG_ATOMIC_T = @HAVE_TYPE_VOLATILE_SIG_ATOMIC_T@
751HAVE_UNISTD_H = @HAVE_UNISTD_H@ 753HAVE_UNISTD_H = @HAVE_UNISTD_H@
@@ -949,6 +951,7 @@ REPLACE_FCNTL = @REPLACE_FCNTL@
949REPLACE_FDOPEN = @REPLACE_FDOPEN@ 951REPLACE_FDOPEN = @REPLACE_FDOPEN@
950REPLACE_FDOPENDIR = @REPLACE_FDOPENDIR@ 952REPLACE_FDOPENDIR = @REPLACE_FDOPENDIR@
951REPLACE_FFLUSH = @REPLACE_FFLUSH@ 953REPLACE_FFLUSH = @REPLACE_FFLUSH@
954REPLACE_FFSLL = @REPLACE_FFSLL@
952REPLACE_FOPEN = @REPLACE_FOPEN@ 955REPLACE_FOPEN = @REPLACE_FOPEN@
953REPLACE_FPRINTF = @REPLACE_FPRINTF@ 956REPLACE_FPRINTF = @REPLACE_FPRINTF@
954REPLACE_FPURGE = @REPLACE_FPURGE@ 957REPLACE_FPURGE = @REPLACE_FPURGE@
@@ -989,7 +992,9 @@ REPLACE_MEMCHR = @REPLACE_MEMCHR@
989REPLACE_MEMMEM = @REPLACE_MEMMEM@ 992REPLACE_MEMMEM = @REPLACE_MEMMEM@
990REPLACE_MKDIR = @REPLACE_MKDIR@ 993REPLACE_MKDIR = @REPLACE_MKDIR@
991REPLACE_MKFIFO = @REPLACE_MKFIFO@ 994REPLACE_MKFIFO = @REPLACE_MKFIFO@
995REPLACE_MKFIFOAT = @REPLACE_MKFIFOAT@
992REPLACE_MKNOD = @REPLACE_MKNOD@ 996REPLACE_MKNOD = @REPLACE_MKNOD@
997REPLACE_MKNODAT = @REPLACE_MKNODAT@
993REPLACE_MKSTEMP = @REPLACE_MKSTEMP@ 998REPLACE_MKSTEMP = @REPLACE_MKSTEMP@
994REPLACE_MKTIME = @REPLACE_MKTIME@ 999REPLACE_MKTIME = @REPLACE_MKTIME@
995REPLACE_NANOSLEEP = @REPLACE_NANOSLEEP@ 1000REPLACE_NANOSLEEP = @REPLACE_NANOSLEEP@
@@ -1087,6 +1092,7 @@ SYSTEM_TYPE = @SYSTEM_TYPE@
1087SYS_TIME_H_DEFINES_STRUCT_TIMESPEC = @SYS_TIME_H_DEFINES_STRUCT_TIMESPEC@ 1092SYS_TIME_H_DEFINES_STRUCT_TIMESPEC = @SYS_TIME_H_DEFINES_STRUCT_TIMESPEC@
1088TERMCAP_OBJ = @TERMCAP_OBJ@ 1093TERMCAP_OBJ = @TERMCAP_OBJ@
1089TIME_H_DEFINES_STRUCT_TIMESPEC = @TIME_H_DEFINES_STRUCT_TIMESPEC@ 1094TIME_H_DEFINES_STRUCT_TIMESPEC = @TIME_H_DEFINES_STRUCT_TIMESPEC@
1095TIME_H_DEFINES_TIME_UTC = @TIME_H_DEFINES_TIME_UTC@
1090TOOLKIT_LIBW = @TOOLKIT_LIBW@ 1096TOOLKIT_LIBW = @TOOLKIT_LIBW@
1091UINT32_MAX_LT_UINTMAX_MAX = @UINT32_MAX_LT_UINTMAX_MAX@ 1097UINT32_MAX_LT_UINTMAX_MAX = @UINT32_MAX_LT_UINTMAX_MAX@
1092UINT64_MAX_EQ_ULONG_MAX = @UINT64_MAX_EQ_ULONG_MAX@ 1098UINT64_MAX_EQ_ULONG_MAX = @UINT64_MAX_EQ_ULONG_MAX@
@@ -1171,6 +1177,7 @@ gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1 = @gl_GNULIB_ENABLED_a9786850
1171gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36@ 1177gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36@
1172gl_GNULIB_ENABLED_cloexec = @gl_GNULIB_ENABLED_cloexec@ 1178gl_GNULIB_ENABLED_cloexec = @gl_GNULIB_ENABLED_cloexec@
1173gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@ 1179gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@
1180gl_GNULIB_ENABLED_dynarray = @gl_GNULIB_ENABLED_dynarray@
1174gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@ 1181gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@
1175gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@ 1182gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@
1176gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@ 1183gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@
@@ -1584,6 +1591,20 @@ EXTRA_libgnu_a_SOURCES += dup2.c
1584endif 1591endif
1585## end gnulib module dup2 1592## end gnulib module dup2
1586 1593
1594## begin gnulib module dynarray
1595ifeq (,$(OMIT_GNULIB_MODULE_dynarray))
1596
1597ifneq (,$(gl_GNULIB_ENABLED_dynarray))
1598libgnu_a_SOURCES += malloc/dynarray_at_failure.c malloc/dynarray_emplace_enlarge.c malloc/dynarray_finalize.c malloc/dynarray_resize.c malloc/dynarray_resize_clear.c
1599
1600endif
1601EXTRA_DIST += dynarray.h malloc/dynarray-skeleton.c malloc/dynarray.h
1602
1603EXTRA_libgnu_a_SOURCES += malloc/dynarray-skeleton.c
1604
1605endif
1606## end gnulib module dynarray
1607
1587## begin gnulib module eloop-threshold 1608## begin gnulib module eloop-threshold
1588ifeq (,$(OMIT_GNULIB_MODULE_eloop-threshold)) 1609ifeq (,$(OMIT_GNULIB_MODULE_eloop-threshold))
1589 1610
@@ -3036,6 +3057,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
3036 -e 's|@''HAVE_SIGDESCR_NP''@|$(HAVE_SIGDESCR_NP)|g' \ 3057 -e 's|@''HAVE_SIGDESCR_NP''@|$(HAVE_SIGDESCR_NP)|g' \
3037 -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \ 3058 -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \
3038 -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \ 3059 -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \
3060 -e 's|@''REPLACE_FFSLL''@|$(REPLACE_FFSLL)|g' \
3039 -e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \ 3061 -e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \
3040 -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \ 3062 -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \
3041 -e 's|@''REPLACE_STPNCPY''@|$(REPLACE_STPNCPY)|g' \ 3063 -e 's|@''REPLACE_STPNCPY''@|$(REPLACE_STPNCPY)|g' \
@@ -3237,7 +3259,9 @@ sys/stat.h: sys_stat.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNU
3237 -e 's|@''REPLACE_LSTAT''@|$(REPLACE_LSTAT)|g' \ 3259 -e 's|@''REPLACE_LSTAT''@|$(REPLACE_LSTAT)|g' \
3238 -e 's|@''REPLACE_MKDIR''@|$(REPLACE_MKDIR)|g' \ 3260 -e 's|@''REPLACE_MKDIR''@|$(REPLACE_MKDIR)|g' \
3239 -e 's|@''REPLACE_MKFIFO''@|$(REPLACE_MKFIFO)|g' \ 3261 -e 's|@''REPLACE_MKFIFO''@|$(REPLACE_MKFIFO)|g' \
3262 -e 's|@''REPLACE_MKFIFOAT''@|$(REPLACE_MKFIFOAT)|g' \
3240 -e 's|@''REPLACE_MKNOD''@|$(REPLACE_MKNOD)|g' \ 3263 -e 's|@''REPLACE_MKNOD''@|$(REPLACE_MKNOD)|g' \
3264 -e 's|@''REPLACE_MKNODAT''@|$(REPLACE_MKNODAT)|g' \
3241 -e 's|@''REPLACE_STAT''@|$(REPLACE_STAT)|g' \ 3265 -e 's|@''REPLACE_STAT''@|$(REPLACE_STAT)|g' \
3242 -e 's|@''REPLACE_UTIMENSAT''@|$(REPLACE_UTIMENSAT)|g' \ 3266 -e 's|@''REPLACE_UTIMENSAT''@|$(REPLACE_UTIMENSAT)|g' \
3243 -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ 3267 -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
@@ -3350,6 +3374,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(
3350 -e 's/@''GNULIB_STRFTIME''@/$(GNULIB_STRFTIME)/g' \ 3374 -e 's/@''GNULIB_STRFTIME''@/$(GNULIB_STRFTIME)/g' \
3351 -e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \ 3375 -e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \
3352 -e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \ 3376 -e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \
3377 -e 's/@''GNULIB_TIMESPEC_GET''@/$(GNULIB_TIMESPEC_GET)/g' \
3353 -e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \ 3378 -e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \
3354 -e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \ 3379 -e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \
3355 -e 's/@''GNULIB_TZSET''@/$(GNULIB_TZSET)/g' \ 3380 -e 's/@''GNULIB_TZSET''@/$(GNULIB_TZSET)/g' \
@@ -3358,6 +3383,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(
3358 -e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \ 3383 -e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \
3359 -e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \ 3384 -e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \
3360 -e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \ 3385 -e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \
3386 -e 's|@''HAVE_TIMESPEC_GET''@|$(HAVE_TIMESPEC_GET)|g' \
3361 -e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \ 3387 -e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \
3362 -e 's|@''REPLACE_CTIME''@|$(REPLACE_CTIME)|g' \ 3388 -e 's|@''REPLACE_CTIME''@|$(REPLACE_CTIME)|g' \
3363 -e 's|@''REPLACE_GMTIME''@|$(REPLACE_GMTIME)|g' \ 3389 -e 's|@''REPLACE_GMTIME''@|$(REPLACE_GMTIME)|g' \
@@ -3372,6 +3398,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(
3372 -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ 3398 -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \
3373 -e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ 3399 -e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \
3374 -e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \ 3400 -e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \
3401 -e 's|@''TIME_H_DEFINES_TIME_UTC''@|$(TIME_H_DEFINES_TIME_UTC)|g' \
3375 -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ 3402 -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
3376 -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ 3403 -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
3377 -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ 3404 -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
diff --git a/lib/libc-config.h b/lib/libc-config.h
index d4e29951f35..c0eac707cfd 100644
--- a/lib/libc-config.h
+++ b/lib/libc-config.h
@@ -71,107 +71,112 @@
71# endif 71# endif
72#endif 72#endif
73 73
74 74#ifndef __attribute_maybe_unused__
75/* Prepare to include <cdefs.h>, which is our copy of glibc 75/* <sys/cdefs.h> either does not exist, or is too old for Gnulib.
76 <sys/cdefs.h>. */ 76 Prepare to include <cdefs.h>, which is Gnulib's version of a
77 more-recent glibc <sys/cdefs.h>. */
77 78
78/* Define _FEATURES_H so that <cdefs.h> does not include <features.h>. */ 79/* Define _FEATURES_H so that <cdefs.h> does not include <features.h>. */
79#ifndef _FEATURES_H 80# ifndef _FEATURES_H
80# define _FEATURES_H 1 81# define _FEATURES_H 1
81#endif 82# endif
82/* Define __WORDSIZE so that <cdefs.h> does not attempt to include 83/* Define __WORDSIZE so that <cdefs.h> does not attempt to include
83 nonexistent files. Make it a syntax error, since Gnulib does not 84 nonexistent files. Make it a syntax error, since Gnulib does not
84 use __WORDSIZE now, and if Gnulib uses it later the syntax error 85 use __WORDSIZE now, and if Gnulib uses it later the syntax error
85 will let us know that __WORDSIZE needs configuring. */ 86 will let us know that __WORDSIZE needs configuring. */
86#ifndef __WORDSIZE 87# ifndef __WORDSIZE
87# define __WORDSIZE %%% 88# define __WORDSIZE %%%
88#endif 89# endif
89/* Undef the macros unconditionally defined by our copy of glibc 90/* Undef the macros unconditionally defined by our copy of glibc
90 <sys/cdefs.h>, so that they do not clash with any system-defined 91 <sys/cdefs.h>, so that they do not clash with any system-defined
91 versions. */ 92 versions. */
92#undef _SYS_CDEFS_H 93# undef _SYS_CDEFS_H
93#undef __ASMNAME 94# undef __ASMNAME
94#undef __ASMNAME2 95# undef __ASMNAME2
95#undef __BEGIN_DECLS 96# undef __BEGIN_DECLS
96#undef __CONCAT 97# undef __CONCAT
97#undef __END_DECLS 98# undef __END_DECLS
98#undef __HAVE_GENERIC_SELECTION 99# undef __HAVE_GENERIC_SELECTION
99#undef __LDBL_COMPAT 100# undef __LDBL_COMPAT
100#undef __LDBL_REDIR 101# undef __LDBL_REDIR
101#undef __LDBL_REDIR1 102# undef __LDBL_REDIR1
102#undef __LDBL_REDIR1_DECL 103# undef __LDBL_REDIR1_DECL
103#undef __LDBL_REDIR1_NTH 104# undef __LDBL_REDIR1_NTH
104#undef __LDBL_REDIR_DECL 105# undef __LDBL_REDIR2_DECL
105#undef __LDBL_REDIR_NTH 106# undef __LDBL_REDIR_DECL
106#undef __LEAF 107# undef __LDBL_REDIR_NTH
107#undef __LEAF_ATTR 108# undef __LEAF
108#undef __NTH 109# undef __LEAF_ATTR
109#undef __NTHNL 110# undef __NTH
110#undef __P 111# undef __NTHNL
111#undef __PMT 112# undef __REDIRECT
112#undef __REDIRECT 113# undef __REDIRECT_LDBL
113#undef __REDIRECT_LDBL 114# undef __REDIRECT_NTH
114#undef __REDIRECT_NTH 115# undef __REDIRECT_NTHNL
115#undef __REDIRECT_NTHNL 116# undef __REDIRECT_NTH_LDBL
116#undef __REDIRECT_NTH_LDBL 117# undef __STRING
117#undef __STRING 118# undef __THROW
118#undef __THROW 119# undef __THROWNL
119#undef __THROWNL 120# undef __attr_access
120#undef __always_inline 121# undef __attribute__
121#undef __attribute__ 122# undef __attribute_alloc_size__
122#undef __attribute_alloc_size__ 123# undef __attribute_artificial__
123#undef __attribute_artificial__ 124# undef __attribute_const__
124#undef __attribute_const__ 125# undef __attribute_deprecated__
125#undef __attribute_deprecated__ 126# undef __attribute_deprecated_msg__
126#undef __attribute_deprecated_msg__ 127# undef __attribute_format_arg__
127#undef __attribute_format_arg__ 128# undef __attribute_format_strfmon__
128#undef __attribute_format_strfmon__ 129# undef __attribute_malloc__
129#undef __attribute_malloc__ 130# undef __attribute_noinline__
130#undef __attribute_noinline__ 131# undef __attribute_nonstring__
131#undef __attribute_nonstring__ 132# undef __attribute_pure__
132#undef __attribute_pure__ 133# undef __attribute_returns_twice__
133#undef __attribute_used__ 134# undef __attribute_used__
134#undef __attribute_warn_unused_result__ 135# undef __attribute_warn_unused_result__
135#undef __bos 136# undef __bos
136#undef __bos0 137# undef __bos0
137#undef __errordecl 138# undef __errordecl
138#undef __extension__ 139# undef __extension__
139#undef __extern_always_inline 140# undef __extern_always_inline
140#undef __extern_inline 141# undef __extern_inline
141#undef __flexarr 142# undef __flexarr
142#undef __fortify_function 143# undef __fortify_function
143#undef __glibc_c99_flexarr_available 144# undef __glibc_c99_flexarr_available
144#undef __glibc_clang_has_extension 145# undef __glibc_has_attribute
145#undef __glibc_likely 146# undef __glibc_has_builtin
146#undef __glibc_macro_warning 147# undef __glibc_has_extension
147#undef __glibc_macro_warning1 148# undef __glibc_macro_warning
148#undef __glibc_unlikely 149# undef __glibc_macro_warning1
149#undef __inline 150# undef __glibc_objsize
150#undef __ptr_t 151# undef __glibc_objsize0
151#undef __restrict 152# undef __glibc_unlikely
152#undef __restrict_arr 153# undef __inline
153#undef __va_arg_pack 154# undef __ptr_t
154#undef __va_arg_pack_len 155# undef __restrict
155#undef __warnattr 156# undef __restrict_arr
156#undef __warndecl 157# undef __va_arg_pack
158# undef __va_arg_pack_len
159# undef __warnattr
157 160
158/* Include our copy of glibc <sys/cdefs.h>. */ 161/* Include our copy of glibc <sys/cdefs.h>. */
159#include <cdefs.h> 162# include <cdefs.h>
160 163
161/* <cdefs.h> __inline is too pessimistic for non-GCC. */ 164/* <cdefs.h> __inline is too pessimistic for non-GCC. */
162#undef __inline 165# undef __inline
163#ifndef HAVE___INLINE 166# ifndef HAVE___INLINE
164# if 199901 <= __STDC_VERSION__ || defined inline 167# if 199901 <= __STDC_VERSION__ || defined inline
165# define __inline inline 168# define __inline inline
166# else 169# else
167# define __inline 170# define __inline
171# endif
168# endif 172# endif
169#endif 173
174#endif /* defined __glibc_likely */
170 175
171 176
172/* A substitute for glibc <libc-symbols.h>, good enough for Gnulib. */ 177/* A substitute for glibc <libc-symbols.h>, good enough for Gnulib. */
173#define attribute_hidden 178#define attribute_hidden
174#define libc_hidden_proto(name, ...) 179#define libc_hidden_proto(name)
175#define libc_hidden_def(name) 180#define libc_hidden_def(name)
176#define libc_hidden_weak(name) 181#define libc_hidden_weak(name)
177#define libc_hidden_ver(local, name) 182#define libc_hidden_ver(local, name)
diff --git a/lib/malloc/dynarray-skeleton.c b/lib/malloc/dynarray-skeleton.c
new file mode 100644
index 00000000000..4995fd1c049
--- /dev/null
+++ b/lib/malloc/dynarray-skeleton.c
@@ -0,0 +1,525 @@
1/* Type-safe arrays which grow dynamically.
2 Copyright (C) 2017-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library.
4
5 The GNU C Library is free software; you can redistribute it and/or
6 modify it under the terms of the GNU General Public
7 License as published by the Free Software Foundation; either
8 version 3 of the License, or (at your option) any later version.
9
10 The GNU C Library is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 General Public License for more details.
14
15 You should have received a copy of the GNU General Public
16 License along with the GNU C Library; if not, see
17 <https://www.gnu.org/licenses/>. */
18
19/* Pre-processor macros which act as parameters:
20
21 DYNARRAY_STRUCT
22 The struct tag of dynamic array to be defined.
23 DYNARRAY_ELEMENT
24 The type name of the element type. Elements are copied
25 as if by memcpy, and can change address as the dynamic
26 array grows.
27 DYNARRAY_PREFIX
28 The prefix of the functions which are defined.
29
30 The following parameters are optional:
31
32 DYNARRAY_ELEMENT_FREE
33 DYNARRAY_ELEMENT_FREE (E) is evaluated to deallocate the
34 contents of elements. E is of type DYNARRAY_ELEMENT *.
35 DYNARRAY_ELEMENT_INIT
36 DYNARRAY_ELEMENT_INIT (E) is evaluated to initialize a new
37 element. E is of type DYNARRAY_ELEMENT *.
38 If DYNARRAY_ELEMENT_FREE but not DYNARRAY_ELEMENT_INIT is
39 defined, new elements are automatically zero-initialized.
40 Otherwise, new elements have undefined contents.
41 DYNARRAY_INITIAL_SIZE
42 The size of the statically allocated array (default:
43 at least 2, more elements if they fit into 128 bytes).
44 Must be a preprocessor constant. If DYNARRAY_INITIAL_SIZE is 0,
45 there is no statically allocated array at, and all non-empty
46 arrays are heap-allocated.
47 DYNARRAY_FINAL_TYPE
48 The name of the type which holds the final array. If not
49 defined, is PREFIX##finalize not provided. DYNARRAY_FINAL_TYPE
50 must be a struct type, with members of type DYNARRAY_ELEMENT and
51 size_t at the start (in this order).
52
53 These macros are undefined after this header file has been
54 included.
55
56 The following types are provided (their members are private to the
57 dynarray implementation):
58
59 struct DYNARRAY_STRUCT
60
61 The following functions are provided:
62
63 void DYNARRAY_PREFIX##init (struct DYNARRAY_STRUCT *);
64 void DYNARRAY_PREFIX##free (struct DYNARRAY_STRUCT *);
65 bool DYNARRAY_PREFIX##has_failed (const struct DYNARRAY_STRUCT *);
66 void DYNARRAY_PREFIX##mark_failed (struct DYNARRAY_STRUCT *);
67 size_t DYNARRAY_PREFIX##size (const struct DYNARRAY_STRUCT *);
68 DYNARRAY_ELEMENT *DYNARRAY_PREFIX##begin (const struct DYNARRAY_STRUCT *);
69 DYNARRAY_ELEMENT *DYNARRAY_PREFIX##end (const struct DYNARRAY_STRUCT *);
70 DYNARRAY_ELEMENT *DYNARRAY_PREFIX##at (struct DYNARRAY_STRUCT *, size_t);
71 void DYNARRAY_PREFIX##add (struct DYNARRAY_STRUCT *, DYNARRAY_ELEMENT);
72 DYNARRAY_ELEMENT *DYNARRAY_PREFIX##emplace (struct DYNARRAY_STRUCT *);
73 bool DYNARRAY_PREFIX##resize (struct DYNARRAY_STRUCT *, size_t);
74 void DYNARRAY_PREFIX##remove_last (struct DYNARRAY_STRUCT *);
75 void DYNARRAY_PREFIX##clear (struct DYNARRAY_STRUCT *);
76
77 The following functions are provided are provided if the
78 prerequisites are met:
79
80 bool DYNARRAY_PREFIX##finalize (struct DYNARRAY_STRUCT *,
81 DYNARRAY_FINAL_TYPE *);
82 (if DYNARRAY_FINAL_TYPE is defined)
83 DYNARRAY_ELEMENT *DYNARRAY_PREFIX##finalize (struct DYNARRAY_STRUCT *,
84 size_t *);
85 (if DYNARRAY_FINAL_TYPE is not defined)
86*/
87
88#include <malloc/dynarray.h>
89
90#include <errno.h>
91#include <stdlib.h>
92#include <string.h>
93
94#ifndef DYNARRAY_STRUCT
95# error "DYNARRAY_STRUCT must be defined"
96#endif
97
98#ifndef DYNARRAY_ELEMENT
99# error "DYNARRAY_ELEMENT must be defined"
100#endif
101
102#ifndef DYNARRAY_PREFIX
103# error "DYNARRAY_PREFIX must be defined"
104#endif
105
106#ifdef DYNARRAY_INITIAL_SIZE
107# if DYNARRAY_INITIAL_SIZE < 0
108# error "DYNARRAY_INITIAL_SIZE must be non-negative"
109# endif
110# if DYNARRAY_INITIAL_SIZE > 0
111# define DYNARRAY_HAVE_SCRATCH 1
112# else
113# define DYNARRAY_HAVE_SCRATCH 0
114# endif
115#else
116/* Provide a reasonable default which limits the size of
117 DYNARRAY_STRUCT. */
118# define DYNARRAY_INITIAL_SIZE \
119 (sizeof (DYNARRAY_ELEMENT) > 64 ? 2 : 128 / sizeof (DYNARRAY_ELEMENT))
120# define DYNARRAY_HAVE_SCRATCH 1
121#endif
122
123/* Public type definitions. */
124
125/* All fields of this struct are private to the implementation. */
126struct DYNARRAY_STRUCT
127{
128 union
129 {
130 struct dynarray_header dynarray_abstract;
131 struct
132 {
133 /* These fields must match struct dynarray_header. */
134 size_t used;
135 size_t allocated;
136 DYNARRAY_ELEMENT *array;
137 } dynarray_header;
138 } u;
139
140#if DYNARRAY_HAVE_SCRATCH
141 /* Initial inline allocation. */
142 DYNARRAY_ELEMENT scratch[DYNARRAY_INITIAL_SIZE];
143#endif
144};
145
146/* Internal use only: Helper macros. */
147
148/* Ensure macro-expansion of DYNARRAY_PREFIX. */
149#define DYNARRAY_CONCAT0(prefix, name) prefix##name
150#define DYNARRAY_CONCAT1(prefix, name) DYNARRAY_CONCAT0(prefix, name)
151#define DYNARRAY_NAME(name) DYNARRAY_CONCAT1(DYNARRAY_PREFIX, name)
152
153/* Use DYNARRAY_FREE instead of DYNARRAY_NAME (free),
154 so that Gnulib does not change 'free' to 'rpl_free'. */
155#define DYNARRAY_FREE DYNARRAY_CONCAT1 (DYNARRAY_NAME (f), ree)
156
157/* Address of the scratch buffer if any. */
158#if DYNARRAY_HAVE_SCRATCH
159# define DYNARRAY_SCRATCH(list) (list)->scratch
160#else
161# define DYNARRAY_SCRATCH(list) NULL
162#endif
163
164/* Internal use only: Helper functions. */
165
166/* Internal function. Call DYNARRAY_ELEMENT_FREE with the array
167 elements. Name mangling needed due to the DYNARRAY_ELEMENT_FREE
168 macro expansion. */
169static inline void
170DYNARRAY_NAME (free__elements__) (DYNARRAY_ELEMENT *__dynarray_array,
171 size_t __dynarray_used)
172{
173#ifdef DYNARRAY_ELEMENT_FREE
174 for (size_t __dynarray_i = 0; __dynarray_i < __dynarray_used; ++__dynarray_i)
175 DYNARRAY_ELEMENT_FREE (&__dynarray_array[__dynarray_i]);
176#endif /* DYNARRAY_ELEMENT_FREE */
177}
178
179/* Internal function. Free the non-scratch array allocation. */
180static inline void
181DYNARRAY_NAME (free__array__) (struct DYNARRAY_STRUCT *list)
182{
183#if DYNARRAY_HAVE_SCRATCH
184 if (list->u.dynarray_header.array != list->scratch)
185 free (list->u.dynarray_header.array);
186#else
187 free (list->u.dynarray_header.array);
188#endif
189}
190
191/* Public functions. */
192
193/* Initialize a dynamic array object. This must be called before any
194 use of the object. */
195__nonnull ((1))
196static void
197DYNARRAY_NAME (init) (struct DYNARRAY_STRUCT *list)
198{
199 list->u.dynarray_header.used = 0;
200 list->u.dynarray_header.allocated = DYNARRAY_INITIAL_SIZE;
201 list->u.dynarray_header.array = DYNARRAY_SCRATCH (list);
202}
203
204/* Deallocate the dynamic array and its elements. */
205__attribute_maybe_unused__ __nonnull ((1))
206static void
207DYNARRAY_FREE (struct DYNARRAY_STRUCT *list)
208{
209 DYNARRAY_NAME (free__elements__)
210 (list->u.dynarray_header.array, list->u.dynarray_header.used);
211 DYNARRAY_NAME (free__array__) (list);
212 DYNARRAY_NAME (init) (list);
213}
214
215/* Return true if the dynamic array is in an error state. */
216__nonnull ((1))
217static inline bool
218DYNARRAY_NAME (has_failed) (const struct DYNARRAY_STRUCT *list)
219{
220 return list->u.dynarray_header.allocated == __dynarray_error_marker ();
221}
222
223/* Mark the dynamic array as failed. All elements are deallocated as
224 a side effect. */
225__nonnull ((1))
226static void
227DYNARRAY_NAME (mark_failed) (struct DYNARRAY_STRUCT *list)
228{
229 DYNARRAY_NAME (free__elements__)
230 (list->u.dynarray_header.array, list->u.dynarray_header.used);
231 DYNARRAY_NAME (free__array__) (list);
232 list->u.dynarray_header.array = DYNARRAY_SCRATCH (list);
233 list->u.dynarray_header.used = 0;
234 list->u.dynarray_header.allocated = __dynarray_error_marker ();
235}
236
237/* Return the number of elements which have been added to the dynamic
238 array. */
239__nonnull ((1))
240static inline size_t
241DYNARRAY_NAME (size) (const struct DYNARRAY_STRUCT *list)
242{
243 return list->u.dynarray_header.used;
244}
245
246/* Return a pointer to the array element at INDEX. Terminate the
247 process if INDEX is out of bounds. */
248__nonnull ((1))
249static inline DYNARRAY_ELEMENT *
250DYNARRAY_NAME (at) (struct DYNARRAY_STRUCT *list, size_t index)
251{
252 if (__glibc_unlikely (index >= DYNARRAY_NAME (size) (list)))
253 __libc_dynarray_at_failure (DYNARRAY_NAME (size) (list), index);
254 return list->u.dynarray_header.array + index;
255}
256
257/* Return a pointer to the first array element, if any. For a
258 zero-length array, the pointer can be NULL even though the dynamic
259 array has not entered the failure state. */
260__nonnull ((1))
261static inline DYNARRAY_ELEMENT *
262DYNARRAY_NAME (begin) (struct DYNARRAY_STRUCT *list)
263{
264 return list->u.dynarray_header.array;
265}
266
267/* Return a pointer one element past the last array element. For a
268 zero-length array, the pointer can be NULL even though the dynamic
269 array has not entered the failure state. */
270__nonnull ((1))
271static inline DYNARRAY_ELEMENT *
272DYNARRAY_NAME (end) (struct DYNARRAY_STRUCT *list)
273{
274 return list->u.dynarray_header.array + list->u.dynarray_header.used;
275}
276
277/* Internal function. Slow path for the add function below. */
278static void
279DYNARRAY_NAME (add__) (struct DYNARRAY_STRUCT *list, DYNARRAY_ELEMENT item)
280{
281 if (__glibc_unlikely
282 (!__libc_dynarray_emplace_enlarge (&list->u.dynarray_abstract,
283 DYNARRAY_SCRATCH (list),
284 sizeof (DYNARRAY_ELEMENT))))
285 {
286 DYNARRAY_NAME (mark_failed) (list);
287 return;
288 }
289
290 /* Copy the new element and increase the array length. */
291 list->u.dynarray_header.array[list->u.dynarray_header.used++] = item;
292}
293
294/* Add ITEM at the end of the array, enlarging it by one element.
295 Mark *LIST as failed if the dynamic array allocation size cannot be
296 increased. */
297__nonnull ((1))
298static inline void
299DYNARRAY_NAME (add) (struct DYNARRAY_STRUCT *list, DYNARRAY_ELEMENT item)
300{
301 /* Do nothing in case of previous error. */
302 if (DYNARRAY_NAME (has_failed) (list))
303 return;
304
305 /* Enlarge the array if necessary. */
306 if (__glibc_unlikely (list->u.dynarray_header.used
307 == list->u.dynarray_header.allocated))
308 {
309 DYNARRAY_NAME (add__) (list, item);
310 return;
311 }
312
313 /* Copy the new element and increase the array length. */
314 list->u.dynarray_header.array[list->u.dynarray_header.used++] = item;
315}
316
317/* Internal function. Building block for the emplace functions below.
318 Assumes space for one more element in *LIST. */
319static inline DYNARRAY_ELEMENT *
320DYNARRAY_NAME (emplace__tail__) (struct DYNARRAY_STRUCT *list)
321{
322 DYNARRAY_ELEMENT *result
323 = &list->u.dynarray_header.array[list->u.dynarray_header.used];
324 ++list->u.dynarray_header.used;
325#if defined (DYNARRAY_ELEMENT_INIT)
326 DYNARRAY_ELEMENT_INIT (result);
327#elif defined (DYNARRAY_ELEMENT_FREE)
328 memset (result, 0, sizeof (*result));
329#endif
330 return result;
331}
332
333/* Internal function. Slow path for the emplace function below. */
334static DYNARRAY_ELEMENT *
335DYNARRAY_NAME (emplace__) (struct DYNARRAY_STRUCT *list)
336{
337 if (__glibc_unlikely
338 (!__libc_dynarray_emplace_enlarge (&list->u.dynarray_abstract,
339 DYNARRAY_SCRATCH (list),
340 sizeof (DYNARRAY_ELEMENT))))
341 {
342 DYNARRAY_NAME (mark_failed) (list);
343 return NULL;
344 }
345 return DYNARRAY_NAME (emplace__tail__) (list);
346}
347
348/* Allocate a place for a new element in *LIST and return a pointer to
349 it. The pointer can be NULL if the dynamic array cannot be
350 enlarged due to a memory allocation failure. */
351__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1))
352static
353/* Avoid inlining with the larger initialization code. */
354#if !(defined (DYNARRAY_ELEMENT_INIT) || defined (DYNARRAY_ELEMENT_FREE))
355inline
356#endif
357DYNARRAY_ELEMENT *
358DYNARRAY_NAME (emplace) (struct DYNARRAY_STRUCT *list)
359{
360 /* Do nothing in case of previous error. */
361 if (DYNARRAY_NAME (has_failed) (list))
362 return NULL;
363
364 /* Enlarge the array if necessary. */
365 if (__glibc_unlikely (list->u.dynarray_header.used
366 == list->u.dynarray_header.allocated))
367 return (DYNARRAY_NAME (emplace__) (list));
368 return DYNARRAY_NAME (emplace__tail__) (list);
369}
370
371/* Change the size of *LIST to SIZE. If SIZE is larger than the
372 existing size, new elements are added (which can be initialized).
373 Otherwise, the list is truncated, and elements are freed. Return
374 false on memory allocation failure (and mark *LIST as failed). */
375__attribute_maybe_unused__ __nonnull ((1))
376static bool
377DYNARRAY_NAME (resize) (struct DYNARRAY_STRUCT *list, size_t size)
378{
379 if (size > list->u.dynarray_header.used)
380 {
381 bool ok;
382#if defined (DYNARRAY_ELEMENT_INIT)
383 /* The new elements have to be initialized. */
384 size_t old_size = list->u.dynarray_header.used;
385 ok = __libc_dynarray_resize (&list->u.dynarray_abstract,
386 size, DYNARRAY_SCRATCH (list),
387 sizeof (DYNARRAY_ELEMENT));
388 if (ok)
389 for (size_t i = old_size; i < size; ++i)
390 {
391 DYNARRAY_ELEMENT_INIT (&list->u.dynarray_header.array[i]);
392 }
393#elif defined (DYNARRAY_ELEMENT_FREE)
394 /* Zero initialization is needed so that the elements can be
395 safely freed. */
396 ok = __libc_dynarray_resize_clear
397 (&list->u.dynarray_abstract, size,
398 DYNARRAY_SCRATCH (list), sizeof (DYNARRAY_ELEMENT));
399#else
400 ok = __libc_dynarray_resize (&list->u.dynarray_abstract,
401 size, DYNARRAY_SCRATCH (list),
402 sizeof (DYNARRAY_ELEMENT));
403#endif
404 if (__glibc_unlikely (!ok))
405 DYNARRAY_NAME (mark_failed) (list);
406 return ok;
407 }
408 else
409 {
410 /* The list has shrunk in size. Free the removed elements. */
411 DYNARRAY_NAME (free__elements__)
412 (list->u.dynarray_header.array + size,
413 list->u.dynarray_header.used - size);
414 list->u.dynarray_header.used = size;
415 return true;
416 }
417}
418
419/* Remove the last element of LIST if it is present. */
420__attribute_maybe_unused__ __nonnull ((1))
421static void
422DYNARRAY_NAME (remove_last) (struct DYNARRAY_STRUCT *list)
423{
424 /* used > 0 implies that the array is the non-failed state. */
425 if (list->u.dynarray_header.used > 0)
426 {
427 size_t new_length = list->u.dynarray_header.used - 1;
428#ifdef DYNARRAY_ELEMENT_FREE
429 DYNARRAY_ELEMENT_FREE (&list->u.dynarray_header.array[new_length]);
430#endif
431 list->u.dynarray_header.used = new_length;
432 }
433}
434
435/* Remove all elements from the list. The elements are freed, but the
436 list itself is not. */
437__attribute_maybe_unused__ __nonnull ((1))
438static void
439DYNARRAY_NAME (clear) (struct DYNARRAY_STRUCT *list)
440{
441 /* free__elements__ does nothing if the list is in the failed
442 state. */
443 DYNARRAY_NAME (free__elements__)
444 (list->u.dynarray_header.array, list->u.dynarray_header.used);
445 list->u.dynarray_header.used = 0;
446}
447
448#ifdef DYNARRAY_FINAL_TYPE
449/* Transfer the dynamic array to a permanent location at *RESULT.
450 Returns true on success on false on allocation failure. In either
451 case, *LIST is re-initialized and can be reused. A NULL pointer is
452 stored in *RESULT if LIST refers to an empty list. On success, the
453 pointer in *RESULT is heap-allocated and must be deallocated using
454 free. */
455__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1, 2))
456static bool
457DYNARRAY_NAME (finalize) (struct DYNARRAY_STRUCT *list,
458 DYNARRAY_FINAL_TYPE *result)
459{
460 struct dynarray_finalize_result res;
461 if (__libc_dynarray_finalize (&list->u.dynarray_abstract,
462 DYNARRAY_SCRATCH (list),
463 sizeof (DYNARRAY_ELEMENT), &res))
464 {
465 /* On success, the result owns all the data. */
466 DYNARRAY_NAME (init) (list);
467 *result = (DYNARRAY_FINAL_TYPE) { res.array, res.length };
468 return true;
469 }
470 else
471 {
472 /* On error, we need to free all data. */
473 DYNARRAY_FREE (list);
474 errno = ENOMEM;
475 return false;
476 }
477}
478#else /* !DYNARRAY_FINAL_TYPE */
479/* Transfer the dynamic array to a heap-allocated array and return a
480 pointer to it. The pointer is NULL if memory allocation fails, or
481 if the array is empty, so this function should be used only for
482 arrays which are known not be empty (usually because they always
483 have a sentinel at the end). If LENGTHP is not NULL, the array
484 length is written to *LENGTHP. *LIST is re-initialized and can be
485 reused. */
486__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1))
487static DYNARRAY_ELEMENT *
488DYNARRAY_NAME (finalize) (struct DYNARRAY_STRUCT *list, size_t *lengthp)
489{
490 struct dynarray_finalize_result res;
491 if (__libc_dynarray_finalize (&list->u.dynarray_abstract,
492 DYNARRAY_SCRATCH (list),
493 sizeof (DYNARRAY_ELEMENT), &res))
494 {
495 /* On success, the result owns all the data. */
496 DYNARRAY_NAME (init) (list);
497 if (lengthp != NULL)
498 *lengthp = res.length;
499 return res.array;
500 }
501 else
502 {
503 /* On error, we need to free all data. */
504 DYNARRAY_FREE (list);
505 errno = ENOMEM;
506 return NULL;
507 }
508}
509#endif /* !DYNARRAY_FINAL_TYPE */
510
511/* Undo macro definitions. */
512
513#undef DYNARRAY_CONCAT0
514#undef DYNARRAY_CONCAT1
515#undef DYNARRAY_NAME
516#undef DYNARRAY_SCRATCH
517#undef DYNARRAY_HAVE_SCRATCH
518
519#undef DYNARRAY_STRUCT
520#undef DYNARRAY_ELEMENT
521#undef DYNARRAY_PREFIX
522#undef DYNARRAY_ELEMENT_FREE
523#undef DYNARRAY_ELEMENT_INIT
524#undef DYNARRAY_INITIAL_SIZE
525#undef DYNARRAY_FINAL_TYPE
diff --git a/lib/malloc/dynarray.h b/lib/malloc/dynarray.h
new file mode 100644
index 00000000000..84e4394bf32
--- /dev/null
+++ b/lib/malloc/dynarray.h
@@ -0,0 +1,178 @@
1/* Type-safe arrays which grow dynamically. Shared definitions.
2 Copyright (C) 2017-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library.
4
5 The GNU C Library is free software; you can redistribute it and/or
6 modify it under the terms of the GNU General Public
7 License as published by the Free Software Foundation; either
8 version 3 of the License, or (at your option) any later version.
9
10 The GNU C Library is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 General Public License for more details.
14
15 You should have received a copy of the GNU General Public
16 License along with the GNU C Library; if not, see
17 <https://www.gnu.org/licenses/>. */
18
19/* To use the dynarray facility, you need to include
20 <malloc/dynarray-skeleton.c> and define the parameter macros
21 documented in that file.
22
23 A minimal example which provides a growing list of integers can be
24 defined like this:
25
26 struct int_array
27 {
28 // Pointer to result array followed by its length,
29 // as required by DYNARRAY_FINAL_TYPE.
30 int *array;
31 size_t length;
32 };
33
34 #define DYNARRAY_STRUCT dynarray_int
35 #define DYNARRAY_ELEMENT int
36 #define DYNARRAY_PREFIX dynarray_int_
37 #define DYNARRAY_FINAL_TYPE struct int_array
38 #include <malloc/dynarray-skeleton.c>
39
40 To create a three-element array with elements 1, 2, 3, use this
41 code:
42
43 struct dynarray_int dyn;
44 dynarray_int_init (&dyn);
45 for (int i = 1; i <= 3; ++i)
46 {
47 int *place = dynarray_int_emplace (&dyn);
48 assert (place != NULL);
49 *place = i;
50 }
51 struct int_array result;
52 bool ok = dynarray_int_finalize (&dyn, &result);
53 assert (ok);
54 assert (result.length == 3);
55 assert (result.array[0] == 1);
56 assert (result.array[1] == 2);
57 assert (result.array[2] == 3);
58 free (result.array);
59
60 If the elements contain resources which must be freed, define
61 DYNARRAY_ELEMENT_FREE appropriately, like this:
62
63 struct str_array
64 {
65 char **array;
66 size_t length;
67 };
68
69 #define DYNARRAY_STRUCT dynarray_str
70 #define DYNARRAY_ELEMENT char *
71 #define DYNARRAY_ELEMENT_FREE(ptr) free (*ptr)
72 #define DYNARRAY_PREFIX dynarray_str_
73 #define DYNARRAY_FINAL_TYPE struct str_array
74 #include <malloc/dynarray-skeleton.c>
75
76 Compared to scratch buffers, dynamic arrays have the following
77 features:
78
79 - They have an element type, and are not just an untyped buffer of
80 bytes.
81
82 - When growing, previously stored elements are preserved. (It is
83 expected that scratch_buffer_grow_preserve and
84 scratch_buffer_set_array_size eventually go away because all
85 current users are moved to dynamic arrays.)
86
87 - Scratch buffers have a more aggressive growth policy because
88 growing them typically means a retry of an operation (across an
89 NSS service module boundary), which is expensive.
90
91 - For the same reason, scratch buffers have a much larger initial
92 stack allocation. */
93
94#ifndef _DYNARRAY_H
95#define _DYNARRAY_H
96
97#include <stdbool.h>
98#include <stddef.h>
99#include <string.h>
100
101struct dynarray_header
102{
103 size_t used;
104 size_t allocated;
105 void *array;
106};
107
108/* Marker used in the allocated member to indicate that an error was
109 encountered. */
110static inline size_t
111__dynarray_error_marker (void)
112{
113 return -1;
114}
115
116/* Internal function. See the has_failed function in
117 dynarray-skeleton.c. */
118static inline bool
119__dynarray_error (struct dynarray_header *list)
120{
121 return list->allocated == __dynarray_error_marker ();
122}
123
124/* Internal function. Enlarge the dynamically allocated area of the
125 array to make room for one more element. SCRATCH is a pointer to
126 the scratch area (which is not heap-allocated and must not be
127 freed). ELEMENT_SIZE is the size, in bytes, of one element.
128 Return false on failure, true on success. */
129bool __libc_dynarray_emplace_enlarge (struct dynarray_header *,
130 void *scratch, size_t element_size);
131
132/* Internal function. Enlarge the dynamically allocated area of the
133 array to make room for at least SIZE elements (which must be larger
134 than the existing used part of the dynamic array). SCRATCH is a
135 pointer to the scratch area (which is not heap-allocated and must
136 not be freed). ELEMENT_SIZE is the size, in bytes, of one element.
137 Return false on failure, true on success. */
138bool __libc_dynarray_resize (struct dynarray_header *, size_t size,
139 void *scratch, size_t element_size);
140
141/* Internal function. Like __libc_dynarray_resize, but clear the new
142 part of the dynamic array. */
143bool __libc_dynarray_resize_clear (struct dynarray_header *, size_t size,
144 void *scratch, size_t element_size);
145
146/* Internal type. */
147struct dynarray_finalize_result
148{
149 void *array;
150 size_t length;
151};
152
153/* Internal function. Copy the dynamically-allocated area to an
154 explicitly-sized heap allocation. SCRATCH is a pointer to the
155 embedded scratch space. ELEMENT_SIZE is the size, in bytes, of the
156 element type. On success, true is returned, and pointer and length
157 are written to *RESULT. On failure, false is returned. The caller
158 has to take care of some of the memory management; this function is
159 expected to be called from dynarray-skeleton.c. */
160bool __libc_dynarray_finalize (struct dynarray_header *list, void *scratch,
161 size_t element_size,
162 struct dynarray_finalize_result *result);
163
164
165/* Internal function. Terminate the process after an index error.
166 SIZE is the number of elements of the dynamic array. INDEX is the
167 lookup index which triggered the failure. */
168_Noreturn void __libc_dynarray_at_failure (size_t size, size_t index);
169
170#ifndef _ISOMAC
171libc_hidden_proto (__libc_dynarray_emplace_enlarge)
172libc_hidden_proto (__libc_dynarray_resize)
173libc_hidden_proto (__libc_dynarray_resize_clear)
174libc_hidden_proto (__libc_dynarray_finalize)
175libc_hidden_proto (__libc_dynarray_at_failure)
176#endif
177
178#endif /* _DYNARRAY_H */
diff --git a/lib/malloc/dynarray_at_failure.c b/lib/malloc/dynarray_at_failure.c
new file mode 100644
index 00000000000..a4424593748
--- /dev/null
+++ b/lib/malloc/dynarray_at_failure.c
@@ -0,0 +1,35 @@
1/* Report an dynamic array index out of bounds condition.
2 Copyright (C) 2017-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library.
4
5 The GNU C Library is free software; you can redistribute it and/or
6 modify it under the terms of the GNU General Public
7 License as published by the Free Software Foundation; either
8 version 3 of the License, or (at your option) any later version.
9
10 The GNU C Library is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 General Public License for more details.
14
15 You should have received a copy of the GNU General Public
16 License along with the GNU C Library; if not, see
17 <https://www.gnu.org/licenses/>. */
18
19#include <dynarray.h>
20#include <stdio.h>
21#include <stdlib.h>
22
23void
24__libc_dynarray_at_failure (size_t size, size_t index)
25{
26#ifdef _LIBC
27 char buf[200];
28 __snprintf (buf, sizeof (buf), "Fatal glibc error: "
29 "array index %zu not less than array length %zu\n",
30 index, size);
31#else
32 abort ();
33#endif
34}
35libc_hidden_def (__libc_dynarray_at_failure)
diff --git a/lib/malloc/dynarray_emplace_enlarge.c b/lib/malloc/dynarray_emplace_enlarge.c
new file mode 100644
index 00000000000..7ac4b6db403
--- /dev/null
+++ b/lib/malloc/dynarray_emplace_enlarge.c
@@ -0,0 +1,73 @@
1/* Increase the size of a dynamic array in preparation of an emplace operation.
2 Copyright (C) 2017-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library.
4
5 The GNU C Library is free software; you can redistribute it and/or
6 modify it under the terms of the GNU General Public
7 License as published by the Free Software Foundation; either
8 version 3 of the License, or (at your option) any later version.
9
10 The GNU C Library is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 General Public License for more details.
14
15 You should have received a copy of the GNU General Public
16 License along with the GNU C Library; if not, see
17 <https://www.gnu.org/licenses/>. */
18
19#include <dynarray.h>
20#include <errno.h>
21#include <intprops.h>
22#include <stdlib.h>
23#include <string.h>
24
25bool
26__libc_dynarray_emplace_enlarge (struct dynarray_header *list,
27 void *scratch, size_t element_size)
28{
29 size_t new_allocated;
30 if (list->allocated == 0)
31 {
32 /* No scratch buffer provided. Choose a reasonable default
33 size. */
34 if (element_size < 4)
35 new_allocated = 16;
36 else if (element_size < 8)
37 new_allocated = 8;
38 else
39 new_allocated = 4;
40 }
41 else
42 /* Increase the allocated size, using an exponential growth
43 policy. */
44 {
45 new_allocated = list->allocated + list->allocated / 2 + 1;
46 if (new_allocated <= list->allocated)
47 {
48 /* Overflow. */
49 __set_errno (ENOMEM);
50 return false;
51 }
52 }
53
54 size_t new_size;
55 if (INT_MULTIPLY_WRAPV (new_allocated, element_size, &new_size))
56 return false;
57 void *new_array;
58 if (list->array == scratch)
59 {
60 /* The previous array was not heap-allocated. */
61 new_array = malloc (new_size);
62 if (new_array != NULL && list->array != NULL)
63 memcpy (new_array, list->array, list->used * element_size);
64 }
65 else
66 new_array = realloc (list->array, new_size);
67 if (new_array == NULL)
68 return false;
69 list->array = new_array;
70 list->allocated = new_allocated;
71 return true;
72}
73libc_hidden_def (__libc_dynarray_emplace_enlarge)
diff --git a/lib/malloc/dynarray_finalize.c b/lib/malloc/dynarray_finalize.c
new file mode 100644
index 00000000000..be9441e313d
--- /dev/null
+++ b/lib/malloc/dynarray_finalize.c
@@ -0,0 +1,62 @@
1/* Copy the dynamically-allocated area to an explicitly-sized heap allocation.
2 Copyright (C) 2017-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library.
4
5 The GNU C Library is free software; you can redistribute it and/or
6 modify it under the terms of the GNU General Public
7 License as published by the Free Software Foundation; either
8 version 3 of the License, or (at your option) any later version.
9
10 The GNU C Library is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 General Public License for more details.
14
15 You should have received a copy of the GNU General Public
16 License along with the GNU C Library; if not, see
17 <https://www.gnu.org/licenses/>. */
18
19#include <dynarray.h>
20#include <stdlib.h>
21#include <string.h>
22
23bool
24__libc_dynarray_finalize (struct dynarray_header *list,
25 void *scratch, size_t element_size,
26 struct dynarray_finalize_result *result)
27{
28 if (__dynarray_error (list))
29 /* The caller will reported the deferred error. */
30 return false;
31
32 size_t used = list->used;
33
34 /* Empty list. */
35 if (used == 0)
36 {
37 /* An empty list could still be backed by a heap-allocated
38 array. Free it if necessary. */
39 if (list->array != scratch)
40 free (list->array);
41 *result = (struct dynarray_finalize_result) { NULL, 0 };
42 return true;
43 }
44
45 size_t allocation_size = used * element_size;
46 void *heap_array = malloc (allocation_size);
47 if (heap_array != NULL)
48 {
49 /* The new array takes ownership of the strings. */
50 if (list->array != NULL)
51 memcpy (heap_array, list->array, allocation_size);
52 if (list->array != scratch)
53 free (list->array);
54 *result = (struct dynarray_finalize_result)
55 { .array = heap_array, .length = used };
56 return true;
57 }
58 else
59 /* The caller will perform the freeing operation. */
60 return false;
61}
62libc_hidden_def (__libc_dynarray_finalize)
diff --git a/lib/malloc/dynarray_resize.c b/lib/malloc/dynarray_resize.c
new file mode 100644
index 00000000000..92bbddd4461
--- /dev/null
+++ b/lib/malloc/dynarray_resize.c
@@ -0,0 +1,64 @@
1/* Increase the size of a dynamic array.
2 Copyright (C) 2017-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library.
4
5 The GNU C Library is free software; you can redistribute it and/or
6 modify it under the terms of the GNU General Public
7 License as published by the Free Software Foundation; either
8 version 3 of the License, or (at your option) any later version.
9
10 The GNU C Library is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 General Public License for more details.
14
15 You should have received a copy of the GNU General Public
16 License along with the GNU C Library; if not, see
17 <https://www.gnu.org/licenses/>. */
18
19#include <dynarray.h>
20#include <errno.h>
21#include <intprops.h>
22#include <stdlib.h>
23#include <string.h>
24
25bool
26__libc_dynarray_resize (struct dynarray_header *list, size_t size,
27 void *scratch, size_t element_size)
28{
29 /* The existing allocation provides sufficient room. */
30 if (size <= list->allocated)
31 {
32 list->used = size;
33 return true;
34 }
35
36 /* Otherwise, use size as the new allocation size. The caller is
37 expected to provide the final size of the array, so there is no
38 over-allocation here. */
39
40 size_t new_size_bytes;
41 if (INT_MULTIPLY_WRAPV (size, element_size, &new_size_bytes))
42 {
43 /* Overflow. */
44 __set_errno (ENOMEM);
45 return false;
46 }
47 void *new_array;
48 if (list->array == scratch)
49 {
50 /* The previous array was not heap-allocated. */
51 new_array = malloc (new_size_bytes);
52 if (new_array != NULL && list->array != NULL)
53 memcpy (new_array, list->array, list->used * element_size);
54 }
55 else
56 new_array = realloc (list->array, new_size_bytes);
57 if (new_array == NULL)
58 return false;
59 list->array = new_array;
60 list->allocated = size;
61 list->used = size;
62 return true;
63}
64libc_hidden_def (__libc_dynarray_resize)
diff --git a/lib/malloc/dynarray_resize_clear.c b/lib/malloc/dynarray_resize_clear.c
new file mode 100644
index 00000000000..99c2cc87c31
--- /dev/null
+++ b/lib/malloc/dynarray_resize_clear.c
@@ -0,0 +1,35 @@
1/* Increase the size of a dynamic array and clear the new part.
2 Copyright (C) 2017-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library.
4
5 The GNU C Library is free software; you can redistribute it and/or
6 modify it under the terms of the GNU General Public
7 License as published by the Free Software Foundation; either
8 version 3 of the License, or (at your option) any later version.
9
10 The GNU C Library is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 General Public License for more details.
14
15 You should have received a copy of the GNU General Public
16 License along with the GNU C Library; if not, see
17 <https://www.gnu.org/licenses/>. */
18
19#include <dynarray.h>
20#include <string.h>
21
22bool
23__libc_dynarray_resize_clear (struct dynarray_header *list, size_t size,
24 void *scratch, size_t element_size)
25{
26 size_t old_size = list->used;
27 if (!__libc_dynarray_resize (list, size, scratch, element_size))
28 return false;
29 /* __libc_dynarray_resize already checked for overflow. */
30 char *array = list->array;
31 memset (array + (old_size * element_size), 0,
32 (size - old_size) * element_size);
33 return true;
34}
35libc_hidden_def (__libc_dynarray_resize_clear)
diff --git a/lib/malloc/scratch_buffer_grow.c b/lib/malloc/scratch_buffer_grow.c
index 41befe3d65f..e7606d81cd7 100644
--- a/lib/malloc/scratch_buffer_grow.c
+++ b/lib/malloc/scratch_buffer_grow.c
@@ -1,5 +1,5 @@
1/* Variable-sized buffer with on-stack default allocation. 1/* Variable-sized buffer with on-stack default allocation.
2 Copyright (C) 2015-2020 Free Software Foundation, Inc. 2 Copyright (C) 2015-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library. 3 This file is part of the GNU C Library.
4 4
5 The GNU C Library is free software; you can redistribute it and/or 5 The GNU C Library is free software; you can redistribute it and/or
diff --git a/lib/malloc/scratch_buffer_grow_preserve.c b/lib/malloc/scratch_buffer_grow_preserve.c
index aef232938d5..59f8c710001 100644
--- a/lib/malloc/scratch_buffer_grow_preserve.c
+++ b/lib/malloc/scratch_buffer_grow_preserve.c
@@ -1,5 +1,5 @@
1/* Variable-sized buffer with on-stack default allocation. 1/* Variable-sized buffer with on-stack default allocation.
2 Copyright (C) 2015-2020 Free Software Foundation, Inc. 2 Copyright (C) 2015-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library. 3 This file is part of the GNU C Library.
4 4
5 The GNU C Library is free software; you can redistribute it and/or 5 The GNU C Library is free software; you can redistribute it and/or
diff --git a/lib/malloc/scratch_buffer_set_array_size.c b/lib/malloc/scratch_buffer_set_array_size.c
index 5f5e4c24f5a..e2b9f31211a 100644
--- a/lib/malloc/scratch_buffer_set_array_size.c
+++ b/lib/malloc/scratch_buffer_set_array_size.c
@@ -1,5 +1,5 @@
1/* Variable-sized buffer with on-stack default allocation. 1/* Variable-sized buffer with on-stack default allocation.
2 Copyright (C) 2015-2020 Free Software Foundation, Inc. 2 Copyright (C) 2015-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library. 3 This file is part of the GNU C Library.
4 4
5 The GNU C Library is free software; you can redistribute it and/or 5 The GNU C Library is free software; you can redistribute it and/or
diff --git a/lib/mini-gmp.c b/lib/mini-gmp.c
index d34fe525e4c..de061e673ac 100644
--- a/lib/mini-gmp.c
+++ b/lib/mini-gmp.c
@@ -4521,7 +4521,7 @@ mpz_export (void *r, size_t *countp, int order, size_t size, int endian,
4521 mp_size_t un; 4521 mp_size_t un;
4522 4522
4523 if (nails != 0) 4523 if (nails != 0)
4524 gmp_die ("mpz_import: Nails not supported."); 4524 gmp_die ("mpz_export: Nails not supported.");
4525 4525
4526 assert (order == 1 || order == -1); 4526 assert (order == 1 || order == -1);
4527 assert (endian >= -1 && endian <= 1); 4527 assert (endian >= -1 && endian <= 1);
diff --git a/lib/mktime-internal.h b/lib/mktime-internal.h
index b765a37ee34..9c447bd7b05 100644
--- a/lib/mktime-internal.h
+++ b/lib/mktime-internal.h
@@ -1,5 +1,5 @@
1/* Internals of mktime and related functions 1/* Internals of mktime and related functions
2 Copyright 2016-2020 Free Software Foundation, Inc. 2 Copyright 2016-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library. 3 This file is part of the GNU C Library.
4 Contributed by Paul Eggert <eggert@cs.ucla.edu>. 4 Contributed by Paul Eggert <eggert@cs.ucla.edu>.
5 5
diff --git a/lib/nstrftime.c b/lib/nstrftime.c
index 8ba6975552b..2f5e4fbe639 100644
--- a/lib/nstrftime.c
+++ b/lib/nstrftime.c
@@ -19,7 +19,7 @@
19# define USE_IN_EXTENDED_LOCALE_MODEL 1 19# define USE_IN_EXTENDED_LOCALE_MODEL 1
20# define HAVE_STRUCT_ERA_ENTRY 1 20# define HAVE_STRUCT_ERA_ENTRY 1
21# define HAVE_TM_GMTOFF 1 21# define HAVE_TM_GMTOFF 1
22# define HAVE_TM_ZONE 1 22# define HAVE_STRUCT_TM_TM_ZONE 1
23# define HAVE_TZNAME 1 23# define HAVE_TZNAME 1
24# include "../locale/localeinfo.h" 24# include "../locale/localeinfo.h"
25#else 25#else
@@ -499,7 +499,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
499#endif 499#endif
500 500
501 zone = NULL; 501 zone = NULL;
502#if HAVE_TM_ZONE 502#if HAVE_STRUCT_TM_TM_ZONE
503 /* The POSIX test suite assumes that setting 503 /* The POSIX test suite assumes that setting
504 the environment variable TZ to a new value before calling strftime() 504 the environment variable TZ to a new value before calling strftime()
505 will influence the result (the %Z format) even if the information in 505 will influence the result (the %Z format) even if the information in
@@ -516,7 +516,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
516 } 516 }
517 else 517 else
518 { 518 {
519# if !HAVE_TM_ZONE 519# if !HAVE_STRUCT_TM_TM_ZONE
520 /* Infer the zone name from *TZ instead of from TZNAME. */ 520 /* Infer the zone name from *TZ instead of from TZNAME. */
521 tzname_vec = tz->tzname_copy; 521 tzname_vec = tz->tzname_copy;
522# endif 522# endif
diff --git a/lib/regex.c b/lib/regex.c
index 88173bb1052..f76a416b3b5 100644
--- a/lib/regex.c
+++ b/lib/regex.c
@@ -1,5 +1,5 @@
1/* Extended regular expression matching and search library. 1/* Extended regular expression matching and search library.
2 Copyright (C) 2002-2020 Free Software Foundation, Inc. 2 Copyright (C) 2002-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library. 3 This file is part of the GNU C Library.
4 Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. 4 Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.
5 5
diff --git a/lib/regex_internal.h b/lib/regex_internal.h
index be2fa4fe78e..4c634edcbfa 100644
--- a/lib/regex_internal.h
+++ b/lib/regex_internal.h
@@ -32,6 +32,7 @@
32#include <stdbool.h> 32#include <stdbool.h>
33#include <stdint.h> 33#include <stdint.h>
34 34
35#include <dynarray.h>
35#include <intprops.h> 36#include <intprops.h>
36#include <verify.h> 37#include <verify.h>
37 38
@@ -444,25 +445,6 @@ typedef struct re_dfa_t re_dfa_t;
444#define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) 445#define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx))
445#define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) 446#define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx))
446 447
447#if defined _LIBC || HAVE_ALLOCA
448# include <alloca.h>
449#endif
450
451#ifndef _LIBC
452# if HAVE_ALLOCA
453/* The OS usually guarantees only one guard page at the bottom of the stack,
454 and a page size can be as small as 4096 bytes. So we cannot safely
455 allocate anything larger than 4096 bytes. Also care for the possibility
456 of a few compiler-allocated temporary stack slots. */
457# define __libc_use_alloca(n) ((n) < 4032)
458# else
459/* alloca is implemented with malloc, so just use malloc. */
460# define __libc_use_alloca(n) 0
461# undef alloca
462# define alloca(n) malloc (n)
463# endif
464#endif
465
466#ifdef _LIBC 448#ifdef _LIBC
467# define MALLOC_0_IS_NONNULL 1 449# define MALLOC_0_IS_NONNULL 1
468#elif !defined MALLOC_0_IS_NONNULL 450#elif !defined MALLOC_0_IS_NONNULL
@@ -848,12 +830,14 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx)
848} 830}
849#endif /* RE_ENABLE_I18N */ 831#endif /* RE_ENABLE_I18N */
850 832
851#ifndef FALLTHROUGH 833#ifdef _LIBC
852# if (__GNUC__ >= 7) || (__clang_major__ >= 10) 834# if __GNUC__ >= 7
853# define FALLTHROUGH __attribute__ ((__fallthrough__)) 835# define FALLTHROUGH __attribute__ ((__fallthrough__))
854# else 836# else
855# define FALLTHROUGH ((void) 0) 837# define FALLTHROUGH ((void) 0)
856# endif 838# endif
839#else
840# include "attribute.h"
857#endif 841#endif
858 842
859#endif /* _REGEX_INTERNAL_H */ 843#endif /* _REGEX_INTERNAL_H */
diff --git a/lib/regexec.c b/lib/regexec.c
index 395e37db591..15dc57bd0e6 100644
--- a/lib/regexec.c
+++ b/lib/regexec.c
@@ -1,5 +1,5 @@
1/* Extended regular expression matching and search library. 1/* Extended regular expression matching and search library.
2 Copyright (C) 2002-2020 Free Software Foundation, Inc. 2 Copyright (C) 2002-2021 Free Software Foundation, Inc.
3 This file is part of the GNU C Library. 3 This file is part of the GNU C Library.
4 Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. 4 Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.
5 5
@@ -1355,6 +1355,12 @@ pop_fail_stack (struct re_fail_stack_t *fs, Idx *pidx, Idx nregs,
1355 return fs->stack[num].node; 1355 return fs->stack[num].node;
1356} 1356}
1357 1357
1358
1359#define DYNARRAY_STRUCT regmatch_list
1360#define DYNARRAY_ELEMENT regmatch_t
1361#define DYNARRAY_PREFIX regmatch_list_
1362#include <malloc/dynarray-skeleton.c>
1363
1358/* Set the positions where the subexpressions are starts/ends to registers 1364/* Set the positions where the subexpressions are starts/ends to registers
1359 PMATCH. 1365 PMATCH.
1360 Note: We assume that pmatch[0] is already set, and 1366 Note: We assume that pmatch[0] is already set, and
@@ -1370,8 +1376,8 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
1370 re_node_set eps_via_nodes; 1376 re_node_set eps_via_nodes;
1371 struct re_fail_stack_t *fs; 1377 struct re_fail_stack_t *fs;
1372 struct re_fail_stack_t fs_body = { 0, 2, NULL }; 1378 struct re_fail_stack_t fs_body = { 0, 2, NULL };
1373 regmatch_t *prev_idx_match; 1379 struct regmatch_list prev_match;
1374 bool prev_idx_match_malloced = false; 1380 regmatch_list_init (&prev_match);
1375 1381
1376 DEBUG_ASSERT (nmatch > 1); 1382 DEBUG_ASSERT (nmatch > 1);
1377 DEBUG_ASSERT (mctx->state_log != NULL); 1383 DEBUG_ASSERT (mctx->state_log != NULL);
@@ -1388,18 +1394,13 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
1388 cur_node = dfa->init_node; 1394 cur_node = dfa->init_node;
1389 re_node_set_init_empty (&eps_via_nodes); 1395 re_node_set_init_empty (&eps_via_nodes);
1390 1396
1391 if (__libc_use_alloca (nmatch * sizeof (regmatch_t))) 1397 if (!regmatch_list_resize (&prev_match, nmatch))
1392 prev_idx_match = (regmatch_t *) alloca (nmatch * sizeof (regmatch_t));
1393 else
1394 { 1398 {
1395 prev_idx_match = re_malloc (regmatch_t, nmatch); 1399 regmatch_list_free (&prev_match);
1396 if (prev_idx_match == NULL) 1400 free_fail_stack_return (fs);
1397 { 1401 return REG_ESPACE;
1398 free_fail_stack_return (fs);
1399 return REG_ESPACE;
1400 }
1401 prev_idx_match_malloced = true;
1402 } 1402 }
1403 regmatch_t *prev_idx_match = regmatch_list_begin (&prev_match);
1403 memcpy (prev_idx_match, pmatch, sizeof (regmatch_t) * nmatch); 1404 memcpy (prev_idx_match, pmatch, sizeof (regmatch_t) * nmatch);
1404 1405
1405 for (idx = pmatch[0].rm_so; idx <= pmatch[0].rm_eo ;) 1406 for (idx = pmatch[0].rm_so; idx <= pmatch[0].rm_eo ;)
@@ -1417,8 +1418,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
1417 if (reg_idx == nmatch) 1418 if (reg_idx == nmatch)
1418 { 1419 {
1419 re_node_set_free (&eps_via_nodes); 1420 re_node_set_free (&eps_via_nodes);
1420 if (prev_idx_match_malloced) 1421 regmatch_list_free (&prev_match);
1421 re_free (prev_idx_match);
1422 return free_fail_stack_return (fs); 1422 return free_fail_stack_return (fs);
1423 } 1423 }
1424 cur_node = pop_fail_stack (fs, &idx, nmatch, pmatch, 1424 cur_node = pop_fail_stack (fs, &idx, nmatch, pmatch,
@@ -1427,8 +1427,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
1427 else 1427 else
1428 { 1428 {
1429 re_node_set_free (&eps_via_nodes); 1429 re_node_set_free (&eps_via_nodes);
1430 if (prev_idx_match_malloced) 1430 regmatch_list_free (&prev_match);
1431 re_free (prev_idx_match);
1432 return REG_NOERROR; 1431 return REG_NOERROR;
1433 } 1432 }
1434 } 1433 }
@@ -1442,8 +1441,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
1442 if (__glibc_unlikely (cur_node == -2)) 1441 if (__glibc_unlikely (cur_node == -2))
1443 { 1442 {
1444 re_node_set_free (&eps_via_nodes); 1443 re_node_set_free (&eps_via_nodes);
1445 if (prev_idx_match_malloced) 1444 regmatch_list_free (&prev_match);
1446 re_free (prev_idx_match);
1447 free_fail_stack_return (fs); 1445 free_fail_stack_return (fs);
1448 return REG_ESPACE; 1446 return REG_ESPACE;
1449 } 1447 }
@@ -1453,15 +1451,13 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
1453 else 1451 else
1454 { 1452 {
1455 re_node_set_free (&eps_via_nodes); 1453 re_node_set_free (&eps_via_nodes);
1456 if (prev_idx_match_malloced) 1454 regmatch_list_free (&prev_match);
1457 re_free (prev_idx_match);
1458 return REG_NOMATCH; 1455 return REG_NOMATCH;
1459 } 1456 }
1460 } 1457 }
1461 } 1458 }
1462 re_node_set_free (&eps_via_nodes); 1459 re_node_set_free (&eps_via_nodes);
1463 if (prev_idx_match_malloced) 1460 regmatch_list_free (&prev_match);
1464 re_free (prev_idx_match);
1465 return free_fail_stack_return (fs); 1461 return free_fail_stack_return (fs);
1466} 1462}
1467 1463
@@ -3251,7 +3247,7 @@ expand_bkref_cache (re_match_context_t *mctx, re_node_set *cur_nodes,
3251/* Build transition table for the state. 3247/* Build transition table for the state.
3252 Return true if successful. */ 3248 Return true if successful. */
3253 3249
3254static bool 3250static bool __attribute_noinline__
3255build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) 3251build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
3256{ 3252{
3257 reg_errcode_t err; 3253 reg_errcode_t err;
@@ -3259,36 +3255,20 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
3259 int ch; 3255 int ch;
3260 bool need_word_trtable = false; 3256 bool need_word_trtable = false;
3261 bitset_word_t elem, mask; 3257 bitset_word_t elem, mask;
3262 bool dests_node_malloced = false;
3263 bool dest_states_malloced = false;
3264 Idx ndests; /* Number of the destination states from 'state'. */ 3258 Idx ndests; /* Number of the destination states from 'state'. */
3265 re_dfastate_t **trtable; 3259 re_dfastate_t **trtable;
3266 re_dfastate_t **dest_states = NULL, **dest_states_word, **dest_states_nl; 3260 re_dfastate_t *dest_states[SBC_MAX];
3267 re_node_set follows, *dests_node; 3261 re_dfastate_t *dest_states_word[SBC_MAX];
3268 bitset_t *dests_ch; 3262 re_dfastate_t *dest_states_nl[SBC_MAX];
3263 re_node_set follows;
3269 bitset_t acceptable; 3264 bitset_t acceptable;
3270 3265
3271 struct dests_alloc
3272 {
3273 re_node_set dests_node[SBC_MAX];
3274 bitset_t dests_ch[SBC_MAX];
3275 } *dests_alloc;
3276
3277 /* We build DFA states which corresponds to the destination nodes 3266 /* We build DFA states which corresponds to the destination nodes
3278 from 'state'. 'dests_node[i]' represents the nodes which i-th 3267 from 'state'. 'dests_node[i]' represents the nodes which i-th
3279 destination state contains, and 'dests_ch[i]' represents the 3268 destination state contains, and 'dests_ch[i]' represents the
3280 characters which i-th destination state accepts. */ 3269 characters which i-th destination state accepts. */
3281 if (__libc_use_alloca (sizeof (struct dests_alloc))) 3270 re_node_set dests_node[SBC_MAX];
3282 dests_alloc = (struct dests_alloc *) alloca (sizeof (struct dests_alloc)); 3271 bitset_t dests_ch[SBC_MAX];
3283 else
3284 {
3285 dests_alloc = re_malloc (struct dests_alloc, 1);
3286 if (__glibc_unlikely (dests_alloc == NULL))
3287 return false;
3288 dests_node_malloced = true;
3289 }
3290 dests_node = dests_alloc->dests_node;
3291 dests_ch = dests_alloc->dests_ch;
3292 3272
3293 /* Initialize transition table. */ 3273 /* Initialize transition table. */
3294 state->word_trtable = state->trtable = NULL; 3274 state->word_trtable = state->trtable = NULL;
@@ -3298,8 +3278,6 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
3298 ndests = group_nodes_into_DFAstates (dfa, state, dests_node, dests_ch); 3278 ndests = group_nodes_into_DFAstates (dfa, state, dests_node, dests_ch);
3299 if (__glibc_unlikely (ndests <= 0)) 3279 if (__glibc_unlikely (ndests <= 0))
3300 { 3280 {
3301 if (dests_node_malloced)
3302 re_free (dests_alloc);
3303 /* Return false in case of an error, true otherwise. */ 3281 /* Return false in case of an error, true otherwise. */
3304 if (ndests == 0) 3282 if (ndests == 0)
3305 { 3283 {
@@ -3314,38 +3292,14 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
3314 3292
3315 err = re_node_set_alloc (&follows, ndests + 1); 3293 err = re_node_set_alloc (&follows, ndests + 1);
3316 if (__glibc_unlikely (err != REG_NOERROR)) 3294 if (__glibc_unlikely (err != REG_NOERROR))
3317 goto out_free;
3318
3319 /* Avoid arithmetic overflow in size calculation. */
3320 size_t ndests_max
3321 = ((SIZE_MAX - (sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX)
3322 / (3 * sizeof (re_dfastate_t *)));
3323 if (__glibc_unlikely (ndests_max < ndests))
3324 goto out_free;
3325
3326 if (__libc_use_alloca ((sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX
3327 + ndests * 3 * sizeof (re_dfastate_t *)))
3328 dest_states = (re_dfastate_t **)
3329 alloca (ndests * 3 * sizeof (re_dfastate_t *));
3330 else
3331 { 3295 {
3332 dest_states = re_malloc (re_dfastate_t *, ndests * 3); 3296 out_free:
3333 if (__glibc_unlikely (dest_states == NULL)) 3297 re_node_set_free (&follows);
3334 { 3298 for (i = 0; i < ndests; ++i)
3335out_free: 3299 re_node_set_free (dests_node + i);
3336 if (dest_states_malloced) 3300 return false;
3337 re_free (dest_states);
3338 re_node_set_free (&follows);
3339 for (i = 0; i < ndests; ++i)
3340 re_node_set_free (dests_node + i);
3341 if (dests_node_malloced)
3342 re_free (dests_alloc);
3343 return false;
3344 }
3345 dest_states_malloced = true;
3346 } 3301 }
3347 dest_states_word = dest_states + ndests; 3302
3348 dest_states_nl = dest_states_word + ndests;
3349 bitset_empty (acceptable); 3303 bitset_empty (acceptable);
3350 3304
3351 /* Then build the states for all destinations. */ 3305 /* Then build the states for all destinations. */
@@ -3470,16 +3424,9 @@ out_free:
3470 } 3424 }
3471 } 3425 }
3472 3426
3473 if (dest_states_malloced)
3474 re_free (dest_states);
3475
3476 re_node_set_free (&follows); 3427 re_node_set_free (&follows);
3477 for (i = 0; i < ndests; ++i) 3428 for (i = 0; i < ndests; ++i)
3478 re_node_set_free (dests_node + i); 3429 re_node_set_free (dests_node + i);
3479
3480 if (dests_node_malloced)
3481 re_free (dests_alloc);
3482
3483 return true; 3430 return true;
3484} 3431}
3485 3432
diff --git a/lib/scratch_buffer.h b/lib/scratch_buffer.h
index 3e2b5ef27db..603b0d65d0a 100644
--- a/lib/scratch_buffer.h
+++ b/lib/scratch_buffer.h
@@ -21,6 +21,7 @@
21 21
22#include <libc-config.h> 22#include <libc-config.h>
23 23
24#define __libc_scratch_buffer_dupfree gl_scratch_buffer_dupfree
24#define __libc_scratch_buffer_grow gl_scratch_buffer_grow 25#define __libc_scratch_buffer_grow gl_scratch_buffer_grow
25#define __libc_scratch_buffer_grow_preserve gl_scratch_buffer_grow_preserve 26#define __libc_scratch_buffer_grow_preserve gl_scratch_buffer_grow_preserve
26#define __libc_scratch_buffer_set_array_size gl_scratch_buffer_set_array_size 27#define __libc_scratch_buffer_set_array_size gl_scratch_buffer_set_array_size
diff --git a/lib/stddef.in.h b/lib/stddef.in.h
index ba7195a9102..0f506a5b18b 100644
--- a/lib/stddef.in.h
+++ b/lib/stddef.in.h
@@ -49,6 +49,23 @@
49 49
50# ifndef _@GUARD_PREFIX@_STDDEF_H 50# ifndef _@GUARD_PREFIX@_STDDEF_H
51 51
52/* On AIX 7.2, with xlc in 64-bit mode, <stddef.h> defines max_align_t to a
53 type with alignment 4, but 'long' has alignment 8. */
54# if defined _AIX && defined _ARCH_PPC64
55# if !GNULIB_defined_max_align_t
56# ifdef _MAX_ALIGN_T
57/* /usr/include/stddef.h has already defined max_align_t. Override it. */
58typedef long rpl_max_align_t;
59# define max_align_t rpl_max_align_t
60# else
61/* Prevent /usr/include/stddef.h from defining max_align_t. */
62typedef long max_align_t;
63# define _MAX_ALIGN_T
64# endif
65# define GNULIB_defined_max_align_t 1
66# endif
67# endif
68
52/* The include_next requires a split double-inclusion guard. */ 69/* The include_next requires a split double-inclusion guard. */
53 70
54# @INCLUDE_NEXT@ @NEXT_STDDEF_H@ 71# @INCLUDE_NEXT@ @NEXT_STDDEF_H@
@@ -86,8 +103,10 @@
86 we are currently compiling with gcc. 103 we are currently compiling with gcc.
87 On MSVC, max_align_t is defined only in C++ mode, after <cstddef> was 104 On MSVC, max_align_t is defined only in C++ mode, after <cstddef> was
88 included. Its definition is good since it has an alignment of 8 (on x86 105 included. Its definition is good since it has an alignment of 8 (on x86
89 and x86_64). */ 106 and x86_64).
90#if defined _MSC_VER && defined __cplusplus 107 Similarly on OS/2 kLIBC. */
108#if (defined _MSC_VER || (defined __KLIBC__ && !defined __LIBCN__)) \
109 && defined __cplusplus
91# include <cstddef> 110# include <cstddef>
92#else 111#else
93# if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T) 112# if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T)
diff --git a/lib/string.in.h b/lib/string.in.h
index 9f68e77c767..c76c1820b36 100644
--- a/lib/string.in.h
+++ b/lib/string.in.h
@@ -69,6 +69,14 @@
69# include <unistd.h> 69# include <unistd.h>
70#endif 70#endif
71 71
72/* AIX 7.2 declares ffsl and ffsll in <strings.h>, not in <string.h>. */
73/* But in any case avoid namespace pollution on glibc systems. */
74#if ((@GNULIB_FFSL@ || @GNULIB_FFSLL@ || defined GNULIB_POSIXCHECK) \
75 && defined _AIX) \
76 && ! defined __GLIBC__
77# include <strings.h>
78#endif
79
72/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ 80/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
73 81
74/* The definition of _GL_ARG_NONNULL is copied here. */ 82/* The definition of _GL_ARG_NONNULL is copied here. */
@@ -110,10 +118,18 @@ _GL_WARN_ON_USE (ffsl, "ffsl is not portable - use the ffsl module");
110 118
111/* Find the index of the least-significant set bit. */ 119/* Find the index of the least-significant set bit. */
112#if @GNULIB_FFSLL@ 120#if @GNULIB_FFSLL@
113# if !@HAVE_FFSLL@ 121# if @REPLACE_FFSLL@
122# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
123# define ffsll rpl_ffsll
124# endif
125_GL_FUNCDECL_RPL (ffsll, int, (long long int i));
126_GL_CXXALIAS_RPL (ffsll, int, (long long int i));
127# else
128# if !@HAVE_FFSLL@
114_GL_FUNCDECL_SYS (ffsll, int, (long long int i)); 129_GL_FUNCDECL_SYS (ffsll, int, (long long int i));
115# endif 130# endif
116_GL_CXXALIAS_SYS (ffsll, int, (long long int i)); 131_GL_CXXALIAS_SYS (ffsll, int, (long long int i));
132# endif
117_GL_CXXALIASWARN (ffsll); 133_GL_CXXALIASWARN (ffsll);
118#elif defined GNULIB_POSIXCHECK 134#elif defined GNULIB_POSIXCHECK
119# undef ffsll 135# undef ffsll
diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h
index ccdb5cbd143..13d12943cd0 100644
--- a/lib/sys_stat.in.h
+++ b/lib/sys_stat.in.h
@@ -713,11 +713,21 @@ _GL_WARN_ON_USE (mkfifo, "mkfifo is not portable - "
713 713
714 714
715#if @GNULIB_MKFIFOAT@ 715#if @GNULIB_MKFIFOAT@
716# if !@HAVE_MKFIFOAT@ 716# if @REPLACE_MKFIFOAT@
717# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
718# undef mkfifoat
719# define mkfifoat rpl_mkfifoat
720# endif
721_GL_FUNCDECL_RPL (mkfifoat, int, (int fd, char const *file, mode_t mode)
722 _GL_ARG_NONNULL ((2)));
723_GL_CXXALIAS_RPL (mkfifoat, int, (int fd, char const *file, mode_t mode));
724# else
725# if !@HAVE_MKFIFOAT@
717_GL_FUNCDECL_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode) 726_GL_FUNCDECL_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode)
718 _GL_ARG_NONNULL ((2))); 727 _GL_ARG_NONNULL ((2)));
719# endif 728# endif
720_GL_CXXALIAS_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode)); 729_GL_CXXALIAS_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode));
730# endif
721_GL_CXXALIASWARN (mkfifoat); 731_GL_CXXALIASWARN (mkfifoat);
722#elif defined GNULIB_POSIXCHECK 732#elif defined GNULIB_POSIXCHECK
723# undef mkfifoat 733# undef mkfifoat
@@ -756,13 +766,25 @@ _GL_WARN_ON_USE (mknod, "mknod is not portable - "
756 766
757 767
758#if @GNULIB_MKNODAT@ 768#if @GNULIB_MKNODAT@
759# if !@HAVE_MKNODAT@ 769# if @REPLACE_MKNODAT@
770# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
771# undef mknodat
772# define mknodat rpl_mknodat
773# endif
774_GL_FUNCDECL_RPL (mknodat, int,
775 (int fd, char const *file, mode_t mode, dev_t dev)
776 _GL_ARG_NONNULL ((2)));
777_GL_CXXALIAS_RPL (mknodat, int,
778 (int fd, char const *file, mode_t mode, dev_t dev));
779# else
780# if !@HAVE_MKNODAT@
760_GL_FUNCDECL_SYS (mknodat, int, 781_GL_FUNCDECL_SYS (mknodat, int,
761 (int fd, char const *file, mode_t mode, dev_t dev) 782 (int fd, char const *file, mode_t mode, dev_t dev)
762 _GL_ARG_NONNULL ((2))); 783 _GL_ARG_NONNULL ((2)));
763# endif 784# endif
764_GL_CXXALIAS_SYS (mknodat, int, 785_GL_CXXALIAS_SYS (mknodat, int,
765 (int fd, char const *file, mode_t mode, dev_t dev)); 786 (int fd, char const *file, mode_t mode, dev_t dev));
787# endif
766_GL_CXXALIASWARN (mknodat); 788_GL_CXXALIASWARN (mknodat);
767#elif defined GNULIB_POSIXCHECK 789#elif defined GNULIB_POSIXCHECK
768# undef mknodat 790# undef mknodat
diff --git a/lib/tempname.c b/lib/tempname.c
index 3d91deef1e1..e243483eaf8 100644
--- a/lib/tempname.c
+++ b/lib/tempname.c
@@ -22,6 +22,7 @@
22 22
23#include <sys/types.h> 23#include <sys/types.h>
24#include <assert.h> 24#include <assert.h>
25#include <stdbool.h>
25 26
26#include <errno.h> 27#include <errno.h>
27 28
@@ -61,7 +62,8 @@
61# define __gen_tempname gen_tempname 62# define __gen_tempname gen_tempname
62# define __mkdir mkdir 63# define __mkdir mkdir
63# define __open open 64# define __open open
64# define __lxstat64(version, file, buf) lstat (file, buf) 65# define __lstat64(file, buf) lstat (file, buf)
66# define __stat64(file, buf) stat (file, buf)
65# define __getrandom getrandom 67# define __getrandom getrandom
66# define __clock_gettime64 clock_gettime 68# define __clock_gettime64 clock_gettime
67# define __timespec64 timespec 69# define __timespec64 timespec
@@ -76,13 +78,14 @@ typedef uint_fast64_t random_value;
76#define BASE_62_POWER (62LL * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62) 78#define BASE_62_POWER (62LL * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62)
77 79
78static random_value 80static random_value
79random_bits (random_value var) 81random_bits (random_value var, bool use_getrandom)
80{ 82{
81 random_value r; 83 random_value r;
82 if (__getrandom (&r, sizeof r, 0) == sizeof r) 84 /* Without GRND_NONBLOCK it can be blocked for minutes on some systems. */
85 if (use_getrandom && __getrandom (&r, sizeof r, GRND_NONBLOCK) == sizeof r)
83 return r; 86 return r;
84#if _LIBC || (defined CLOCK_MONOTONIC && HAVE_CLOCK_GETTIME) 87#if _LIBC || (defined CLOCK_MONOTONIC && HAVE_CLOCK_GETTIME)
85 /* Add entropy if getrandom is not supported. */ 88 /* Add entropy if getrandom did not work. */
86 struct __timespec64 tv; 89 struct __timespec64 tv;
87 __clock_gettime64 (CLOCK_MONOTONIC, &tv); 90 __clock_gettime64 (CLOCK_MONOTONIC, &tv);
88 var ^= tv.tv_nsec; 91 var ^= tv.tv_nsec;
@@ -96,7 +99,7 @@ static int
96direxists (const char *dir) 99direxists (const char *dir)
97{ 100{
98 struct_stat64 buf; 101 struct_stat64 buf;
99 return __xstat64 (_STAT_VER, dir, &buf) == 0 && S_ISDIR (buf.st_mode); 102 return __stat64 (dir, &buf) == 0 && S_ISDIR (buf.st_mode);
100} 103}
101 104
102/* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is 105/* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is
@@ -188,7 +191,7 @@ try_nocreate (char *tmpl, void *flags _GL_UNUSED)
188{ 191{
189 struct_stat64 st; 192 struct_stat64 st;
190 193
191 if (__lxstat64 (_STAT_VER, tmpl, &st) == 0 || errno == EOVERFLOW) 194 if (__lstat64 (tmpl, &st) == 0 || errno == EOVERFLOW)
192 __set_errno (EEXIST); 195 __set_errno (EEXIST);
193 return errno == ENOENT ? 0 : -1; 196 return errno == ENOENT ? 0 : -1;
194} 197}
@@ -267,6 +270,13 @@ try_tempname_len (char *tmpl, int suffixlen, void *args,
267 /* How many random base-62 digits can currently be extracted from V. */ 270 /* How many random base-62 digits can currently be extracted from V. */
268 int vdigits = 0; 271 int vdigits = 0;
269 272
273 /* Whether to consume entropy when acquiring random bits. On the
274 first try it's worth the entropy cost with __GT_NOCREATE, which
275 is inherently insecure and can use the entropy to make it a bit
276 less secure. On the (rare) second and later attempts it might
277 help against DoS attacks. */
278 bool use_getrandom = tryfunc == try_nocreate;
279
270 /* Least unfair value for V. If V is less than this, V can generate 280 /* Least unfair value for V. If V is less than this, V can generate
271 BASE_62_DIGITS digits fairly. Otherwise it might be biased. */ 281 BASE_62_DIGITS digits fairly. Otherwise it might be biased. */
272 random_value const unfair_min 282 random_value const unfair_min
@@ -290,7 +300,10 @@ try_tempname_len (char *tmpl, int suffixlen, void *args,
290 if (vdigits == 0) 300 if (vdigits == 0)
291 { 301 {
292 do 302 do
293 v = random_bits (v); 303 {
304 v = random_bits (v, use_getrandom);
305 use_getrandom = true;
306 }
294 while (unfair_min <= v); 307 while (unfair_min <= v);
295 308
296 vdigits = BASE_62_DIGITS; 309 vdigits = BASE_62_DIGITS;
diff --git a/lib/time-internal.h b/lib/time-internal.h
index 63a3f9e3db1..067ee729eda 100644
--- a/lib/time-internal.h
+++ b/lib/time-internal.h
@@ -24,7 +24,7 @@ struct tm_zone
24 members are zero. */ 24 members are zero. */
25 struct tm_zone *next; 25 struct tm_zone *next;
26 26
27#if HAVE_TZNAME && !HAVE_TM_ZONE 27#if HAVE_TZNAME && !HAVE_STRUCT_TM_TM_ZONE
28 /* Copies of recent strings taken from tzname[0] and tzname[1]. 28 /* Copies of recent strings taken from tzname[0] and tzname[1].
29 The copies are in ABBRS, so that they survive tzset. Null if unknown. */ 29 The copies are in ABBRS, so that they survive tzset. Null if unknown. */
30 char *tzname_copy[2]; 30 char *tzname_copy[2];
diff --git a/lib/time.in.h b/lib/time.in.h
index 958dc0bd292..1385980cdf5 100644
--- a/lib/time.in.h
+++ b/lib/time.in.h
@@ -101,6 +101,25 @@ struct __time_t_must_be_integral {
101# define GNULIB_defined_struct_time_t_must_be_integral 1 101# define GNULIB_defined_struct_time_t_must_be_integral 1
102# endif 102# endif
103 103
104/* Define TIME_UTC, a positive integer constant used for timespec_get(). */
105# if ! @TIME_H_DEFINES_TIME_UTC@
106# if !GNULIB_defined_TIME_UTC
107# define TIME_UTC 1
108# define GNULIB_defined_TIME_UTC 1
109# endif
110# endif
111
112/* Set *TS to the current time, and return BASE.
113 Upon failure, return 0. */
114# if @GNULIB_TIMESPEC_GET@
115# if ! @HAVE_TIMESPEC_GET@
116_GL_FUNCDECL_SYS (timespec_get, int, (struct timespec *ts, int base)
117 _GL_ARG_NONNULL ((1)));
118# endif
119_GL_CXXALIAS_SYS (timespec_get, int, (struct timespec *ts, int base));
120_GL_CXXALIASWARN (timespec_get);
121# endif
122
104/* Sleep for at least RQTP seconds unless interrupted, If interrupted, 123/* Sleep for at least RQTP seconds unless interrupted, If interrupted,
105 return -1 and store the remaining time into RMTP. See 124 return -1 and store the remaining time into RMTP. See
106 <https://pubs.opengroup.org/onlinepubs/9699919799/functions/nanosleep.html>. */ 125 <https://pubs.opengroup.org/onlinepubs/9699919799/functions/nanosleep.html>. */
diff --git a/lib/time_rz.c b/lib/time_rz.c
index 65e20cc5661..3ac053c6219 100644
--- a/lib/time_rz.c
+++ b/lib/time_rz.c
@@ -71,7 +71,7 @@ tzalloc (char const *name)
71 if (tz) 71 if (tz)
72 { 72 {
73 tz->next = NULL; 73 tz->next = NULL;
74#if HAVE_TZNAME && !HAVE_TM_ZONE 74#if HAVE_TZNAME && !HAVE_STRUCT_TM_TM_ZONE
75 tz->tzname_copy[0] = tz->tzname_copy[1] = NULL; 75 tz->tzname_copy[0] = tz->tzname_copy[1] = NULL;
76#endif 76#endif
77 tz->tz_is_set = !!name; 77 tz->tz_is_set = !!name;
@@ -83,13 +83,13 @@ tzalloc (char const *name)
83} 83}
84 84
85/* Save into TZ any nontrivial time zone abbreviation used by TM, and 85/* Save into TZ any nontrivial time zone abbreviation used by TM, and
86 update *TM (if HAVE_TM_ZONE) or *TZ (if !HAVE_TM_ZONE && 86 update *TM (if HAVE_STRUCT_TM_TM_ZONE) or *TZ (if
87 HAVE_TZNAME) if they use the abbreviation. Return true if 87 !HAVE_STRUCT_TM_TM_ZONE && HAVE_TZNAME) if they use the abbreviation.
88 successful, false (setting errno) otherwise. */ 88 Return true if successful, false (setting errno) otherwise. */
89static bool 89static bool
90save_abbr (timezone_t tz, struct tm *tm) 90save_abbr (timezone_t tz, struct tm *tm)
91{ 91{
92#if HAVE_TM_ZONE || HAVE_TZNAME 92#if HAVE_STRUCT_TM_TM_ZONE || HAVE_TZNAME
93 char const *zone = NULL; 93 char const *zone = NULL;
94 char *zone_copy = (char *) ""; 94 char *zone_copy = (char *) "";
95 95
@@ -97,7 +97,7 @@ save_abbr (timezone_t tz, struct tm *tm)
97 int tzname_index = -1; 97 int tzname_index = -1;
98# endif 98# endif
99 99
100# if HAVE_TM_ZONE 100# if HAVE_STRUCT_TM_TM_ZONE
101 zone = tm->tm_zone; 101 zone = tm->tm_zone;
102# endif 102# endif
103 103
@@ -145,7 +145,7 @@ save_abbr (timezone_t tz, struct tm *tm)
145 } 145 }
146 146
147 /* Replace the zone name so that its lifetime matches that of TZ. */ 147 /* Replace the zone name so that its lifetime matches that of TZ. */
148# if HAVE_TM_ZONE 148# if HAVE_STRUCT_TM_TM_ZONE
149 tm->tm_zone = zone_copy; 149 tm->tm_zone = zone_copy;
150# else 150# else
151 if (0 <= tzname_index) 151 if (0 <= tzname_index)
@@ -303,7 +303,7 @@ mktime_z (timezone_t tz, struct tm *tm)
303 tm_1.tm_isdst = tm->tm_isdst; 303 tm_1.tm_isdst = tm->tm_isdst;
304 time_t t = mktime (&tm_1); 304 time_t t = mktime (&tm_1);
305 bool ok = 0 <= tm_1.tm_yday; 305 bool ok = 0 <= tm_1.tm_yday;
306#if HAVE_TM_ZONE || HAVE_TZNAME 306#if HAVE_STRUCT_TM_TM_ZONE || HAVE_TZNAME
307 ok = ok && save_abbr (tz, &tm_1); 307 ok = ok && save_abbr (tz, &tm_1);
308#endif 308#endif
309 if (revert_tz (old_tz) && ok) 309 if (revert_tz (old_tz) && ok)
diff --git a/lib/timegm.c b/lib/timegm.c
index fa30943084d..e4127e71c0b 100644
--- a/lib/timegm.c
+++ b/lib/timegm.c
@@ -1,6 +1,6 @@
1/* Convert UTC calendar time to simple time. Like mktime but assumes UTC. 1/* Convert UTC calendar time to simple time. Like mktime but assumes UTC.
2 2
3 Copyright (C) 1994-2020 Free Software Foundation, Inc. 3 Copyright (C) 1994-2021 Free Software Foundation, Inc.
4 This file is part of the GNU C Library. 4 This file is part of the GNU C Library.
5 5
6 The GNU C Library is free software; you can redistribute it and/or 6 The GNU C Library is free software; you can redistribute it and/or
diff --git a/lib/utimens.c b/lib/utimens.c
index 5bbae058132..44d1ea003e2 100644
--- a/lib/utimens.c
+++ b/lib/utimens.c
@@ -27,6 +27,7 @@
27#include <errno.h> 27#include <errno.h>
28#include <fcntl.h> 28#include <fcntl.h>
29#include <stdbool.h> 29#include <stdbool.h>
30#include <string.h>
30#include <sys/stat.h> 31#include <sys/stat.h>
31#include <sys/time.h> 32#include <sys/time.h>
32#include <unistd.h> 33#include <unistd.h>
@@ -52,7 +53,9 @@
52 53
53/* Avoid recursion with rpl_futimens or rpl_utimensat. */ 54/* Avoid recursion with rpl_futimens or rpl_utimensat. */
54#undef futimens 55#undef futimens
55#undef utimensat 56#if !HAVE_NEARLY_WORKING_UTIMENSAT
57# undef utimensat
58#endif
56 59
57/* Solaris 9 mistakenly succeeds when given a non-directory with a 60/* Solaris 9 mistakenly succeeds when given a non-directory with a
58 trailing slash. Force the use of rpl_stat for a fix. */ 61 trailing slash. Force the use of rpl_stat for a fix. */
@@ -246,6 +249,20 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2])
246# if HAVE_UTIMENSAT 249# if HAVE_UTIMENSAT
247 if (fd < 0) 250 if (fd < 0)
248 { 251 {
252# if defined __APPLE__ && defined __MACH__
253 size_t len = strlen (file);
254 if (len > 0 && file[len - 1] == '/')
255 {
256 struct stat statbuf;
257 if (stat (file, &statbuf) < 0)
258 return -1;
259 if (!S_ISDIR (statbuf.st_mode))
260 {
261 errno = ENOTDIR;
262 return -1;
263 }
264 }
265# endif
249 result = utimensat (AT_FDCWD, file, ts, 0); 266 result = utimensat (AT_FDCWD, file, ts, 0);
250# ifdef __linux__ 267# ifdef __linux__
251 /* Work around a kernel bug: 268 /* Work around a kernel bug:
diff --git a/lib/utimensat.c b/lib/utimensat.c
index 2cea64f6982..9fdecd681f6 100644
--- a/lib/utimensat.c
+++ b/lib/utimensat.c
@@ -24,14 +24,40 @@
24#include <errno.h> 24#include <errno.h>
25#include <fcntl.h> 25#include <fcntl.h>
26#include <stdlib.h> 26#include <stdlib.h>
27#include <string.h>
28#include <sys/stat.h>
27 29
28#include "stat-time.h" 30#include "stat-time.h"
29#include "timespec.h" 31#include "timespec.h"
30#include "utimens.h" 32#include "utimens.h"
31 33
32#if HAVE_UTIMENSAT 34#if HAVE_NEARLY_WORKING_UTIMENSAT
33 35
36/* Use the original utimensat(), but correct the trailing slash handling. */
37int
38rpl_utimensat (int fd, char const *file, struct timespec const times[2],
39 int flag)
34# undef utimensat 40# undef utimensat
41{
42 size_t len = strlen (file);
43 if (len && file[len - 1] == '/')
44 {
45 struct stat st;
46 if (fstatat (fd, file, &st, flag & AT_SYMLINK_NOFOLLOW) < 0)
47 return -1;
48 if (!S_ISDIR (st.st_mode))
49 {
50 errno = ENOTDIR;
51 return -1;
52 }
53 }
54
55 return utimensat (fd, file, times, flag);
56}
57
58#else
59
60# if HAVE_UTIMENSAT
35 61
36/* If we have a native utimensat, but are compiling this file, then 62/* If we have a native utimensat, but are compiling this file, then
37 utimensat was defined to rpl_utimensat by our replacement 63 utimensat was defined to rpl_utimensat by our replacement
@@ -42,24 +68,25 @@
42 local_utimensat provides the fallback manipulation. */ 68 local_utimensat provides the fallback manipulation. */
43 69
44static int local_utimensat (int, char const *, struct timespec const[2], int); 70static int local_utimensat (int, char const *, struct timespec const[2], int);
45# define AT_FUNC_NAME local_utimensat 71# define AT_FUNC_NAME local_utimensat
46 72
47/* Like utimensat, but work around native bugs. */ 73/* Like utimensat, but work around native bugs. */
48 74
49int 75int
50rpl_utimensat (int fd, char const *file, struct timespec const times[2], 76rpl_utimensat (int fd, char const *file, struct timespec const times[2],
51 int flag) 77 int flag)
78# undef utimensat
52{ 79{
53# if defined __linux__ || defined __sun 80# if defined __linux__ || defined __sun
54 struct timespec ts[2]; 81 struct timespec ts[2];
55# endif 82# endif
56 83
57 /* See comments in utimens.c for details. */ 84 /* See comments in utimens.c for details. */
58 static int utimensat_works_really; /* 0 = unknown, 1 = yes, -1 = no. */ 85 static int utimensat_works_really; /* 0 = unknown, 1 = yes, -1 = no. */
59 if (0 <= utimensat_works_really) 86 if (0 <= utimensat_works_really)
60 { 87 {
61 int result; 88 int result;
62# if defined __linux__ || defined __sun 89# if defined __linux__ || defined __sun
63 struct stat st; 90 struct stat st;
64 /* As recently as Linux kernel 2.6.32 (Dec 2009), several file 91 /* As recently as Linux kernel 2.6.32 (Dec 2009), several file
65 systems (xfs, ntfs-3g) have bugs with a single UTIME_OMIT, 92 systems (xfs, ntfs-3g) have bugs with a single UTIME_OMIT,
@@ -90,7 +117,7 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2],
90 ts[1] = times[1]; 117 ts[1] = times[1];
91 times = ts; 118 times = ts;
92 } 119 }
93# ifdef __hppa__ 120# ifdef __hppa__
94 /* Linux kernel 2.6.22.19 on hppa does not reject invalid tv_nsec 121 /* Linux kernel 2.6.22.19 on hppa does not reject invalid tv_nsec
95 values. */ 122 values. */
96 else if (times 123 else if (times
@@ -104,8 +131,36 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2],
104 errno = EINVAL; 131 errno = EINVAL;
105 return -1; 132 return -1;
106 } 133 }
134# endif
135# endif
136# if defined __APPLE__ && defined __MACH__
137 /* macOS 10.13 does not reject invalid tv_nsec values either. */
138 if (times
139 && ((times[0].tv_nsec != UTIME_OMIT
140 && times[0].tv_nsec != UTIME_NOW
141 && ! (0 <= times[0].tv_nsec
142 && times[0].tv_nsec < TIMESPEC_HZ))
143 || (times[1].tv_nsec != UTIME_OMIT
144 && times[1].tv_nsec != UTIME_NOW
145 && ! (0 <= times[1].tv_nsec
146 && times[1].tv_nsec < TIMESPEC_HZ))))
147 {
148 errno = EINVAL;
149 return -1;
150 }
151 size_t len = strlen (file);
152 if (len > 0 && file[len - 1] == '/')
153 {
154 struct stat statbuf;
155 if (fstatat (fd, file, &statbuf, 0) < 0)
156 return -1;
157 if (!S_ISDIR (statbuf.st_mode))
158 {
159 errno = ENOTDIR;
160 return -1;
161 }
162 }
107# endif 163# endif
108# endif
109 result = utimensat (fd, file, times, flag); 164 result = utimensat (fd, file, times, flag);
110 /* Linux kernel 2.6.25 has a bug where it returns EINVAL for 165 /* Linux kernel 2.6.25 has a bug where it returns EINVAL for
111 UTIME_NOW or UTIME_OMIT with non-zero tv_sec, which 166 UTIME_NOW or UTIME_OMIT with non-zero tv_sec, which
@@ -129,11 +184,11 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2],
129 return local_utimensat (fd, file, times, flag); 184 return local_utimensat (fd, file, times, flag);
130} 185}
131 186
132#else /* !HAVE_UTIMENSAT */ 187# else /* !HAVE_UTIMENSAT */
133 188
134# define AT_FUNC_NAME utimensat 189# define AT_FUNC_NAME utimensat
135 190
136#endif /* !HAVE_UTIMENSAT */ 191# endif /* !HAVE_UTIMENSAT */
137 192
138/* Set the access and modification timestamps of FILE to be 193/* Set the access and modification timestamps of FILE to be
139 TIMESPEC[0] and TIMESPEC[1], respectively; relative to directory 194 TIMESPEC[0] and TIMESPEC[1], respectively; relative to directory
@@ -146,15 +201,17 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2],
146 Return 0 on success, -1 (setting errno) on failure. */ 201 Return 0 on success, -1 (setting errno) on failure. */
147 202
148/* AT_FUNC_NAME is now utimensat or local_utimensat. */ 203/* AT_FUNC_NAME is now utimensat or local_utimensat. */
149#define AT_FUNC_F1 lutimens 204# define AT_FUNC_F1 lutimens
150#define AT_FUNC_F2 utimens 205# define AT_FUNC_F2 utimens
151#define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW 206# define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW
152#define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag 207# define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag
153#define AT_FUNC_POST_FILE_ARGS , ts 208# define AT_FUNC_POST_FILE_ARGS , ts
154#include "at-func.c" 209# include "at-func.c"
155#undef AT_FUNC_NAME 210# undef AT_FUNC_NAME
156#undef AT_FUNC_F1 211# undef AT_FUNC_F1
157#undef AT_FUNC_F2 212# undef AT_FUNC_F2
158#undef AT_FUNC_USE_F1_COND 213# undef AT_FUNC_USE_F1_COND
159#undef AT_FUNC_POST_FILE_PARAM_DECLS 214# undef AT_FUNC_POST_FILE_PARAM_DECLS
160#undef AT_FUNC_POST_FILE_ARGS 215# undef AT_FUNC_POST_FILE_ARGS
216
217#endif /* !HAVE_NEARLY_WORKING_UTIMENSAT */
diff --git a/lib/verify.h b/lib/verify.h
index 3cdcdca5671..65514c34b9e 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -22,16 +22,10 @@
22 22
23 23
24/* Define _GL_HAVE__STATIC_ASSERT to 1 if _Static_assert (R, DIAGNOSTIC) 24/* Define _GL_HAVE__STATIC_ASSERT to 1 if _Static_assert (R, DIAGNOSTIC)
25 works as per C11. This is supported by GCC 4.6.0 and later, in C 25 works as per C11. This is supported by GCC 4.6.0+ and by clang 4+.
26 mode, and by clang (also in C++ mode).
27 26
28 Define _GL_HAVE__STATIC_ASSERT1 to 1 if _Static_assert (R) works as 27 Define _GL_HAVE__STATIC_ASSERT1 to 1 if _Static_assert (R) works as
29 per C2X. This is supported by GCC 9.1 and later, and by clang in 28 per C2X. This is supported by GCC 9.1+.
30 C++1z mode.
31
32 Define _GL_HAVE_STATIC_ASSERT1 if static_assert (R) works as per
33 C++17. This is supported by GCC 9.1 and later, and by clang in
34 C++1z mode.
35 29
36 Support compilers claiming conformance to the relevant standard, 30 Support compilers claiming conformance to the relevant standard,
37 and also support GCC when not pedantic. If we were willing to slow 31 and also support GCC when not pedantic. If we were willing to slow
@@ -47,18 +41,6 @@
47 || (!defined __STRICT_ANSI__ && 9 <= __GNUC__)) 41 || (!defined __STRICT_ANSI__ && 9 <= __GNUC__))
48# define _GL_HAVE__STATIC_ASSERT1 1 42# define _GL_HAVE__STATIC_ASSERT1 1
49# endif 43# endif
50#else
51# if 4 <= __clang_major__
52# define _GL_HAVE__STATIC_ASSERT 1
53# endif
54# if 4 <= __clang_major__ && 201411 <= __cpp_static_assert
55# define _GL_HAVE__STATIC_ASSERT1 1
56# endif
57# if 201703L <= __cplusplus \
58 || 9 <= __GNUC__ \
59 || (4 <= __clang_major__ && 201411 <= __cpp_static_assert)
60# define _GL_HAVE_STATIC_ASSERT1 1
61# endif
62#endif 44#endif
63 45
64/* FreeBSD 9.1 <sys/cdefs.h>, included by <stddef.h> and lots of other 46/* FreeBSD 9.1 <sys/cdefs.h>, included by <stddef.h> and lots of other
@@ -225,7 +207,9 @@ template <int w>
225 Unfortunately, unlike C11, this implementation must appear as an 207 Unfortunately, unlike C11, this implementation must appear as an
226 ordinary declaration, and cannot appear inside struct { ... }. */ 208 ordinary declaration, and cannot appear inside struct { ... }. */
227 209
228#if defined _GL_HAVE__STATIC_ASSERT 210#if 200410 <= __cpp_static_assert
211# define _GL_VERIFY(R, DIAGNOSTIC, ...) static_assert (R, DIAGNOSTIC)
212#elif defined _GL_HAVE__STATIC_ASSERT
229# define _GL_VERIFY(R, DIAGNOSTIC, ...) _Static_assert (R, DIAGNOSTIC) 213# define _GL_VERIFY(R, DIAGNOSTIC, ...) _Static_assert (R, DIAGNOSTIC)
230#else 214#else
231# define _GL_VERIFY(R, DIAGNOSTIC, ...) \ 215# define _GL_VERIFY(R, DIAGNOSTIC, ...) \
@@ -239,7 +223,7 @@ template <int w>
239# define _Static_assert(...) \ 223# define _Static_assert(...) \
240 _GL_VERIFY (__VA_ARGS__, "static assertion failed", -) 224 _GL_VERIFY (__VA_ARGS__, "static assertion failed", -)
241# endif 225# endif
242# if !defined _GL_HAVE_STATIC_ASSERT1 && !defined static_assert 226# if __cpp_static_assert < 201411 && !defined static_assert
243# define static_assert _Static_assert /* C11 requires this #define. */ 227# define static_assert _Static_assert /* C11 requires this #define. */
244# endif 228# endif
245#endif 229#endif
diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el
index ea79bfa69a0..fda0b4bbedb 100644
--- a/lisp/calc/calc-embed.el
+++ b/lisp/calc/calc-embed.el
@@ -651,6 +651,8 @@ The command \\[yank] can retrieve it from there."
651(defvar calc-embed-prev-modes) 651(defvar calc-embed-prev-modes)
652 652
653(defun calc-embedded-set-modes (gmodes modes local-modes &optional temp) 653(defun calc-embedded-set-modes (gmodes modes local-modes &optional temp)
654 (defvar the-language)
655 (defvar the-display-just)
654 (let ((the-language (calc-embedded-language)) 656 (let ((the-language (calc-embedded-language))
655 (the-display-just (calc-embedded-justify)) 657 (the-display-just (calc-embedded-justify))
656 (v gmodes) 658 (v gmodes)
diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el
index b4b2d4cc4f4..0117f449dd5 100644
--- a/lisp/calc/calc-lang.el
+++ b/lisp/calc/calc-lang.el
@@ -2181,7 +2181,7 @@ order to Calc's."
2181 v math-read-big-baseline)) 2181 v math-read-big-baseline))
2182 2182
2183 ;; Small radical sign. 2183 ;; Small radical sign.
2184 ((and (= other-char ?V) 2184 ((and (memq other-char '(?V ?√))
2185 (= (math-read-big-char (1+ math-rb-h1) (1- v)) ?\_)) 2185 (= (math-read-big-char (1+ math-rb-h1) (1- v)) ?\_))
2186 (setq h (1+ math-rb-h1)) 2186 (setq h (1+ math-rb-h1))
2187 (math-read-big-emptyp math-rb-h1 math-rb-v1 h (1- v) nil t) 2187 (math-read-big-emptyp math-rb-h1 math-rb-v1 h (1- v) nil t)
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index d684c7ba97f..ec09abb34c4 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -2144,7 +2144,7 @@ the United States."
2144 (let ((w (split-window nil (/ (* (window-width) 2) 3) t))) 2144 (let ((w (split-window nil (/ (* (window-width) 2) 3) t)))
2145 (set-window-buffer w calc-trail-buffer) 2145 (set-window-buffer w calc-trail-buffer)
2146 (and calc-make-windows-dedicated 2146 (and calc-make-windows-dedicated
2147 (set-window-dedicated-p nil t)))) 2147 (set-window-dedicated-p w t))))
2148 (calc-wrapper 2148 (calc-wrapper
2149 (setq overlay-arrow-string calc-trail-overlay 2149 (setq overlay-arrow-string calc-trail-overlay
2150 overlay-arrow-position calc-trail-pointer) 2150 overlay-arrow-position calc-trail-pointer)
diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el
index 07e70cad0a8..bd81d7fe406 100644
--- a/lisp/calc/calccomp.el
+++ b/lisp/calc/calccomp.el
@@ -138,19 +138,19 @@
138 (math-format-number (nth 2 aa)))))) 138 (math-format-number (nth 2 aa))))))
139 (if (= calc-number-radix 10) 139 (if (= calc-number-radix 10)
140 c 140 c
141 (list 'horiz "(" c 141 (list 'subscr (math--comp-round-bracket c)
142 (list 'subscr ")" 142 (int-to-string calc-number-radix))))
143 (int-to-string calc-number-radix)))))
144 (math-format-number a))) 143 (math-format-number a)))
145 (if (not (eq calc-language 'big)) 144 (if (not (eq calc-language 'big))
146 (math-format-number a prec) 145 (math-format-number a prec)
147 (if (memq (car-safe a) '(cplx polar)) 146 (if (memq (car-safe a) '(cplx polar))
148 (if (math-zerop (nth 2 a)) 147 (if (math-zerop (nth 2 a))
149 (math-compose-expr (nth 1 a) prec) 148 (math-compose-expr (nth 1 a) prec)
150 (list 'horiz "(" 149 (math--comp-round-bracket
151 (math-compose-expr (nth 1 a) 0) 150 (list 'horiz
152 (if (eq (car a) 'cplx) ", " "; ") 151 (math-compose-expr (nth 1 a) 0)
153 (math-compose-expr (nth 2 a) 0) ")")) 152 (if (eq (car a) 'cplx) ", " "; ")
153 (math-compose-expr (nth 2 a) 0))))
154 (if (or (= calc-number-radix 10) 154 (if (or (= calc-number-radix 10)
155 (not (Math-realp a)) 155 (not (Math-realp a))
156 (and calc-group-digits 156 (and calc-group-digits
@@ -340,12 +340,13 @@
340 (funcall spfn a prec) 340 (funcall spfn a prec)
341 (math-compose-var a))))) 341 (math-compose-var a)))))
342 ((eq (car a) 'intv) 342 ((eq (car a) 'intv)
343 (list 'horiz 343 (math--comp-bracket
344 (if (memq (nth 1 a) '(0 1)) "(" "[") 344 (if (memq (nth 1 a) '(0 1)) ?\( ?\[)
345 (math-compose-expr (nth 2 a) 0) 345 (if (memq (nth 1 a) '(0 2)) ?\) ?\])
346 " .. " 346 (list 'horiz
347 (math-compose-expr (nth 3 a) 0) 347 (math-compose-expr (nth 2 a) 0)
348 (if (memq (nth 1 a) '(0 2)) ")" "]"))) 348 " .. "
349 (math-compose-expr (nth 3 a) 0))))
349 ((eq (car a) 'date) 350 ((eq (car a) 'date)
350 (if (eq (car calc-date-format) 'X) 351 (if (eq (car calc-date-format) 'X)
351 (math-format-date a) 352 (math-format-date a)
@@ -377,7 +378,7 @@
377 (and (eq (car-safe (nth 1 a)) 'cplx) 378 (and (eq (car-safe (nth 1 a)) 'cplx)
378 (math-negp (nth 1 (nth 1 a))) 379 (math-negp (nth 1 (nth 1 a)))
379 (eq (nth 2 (nth 1 a)) 0))) 380 (eq (nth 2 (nth 1 a)) 0)))
380 (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")") 381 (math--comp-round-bracket (math-compose-expr (nth 1 a) 0))
381 (math-compose-expr (nth 1 a) 201)) 382 (math-compose-expr (nth 1 a) 201))
382 (let ((calc-language 'flat) 383 (let ((calc-language 'flat)
383 (calc-number-radix 10) 384 (calc-number-radix 10)
@@ -444,7 +445,7 @@
444 (if (> prec (nth 2 a)) 445 (if (> prec (nth 2 a))
445 (if (setq spfn (get calc-language 'math-big-parens)) 446 (if (setq spfn (get calc-language 'math-big-parens))
446 (list 'horiz (car spfn) c (cdr spfn)) 447 (list 'horiz (car spfn) c (cdr spfn))
447 (list 'horiz "(" c ")")) 448 (math--comp-round-bracket c))
448 c))) 449 c)))
449 ((and (eq (car a) 'calcFunc-choriz) 450 ((and (eq (car a) 'calcFunc-choriz)
450 (not (eq calc-language 'unform)) 451 (not (eq calc-language 'unform))
@@ -612,7 +613,7 @@
612 (list 'horiz "{left ( " 613 (list 'horiz "{left ( "
613 (math-compose-expr a -1) 614 (math-compose-expr a -1)
614 " right )}"))) 615 " right )}")))
615 (list 'horiz "(" (math-compose-expr a 0) ")")))) 616 (math--comp-round-bracket (math-compose-expr a 0)))))
616 ((and (memq calc-language '(tex latex)) 617 ((and (memq calc-language '(tex latex))
617 (memq (car a) '(/ calcFunc-choose calcFunc-evalto)) 618 (memq (car a) '(/ calcFunc-choose calcFunc-evalto))
618 (>= prec 0)) 619 (>= prec 0))
@@ -638,7 +639,7 @@
638 (rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1 op) '/)))) 639 (rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1 op) '/))))
639 (and (equal (car op) "^") 640 (and (equal (car op) "^")
640 (eq (math-comp-first-char lhs) ?-) 641 (eq (math-comp-first-char lhs) ?-)
641 (setq lhs (list 'horiz "(" lhs ")"))) 642 (setq lhs (math--comp-round-bracket lhs)))
642 (and (memq calc-language '(tex latex)) 643 (and (memq calc-language '(tex latex))
643 (or (equal (car op) "^") (equal (car op) "_")) 644 (or (equal (car op) "^") (equal (car op) "_"))
644 (not (and (stringp rhs) (= (length rhs) 1))) 645 (not (and (stringp rhs) (= (length rhs) 1)))
@@ -721,7 +722,7 @@
721 (list 'horiz "{left ( " 722 (list 'horiz "{left ( "
722 (math-compose-expr a -1) 723 (math-compose-expr a -1)
723 " right )}"))) 724 " right )}")))
724 (list 'horiz "(" (math-compose-expr a 0) ")")))) 725 (math--comp-round-bracket (math-compose-expr a 0)))))
725 (t 726 (t
726 (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op)))) 727 (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
727 (list 'horiz 728 (list 'horiz
@@ -759,7 +760,7 @@
759 (list 'horiz "{left ( " 760 (list 'horiz "{left ( "
760 (math-compose-expr a -1) 761 (math-compose-expr a -1)
761 " right )}"))) 762 " right )}")))
762 (list 'horiz "(" (math-compose-expr a 0) ")")))) 763 (math--comp-round-bracket (math-compose-expr a 0)))))
763 (t 764 (t
764 (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op)))) 765 (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
765 (list 'horiz 766 (list 'horiz
@@ -821,9 +822,16 @@
821 (if (setq spfn (get calc-language 'math-func-formatter)) 822 (if (setq spfn (get calc-language 'math-func-formatter))
822 (funcall spfn func a) 823 (funcall spfn func a)
823 824
824 (list 'horiz func calc-function-open 825 (let ((args (math-compose-vector (cdr a) ", " 0)))
825 (math-compose-vector (cdr a) ", " 0) 826 (if (and (member calc-function-open '("(" "[" "{"))
826 calc-function-close)))))))))) 827 (member calc-function-close '(")" "]" "}")))
828 (list 'horiz func
829 (math--comp-bracket
830 (string-to-char calc-function-open)
831 (string-to-char calc-function-close)
832 args))
833 (list 'horiz func calc-function-open
834 args calc-function-close))))))))))))
827 835
828 836
829(defun math-prod-first-term (x) 837(defun math-prod-first-term (x)
@@ -966,6 +974,69 @@
966 (and (memq (car a) '(^ calcFunc-subscr)) 974 (and (memq (car a) '(^ calcFunc-subscr))
967 (math-tex-expr-is-flat (nth 1 a))))) 975 (math-tex-expr-is-flat (nth 1 a)))))
968 976
977;; FIXME: maybe try box drawing chars if big bracket chars are unavailable,
978;; like ┌ ┐n
979;; │a + b│ ┌ a + b ┐n
980;; │-----│ or │ ----- │ ?
981;; │ c │ └ c ┘
982;; └ ┘
983;; They are more common than the chars below, but look a bit square.
984;; Rounded corners exist but are less commonly available.
985
986(defconst math--big-bracket-alist
987 '((?\( . (?⎛ ?⎝ ?⎜))
988 (?\) . (?⎞ ?⎠ ?⎟))
989 (?\[ . (?⎡ ?⎣ ?⎢))
990 (?\] . (?⎤ ?⎦ ?⎥))
991 (?\{ . (?⎧ ?⎩ ?⎪ ?⎨))
992 (?\} . (?⎫ ?⎭ ?⎪ ?⎬)))
993 "Alist mapping bracket chars to (UPPER LOWER EXTENSION MIDPIECE).
994Not all brackets have midpieces.")
995
996(defun math--big-bracket (bracket-char height baseline)
997 "Composition for BRACKET-CHAR of HEIGHT with BASELINE."
998 (if (<= height 1)
999 (char-to-string bracket-char)
1000 (let ((pieces (cdr (assq bracket-char math--big-bracket-alist))))
1001 (if (memq nil (mapcar #'char-displayable-p pieces))
1002 (char-to-string bracket-char)
1003 (let* ((upper (nth 0 pieces))
1004 (lower (nth 1 pieces))
1005 (extension (nth 2 pieces))
1006 (midpiece (nth 3 pieces)))
1007 (cons 'vleft ; alignment doesn't matter; width is 1 char
1008 (cons baseline
1009 (mapcar
1010 #'char-to-string
1011 (append
1012 (list upper)
1013 (if midpiece
1014 (let ((lower-ext (/ (- height 3) 2)))
1015 (append
1016 (make-list (- height 3 lower-ext) extension)
1017 (list midpiece)
1018 (make-list lower-ext extension)))
1019 (make-list (- height 2) extension))
1020 (list lower))))))))))
1021
1022(defun math--comp-bracket (left-bracket right-bracket comp)
1023 "Put the composition COMP inside LEFT-BRACKET and RIGHT-BRACKET."
1024 (if (eq calc-language 'big)
1025 (let ((height (math-comp-height comp))
1026 (baseline (1- (math-comp-ascent comp))))
1027 (list 'horiz
1028 (math--big-bracket left-bracket height baseline)
1029 comp
1030 (math--big-bracket right-bracket height baseline)))
1031 (list 'horiz
1032 (char-to-string left-bracket)
1033 comp
1034 (char-to-string right-bracket))))
1035
1036(defun math--comp-round-bracket (comp)
1037 "Put the composition COMP inside plain brackets."
1038 (math--comp-bracket ?\( ?\) comp))
1039
969(put 'calcFunc-log 'math-compose-big #'math-compose-log) 1040(put 'calcFunc-log 'math-compose-big #'math-compose-log)
970(defun math-compose-log (a _prec) 1041(defun math-compose-log (a _prec)
971 (and (= (length a) 3) 1042 (and (= (length a) 3)
@@ -973,18 +1044,14 @@
973 (list 'subscr "log" 1044 (list 'subscr "log"
974 (let ((calc-language 'flat)) 1045 (let ((calc-language 'flat))
975 (math-compose-expr (nth 2 a) 1000))) 1046 (math-compose-expr (nth 2 a) 1000)))
976 "(" 1047 (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000)))))
977 (math-compose-expr (nth 1 a) 1000)
978 ")")))
979 1048
980(put 'calcFunc-log10 'math-compose-big #'math-compose-log10) 1049(put 'calcFunc-log10 'math-compose-big #'math-compose-log10)
981(defun math-compose-log10 (a _prec) 1050(defun math-compose-log10 (a _prec)
982 (and (= (length a) 2) 1051 (and (= (length a) 2)
983 (list 'horiz 1052 (list 'horiz
984 (list 'subscr "log" "10") 1053 (list 'subscr "log" "10")
985 "(" 1054 (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000)))))
986 (math-compose-expr (nth 1 a) 1000)
987 ")")))
988 1055
989(put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv) 1056(put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv)
990(put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv) 1057(put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv)
@@ -1027,12 +1094,9 @@
1027(defun math-compose-choose (a _prec) 1094(defun math-compose-choose (a _prec)
1028 (let ((a1 (math-compose-expr (nth 1 a) 0)) 1095 (let ((a1 (math-compose-expr (nth 1 a) 0))
1029 (a2 (math-compose-expr (nth 2 a) 0))) 1096 (a2 (math-compose-expr (nth 2 a) 0)))
1030 (list 'horiz 1097 (math--comp-round-bracket (list 'vcent
1031 "(" 1098 (+ (math-comp-height a1))
1032 (list 'vcent 1099 a1 " " a2))))
1033 (math-comp-height a1)
1034 a1 " " a2)
1035 ")")))
1036 1100
1037(put 'calcFunc-integ 'math-compose-big #'math-compose-integ) 1101(put 'calcFunc-integ 'math-compose-big #'math-compose-integ)
1038(defun math-compose-integ (a prec) 1102(defun math-compose-integ (a prec)
@@ -1052,9 +1116,12 @@
1052 "d%s" 1116 "d%s"
1053 (nth 1 (nth 2 a))))) 1117 (nth 1 (nth 2 a)))))
1054 (nth 1 a)) 185)) 1118 (nth 1 a)) 185))
1055 (calc-language 'flat) 1119 (low (and (nth 3 a)
1056 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) 1120 (let ((calc-language 'flat))
1057 (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))) 1121 (math-compose-expr (nth 3 a) 0))))
1122 (high (and (nth 4 a)
1123 (let ((calc-language 'flat))
1124 (math-compose-expr (nth 4 a) 0))))
1058 ;; Check if we have Unicode integral top/bottom parts. 1125 ;; Check if we have Unicode integral top/bottom parts.
1059 (fancy (and (char-displayable-p ?⌠) 1126 (fancy (and (char-displayable-p ?⌠)
1060 (char-displayable-p ?⌡))) 1127 (char-displayable-p ?⌡)))
@@ -1066,40 +1133,47 @@
1066 ((char-displayable-p ?│) "│ ") 1133 ((char-displayable-p ?│) "│ ")
1067 ;; U+007C VERTICAL LINE 1134 ;; U+007C VERTICAL LINE
1068 (t "| ")))) 1135 (t "| "))))
1069 (list 'horiz 1136 (let ((comp
1070 (if parens "(" "") 1137 (list 'horiz
1071 (append (list 'vcent (if fancy 1138 (append (list 'vcent (if fancy
1072 (if high 2 1) 1139 (if high 2 1)
1073 (if high 3 2))) 1140 (if high 3 2)))
1074 (and high (list (if fancy 1141 (and high (list (if fancy
1075 (list 'horiz high " ") 1142 (list 'horiz high " ")
1076 (list 'horiz " " high)))) 1143 (list 'horiz " " high))))
1077 (if fancy 1144 (if fancy
1078 (list "⌠ " fancy-stem "⌡ ") 1145 (list "⌠ " fancy-stem "⌡ ")
1079 '(" /" 1146 '(" /"
1080 " | " 1147 " | "
1081 " | " 1148 " | "
1082 " | " 1149 " | "
1083 "/ ")) 1150 "/ "))
1084 (and low (list (if fancy 1151 (and low (list (if fancy
1085 (list 'horiz low " ") 1152 (list 'horiz low " ")
1086 (list 'horiz low " "))))) 1153 (list 'horiz low " ")))))
1087 expr 1154 expr
1088 (if over 1155 (if over
1089 "" 1156 ""
1090 (list 'horiz " d" var)) 1157 (list 'horiz " d" var)))))
1091 (if parens ")" ""))))) 1158 (if parens
1159 (math--comp-round-bracket comp)
1160 comp)))))
1092 1161
1093(put 'calcFunc-sum 'math-compose-big #'math-compose-sum) 1162(put 'calcFunc-sum 'math-compose-big #'math-compose-sum)
1094(defun math-compose-sum (a prec) 1163(defun math-compose-sum (a prec)
1095 (and (memq (length a) '(3 5 6)) 1164 (and (memq (length a) '(3 5 6))
1096 (let* ((expr (math-compose-expr (nth 1 a) 185)) 1165 (let* ((expr (math-compose-expr (nth 1 a) 185))
1097 (calc-language 'flat) 1166 (var
1098 (var (math-compose-expr (nth 2 a) 0)) 1167 (let ((calc-language 'flat))
1099 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) 1168 (math-compose-expr (nth 2 a) 0)))
1100 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) 1169 (low (and (nth 3 a)
1101 (list 'horiz 1170 (let ((calc-language 'flat))
1102 (if (memq prec '(180 201)) "(" "") 1171 (math-compose-expr (nth 3 a) 0))))
1172 (high (and (nth 4 a)
1173 (let ((calc-language 'flat))
1174 (math-compose-vector (nthcdr 4 a) ", " 0))))
1175 (comp
1176 (list 'horiz
1103 (append (list 'vcent (if high 3 2)) 1177 (append (list 'vcent (if high 3 2))
1104 (and high (list high)) 1178 (and high (list high))
1105 '("---- " 1179 '("---- "
@@ -1112,32 +1186,42 @@
1112 (list var))) 1186 (list var)))
1113 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) 1187 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1114 " " "") 1188 " " "")
1115 expr 1189 expr)))
1116 (if (memq prec '(180 201)) ")" ""))))) 1190 (if (memq prec '(180 201))
1191 (math--comp-round-bracket comp)
1192 comp))))
1117 1193
1118(put 'calcFunc-prod 'math-compose-big #'math-compose-prod) 1194(put 'calcFunc-prod 'math-compose-big #'math-compose-prod)
1119(defun math-compose-prod (a prec) 1195(defun math-compose-prod (a prec)
1120 (and (memq (length a) '(3 5 6)) 1196 (and (memq (length a) '(3 5 6))
1121 (let* ((expr (math-compose-expr (nth 1 a) 198)) 1197 (let* ((expr (math-compose-expr (nth 1 a) 198))
1122 (calc-language 'flat) 1198 (var
1123 (var (math-compose-expr (nth 2 a) 0)) 1199 (let ((calc-language 'flat))
1124 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) 1200 (math-compose-expr (nth 2 a) 0)))
1125 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) 1201 (low (and (nth 3 a)
1126 (list 'horiz 1202 (let ((calc-language 'flat))
1127 (if (memq prec '(196 201)) "(" "") 1203 (math-compose-expr (nth 3 a) 0))))
1128 (append (list 'vcent (if high 3 2)) 1204 (high (and (nth 4 a)
1129 (and high (list high)) 1205 (let ((calc-language 'flat))
1130 '("----- " 1206 (math-compose-vector (nthcdr 4 a) ", " 0))))
1131 " | | " 1207 (comp
1132 " | | " 1208 (list 'horiz
1133 " | | ") 1209 (append (list 'vcent (if high 3 2))
1134 (if low 1210 (and high (list high))
1135 (list (list 'horiz var " = " low)) 1211 '("----- "
1136 (list var))) 1212 " | | "
1137 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) 1213 " | | "
1138 " " "") 1214 " | | ")
1139 expr 1215 (if low
1140 (if (memq prec '(196 201)) ")" ""))))) 1216 (list (list 'horiz var " = " low))
1217 (list var)))
1218 (if (memq (car-safe (nth 1 a))
1219 '(calcFunc-sum calcFunc-prod))
1220 " " "")
1221 expr)))
1222 (if (memq prec '(196 201))
1223 (math--comp-round-bracket comp)
1224 comp))))
1141 1225
1142;; The variables math-svo-c, math-svo-wid and math-svo-off are local 1226;; The variables math-svo-c, math-svo-wid and math-svo-off are local
1143;; to math-stack-value-offset in calc.el, but are used by 1227;; to math-stack-value-offset in calc.el, but are used by
diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el
index 22e4cdbcd52..c2e4205c0bc 100644
--- a/lisp/calendar/cal-bahai.el
+++ b/lisp/calendar/cal-bahai.el
@@ -1,4 +1,4 @@
1;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. 1;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
4 4
@@ -124,9 +124,10 @@ Defaults to today's date if DATE is not given."
124 (y (calendar-extract-year bahai-date))) 124 (y (calendar-extract-year bahai-date)))
125 (if (< y 1) 125 (if (< y 1)
126 "" ; pre-Bahai 126 "" ; pre-Bahai
127 (let* ((m (calendar-extract-month bahai-date)) 127 (let ((m (calendar-extract-month bahai-date))
128 (d (calendar-extract-day bahai-date)) 128 (d (calendar-extract-day bahai-date)))
129 (monthname (if (and (= m 19) 129 (calendar-dlet*
130 ((monthname (if (and (= m 19)
130 (<= d 0)) 131 (<= d 0))
131 "Ayyám-i-Há" 132 "Ayyám-i-Há"
132 (aref calendar-bahai-month-name-array (1- m)))) 133 (aref calendar-bahai-month-name-array (1- m))))
@@ -137,8 +138,8 @@ Defaults to today's date if DATE is not given."
137 (year (number-to-string y)) 138 (year (number-to-string y))
138 (month (number-to-string m)) 139 (month (number-to-string m))
139 dayname) 140 dayname)
140 ;; Can't call calendar-date-string because of monthname oddity. 141 ;; Can't call calendar-date-string because of monthname oddity.
141 (mapconcat 'eval calendar-date-display-form ""))))) 142 (mapconcat #'eval calendar-date-display-form ""))))))
142 143
143;;;###cal-autoload 144;;;###cal-autoload
144(defun calendar-bahai-print-date () 145(defun calendar-bahai-print-date ()
@@ -153,13 +154,12 @@ Defaults to today's date if DATE is not given."
153 "Interactively read the arguments for a Bahá’í date command. 154 "Interactively read the arguments for a Bahá’í date command.
154Reads a year, month and day." 155Reads a year, month and day."
155 (let* ((today (calendar-current-date)) 156 (let* ((today (calendar-current-date))
156 (year (calendar-read 157 (year (calendar-read-sexp
157 "Bahá’í calendar year (not 0): " 158 "Bahá’í calendar year (not 0)"
158 (lambda (x) (not (zerop x))) 159 (lambda (x) (not (zerop x)))
159 (number-to-string 160 (calendar-extract-year
160 (calendar-extract-year 161 (calendar-bahai-from-absolute
161 (calendar-bahai-from-absolute 162 (calendar-absolute-from-gregorian today)))))
162 (calendar-absolute-from-gregorian today))))))
163 (completion-ignore-case t) 163 (completion-ignore-case t)
164 (month (cdr (assoc 164 (month (cdr (assoc
165 (completing-read 165 (completing-read
@@ -169,8 +169,8 @@ Reads a year, month and day."
169 nil t) 169 nil t)
170 (calendar-make-alist calendar-bahai-month-name-array 170 (calendar-make-alist calendar-bahai-month-name-array
171 1)))) 171 1))))
172 (day (calendar-read "Bahá’í calendar day (1-19): " 172 (day (calendar-read-sexp "Bahá’í calendar day (1-19)"
173 (lambda (x) (and (< 0 x) (<= x 19)))))) 173 (lambda (x) (and (< 0 x) (<= x 19))))))
174 (list (list month day year)))) 174 (list (list month day year))))
175 175
176;;;###cal-autoload 176;;;###cal-autoload
diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el
index 7e5d0c46e11..9a28984a7ab 100644
--- a/lisp/calendar/cal-china.el
+++ b/lisp/calendar/cal-china.el
@@ -1,4 +1,4 @@
1;;; cal-china.el --- calendar functions for the Chinese calendar 1;;; cal-china.el --- calendar functions for the Chinese calendar -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -185,7 +185,9 @@ N congruent to 1 gives the first name, N congruent to 2 gives the second name,
185(defun calendar-chinese-zodiac-sign-on-or-after (d) 185(defun calendar-chinese-zodiac-sign-on-or-after (d)
186 "Absolute date of first new Zodiac sign on or after absolute date D. 186 "Absolute date of first new Zodiac sign on or after absolute date D.
187The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." 187The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
188 (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) 188 (with-suppressed-warnings ((lexical year))
189 (defvar year))
190 (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
189 (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year 191 (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year
190 (calendar-daylight-time-offset 192 (calendar-daylight-time-offset
191 calendar-chinese-daylight-time-offset) 193 calendar-chinese-daylight-time-offset)
@@ -207,6 +209,8 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
207 209
208(defun calendar-chinese-new-moon-on-or-after (d) 210(defun calendar-chinese-new-moon-on-or-after (d)
209 "Absolute date of first new moon on or after absolute date D." 211 "Absolute date of first new moon on or after absolute date D."
212 (with-suppressed-warnings ((lexical year))
213 (defvar year))
210 (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) 214 (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
211 (calendar-time-zone (eval calendar-chinese-time-zone)) 215 (calendar-time-zone (eval calendar-chinese-time-zone))
212 (calendar-daylight-time-offset 216 (calendar-daylight-time-offset
@@ -602,14 +606,14 @@ Echo Chinese date unless NOECHO is non-nil."
602 (interactive 606 (interactive
603 (let* ((c (calendar-chinese-from-absolute 607 (let* ((c (calendar-chinese-from-absolute
604 (calendar-absolute-from-gregorian (calendar-current-date)))) 608 (calendar-absolute-from-gregorian (calendar-current-date))))
605 (cycle (calendar-read 609 (cycle (calendar-read-sexp
606 "Chinese calendar cycle number (>44): " 610 "Chinese calendar cycle number (>44)"
607 (lambda (x) (> x 44)) 611 (lambda (x) (> x 44))
608 (number-to-string (car c)))) 612 (car c)))
609 (year (calendar-read 613 (year (calendar-read-sexp
610 "Year in Chinese cycle (1..60): " 614 "Year in Chinese cycle (1..60)"
611 (lambda (x) (and (<= 1 x) (<= x 60))) 615 (lambda (x) (and (<= 1 x) (<= x 60)))
612 (number-to-string (cadr c)))) 616 (cadr c)))
613 (month-list (calendar-chinese-months-to-alist 617 (month-list (calendar-chinese-months-to-alist
614 (calendar-chinese-months cycle year))) 618 (calendar-chinese-months cycle year)))
615 (month (cdr (assoc 619 (month (cdr (assoc
@@ -624,9 +628,11 @@ Echo Chinese date unless NOECHO is non-nil."
624 (list cycle year month 1)))))) 628 (list cycle year month 1))))))
625 30 629 30
626 29)) 630 29))
627 (day (calendar-read 631 (day (calendar-read-sexp
628 (format "Chinese calendar day (1-%d): " last) 632 "Chinese calendar day (1-%d)"
629 (lambda (x) (and (<= 1 x) (<= x last)))))) 633 (lambda (x) (and (<= 1 x) (<= x last)))
634 nil
635 last)))
630 (list (list cycle year month day)))) 636 (list (list cycle year month day))))
631 (calendar-goto-date (calendar-gregorian-from-absolute 637 (calendar-goto-date (calendar-gregorian-from-absolute
632 (calendar-chinese-to-absolute date))) 638 (calendar-chinese-to-absolute date)))
@@ -663,17 +669,17 @@ Echo Chinese date unless NOECHO is non-nil."
663 ["正月" "二月" "三月" "四月" "五月" "六月" 669 ["正月" "二月" "三月" "四月" "五月" "六月"
664 "七月" "八月" "九月" "十月" "冬月" "臘月"]) 670 "七月" "八月" "九月" "十月" "冬月" "臘月"])
665 671
666;;; NOTE: In the diary the cycle and year of a Chinese date is 672;; NOTE: In the diary the cycle and year of a Chinese date is
667;;; combined using this formula: (+ (* cycle 100) year). 673;; combined using this formula: (+ (* cycle 100) year).
668;;; 674;;;
669;;; These two functions convert to and back from this representation. 675;; These two functions convert to and back from this representation.
670(defun calendar-chinese-from-absolute-for-diary (date) 676(defun calendar-chinese-from-absolute-for-diary (thedate)
671 (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date))) 677 (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute thedate)))
672 ;; Note: For leap months M is a float. 678 ;; Note: For leap months M is a float.
673 (list (floor m) d (+ (* c 100) y)))) 679 (list (floor m) d (+ (* c 100) y))))
674 680
675(defun calendar-chinese-to-absolute-for-diary (date &optional prefer-leap) 681(defun calendar-chinese-to-absolute-for-diary (thedate &optional prefer-leap)
676 (pcase-let* ((`(,m ,d ,y) date) 682 (pcase-let* ((`(,m ,d ,y) thedate)
677 (cycle (floor y 100)) 683 (cycle (floor y 100))
678 (year (mod y 100)) 684 (year (mod y 100))
679 (months (calendar-chinese-months cycle year)) 685 (months (calendar-chinese-months cycle year))
@@ -691,7 +697,8 @@ Echo Chinese date unless NOECHO is non-nil."
691 (unless (zerop month) 697 (unless (zerop month)
692 (calendar-mark-1 month day year 698 (calendar-mark-1 month day year
693 #'calendar-chinese-from-absolute-for-diary 699 #'calendar-chinese-from-absolute-for-diary
694 (lambda (date) (calendar-chinese-to-absolute-for-diary date t)) 700 (lambda (thedate)
701 (calendar-chinese-to-absolute-for-diary thedate t))
695 color))) 702 color)))
696 703
697;;;###cal-autoload 704;;;###cal-autoload
diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el
index 3461f3259b9..346585e1817 100644
--- a/lisp/calendar/cal-coptic.el
+++ b/lisp/calendar/cal-coptic.el
@@ -1,4 +1,4 @@
1;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars 1;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -116,12 +116,13 @@ Defaults to today's date if DATE is not given."
116 (m (calendar-extract-month coptic-date))) 116 (m (calendar-extract-month coptic-date)))
117 (if (< y 1) 117 (if (< y 1)
118 "" 118 ""
119 (let ((monthname (aref calendar-coptic-month-name-array (1- m))) 119 (calendar-dlet*
120 (day (number-to-string (calendar-extract-day coptic-date))) 120 ((monthname (aref calendar-coptic-month-name-array (1- m)))
121 (dayname nil) 121 (day (number-to-string (calendar-extract-day coptic-date)))
122 (month (number-to-string m)) 122 (dayname nil)
123 (year (number-to-string y))) 123 (month (number-to-string m))
124 (mapconcat 'eval calendar-date-display-form ""))))) 124 (year (number-to-string y)))
125 (mapconcat #'eval calendar-date-display-form "")))))
125 126
126;;;###cal-autoload 127;;;###cal-autoload
127(defun calendar-coptic-print-date () 128(defun calendar-coptic-print-date ()
@@ -136,13 +137,13 @@ Defaults to today's date if DATE is not given."
136 "Interactively read the arguments for a Coptic date command. 137 "Interactively read the arguments for a Coptic date command.
137Reads a year, month, and day." 138Reads a year, month, and day."
138 (let* ((today (calendar-current-date)) 139 (let* ((today (calendar-current-date))
139 (year (calendar-read 140 (year (calendar-read-sexp
140 (format "%s calendar year (>0): " calendar-coptic-name) 141 "%s calendar year (>0)"
141 (lambda (x) (> x 0)) 142 (lambda (x) (> x 0))
142 (number-to-string 143 (calendar-extract-year
143 (calendar-extract-year 144 (calendar-coptic-from-absolute
144 (calendar-coptic-from-absolute 145 (calendar-absolute-from-gregorian today)))
145 (calendar-absolute-from-gregorian today)))))) 146 calendar-coptic-name))
146 (completion-ignore-case t) 147 (completion-ignore-case t)
147 (month (cdr (assoc-string 148 (month (cdr (assoc-string
148 (completing-read 149 (completing-read
@@ -151,11 +152,14 @@ Reads a year, month, and day."
151 (append calendar-coptic-month-name-array nil)) 152 (append calendar-coptic-month-name-array nil))
152 nil t) 153 nil t)
153 (calendar-make-alist calendar-coptic-month-name-array 154 (calendar-make-alist calendar-coptic-month-name-array
154 1) t))) 155 1)
156 t)))
155 (last (calendar-coptic-last-day-of-month month year)) 157 (last (calendar-coptic-last-day-of-month month year))
156 (day (calendar-read 158 (day (calendar-read-sexp
157 (format "%s calendar day (1-%d): " calendar-coptic-name last) 159 "%s calendar day (1-%d)"
158 (lambda (x) (and (< 0 x) (<= x last)))))) 160 (lambda (x) (and (< 0 x) (<= x last)))
161 nil
162 calendar-coptic-name last)))
159 (list (list month day year)))) 163 (list (list month day year))))
160 164
161;;;###cal-autoload 165;;;###cal-autoload
@@ -194,30 +198,30 @@ Echo Coptic date unless NOECHO is t."
194(defconst calendar-ethiopic-name "Ethiopic" 198(defconst calendar-ethiopic-name "Ethiopic"
195 "Used in some message strings.") 199 "Used in some message strings.")
196 200
197(defun calendar-ethiopic-to-absolute (date) 201(defun calendar-ethiopic-to-absolute (thedate)
198 "Compute absolute date from Ethiopic date DATE. 202 "Compute absolute date from Ethiopic date DATE.
199The absolute date is the number of days elapsed since the (imaginary) 203The absolute date is the number of days elapsed since the (imaginary)
200Gregorian date Sunday, December 31, 1 BC." 204Gregorian date Sunday, December 31, 1 BC."
201 (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) 205 (let ((calendar-coptic-epoch calendar-ethiopic-epoch))
202 (calendar-coptic-to-absolute date))) 206 (calendar-coptic-to-absolute thedate)))
203 207
204(defun calendar-ethiopic-from-absolute (date) 208(defun calendar-ethiopic-from-absolute (thedate)
205 "Compute the Ethiopic equivalent for absolute date DATE. 209 "Compute the Ethiopic equivalent for absolute date DATE.
206The result is a list of the form (MONTH DAY YEAR). 210The result is a list of the form (MONTH DAY YEAR).
207The absolute date is the number of days elapsed since the imaginary 211The absolute date is the number of days elapsed since the imaginary
208Gregorian date Sunday, December 31, 1 BC." 212Gregorian date Sunday, December 31, 1 BC."
209 (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) 213 (let ((calendar-coptic-epoch calendar-ethiopic-epoch))
210 (calendar-coptic-from-absolute date))) 214 (calendar-coptic-from-absolute thedate)))
211 215
212;;;###cal-autoload 216;;;###cal-autoload
213(defun calendar-ethiopic-date-string (&optional date) 217(defun calendar-ethiopic-date-string (&optional thedate)
214 "String of Ethiopic date of Gregorian DATE. 218 "String of Ethiopic date of Gregorian DATE.
215Returns the empty string if DATE is pre-Ethiopic calendar. 219Returns the empty string if DATE is pre-Ethiopic calendar.
216Defaults to today's date if DATE is not given." 220Defaults to today's date if DATE is not given."
217 (let ((calendar-coptic-epoch calendar-ethiopic-epoch) 221 (let ((calendar-coptic-epoch calendar-ethiopic-epoch)
218 (calendar-coptic-name calendar-ethiopic-name) 222 (calendar-coptic-name calendar-ethiopic-name)
219 (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) 223 (calendar-coptic-month-name-array calendar-ethiopic-month-name-array))
220 (calendar-coptic-date-string date))) 224 (calendar-coptic-date-string thedate)))
221 225
222;;;###cal-autoload 226;;;###cal-autoload
223(defun calendar-ethiopic-print-date () 227(defun calendar-ethiopic-print-date ()
@@ -229,8 +233,8 @@ Defaults to today's date if DATE is not given."
229 (call-interactively 'calendar-coptic-print-date))) 233 (call-interactively 'calendar-coptic-print-date)))
230 234
231;;;###cal-autoload 235;;;###cal-autoload
232(defun calendar-ethiopic-goto-date (date &optional noecho) 236(defun calendar-ethiopic-goto-date (thedate &optional noecho)
233 "Move cursor to Ethiopic date DATE. 237 "Move cursor to Ethiopic date THEDATE.
234Echo Ethiopic date unless NOECHO is t." 238Echo Ethiopic date unless NOECHO is t."
235 (interactive 239 (interactive
236 (let ((calendar-coptic-epoch calendar-ethiopic-epoch) 240 (let ((calendar-coptic-epoch calendar-ethiopic-epoch)
@@ -238,7 +242,7 @@ Echo Ethiopic date unless NOECHO is t."
238 (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) 242 (calendar-coptic-month-name-array calendar-ethiopic-month-name-array))
239 (calendar-coptic-read-date))) 243 (calendar-coptic-read-date)))
240 (calendar-goto-date (calendar-gregorian-from-absolute 244 (calendar-goto-date (calendar-gregorian-from-absolute
241 (calendar-ethiopic-to-absolute date))) 245 (calendar-ethiopic-to-absolute thedate)))
242 (or noecho (calendar-ethiopic-print-date))) 246 (or noecho (calendar-ethiopic-print-date)))
243 247
244;; To be called from diary-list-sexp-entries, where DATE is bound. 248;; To be called from diary-list-sexp-entries, where DATE is bound.
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el
index e759b5dad95..639bae700cc 100644
--- a/lisp/calendar/cal-french.el
+++ b/lisp/calendar/cal-french.el
@@ -1,4 +1,4 @@
1;;; cal-french.el --- calendar functions for the French Revolutionary calendar 1;;; cal-french.el --- calendar functions for the French Revolutionary calendar -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free 3;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free
4;; Software Foundation, Inc. 4;; Software Foundation, Inc.
@@ -35,54 +35,45 @@
35(defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792)) 35(defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792))
36 "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.") 36 "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.")
37 37
38(defconst calendar-french-month-name-array 38(define-obsolete-variable-alias 'calendar-french-multibyte-month-name-array
39 ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se" 39 'calendar-french-month-name-array "28.1")
40 "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]
41 "Array of month names in the French calendar.")
42 40
43(defconst calendar-french-multibyte-month-name-array 41(defconst calendar-french-month-name-array
44 ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" 42 ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
45 "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"] 43 "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
46 "Array of multibyte month names in the French calendar.") 44 "Array of month names in the French calendar.")
47 45
48(defconst calendar-french-day-name-array 46(defconst calendar-french-day-name-array
49 ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" 47 ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
50 "Octidi" "Nonidi" "Decadi"] 48 "Octidi" "Nonidi" "Decadi"]
51 "Array of day names in the French calendar.") 49 "Array of day names in the French calendar.")
52 50
53(defconst calendar-french-special-days-array 51(define-obsolete-variable-alias 'calendar-french-multibyte-special-days-array
54 ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses" 52 'calendar-french-special-days-array "28.1")
55 "de la Re'volution"]
56 "Array of special day names in the French calendar.")
57 53
58(defconst calendar-french-multibyte-special-days-array 54(defconst calendar-french-special-days-array
59 ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses" 55 ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
60 "de la Révolution"] 56 "de la Révolution"]
61 "Array of multibyte special day names in the French calendar.") 57 "Array of special day names in the French calendar.")
62 58
63(defun calendar-french-accents-p () 59(defun calendar-french-accents-p ()
64 "Return non-nil if diacritical marks are available." 60 (declare (obsolete nil "28.1"))
65 (and (or window-system 61 t)
66 (terminal-coding-system))
67 (or enable-multibyte-characters
68 (and (char-table-p standard-display-table)
69 (equal (aref standard-display-table 161) [161])))))
70 62
71(defun calendar-french-month-name-array () 63(defun calendar-french-month-name-array ()
72 "Return the array of month names, depending on whether accents are available." 64 "Return the array of month names, depending on whether accents are available."
73 (if (calendar-french-accents-p) 65 (declare (obsolete "use the variable of the same name instead" "28.1"))
74 calendar-french-multibyte-month-name-array 66 calendar-french-month-name-array)
75 calendar-french-month-name-array))
76 67
77(defun calendar-french-day-name-array () 68(defun calendar-french-day-name-array ()
78 "Return the array of day names." 69 "Return the array of day names."
70 (declare (obsolete "use the variable of the same name instead" "28.1"))
79 calendar-french-day-name-array) 71 calendar-french-day-name-array)
80 72
81(defun calendar-french-special-days-array () 73(defun calendar-french-special-days-array ()
82 "Return the special day names, depending on whether accents are available." 74 "Return the special day names, depending on whether accents are available."
83 (if (calendar-french-accents-p) 75 (declare (obsolete "use the variable of the same name instead" "28.1"))
84 calendar-french-multibyte-special-days-array 76 calendar-french-special-days-array)
85 calendar-french-special-days-array))
86 77
87(defun calendar-french-leap-year-p (year) 78(defun calendar-french-leap-year-p (year)
88 "True if YEAR is a leap year on the French Revolutionary calendar. 79 "True if YEAR is a leap year on the French Revolutionary calendar.
@@ -171,17 +162,13 @@ Defaults to today's date if DATE is not given."
171 (d (calendar-extract-day french-date))) 162 (d (calendar-extract-day french-date)))
172 (cond 163 (cond
173 ((< y 1) "") 164 ((< y 1) "")
174 ((= m 13) (format (if (calendar-french-accents-p) 165 ((= m 13) (format "Jour %s de l'Année %d de la Révolution"
175 "Jour %s de l'Année %d de la Révolution" 166 (aref calendar-french-special-days-array (1- d))
176 "Jour %s de l'Anne'e %d de la Re'volution")
177 (aref (calendar-french-special-days-array) (1- d))
178 y)) 167 y))
179 (t (format 168 (t (format
180 (if (calendar-french-accents-p) 169 "%d %s an %d de la Révolution"
181 "%d %s an %d de la Révolution"
182 "%d %s an %d de la Re'volution")
183 d 170 d
184 (aref (calendar-french-month-name-array) (1- m)) 171 (aref calendar-french-month-name-array (1- m))
185 y))))) 172 y)))))
186 173
187;;;###cal-autoload 174;;;###cal-autoload
@@ -198,19 +185,16 @@ Defaults to today's date if DATE is not given."
198 "Move cursor to French Revolutionary date DATE. 185 "Move cursor to French Revolutionary date DATE.
199Echo French Revolutionary date unless NOECHO is non-nil." 186Echo French Revolutionary date unless NOECHO is non-nil."
200 (interactive 187 (interactive
201 (let* ((months (calendar-french-month-name-array)) 188 (let* ((months calendar-french-month-name-array)
202 (special-days (calendar-french-special-days-array)) 189 (special-days calendar-french-special-days-array)
203 (year (progn 190 (year (progn
204 (calendar-read 191 (calendar-read-sexp
205 (if (calendar-french-accents-p) 192 "Année de la Révolution (>0)"
206 "Année de la Révolution (>0): "
207 "Anne'e de la Re'volution (>0): ")
208 (lambda (x) (> x 0)) 193 (lambda (x) (> x 0))
209 (number-to-string 194 (calendar-extract-year
210 (calendar-extract-year 195 (calendar-french-from-absolute
211 (calendar-french-from-absolute 196 (calendar-absolute-from-gregorian
212 (calendar-absolute-from-gregorian 197 (calendar-current-date)))))))
213 (calendar-current-date))))))))
214 (month-list 198 (month-list
215 (mapcar 'list 199 (mapcar 'list
216 (append months 200 (append months
@@ -234,8 +218,8 @@ Echo French Revolutionary date unless NOECHO is non-nil."
234 (calendar-make-alist month-list 1 'car) t))) 218 (calendar-make-alist month-list 1 'car) t)))
235 (day (if (> month 12) 219 (day (if (> month 12)
236 (- month 12) 220 (- month 12)
237 (calendar-read 221 (calendar-read-sexp
238 "Jour (1-30): " 222 "Jour (1-30)"
239 (lambda (x) (and (<= 1 x) (<= x 30)))))) 223 (lambda (x) (and (<= 1 x) (<= x 30))))))
240 (month (if (> month 12) 13 month))) 224 (month (if (> month 12) 13 month)))
241 (list (list month day year)))) 225 (list (list month day year))))
diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el
index bcc80f0877b..50b4fc363bb 100644
--- a/lisp/calendar/cal-hebrew.el
+++ b/lisp/calendar/cal-hebrew.el
@@ -1,4 +1,4 @@
1;;; cal-hebrew.el --- calendar functions for the Hebrew calendar 1;;; cal-hebrew.el --- calendar functions for the Hebrew calendar -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -225,13 +225,12 @@ Driven by the variable `calendar-date-display-form'."
225 "Interactively read the arguments for a Hebrew date command. 225 "Interactively read the arguments for a Hebrew date command.
226Reads a year, month, and day." 226Reads a year, month, and day."
227 (let* ((today (calendar-current-date)) 227 (let* ((today (calendar-current-date))
228 (year (calendar-read 228 (year (calendar-read-sexp
229 "Hebrew calendar year (>3760): " 229 "Hebrew calendar year (>3760)"
230 (lambda (x) (> x 3760)) 230 (lambda (x) (> x 3760))
231 (number-to-string 231 (calendar-extract-year
232 (calendar-extract-year 232 (calendar-hebrew-from-absolute
233 (calendar-hebrew-from-absolute 233 (calendar-absolute-from-gregorian today)))))
234 (calendar-absolute-from-gregorian today))))))
235 (month-array (if (calendar-hebrew-leap-year-p year) 234 (month-array (if (calendar-hebrew-leap-year-p year)
236 calendar-hebrew-month-name-array-leap-year 235 calendar-hebrew-month-name-array-leap-year
237 calendar-hebrew-month-name-array-common-year)) 236 calendar-hebrew-month-name-array-common-year))
@@ -258,10 +257,11 @@ Reads a year, month, and day."
258 (last (calendar-hebrew-last-day-of-month month year)) 257 (last (calendar-hebrew-last-day-of-month month year))
259 (first (if (and (= year 3761) (= month 10)) 258 (first (if (and (= year 3761) (= month 10))
260 18 1)) 259 18 1))
261 (day (calendar-read 260 (day (calendar-read-sexp
262 (format "Hebrew calendar day (%d-%d): " 261 "Hebrew calendar day (%d-%d)"
263 first last) 262 (lambda (x) (and (<= first x) (<= x last)))
264 (lambda (x) (and (<= first x) (<= x last)))))) 263 nil
264 first last)))
265 (list (list month day year)))) 265 (list (list month day year))))
266 266
267;;;###cal-autoload 267;;;###cal-autoload
@@ -399,19 +399,20 @@ is non-nil."
399 (list m (calendar-last-day-of-month m y) y)))))) 399 (list m (calendar-last-day-of-month m y) y))))))
400 (abs-h (calendar-hebrew-to-absolute (list 9 25 h-y))) 400 (abs-h (calendar-hebrew-to-absolute (list 9 25 h-y)))
401 (ord ["first" "second" "third" "fourth" "fifth" "sixth" 401 (ord ["first" "second" "third" "fourth" "fifth" "sixth"
402 "seventh" "eighth"]) 402 "seventh" "eighth"]))
403 han)
404 (holiday-filter-visible-calendar 403 (holiday-filter-visible-calendar
405 (if (or all calendar-hebrew-all-holidays-flag) 404 (if (or all calendar-hebrew-all-holidays-flag)
406 (append 405 (append
407 (list 406 (list
408 (list (calendar-gregorian-from-absolute (1- abs-h)) 407 (list (calendar-gregorian-from-absolute (1- abs-h))
409 "Erev Hanukkah")) 408 "Erev Hanukkah"))
410 (dotimes (i 8 (nreverse han)) 409 (let (han)
411 (push (list 410 (dotimes (i 8)
412 (calendar-gregorian-from-absolute (+ abs-h i)) 411 (push (list
413 (format "Hanukkah (%s day)" (aref ord i))) 412 (calendar-gregorian-from-absolute (+ abs-h i))
414 han))) 413 (format "Hanukkah (%s day)" (aref ord i)))
414 han))
415 (nreverse han)))
415 (list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah"))))))) 416 (list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah")))))))
416 417
417;;;###holiday-autoload 418;;;###holiday-autoload
@@ -681,10 +682,10 @@ from the cursor position."
681 (if (equal (current-buffer) (get-buffer calendar-buffer)) 682 (if (equal (current-buffer) (get-buffer calendar-buffer))
682 (calendar-cursor-to-date t) 683 (calendar-cursor-to-date t)
683 (let* ((today (calendar-current-date)) 684 (let* ((today (calendar-current-date))
684 (year (calendar-read 685 (year (calendar-read-sexp
685 "Year of death (>0): " 686 "Year of death (>0)"
686 (lambda (x) (> x 0)) 687 (lambda (x) (> x 0))
687 (number-to-string (calendar-extract-year today)))) 688 (calendar-extract-year today)))
688 (month-array calendar-month-name-array) 689 (month-array calendar-month-name-array)
689 (completion-ignore-case t) 690 (completion-ignore-case t)
690 (month (cdr (assoc-string 691 (month (cdr (assoc-string
@@ -694,20 +695,23 @@ from the cursor position."
694 nil t) 695 nil t)
695 (calendar-make-alist month-array 1) t))) 696 (calendar-make-alist month-array 1) t)))
696 (last (calendar-last-day-of-month month year)) 697 (last (calendar-last-day-of-month month year))
697 (day (calendar-read 698 (day (calendar-read-sexp
698 (format "Day of death (1-%d): " last) 699 "Day of death (1-%d)"
699 (lambda (x) (and (< 0 x) (<= x last)))))) 700 (lambda (x) (and (< 0 x) (<= x last)))
701 nil
702 last)))
700 (list month day year)))) 703 (list month day year))))
701 (death-year (calendar-extract-year death-date)) 704 (death-year (calendar-extract-year death-date))
702 (start-year (calendar-read 705 (start-year (calendar-read-sexp
703 (format "Starting year of Yahrzeit table (>%d): " 706 "Starting year of Yahrzeit table (>%d)"
704 death-year)
705 (lambda (x) (> x death-year)) 707 (lambda (x) (> x death-year))
706 (number-to-string (1+ death-year)))) 708 (1+ death-year)
707 (end-year (calendar-read 709 death-year))
708 (format "Ending year of Yahrzeit table (>=%d): " 710 (end-year (calendar-read-sexp
709 start-year) 711 "Ending year of Yahrzeit table (>=%d)"
710 (lambda (x) (>= x start-year))))) 712 (lambda (x) (>= x start-year))
713 nil
714 start-year)))
711 (list death-date start-year end-year))) 715 (list death-date start-year end-year)))
712 (message "Computing Yahrzeits...") 716 (message "Computing Yahrzeits...")
713 (let* ((h-date (calendar-hebrew-from-absolute 717 (let* ((h-date (calendar-hebrew-from-absolute
diff --git a/lisp/calendar/cal-html.el b/lisp/calendar/cal-html.el
index 3d7cc938437..e5810c3f027 100644
--- a/lisp/calendar/cal-html.el
+++ b/lisp/calendar/cal-html.el
@@ -1,4 +1,4 @@
1;;; cal-html.el --- functions for printing HTML calendars 1;;; cal-html.el --- functions for printing HTML calendars -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 2002-2021 Free Software Foundation, Inc. 3;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
4 4
@@ -250,7 +250,7 @@ Contains links to previous and next month and year, and current minical."
250 calendar-week-start-day)) 250 calendar-week-start-day))
251 7)) 251 7))
252 (monthpage-name (cal-html-monthpage-name month year)) 252 (monthpage-name (cal-html-monthpage-name month year))
253 date) 253 ) ;; date
254 ;; Start writing table. 254 ;; Start writing table.
255 (insert (cal-html-comment "MINICAL") 255 (insert (cal-html-comment "MINICAL")
256 (cal-html-b-table "class=minical border=1 align=center")) 256 (cal-html-b-table "class=minical border=1 align=center"))
@@ -276,7 +276,7 @@ Contains links to previous and next month and year, and current minical."
276 (insert cal-html-e-tablerow-string 276 (insert cal-html-e-tablerow-string
277 cal-html-b-tablerow-string))) 277 cal-html-b-tablerow-string)))
278 ;; End empty slots (for some browsers like konqueror). 278 ;; End empty slots (for some browsers like konqueror).
279 (dotimes (i end-blank-days) 279 (dotimes (_ end-blank-days)
280 (insert 280 (insert
281 cal-html-b-tabledata-string 281 cal-html-b-tabledata-string
282 cal-html-e-tabledata-string))) 282 cal-html-e-tabledata-string)))
@@ -431,12 +431,11 @@ holidays in HOLIDAY-LIST."
431;;; User commands. 431;;; User commands.
432 432
433;;;###cal-autoload 433;;;###cal-autoload
434(defun cal-html-cursor-month (month year dir &optional event) 434(defun cal-html-cursor-month (month year dir &optional _event)
435 "Write an HTML calendar file for numeric MONTH of four-digit YEAR. 435 "Write an HTML calendar file for numeric MONTH of four-digit YEAR.
436The output directory DIR is created if necessary. Interactively, 436The output directory DIR is created if necessary. Interactively,
437MONTH and YEAR are taken from the calendar cursor position, or from 437MONTH and YEAR are taken from the calendar cursor position.
438the position specified by EVENT. Note that any existing output files 438Note that any existing output files are overwritten."
439are overwritten."
440 (interactive (let* ((event last-nonmenu-event) 439 (interactive (let* ((event last-nonmenu-event)
441 (date (calendar-cursor-to-date t event)) 440 (date (calendar-cursor-to-date t event))
442 (month (calendar-extract-month date)) 441 (month (calendar-extract-month date))
@@ -446,11 +445,11 @@ are overwritten."
446 (cal-html-one-month month year dir)) 445 (cal-html-one-month month year dir))
447 446
448;;;###cal-autoload 447;;;###cal-autoload
449(defun cal-html-cursor-year (year dir &optional event) 448(defun cal-html-cursor-year (year dir &optional _event)
450 "Write HTML calendar files (index and monthly pages) for four-digit YEAR. 449 "Write HTML calendar files (index and monthly pages) for four-digit YEAR.
451The output directory DIR is created if necessary. Interactively, 450The output directory DIR is created if necessary. Interactively,
452YEAR is taken from the calendar cursor position, or from the position 451YEAR is taken from the calendar cursor position.
453specified by EVENT. Note that any existing output files are overwritten." 452Note that any existing output files are overwritten."
454 (interactive (let* ((event last-nonmenu-event) 453 (interactive (let* ((event last-nonmenu-event)
455 (year (calendar-extract-year 454 (year (calendar-extract-year
456 (calendar-cursor-to-date t event)))) 455 (calendar-cursor-to-date t event))))
diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el
index d256310ba6c..45c6ffa7bd7 100644
--- a/lisp/calendar/cal-islam.el
+++ b/lisp/calendar/cal-islam.el
@@ -1,4 +1,4 @@
1;;; cal-islam.el --- calendar functions for the Islamic calendar 1;;; cal-islam.el --- calendar functions for the Islamic calendar -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -67,8 +67,8 @@
67 "Absolute date of Islamic DATE. 67 "Absolute date of Islamic DATE.
68The absolute date is the number of days elapsed since the (imaginary) 68The absolute date is the number of days elapsed since the (imaginary)
69Gregorian date Sunday, December 31, 1 BC." 69Gregorian date Sunday, December 31, 1 BC."
70 (let* ((month (calendar-extract-month date)) 70 (let* (;;(month (calendar-extract-month date))
71 (day (calendar-extract-day date)) 71 ;;(day (calendar-extract-day date))
72 (year (calendar-extract-year date)) 72 (year (calendar-extract-year date))
73 (y (% year 30)) 73 (y (% year 30))
74 (leap-years-in-cycle (cond ((< y 3) 0) 74 (leap-years-in-cycle (cond ((< y 3) 0)
@@ -143,13 +143,12 @@ Driven by the variable `calendar-date-display-form'."
143 "Interactively read the arguments for an Islamic date command. 143 "Interactively read the arguments for an Islamic date command.
144Reads a year, month, and day." 144Reads a year, month, and day."
145 (let* ((today (calendar-current-date)) 145 (let* ((today (calendar-current-date))
146 (year (calendar-read 146 (year (calendar-read-sexp
147 "Islamic calendar year (>0): " 147 "Islamic calendar year (>0)"
148 (lambda (x) (> x 0)) 148 (lambda (x) (> x 0))
149 (number-to-string 149 (calendar-extract-year
150 (calendar-extract-year 150 (calendar-islamic-from-absolute
151 (calendar-islamic-from-absolute 151 (calendar-absolute-from-gregorian today)))))
152 (calendar-absolute-from-gregorian today))))))
153 (month-array calendar-islamic-month-name-array) 152 (month-array calendar-islamic-month-name-array)
154 (completion-ignore-case t) 153 (completion-ignore-case t)
155 (month (cdr (assoc-string 154 (month (cdr (assoc-string
@@ -159,9 +158,11 @@ Reads a year, month, and day."
159 nil t) 158 nil t)
160 (calendar-make-alist month-array 1) t))) 159 (calendar-make-alist month-array 1) t)))
161 (last (calendar-islamic-last-day-of-month month year)) 160 (last (calendar-islamic-last-day-of-month month year))
162 (day (calendar-read 161 (day (calendar-read-sexp
163 (format "Islamic calendar day (1-%d): " last) 162 "Islamic calendar day (1-%d)"
164 (lambda (x) (and (< 0 x) (<= x last)))))) 163 (lambda (x) (and (< 0 x) (<= x last)))
164 nil
165 last)))
165 (list (list month day year)))) 166 (list (list month day year))))
166 167
167;;;###cal-autoload 168;;;###cal-autoload
diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el
index 956433e4a20..90f57c25e9d 100644
--- a/lisp/calendar/cal-iso.el
+++ b/lisp/calendar/cal-iso.el
@@ -1,4 +1,4 @@
1;;; cal-iso.el --- calendar functions for the ISO calendar 1;;; cal-iso.el --- calendar functions for the ISO calendar -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -92,22 +92,23 @@ date Sunday, December 31, 1 BC."
92 "Interactively read the arguments for an ISO date command. 92 "Interactively read the arguments for an ISO date command.
93Reads a year and week, and if DAYFLAG is non-nil a day (otherwise 93Reads a year and week, and if DAYFLAG is non-nil a day (otherwise
94taken to be 1)." 94taken to be 1)."
95 (let* ((year (calendar-read 95 (let* ((year (calendar-read-sexp
96 "ISO calendar year (>0): " 96 "ISO calendar year (>0)"
97 (lambda (x) (> x 0)) 97 (lambda (x) (> x 0))
98 (number-to-string (calendar-extract-year 98 (calendar-extract-year (calendar-current-date))))
99 (calendar-current-date)))))
100 (no-weeks (calendar-extract-month 99 (no-weeks (calendar-extract-month
101 (calendar-iso-from-absolute 100 (calendar-iso-from-absolute
102 (1- 101 (1-
103 (calendar-dayname-on-or-before 102 (calendar-dayname-on-or-before
104 1 (calendar-absolute-from-gregorian 103 1 (calendar-absolute-from-gregorian
105 (list 1 4 (1+ year)))))))) 104 (list 1 4 (1+ year))))))))
106 (week (calendar-read 105 (week (calendar-read-sexp
107 (format "ISO calendar week (1-%d): " no-weeks) 106 "ISO calendar week (1-%d)"
108 (lambda (x) (and (> x 0) (<= x no-weeks))))) 107 (lambda (x) (and (> x 0) (<= x no-weeks)))
109 (day (if dayflag (calendar-read 108 nil
110 "ISO day (1-7): " 109 no-weeks))
110 (day (if dayflag (calendar-read-sexp
111 "ISO day (1-7)"
111 (lambda (x) (and (<= 1 x) (<= x 7)))) 112 (lambda (x) (and (<= 1 x) (<= x 7))))
112 1))) 113 1)))
113 (list (list week day year)))) 114 (list (list week day year))))
diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el
index 235b4d00900..47880a4e974 100644
--- a/lisp/calendar/cal-julian.el
+++ b/lisp/calendar/cal-julian.el
@@ -95,14 +95,13 @@ Driven by the variable `calendar-date-display-form'."
95 "Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil." 95 "Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil."
96 (interactive 96 (interactive
97 (let* ((today (calendar-current-date)) 97 (let* ((today (calendar-current-date))
98 (year (calendar-read 98 (year (calendar-read-sexp
99 "Julian calendar year (>0): " 99 "Julian calendar year (>0)"
100 (lambda (x) (> x 0)) 100 (lambda (x) (> x 0))
101 (number-to-string 101 (calendar-extract-year
102 (calendar-extract-year 102 (calendar-julian-from-absolute
103 (calendar-julian-from-absolute 103 (calendar-absolute-from-gregorian
104 (calendar-absolute-from-gregorian 104 today)))))
105 today))))))
106 (month-array calendar-month-name-array) 105 (month-array calendar-month-name-array)
107 (completion-ignore-case t) 106 (completion-ignore-case t)
108 (month (cdr (assoc-string 107 (month (cdr (assoc-string
@@ -115,12 +114,13 @@ Driven by the variable `calendar-date-display-form'."
115 (if (and (zerop (% year 4)) (= month 2)) 114 (if (and (zerop (% year 4)) (= month 2))
116 29 115 29
117 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) 116 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
118 (day (calendar-read 117 (day (calendar-read-sexp
119 (format "Julian calendar day (%d-%d): " 118 "Julian calendar day (%d-%d)"
120 (if (and (= year 1) (= month 1)) 3 1) last)
121 (lambda (x) 119 (lambda (x)
122 (and (< (if (and (= year 1) (= month 1)) 2 0) x) 120 (and (< (if (and (= year 1) (= month 1)) 2 0) x)
123 (<= x last)))))) 121 (<= x last)))
122 nil
123 (if (and (= year 1) (= month 1)) 3 1) last)))
124 (list (list month day year)))) 124 (list (list month day year))))
125 (calendar-goto-date (calendar-gregorian-from-absolute 125 (calendar-goto-date (calendar-gregorian-from-absolute
126 (calendar-julian-to-absolute date))) 126 (calendar-julian-to-absolute date)))
@@ -173,8 +173,8 @@ Defaults to today's date if DATE is not given."
173(defun calendar-astro-goto-day-number (daynumber &optional noecho) 173(defun calendar-astro-goto-day-number (daynumber &optional noecho)
174 "Move cursor to astronomical (Julian) DAYNUMBER. 174 "Move cursor to astronomical (Julian) DAYNUMBER.
175Echo astronomical (Julian) day number unless NOECHO is non-nil." 175Echo astronomical (Julian) day number unless NOECHO is non-nil."
176 (interactive (list (calendar-read 176 (interactive (list (calendar-read-sexp
177 "Astronomical (Julian) day number (>1721425): " 177 "Astronomical (Julian) day number (>1721425)"
178 (lambda (x) (> x 1721425))))) 178 (lambda (x) (> x 1721425)))))
179 (calendar-goto-date 179 (calendar-goto-date
180 (calendar-gregorian-from-absolute 180 (calendar-gregorian-from-absolute
diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el
index 8d894ebd986..9a221921130 100644
--- a/lisp/calendar/cal-mayan.el
+++ b/lisp/calendar/cal-mayan.el
@@ -1,4 +1,4 @@
1;;; cal-mayan.el --- calendar functions for the Mayan calendars 1;;; cal-mayan.el --- calendar functions for the Mayan calendars -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software 3;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software
4;; Foundation, Inc. 4;; Foundation, Inc.
@@ -135,8 +135,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
135(defun calendar-mayan-read-haab-date () 135(defun calendar-mayan-read-haab-date ()
136 "Prompt for a Mayan haab date." 136 "Prompt for a Mayan haab date."
137 (let* ((completion-ignore-case t) 137 (let* ((completion-ignore-case t)
138 (haab-day (calendar-read 138 (haab-day (calendar-read-sexp
139 "Haab kin (0-19): " 139 "Haab kin (0-19)"
140 (lambda (x) (and (>= x 0) (< x 20))))) 140 (lambda (x) (and (>= x 0) (< x 20)))))
141 (haab-month-list (append calendar-mayan-haab-month-name-array 141 (haab-month-list (append calendar-mayan-haab-month-name-array
142 (and (< haab-day 5) '("Uayeb")))) 142 (and (< haab-day 5) '("Uayeb"))))
@@ -151,8 +151,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
151(defun calendar-mayan-read-tzolkin-date () 151(defun calendar-mayan-read-tzolkin-date ()
152 "Prompt for a Mayan tzolkin date." 152 "Prompt for a Mayan tzolkin date."
153 (let* ((completion-ignore-case t) 153 (let* ((completion-ignore-case t)
154 (tzolkin-count (calendar-read 154 (tzolkin-count (calendar-read-sexp
155 "Tzolkin kin (1-13): " 155 "Tzolkin kin (1-13)"
156 (lambda (x) (and (> x 0) (< x 14))))) 156 (lambda (x) (and (> x 0) (< x 14)))))
157 (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) 157 (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
158 (tzolkin-name (cdr 158 (tzolkin-name (cdr
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el
index a30c681a897..497f3329055 100644
--- a/lisp/calendar/cal-menu.el
+++ b/lisp/calendar/cal-menu.el
@@ -1,4 +1,4 @@
1;;; cal-menu.el --- calendar functions for menu bar and popup menu support 1;;; cal-menu.el --- calendar functions for menu bar and popup menu support -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -183,6 +183,8 @@ Signals an error if popups are unavailable."
183;; Autoloaded in diary-lib. 183;; Autoloaded in diary-lib.
184(declare-function calendar-check-holidays "holidays" (date)) 184(declare-function calendar-check-holidays "holidays" (date))
185 185
186(defvar diary-list-include-blanks)
187
186(defun calendar-mouse-view-diary-entries (&optional date diary event) 188(defun calendar-mouse-view-diary-entries (&optional date diary event)
187 "Pop up menu of diary entries for mouse-selected date. 189 "Pop up menu of diary entries for mouse-selected date.
188Use optional DATE and alternative file DIARY. EVENT is the event 190Use optional DATE and alternative file DIARY. EVENT is the event
diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el
index 710ce37ccbf..9294362cb43 100644
--- a/lisp/calendar/cal-move.el
+++ b/lisp/calendar/cal-move.el
@@ -1,4 +1,4 @@
1;;; cal-move.el --- calendar functions for movement in the calendar 1;;; cal-move.el --- calendar functions for movement in the calendar -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -386,15 +386,16 @@ Moves forward if ARG is negative."
386 "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil. 386 "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil.
387Negative DAY counts backward from end of year." 387Negative DAY counts backward from end of year."
388 (interactive 388 (interactive
389 (let* ((year (calendar-read 389 (let* ((year (calendar-read-sexp
390 "Year (>0): " 390 "Year (>0)"
391 (lambda (x) (> x 0)) 391 (lambda (x) (> x 0))
392 (number-to-string (calendar-extract-year 392 (calendar-extract-year (calendar-current-date))))
393 (calendar-current-date)))))
394 (last (if (calendar-leap-year-p year) 366 365)) 393 (last (if (calendar-leap-year-p year) 366 365))
395 (day (calendar-read 394 (day (calendar-read-sexp
396 (format "Day number (+/- 1-%d): " last) 395 "Day number (+/- 1-%d)"
397 (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))))) 396 (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))
397 nil
398 last)))
398 (list year day))) 399 (list year day)))
399 (calendar-goto-date 400 (calendar-goto-date
400 (calendar-gregorian-from-absolute 401 (calendar-gregorian-from-absolute
diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el
index a9c99fedbdb..ca37d803224 100644
--- a/lisp/calendar/cal-persia.el
+++ b/lisp/calendar/cal-persia.el
@@ -1,4 +1,4 @@
1;;; cal-persia.el --- calendar functions for the Persian calendar 1;;; cal-persia.el --- calendar functions for the Persian calendar -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -139,13 +139,14 @@ Gregorian date Sunday, December 31, 1 BC."
139 (calendar-absolute-from-gregorian 139 (calendar-absolute-from-gregorian
140 (or date (calendar-current-date))))) 140 (or date (calendar-current-date)))))
141 (y (calendar-extract-year persian-date)) 141 (y (calendar-extract-year persian-date))
142 (m (calendar-extract-month persian-date)) 142 (m (calendar-extract-month persian-date)))
143 (monthname (aref calendar-persian-month-name-array (1- m))) 143 (calendar-dlet*
144 ((monthname (aref calendar-persian-month-name-array (1- m)))
144 (day (number-to-string (calendar-extract-day persian-date))) 145 (day (number-to-string (calendar-extract-day persian-date)))
145 (year (number-to-string y)) 146 (year (number-to-string y))
146 (month (number-to-string m)) 147 (month (number-to-string m))
147 dayname) 148 dayname)
148 (mapconcat 'eval calendar-date-display-form ""))) 149 (mapconcat #'eval calendar-date-display-form ""))))
149 150
150;;;###cal-autoload 151;;;###cal-autoload
151(defun calendar-persian-print-date () 152(defun calendar-persian-print-date ()
@@ -157,14 +158,13 @@ Gregorian date Sunday, December 31, 1 BC."
157(defun calendar-persian-read-date () 158(defun calendar-persian-read-date ()
158 "Interactively read the arguments for a Persian date command. 159 "Interactively read the arguments for a Persian date command.
159Reads a year, month, and day." 160Reads a year, month, and day."
160 (let* ((year (calendar-read 161 (let* ((year (calendar-read-sexp
161 "Persian calendar year (not 0): " 162 "Persian calendar year (not 0)"
162 (lambda (x) (not (zerop x))) 163 (lambda (x) (not (zerop x)))
163 (number-to-string 164 (calendar-extract-year
164 (calendar-extract-year 165 (calendar-persian-from-absolute
165 (calendar-persian-from-absolute 166 (calendar-absolute-from-gregorian
166 (calendar-absolute-from-gregorian 167 (calendar-current-date))))))
167 (calendar-current-date)))))))
168 (completion-ignore-case t) 168 (completion-ignore-case t)
169 (month (cdr (assoc 169 (month (cdr (assoc
170 (completing-read 170 (completing-read
@@ -175,9 +175,11 @@ Reads a year, month, and day."
175 (calendar-make-alist calendar-persian-month-name-array 175 (calendar-make-alist calendar-persian-month-name-array
176 1)))) 176 1))))
177 (last (calendar-persian-last-day-of-month month year)) 177 (last (calendar-persian-last-day-of-month month year))
178 (day (calendar-read 178 (day (calendar-read-sexp
179 (format "Persian calendar day (1-%d): " last) 179 "Persian calendar day (1-%d)"
180 (lambda (x) (and (< 0 x) (<= x last)))))) 180 (lambda (x) (and (< 0 x) (<= x last)))
181 nil
182 last)))
181 (list (list month day year)))) 183 (list (list month day year))))
182 184
183;;;###cal-autoload 185;;;###cal-autoload
diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el
index 9df9f4cbedf..f5932014dd9 100644
--- a/lisp/calendar/cal-tex.el
+++ b/lisp/calendar/cal-tex.el
@@ -1,4 +1,4 @@
1;;; cal-tex.el --- calendar functions for printing calendars with LaTeX 1;;; cal-tex.el --- calendar functions for printing calendars with LaTeX -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
4 4
@@ -248,6 +248,8 @@ This definition is the heart of the calendar!")
248 248
249(autoload 'diary-list-entries "diary-lib") 249(autoload 'diary-list-entries "diary-lib")
250 250
251(defvar diary-list-include-blanks)
252
251(defun cal-tex-list-diary-entries (d1 d2) 253(defun cal-tex-list-diary-entries (d1 d2)
252 "Generate a list of all diary-entries from absolute date D1 to D2." 254 "Generate a list of all diary-entries from absolute date D1 to D2."
253 (let (diary-list-include-blanks) 255 (let (diary-list-include-blanks)
@@ -591,6 +593,8 @@ indicates a buffer position to use instead of point."
591LaTeX commands are inserted for the days of the MONTH in YEAR. 593LaTeX commands are inserted for the days of the MONTH in YEAR.
592Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS 594Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS
593are included. Each day is formatted using format DAY-FORMAT." 595are included. Each day is formatted using format DAY-FORMAT."
596 (with-suppressed-warnings ((lexical date))
597 (defvar date)) ;For `cal-tex-daily-string'.
594 (let ((blank-days ; at start of month 598 (let ((blank-days ; at start of month
595 (mod 599 (mod
596 (- (calendar-day-of-week (list month 1 year)) 600 (- (calendar-day-of-week (list month 1 year))
@@ -605,7 +609,7 @@ are included. Each day is formatted using format DAY-FORMAT."
605 (insert (format day-format (cal-tex-month-name month) j)) 609 (insert (format day-format (cal-tex-month-name month) j))
606 (cal-tex-arg (cal-tex-latexify-list diary-list date)) 610 (cal-tex-arg (cal-tex-latexify-list diary-list date))
607 (cal-tex-arg (cal-tex-latexify-list holidays date)) 611 (cal-tex-arg (cal-tex-latexify-list holidays date))
608 (cal-tex-arg (eval cal-tex-daily-string)) 612 (cal-tex-arg (eval cal-tex-daily-string t))
609 (cal-tex-arg) 613 (cal-tex-arg)
610 (cal-tex-comment)) 614 (cal-tex-comment))
611 (when (and (zerop (mod (+ j blank-days) 7)) 615 (when (and (zerop (mod (+ j blank-days) 7))
@@ -885,13 +889,15 @@ argument EVENT specifies a different buffer position."
885 (interactive (list (prefix-numeric-value current-prefix-arg) 889 (interactive (list (prefix-numeric-value current-prefix-arg)
886 last-nonmenu-event)) 890 last-nonmenu-event))
887 (or n (setq n 1)) 891 (or n (setq n 1))
892 (with-suppressed-warnings ((lexical date))
893 (defvar date)) ;For `cal-tex-daily-string'.
888 (let* ((date (calendar-gregorian-from-absolute 894 (let* ((date (calendar-gregorian-from-absolute
889 (calendar-dayname-on-or-before 895 (calendar-dayname-on-or-before
890 1 896 1
891 (calendar-absolute-from-gregorian 897 (calendar-absolute-from-gregorian
892 (calendar-cursor-to-date t event))))) 898 (calendar-cursor-to-date t event)))))
893 (month (calendar-extract-month date)) 899 (month (calendar-extract-month date))
894 (year (calendar-extract-year date)) 900 ;; (year (calendar-extract-year date))
895 (day (calendar-extract-day date)) 901 (day (calendar-extract-day date))
896 (d1 (calendar-absolute-from-gregorian date)) 902 (d1 (calendar-absolute-from-gregorian date))
897 (d2 (+ (* 7 n) d1)) 903 (d2 (+ (* 7 n) d1))
@@ -932,7 +938,7 @@ argument EVENT specifies a different buffer position."
932 (insert ": ") 938 (insert ": ")
933 (cal-tex-large-bf s)) 939 (cal-tex-large-bf s))
934 (cal-tex-hfill) 940 (cal-tex-hfill)
935 (insert " " (eval cal-tex-daily-string)) 941 (insert " " (eval cal-tex-daily-string t))
936 (cal-tex-e-parbox) 942 (cal-tex-e-parbox)
937 (cal-tex-nl) 943 (cal-tex-nl)
938 (cal-tex-noindent) 944 (cal-tex-noindent)
@@ -951,7 +957,8 @@ argument EVENT specifies a different buffer position."
951 (cal-tex-e-parbox "2cm") 957 (cal-tex-e-parbox "2cm")
952 (cal-tex-nl) 958 (cal-tex-nl)
953 (setq month (calendar-extract-month date) 959 (setq month (calendar-extract-month date)
954 year (calendar-extract-year date))) 960 ;; year (calendar-extract-year date)
961 ))
955 (cal-tex-e-parbox) 962 (cal-tex-e-parbox)
956 (unless (= i (1- n)) 963 (unless (= i (1- n))
957 (run-hooks 'cal-tex-week-hook) 964 (run-hooks 'cal-tex-week-hook)
@@ -961,13 +968,16 @@ argument EVENT specifies a different buffer position."
961 968
962;; TODO respect cal-tex-daily-start,end? 969;; TODO respect cal-tex-daily-start,end?
963;; Using different numbers of hours will probably break some layouts. 970;; Using different numbers of hours will probably break some layouts.
964(defun cal-tex-week-hours (date holidays height) 971(defun cal-tex-week-hours (thedate holidays height)
965 "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT. 972 "Insert hourly entries for THEDATE with HOLIDAYS, with line height HEIGHT.
966Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours 973Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours
967shown are hard-coded to 8-12, 13-17." 974shown are hard-coded to 8-12, 13-17."
968 (let ((month (calendar-extract-month date)) 975 (with-suppressed-warnings ((lexical date))
976 (defvar date)) ;For `cal-tex-daily-string'.
977 (let ((date thedate)
978 (month (calendar-extract-month date))
969 (day (calendar-extract-day date)) 979 (day (calendar-extract-day date))
970 (year (calendar-extract-year date)) 980 ;; (year (calendar-extract-year date))
971 morning afternoon s) 981 morning afternoon s)
972 (cal-tex-comment "begin cal-tex-week-hours") 982 (cal-tex-comment "begin cal-tex-week-hours")
973 (cal-tex-cmd "\\ \\\\[-.2cm]") 983 (cal-tex-cmd "\\ \\\\[-.2cm]")
@@ -983,7 +993,7 @@ shown are hard-coded to 8-12, 13-17."
983 (insert ": ") 993 (insert ": ")
984 (cal-tex-large-bf s)) 994 (cal-tex-large-bf s))
985 (cal-tex-hfill) 995 (cal-tex-hfill)
986 (insert " " (eval cal-tex-daily-string)) 996 (insert " " (eval cal-tex-daily-string t))
987 (cal-tex-e-parbox) 997 (cal-tex-e-parbox)
988 (cal-tex-nl "-.3cm") 998 (cal-tex-nl "-.3cm")
989 (cal-tex-rule "0pt" "6.8in" ".2mm") 999 (cal-tex-rule "0pt" "6.8in" ".2mm")
@@ -1088,14 +1098,16 @@ shown are hard-coded to 8-12, 13-17."
1088(defun cal-tex-weekly-common (n event &optional filofax) 1098(defun cal-tex-weekly-common (n event &optional filofax)
1089 "Common code for weekly calendars." 1099 "Common code for weekly calendars."
1090 (or n (setq n 1)) 1100 (or n (setq n 1))
1101 (with-suppressed-warnings ((lexical date))
1102 (defvar date)) ;For `cal-tex-daily-string'.
1091 (let* ((date (calendar-gregorian-from-absolute 1103 (let* ((date (calendar-gregorian-from-absolute
1092 (calendar-dayname-on-or-before 1104 (calendar-dayname-on-or-before
1093 1 1105 1
1094 (calendar-absolute-from-gregorian 1106 (calendar-absolute-from-gregorian
1095 (calendar-cursor-to-date t event))))) 1107 (calendar-cursor-to-date t event)))))
1096 (month (calendar-extract-month date)) 1108 ;; (month (calendar-extract-month date))
1097 (year (calendar-extract-year date)) 1109 ;; (year (calendar-extract-year date))
1098 (day (calendar-extract-day date)) 1110 ;; (day (calendar-extract-day date))
1099 (d1 (calendar-absolute-from-gregorian date)) 1111 (d1 (calendar-absolute-from-gregorian date))
1100 (d2 (+ (* 7 n) d1)) 1112 (d2 (+ (* 7 n) d1))
1101 (holidays (if cal-tex-holidays 1113 (holidays (if cal-tex-holidays
@@ -1161,7 +1173,7 @@ shown are hard-coded to 8-12, 13-17."
1161 (cal-tex-arg (number-to-string (calendar-extract-day date))) 1173 (cal-tex-arg (number-to-string (calendar-extract-day date)))
1162 (cal-tex-arg (cal-tex-latexify-list diary-list date)) 1174 (cal-tex-arg (cal-tex-latexify-list diary-list date))
1163 (cal-tex-arg (cal-tex-latexify-list holidays date)) 1175 (cal-tex-arg (cal-tex-latexify-list holidays date))
1164 (cal-tex-arg (eval cal-tex-daily-string)) 1176 (cal-tex-arg (eval cal-tex-daily-string t))
1165 (insert "%\n") 1177 (insert "%\n")
1166 (setq date (cal-tex-incr-date date))) 1178 (setq date (cal-tex-incr-date date)))
1167 (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n") 1179 (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")
@@ -1258,14 +1270,16 @@ Optional EVENT indicates a buffer position to use instead of point."
1258 (interactive (list (prefix-numeric-value current-prefix-arg) 1270 (interactive (list (prefix-numeric-value current-prefix-arg)
1259 last-nonmenu-event)) 1271 last-nonmenu-event))
1260 (or n (setq n 1)) 1272 (or n (setq n 1))
1273 (with-suppressed-warnings ((lexical date))
1274 (defvar date)) ;For `cal-tex-daily-string'.
1261 (let* ((date (calendar-gregorian-from-absolute 1275 (let* ((date (calendar-gregorian-from-absolute
1262 (calendar-dayname-on-or-before 1276 (calendar-dayname-on-or-before
1263 calendar-week-start-day 1277 calendar-week-start-day
1264 (calendar-absolute-from-gregorian 1278 (calendar-absolute-from-gregorian
1265 (calendar-cursor-to-date t event))))) 1279 (calendar-cursor-to-date t event)))))
1266 (month (calendar-extract-month date)) 1280 ;; (month (calendar-extract-month date))
1267 (year (calendar-extract-year date)) 1281 ;; (year (calendar-extract-year date))
1268 (day (calendar-extract-day date)) 1282 ;; (day (calendar-extract-day date))
1269 (d1 (calendar-absolute-from-gregorian date)) 1283 (d1 (calendar-absolute-from-gregorian date))
1270 (d2 (+ (* 7 n) d1)) 1284 (d2 (+ (* 7 n) d1))
1271 (holidays (if cal-tex-holidays 1285 (holidays (if cal-tex-holidays
@@ -1311,7 +1325,7 @@ Optional EVENT indicates a buffer position to use instead of point."
1311 (cal-tex-arg (number-to-string (calendar-extract-day date))) 1325 (cal-tex-arg (number-to-string (calendar-extract-day date)))
1312 (cal-tex-arg (cal-tex-latexify-list diary-list date)) 1326 (cal-tex-arg (cal-tex-latexify-list diary-list date))
1313 (cal-tex-arg (cal-tex-latexify-list holidays date)) 1327 (cal-tex-arg (cal-tex-latexify-list holidays date))
1314 (cal-tex-arg (eval cal-tex-daily-string)) 1328 (cal-tex-arg (eval cal-tex-daily-string t))
1315 (insert "%\n") 1329 (insert "%\n")
1316 (setq date (cal-tex-incr-date date))) 1330 (setq date (cal-tex-incr-date date)))
1317 (unless (= i (1- n)) 1331 (unless (= i (1- n))
@@ -1342,14 +1356,16 @@ Optional EVENT indicates a buffer position to use instead of point."
1342 (interactive (list (prefix-numeric-value current-prefix-arg) 1356 (interactive (list (prefix-numeric-value current-prefix-arg)
1343 last-nonmenu-event)) 1357 last-nonmenu-event))
1344 (or n (setq n 1)) 1358 (or n (setq n 1))
1359 (with-suppressed-warnings ((lexical date))
1360 (defvar date)) ;For `cal-tex-daily-string'.
1345 (let* ((date (calendar-gregorian-from-absolute 1361 (let* ((date (calendar-gregorian-from-absolute
1346 (calendar-dayname-on-or-before 1362 (calendar-dayname-on-or-before
1347 1 1363 1
1348 (calendar-absolute-from-gregorian 1364 (calendar-absolute-from-gregorian
1349 (calendar-cursor-to-date t event))))) 1365 (calendar-cursor-to-date t event)))))
1350 (month (calendar-extract-month date)) 1366 ;; (month (calendar-extract-month date))
1351 (year (calendar-extract-year date)) 1367 ;; (year (calendar-extract-year date))
1352 (day (calendar-extract-day date)) 1368 ;; (day (calendar-extract-day date))
1353 (d1 (calendar-absolute-from-gregorian date)) 1369 (d1 (calendar-absolute-from-gregorian date))
1354 (d2 (+ (* 7 n) d1)) 1370 (d2 (+ (* 7 n) d1))
1355 (holidays (if cal-tex-holidays 1371 (holidays (if cal-tex-holidays
@@ -1383,11 +1399,11 @@ Optional EVENT indicates a buffer position to use instead of point."
1383 "\\leftday"))) 1399 "\\leftday")))
1384 (cal-tex-arg (cal-tex-latexify-list diary-list date)) 1400 (cal-tex-arg (cal-tex-latexify-list diary-list date))
1385 (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) 1401 (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t))
1386 (cal-tex-arg (eval cal-tex-daily-string)) 1402 (cal-tex-arg (eval cal-tex-daily-string t))
1387 (insert "%\n") 1403 (insert "%\n")
1388 (if cal-tex-rules 1404 (insert (if cal-tex-rules
1389 (insert "\\linesfill\n") 1405 "\\linesfill\n"
1390 (insert "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) 1406 "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
1391 (cal-tex-newpage) 1407 (cal-tex-newpage)
1392 (setq date (cal-tex-incr-date date))) 1408 (setq date (cal-tex-incr-date date)))
1393 (insert "%\n") 1409 (insert "%\n")
@@ -1397,11 +1413,11 @@ Optional EVENT indicates a buffer position to use instead of point."
1397 (insert "\\weekend") 1413 (insert "\\weekend")
1398 (cal-tex-arg (cal-tex-latexify-list diary-list date)) 1414 (cal-tex-arg (cal-tex-latexify-list diary-list date))
1399 (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) 1415 (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t))
1400 (cal-tex-arg (eval cal-tex-daily-string)) 1416 (cal-tex-arg (eval cal-tex-daily-string t))
1401 (insert "%\n") 1417 (insert "%\n")
1402 (if cal-tex-rules 1418 (insert (if cal-tex-rules
1403 (insert "\\linesfill\n") 1419 "\\linesfill\n"
1404 (insert "\\vfill")) 1420 "\\vfill"))
1405 (setq date (cal-tex-incr-date date))) 1421 (setq date (cal-tex-incr-date date)))
1406 (or cal-tex-rules 1422 (or cal-tex-rules
1407 (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) 1423 (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
@@ -1442,12 +1458,15 @@ a buffer position to use instead of point."
1442 (cal-tex-end-document) 1458 (cal-tex-end-document)
1443 (run-hooks 'cal-tex-hook))) 1459 (run-hooks 'cal-tex-hook)))
1444 1460
1445(defun cal-tex-daily-page (date) 1461(defun cal-tex-daily-page (thedate)
1446 "Make a calendar page for Gregorian DATE on 8.5 by 11 paper. 1462 "Make a calendar page for Gregorian THEDATE on 8.5 by 11 paper.
1447Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces 1463Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces
1448hourly sections for the period specified by `cal-tex-daily-start' 1464hourly sections for the period specified by `cal-tex-daily-start'
1449and `cal-tex-daily-end'." 1465and `cal-tex-daily-end'."
1450 (let ((month-name (cal-tex-month-name (calendar-extract-month date))) 1466 (with-suppressed-warnings ((lexical date))
1467 (defvar date)) ;For `cal-tex-daily-string'.
1468 (let ((date thedate)
1469 (month-name (cal-tex-month-name (calendar-extract-month date)))
1451 (i (1- cal-tex-daily-start)) 1470 (i (1- cal-tex-daily-start))
1452 hour) 1471 hour)
1453 (cal-tex-banner "cal-tex-daily-page") 1472 (cal-tex-banner "cal-tex-daily-page")
@@ -1459,7 +1478,7 @@ and `cal-tex-daily-end'."
1459 (cal-tex-bf month-name ) 1478 (cal-tex-bf month-name )
1460 (cal-tex-e-parbox) 1479 (cal-tex-e-parbox)
1461 (cal-tex-hspace "1cm") 1480 (cal-tex-hspace "1cm")
1462 (cal-tex-scriptsize (eval cal-tex-daily-string)) 1481 (cal-tex-scriptsize (eval cal-tex-daily-string t))
1463 (cal-tex-hspace "3.5cm") 1482 (cal-tex-hspace "3.5cm")
1464 (cal-tex-e-makebox) 1483 (cal-tex-e-makebox)
1465 (cal-tex-hfill) 1484 (cal-tex-hfill)
diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el
index 1c19a60db10..ca303ce39ae 100644
--- a/lisp/calendar/cal-x.el
+++ b/lisp/calendar/cal-x.el
@@ -1,4 +1,4 @@
1;;; cal-x.el --- calendar windows in dedicated frames 1;;; cal-x.el --- calendar windows in dedicated frames -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
4 4
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 21cea212e18..3f9fe1c9d8f 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -112,6 +112,8 @@
112 112
113;;; Code: 113;;; Code:
114 114
115(eval-when-compile (require 'subr-x))
116
115(load "cal-loaddefs" nil t) 117(load "cal-loaddefs" nil t)
116 118
117;; Calendar has historically relied heavily on dynamic scoping. 119;; Calendar has historically relied heavily on dynamic scoping.
@@ -1459,7 +1461,7 @@ Optional integers MON and YR are used instead of today's date."
1459Inserts STRING so that it ends at INDENT. STRING is either a 1461Inserts STRING so that it ends at INDENT. STRING is either a
1460literal string, or a sexp to evaluate to return such. Truncates 1462literal string, or a sexp to evaluate to return such. Truncates
1461STRING to length TRUNCATE, and ensures a trailing space." 1463STRING to length TRUNCATE, and ensures a trailing space."
1462 (if (not (ignore-errors (stringp (setq string (eval string))))) 1464 (if (not (ignore-errors (stringp (setq string (eval string t)))))
1463 (calendar-move-to-column indent) 1465 (calendar-move-to-column indent)
1464 (if (> (string-width string) truncate) 1466 (if (> (string-width string) truncate)
1465 (setq string (truncate-string-to-width string truncate))) 1467 (setq string (truncate-string-to-width string truncate)))
@@ -1526,7 +1528,7 @@ first INDENT characters on the line."
1526 (format (format "%%%dd" calendar-day-digit-width) day) 1528 (format (format "%%%dd" calendar-day-digit-width) day)
1527 'mouse-face 'highlight 1529 'mouse-face 'highlight
1528 'help-echo (calendar-dlet* ((day day) (month month) (year year)) 1530 'help-echo (calendar-dlet* ((day day) (month month) (year year))
1529 (eval calendar-date-echo-text)) 1531 (eval calendar-date-echo-text t))
1530 ;; 'date property prevents intermonth text confusing re-searches. 1532 ;; 'date property prevents intermonth text confusing re-searches.
1531 ;; (Tried intangible, it did not really work.) 1533 ;; (Tried intangible, it did not really work.)
1532 'date t) 1534 'date t)
@@ -2054,23 +2056,40 @@ With argument ARG, jump to mark, pop it, and put point at end of ring."
2054 (error "%s not available in the calendar" 2056 (error "%s not available in the calendar"
2055 (global-key-binding (this-command-keys)))) 2057 (global-key-binding (this-command-keys))))
2056 2058
2059(defun calendar-read-sexp (prompt predicate &optional default &rest args)
2060 "Return an object read from the minibuffer.
2061Passes PROMPT, DEFAULT, and ARGS to `format-prompt' to build
2062the actual prompt. PREDICATE is called with a single value (the object
2063the user entered) and it should return non-nil if that value is a valid choice.
2064DEFAULT is the default value to use."
2065 (unless (stringp default) (setq default (format "%S" default)))
2066 (named-let query ()
2067 ;; The call to `read-from-minibuffer' is copied from `read-minibuffer',
2068 ;; except it's changed to use the DEFAULT arg instead of INITIAL-CONTENTS.
2069 (let ((value (read-from-minibuffer
2070 (apply #'format-prompt prompt default args)
2071 nil minibuffer-local-map t 'minibuffer-history default)))
2072 (if (funcall predicate value)
2073 value
2074 (query)))))
2075
2057(defun calendar-read (prompt acceptable &optional initial-contents) 2076(defun calendar-read (prompt acceptable &optional initial-contents)
2058 "Return an object read from the minibuffer. 2077 "Return an object read from the minibuffer.
2059Prompt with the string PROMPT and use the function ACCEPTABLE to decide 2078Prompt with the string PROMPT and use the function ACCEPTABLE to decide
2060if entered item is acceptable. If non-nil, optional third arg 2079if entered item is acceptable. If non-nil, optional third arg
2061INITIAL-CONTENTS is a string to insert in the minibuffer before reading." 2080INITIAL-CONTENTS is a string to insert in the minibuffer before reading."
2081 (declare (obsolete calendar-read-sexp "28.1"))
2062 (let ((value (read-minibuffer prompt initial-contents))) 2082 (let ((value (read-minibuffer prompt initial-contents)))
2063 (while (not (funcall acceptable value)) 2083 (while (not (funcall acceptable value))
2064 (setq value (read-minibuffer prompt initial-contents))) 2084 (setq value (read-minibuffer prompt initial-contents)))
2065 value)) 2085 value))
2066 2086
2067
2068(defun calendar-customized-p (symbol) 2087(defun calendar-customized-p (symbol)
2069 "Return non-nil if SYMBOL has been customized." 2088 "Return non-nil if SYMBOL has been customized."
2070 (and (default-boundp symbol) 2089 (and (default-boundp symbol)
2071 (let ((standard (get symbol 'standard-value))) 2090 (let ((standard (get symbol 'standard-value)))
2072 (and standard 2091 (and standard
2073 (not (equal (eval (car standard)) (default-value symbol))))))) 2092 (not (equal (eval (car standard) t) (default-value symbol)))))))
2074 2093
2075(defun calendar-abbrev-construct (full &optional maxlen) 2094(defun calendar-abbrev-construct (full &optional maxlen)
2076 "From sequence FULL, return a vector of abbreviations. 2095 "From sequence FULL, return a vector of abbreviations.
@@ -2284,32 +2303,38 @@ arguments SEQUENCES."
2284 (append (list sequence) sequences)) 2303 (append (list sequence) sequences))
2285 (reverse alist))) 2304 (reverse alist)))
2286 2305
2287(defun calendar-read-date (&optional noday) 2306(defun calendar-read-date (&optional noday default-date)
2288 "Prompt for Gregorian date. Return a list (month day year). 2307 "Prompt for Gregorian date. Return a list (month day year).
2289If optional NODAY is t, does not ask for day, but just returns 2308If optional NODAY is t, does not ask for day, but just returns
2290\(month 1 year); if NODAY is any other non-nil value the value 2309\(month 1 year); if NODAY is any other non-nil value the value
2291returned is (month year)." 2310returned is (month year)."
2292 (let* ((year (calendar-read 2311 (unless default-date (setq default-date (calendar-current-date)))
2293 "Year (>0): " 2312 (let* ((defyear (calendar-extract-year default-date))
2294 (lambda (x) (> x 0)) 2313 (year (calendar-read-sexp "Year (>0)"
2295 (number-to-string (calendar-extract-year 2314 (lambda (x) (> x 0))
2296 (calendar-current-date))))) 2315 defyear))
2297 (month-array calendar-month-name-array) 2316 (month-array calendar-month-name-array)
2317 (defmon (aref month-array (1- (calendar-extract-month default-date))))
2298 (completion-ignore-case t) 2318 (completion-ignore-case t)
2299 (month (cdr (assoc-string 2319 (month (cdr (assoc-string
2300 (completing-read 2320 (completing-read
2301 "Month name: " 2321 (format-prompt "Month name" defmon)
2302 (mapcar #'list (append month-array nil)) 2322 (append month-array nil)
2303 nil t) 2323 nil t nil nil defmon)
2304 (calendar-make-alist month-array 1) t))) 2324 (calendar-make-alist month-array 1) t)))
2325 (defday (calendar-extract-day default-date))
2305 (last (calendar-last-day-of-month month year))) 2326 (last (calendar-last-day-of-month month year)))
2306 (if noday 2327 (if noday
2307 (if (eq noday t) 2328 (if (eq noday t)
2308 (list month 1 year) 2329 (list month 1 year)
2309 (list month year)) 2330 (list month year))
2310 (list month 2331 (list month
2311 (calendar-read (format "Day (1-%d): " last) 2332 (calendar-read-sexp "Day (1-%d)"
2312 (lambda (x) (and (< 0 x) (<= x last)))) 2333 (lambda (x) (and (< 0 x) (<= x last)))
2334 ;; Don't offer today's day as default
2335 ;; if it's not valid for the chosen
2336 ;; month/year.
2337 (if (<= defday last) defday) last)
2313 year)))) 2338 year))))
2314 2339
2315(defun calendar-interval (mon1 yr1 mon2 yr2) 2340(defun calendar-interval (mon1 yr1 mon2 yr2)
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index aad70161f9f..4efa3669967 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -2221,8 +2221,8 @@ Prefix argument ARG makes the entry nonmarking."
2221 (diary-make-entry 2221 (diary-make-entry
2222 (format "%s(diary-cyclic %d %s)" 2222 (format "%s(diary-cyclic %d %s)"
2223 diary-sexp-entry-symbol 2223 diary-sexp-entry-symbol
2224 (calendar-read "Repeat every how many days: " 2224 (calendar-read-sexp "Repeat every how many days"
2225 (lambda (x) (> x 0))) 2225 (lambda (x) (> x 0)))
2226 (calendar-date-string (calendar-cursor-to-date t) nil t)) 2226 (calendar-date-string (calendar-cursor-to-date t) nil t))
2227 arg))) 2227 arg)))
2228 2228
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el
index 932993beba0..4bc17de3067 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -423,16 +423,15 @@ of a holiday list.
423 423
424The optional LABEL is used to label the buffer created." 424The optional LABEL is used to label the buffer created."
425 (interactive 425 (interactive
426 (let* ((start-year (calendar-read 426 (let* ((start-year (calendar-read-sexp
427 "Starting year of holidays (>0): " 427 "Starting year of holidays (>0)"
428 (lambda (x) (> x 0)) 428 (lambda (x) (> x 0))
429 (number-to-string (calendar-extract-year 429 (calendar-extract-year (calendar-current-date))))
430 (calendar-current-date))))) 430 (end-year (calendar-read-sexp
431 (end-year (calendar-read 431 "Ending year (inclusive) of holidays (>=%s)"
432 (format "Ending year (inclusive) of holidays (>=%s): "
433 start-year)
434 (lambda (x) (>= x start-year)) 432 (lambda (x) (>= x start-year))
435 (number-to-string start-year))) 433 start-year
434 start-year))
436 (completion-ignore-case t) 435 (completion-ignore-case t)
437 (lists 436 (lists
438 (list 437 (list
diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el
index 7799746e0c4..810d6ef3bd4 100644
--- a/lisp/cedet/ede/base.el
+++ b/lisp/cedet/ede/base.el
@@ -160,16 +160,13 @@ and querying them will cause the actual project to get loaded.")
160;; Projects can also affect how EDE works, by changing what appears in 160;; Projects can also affect how EDE works, by changing what appears in
161;; the EDE menu, or how some keys are bound. 161;; the EDE menu, or how some keys are bound.
162;; 162;;
163(unless (fboundp 'ede-target-list-p)
164 (cl-deftype ede-target-list () '(list-of ede-target)))
165
166(defclass ede-project (ede-project-placeholder) 163(defclass ede-project (ede-project-placeholder)
167 ((subproj :initform nil 164 ((subproj :initform nil
168 :type list 165 :type list
169 :documentation "Sub projects controlled by this project. 166 :documentation "Sub projects controlled by this project.
170For Automake based projects, each directory is treated as a project.") 167For Automake based projects, each directory is treated as a project.")
171 (targets :initarg :targets 168 (targets :initarg :targets
172 :type ede-target-list 169 :type (list-of ede-target)
173 :custom (repeat (object :objectcreatefcn ede-new-target-custom)) 170 :custom (repeat (object :objectcreatefcn ede-new-target-custom))
174 :label "Local Targets" 171 :label "Local Targets"
175 :group (targets) 172 :group (targets)
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el
index 59628ebf4c9..4af8b4104f5 100644
--- a/lisp/cedet/ede/proj.el
+++ b/lisp/cedet/ede/proj.el
@@ -184,7 +184,7 @@ Target variables are always renamed such as foo_CFLAGS, then included into
184commands where the variable would usually appear.") 184commands where the variable would usually appear.")
185 (rules :initarg :rules 185 (rules :initarg :rules
186 :initform nil 186 :initform nil
187 :type list 187 :type (list-of ede-makefile-rule)
188 :custom (repeat (object :objecttype ede-makefile-rule)) 188 :custom (repeat (object :objecttype ede-makefile-rule))
189 :label "Additional Rules" 189 :label "Additional Rules"
190 :group (make) 190 :group (make)
diff --git a/lisp/comint.el b/lisp/comint.el
index 53153af7d27..e52d67d0e50 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -3863,7 +3863,11 @@ REGEXP-GROUP is the regular expression group in REGEXP to use."
3863 (push (buffer-substring-no-properties 3863 (push (buffer-substring-no-properties
3864 (match-beginning regexp-group) 3864 (match-beginning regexp-group)
3865 (match-end regexp-group)) 3865 (match-end regexp-group))
3866 results)) 3866 results)
3867 (when (zerop (length (match-string 0)))
3868 ;; If the regexp can be empty (for instance, "^.*$"), we
3869 ;; don't advance, so ensure forward progress.
3870 (forward-line 1)))
3867 (nreverse results)))) 3871 (nreverse results))))
3868 3872
3869;; Converting process modes to use comint mode 3873;; Converting process modes to use comint mode
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 0293d34d1cd..27fdb723441 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -880,7 +880,7 @@ since it could result in memory overflow and make Emacs crash."
880 ;; Don't re-add to custom-delayed-init-variables post-startup. 880 ;; Don't re-add to custom-delayed-init-variables post-startup.
881 (unless after-init-time 881 (unless after-init-time
882 ;; Note this is the _only_ initialize property we handle. 882 ;; Note this is the _only_ initialize property we handle.
883 (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay) 883 (if (eq (cadr (memq :initialize rest)) #'custom-initialize-delay)
884 ;; These vars are defined early and should hence be initialized 884 ;; These vars are defined early and should hence be initialized
885 ;; early, even if this file happens to be loaded late. so add them 885 ;; early, even if this file happens to be loaded late. so add them
886 ;; to the end of custom-delayed-init-variables. Otherwise, 886 ;; to the end of custom-delayed-init-variables. Otherwise,
diff --git a/lisp/custom.el b/lisp/custom.el
index 58ecd0439ad..5e354c4c595 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -125,17 +125,7 @@ This is used in files that are preloaded (or for autoloaded
125variables), so that the initialization is done in the run-time 125variables), so that the initialization is done in the run-time
126context rather than the build-time context. This also has the 126context rather than the build-time context. This also has the
127side-effect that the (delayed) initialization is performed with 127side-effect that the (delayed) initialization is performed with
128the :set function. 128the :set function."
129
130For variables in preloaded files, you can simply use this
131function for the :initialize property. For autoloaded variables,
132you will also need to add an autoload stanza calling this
133function, and another one setting the standard-value property.
134Or you can wrap the defcustom in a progn, to force the autoloader
135to include all of it." ; see eg vc-sccs-search-project-dir
136 ;; No longer true:
137 ;; "See `send-mail-function' in sendmail.el for an example."
138
139 ;; Defvar it so as to mark it special, etc (bug#25770). 129 ;; Defvar it so as to mark it special, etc (bug#25770).
140 (internal--define-uninitialized-variable symbol) 130 (internal--define-uninitialized-variable symbol)
141 131
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 5a96742fda9..c765e4be45d 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1168,7 +1168,10 @@ ARGS are command switches passed to PROGRAM.")
1168 ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o") 1168 ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o")
1169 ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o") 1169 ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o")
1170 ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o") 1170 ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o")
1171 ("\\.zip\\'" . "zip %o -r --filesync %i")) 1171 ("\\.tar\\.lz\\'" . "tar -cf - %i | lzip -c9 > %o")
1172 ("\\.tar\\.lzo\\'" . "tar -cf - %i | lzop -c9 > %o")
1173 ("\\.zip\\'" . "zip %o -r --filesync %i")
1174 ("\\.pax\\'" . "pax -wf %o %i"))
1172 "Control the compression shell command for `dired-do-compress-to'. 1175 "Control the compression shell command for `dired-do-compress-to'.
1173 1176
1174Each element is (REGEXP . CMD), where REGEXP is the name of the 1177Each element is (REGEXP . CMD), where REGEXP is the name of the
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index aebffe339eb..5a52eccbbe3 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -1483,7 +1483,7 @@ a prefix argument, when it offers the filename near point as a default."
1483;;; Internal functions. 1483;;; Internal functions.
1484 1484
1485;; Fixme: This should probably use `thing-at-point'. -- fx 1485;; Fixme: This should probably use `thing-at-point'. -- fx
1486(define-obsolete-function-alias 'dired-file-name-at-point 1486(define-obsolete-function-alias 'dired-filename-at-point
1487 #'dired-x-guess-file-name-at-point "28.1") 1487 #'dired-x-guess-file-name-at-point "28.1")
1488(defun dired-x-guess-file-name-at-point () 1488(defun dired-x-guess-file-name-at-point ()
1489 "Return the filename closest to point, expanded. 1489 "Return the filename closest to point, expanded.
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index cf89456541e..66a117fccc8 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -284,8 +284,10 @@
284 ;; If `fn' is from the same file, it has already 284 ;; If `fn' is from the same file, it has already
285 ;; been preprocessed! 285 ;; been preprocessed!
286 `(function ,fn) 286 `(function ,fn)
287 (byte-compile-preprocess 287 ;; Try and process it "in its original environment".
288 (byte-compile--reify-function fn))))) 288 (let ((byte-compile-bound-variables nil))
289 (byte-compile-preprocess
290 (byte-compile--reify-function fn))))))
289 (if (eq (car-safe newfn) 'function) 291 (if (eq (car-safe newfn) 'function)
290 (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) 292 (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
291 ;; This can happen because of macroexp-warn-and-return &co. 293 ;; This can happen because of macroexp-warn-and-return &co.
@@ -374,185 +376,184 @@
374 ;; the important aspect is that they are subrs that don't evaluate all of 376 ;; the important aspect is that they are subrs that don't evaluate all of
375 ;; their args.) 377 ;; their args.)
376 ;; 378 ;;
377 (let ((fn (car-safe form)) 379 ;; FIXME: There are a bunch of `byte-compile-warn' here which arguably
378 tmp) 380 ;; have no place in an optimizer: the corresponding tests should be
379 (cond ((not (consp form)) 381 ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'.
380 (if (not (and for-effect 382 (let ((fn (car-safe form)))
381 (or byte-compile-delete-errors 383 (pcase form
382 (not (symbolp form)) 384 ((pred (not consp))
383 (eq form t)))) 385 (if (not (and for-effect
384 form)) 386 (or byte-compile-delete-errors
385 ((eq fn 'quote) 387 (not (symbolp form))
386 (if (cdr (cdr form)) 388 (eq form t))))
387 (byte-compile-warn "malformed quote form: `%s'" 389 form))
388 (prin1-to-string form))) 390 (`(quote . ,v)
389 ;; map (quote nil) to nil to simplify optimizer logic. 391 (if (cdr v)
390 ;; map quoted constants to nil if for-effect (just because). 392 (byte-compile-warn "malformed quote form: `%s'"
391 (and (nth 1 form) 393 (prin1-to-string form)))
392 (not for-effect) 394 ;; Map (quote nil) to nil to simplify optimizer logic.
393 form)) 395 ;; Map quoted constants to nil if for-effect (just because).
394 ((memq fn '(let let*)) 396 (and (car v)
395 ;; recursively enter the optimizer for the bindings and body 397 (not for-effect)
396 ;; of a let or let*. This for depth-firstness: forms that 398 form))
397 ;; are more deeply nested are optimized first. 399 (`(,(or 'let 'let*) . ,(or `(,bindings . ,exps) pcase--dontcare))
398 (cons fn 400 ;; Recursively enter the optimizer for the bindings and body
401 ;; of a let or let*. This for depth-firstness: forms that
402 ;; are more deeply nested are optimized first.
403 (cons fn
399 (cons 404 (cons
400 (mapcar (lambda (binding) 405 (mapcar (lambda (binding)
401 (if (symbolp binding) 406 (if (symbolp binding)
402 binding 407 binding
403 (if (cdr (cdr binding)) 408 (if (cdr (cdr binding))
404 (byte-compile-warn "malformed let binding: `%s'" 409 (byte-compile-warn "malformed let binding: `%s'"
405 (prin1-to-string binding))) 410 (prin1-to-string binding)))
406 (list (car binding) 411 (list (car binding)
407 (byte-optimize-form (nth 1 binding) nil)))) 412 (byte-optimize-form (nth 1 binding) nil))))
408 (nth 1 form)) 413 bindings)
409 (byte-optimize-body (cdr (cdr form)) for-effect)))) 414 (byte-optimize-body exps for-effect))))
410 ((eq fn 'cond) 415 (`(cond . ,clauses)
411 (cons fn 416 (cons fn
412 (mapcar (lambda (clause) 417 (mapcar (lambda (clause)
413 (if (consp clause) 418 (if (consp clause)
414 (cons 419 (cons
415 (byte-optimize-form (car clause) nil) 420 (byte-optimize-form (car clause) nil)
416 (byte-optimize-body (cdr clause) for-effect)) 421 (byte-optimize-body (cdr clause) for-effect))
417 (byte-compile-warn "malformed cond form: `%s'" 422 (byte-compile-warn "malformed cond form: `%s'"
418 (prin1-to-string clause)) 423 (prin1-to-string clause))
419 clause)) 424 clause))
420 (cdr form)))) 425 clauses)))
421 ((eq fn 'progn) 426 (`(progn . ,exps)
422 ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. 427 ;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
423 (if (cdr (cdr form)) 428 (if (cdr exps)
424 (macroexp-progn (byte-optimize-body (cdr form) for-effect)) 429 (macroexp-progn (byte-optimize-body exps for-effect))
425 (byte-optimize-form (nth 1 form) for-effect))) 430 (byte-optimize-form (car exps) for-effect)))
426 ((eq fn 'prog1) 431 (`(prog1 . ,(or `(,exp . ,exps) pcase--dontcare))
427 (if (cdr (cdr form)) 432 (if exps
428 (cons 'prog1 433 `(prog1 ,(byte-optimize-form exp for-effect)
429 (cons (byte-optimize-form (nth 1 form) for-effect) 434 . ,(byte-optimize-body exps t))
430 (byte-optimize-body (cdr (cdr form)) t))) 435 (byte-optimize-form exp for-effect)))
431 (byte-optimize-form (nth 1 form) for-effect))) 436
432 437 (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps)
433 ((memq fn '(save-excursion save-restriction save-current-buffer)) 438 ;; Those subrs which have an implicit progn; it's not quite good
434 ;; those subrs which have an implicit progn; it's not quite good 439 ;; enough to treat these like normal function calls.
435 ;; enough to treat these like normal function calls. 440 ;; This can turn (save-excursion ...) into (save-excursion) which
436 ;; This can turn (save-excursion ...) into (save-excursion) which 441 ;; will be optimized away in the lap-optimize pass.
437 ;; will be optimized away in the lap-optimize pass. 442 (cons fn (byte-optimize-body exps for-effect)))
438 (cons fn (byte-optimize-body (cdr form) for-effect))) 443
439 444 (`(if ,test ,then . ,else)
440 ((eq fn 'if) 445 `(if ,(byte-optimize-form test nil)
441 (when (< (length form) 3) 446 ,(byte-optimize-form then for-effect)
442 (byte-compile-warn "too few arguments for `if'")) 447 . ,(byte-optimize-body else for-effect)))
443 (cons fn 448 (`(if . ,_)
444 (cons (byte-optimize-form (nth 1 form) nil) 449 (byte-compile-warn "too few arguments for `if'"))
445 (cons 450
446 (byte-optimize-form (nth 2 form) for-effect) 451 (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures.
447 (byte-optimize-body (nthcdr 3 form) for-effect))))) 452 ;; Take forms off the back until we can't any more.
448 453 ;; In the future it could conceivably be a problem that the
449 ((memq fn '(and or)) ; Remember, and/or are control structures. 454 ;; subexpressions of these forms are optimized in the reverse
450 ;; Take forms off the back until we can't any more. 455 ;; order, but it's ok for now.
451 ;; In the future it could conceivably be a problem that the 456 (if for-effect
452 ;; subexpressions of these forms are optimized in the reverse 457 (let ((backwards (reverse exps)))
453 ;; order, but it's ok for now. 458 (while (and backwards
454 (if for-effect 459 (null (setcar backwards
455 (let ((backwards (reverse (cdr form)))) 460 (byte-optimize-form (car backwards)
456 (while (and backwards 461 for-effect))))
457 (null (setcar backwards 462 (setq backwards (cdr backwards)))
458 (byte-optimize-form (car backwards) 463 (if (and exps (null backwards))
459 for-effect)))) 464 (byte-compile-log
460 (setq backwards (cdr backwards))) 465 " all subforms of %s called for effect; deleted" form))
461 (if (and (cdr form) (null backwards)) 466 (and backwards
462 (byte-compile-log 467 (cons fn (nreverse (mapcar #'byte-optimize-form
463 " all subforms of %s called for effect; deleted" form)) 468 backwards)))))
464 (and backwards 469 (cons fn (mapcar #'byte-optimize-form exps))))
465 (cons fn (nreverse (mapcar 'byte-optimize-form 470
466 backwards))))) 471 (`(while ,exp . ,exps)
467 (cons fn (mapcar 'byte-optimize-form (cdr form))))) 472 `(while ,(byte-optimize-form exp nil)
468 473 . ,(byte-optimize-body exps t)))
469 ((eq fn 'while) 474 (`(while . ,_)
470 (unless (consp (cdr form)) 475 (byte-compile-warn "too few arguments for `while'"))
471 (byte-compile-warn "too few arguments for `while'")) 476
472 (cons fn 477 (`(interactive . ,_)
473 (cons (byte-optimize-form (cadr form) nil) 478 (byte-compile-warn "misplaced interactive spec: `%s'"
474 (byte-optimize-body (cddr form) t)))) 479 (prin1-to-string form))
475 480 nil)
476 ((eq fn 'interactive) 481
477 (byte-compile-warn "misplaced interactive spec: `%s'" 482 (`(function . ,_)
478 (prin1-to-string form)) 483 ;; This forms is compiled as constant or by breaking out
479 nil) 484 ;; all the subexpressions and compiling them separately.
480 485 form)
481 ((eq fn 'function)
482 ;; This forms is compiled as constant or by breaking out
483 ;; all the subexpressions and compiling them separately.
484 form)
485
486 ((eq fn 'condition-case)
487 `(condition-case ,(nth 1 form) ;Not evaluated.
488 ,(byte-optimize-form (nth 2 form) for-effect)
489 ,@(mapcar (lambda (clause)
490 `(,(car clause)
491 ,@(byte-optimize-body (cdr clause) for-effect)))
492 (nthcdr 3 form))))
493
494 ((eq fn 'unwind-protect)
495 ;; the "protected" part of an unwind-protect is compiled (and thus
496 ;; optimized) as a top-level form, so don't do it here. But the
497 ;; non-protected part has the same for-effect status as the
498 ;; unwind-protect itself. (The protected part is always for effect,
499 ;; but that isn't handled properly yet.)
500 (cons fn
501 (cons (byte-optimize-form (nth 1 form) for-effect)
502 (cdr (cdr form)))))
503
504 ((eq fn 'catch)
505 (cons fn
506 (cons (byte-optimize-form (nth 1 form) nil)
507 (byte-optimize-body (cdr form) for-effect))))
508
509 ((eq fn 'ignore)
510 ;; Don't treat the args to `ignore' as being
511 ;; computed for effect. We want to avoid the warnings
512 ;; that might occur if they were treated that way.
513 ;; However, don't actually bother calling `ignore'.
514 `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
515
516 ;; Needed as long as we run byte-optimize-form after cconv.
517 ((eq fn 'internal-make-closure) form)
518
519 ((eq (car-safe fn) 'lambda)
520 (let ((newform (byte-compile-unfold-lambda form)))
521 (if (eq newform form)
522 ;; Some error occurred, avoid infinite recursion
523 form
524 (byte-optimize-form newform for-effect))))
525
526 ((eq (car-safe fn) 'closure) form)
527
528 ((byte-code-function-p fn)
529 (cons fn (mapcar #'byte-optimize-form (cdr form))))
530
531 ((not (symbolp fn))
532 (byte-compile-warn "`%s' is a malformed function"
533 (prin1-to-string fn))
534 form)
535
536 ((and for-effect (setq tmp (get fn 'side-effect-free))
537 (or byte-compile-delete-errors
538 (eq tmp 'error-free)
539 (progn
540 (byte-compile-warn "value returned from %s is unused"
541 (prin1-to-string form))
542 nil)))
543 (byte-compile-log " %s called for effect; deleted" fn)
544 ;; appending a nil here might not be necessary, but it can't hurt.
545 (byte-optimize-form
546 (cons 'progn (append (cdr form) '(nil))) t))
547 486
548 (t 487 (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare))
549 ;; Otherwise, no args can be considered to be for-effect, 488 `(condition-case ,var ;Not evaluated.
550 ;; even if the called function is for-effect, because we 489 ,(byte-optimize-form exp for-effect)
551 ;; don't know anything about that function. 490 ,@(mapcar (lambda (clause)
552 (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) 491 `(,(car clause)
553 (if (get fn 'pure) 492 ,@(byte-optimize-body (cdr clause) for-effect)))
554 (byte-optimize-constant-args form) 493 clauses)))
555 form)))))) 494
495 (`(unwind-protect . ,(or `(,exp . ,exps) pcase--dontcare))
496 ;; The "protected" part of an unwind-protect is compiled (and thus
497 ;; optimized) as a top-level form, so don't do it here. But the
498 ;; non-protected part has the same for-effect status as the
499 ;; unwind-protect itself. (The protected part is always for effect,
500 ;; but that isn't handled properly yet.)
501 `(unwind-protect ,(byte-optimize-form exp for-effect) . ,exps))
502
503 (`(catch . ,(or `(,tag . ,exps) pcase--dontcare))
504 `(catch ,(byte-optimize-form tag nil)
505 . ,(byte-optimize-body exps for-effect)))
506
507 (`(ignore . ,exps)
508 ;; Don't treat the args to `ignore' as being
509 ;; computed for effect. We want to avoid the warnings
510 ;; that might occur if they were treated that way.
511 ;; However, don't actually bother calling `ignore'.
512 `(prog1 nil . ,(mapcar #'byte-optimize-form exps)))
513
514 ;; Needed as long as we run byte-optimize-form after cconv.
515 (`(internal-make-closure . ,_) form)
516
517 (`((lambda . ,_) . ,_)
518 (let ((newform (byte-compile-unfold-lambda form)))
519 (if (eq newform form)
520 ;; Some error occurred, avoid infinite recursion.
521 form
522 (byte-optimize-form newform for-effect))))
523
524 ;; FIXME: Strictly speaking, I think this is a bug: (closure...)
525 ;; is a *value* and shouldn't appear in the car.
526 (`((closure . ,_) . ,_) form)
527
528 (`(,(pred byte-code-function-p) . ,exps)
529 (cons fn (mapcar #'byte-optimize-form exps)))
530
531 (`(,(pred (not symbolp)) . ,_)
532 (byte-compile-warn "`%s' is a malformed function"
533 (prin1-to-string fn))
534 form)
535
536 ((guard (when for-effect
537 (if-let ((tmp (get fn 'side-effect-free)))
538 (or byte-compile-delete-errors
539 (eq tmp 'error-free)
540 (progn
541 (byte-compile-warn "value returned from %s is unused"
542 (prin1-to-string form))
543 nil)))))
544 (byte-compile-log " %s called for effect; deleted" fn)
545 ;; appending a nil here might not be necessary, but it can't hurt.
546 (byte-optimize-form
547 (cons 'progn (append (cdr form) '(nil))) t))
548
549 (_
550 ;; Otherwise, no args can be considered to be for-effect,
551 ;; even if the called function is for-effect, because we
552 ;; don't know anything about that function.
553 (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form)))))
554 (if (get fn 'pure)
555 (byte-optimize-constant-args form)
556 form))))))
556 557
557(defun byte-optimize-form (form &optional for-effect) 558(defun byte-optimize-form (form &optional for-effect)
558 "The source-level pass of the optimizer." 559 "The source-level pass of the optimizer."
@@ -1562,467 +1563,548 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1562 ;; You may notice that sequences like "dup varset discard" are 1563 ;; You may notice that sequences like "dup varset discard" are
1563 ;; optimized but sequences like "dup varset TAG1: discard" are not. 1564 ;; optimized but sequences like "dup varset TAG1: discard" are not.
1564 ;; You may be tempted to change this; resist that temptation. 1565 ;; You may be tempted to change this; resist that temptation.
1565 (cond ;; 1566 (cond
1566 ;; <side-effect-free> pop --> <deleted> 1567 ;; <side-effect-free> pop --> <deleted>
1567 ;; ...including: 1568 ;; ...including:
1568 ;; const-X pop --> <deleted> 1569 ;; const-X pop --> <deleted>
1569 ;; varref-X pop --> <deleted> 1570 ;; varref-X pop --> <deleted>
1570 ;; dup pop --> <deleted> 1571 ;; dup pop --> <deleted>
1571 ;; 1572 ;;
1572 ((and (eq 'byte-discard (car lap1)) 1573 ((and (eq 'byte-discard (car lap1))
1573 (memq (car lap0) side-effect-free)) 1574 (memq (car lap0) side-effect-free))
1574 (setq keep-going t) 1575 (setq keep-going t)
1575 (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) 1576 (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
1576 (setq rest (cdr rest)) 1577 (setq rest (cdr rest))
1577 (cond ((= tmp 1) 1578 (cond ((= tmp 1)
1578 (byte-compile-log-lap 1579 (byte-compile-log-lap
1579 " %s discard\t-->\t<deleted>" lap0) 1580 " %s discard\t-->\t<deleted>" lap0)
1580 (setq lap (delq lap0 (delq lap1 lap)))) 1581 (setq lap (delq lap0 (delq lap1 lap))))
1581 ((= tmp 0) 1582 ((= tmp 0)
1582 (byte-compile-log-lap 1583 (byte-compile-log-lap
1583 " %s discard\t-->\t<deleted> discard" lap0) 1584 " %s discard\t-->\t<deleted> discard" lap0)
1584 (setq lap (delq lap0 lap)))
1585 ((= tmp -1)
1586 (byte-compile-log-lap
1587 " %s discard\t-->\tdiscard discard" lap0)
1588 (setcar lap0 'byte-discard)
1589 (setcdr lap0 0))
1590 ((error "Optimizer error: too much on the stack"))))
1591 ;;
1592 ;; goto*-X X: --> X:
1593 ;;
1594 ((and (memq (car lap0) byte-goto-ops)
1595 (eq (cdr lap0) lap1))
1596 (cond ((eq (car lap0) 'byte-goto)
1597 (setq lap (delq lap0 lap))
1598 (setq tmp "<deleted>"))
1599 ((memq (car lap0) byte-goto-always-pop-ops)
1600 (setcar lap0 (setq tmp 'byte-discard))
1601 (setcdr lap0 0))
1602 ((error "Depth conflict at tag %d" (nth 2 lap0))))
1603 (and (memq byte-optimize-log '(t byte))
1604 (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
1605 (nth 1 lap1) (nth 1 lap1)
1606 tmp (nth 1 lap1)))
1607 (setq keep-going t))
1608 ;;
1609 ;; varset-X varref-X --> dup varset-X
1610 ;; varbind-X varref-X --> dup varbind-X
1611 ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
1612 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
1613 ;; The latter two can enable other optimizations.
1614 ;;
1615 ;; For lexical variables, we could do the same
1616 ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
1617 ;; but this is a very minor gain, since dup is stack-ref-0,
1618 ;; i.e. it's only better if X>5, and even then it comes
1619 ;; at the cost of an extra stack slot. Let's not bother.
1620 ((and (eq 'byte-varref (car lap2))
1621 (eq (cdr lap1) (cdr lap2))
1622 (memq (car lap1) '(byte-varset byte-varbind)))
1623 (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
1624 (not (eq (car lap0) 'byte-constant)))
1625 nil
1626 (setq keep-going t)
1627 (if (memq (car lap0) '(byte-constant byte-dup))
1628 (progn
1629 (setq tmp (if (or (not tmp)
1630 (macroexp--const-symbol-p
1631 (car (cdr lap0))))
1632 (cdr lap0)
1633 (byte-compile-get-constant t)))
1634 (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
1635 lap0 lap1 lap2 lap0 lap1
1636 (cons (car lap0) tmp))
1637 (setcar lap2 (car lap0))
1638 (setcdr lap2 tmp))
1639 (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
1640 (setcar lap2 (car lap1))
1641 (setcar lap1 'byte-dup)
1642 (setcdr lap1 0)
1643 ;; The stack depth gets locally increased, so we will
1644 ;; increase maxdepth in case depth = maxdepth here.
1645 ;; This can cause the third argument to byte-code to
1646 ;; be larger than necessary.
1647 (setq add-depth 1))))
1648 ;;
1649 ;; dup varset-X discard --> varset-X
1650 ;; dup varbind-X discard --> varbind-X
1651 ;; dup stack-set-X discard --> stack-set-X-1
1652 ;; (the varbind variant can emerge from other optimizations)
1653 ;;
1654 ((and (eq 'byte-dup (car lap0))
1655 (eq 'byte-discard (car lap2))
1656 (memq (car lap1) '(byte-varset byte-varbind
1657 byte-stack-set)))
1658 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
1659 (setq keep-going t
1660 rest (cdr rest))
1661 (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
1662 (setq lap (delq lap0 (delq lap2 lap))))
1663 ;;
1664 ;; not goto-X-if-nil --> goto-X-if-non-nil
1665 ;; not goto-X-if-non-nil --> goto-X-if-nil
1666 ;;
1667 ;; it is wrong to do the same thing for the -else-pop variants.
1668 ;;
1669 ((and (eq 'byte-not (car lap0))
1670 (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
1671 (byte-compile-log-lap " not %s\t-->\t%s"
1672 lap1
1673 (cons
1674 (if (eq (car lap1) 'byte-goto-if-nil)
1675 'byte-goto-if-not-nil
1676 'byte-goto-if-nil)
1677 (cdr lap1)))
1678 (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
1679 'byte-goto-if-not-nil
1680 'byte-goto-if-nil))
1681 (setq lap (delq lap0 lap))
1682 (setq keep-going t))
1683 ;;
1684 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
1685 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
1686 ;;
1687 ;; it is wrong to do the same thing for the -else-pop variants.
1688 ;;
1689 ((and (memq (car lap0)
1690 '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
1691 (eq 'byte-goto (car lap1)) ; gotoY
1692 (eq (cdr lap0) lap2)) ; TAG X
1693 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
1694 'byte-goto-if-not-nil 'byte-goto-if-nil)))
1695 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
1696 lap0 lap1 lap2
1697 (cons inverse (cdr lap1)) lap2)
1698 (setq lap (delq lap0 lap))
1699 (setcar lap1 inverse)
1700 (setq keep-going t)))
1701 ;;
1702 ;; const goto-if-* --> whatever
1703 ;;
1704 ((and (eq 'byte-constant (car lap0))
1705 (memq (car lap1) byte-conditional-ops)
1706 ;; If the `byte-constant's cdr is not a cons cell, it has
1707 ;; to be an index into the constant pool); even though
1708 ;; it'll be a constant, that constant is not known yet
1709 ;; (it's typically a free variable of a closure, so will
1710 ;; only be known when the closure will be built at
1711 ;; run-time).
1712 (consp (cdr lap0)))
1713 (cond ((if (memq (car lap1) '(byte-goto-if-nil
1714 byte-goto-if-nil-else-pop))
1715 (car (cdr lap0))
1716 (not (car (cdr lap0))))
1717 (byte-compile-log-lap " %s %s\t-->\t<deleted>"
1718 lap0 lap1)
1719 (setq rest (cdr rest)
1720 lap (delq lap0 (delq lap1 lap))))
1721 (t
1722 (byte-compile-log-lap " %s %s\t-->\t%s"
1723 lap0 lap1
1724 (cons 'byte-goto (cdr lap1)))
1725 (when (memq (car lap1) byte-goto-always-pop-ops)
1726 (setq lap (delq lap0 lap)))
1727 (setcar lap1 'byte-goto)))
1728 (setq keep-going t))
1729 ;;
1730 ;; varref-X varref-X --> varref-X dup
1731 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
1732 ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
1733 ;; We don't optimize the const-X variations on this here,
1734 ;; because that would inhibit some goto optimizations; we
1735 ;; optimize the const-X case after all other optimizations.
1736 ;;
1737 ((and (memq (car lap0) '(byte-varref byte-stack-ref))
1738 (progn
1739 (setq tmp (cdr rest))
1740 (setq tmp2 0)
1741 (while (eq (car (car tmp)) 'byte-dup)
1742 (setq tmp2 (1+ tmp2))
1743 (setq tmp (cdr tmp)))
1744 t)
1745 (eq (if (eq 'byte-stack-ref (car lap0))
1746 (+ tmp2 1 (cdr lap0))
1747 (cdr lap0))
1748 (cdr (car tmp)))
1749 (eq (car lap0) (car (car tmp))))
1750 (if (memq byte-optimize-log '(t byte))
1751 (let ((str ""))
1752 (setq tmp2 (cdr rest))
1753 (while (not (eq tmp tmp2))
1754 (setq tmp2 (cdr tmp2)
1755 str (concat str " dup")))
1756 (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
1757 lap0 str lap0 lap0 str)))
1758 (setq keep-going t)
1759 (setcar (car tmp) 'byte-dup)
1760 (setcdr (car tmp) 0)
1761 (setq rest tmp))
1762 ;;
1763 ;; TAG1: TAG2: --> TAG1: <deleted>
1764 ;; (and other references to TAG2 are replaced with TAG1)
1765 ;;
1766 ((and (eq (car lap0) 'TAG)
1767 (eq (car lap1) 'TAG))
1768 (and (memq byte-optimize-log '(t byte))
1769 (byte-compile-log " adjacent tags %d and %d merged"
1770 (nth 1 lap1) (nth 1 lap0)))
1771 (setq tmp3 lap)
1772 (while (setq tmp2 (rassq lap0 tmp3))
1773 (setcdr tmp2 lap1)
1774 (setq tmp3 (cdr (memq tmp2 tmp3))))
1775 (setq lap (delq lap0 lap)
1776 keep-going t)
1777 ;; replace references to tag in jump tables, if any
1778 (dolist (table byte-compile-jump-tables)
1779 (maphash #'(lambda (value tag)
1780 (when (equal tag lap0)
1781 (puthash value lap1 table)))
1782 table)))
1783 ;;
1784 ;; unused-TAG: --> <deleted>
1785 ;;
1786 ((and (eq 'TAG (car lap0))
1787 (not (rassq lap0 lap))
1788 ;; make sure this tag isn't used in a jump-table
1789 (cl-loop for table in byte-compile-jump-tables
1790 when (member lap0 (hash-table-values table))
1791 return nil finally return t))
1792 (and (memq byte-optimize-log '(t byte))
1793 (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
1794 (setq lap (delq lap0 lap)
1795 keep-going t))
1796 ;;
1797 ;; goto ... --> goto <delete until TAG or end>
1798 ;; return ... --> return <delete until TAG or end>
1799 ;; (unless a jump-table is being used, where deleting may affect
1800 ;; other valid case bodies)
1801 ;;
1802 ((and (memq (car lap0) '(byte-goto byte-return))
1803 (not (memq (car lap1) '(TAG nil)))
1804 ;; FIXME: Instead of deferring simply when jump-tables are
1805 ;; being used, keep a list of tags used for switch tags and
1806 ;; use them instead (see `byte-compile-inline-lapcode').
1807 (not byte-compile-jump-tables))
1808 (setq tmp rest)
1809 (let ((i 0)
1810 (opt-p (memq byte-optimize-log '(t lap)))
1811 str deleted)
1812 (while (and (setq tmp (cdr tmp))
1813 (not (eq 'TAG (car (car tmp)))))
1814 (if opt-p (setq deleted (cons (car tmp) deleted)
1815 str (concat str " %s")
1816 i (1+ i))))
1817 (if opt-p
1818 (let ((tagstr
1819 (if (eq 'TAG (car (car tmp)))
1820 (format "%d:" (car (cdr (car tmp))))
1821 (or (car tmp) ""))))
1822 (if (< i 6)
1823 (apply 'byte-compile-log-lap-1
1824 (concat " %s" str
1825 " %s\t-->\t%s <deleted> %s")
1826 lap0
1827 (nconc (nreverse deleted)
1828 (list tagstr lap0 tagstr)))
1829 (byte-compile-log-lap
1830 " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
1831 lap0 i (if (= i 1) "" "s")
1832 tagstr lap0 tagstr))))
1833 (rplacd rest tmp))
1834 (setq keep-going t))
1835 ;;
1836 ;; <safe-op> unbind --> unbind <safe-op>
1837 ;; (this may enable other optimizations.)
1838 ;;
1839 ((and (eq 'byte-unbind (car lap1))
1840 (memq (car lap0) byte-after-unbind-ops))
1841 (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
1842 (setcar rest lap1)
1843 (setcar (cdr rest) lap0)
1844 (setq keep-going t))
1845 ;;
1846 ;; varbind-X unbind-N --> discard unbind-(N-1)
1847 ;; save-excursion unbind-N --> unbind-(N-1)
1848 ;; save-restriction unbind-N --> unbind-(N-1)
1849 ;;
1850 ((and (eq 'byte-unbind (car lap1))
1851 (memq (car lap0) '(byte-varbind byte-save-excursion
1852 byte-save-restriction))
1853 (< 0 (cdr lap1)))
1854 (if (zerop (setcdr lap1 (1- (cdr lap1))))
1855 (delq lap1 rest))
1856 (if (eq (car lap0) 'byte-varbind)
1857 (setcar rest (cons 'byte-discard 0))
1858 (setq lap (delq lap0 lap))) 1585 (setq lap (delq lap0 lap)))
1859 (byte-compile-log-lap " %s %s\t-->\t%s %s" 1586 ((= tmp -1)
1860 lap0 (cons (car lap1) (1+ (cdr lap1))) 1587 (byte-compile-log-lap
1861 (if (eq (car lap0) 'byte-varbind) 1588 " %s discard\t-->\tdiscard discard" lap0)
1862 (car rest) 1589 (setcar lap0 'byte-discard)
1863 (car (cdr rest))) 1590 (setcdr lap0 0))
1864 (if (and (/= 0 (cdr lap1)) 1591 ((error "Optimizer error: too much on the stack"))))
1865 (eq (car lap0) 'byte-varbind)) 1592 ;;
1866 (car (cdr rest)) 1593 ;; goto*-X X: --> X:
1867 "")) 1594 ;;
1868 (setq keep-going t)) 1595 ((and (memq (car lap0) byte-goto-ops)
1869 ;; 1596 (eq (cdr lap0) lap1))
1870 ;; goto*-X ... X: goto-Y --> goto*-Y 1597 (cond ((eq (car lap0) 'byte-goto)
1871 ;; goto-X ... X: return --> return 1598 (setq lap (delq lap0 lap))
1872 ;; 1599 (setq tmp "<deleted>"))
1873 ((and (memq (car lap0) byte-goto-ops) 1600 ((memq (car lap0) byte-goto-always-pop-ops)
1874 (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) 1601 (setcar lap0 (setq tmp 'byte-discard))
1875 '(byte-goto byte-return))) 1602 (setcdr lap0 0))
1876 (cond ((and (not (eq tmp lap0)) 1603 ((error "Depth conflict at tag %d" (nth 2 lap0))))
1877 (or (eq (car lap0) 'byte-goto) 1604 (and (memq byte-optimize-log '(t byte))
1878 (eq (car tmp) 'byte-goto))) 1605 (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
1879 (byte-compile-log-lap " %s [%s]\t-->\t%s" 1606 (nth 1 lap1) (nth 1 lap1)
1880 (car lap0) tmp tmp) 1607 tmp (nth 1 lap1)))
1881 (if (eq (car tmp) 'byte-return) 1608 (setq keep-going t))
1882 (setcar lap0 'byte-return)) 1609 ;;
1883 (setcdr lap0 (cdr tmp)) 1610 ;; varset-X varref-X --> dup varset-X
1884 (setq keep-going t)))) 1611 ;; varbind-X varref-X --> dup varbind-X
1885 ;; 1612 ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
1886 ;; goto-*-else-pop X ... X: goto-if-* --> whatever 1613 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
1887 ;; goto-*-else-pop X ... X: discard --> whatever 1614 ;; The latter two can enable other optimizations.
1888 ;; 1615 ;;
1889 ((and (memq (car lap0) '(byte-goto-if-nil-else-pop 1616 ;; For lexical variables, we could do the same
1890 byte-goto-if-not-nil-else-pop)) 1617 ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
1891 (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) 1618 ;; but this is a very minor gain, since dup is stack-ref-0,
1892 (eval-when-compile 1619 ;; i.e. it's only better if X>5, and even then it comes
1893 (cons 'byte-discard byte-conditional-ops))) 1620 ;; at the cost of an extra stack slot. Let's not bother.
1894 (not (eq lap0 (car tmp)))) 1621 ((and (eq 'byte-varref (car lap2))
1895 (setq tmp2 (car tmp)) 1622 (eq (cdr lap1) (cdr lap2))
1896 (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop 1623 (memq (car lap1) '(byte-varset byte-varbind)))
1897 byte-goto-if-nil) 1624 (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
1898 (byte-goto-if-not-nil-else-pop 1625 (not (eq (car lap0) 'byte-constant)))
1899 byte-goto-if-not-nil)))) 1626 nil
1900 (if (memq (car tmp2) tmp3) 1627 (setq keep-going t)
1901 (progn (setcar lap0 (car tmp2)) 1628 (if (memq (car lap0) '(byte-constant byte-dup))
1902 (setcdr lap0 (cdr tmp2)) 1629 (progn
1903 (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" 1630 (setq tmp (if (or (not tmp)
1904 (car lap0) tmp2 lap0)) 1631 (macroexp--const-symbol-p
1905 ;; Get rid of the -else-pop's and jump one step further. 1632 (car (cdr lap0))))
1633 (cdr lap0)
1634 (byte-compile-get-constant t)))
1635 (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
1636 lap0 lap1 lap2 lap0 lap1
1637 (cons (car lap0) tmp))
1638 (setcar lap2 (car lap0))
1639 (setcdr lap2 tmp))
1640 (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
1641 (setcar lap2 (car lap1))
1642 (setcar lap1 'byte-dup)
1643 (setcdr lap1 0)
1644 ;; The stack depth gets locally increased, so we will
1645 ;; increase maxdepth in case depth = maxdepth here.
1646 ;; This can cause the third argument to byte-code to
1647 ;; be larger than necessary.
1648 (setq add-depth 1))))
1649 ;;
1650 ;; dup varset-X discard --> varset-X
1651 ;; dup varbind-X discard --> varbind-X
1652 ;; dup stack-set-X discard --> stack-set-X-1
1653 ;; (the varbind variant can emerge from other optimizations)
1654 ;;
1655 ((and (eq 'byte-dup (car lap0))
1656 (eq 'byte-discard (car lap2))
1657 (memq (car lap1) '(byte-varset byte-varbind
1658 byte-stack-set)))
1659 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
1660 (setq keep-going t
1661 rest (cdr rest))
1662 (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
1663 (setq lap (delq lap0 (delq lap2 lap))))
1664 ;;
1665 ;; not goto-X-if-nil --> goto-X-if-non-nil
1666 ;; not goto-X-if-non-nil --> goto-X-if-nil
1667 ;;
1668 ;; it is wrong to do the same thing for the -else-pop variants.
1669 ;;
1670 ((and (eq 'byte-not (car lap0))
1671 (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
1672 (byte-compile-log-lap " not %s\t-->\t%s"
1673 lap1
1674 (cons
1675 (if (eq (car lap1) 'byte-goto-if-nil)
1676 'byte-goto-if-not-nil
1677 'byte-goto-if-nil)
1678 (cdr lap1)))
1679 (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
1680 'byte-goto-if-not-nil
1681 'byte-goto-if-nil))
1682 (setq lap (delq lap0 lap))
1683 (setq keep-going t))
1684 ;;
1685 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
1686 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
1687 ;;
1688 ;; it is wrong to do the same thing for the -else-pop variants.
1689 ;;
1690 ((and (memq (car lap0)
1691 '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
1692 (eq 'byte-goto (car lap1)) ; gotoY
1693 (eq (cdr lap0) lap2)) ; TAG X
1694 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
1695 'byte-goto-if-not-nil 'byte-goto-if-nil)))
1696 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
1697 lap0 lap1 lap2
1698 (cons inverse (cdr lap1)) lap2)
1699 (setq lap (delq lap0 lap))
1700 (setcar lap1 inverse)
1701 (setq keep-going t)))
1702 ;;
1703 ;; const goto-if-* --> whatever
1704 ;;
1705 ((and (eq 'byte-constant (car lap0))
1706 (memq (car lap1) byte-conditional-ops)
1707 ;; If the `byte-constant's cdr is not a cons cell, it has
1708 ;; to be an index into the constant pool); even though
1709 ;; it'll be a constant, that constant is not known yet
1710 ;; (it's typically a free variable of a closure, so will
1711 ;; only be known when the closure will be built at
1712 ;; run-time).
1713 (consp (cdr lap0)))
1714 (cond ((if (memq (car lap1) '(byte-goto-if-nil
1715 byte-goto-if-nil-else-pop))
1716 (car (cdr lap0))
1717 (not (car (cdr lap0))))
1718 (byte-compile-log-lap " %s %s\t-->\t<deleted>"
1719 lap0 lap1)
1720 (setq rest (cdr rest)
1721 lap (delq lap0 (delq lap1 lap))))
1722 (t
1723 (byte-compile-log-lap " %s %s\t-->\t%s"
1724 lap0 lap1
1725 (cons 'byte-goto (cdr lap1)))
1726 (when (memq (car lap1) byte-goto-always-pop-ops)
1727 (setq lap (delq lap0 lap)))
1728 (setcar lap1 'byte-goto)))
1729 (setq keep-going t))
1730 ;;
1731 ;; varref-X varref-X --> varref-X dup
1732 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
1733 ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
1734 ;; We don't optimize the const-X variations on this here,
1735 ;; because that would inhibit some goto optimizations; we
1736 ;; optimize the const-X case after all other optimizations.
1737 ;;
1738 ((and (memq (car lap0) '(byte-varref byte-stack-ref))
1739 (progn
1740 (setq tmp (cdr rest))
1741 (setq tmp2 0)
1742 (while (eq (car (car tmp)) 'byte-dup)
1743 (setq tmp2 (1+ tmp2))
1744 (setq tmp (cdr tmp)))
1745 t)
1746 (eq (if (eq 'byte-stack-ref (car lap0))
1747 (+ tmp2 1 (cdr lap0))
1748 (cdr lap0))
1749 (cdr (car tmp)))
1750 (eq (car lap0) (car (car tmp))))
1751 (if (memq byte-optimize-log '(t byte))
1752 (let ((str ""))
1753 (setq tmp2 (cdr rest))
1754 (while (not (eq tmp tmp2))
1755 (setq tmp2 (cdr tmp2)
1756 str (concat str " dup")))
1757 (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
1758 lap0 str lap0 lap0 str)))
1759 (setq keep-going t)
1760 (setcar (car tmp) 'byte-dup)
1761 (setcdr (car tmp) 0)
1762 (setq rest tmp))
1763 ;;
1764 ;; TAG1: TAG2: --> TAG1: <deleted>
1765 ;; (and other references to TAG2 are replaced with TAG1)
1766 ;;
1767 ((and (eq (car lap0) 'TAG)
1768 (eq (car lap1) 'TAG))
1769 (and (memq byte-optimize-log '(t byte))
1770 (byte-compile-log " adjacent tags %d and %d merged"
1771 (nth 1 lap1) (nth 1 lap0)))
1772 (setq tmp3 lap)
1773 (while (setq tmp2 (rassq lap0 tmp3))
1774 (setcdr tmp2 lap1)
1775 (setq tmp3 (cdr (memq tmp2 tmp3))))
1776 (setq lap (delq lap0 lap)
1777 keep-going t)
1778 ;; replace references to tag in jump tables, if any
1779 (dolist (table byte-compile-jump-tables)
1780 (maphash #'(lambda (value tag)
1781 (when (equal tag lap0)
1782 (puthash value lap1 table)))
1783 table)))
1784 ;;
1785 ;; unused-TAG: --> <deleted>
1786 ;;
1787 ((and (eq 'TAG (car lap0))
1788 (not (rassq lap0 lap))
1789 ;; make sure this tag isn't used in a jump-table
1790 (cl-loop for table in byte-compile-jump-tables
1791 when (member lap0 (hash-table-values table))
1792 return nil finally return t))
1793 (and (memq byte-optimize-log '(t byte))
1794 (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
1795 (setq lap (delq lap0 lap)
1796 keep-going t))
1797 ;;
1798 ;; goto ... --> goto <delete until TAG or end>
1799 ;; return ... --> return <delete until TAG or end>
1800 ;; (unless a jump-table is being used, where deleting may affect
1801 ;; other valid case bodies)
1802 ;;
1803 ((and (memq (car lap0) '(byte-goto byte-return))
1804 (not (memq (car lap1) '(TAG nil)))
1805 ;; FIXME: Instead of deferring simply when jump-tables are
1806 ;; being used, keep a list of tags used for switch tags and
1807 ;; use them instead (see `byte-compile-inline-lapcode').
1808 (not byte-compile-jump-tables))
1809 (setq tmp rest)
1810 (let ((i 0)
1811 (opt-p (memq byte-optimize-log '(t lap)))
1812 str deleted)
1813 (while (and (setq tmp (cdr tmp))
1814 (not (eq 'TAG (car (car tmp)))))
1815 (if opt-p (setq deleted (cons (car tmp) deleted)
1816 str (concat str " %s")
1817 i (1+ i))))
1818 (if opt-p
1819 (let ((tagstr
1820 (if (eq 'TAG (car (car tmp)))
1821 (format "%d:" (car (cdr (car tmp))))
1822 (or (car tmp) ""))))
1823 (if (< i 6)
1824 (apply 'byte-compile-log-lap-1
1825 (concat " %s" str
1826 " %s\t-->\t%s <deleted> %s")
1827 lap0
1828 (nconc (nreverse deleted)
1829 (list tagstr lap0 tagstr)))
1830 (byte-compile-log-lap
1831 " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
1832 lap0 i (if (= i 1) "" "s")
1833 tagstr lap0 tagstr))))
1834 (rplacd rest tmp))
1835 (setq keep-going t))
1836 ;;
1837 ;; <safe-op> unbind --> unbind <safe-op>
1838 ;; (this may enable other optimizations.)
1839 ;;
1840 ((and (eq 'byte-unbind (car lap1))
1841 (memq (car lap0) byte-after-unbind-ops))
1842 (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
1843 (setcar rest lap1)
1844 (setcar (cdr rest) lap0)
1845 (setq keep-going t))
1846 ;;
1847 ;; varbind-X unbind-N --> discard unbind-(N-1)
1848 ;; save-excursion unbind-N --> unbind-(N-1)
1849 ;; save-restriction unbind-N --> unbind-(N-1)
1850 ;;
1851 ((and (eq 'byte-unbind (car lap1))
1852 (memq (car lap0) '(byte-varbind byte-save-excursion
1853 byte-save-restriction))
1854 (< 0 (cdr lap1)))
1855 (if (zerop (setcdr lap1 (1- (cdr lap1))))
1856 (delq lap1 rest))
1857 (if (eq (car lap0) 'byte-varbind)
1858 (setcar rest (cons 'byte-discard 0))
1859 (setq lap (delq lap0 lap)))
1860 (byte-compile-log-lap " %s %s\t-->\t%s %s"
1861 lap0 (cons (car lap1) (1+ (cdr lap1)))
1862 (if (eq (car lap0) 'byte-varbind)
1863 (car rest)
1864 (car (cdr rest)))
1865 (if (and (/= 0 (cdr lap1))
1866 (eq (car lap0) 'byte-varbind))
1867 (car (cdr rest))
1868 ""))
1869 (setq keep-going t))
1870 ;;
1871 ;; goto*-X ... X: goto-Y --> goto*-Y
1872 ;; goto-X ... X: return --> return
1873 ;;
1874 ((and (memq (car lap0) byte-goto-ops)
1875 (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
1876 '(byte-goto byte-return)))
1877 (cond ((and (not (eq tmp lap0))
1878 (or (eq (car lap0) 'byte-goto)
1879 (eq (car tmp) 'byte-goto)))
1880 (byte-compile-log-lap " %s [%s]\t-->\t%s"
1881 (car lap0) tmp tmp)
1882 (if (eq (car tmp) 'byte-return)
1883 (setcar lap0 'byte-return))
1884 (setcdr lap0 (cdr tmp))
1885 (setq keep-going t))))
1886 ;;
1887 ;; goto-*-else-pop X ... X: goto-if-* --> whatever
1888 ;; goto-*-else-pop X ... X: discard --> whatever
1889 ;;
1890 ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
1891 byte-goto-if-not-nil-else-pop))
1892 (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
1893 (eval-when-compile
1894 (cons 'byte-discard byte-conditional-ops)))
1895 (not (eq lap0 (car tmp))))
1896 (setq tmp2 (car tmp))
1897 (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
1898 byte-goto-if-nil)
1899 (byte-goto-if-not-nil-else-pop
1900 byte-goto-if-not-nil))))
1901 (if (memq (car tmp2) tmp3)
1902 (progn (setcar lap0 (car tmp2))
1903 (setcdr lap0 (cdr tmp2))
1904 (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
1905 (car lap0) tmp2 lap0))
1906 ;; Get rid of the -else-pop's and jump one step further.
1907 (or (eq 'TAG (car (nth 1 tmp)))
1908 (setcdr tmp (cons (byte-compile-make-tag)
1909 (cdr tmp))))
1910 (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
1911 (car lap0) tmp2 (nth 1 tmp3))
1912 (setcar lap0 (nth 1 tmp3))
1913 (setcdr lap0 (nth 1 tmp)))
1914 (setq keep-going t))
1915 ;;
1916 ;; const goto-X ... X: goto-if-* --> whatever
1917 ;; const goto-X ... X: discard --> whatever
1918 ;;
1919 ((and (eq (car lap0) 'byte-constant)
1920 (eq (car lap1) 'byte-goto)
1921 (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
1922 (eval-when-compile
1923 (cons 'byte-discard byte-conditional-ops)))
1924 (not (eq lap1 (car tmp))))
1925 (setq tmp2 (car tmp))
1926 (cond ((when (consp (cdr lap0))
1927 (memq (car tmp2)
1928 (if (null (car (cdr lap0)))
1929 '(byte-goto-if-nil byte-goto-if-nil-else-pop)
1930 '(byte-goto-if-not-nil
1931 byte-goto-if-not-nil-else-pop))))
1932 (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
1933 lap0 tmp2 lap0 tmp2)
1934 (setcar lap1 (car tmp2))
1935 (setcdr lap1 (cdr tmp2))
1936 ;; Let next step fix the (const,goto-if*) sequence.
1937 (setq rest (cons nil rest))
1938 (setq keep-going t))
1939 ((or (consp (cdr lap0))
1940 (eq (car tmp2) 'byte-discard))
1941 ;; Jump one step further
1942 (byte-compile-log-lap
1943 " %s goto [%s]\t-->\t<deleted> goto <skip>"
1944 lap0 tmp2)
1906 (or (eq 'TAG (car (nth 1 tmp))) 1945 (or (eq 'TAG (car (nth 1 tmp)))
1907 (setcdr tmp (cons (byte-compile-make-tag) 1946 (setcdr tmp (cons (byte-compile-make-tag)
1908 (cdr tmp)))) 1947 (cdr tmp))))
1909 (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" 1948 (setcdr lap1 (car (cdr tmp)))
1910 (car lap0) tmp2 (nth 1 tmp3)) 1949 (setq lap (delq lap0 lap))
1911 (setcar lap0 (nth 1 tmp3)) 1950 (setq keep-going t))))
1912 (setcdr lap0 (nth 1 tmp))) 1951 ;;
1913 (setq keep-going t)) 1952 ;; X: varref-Y ... varset-Y goto-X -->
1914 ;; 1953 ;; X: varref-Y Z: ... dup varset-Y goto-Z
1915 ;; const goto-X ... X: goto-if-* --> whatever 1954 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
1916 ;; const goto-X ... X: discard --> whatever 1955 ;; (This is so usual for while loops that it is worth handling).
1917 ;; 1956 ;;
1918 ((and (eq (car lap0) 'byte-constant) 1957 ;; Here again, we could do it for stack-ref/stack-set, but
1919 (eq (car lap1) 'byte-goto) 1958 ;; that's replacing a stack-ref-Y with a stack-ref-0, which
1920 (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) 1959 ;; is a very minor improvement (if any), at the cost of
1921 (eval-when-compile 1960 ;; more stack use and more byte-code. Let's not do it.
1922 (cons 'byte-discard byte-conditional-ops))) 1961 ;;
1923 (not (eq lap1 (car tmp)))) 1962 ((and (eq (car lap1) 'byte-varset)
1924 (setq tmp2 (car tmp)) 1963 (eq (car lap2) 'byte-goto)
1925 (cond ((when (consp (cdr lap0)) 1964 (not (memq (cdr lap2) rest)) ;Backwards jump
1926 (memq (car tmp2) 1965 (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
1927 (if (null (car (cdr lap0))) 1966 'byte-varref)
1928 '(byte-goto-if-nil byte-goto-if-nil-else-pop) 1967 (eq (cdr (car tmp)) (cdr lap1))
1929 '(byte-goto-if-not-nil 1968 (not (memq (car (cdr lap1)) byte-boolean-vars)))
1930 byte-goto-if-not-nil-else-pop)))) 1969 ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
1931 (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" 1970 (let ((newtag (byte-compile-make-tag)))
1932 lap0 tmp2 lap0 tmp2) 1971 (byte-compile-log-lap
1933 (setcar lap1 (car tmp2)) 1972 " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
1934 (setcdr lap1 (cdr tmp2)) 1973 (nth 1 (cdr lap2)) (car tmp)
1935 ;; Let next step fix the (const,goto-if*) sequence. 1974 lap1 lap2
1936 (setq rest (cons nil rest)) 1975 (nth 1 (cdr lap2)) (car tmp)
1937 (setq keep-going t)) 1976 (nth 1 newtag) 'byte-dup lap1
1938 ((or (consp (cdr lap0)) 1977 (cons 'byte-goto newtag)
1939 (eq (car tmp2) 'byte-discard)) 1978 )
1940 ;; Jump one step further 1979 (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
1941 (byte-compile-log-lap 1980 (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
1942 " %s goto [%s]\t-->\t<deleted> goto <skip>" 1981 (setq add-depth 1)
1943 lap0 tmp2) 1982 (setq keep-going t))
1944 (or (eq 'TAG (car (nth 1 tmp))) 1983 ;;
1945 (setcdr tmp (cons (byte-compile-make-tag) 1984 ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
1946 (cdr tmp)))) 1985 ;; (This can pull the loop test to the end of the loop)
1947 (setcdr lap1 (car (cdr tmp))) 1986 ;;
1948 (setq lap (delq lap0 lap)) 1987 ((and (eq (car lap0) 'byte-goto)
1949 (setq keep-going t)))) 1988 (eq (car lap1) 'TAG)
1950 ;; 1989 (eq lap1
1951 ;; X: varref-Y ... varset-Y goto-X --> 1990 (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
1952 ;; X: varref-Y Z: ... dup varset-Y goto-Z 1991 (memq (car (car tmp))
1953 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) 1992 '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
1954 ;; (This is so usual for while loops that it is worth handling). 1993 byte-goto-if-nil-else-pop)))
1955 ;; 1994 ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
1956 ;; Here again, we could do it for stack-ref/stack-set, but 1995 ;; lap0 lap1 (cdr lap0) (car tmp))
1957 ;; that's replacing a stack-ref-Y with a stack-ref-0, which 1996 (let ((newtag (byte-compile-make-tag)))
1958 ;; is a very minor improvement (if any), at the cost of 1997 (byte-compile-log-lap
1959 ;; more stack use and more byte-code. Let's not do it. 1998 "%s %s: ... %s: %s\t-->\t%s ... %s:"
1960 ;; 1999 lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
1961 ((and (eq (car lap1) 'byte-varset) 2000 (cons (cdr (assq (car (car tmp))
1962 (eq (car lap2) 'byte-goto) 2001 '((byte-goto-if-nil . byte-goto-if-not-nil)
1963 (not (memq (cdr lap2) rest)) ;Backwards jump 2002 (byte-goto-if-not-nil . byte-goto-if-nil)
1964 (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) 2003 (byte-goto-if-nil-else-pop .
1965 'byte-varref) 2004 byte-goto-if-not-nil-else-pop)
1966 (eq (cdr (car tmp)) (cdr lap1)) 2005 (byte-goto-if-not-nil-else-pop .
1967 (not (memq (car (cdr lap1)) byte-boolean-vars))) 2006 byte-goto-if-nil-else-pop))))
1968 ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) 2007 newtag)
1969 (let ((newtag (byte-compile-make-tag))) 2008
1970 (byte-compile-log-lap 2009 (nth 1 newtag)
1971 " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" 2010 )
1972 (nth 1 (cdr lap2)) (car tmp) 2011 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
1973 lap1 lap2 2012 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
1974 (nth 1 (cdr lap2)) (car tmp) 2013 ;; We can handle this case but not the -if-not-nil case,
1975 (nth 1 newtag) 'byte-dup lap1 2014 ;; because we won't know which non-nil constant to push.
1976 (cons 'byte-goto newtag) 2015 (setcdr rest (cons (cons 'byte-constant
1977 ) 2016 (byte-compile-get-constant nil))
1978 (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) 2017 (cdr rest))))
1979 (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) 2018 (setcar lap0 (nth 1 (memq (car (car tmp))
1980 (setq add-depth 1) 2019 '(byte-goto-if-nil-else-pop
1981 (setq keep-going t)) 2020 byte-goto-if-not-nil
1982 ;; 2021 byte-goto-if-nil
1983 ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: 2022 byte-goto-if-not-nil
1984 ;; (This can pull the loop test to the end of the loop) 2023 byte-goto byte-goto))))
1985 ;; 2024 )
1986 ((and (eq (car lap0) 'byte-goto) 2025 (setq keep-going t))
1987 (eq (car lap1) 'TAG) 2026
1988 (eq lap1 2027 ;;
1989 (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) 2028 ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
1990 (memq (car (car tmp)) 2029 ;; stack-set-M [discard/discardN ...] --> discardN
1991 '(byte-goto byte-goto-if-nil byte-goto-if-not-nil 2030 ;;
1992 byte-goto-if-nil-else-pop))) 2031 ((and (eq (car lap0) 'byte-stack-set)
1993;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" 2032 (memq (car lap1) '(byte-discard byte-discardN))
1994;; lap0 lap1 (cdr lap0) (car tmp)) 2033 (progn
1995 (let ((newtag (byte-compile-make-tag))) 2034 ;; See if enough discard operations follow to expose or
1996 (byte-compile-log-lap 2035 ;; destroy the value stored by the stack-set.
1997 "%s %s: ... %s: %s\t-->\t%s ... %s:" 2036 (setq tmp (cdr rest))
1998 lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) 2037 (setq tmp2 (1- (cdr lap0)))
1999 (cons (cdr (assq (car (car tmp)) 2038 (setq tmp3 0)
2000 '((byte-goto-if-nil . byte-goto-if-not-nil) 2039 (while (memq (car (car tmp)) '(byte-discard byte-discardN))
2001 (byte-goto-if-not-nil . byte-goto-if-nil) 2040 (setq tmp3
2002 (byte-goto-if-nil-else-pop . 2041 (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
2003 byte-goto-if-not-nil-else-pop) 2042 1
2004 (byte-goto-if-not-nil-else-pop . 2043 (cdr (car tmp)))))
2005 byte-goto-if-nil-else-pop)))) 2044 (setq tmp (cdr tmp)))
2006 newtag) 2045 (>= tmp3 tmp2)))
2007 2046 ;; Do the optimization.
2008 (nth 1 newtag) 2047 (setq lap (delq lap0 lap))
2009 ) 2048 (setcar lap1
2010 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) 2049 (if (= tmp2 tmp3)
2011 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) 2050 ;; The value stored is the new TOS, so pop one more
2012 ;; We can handle this case but not the -if-not-nil case, 2051 ;; value (to get rid of the old value) using the
2013 ;; because we won't know which non-nil constant to push. 2052 ;; TOS-preserving discard operator.
2014 (setcdr rest (cons (cons 'byte-constant 2053 'byte-discardN-preserve-tos
2015 (byte-compile-get-constant nil)) 2054 ;; Otherwise, the value stored is lost, so just use a
2016 (cdr rest)))) 2055 ;; normal discard.
2017 (setcar lap0 (nth 1 (memq (car (car tmp)) 2056 'byte-discardN))
2018 '(byte-goto-if-nil-else-pop 2057 (setcdr lap1 (1+ tmp3))
2019 byte-goto-if-not-nil 2058 (setcdr (cdr rest) tmp)
2020 byte-goto-if-nil 2059 (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
2021 byte-goto-if-not-nil 2060 lap0 lap1))
2022 byte-goto byte-goto)))) 2061
2023 ) 2062 ;;
2024 (setq keep-going t)) 2063 ;; discardN-preserve-tos return --> return
2025 ) 2064 ;; dup return --> return
2065 ;; stack-set-N return --> return ; where N is TOS-1
2066 ;;
2067 ((and (eq (car lap1) 'byte-return)
2068 (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
2069 (and (eq (car lap0) 'byte-stack-set)
2070 (= (cdr lap0) 1))))
2071 (setq keep-going t)
2072 ;; The byte-code interpreter will pop the stack for us, so
2073 ;; we can just leave stuff on it.
2074 (setq lap (delq lap0 lap))
2075 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
2076
2077 ;;
2078 ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y:
2079 ;;
2080 ((and (eq (car lap0) 'byte-goto)
2081 (setq tmp (cdr (memq (cdr lap0) lap)))
2082 (memq (caar tmp) '(byte-discard byte-discardN
2083 byte-discardN-preserve-tos)))
2084 (byte-compile-log-lap
2085 " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
2086 (car tmp) (car tmp))
2087 (setq keep-going t)
2088 (let* ((newtag (byte-compile-make-tag))
2089 ;; Make a copy, since we sometimes modify insts in-place!
2090 (newdiscard (cons (caar tmp) (cdar tmp)))
2091 (newjmp (cons (car lap0) newtag)))
2092 (push newtag (cdr tmp)) ;Push new tag after the discard.
2093 (setcar rest newdiscard)
2094 (push newjmp (cdr rest))))
2095
2096 ;;
2097 ;; const discardN-preserve-tos ==> discardN const
2098 ;;
2099 ((and (eq (car lap0) 'byte-constant)
2100 (eq (car lap1) 'byte-discardN-preserve-tos))
2101 (setq keep-going t)
2102 (let ((newdiscard (cons 'byte-discardN (cdr lap1))))
2103 (byte-compile-log-lap
2104 " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
2105 (setf (car rest) newdiscard)
2106 (setf (cadr rest) lap0)))
2107 )
2026 (setq rest (cdr rest))) 2108 (setq rest (cdr rest)))
2027 ) 2109 )
2028 ;; Cleanup stage: 2110 ;; Cleanup stage:
@@ -2086,41 +2168,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
2086 (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) 2168 (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
2087 2169
2088 ;; 2170 ;;
2089 ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
2090 ;; stack-set-M [discard/discardN ...] --> discardN
2091 ;;
2092 ((and (eq (car lap0) 'byte-stack-set)
2093 (memq (car lap1) '(byte-discard byte-discardN))
2094 (progn
2095 ;; See if enough discard operations follow to expose or
2096 ;; destroy the value stored by the stack-set.
2097 (setq tmp (cdr rest))
2098 (setq tmp2 (1- (cdr lap0)))
2099 (setq tmp3 0)
2100 (while (memq (car (car tmp)) '(byte-discard byte-discardN))
2101 (setq tmp3
2102 (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
2103 1
2104 (cdr (car tmp)))))
2105 (setq tmp (cdr tmp)))
2106 (>= tmp3 tmp2)))
2107 ;; Do the optimization.
2108 (setq lap (delq lap0 lap))
2109 (setcar lap1
2110 (if (= tmp2 tmp3)
2111 ;; The value stored is the new TOS, so pop one more
2112 ;; value (to get rid of the old value) using the
2113 ;; TOS-preserving discard operator.
2114 'byte-discardN-preserve-tos
2115 ;; Otherwise, the value stored is lost, so just use a
2116 ;; normal discard.
2117 'byte-discardN))
2118 (setcdr lap1 (1+ tmp3))
2119 (setcdr (cdr rest) tmp)
2120 (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
2121 lap0 lap1))
2122
2123 ;;
2124 ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> 2171 ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
2125 ;; discardN-(X+Y) 2172 ;; discardN-(X+Y)
2126 ;; 2173 ;;
@@ -2147,20 +2194,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
2147 (setq lap (delq lap0 lap)) 2194 (setq lap (delq lap0 lap))
2148 (setcdr lap1 (+ (cdr lap0) (cdr lap1))) 2195 (setcdr lap1 (+ (cdr lap0) (cdr lap1)))
2149 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) 2196 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
2150
2151 ;;
2152 ;; discardN-preserve-tos return --> return
2153 ;; dup return --> return
2154 ;; stack-set-N return --> return ; where N is TOS-1
2155 ;;
2156 ((and (eq (car lap1) 'byte-return)
2157 (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
2158 (and (eq (car lap0) 'byte-stack-set)
2159 (= (cdr lap0) 1))))
2160 ;; The byte-code interpreter will pop the stack for us, so
2161 ;; we can just leave stuff on it.
2162 (setq lap (delq lap0 lap))
2163 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
2164 ) 2197 )
2165 (setq rest (cdr rest))) 2198 (setq rest (cdr rest)))
2166 (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) 2199 (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 3ed299864b7..a3ad43038e7 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -238,8 +238,11 @@ The return value is undefined.
238 #'(lambda (x) 238 #'(lambda (x)
239 (let ((f (cdr (assq (car x) macro-declarations-alist)))) 239 (let ((f (cdr (assq (car x) macro-declarations-alist))))
240 (if f (apply (car f) name arglist (cdr x)) 240 (if f (apply (car f) name arglist (cdr x))
241 (message "Warning: Unknown macro property %S in %S" 241 (macroexp--warn-and-return
242 (car x) name)))) 242 (format-message
243 "Unknown macro property %S in %S"
244 (car x) name)
245 nil))))
243 decls))) 246 decls)))
244 ;; Refresh font-lock if this is a new macro, or it is an 247 ;; Refresh font-lock if this is a new macro, or it is an
245 ;; existing macro whose 'no-font-lock-keyword declaration 248 ;; existing macro whose 'no-font-lock-keyword declaration
@@ -307,9 +310,12 @@ The return value is undefined.
307 (cdr body) 310 (cdr body)
308 body))) 311 body)))
309 nil) 312 nil)
310 (t (message "Warning: Unknown defun property `%S' in %S" 313 (t
311 (car x) name))))) 314 (macroexp--warn-and-return
312 decls)) 315 (format-message "Unknown defun property `%S' in %S"
316 (car x) name)
317 nil)))))
318 decls))
313 (def (list 'defalias 319 (def (list 'defalias
314 (list 'quote name) 320 (list 'quote name)
315 (list 'function 321 (list 'function
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 54f8301b085..c0f8db69e51 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2577,7 +2577,8 @@ list that represents a doc string reference.
2577 (when (memq sym byte-compile-lexical-variables) 2577 (when (memq sym byte-compile-lexical-variables)
2578 (setq byte-compile-lexical-variables 2578 (setq byte-compile-lexical-variables
2579 (delq sym byte-compile-lexical-variables)) 2579 (delq sym byte-compile-lexical-variables))
2580 (byte-compile-warn "Variable `%S' declared after its first use" sym)) 2580 (when (byte-compile-warning-enabled-p 'lexical sym)
2581 (byte-compile-warn "Variable `%S' declared after its first use" sym)))
2581 (push sym byte-compile-bound-variables) 2582 (push sym byte-compile-bound-variables)
2582 (push sym byte-compile--seen-defvars)) 2583 (push sym byte-compile--seen-defvars))
2583 2584
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 2e204ff7aea..76638ec13b1 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -241,7 +241,12 @@ system. Possible values are:
241 defun - Spell-check when style checking a single defun. 241 defun - Spell-check when style checking a single defun.
242 buffer - Spell-check when style checking the whole buffer. 242 buffer - Spell-check when style checking the whole buffer.
243 interactive - Spell-check during any interactive check. 243 interactive - Spell-check during any interactive check.
244 t - Always spell-check." 244 t - Always spell-check.
245
246There is a list of Lisp-specific words which checkdoc will
247install into Ispell on the fly, but only if Ispell is not already
248running. Use `ispell-kill-ispell' to make checkdoc restart it
249with these words enabled."
245 :type '(choice (const nil) 250 :type '(choice (const nil)
246 (const defun) 251 (const defun)
247 (const buffer) 252 (const buffer)
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 58517549454..fdbf95319ff 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil."
487Returns nil if they are." 487Returns nil if they are."
488 (if (not (eq (type-of a) (type-of b))) 488 (if (not (eq (type-of a) (type-of b)))
489 `(different-types ,a ,b) 489 `(different-types ,a ,b)
490 (pcase-exhaustive a 490 (pcase a
491 ((pred consp) 491 ((pred consp)
492 (let ((a-length (proper-list-p a)) 492 (let ((a-length (proper-list-p a))
493 (b-length (proper-list-p b))) 493 (b-length (proper-list-p b)))
@@ -538,7 +538,7 @@ Returns nil if they are."
538 for xi = (ert--explain-equal-rec ai bi) 538 for xi = (ert--explain-equal-rec ai bi)
539 do (when xi (cl-return `(array-elt ,i ,xi))) 539 do (when xi (cl-return `(array-elt ,i ,xi)))
540 finally (cl-assert (equal a b) t)))) 540 finally (cl-assert (equal a b) t))))
541 ((pred atom) 541 (_
542 (if (not (equal a b)) 542 (if (not (equal a b))
543 (if (and (symbolp a) (symbolp b) (string= a b)) 543 (if (and (symbolp a) (symbolp b) (string= a b))
544 `(different-symbols-with-the-same-name ,a ,b) 544 `(different-symbols-with-the-same-name ,a ,b)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 37844977f8f..aa49bccc8d0 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -127,7 +127,7 @@ and also to avoid outputting the warning during normal execution."
127 (cond 127 (cond
128 ((null msg) form) 128 ((null msg) form)
129 ((macroexp--compiling-p) 129 ((macroexp--compiling-p)
130 (if (gethash form macroexp--warned) 130 (if (and (consp form) (gethash form macroexp--warned))
131 ;; Already wrapped this exp with a warning: avoid inf-looping 131 ;; Already wrapped this exp with a warning: avoid inf-looping
132 ;; where we keep adding the same warning onto `form' because 132 ;; where we keep adding the same warning onto `form' because
133 ;; macroexpand-all gets right back to macroexpanding `form'. 133 ;; macroexpand-all gets right back to macroexpanding `form'.
@@ -138,9 +138,10 @@ and also to avoid outputting the warning during normal execution."
138 ,form))) 138 ,form)))
139 (t 139 (t
140 (unless compile-only 140 (unless compile-only
141 (message "%s%s" (if (stringp load-file-name) 141 (message "%sWarning: %s"
142 (concat (file-relative-name load-file-name) ": ") 142 (if (stringp load-file-name)
143 "") 143 (concat (file-relative-name load-file-name) ": ")
144 "")
144 msg)) 145 msg))
145 form)))) 146 form))))
146 147
@@ -180,8 +181,9 @@ and also to avoid outputting the warning during normal execution."
180 181
181(defun macroexp-macroexpand (form env) 182(defun macroexp-macroexpand (form env)
182 "Like `macroexpand' but checking obsolescence." 183 "Like `macroexpand' but checking obsolescence."
183 (let ((new-form 184 (let* ((macroexpand-all-environment env)
184 (macroexpand form env))) 185 (new-form
186 (macroexpand form env)))
185 (if (and (not (eq form new-form)) ;It was a macro call. 187 (if (and (not (eq form new-form)) ;It was a macro call.
186 (car-safe form) 188 (car-safe form)
187 (symbolp (car form)) 189 (symbolp (car form))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 125fbe09961..9f155bad394 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -3288,9 +3288,9 @@ To unhide a package, type
3288`\\[customize-variable] RET package-hidden-regexps'. 3288`\\[customize-variable] RET package-hidden-regexps'.
3289 3289
3290Type \\[package-menu-toggle-hiding] to toggle package hiding." 3290Type \\[package-menu-toggle-hiding] to toggle package hiding."
3291 (declare (interactive-only "change `package-hidden-regexps' instead."))
3291 (interactive) 3292 (interactive)
3292 (package--ensure-package-menu-mode) 3293 (package--ensure-package-menu-mode)
3293 (declare (interactive-only "change `package-hidden-regexps' instead."))
3294 (let* ((name (when (derived-mode-p 'package-menu-mode) 3294 (let* ((name (when (derived-mode-p 'package-menu-mode)
3295 (concat "\\`" (regexp-quote (symbol-name (package-desc-name 3295 (concat "\\`" (regexp-quote (symbol-name (package-desc-name
3296 (tabulated-list-get-id)))) 3296 (tabulated-list-get-id))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 72ea1ba0188..bfd577c5d14 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -39,10 +39,10 @@
39;; - along these lines, provide patterns to match CL structs. 39;; - along these lines, provide patterns to match CL structs.
40;; - provide something like (setq VAR) so a var can be set rather than 40;; - provide something like (setq VAR) so a var can be set rather than
41;; let-bound. 41;; let-bound.
42;; - provide a way to fallthrough to subsequent cases (not sure what I meant by 42;; - provide a way to fallthrough to subsequent cases
43;; this :-() 43;; (e.g. Like Racket's (=> ID).
44;; - try and be more clever to reduce the size of the decision tree, and 44;; - try and be more clever to reduce the size of the decision tree, and
45;; to reduce the number of leaves that need to be turned into function: 45;; to reduce the number of leaves that need to be turned into functions:
46;; - first, do the tests shared by all remaining branches (it will have 46;; - first, do the tests shared by all remaining branches (it will have
47;; to be performed anyway, so better do it first so it's shared). 47;; to be performed anyway, so better do it first so it's shared).
48;; - then choose the test that discriminates more (?). 48;; - then choose the test that discriminates more (?).
@@ -97,11 +97,15 @@
97(declare-function get-edebug-spec "edebug" (symbol)) 97(declare-function get-edebug-spec "edebug" (symbol))
98(declare-function edebug-match "edebug" (cursor specs)) 98(declare-function edebug-match "edebug" (cursor specs))
99 99
100(defun pcase--get-macroexpander (s)
101 "Return the macroexpander for pcase pattern head S, or nil"
102 (get s 'pcase-macroexpander))
103
100(defun pcase--edebug-match-macro (cursor) 104(defun pcase--edebug-match-macro (cursor)
101 (let (specs) 105 (let (specs)
102 (mapatoms 106 (mapatoms
103 (lambda (s) 107 (lambda (s)
104 (let ((m (get s 'pcase-macroexpander))) 108 (let ((m (pcase--get-macroexpander s)))
105 (when (and m (get-edebug-spec m)) 109 (when (and m (get-edebug-spec m))
106 (push (cons (symbol-name s) (get-edebug-spec m)) 110 (push (cons (symbol-name s) (get-edebug-spec m))
107 specs))))) 111 specs)))))
@@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms:
128 If a SYMBOL is used twice in the same pattern 132 If a SYMBOL is used twice in the same pattern
129 the second occurrence becomes an `eq'uality test. 133 the second occurrence becomes an `eq'uality test.
130 (pred FUN) matches if FUN called on EXPVAL returns non-nil. 134 (pred FUN) matches if FUN called on EXPVAL returns non-nil.
135 (pred (not FUN)) matches if FUN called on EXPVAL returns nil.
131 (app FUN PAT) matches if FUN called on EXPVAL matches PAT. 136 (app FUN PAT) matches if FUN called on EXPVAL matches PAT.
132 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. 137 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
133 (let PAT EXPR) matches if EXPR matches PAT. 138 (let PAT EXPR) matches if EXPR matches PAT.
@@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples."
193 (let (more) 198 (let (more)
194 ;; Collect all the extensions. 199 ;; Collect all the extensions.
195 (mapatoms (lambda (symbol) 200 (mapatoms (lambda (symbol)
196 (let ((me (get symbol 'pcase-macroexpander))) 201 (let ((me (pcase--get-macroexpander symbol)))
197 (when me 202 (when me
198 (push (cons symbol me) 203 (push (cons symbol me)
199 more))))) 204 more)))))
@@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'.
424 ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) 429 ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
425 ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) 430 ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
426 (t 431 (t
427 (let* ((expander (get head 'pcase-macroexpander)) 432 (let* ((expander (pcase--get-macroexpander head))
428 (npat (if expander (apply expander (cdr pat))))) 433 (npat (if expander (apply expander (cdr pat)))))
429 (if (null npat) 434 (if (null npat)
430 (error (if expander 435 (error (if expander
@@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form:
658 '(:pcase--succeed . nil)))) 663 '(:pcase--succeed . nil))))
659 664
660(defun pcase--split-pred (vars upat pat) 665(defun pcase--split-pred (vars upat pat)
666 "Indicate the overlap or mutual-exclusion between UPAT and PAT.
667More specifically retuns a pair (A . B) where A indicates whether PAT
668can match when UPAT has matched, and B does the same for the case
669where UPAT failed to match.
670A and B can be one of:
671- nil if we don't know
672- `:pcase--fail' if UPAT match's result implies that PAT can't match
673- `:pcase--succeed' if UPAT match's result implies that PAT matches"
661 (let (test) 674 (let (test)
662 (cond 675 (cond
663 ((and (equal upat pat) 676 ((and (equal upat pat)
@@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form:
670 ;; and catch at least the easy cases such as (bug#14773). 683 ;; and catch at least the easy cases such as (bug#14773).
671 (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) 684 (not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
672 '(:pcase--succeed . :pcase--fail)) 685 '(:pcase--succeed . :pcase--fail))
686 ;; In case UPAT is of the form (pred (not PRED))
687 ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
688 (let* ((test (cadr (cadr upat)))
689 (res (pcase--split-pred vars `(pred ,test) pat)))
690 (cons (cdr res) (car res))))
691 ;; In case PAT is of the form (pred (not PRED))
692 ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
693 (let* ((test (cadr (cadr pat)))
694 (res (pcase--split-pred vars upat `(pred ,test)))
695 (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail)
696 ((eq x :pcase--fail) :pcase--succeed)))))
697 (cons (funcall reverse (car res))
698 (funcall reverse (cdr res)))))
673 ((and (eq 'pred (car upat)) 699 ((and (eq 'pred (car upat))
674 (let ((otherpred 700 (let ((otherpred
675 (cond ((eq 'pred (car-safe pat)) (cadr pat)) 701 (cond ((eq 'pred (car-safe pat)) (cadr pat))
@@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form:
728 754
729(defun pcase--funcall (fun arg vars) 755(defun pcase--funcall (fun arg vars)
730 "Build a function call to FUN with arg ARG." 756 "Build a function call to FUN with arg ARG."
731 (if (symbolp fun) 757 (cond
732 `(,fun ,arg) 758 ((symbolp fun) `(,fun ,arg))
759 ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars)))
760 (t
733 (let* (;; `env' is an upper bound on the bindings we need. 761 (let* (;; `env' is an upper bound on the bindings we need.
734 (env (mapcar (lambda (x) (list (car x) (cdr x))) 762 (env (mapcar (lambda (x) (list (car x) (cdr x)))
735 (macroexp--fgrep vars fun))) 763 (macroexp--fgrep vars fun)))
@@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form:
747 ;; Let's not replace `vars' in `fun' since it's 775 ;; Let's not replace `vars' in `fun' since it's
748 ;; too difficult to do it right, instead just 776 ;; too difficult to do it right, instead just
749 ;; let-bind `vars' around `fun'. 777 ;; let-bind `vars' around `fun'.
750 `(let* ,env ,call))))) 778 `(let* ,env ,call))))))
751 779
752(defun pcase--eval (exp vars) 780(defun pcase--eval (exp vars)
753 "Build an expression that will evaluate EXP." 781 "Build an expression that will evaluate EXP."
diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el
index 6a483a6d498..0905ac608bb 100644
--- a/lisp/emacs-lisp/radix-tree.el
+++ b/lisp/emacs-lisp/radix-tree.el
@@ -198,9 +198,10 @@ If not found, return nil."
198 (pcase-defmacro radix-tree-leaf (vpat) 198 (pcase-defmacro radix-tree-leaf (vpat)
199 "Pattern which matches a radix-tree leaf. 199 "Pattern which matches a radix-tree leaf.
200The pattern VPAT is matched against the leaf's carried value." 200The pattern VPAT is matched against the leaf's carried value."
201 ;; FIXME: We'd like to use a negative pattern (not consp), but pcase 201 ;; We used to use `(pred atom)', but `pcase' doesn't understand that
202 ;; doesn't support it. Using `atom' works but generates sub-optimal code. 202 ;; `atom' is equivalent to the negation of `consp' and hence generates
203 `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) 203 ;; suboptimal code.
204 `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat))))
204 205
205(defun radix-tree-iter-subtrees (tree fun) 206(defun radix-tree-iter-subtrees (tree fun)
206 "Apply FUN to every immediate subtree of radix TREE. 207 "Apply FUN to every immediate subtree of radix TREE.
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index b90227da42f..a4514454c0b 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -389,6 +389,28 @@ it makes no sense to convert it to a string using
389 (set-buffer source-buffer) 389 (set-buffer source-buffer)
390 (replace-buffer-contents tmp-buffer max-secs max-costs))))))))) 390 (replace-buffer-contents tmp-buffer max-secs max-costs)))))))))
391 391
392(defmacro named-let (name bindings &rest body)
393 "Looping construct taken from Scheme.
394Like `let', bind variables in BINDINGS and then evaluate BODY,
395but with the twist that BODY can evaluate itself recursively by
396calling NAME, where the arguments passed to NAME are used
397as the new values of the bound variables in the recursive invocation."
398 (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
399 (require 'cl-lib)
400 (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))
401 (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)))
402 ;; According to the Scheme semantics of named let, `name' is not in scope
403 ;; while evaluating the expressions in `bindings', and for this reason, the
404 ;; "initial" function call below needs to be outside of the `cl-labels'.
405 ;; When the "self-tco" eliminates all recursive calls, the `cl-labels'
406 ;; expands to a lambda which the byte-compiler then combines with the
407 ;; funcall to make a `let' so we end up with a plain `while' loop and no
408 ;; remaining `lambda' at all.
409 `(funcall
410 (cl-labels ((,name ,fargs . ,body)) #',name)
411 . ,aargs)))
412
413
392(provide 'subr-x) 414(provide 'subr-x)
393 415
394;;; subr-x.el ends here 416;;; subr-x.el ends here
diff --git a/lisp/emulation/cua-gmrk.el b/lisp/emulation/cua-gmrk.el
index 195bba1f317..6f6b9fce130 100644
--- a/lisp/emulation/cua-gmrk.el
+++ b/lisp/emulation/cua-gmrk.el
@@ -87,9 +87,11 @@
87 87
88(defun cua-toggle-global-mark (stay) 88(defun cua-toggle-global-mark (stay)
89 "Set or cancel the global marker. 89 "Set or cancel the global marker.
90When the global marker is set, CUA cut and copy commands will automatically 90When the global marker is set, CUA cut and copy commands will
91insert the deleted or copied text before the global marker, even when the 91automatically insert the inserted, deleted or copied text before
92global marker is in another buffer. 92the global marker, even when the global marker is in another
93buffer.
94
93If the global marker isn't set, set the global marker at point in the current 95If the global marker isn't set, set the global marker at point in the current
94buffer. Otherwise jump to the global marker position and cancel it. 96buffer. Otherwise jump to the global marker position and cancel it.
95With prefix argument, don't jump to global mark when canceling it." 97With prefix argument, don't jump to global mark when canceling it."
diff --git a/lisp/epa.el b/lisp/epa.el
index db2b1271473..197cd92f977 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -359,8 +359,8 @@ DOC is documentation text to insert at the start."
359 359
360 ;; Find the end of the documentation text at the start. 360 ;; Find the end of the documentation text at the start.
361 ;; Set POINT to where it ends, or nil if ends at eob. 361 ;; Set POINT to where it ends, or nil if ends at eob.
362 (unless (get-text-property point 'epa-list-keys) 362 (unless (get-text-property point 'epa-key)
363 (setq point (next-single-property-change point 'epa-list-keys))) 363 (setq point (next-single-property-change point 'epa-key)))
364 364
365 ;; If caller specified documentation text for that, replace the old 365 ;; If caller specified documentation text for that, replace the old
366 ;; documentation text (if any) with what was specified. 366 ;; documentation text (if any) with what was specified.
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 2609397b0d9..dc5f8f46aba 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -606,9 +606,14 @@ color. The function should accept a single argument, the color name."
606 606
607(defun list-colors-print (list &optional callback) 607(defun list-colors-print (list &optional callback)
608 (let ((callback-fn 608 (let ((callback-fn
609 (if callback 609 ;; Expect CALLBACK to be a function, but allow it to be a form that
610 `(lambda (button) 610 ;; evaluates to a function, for backward-compatibility. (Bug#45831)
611 (funcall ,callback (button-get button 'color-name)))))) 611 (cond ((functionp callback)
612 (lambda (button)
613 (funcall callback (button-get button 'color-name))))
614 (callback
615 `(lambda (button)
616 (funcall ,callback (button-get button 'color-name)))))))
612 (dolist (color list) 617 (dolist (color list)
613 (if (consp color) 618 (if (consp color)
614 (if (cdr color) 619 (if (cdr color)
diff --git a/lisp/faces.el b/lisp/faces.el
index 4e98338432f..d654b1f0e2a 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -2199,7 +2199,7 @@ the above example."
2199 (not (funcall pred type))) 2199 (not (funcall pred type)))
2200 ;; Strip off last hyphen and what follows, then try again 2200 ;; Strip off last hyphen and what follows, then try again
2201 (setq type 2201 (setq type
2202 (if (setq hyphend (string-match-p "[-_][^-_]+$" type)) 2202 (if (setq hyphend (string-match-p "[-_.][^-_.]+$" type))
2203 (substring type 0 hyphend) 2203 (substring type 0 hyphend)
2204 nil)))) 2204 nil))))
2205 type) 2205 type)
diff --git a/lisp/files.el b/lisp/files.el
index 695afae8c56..e9be7c7e75c 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -4067,7 +4067,7 @@ Return the new variables list."
4067 (subdirs (assq 'subdirs alist))) 4067 (subdirs (assq 'subdirs alist)))
4068 (if (or (not subdirs) 4068 (if (or (not subdirs)
4069 (progn 4069 (progn
4070 (setq alist (delq subdirs alist)) 4070 (setq alist (remq subdirs alist))
4071 (cdr-safe subdirs)) 4071 (cdr-safe subdirs))
4072 ;; TODO someone might want to extend this to allow 4072 ;; TODO someone might want to extend this to allow
4073 ;; integer values for subdir, where N means 4073 ;; integer values for subdir, where N means
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index a51434c38c9..a9fc69d419a 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1104,8 +1104,8 @@ Called with two arguments BEG and END.")
1104 "Reinitialize the font-lock machinery and (re-)fontify the buffer. 1104 "Reinitialize the font-lock machinery and (re-)fontify the buffer.
1105This functions is a convenience functions when developing font 1105This functions is a convenience functions when developing font
1106locking for a mode, and is not meant to be called from lisp functions." 1106locking for a mode, and is not meant to be called from lisp functions."
1107 (interactive)
1108 (declare (interactive-only t)) 1107 (declare (interactive-only t))
1108 (interactive)
1109 ;; Make font-lock recalculate all the mode-specific data. 1109 ;; Make font-lock recalculate all the mode-specific data.
1110 (setq font-lock-major-mode nil) 1110 (setq font-lock-major-mode nil)
1111 ;; Make the syntax machinery discard all information. 1111 ;; Make the syntax machinery discard all information.
diff --git a/lisp/frame.el b/lisp/frame.el
index e2d7f21a498..06aab269ddd 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -2552,13 +2552,15 @@ Use 0 or negative value to blink forever."
2552This starts the timer `blink-cursor-timer', which makes the cursor blink 2552This starts the timer `blink-cursor-timer', which makes the cursor blink
2553if appropriate. It also arranges to cancel that timer when the next 2553if appropriate. It also arranges to cancel that timer when the next
2554command starts, by installing a pre-command hook." 2554command starts, by installing a pre-command hook."
2555 (when (null blink-cursor-timer) 2555 (cond
2556 ((null blink-cursor-mode) (blink-cursor-mode -1))
2557 ((null blink-cursor-timer)
2556 ;; Set up the timer first, so that if this signals an error, 2558 ;; Set up the timer first, so that if this signals an error,
2557 ;; blink-cursor-end is not added to pre-command-hook. 2559 ;; blink-cursor-end is not added to pre-command-hook.
2558 (setq blink-cursor-blinks-done 1) 2560 (setq blink-cursor-blinks-done 1)
2559 (blink-cursor--start-timer) 2561 (blink-cursor--start-timer)
2560 (add-hook 'pre-command-hook #'blink-cursor-end) 2562 (add-hook 'pre-command-hook #'blink-cursor-end)
2561 (internal-show-cursor nil nil))) 2563 (internal-show-cursor nil nil))))
2562 2564
2563(defun blink-cursor-timer-function () 2565(defun blink-cursor-timer-function ()
2564 "Timer function of timer `blink-cursor-timer'." 2566 "Timer function of timer `blink-cursor-timer'."
@@ -2615,7 +2617,7 @@ stopped by `blink-cursor-suspend'. Internally calls
2615`blink-cursor--should-blink' and returns its result." 2617`blink-cursor--should-blink' and returns its result."
2616 (let ((should-blink (blink-cursor--should-blink))) 2618 (let ((should-blink (blink-cursor--should-blink)))
2617 (when (and should-blink (not blink-cursor-idle-timer)) 2619 (when (and should-blink (not blink-cursor-idle-timer))
2618 (remove-hook 'post-command-hook 'blink-cursor-check) 2620 (remove-hook 'post-command-hook #'blink-cursor-check)
2619 (blink-cursor--start-idle-timer)) 2621 (blink-cursor--start-idle-timer))
2620 should-blink)) 2622 should-blink))
2621 2623
@@ -2637,16 +2639,16 @@ This command is effective only on graphical frames. On text-only
2637terminals, cursor blinking is controlled by the terminal." 2639terminals, cursor blinking is controlled by the terminal."
2638 :init-value (not (or noninteractive 2640 :init-value (not (or noninteractive
2639 no-blinking-cursor 2641 no-blinking-cursor
2640 (eq system-type 'ms-dos) 2642 (eq system-type 'ms-dos)))
2641 (not (display-blink-cursor-p)))) 2643 :initialize #'custom-initialize-delay
2642 :initialize 'custom-initialize-delay
2643 :group 'cursor 2644 :group 'cursor
2644 :global t 2645 :global t
2645 (blink-cursor-suspend) 2646 (blink-cursor-suspend)
2646 (remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) 2647 (remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
2647 (remove-function after-focus-change-function #'blink-cursor--rescan-frames) 2648 (remove-function after-focus-change-function #'blink-cursor--rescan-frames)
2648 (when blink-cursor-mode 2649 (when blink-cursor-mode
2649 (add-function :after after-focus-change-function #'blink-cursor--rescan-frames) 2650 (add-function :after after-focus-change-function
2651 #'blink-cursor--rescan-frames)
2650 (add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) 2652 (add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
2651 (blink-cursor-check))) 2653 (blink-cursor-check)))
2652 2654
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index 56640ea8302..686623029ed 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -1789,6 +1789,7 @@ variables. Returns the first non-nil value found."
1789 . gnus-agent-enable-expiration) 1789 . gnus-agent-enable-expiration)
1790 (agent-predicate . gnus-agent-predicate))))))) 1790 (agent-predicate . gnus-agent-predicate)))))))
1791 1791
1792;; FIXME: This looks an awful lot like `gnus-agent-retrieve-headers'.
1792(defun gnus-agent-fetch-headers (group) 1793(defun gnus-agent-fetch-headers (group)
1793 "Fetch interesting headers into the agent. The group's overview 1794 "Fetch interesting headers into the agent. The group's overview
1794file will be updated to include the headers while a list of available 1795file will be updated to include the headers while a list of available
@@ -1810,10 +1811,9 @@ article numbers will be returned."
1810 (cdr active)))) 1811 (cdr active))))
1811 (gnus-uncompress-range (gnus-active group))) 1812 (gnus-uncompress-range (gnus-active group)))
1812 (gnus-list-of-unread-articles group))) 1813 (gnus-list-of-unread-articles group)))
1813 (gnus-decode-encoded-word-function 'identity)
1814 (gnus-decode-encoded-address-function 'identity)
1815 (file (gnus-agent-article-name ".overview" group)) 1814 (file (gnus-agent-article-name ".overview" group))
1816 (file-name-coding-system nnmail-pathname-coding-system)) 1815 (file-name-coding-system nnmail-pathname-coding-system)
1816 headers fetched-headers)
1817 1817
1818 (unless fetch-all 1818 (unless fetch-all
1819 ;; Add articles with marks to the list of article headers we want to 1819 ;; Add articles with marks to the list of article headers we want to
@@ -1824,7 +1824,7 @@ article numbers will be returned."
1824 (dolist (arts (gnus-info-marks (gnus-get-info group))) 1824 (dolist (arts (gnus-info-marks (gnus-get-info group)))
1825 (unless (memq (car arts) '(seen recent killed cache)) 1825 (unless (memq (car arts) '(seen recent killed cache))
1826 (setq articles (gnus-range-add articles (cdr arts))))) 1826 (setq articles (gnus-range-add articles (cdr arts)))))
1827 (setq articles (sort (gnus-uncompress-sequence articles) '<))) 1827 (setq articles (sort (gnus-uncompress-range articles) '<)))
1828 1828
1829 ;; At this point, I have the list of articles to consider for 1829 ;; At this point, I have the list of articles to consider for
1830 ;; fetching. This is the list that I'll return to my caller. Some 1830 ;; fetching. This is the list that I'll return to my caller. Some
@@ -1867,38 +1867,52 @@ article numbers will be returned."
1867 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" 1867 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'"
1868 (gnus-compress-sequence articles t))) 1868 (gnus-compress-sequence articles t)))
1869 1869
1870 (with-current-buffer nntp-server-buffer 1870 ;; Parse known headers from FILE.
1871 (if articles 1871 (if (file-exists-p file)
1872 (progn 1872 (with-current-buffer gnus-agent-overview-buffer
1873 (gnus-message 8 "Fetching headers for %s..." group) 1873 (erase-buffer)
1874 1874 (let ((nnheader-file-coding-system
1875 ;; Fetch them. 1875 gnus-agent-file-coding-system))
1876 (gnus-make-directory (nnheader-translate-file-chars 1876 (nnheader-insert-nov-file file (car articles))
1877 (file-name-directory file) t)) 1877 (with-current-buffer nntp-server-buffer
1878 1878 (erase-buffer)
1879 (unless (eq 'nov (gnus-retrieve-headers articles group)) 1879 (insert-buffer-substring gnus-agent-overview-buffer)
1880 (nnvirtual-convert-headers)) 1880 (setq headers
1881 (gnus-agent-check-overview-buffer) 1881 (gnus-get-newsgroup-headers-xover
1882 ;; Move these headers to the overview buffer so that 1882 articles nil (buffer-local-value
1883 ;; gnus-agent-braid-nov can merge them with the contents 1883 'gnus-newsgroup-dependencies
1884 ;; of FILE. 1884 gnus-summary-buffer)
1885 (copy-to-buffer 1885 gnus-newsgroup-name)))))
1886 gnus-agent-overview-buffer (point-min) (point-max)) 1886 (gnus-make-directory (nnheader-translate-file-chars
1887 ;; NOTE: Call g-a-brand-nov even when the file does not 1887 (file-name-directory file) t)))
1888 ;; exist. As a minimum, it will validate the article 1888
1889 ;; numbers already in the buffer. 1889 ;; Fetch our new headers.
1890 (gnus-agent-braid-nov articles file) 1890 (gnus-message 8 "Fetching headers for %s..." group)
1891 (let ((coding-system-for-write 1891 (if articles
1892 gnus-agent-file-coding-system)) 1892 (setq fetched-headers (gnus-fetch-headers articles)))
1893 (gnus-agent-check-overview-buffer) 1893
1894 (write-region (point-min) (point-max) file nil 'silent)) 1894 ;; Merge two sets of headers.
1895 (gnus-agent-update-view-total-fetched-for group t) 1895 (setq headers
1896 (gnus-agent-save-alist group articles nil) 1896 (if (and headers fetched-headers)
1897 articles) 1897 (delete-dups
1898 (ignore-errors 1898 (sort (append headers (copy-sequence fetched-headers))
1899 (erase-buffer) 1899 (lambda (l r)
1900 (nnheader-insert-file-contents file))))) 1900 (< (mail-header-number l)
1901 articles)) 1901 (mail-header-number r)))))
1902 (or headers fetched-headers)))
1903
1904 ;; Save the new set of headers to FILE.
1905 (let ((coding-system-for-write
1906 gnus-agent-file-coding-system))
1907 (with-current-buffer gnus-agent-overview-buffer
1908 (goto-char (point-max))
1909 (mapc #'nnheader-insert-nov fetched-headers)
1910 (sort-numeric-fields 1 (point-min) (point-max))
1911 (gnus-agent-check-overview-buffer)
1912 (write-region (point-min) (point-max) file nil 'silent))
1913 (gnus-agent-update-view-total-fetched-for group t)
1914 (gnus-agent-save-alist group articles nil)))
1915 headers))
1902 1916
1903(defsubst gnus-agent-read-article-number () 1917(defsubst gnus-agent-read-article-number ()
1904 "Read the article number at point. 1918 "Read the article number at point.
@@ -1924,96 +1938,6 @@ Return nil when a valid article number can not be read."
1924 (set-buffer nntp-server-buffer) 1938 (set-buffer nntp-server-buffer)
1925 (insert-buffer-substring gnus-agent-overview-buffer b e)))) 1939 (insert-buffer-substring gnus-agent-overview-buffer b e))))
1926 1940
1927(defun gnus-agent-braid-nov (articles file)
1928 "Merge agent overview data with given file.
1929Takes unvalidated headers for ARTICLES from
1930`gnus-agent-overview-buffer' and validated headers from the given
1931FILE and places the combined valid headers into
1932`nntp-server-buffer'. This function can be used, when file
1933doesn't exist, to valid the overview buffer."
1934 (let (start last)
1935 (set-buffer gnus-agent-overview-buffer)
1936 (goto-char (point-min))
1937 (set-buffer nntp-server-buffer)
1938 (erase-buffer)
1939 (when (file-exists-p file)
1940 (nnheader-insert-file-contents file))
1941 (goto-char (point-max))
1942 (forward-line -1)
1943
1944 (unless (or (= (point-min) (point-max))
1945 (< (setq last (read (current-buffer))) (car articles)))
1946 ;; Old and new overlap -- We do it the hard way.
1947 (when (nnheader-find-nov-line (car articles))
1948 ;; Replacing existing NOV entry
1949 (delete-region (point) (progn (forward-line 1) (point))))
1950 (gnus-agent-copy-nov-line (pop articles))
1951
1952 (ignore-errors
1953 (while articles
1954 (while (let ((art (read (current-buffer))))
1955 (cond ((< art (car articles))
1956 (forward-line 1)
1957 t)
1958 ((= art (car articles))
1959 (beginning-of-line)
1960 (delete-region
1961 (point) (progn (forward-line 1) (point)))
1962 nil)
1963 (t
1964 (beginning-of-line)
1965 nil))))
1966
1967 (gnus-agent-copy-nov-line (pop articles)))))
1968
1969 (goto-char (point-max))
1970
1971 ;; Append the remaining lines
1972 (when articles
1973 (when last
1974 (set-buffer gnus-agent-overview-buffer)
1975 (setq start (point))
1976 (set-buffer nntp-server-buffer))
1977
1978 (let ((p (point)))
1979 (insert-buffer-substring gnus-agent-overview-buffer start)
1980 (goto-char p))
1981
1982 (setq last (or last -134217728))
1983 (while (catch 'problems
1984 (let (sort art)
1985 (while (not (eobp))
1986 (setq art (gnus-agent-read-article-number))
1987 (cond ((not art)
1988 ;; Bad art num - delete this line
1989 (beginning-of-line)
1990 (delete-region (point) (progn (forward-line 1) (point))))
1991 ((< art last)
1992 ;; Art num out of order - enable sort
1993 (setq sort t)
1994 (forward-line 1))
1995 ((= art last)
1996 ;; Bad repeat of art number - delete this line
1997 (beginning-of-line)
1998 (delete-region (point) (progn (forward-line 1) (point))))
1999 (t
2000 ;; Good art num
2001 (setq last art)
2002 (forward-line 1))))
2003 (when sort
2004 ;; something is seriously wrong as we simply shouldn't see out-of-order data.
2005 ;; First, we'll fix the sort.
2006 (sort-numeric-fields 1 (point-min) (point-max))
2007
2008 ;; but now we have to consider that we may have duplicate rows...
2009 ;; so reset to beginning of file
2010 (goto-char (point-min))
2011 (setq last -134217728)
2012
2013 ;; and throw a code that restarts this scan
2014 (throw 'problems t))
2015 nil))))))
2016
2017;; Keeps the compiler from warning about the free variable in 1941;; Keeps the compiler from warning about the free variable in
2018;; gnus-agent-read-agentview. 1942;; gnus-agent-read-agentview.
2019(defvar gnus-agent-read-agentview) 1943(defvar gnus-agent-read-agentview)
@@ -2386,10 +2310,9 @@ modified) original contents, they are first saved to their own file."
2386 (gnus-orphan-score gnus-orphan-score) 2310 (gnus-orphan-score gnus-orphan-score)
2387 ;; Maybe some other gnus-summary local variables should also 2311 ;; Maybe some other gnus-summary local variables should also
2388 ;; be put here. 2312 ;; be put here.
2389 2313 fetched-headers
2390 gnus-headers 2314 gnus-headers
2391 gnus-score 2315 gnus-score
2392 articles
2393 predicate info marks 2316 predicate info marks
2394 ) 2317 )
2395 (unless (gnus-check-group group) 2318 (unless (gnus-check-group group)
@@ -2410,38 +2333,35 @@ modified) original contents, they are first saved to their own file."
2410 (setq info (gnus-get-info group))))))) 2333 (setq info (gnus-get-info group)))))))
2411 (when arts 2334 (when arts
2412 (setq marked-articles (nconc (gnus-uncompress-range arts) 2335 (setq marked-articles (nconc (gnus-uncompress-range arts)
2413 marked-articles)) 2336 marked-articles))))))
2414 ))))
2415 (setq marked-articles (sort marked-articles '<)) 2337 (setq marked-articles (sort marked-articles '<))
2416 2338
2417 ;; Fetch any new articles from the server 2339 (setq gnus-newsgroup-dependencies
2418 (setq articles (gnus-agent-fetch-headers group)) 2340 (or gnus-newsgroup-dependencies
2341 (gnus-make-hashtable)))
2419 2342
2420 ;; Merge new articles with marked 2343 ;; Fetch headers for any new articles from the server.
2421 (setq articles (sort (append marked-articles articles) '<)) 2344 (setq fetched-headers (gnus-agent-fetch-headers group))
2422 2345
2423 (when articles 2346 (when fetched-headers
2424 ;; Parse them and see which articles we want to fetch.
2425 (setq gnus-newsgroup-dependencies
2426 (or gnus-newsgroup-dependencies
2427 (gnus-make-hashtable (length articles))))
2428 (setq gnus-newsgroup-headers 2347 (setq gnus-newsgroup-headers
2429 (or gnus-newsgroup-headers 2348 (or gnus-newsgroup-headers
2430 (gnus-get-newsgroup-headers-xover articles nil nil 2349 fetched-headers)))
2431 group))) 2350 (when marked-articles
2432 ;; `gnus-agent-overview-buffer' may be killed for 2351 ;; `gnus-agent-overview-buffer' may be killed for timeout
2433 ;; timeout reason. If so, recreate it. 2352 ;; reason. If so, recreate it.
2434 (gnus-agent-create-buffer) 2353 (gnus-agent-create-buffer)
2435 2354
2436 (setq predicate 2355 (setq predicate
2437 (gnus-get-predicate 2356 (gnus-get-predicate
2438 (gnus-agent-find-parameter group 'agent-predicate))) 2357 (gnus-agent-find-parameter group 'agent-predicate)))
2358
2359 ;; If the selection predicate requires scoring, score each header.
2439 2360
2440 ;; If the selection predicate requires scoring, score each header
2441 (unless (memq predicate '(gnus-agent-true gnus-agent-false)) 2361 (unless (memq predicate '(gnus-agent-true gnus-agent-false))
2442 (let ((score-param 2362 (let ((score-param
2443 (gnus-agent-find-parameter group 'agent-score-file))) 2363 (gnus-agent-find-parameter group 'agent-score-file)))
2444 ;; Translate score-param into real one 2364 ;; Translate score-param into real one.
2445 (cond 2365 (cond
2446 ((not score-param)) 2366 ((not score-param))
2447 ((eq score-param 'file) 2367 ((eq score-param 'file)
@@ -3661,11 +3581,9 @@ has been fetched."
3661(defun gnus-agent-retrieve-headers (articles group &optional fetch-old) 3581(defun gnus-agent-retrieve-headers (articles group &optional fetch-old)
3662 (save-excursion 3582 (save-excursion
3663 (gnus-agent-create-buffer) 3583 (gnus-agent-create-buffer)
3664 (let ((gnus-decode-encoded-word-function 'identity) 3584 (let ((file (gnus-agent-article-name ".overview" group))
3665 (gnus-decode-encoded-address-function 'identity) 3585 (file-name-coding-system nnmail-pathname-coding-system)
3666 (file (gnus-agent-article-name ".overview" group)) 3586 uncached-articles headers fetched-headers)
3667 uncached-articles
3668 (file-name-coding-system nnmail-pathname-coding-system))
3669 (gnus-make-directory (nnheader-translate-file-chars 3587 (gnus-make-directory (nnheader-translate-file-chars
3670 (file-name-directory file) t)) 3588 (file-name-directory file) t))
3671 3589
@@ -3676,122 +3594,63 @@ has been fetched."
3676 1) 3594 1)
3677 (car (last articles)))))) 3595 (car (last articles))))))
3678 3596
3679 ;; Populate temp buffer with known headers 3597 ;; See if we've got cached headers for ARTICLES and put them in
3598 ;; HEADERS. Articles with no cached headers go in
3599 ;; UNCACHED-ARTICLES to be fetched from the server.
3680 (when (file-exists-p file) 3600 (when (file-exists-p file)
3681 (with-current-buffer gnus-agent-overview-buffer 3601 (with-current-buffer gnus-agent-overview-buffer
3682 (erase-buffer) 3602 (erase-buffer)
3683 (let ((nnheader-file-coding-system 3603 (let ((nnheader-file-coding-system
3684 gnus-agent-file-coding-system)) 3604 gnus-agent-file-coding-system))
3685 (nnheader-insert-nov-file file (car articles))))) 3605 (nnheader-insert-nov-file file (car articles))
3686 3606 (with-current-buffer nntp-server-buffer
3687 (if (setq uncached-articles (gnus-agent-uncached-articles articles group 3607 (erase-buffer)
3688 t)) 3608 (insert-buffer-substring gnus-agent-overview-buffer)
3689 (progn 3609 (setq headers
3690 ;; Populate nntp-server-buffer with uncached headers 3610 (gnus-get-newsgroup-headers-xover
3691 (set-buffer nntp-server-buffer) 3611 articles nil (buffer-local-value
3692 (erase-buffer) 3612 'gnus-newsgroup-dependencies
3693 (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent 3613 gnus-summary-buffer)
3694 (gnus-retrieve-headers 3614 gnus-newsgroup-name))))))
3695 uncached-articles group)))) 3615
3696 (nnvirtual-convert-headers)) 3616 (setq uncached-articles
3697 ((eq 'nntp (car gnus-current-select-method)) 3617 (gnus-agent-uncached-articles articles group t))
3698 ;; The author of gnus-get-newsgroup-headers-xover 3618
3699 ;; reports that the XOVER command is commonly 3619 (when uncached-articles
3700 ;; unreliable. The problem is that recently 3620 (let ((gnus-newsgroup-name group)
3701 ;; posted articles may not be entered into the 3621 gnus-agent) ; Prevent loop.
3702 ;; NOV database in time to respond to my XOVER 3622 ;; Fetch additional headers for the uncached articles.
3703 ;; query. 3623 (setq fetched-headers (gnus-fetch-headers uncached-articles))
3704 ;; 3624 ;; Merge headers we got from the overview file with our
3705 ;; I'm going to use his assumption that the NOV 3625 ;; newly-fetched headers.
3706 ;; database is updated in order of ascending 3626 (when fetched-headers
3707 ;; article ID. Therefore, a response containing 3627 (setq headers
3708 ;; article ID N implies that all articles from 1 3628 (delete-dups
3709 ;; to N-1 are up-to-date. Therefore, missing 3629 (sort (append headers (copy-sequence fetched-headers))
3710 ;; articles in that range have expired. 3630 (lambda (l r)
3711 3631 (< (mail-header-number l)
3712 (set-buffer nntp-server-buffer) 3632 (mail-header-number r))))))
3713 (let* ((fetched-articles (list nil)) 3633
3714 (tail-fetched-articles fetched-articles) 3634 ;; Add the new set of known headers to the overview file.
3715 (min (car articles))
3716 (max (car (last articles))))
3717
3718 ;; Get the list of articles that were fetched
3719 (goto-char (point-min))
3720 (let ((pm (point-max))
3721 art)
3722 (while (< (point) pm)
3723 (when (setq art (gnus-agent-read-article-number))
3724 (gnus-agent-append-to-list tail-fetched-articles art))
3725 (forward-line 1)))
3726
3727 ;; Clip this list to the headers that will
3728 ;; actually be returned
3729 (setq fetched-articles (gnus-list-range-intersection
3730 (cdr fetched-articles)
3731 (cons min max)))
3732
3733 ;; Clip the uncached articles list to exclude
3734 ;; IDs after the last FETCHED header. The
3735 ;; excluded IDs may be fetchable using HEAD.
3736 (if (car tail-fetched-articles)
3737 (setq uncached-articles
3738 (gnus-list-range-intersection
3739 uncached-articles
3740 (cons (car uncached-articles)
3741 (car tail-fetched-articles)))))
3742
3743 ;; Create the list of articles that were
3744 ;; "successfully" fetched. Success, in this
3745 ;; case, means that the ID should not be
3746 ;; fetched again. In the case of an expired
3747 ;; article, the header will not be fetched.
3748 (setq uncached-articles
3749 (gnus-sorted-nunion fetched-articles
3750 uncached-articles))
3751 )))
3752
3753 ;; Erase the temp buffer
3754 (set-buffer gnus-agent-overview-buffer)
3755 (erase-buffer)
3756
3757 ;; Copy the nntp-server-buffer to the temp buffer
3758 (set-buffer nntp-server-buffer)
3759 (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
3760
3761 ;; Merge the temp buffer with the known headers (found on
3762 ;; disk in FILE) into the nntp-server-buffer
3763 (when uncached-articles
3764 (gnus-agent-braid-nov uncached-articles file))
3765
3766 ;; Save the new set of known headers to FILE
3767 (set-buffer nntp-server-buffer)
3768 (let ((coding-system-for-write 3635 (let ((coding-system-for-write
3769 gnus-agent-file-coding-system)) 3636 gnus-agent-file-coding-system))
3770 (gnus-agent-check-overview-buffer) 3637 (with-current-buffer gnus-agent-overview-buffer
3771 (write-region (point-min) (point-max) file nil 'silent)) 3638 ;; We stick the new headers in at the end, then
3772 3639 ;; re-sort the whole buffer with
3773 (gnus-agent-update-view-total-fetched-for group t) 3640 ;; `sort-numeric-fields'. If this turns out to be
3774 3641 ;; slow, we could consider a loop to add the headers
3775 ;; Update the group's article alist to include the newly 3642 ;; in sorted order to begin with.
3776 ;; fetched articles. 3643 (goto-char (point-max))
3777 (gnus-agent-load-alist group) 3644 (mapc #'nnheader-insert-nov fetched-headers)
3778 (gnus-agent-save-alist group uncached-articles nil) 3645 (sort-numeric-fields 1 (point-min) (point-max))
3779 ) 3646 (gnus-agent-check-overview-buffer)
3780 3647 (write-region (point-min) (point-max) file nil 'silent)
3781 ;; Copy the temp buffer to the nntp-server-buffer 3648 (gnus-agent-update-view-total-fetched-for group t)
3782 (set-buffer nntp-server-buffer) 3649 ;; Update the group's article alist to include the
3783 (erase-buffer) 3650 ;; newly fetched articles.
3784 (insert-buffer-substring gnus-agent-overview-buffer))) 3651 (gnus-agent-load-alist group)
3785 3652 (gnus-agent-save-alist group uncached-articles nil))))))
3786 (if (and fetch-old 3653 headers)))
3787 (not (numberp fetch-old)))
3788 t ; Don't remove anything.
3789 (nnheader-nov-delete-outside-range
3790 (car articles)
3791 (car (last articles)))
3792 t)
3793
3794 'nov))
3795 3654
3796(defun gnus-agent-request-article (article group) 3655(defun gnus-agent-request-article (article group)
3797 "Retrieve ARTICLE in GROUP from the agent cache." 3656 "Retrieve ARTICLE in GROUP from the agent cache."
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el
index fefd02c7bfb..ed948a26c0b 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -357,8 +357,13 @@ that was fetched."
357 (let ((nntp-server-buffer (current-buffer)) 357 (let ((nntp-server-buffer (current-buffer))
358 (nnheader-callback-function 358 (nnheader-callback-function
359 (lambda (_arg) 359 (lambda (_arg)
360 (setq gnus-async-header-prefetched 360 (setq gnus-async-header-prefetched
361 (cons group unread))))) 361 (cons group unread)))))
362 ;; FIXME: If header prefetch is ever put into use, we'll
363 ;; have to handle the possibility that
364 ;; `gnus-retrieve-headers' might return a list of header
365 ;; vectors directly, rather than writing them into the
366 ;; current buffer.
362 (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) 367 (gnus-retrieve-headers unread group gnus-fetch-old-headers))))))
363 368
364(defun gnus-async-retrieve-fetched-headers (articles group) 369(defun gnus-async-retrieve-fetched-headers (articles group)
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index 36657e46219..9423d9f2f6b 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -294,49 +294,47 @@ it's not cached."
294(defun gnus-cache-retrieve-headers (articles group &optional fetch-old) 294(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
295 "Retrieve the headers for ARTICLES in GROUP." 295 "Retrieve the headers for ARTICLES in GROUP."
296 (let ((cached 296 (let ((cached
297 (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) 297 (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))
298 (gnus-newsgroup-name group)
299 (gnus-fetch-old-headers fetch-old))
298 (if (not cached) 300 (if (not cached)
299 ;; No cached articles here, so we just retrieve them 301 ;; No cached articles here, so we just retrieve them
300 ;; the normal way. 302 ;; the normal way.
301 (let ((gnus-use-cache nil)) 303 (let ((gnus-use-cache nil))
302 (gnus-retrieve-headers articles group fetch-old)) 304 (gnus-retrieve-headers articles group))
303 (let ((uncached-articles (gnus-sorted-difference articles cached)) 305 (let ((uncached-articles (gnus-sorted-difference articles cached))
304 (cache-file (gnus-cache-file-name group ".overview")) 306 (cache-file (gnus-cache-file-name group ".overview"))
305 type 307 (file-name-coding-system nnmail-pathname-coding-system)
306 (file-name-coding-system nnmail-pathname-coding-system)) 308 headers)
307 ;; We first retrieve all the headers that we don't have in 309 ;; We first retrieve all the headers that we don't have in
308 ;; the cache. 310 ;; the cache.
309 (let ((gnus-use-cache nil)) 311 (let ((gnus-use-cache nil))
310 (when uncached-articles 312 (when uncached-articles
311 (setq type (and articles 313 (setq headers (and articles
312 (gnus-retrieve-headers 314 (gnus-fetch-headers uncached-articles)))))
313 uncached-articles group fetch-old)))))
314 (gnus-cache-save-buffers) 315 (gnus-cache-save-buffers)
315 ;; Then we insert the cached headers. 316 ;; Then we include the cached headers.
316 (save-excursion 317 (when (file-exists-p cache-file)
317 (cond 318 (setq headers
318 ((not (file-exists-p cache-file)) 319 (delete-dups
319 ;; There are no cached headers. 320 (sort
320 type) 321 (append headers
321 ((null type) 322 (let ((coding-system-for-read
322 ;; There were no uncached headers (or retrieval was 323 gnus-cache-overview-coding-system))
323 ;; unsuccessful), so we use the cached headers exclusively. 324 (with-current-buffer nntp-server-buffer
324 (set-buffer nntp-server-buffer) 325 (erase-buffer)
325 (erase-buffer) 326 (insert-file-contents cache-file)
326 (let ((coding-system-for-read 327 (gnus-get-newsgroup-headers-xover
327 gnus-cache-overview-coding-system)) 328 (gnus-sorted-difference
328 (insert-file-contents cache-file)) 329 cached uncached-articles)
329 'nov) 330 nil (buffer-local-value
330 ((eq type 'nov) 331 'gnus-newsgroup-dependencies
331 ;; We have both cached and uncached NOV headers, so we 332 gnus-summary-buffer)
332 ;; braid them. 333 group))))
333 (gnus-cache-braid-nov group cached) 334 (lambda (l r)
334 type) 335 (< (mail-header-number l)
335 (t 336 (mail-header-number r)))))))
336 ;; We braid HEADs. 337 headers))))
337 (gnus-cache-braid-heads group (gnus-sorted-intersection
338 cached articles))
339 type)))))))
340 338
341(defun gnus-cache-enter-article (&optional n) 339(defun gnus-cache-enter-article (&optional n)
342 "Enter the next N articles into the cache. 340 "Enter the next N articles into the cache.
@@ -529,70 +527,6 @@ Returns the list of articles removed."
529 (setq gnus-cache-active-altered t))) 527 (setq gnus-cache-active-altered t)))
530 articles))) 528 articles)))
531 529
532(defun gnus-cache-braid-nov (group cached &optional file)
533 (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))
534 beg end)
535 (gnus-cache-save-buffers)
536 (with-current-buffer cache-buf
537 (erase-buffer)
538 (let ((coding-system-for-read gnus-cache-overview-coding-system)
539 (file-name-coding-system nnmail-pathname-coding-system))
540 (insert-file-contents
541 (or file (gnus-cache-file-name group ".overview"))))
542 (goto-char (point-min))
543 (insert "\n")
544 (goto-char (point-min)))
545 (set-buffer nntp-server-buffer)
546 (goto-char (point-min))
547 (while cached
548 (while (and (not (eobp))
549 (< (read (current-buffer)) (car cached)))
550 (forward-line 1))
551 (beginning-of-line)
552 (set-buffer cache-buf)
553 (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
554 nil t)
555 (setq beg (point-at-bol)
556 end (progn (end-of-line) (point)))
557 (setq beg nil))
558 (set-buffer nntp-server-buffer)
559 (when beg
560 (insert-buffer-substring cache-buf beg end)
561 (insert "\n"))
562 (setq cached (cdr cached)))
563 (kill-buffer cache-buf)))
564
565(defun gnus-cache-braid-heads (group cached)
566 (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
567 (with-current-buffer cache-buf
568 (erase-buffer))
569 (set-buffer nntp-server-buffer)
570 (goto-char (point-min))
571 (dolist (entry cached)
572 (while (and (not (eobp))
573 (looking-at "2.. +\\([0-9]+\\) ")
574 (< (progn (goto-char (match-beginning 1))
575 (read (current-buffer)))
576 entry))
577 (search-forward "\n.\n" nil 'move))
578 (beginning-of-line)
579 (set-buffer cache-buf)
580 (erase-buffer)
581 (let ((coding-system-for-read gnus-cache-coding-system)
582 (file-name-coding-system nnmail-pathname-coding-system))
583 (insert-file-contents (gnus-cache-file-name group entry)))
584 (goto-char (point-min))
585 (insert "220 ")
586 (princ (pop cached) (current-buffer))
587 (insert " Article retrieved.\n")
588 (search-forward "\n\n" nil 'move)
589 (delete-region (point) (point-max))
590 (forward-char -1)
591 (insert ".")
592 (set-buffer nntp-server-buffer)
593 (insert-buffer-substring cache-buf))
594 (kill-buffer cache-buf)))
595
596;;;###autoload 530;;;###autoload
597(defun gnus-jog-cache () 531(defun gnus-jog-cache ()
598 "Go through all groups and put the articles into the cache. 532 "Go through all groups and put the articles into the cache.
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index f7c71f43ce8..00b85f546c2 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -30,6 +30,8 @@
30 30
31(require 'parse-time) 31(require 'parse-time)
32(require 'nnimap) 32(require 'nnimap)
33(declare-function gnus-fetch-headers "gnus-sum")
34(defvar gnus-alter-header-function)
33 35
34(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' 36(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
35(autoload 'epg-make-context "epg") 37(autoload 'epg-make-context "epg")
@@ -391,8 +393,6 @@ When FULL is t, upload everything, not just a difference from the last full."
391 (gnus-group-refresh-group group)) 393 (gnus-group-refresh-group group))
392 (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group))))) 394 (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group)))))
393 395
394(defvar gnus-alter-header-function)
395
396(defun gnus-cloud-add-timestamps (elems) 396(defun gnus-cloud-add-timestamps (elems)
397 (dolist (elem elems) 397 (dolist (elem elems)
398 (let* ((file-name (plist-get elem :file-name)) 398 (let* ((file-name (plist-get elem :file-name))
@@ -407,14 +407,10 @@ When FULL is t, upload everything, not just a difference from the last full."
407 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) 407 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
408 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) 408 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
409 (active (gnus-active group)) 409 (active (gnus-active group))
410 headers head) 410 (gnus-newsgroup-name group)
411 (when (gnus-retrieve-headers (gnus-uncompress-range active) group) 411 (headers (gnus-fetch-headers (gnus-uncompress-range active))))
412 (with-current-buffer nntp-server-buffer 412 (when gnus-alter-header-function
413 (goto-char (point-min)) 413 (mapc gnus-alter-header-function headers))
414 (while (setq head (nnheader-parse-head))
415 (when gnus-alter-header-function
416 (funcall gnus-alter-header-function head))
417 (push head headers))))
418 (sort (nreverse headers) 414 (sort (nreverse headers)
419 (lambda (h1 h2) 415 (lambda (h1 h2)
420 (> (gnus-cloud-chunk-sequence (mail-header-subject h1)) 416 (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el
index 5c6a5b9efd0..44780609af7 100644
--- a/lisp/gnus/gnus-search.el
+++ b/lisp/gnus/gnus-search.el
@@ -909,6 +909,7 @@ quirks.")
909(defclass gnus-search-namazu (gnus-search-indexed) 909(defclass gnus-search-namazu (gnus-search-indexed)
910 ((index-directory 910 ((index-directory
911 :initarg :index-directory 911 :initarg :index-directory
912 :initform (symbol-value 'gnus-search-namazu-index-directory)
912 :type string 913 :type string
913 :custom directory) 914 :custom directory)
914 (program 915 (program
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index fbdbf41dc05..cf37a1ccdfc 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -637,7 +637,7 @@ the first newsgroup."
637 ;; We subscribe the group by changing its level to `subscribed'. 637 ;; We subscribe the group by changing its level to `subscribed'.
638 (gnus-group-change-level 638 (gnus-group-change-level
639 newsgroup gnus-level-default-subscribed 639 newsgroup gnus-level-default-subscribed
640 gnus-level-killed (or next "dummy.group")) 640 gnus-level-killed next)
641 (gnus-request-update-group-status newsgroup 'subscribe) 641 (gnus-request-update-group-status newsgroup 'subscribe)
642 (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) 642 (gnus-message 5 "Subscribe newsgroup: %s" newsgroup)
643 (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) 643 (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup)
@@ -1282,7 +1282,8 @@ string name) to insert this group before."
1282 (gnus-dribble-enter 1282 (gnus-dribble-enter
1283 (format "(gnus-group-change-level %S %S %S %S %S)" 1283 (format "(gnus-group-change-level %S %S %S %S %S)"
1284 group level oldlevel 1284 group level oldlevel
1285 (cadr (member previous gnus-group-list)) 1285 (when previous
1286 (cadr (member previous gnus-group-list)))
1286 fromkilled))) 1287 fromkilled)))
1287 1288
1288 ;; Then we remove the newgroup from any old structures, if needed. 1289 ;; Then we remove the newgroup from any old structures, if needed.
@@ -1341,9 +1342,10 @@ string name) to insert this group before."
1341 ;; at the head of `gnus-newsrc-alist'. 1342 ;; at the head of `gnus-newsrc-alist'.
1342 (push info (cdr gnus-newsrc-alist)) 1343 (push info (cdr gnus-newsrc-alist))
1343 (puthash group (list num info) gnus-newsrc-hashtb) 1344 (puthash group (list num info) gnus-newsrc-hashtb)
1344 (when (stringp previous) 1345 (when (and previous (stringp previous))
1345 (setq previous (gnus-group-entry previous))) 1346 (setq previous (gnus-group-entry previous)))
1346 (let ((idx (or (seq-position gnus-group-list (caadr previous)) 1347 (let ((idx (or (and previous
1348 (seq-position gnus-group-list (caadr previous)))
1347 (length gnus-group-list)))) 1349 (length gnus-group-list))))
1348 (push group (nthcdr idx gnus-group-list))) 1350 (push group (nthcdr idx gnus-group-list)))
1349 (gnus-dribble-enter 1351 (gnus-dribble-enter
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index b0f9ed4c6f0..5bd58b690af 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -5658,10 +5658,21 @@ or a straight list of headers."
5658 (setf (mail-header-subject header) subject)))))) 5658 (setf (mail-header-subject header) subject))))))
5659 5659
5660(defun gnus-fetch-headers (articles &optional limit force-new dependencies) 5660(defun gnus-fetch-headers (articles &optional limit force-new dependencies)
5661 "Fetch headers of ARTICLES." 5661 "Fetch headers of ARTICLES.
5662This calls the `gnus-retrieve-headers' function of the current
5663group's backend server. The server can do one of two things:
5664
56651. Write the headers for ARTICLES into the
5666 `nntp-server-buffer' (the current buffer) in a parseable format, or
56672. Return the headers directly as a list of vectors.
5668
5669In the first case, `gnus-retrieve-headers' returns a symbol
5670value, either `nov' or `headers'. This value determines which
5671parsing function is used to read the headers. It is also stored
5672into the variable `gnus-headers-retrieved-by', which is consulted
5673later when possibly building full threads."
5662 (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) 5674 (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name)
5663 (prog1 5675 (let ((res (setq gnus-headers-retrieved-by
5664 (pcase (setq gnus-headers-retrieved-by
5665 (gnus-retrieve-headers 5676 (gnus-retrieve-headers
5666 articles gnus-newsgroup-name 5677 articles gnus-newsgroup-name
5667 (or limit 5678 (or limit
@@ -5671,22 +5682,34 @@ or a straight list of headers."
5671 (not (eq gnus-fetch-old-headers 'some)) 5682 (not (eq gnus-fetch-old-headers 'some))
5672 (not (numberp gnus-fetch-old-headers))) 5683 (not (numberp gnus-fetch-old-headers)))
5673 (> (length articles) 1)) 5684 (> (length articles) 1))
5674 gnus-fetch-old-headers)))) 5685 gnus-fetch-old-headers))))))
5675 ('nov 5686 (prog1
5676 (gnus-get-newsgroup-headers-xover 5687 (pcase res
5677 articles force-new dependencies gnus-newsgroup-name t)) 5688 ('nov
5678 ('headers 5689 (gnus-get-newsgroup-headers-xover
5679 (gnus-get-newsgroup-headers dependencies force-new)) 5690 articles force-new dependencies gnus-newsgroup-name t))
5680 ((pred listp) 5691 ;; For now, assume that any backend returning its own
5681 (let ((dependencies 5692 ;; headers takes some effort to do so, so return `headers'.
5682 (or dependencies 5693 ((pred listp)
5683 (with-current-buffer gnus-summary-buffer 5694 (setq gnus-headers-retrieved-by 'headers)
5684 gnus-newsgroup-dependencies)))) 5695 (let ((dependencies
5685 (delq nil (mapcar #'(lambda (header) 5696 (or dependencies
5686 (gnus-dependencies-add-header 5697 (buffer-local-value
5687 header dependencies force-new)) 5698 'gnus-newsgroup-dependencies gnus-summary-buffer))))
5688 gnus-headers-retrieved-by))))) 5699 (when (functionp gnus-alter-header-function)
5689 (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name))) 5700 (mapc gnus-alter-header-function res))
5701 (mapc (lambda (header)
5702 ;; The agent or the cache may have already
5703 ;; registered this header in the dependency
5704 ;; table.
5705 (unless (gethash (mail-header-id header) dependencies)
5706 (gnus-dependencies-add-header
5707 header dependencies force-new)))
5708 res)
5709 res))
5710 (_ (gnus-get-newsgroup-headers dependencies force-new)))
5711 (gnus-message 7 "Fetching headers for %s...done"
5712 gnus-newsgroup-name))))
5690 5713
5691(defun gnus-select-newsgroup (group &optional read-all select-articles) 5714(defun gnus-select-newsgroup (group &optional read-all select-articles)
5692 "Select newsgroup GROUP. 5715 "Select newsgroup GROUP.
@@ -6443,6 +6466,10 @@ The resulting hash table is returned, or nil if no Xrefs were found."
6443 (unless (gnus-ephemeral-group-p group) 6466 (unless (gnus-ephemeral-group-p group)
6444 (gnus-group-update-group group t)))))) 6467 (gnus-group-update-group group t))))))
6445 6468
6469;; FIXME: Refactor this with `gnus-get-newsgroup-headers-xover' and
6470;; extract the necessary bits for the direct-header-return case. Also
6471;; look at this and see how similar it is to
6472;; `nnheader-parse-naked-head'.
6446(defun gnus-get-newsgroup-headers (&optional dependencies force-new) 6473(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
6447 (let ((dependencies 6474 (let ((dependencies
6448 (or dependencies 6475 (or dependencies
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 91ab878b22f..4241f30ba9d 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -2388,7 +2388,14 @@ Typical marks are those that make no sense in a standalone back end,
2388such as a mark that says whether an article is stored in the cache 2388such as a mark that says whether an article is stored in the cache
2389\(which doesn't make sense in a standalone back end).") 2389\(which doesn't make sense in a standalone back end).")
2390 2390
2391(defvar gnus-headers-retrieved-by nil) 2391(defvar gnus-headers-retrieved-by nil
2392 "Holds the return value of `gnus-retrieve-headers'.
2393This is either the symbol `nov' or the symbol `headers'. This
2394value is checked during the summary creation process, when
2395building threads. A value of `nov' indicates that header
2396retrieval is relatively cheap and threading is encouraged to
2397include more old articles. A value of `headers' indicates that
2398retrieval is expensive and should be minimized.")
2392(defvar gnus-article-reply nil) 2399(defvar gnus-article-reply nil)
2393(defvar gnus-override-method nil) 2400(defvar gnus-override-method nil)
2394(defvar gnus-opened-servers nil) 2401(defvar gnus-opened-servers nil)
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 50e02187484..1409a4384ab 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -47,7 +47,7 @@
47(require 'rfc2047) 47(require 'rfc2047)
48(require 'puny) 48(require 'puny)
49(require 'rmc) ; read-multiple-choice 49(require 'rmc) ; read-multiple-choice
50(eval-when-compile (require 'subr-x)) 50(require 'subr-x)
51 51
52(autoload 'mailclient-send-it "mailclient") 52(autoload 'mailclient-send-it "mailclient")
53 53
@@ -620,8 +620,8 @@ Done before generating the new subject of a forward."
620 620
621(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" 621(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
622 "All headers that match this regexp will be deleted when forwarding a message. 622 "All headers that match this regexp will be deleted when forwarding a message.
623This variable is not consulted when forwarding encrypted messages 623Also see `message-forward-included-headers' -- both variables are applied.
624and `message-forward-show-mml' is `best'. 624In addition, see `message-forward-included-mime-headers'.
625 625
626This may also be a list of regexps." 626This may also be a list of regexps."
627 :version "21.1" 627 :version "21.1"
@@ -637,7 +637,14 @@ This may also be a list of regexps."
637 '("^From:" "^Subject:" "^Date:" "^To:" "^Cc:") 637 '("^From:" "^Subject:" "^Date:" "^To:" "^Cc:")
638 "If non-nil, delete non-matching headers when forwarding a message. 638 "If non-nil, delete non-matching headers when forwarding a message.
639Only headers that match this regexp will be included. This 639Only headers that match this regexp will be included. This
640variable should be a regexp or a list of regexps." 640variable should be a regexp or a list of regexps.
641
642Also see `message-forward-ignored-headers' -- both variables are applied.
643In addition, see `message-forward-included-mime-headers'.
644
645When forwarding messages as MIME, but when
646`message-forward-show-mml' results in MML not being used,
647`message-forward-included-mime-headers' take precedence."
641 :version "27.1" 648 :version "27.1"
642 :group 'message-forwarding 649 :group 'message-forwarding
643 :type '(repeat :value-to-internal (lambda (widget value) 650 :type '(repeat :value-to-internal (lambda (widget value)
@@ -647,6 +654,24 @@ variable should be a regexp or a list of regexps."
647 (widget-editable-list-match widget value))) 654 (widget-editable-list-match widget value)))
648 regexp)) 655 regexp))
649 656
657(defcustom message-forward-included-mime-headers
658 '("^Content-Type:" "^MIME-Version:")
659 "When forwarding as MIME, but not using MML, don't delete these headers.
660Also see `message-forward-ignored-headers' and
661`message-forward-ignored-headers'.
662
663When forwarding messages as MIME, but when
664`message-forward-show-mml' results in MML not being used,
665`message-forward-included-mime-headers' take precedence."
666 :version "28.1"
667 :group 'message-forwarding
668 :type '(repeat :value-to-internal (lambda (widget value)
669 (custom-split-regexp-maybe value))
670 :match (lambda (widget value)
671 (or (stringp value)
672 (widget-editable-list-match widget value)))
673 regexp))
674
650(defcustom message-ignored-cited-headers "." 675(defcustom message-ignored-cited-headers "."
651 "Delete these headers from the messages you yank." 676 "Delete these headers from the messages you yank."
652 :group 'message-insertion 677 :group 'message-insertion
@@ -3057,22 +3082,23 @@ See also `message-forbidden-properties'."
3057 3082
3058(defun message--syntax-propertize (beg end) 3083(defun message--syntax-propertize (beg end)
3059 "Syntax-propertize certain message text specially." 3084 "Syntax-propertize certain message text specially."
3060 (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$")) 3085 (with-syntax-table message-mode-syntax-table
3061 (smiley-regexp (regexp-opt message-smileys))) 3086 (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
3062 (goto-char beg) 3087 (smiley-regexp (regexp-opt message-smileys)))
3063 (while (search-forward-regexp citation-regexp 3088 (goto-char beg)
3064 end 'noerror) 3089 (while (search-forward-regexp citation-regexp
3065 (let ((start (match-beginning 0)) 3090 end 'noerror)
3066 (end (match-end 0))) 3091 (let ((start (match-beginning 0))
3067 (add-text-properties start (1+ start) 3092 (end (match-end 0)))
3068 `(syntax-table ,(string-to-syntax "<"))) 3093 (add-text-properties start (1+ start)
3069 (add-text-properties end (min (1+ end) (point-max)) 3094 `(syntax-table ,(string-to-syntax "<")))
3070 `(syntax-table ,(string-to-syntax ">"))))) 3095 (add-text-properties end (min (1+ end) (point-max))
3071 (goto-char beg) 3096 `(syntax-table ,(string-to-syntax ">")))))
3072 (while (search-forward-regexp smiley-regexp 3097 (goto-char beg)
3073 end 'noerror) 3098 (while (search-forward-regexp smiley-regexp
3074 (add-text-properties (match-beginning 0) (match-end 0) 3099 end 'noerror)
3075 `(syntax-table ,(string-to-syntax ".")))))) 3100 (add-text-properties (match-beginning 0) (match-end 0)
3101 `(syntax-table ,(string-to-syntax ".")))))))
3076 3102
3077;;;###autoload 3103;;;###autoload
3078(define-derived-mode message-mode text-mode "Message" 3104(define-derived-mode message-mode text-mode "Message"
@@ -7616,14 +7642,28 @@ Optional DIGEST will use digest to forward."
7616 "-------------------- End of forwarded message --------------------\n") 7642 "-------------------- End of forwarded message --------------------\n")
7617 (message-remove-ignored-headers b e))) 7643 (message-remove-ignored-headers b e)))
7618 7644
7619(defun message-remove-ignored-headers (b e) 7645(defun message-remove-ignored-headers (b e &optional preserve-mime)
7620 (when (or message-forward-ignored-headers 7646 (when (or message-forward-ignored-headers
7621 message-forward-included-headers) 7647 message-forward-included-headers)
7648 (let ((saved-headers nil))
7622 (save-restriction 7649 (save-restriction
7623 (narrow-to-region b e) 7650 (narrow-to-region b e)
7624 (goto-char b) 7651 (goto-char b)
7625 (narrow-to-region (point) 7652 (narrow-to-region (point)
7626 (or (search-forward "\n\n" nil t) (point))) 7653 (or (search-forward "\n\n" nil t) (point)))
7654 ;; When forwarding as MIME, preserve some MIME headers.
7655 (when preserve-mime
7656 (let ((headers (buffer-string)))
7657 (with-temp-buffer
7658 (insert headers)
7659 (message-remove-header
7660 (if (listp message-forward-included-mime-headers)
7661 (mapconcat
7662 #'identity (cons "^$" message-forward-included-mime-headers)
7663 "\\|")
7664 message-forward-included-mime-headers)
7665 t nil t)
7666 (setq saved-headers (string-lines (buffer-string) t)))))
7627 (when message-forward-ignored-headers 7667 (when message-forward-ignored-headers
7628 (let ((ignored (if (stringp message-forward-ignored-headers) 7668 (let ((ignored (if (stringp message-forward-ignored-headers)
7629 (list message-forward-ignored-headers) 7669 (list message-forward-ignored-headers)
@@ -7636,10 +7676,14 @@ Optional DIGEST will use digest to forward."
7636 (mapconcat #'identity (cons "^$" message-forward-included-headers) 7676 (mapconcat #'identity (cons "^$" message-forward-included-headers)
7637 "\\|") 7677 "\\|")
7638 message-forward-included-headers) 7678 message-forward-included-headers)
7639 t nil t))))) 7679 t nil t))
7680 ;; Insert the MIME headers, if any.
7681 (goto-char (point-max))
7682 (forward-line -1)
7683 (dolist (header saved-headers)
7684 (insert header "\n"))))))
7640 7685
7641(defun message-forward-make-body-mime (forward-buffer &optional beg end 7686(defun message-forward-make-body-mime (forward-buffer &optional beg end)
7642 remove-headers)
7643 (let ((b (point))) 7687 (let ((b (point)))
7644 (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") 7688 (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
7645 (save-restriction 7689 (save-restriction
@@ -7649,8 +7693,7 @@ Optional DIGEST will use digest to forward."
7649 (goto-char (point-min)) 7693 (goto-char (point-min))
7650 (when (looking-at "From ") 7694 (when (looking-at "From ")
7651 (replace-match "X-From-Line: ")) 7695 (replace-match "X-From-Line: "))
7652 (when remove-headers 7696 (message-remove-ignored-headers (point-min) (point-max) t)
7653 (message-remove-ignored-headers (point-min) (point-max)))
7654 (goto-char (point-max))) 7697 (goto-char (point-max)))
7655 (insert "<#/part>\n") 7698 (insert "<#/part>\n")
7656 ;; Consider there is no illegible text. 7699 ;; Consider there is no illegible text.
@@ -7789,8 +7832,7 @@ is for the internal use."
7789 (message-signed-or-encrypted-p) 7832 (message-signed-or-encrypted-p)
7790 (error t)))))) 7833 (error t))))))
7791 (message-forward-make-body-mml forward-buffer) 7834 (message-forward-make-body-mml forward-buffer)
7792 (message-forward-make-body-mime 7835 (message-forward-make-body-mime forward-buffer))
7793 forward-buffer nil nil (not (eq message-forward-show-mml 'best))))
7794 (message-forward-make-body-plain forward-buffer))) 7836 (message-forward-make-body-plain forward-buffer)))
7795 (message-position-point)) 7837 (message-position-point))
7796 7838
diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el
index ebececa3ce2..3cdfc749703 100644
--- a/lisp/gnus/nnml.el
+++ b/lisp/gnus/nnml.el
@@ -769,8 +769,24 @@ article number. This function is called narrowed to an article."
769 (let ((headers (nnheader-parse-head t))) 769 (let ((headers (nnheader-parse-head t)))
770 (setf (mail-header-chars headers) chars) 770 (setf (mail-header-chars headers) chars)
771 (setf (mail-header-number headers) number) 771 (setf (mail-header-number headers) number)
772 ;; If there's non-ASCII raw characters in the data,
773 ;; RFC2047-encode them to avoid having arbitrary data in the
774 ;; .overview file.
775 (nnml--encode-headers headers)
772 headers)))) 776 headers))))
773 777
778(defun nnml--encode-headers (headers)
779 (let ((subject (mail-header-subject headers))
780 (rfc2047-encoding-type 'mime))
781 (unless (string-match "\\`[[:ascii:]]*\\'" subject)
782 (setf (mail-header-subject headers)
783 (mail-encode-encoded-word-string subject t))))
784 (let ((from (mail-header-from headers))
785 (rfc2047-encoding-type 'address-mime))
786 (unless (string-match "\\`[[:ascii:]]*\\'" from)
787 (setf (mail-header-from headers)
788 (rfc2047-encode-string from t)))))
789
774(defun nnml-get-nov-buffer (group &optional incrementalp) 790(defun nnml-get-nov-buffer (group &optional incrementalp)
775 (let ((buffer (gnus-get-buffer-create 791 (let ((buffer (gnus-get-buffer-create
776 (format " *nnml %soverview %s*" 792 (format " *nnml %soverview %s*"
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 7e10e151a4d..c2bb960f945 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -1209,7 +1209,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the
1209 (read-passwd (format "NNTP (%s@%s) password: " 1209 (read-passwd (format "NNTP (%s@%s) password: "
1210 user nntp-address))))))) 1210 user nntp-address)))))))
1211 (if (not result) 1211 (if (not result)
1212 (signal 'nntp-authinfo-rejected "Password rejected") 1212 (error "Password rejected")
1213 result)))))) 1213 result))))))
1214 1214
1215;;; Internal functions. 1215;;; Internal functions.
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index 1e2feda6365..ba2934351d6 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -101,15 +101,10 @@ It is computed from the marks of individual component groups.")
101 (erase-buffer) 101 (erase-buffer)
102 (if (stringp (car articles)) 102 (if (stringp (car articles))
103 'headers 103 'headers
104 (let ((vbuf (nnheader-set-temp-buffer 104 (let ((carticles (nnvirtual-partition-sequence articles))
105 (gnus-get-buffer-create " *virtual headers*")))
106 (carticles (nnvirtual-partition-sequence articles))
107 (sysname (system-name)) 105 (sysname (system-name))
108 cgroup carticle article result prefix) 106 cgroup headers all-headers article prefix)
109 (while carticles 107 (pcase-dolist (`(,cgroup . ,articles) carticles)
110 (setq cgroup (caar carticles))
111 (setq articles (cdar carticles))
112 (pop carticles)
113 (when (and articles 108 (when (and articles
114 (gnus-check-server 109 (gnus-check-server
115 (gnus-find-method-for-group cgroup) t) 110 (gnus-find-method-for-group cgroup) t)
@@ -119,69 +114,37 @@ It is computed from the marks of individual component groups.")
119 ;; This is probably evil if people have set 114 ;; This is probably evil if people have set
120 ;; gnus-use-cache to nil themselves, but I 115 ;; gnus-use-cache to nil themselves, but I
121 ;; have no way of finding the true value of it. 116 ;; have no way of finding the true value of it.
122 (let ((gnus-use-cache t)) 117 (let ((gnus-use-cache t)
123 (setq result (gnus-retrieve-headers 118 (gnus-newsgroup-name cgroup)
124 articles cgroup nil)))) 119 (gnus-fetch-old-headers nil))
125 (set-buffer nntp-server-buffer) 120 (setq headers (gnus-fetch-headers articles))))
126 ;; If we got HEAD headers, we convert them into NOV 121 (erase-buffer)
127 ;; headers. This is slow, inefficient and, come to think 122 ;; Remove all header article numbers from `articles'.
128 ;; of it, downright evil. So sue me. I couldn't be 123 ;; If there's anything left, those are expired or
129 ;; bothered to write a header parse routine that could 124 ;; canceled articles, so we update the component group
130 ;; parse a mixed HEAD/NOV buffer. 125 ;; below.
131 (when (eq result 'headers) 126 (dolist (h headers)
132 (nnvirtual-convert-headers)) 127 (setq articles (delq (mail-header-number h) articles)
133 (goto-char (point-min)) 128 article (nnvirtual-reverse-map-article
134 (while (not (eobp)) 129 cgroup (mail-header-number h)))
135 (delete-region (point) 130 ;; Update all the header numbers according to their
136 (progn 131 ;; reverse mapping, and drop any with no such mapping.
137 (setq carticle (read nntp-server-buffer)) 132 (when article
138 (point))) 133 ;; Do this first, before we re-set the header's
139 134 ;; article number.
140 ;; We remove this article from the articles list, if 135 (nnvirtual-update-xref-header
141 ;; anything is left in the articles list after going through 136 h cgroup prefix sysname)
142 ;; the entire buffer, then those articles have been 137 (setf (mail-header-number h) article)
143 ;; expired or canceled, so we appropriately update the 138 (push h all-headers)))
144 ;; component group below. They should be coming up 139 ;; Anything left in articles is expired or canceled.
145 ;; generally in order, so this shouldn't be slow. 140 ;; Could be smart and not tell it about articles already
146 (setq articles (delq carticle articles)) 141 ;; known?
147 142 (when articles
148 (setq article (nnvirtual-reverse-map-article cgroup carticle)) 143 (gnus-group-make-articles-read cgroup articles))))
149 (if (null article) 144
150 ;; This line has no reverse mapping, that means it 145 (sort all-headers (lambda (h1 h2)
151 ;; was an extra article reference returned by nntp. 146 (< (mail-header-number h1)
152 (progn 147 (mail-header-number h2)))))))))
153 (beginning-of-line)
154 (delete-region (point) (progn (forward-line 1) (point))))
155 ;; Otherwise insert the virtual article number,
156 ;; and clean up the xrefs.
157 (princ article nntp-server-buffer)
158 (nnvirtual-update-xref-header cgroup carticle
159 prefix sysname)
160 (forward-line 1))
161 )
162
163 (set-buffer vbuf)
164 (goto-char (point-max))
165 (insert-buffer-substring nntp-server-buffer))
166 ;; Anything left in articles is expired or canceled.
167 ;; Could be smart and not tell it about articles already known?
168 (when articles
169 (gnus-group-make-articles-read cgroup articles))
170 )
171
172 ;; The headers are ready for reading, so they are inserted into
173 ;; the nntp-server-buffer, which is where Gnus expects to find
174 ;; them.
175 (prog1
176 (with-current-buffer nntp-server-buffer
177 (erase-buffer)
178 (insert-buffer-substring vbuf)
179 ;; FIX FIX FIX, we should be able to sort faster than
180 ;; this if needed, since each cgroup is sorted, we just
181 ;; need to merge
182 (sort-numeric-fields 1 (point-min) (point-max))
183 'nov)
184 (kill-buffer vbuf)))))))
185 148
186 149
187(defvoo nnvirtual-last-accessed-component-group nil) 150(defvoo nnvirtual-last-accessed-component-group nil)
@@ -372,61 +335,18 @@ It is computed from the marks of individual component groups.")
372 335
373;;; Internal functions. 336;;; Internal functions.
374 337
375(defun nnvirtual-convert-headers () 338(defun nnvirtual-update-xref-header (header group prefix sysname)
376 "Convert HEAD headers into NOV headers." 339 "Add xref to component GROUP to HEADER.
377 (with-current-buffer nntp-server-buffer 340Also add a server PREFIX any existing xref lines."
378 (let* ((dependencies (make-hash-table :test #'equal)) 341 (let ((bits (split-string (mail-header-xref header)
379 (headers (gnus-get-newsgroup-headers dependencies))) 342 nil t "[[:blank:]]"))
380 (erase-buffer) 343 (art-no (mail-header-number header)))
381 (mapc 'nnheader-insert-nov headers)))) 344 (setf (mail-header-xref header)
382 345 (concat
383 346 (format "%s %s:%d " sysname group art-no)
384(defun nnvirtual-update-xref-header (group article prefix sysname) 347 (mapconcat (lambda (bit)
385 "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines." 348 (concat prefix bit))
386 ;; Move to beginning of Xref field, creating a slot if needed. 349 bits " ")))))
387 (beginning-of-line)
388 (looking-at
389 "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
390 (goto-char (match-end 0))
391 (unless (search-forward "\t" (point-at-eol) 'move)
392 (insert "\t"))
393
394 ;; Remove any spaces at the beginning of the Xref field.
395 (while (eq (char-after (1- (point))) ? )
396 (forward-char -1)
397 (delete-char 1))
398
399 (insert "Xref: " sysname " " group ":")
400 (princ article (current-buffer))
401 (insert " ")
402
403 ;; If there were existing xref lines, clean them up to have the correct
404 ;; component server prefix.
405 (save-restriction
406 (narrow-to-region (point)
407 (or (search-forward "\t" (point-at-eol) t)
408 (point-at-eol)))
409 (goto-char (point-min))
410 (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t)
411 (replace-match "" t t))
412 (goto-char (point-min))
413 (when (re-search-forward
414 (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+")
415 nil t)
416 (replace-match "" t t))
417 (unless (eobp)
418 (insert " ")
419 (when (not (string= "" prefix))
420 (while (re-search-forward "[^ ]+:[0-9]+" nil t)
421 (save-excursion
422 (goto-char (match-beginning 0))
423 (insert prefix))))))
424
425 ;; Ensure a trailing \t.
426 (end-of-line)
427 (or (eq (char-after (1- (point))) ?\t)
428 (insert ?\t)))
429
430 350
431(defun nnvirtual-possibly-change-server (server) 351(defun nnvirtual-possibly-change-server (server)
432 (or (not server) 352 (or (not server)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 8ce936ad164..879653057d0 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1655,6 +1655,9 @@ in `describe-keymap'. See also `Searching the Active Keymaps'."
1655 (get-char-property (point) 'local-map) 1655 (get-char-property (point) 'local-map)
1656 (current-local-map))))) 1656 (current-local-map)))))
1657 1657
1658(defvar keymap-name-history nil
1659 "History for input to `describe-keymap'.")
1660
1658;;;###autoload 1661;;;###autoload
1659(defun describe-keymap (keymap) 1662(defun describe-keymap (keymap)
1660 "Describe key bindings in KEYMAP. 1663 "Describe key bindings in KEYMAP.
diff --git a/lisp/hl-line.el b/lisp/hl-line.el
index 73870f9579e..82952e934b6 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -45,11 +45,7 @@
45;; An overlay is used. In the non-sticky cases, this overlay is 45;; An overlay is used. In the non-sticky cases, this overlay is
46;; active only on the selected window. A hook is added to 46;; active only on the selected window. A hook is added to
47;; `post-command-hook' to activate the overlay and move it to the line 47;; `post-command-hook' to activate the overlay and move it to the line
48;; about point. To get the non-sticky behavior, `hl-line-unhighlight' 48;; about point.
49;; is added to `pre-command-hook' as well. This function deactivates
50;; the overlay unconditionally in case the command changes the
51;; selected window. (It does so rather than keeping track of changes
52;; in the selected window).
53 49
54;; You could make variable `global-hl-line-mode' buffer-local and set 50;; You could make variable `global-hl-line-mode' buffer-local and set
55;; it to nil to avoid highlighting specific buffers, when the global 51;; it to nil to avoid highlighting specific buffers, when the global
@@ -91,9 +87,9 @@ when `global-hl-line-sticky-flag' is non-nil.")
91 (set symbol value) 87 (set symbol value)
92 (dolist (buffer (buffer-list)) 88 (dolist (buffer (buffer-list))
93 (with-current-buffer buffer 89 (with-current-buffer buffer
94 (when hl-line-overlay 90 (when (overlayp hl-line-overlay)
95 (overlay-put hl-line-overlay 'face hl-line-face)))) 91 (overlay-put hl-line-overlay 'face hl-line-face))))
96 (when global-hl-line-overlay 92 (when (overlayp global-hl-line-overlay)
97 (overlay-put global-hl-line-overlay 'face hl-line-face)))) 93 (overlay-put global-hl-line-overlay 'face hl-line-face))))
98 94
99(defcustom hl-line-sticky-flag t 95(defcustom hl-line-sticky-flag t
@@ -141,9 +137,7 @@ non-selected window. Hl-Line mode uses the function
141`hl-line-highlight' on `post-command-hook' in this case. 137`hl-line-highlight' on `post-command-hook' in this case.
142 138
143When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the 139When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the
144line about point in the selected window only. In this case, it 140line about point in the selected window only."
145uses the function `hl-line-maybe-unhighlight' in
146addition to `hl-line-highlight' on `post-command-hook'."
147 :group 'hl-line 141 :group 'hl-line
148 (if hl-line-mode 142 (if hl-line-mode
149 (progn 143 (progn
@@ -151,12 +145,10 @@ addition to `hl-line-highlight' on `post-command-hook'."
151 (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) 145 (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t)
152 (hl-line-highlight) 146 (hl-line-highlight)
153 (setq hl-line-overlay-buffer (current-buffer)) 147 (setq hl-line-overlay-buffer (current-buffer))
154 (add-hook 'post-command-hook #'hl-line-highlight nil t) 148 (add-hook 'post-command-hook #'hl-line-highlight nil t))
155 (add-hook 'post-command-hook #'hl-line-maybe-unhighlight nil t))
156 (remove-hook 'post-command-hook #'hl-line-highlight t) 149 (remove-hook 'post-command-hook #'hl-line-highlight t)
157 (hl-line-unhighlight) 150 (hl-line-unhighlight)
158 (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t) 151 (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t)))
159 (remove-hook 'post-command-hook #'hl-line-maybe-unhighlight t)))
160 152
161(defun hl-line-make-overlay () 153(defun hl-line-make-overlay ()
162 (let ((ol (make-overlay (point) (point)))) 154 (let ((ol (make-overlay (point) (point))))
@@ -168,17 +160,19 @@ addition to `hl-line-highlight' on `post-command-hook'."
168 "Activate the Hl-Line overlay on the current line." 160 "Activate the Hl-Line overlay on the current line."
169 (if hl-line-mode ; Might be changed outside the mode function. 161 (if hl-line-mode ; Might be changed outside the mode function.
170 (progn 162 (progn
171 (unless hl-line-overlay 163 (unless (overlayp hl-line-overlay)
172 (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved. 164 (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved.
173 (overlay-put hl-line-overlay 165 (overlay-put hl-line-overlay
174 'window (unless hl-line-sticky-flag (selected-window))) 166 'window (unless hl-line-sticky-flag (selected-window)))
175 (hl-line-move hl-line-overlay)) 167 (hl-line-move hl-line-overlay)
168 (hl-line-maybe-unhighlight))
176 (hl-line-unhighlight))) 169 (hl-line-unhighlight)))
177 170
178(defun hl-line-unhighlight () 171(defun hl-line-unhighlight ()
179 "Deactivate the Hl-Line overlay on the current line." 172 "Deactivate the Hl-Line overlay on the current line."
180 (when hl-line-overlay 173 (when (overlayp hl-line-overlay)
181 (delete-overlay hl-line-overlay))) 174 (delete-overlay hl-line-overlay)
175 (setq hl-line-overlay nil)))
182 176
183(defun hl-line-maybe-unhighlight () 177(defun hl-line-maybe-unhighlight ()
184 "Maybe deactivate the Hl-Line overlay on the current line. 178 "Maybe deactivate the Hl-Line overlay on the current line.
@@ -191,8 +185,7 @@ such overlays in all buffers except the current one."
191 (not (eq curbuf hlob)) 185 (not (eq curbuf hlob))
192 (not (minibufferp))) 186 (not (minibufferp)))
193 (with-current-buffer hlob 187 (with-current-buffer hlob
194 (when (overlayp hl-line-overlay) 188 (hl-line-unhighlight)))
195 (delete-overlay hl-line-overlay))))
196 (when (and (overlayp hl-line-overlay) 189 (when (and (overlayp hl-line-overlay)
197 (eq (overlay-buffer hl-line-overlay) curbuf)) 190 (eq (overlay-buffer hl-line-overlay) curbuf))
198 (setq hl-line-overlay-buffer curbuf)))) 191 (setq hl-line-overlay-buffer curbuf))))
@@ -205,8 +198,8 @@ If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode
205highlights the line about the current buffer's point in all live 198highlights the line about the current buffer's point in all live
206windows. 199windows.
207 200
208Global-Hl-Line mode uses the functions `global-hl-line-highlight' 201Global-Hl-Line mode uses the function `global-hl-line-highlight'
209and `global-hl-line-maybe-unhighlight' on `post-command-hook'." 202on `post-command-hook'."
210 :global t 203 :global t
211 :group 'hl-line 204 :group 'hl-line
212 (if global-hl-line-mode 205 (if global-hl-line-mode
@@ -214,25 +207,24 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'."
214 ;; In case `kill-all-local-variables' is called. 207 ;; In case `kill-all-local-variables' is called.
215 (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight) 208 (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight)
216 (global-hl-line-highlight-all) 209 (global-hl-line-highlight-all)
217 (add-hook 'post-command-hook #'global-hl-line-highlight) 210 (add-hook 'post-command-hook #'global-hl-line-highlight))
218 (add-hook 'post-command-hook #'global-hl-line-maybe-unhighlight))
219 (global-hl-line-unhighlight-all) 211 (global-hl-line-unhighlight-all)
220 (remove-hook 'post-command-hook #'global-hl-line-highlight) 212 (remove-hook 'post-command-hook #'global-hl-line-highlight)
221 (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight) 213 (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight)))
222 (remove-hook 'post-command-hook #'global-hl-line-maybe-unhighlight)))
223 214
224(defun global-hl-line-highlight () 215(defun global-hl-line-highlight ()
225 "Highlight the current line in the current window." 216 "Highlight the current line in the current window."
226 (when global-hl-line-mode ; Might be changed outside the mode function. 217 (when global-hl-line-mode ; Might be changed outside the mode function.
227 (unless (window-minibuffer-p) 218 (unless (window-minibuffer-p)
228 (unless global-hl-line-overlay 219 (unless (overlayp global-hl-line-overlay)
229 (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved. 220 (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved.
230 (unless (member global-hl-line-overlay global-hl-line-overlays) 221 (unless (member global-hl-line-overlay global-hl-line-overlays)
231 (push global-hl-line-overlay global-hl-line-overlays)) 222 (push global-hl-line-overlay global-hl-line-overlays))
232 (overlay-put global-hl-line-overlay 'window 223 (overlay-put global-hl-line-overlay 'window
233 (unless global-hl-line-sticky-flag 224 (unless global-hl-line-sticky-flag
234 (selected-window))) 225 (selected-window)))
235 (hl-line-move global-hl-line-overlay)))) 226 (hl-line-move global-hl-line-overlay)
227 (global-hl-line-maybe-unhighlight))))
236 228
237(defun global-hl-line-highlight-all () 229(defun global-hl-line-highlight-all ()
238 "Highlight the current line in all live windows." 230 "Highlight the current line in all live windows."
@@ -243,8 +235,9 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'."
243 235
244(defun global-hl-line-unhighlight () 236(defun global-hl-line-unhighlight ()
245 "Deactivate the Global-Hl-Line overlay on the current line." 237 "Deactivate the Global-Hl-Line overlay on the current line."
246 (when global-hl-line-overlay 238 (when (overlayp global-hl-line-overlay)
247 (delete-overlay global-hl-line-overlay))) 239 (delete-overlay global-hl-line-overlay)
240 (setq global-hl-line-overlay nil)))
248 241
249(defun global-hl-line-maybe-unhighlight () 242(defun global-hl-line-maybe-unhighlight ()
250 "Maybe deactivate the Global-Hl-Line overlay on the current line. 243 "Maybe deactivate the Global-Hl-Line overlay on the current line.
@@ -256,9 +249,8 @@ all such overlays in all buffers except the current one."
256 (bufferp ovb) 249 (bufferp ovb)
257 (not (eq ovb (current-buffer))) 250 (not (eq ovb (current-buffer)))
258 (not (minibufferp))) 251 (not (minibufferp)))
259 (with-current-buffer ovb 252 (with-current-buffer ovb
260 (when (overlayp global-hl-line-overlay) 253 (global-hl-line-unhighlight)))))
261 (delete-overlay global-hl-line-overlay))))))
262 global-hl-line-overlays)) 254 global-hl-line-overlays))
263 255
264(defun global-hl-line-unhighlight-all () 256(defun global-hl-line-unhighlight-all ()
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 7be1b3d16c9..44574abd46a 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -1497,10 +1497,10 @@ Ordering is lexicographic."
1497 (string-lessp 1497 (string-lessp
1498 ;; FIXME: For now just compare the file name and the process name 1498 ;; FIXME: For now just compare the file name and the process name
1499 ;; (if it exists). Is there a better way to do this? 1499 ;; (if it exists). Is there a better way to do this?
1500 (or (buffer-file-name (car a)) 1500 (or (with-current-buffer (car a) (ibuffer-buffer-file-name))
1501 (let ((pr-a (get-buffer-process (car a)))) 1501 (let ((pr-a (get-buffer-process (car a))))
1502 (and (processp pr-a) (process-name pr-a)))) 1502 (and (processp pr-a) (process-name pr-a))))
1503 (or (buffer-file-name (car b)) 1503 (or (with-current-buffer (car b) (ibuffer-buffer-file-name))
1504 (let ((pr-b (get-buffer-process (car b)))) 1504 (let ((pr-b (get-buffer-process (car b))))
1505 (and (processp pr-b) (process-name pr-b)))))) 1505 (and (processp pr-b) (process-name pr-b))))))
1506 1506
@@ -1823,18 +1823,12 @@ When BUF nil, default to the buffer at current line."
1823;;;###autoload 1823;;;###autoload
1824(defun ibuffer-mark-by-file-name-regexp (regexp) 1824(defun ibuffer-mark-by-file-name-regexp (regexp)
1825 "Mark all buffers whose file name matches REGEXP." 1825 "Mark all buffers whose file name matches REGEXP."
1826 (interactive "sMark by file name (regexp): ") 1826 (interactive (list (read-regexp "Mark by file name (regexp)")))
1827 (ibuffer-mark-on-buffer 1827 (ibuffer-mark-on-buffer
1828 #'(lambda (buf) 1828 (lambda (buf)
1829 (let ((name (or (buffer-file-name buf) 1829 (when-let ((name (with-current-buffer buf (ibuffer-buffer-file-name))))
1830 (with-current-buffer buf 1830 ;; Match on the displayed file name (which is abbreviated).
1831 (and 1831 (string-match-p regexp (ibuffer--abbreviate-file-name name))))))
1832 (boundp 'dired-directory)
1833 (stringp dired-directory)
1834 dired-directory)))))
1835 (when name
1836 ;; Match on the displayed file name (which is abbreviated).
1837 (string-match regexp (abbreviate-file-name name)))))))
1838 1832
1839;;;###autoload 1833;;;###autoload
1840(defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers) 1834(defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers)
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index 4800e0243d7..84c53b16acf 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1308,6 +1308,11 @@ a new window in the current frame, splitting vertically."
1308 (car dired-directory))))) 1308 (car dired-directory)))))
1309 (and dirname (expand-file-name dirname)))))) 1309 (and dirname (expand-file-name dirname))))))
1310 1310
1311(defun ibuffer--abbreviate-file-name (filename)
1312 "Abbreviate FILENAME using `ibuffer-directory-abbrev-alist'."
1313 (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist))
1314 (abbreviate-file-name filename)))
1315
1311(define-ibuffer-op ibuffer-do-save () 1316(define-ibuffer-op ibuffer-do-save ()
1312 "Save marked buffers as with `save-buffer'." 1317 "Save marked buffers as with `save-buffer'."
1313 (:complex t 1318 (:complex t
@@ -1885,9 +1890,7 @@ If point is on a group name, this function operates on that group."
1885 (cond ((zerop total) "No files") 1890 (cond ((zerop total) "No files")
1886 ((= 1 total) "1 file") 1891 ((= 1 total) "1 file")
1887 (t (format "%d files" total)))))) 1892 (t (format "%d files" total))))))
1888 (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist)) 1893 (ibuffer--abbreviate-file-name (or (ibuffer-buffer-file-name) "")))
1889 (abbreviate-file-name
1890 (or (ibuffer-buffer-file-name) ""))))
1891 1894
1892(define-ibuffer-column filename-and-process 1895(define-ibuffer-column filename-and-process
1893 (:name "Filename/Process" 1896 (:name "Filename/Process"
diff --git a/lisp/image.el b/lisp/image.el
index 814035594b6..6955a90de77 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -264,9 +264,9 @@ compatibility with versions of Emacs that lack the variable
264;; Used to be in image-type-header-regexps, but now not used anywhere 264;; Used to be in image-type-header-regexps, but now not used anywhere
265;; (since 2009-08-28). 265;; (since 2009-08-28).
266(defun image-jpeg-p (data) 266(defun image-jpeg-p (data)
267 (declare (obsolete "It is unused inside Emacs and will be removed." "27.1"))
268 "Value is non-nil if DATA, a string, consists of JFIF image data. 267 "Value is non-nil if DATA, a string, consists of JFIF image data.
269We accept the tag Exif because that is the same format." 268We accept the tag Exif because that is the same format."
269 (declare (obsolete "It is unused inside Emacs and will be removed." "27.1"))
270 (setq data (ignore-errors (string-to-unibyte data))) 270 (setq data (ignore-errors (string-to-unibyte data)))
271 (when (and data (string-match-p "\\`\xff\xd8" data)) 271 (when (and data (string-match-p "\\`\xff\xd8" data))
272 (catch 'jfif 272 (catch 'jfif
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index 14e7b89dd1f..8f0f263dcce 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -719,6 +719,7 @@
719 georgian 719 georgian
720 cherokee 720 cherokee
721 canadian-aboriginal 721 canadian-aboriginal
722 cham
722 ogham 723 ogham
723 runic 724 runic
724 symbol 725 symbol
diff --git a/lisp/isearch.el b/lisp/isearch.el
index c6f7fe7bd4a..a86678572c4 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -3757,23 +3757,27 @@ since they have special meaning in a regexp."
3757 (overlay-put isearch-overlay 'priority 1001) 3757 (overlay-put isearch-overlay 'priority 1001)
3758 (overlay-put isearch-overlay 'face isearch-face))) 3758 (overlay-put isearch-overlay 'face isearch-face)))
3759 3759
3760 (when (and search-highlight-submatches 3760 (when (and search-highlight-submatches isearch-regexp)
3761 isearch-regexp)
3762 (mapc 'delete-overlay isearch-submatches-overlays) 3761 (mapc 'delete-overlay isearch-submatches-overlays)
3763 (setq isearch-submatches-overlays nil) 3762 (setq isearch-submatches-overlays nil)
3764 (let ((submatch-data (cddr (butlast match-data))) 3763 ;; 'cddr' removes whole expression match from match-data
3764 (let ((submatch-data (cddr match-data))
3765 (group 0) 3765 (group 0)
3766 ov face) 3766 b e ov face)
3767 (while submatch-data 3767 (while submatch-data
3768 (setq group (1+ group)) 3768 (setq b (pop submatch-data)
3769 (setq ov (make-overlay (pop submatch-data) (pop submatch-data)) 3769 e (pop submatch-data))
3770 face (intern-soft (format "isearch-group-%d" group))) 3770 (when (and (integer-or-marker-p b)
3771 ;; Recycle faces from beginning. 3771 (integer-or-marker-p e))
3772 (unless (facep face) 3772 (setq ov (make-overlay b e)
3773 (setq group 1 face 'isearch-group-1)) 3773 group (1+ group)
3774 (overlay-put ov 'face face) 3774 face (intern-soft (format "isearch-group-%d" group)))
3775 (overlay-put ov 'priority 1002) 3775 ;; Recycle faces from beginning
3776 (push ov isearch-submatches-overlays))))) 3776 (unless (facep face)
3777 (setq group 1 face 'isearch-group-1))
3778 (overlay-put ov 'face face)
3779 (overlay-put ov 'priority 1002)
3780 (push ov isearch-submatches-overlays))))))
3777 3781
3778(defun isearch-dehighlight () 3782(defun isearch-dehighlight ()
3779 (when isearch-overlay 3783 (when isearch-overlay
diff --git a/lisp/language/cham.el b/lisp/language/cham.el
index eef6d6f8f9f..089988da918 100644
--- a/lisp/language/cham.el
+++ b/lisp/language/cham.el
@@ -34,6 +34,12 @@
34(set-language-info-alist 34(set-language-info-alist
35 "Cham" '((charset unicode) 35 "Cham" '((charset unicode)
36 (coding-system utf-8) 36 (coding-system utf-8)
37 (coding-priority utf-8))) 37 (coding-priority utf-8)
38 (input-method . "cham")
39 (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨁꨰ")
40 (documentation . "\
41The Cham script is a Brahmic script used to write Cham,
42an Austronesian language spoken by some 245,000 Chams
43in Vietnam and Cambodia.")))
38 44
39(provide 'cham) 45(provide 'cham)
diff --git a/lisp/leim/quail/cham.el b/lisp/leim/quail/cham.el
new file mode 100644
index 00000000000..d12ae6cddf0
--- /dev/null
+++ b/lisp/leim/quail/cham.el
@@ -0,0 +1,116 @@
1;;; cham.el --- Quail package for inputting Cham characters -*- coding: utf-8; lexical-binding:t -*-
2
3;; Copyright (C) 2021 Free Software Foundation, Inc.
4
5;; Author: Eli Zaretskii <eliz@gnu.org>
6;; Keywords: i18n
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;; This file defines the following Cham keyboards:
26;;
27;; - QWERTY-based Cham.
28
29;;; Code:
30
31(require 'quail)
32
33(quail-define-package
34 "cham" "Cham" "ꨌꩌ" t
35 "A QWERTY-based Cham input method."
36 nil t nil nil t nil nil nil nil nil t)
37
38(quail-define-rules
39 ("a" ?ꨀ)
40 ("A" ?ꨄ)
41 ("i" ?ꨁ)
42 ("u" ?ꨂ)
43 ("e" ?ꨃ)
44 ("o" ?ꨅ)
45 ("k" ?ꨆ)
46 ("K" ?ꨇ)
47 ("g" ?ꨈ)
48 ("G" ?ꨉ)
49 ("q" ?ꨊ)
50 ("Q" ?ꨋ)
51 ("c" ?ꨌ)
52 ("C" ?ꨍ)
53 ("j" ?ꨎ)
54 ("J" ?ꨏ)
55 ("z" ?ꨐ)
56 ("Z" ?ꨑ)
57 ("zz" ?ꨒ)
58 ("t" ?ꨓ)
59 ("T" ?ꨔ)
60 ("d" ?ꨕ)
61 ("D" ?ꨖ)
62 ("n" ?ꨗ)
63 ("N" ?ꨘ)
64 ("p" ?ꨚ)
65 ("P" ?ꨛ)
66 ("f" ?ꨜ)
67 ("b" ?ꨝ)
68 ("B" ?ꨞ)
69 ("m" ?ꨟ)
70 ("M" ?ꨠ)
71 ("mm" ?ꨡ)
72 ("y" ?ꨢ)
73 ("r" ?ꨣ)
74 ("l" ?ꨤ)
75 ("w" ?ꨥ)
76 ("v" ?ꨥ)
77 ("x" ?ꨦ)
78 ("s" ?ꨧ)
79 ("h" ?ꨨ)
80 ("kk" ?ꩀ)
81 ("ww" ?ꩁ)
82 ("vv" ?ꩁ)
83 ("qq" ?ꩂ)
84 ("cc" ?ꩄ)
85 ("tt" ?ꩅ)
86 ("nn" ?ꩆ)
87 ("pp" ?ꩇ)
88 ("yy" ?ꩈ)
89 ("rr" ?ꩉ)
90 ("ll" ?ꩊ)
91 ("gg" ?ꩊ)
92 ("xx" ?ꩋ)
93 ("." ?ꩌ)
94 ("H" ?ꩍ)
95 ("0" ?꩐)
96 ("1" ?꩑)
97 ("2" ?꩒)
98 ("3" ?꩓)
99 ("4" ?꩔)
100 ("5" ?꩕)
101 ("6" ?꩖)
102 ("7" ?꩗)
103 ("8" ?꩘)
104 ("9" ?꩙)
105 ("!" ?ꨩ)
106 ("#" ?ꨪ)
107 ("$" ?ꨫ)
108 ("^" ?ꨬ)
109 ("&" ?ꨮ)
110 ("`" ?꩜)
111 ("=" ?ꨱ)
112 ("-" ?ꩃ)
113 ("~" ?꩟)
114 )
115
116;;; cham.el ends here
diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el
index e93ba547a89..0fab1b21b47 100644
--- a/lisp/mail/flow-fill.el
+++ b/lisp/mail/flow-fill.el
@@ -174,8 +174,8 @@ lines."
174(defvar fill-flowed-encode-tests) 174(defvar fill-flowed-encode-tests)
175 175
176(defun fill-flowed-test () 176(defun fill-flowed-test ()
177 (interactive "")
178 (declare (obsolete nil "27.1")) 177 (declare (obsolete nil "27.1"))
178 (interactive "")
179 (user-error (concat "This function is obsolete. Please see " 179 (user-error (concat "This function is obsolete. Please see "
180 "test/lisp/mail/flow-fill-tests.el " 180 "test/lisp/mail/flow-fill-tests.el "
181 "in the Emacs source tree"))) 181 "in the Emacs source tree")))
diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el
index ea109eec12a..995ae5f9160 100644
--- a/lisp/mail/footnote.el
+++ b/lisp/mail/footnote.el
@@ -910,7 +910,31 @@ play around with the following keys:
910 (unless (assoc bullet-regexp filladapt-token-table) 910 (unless (assoc bullet-regexp filladapt-token-table)
911 (setq filladapt-token-table 911 (setq filladapt-token-table
912 (append filladapt-token-table 912 (append filladapt-token-table
913 (list (list bullet-regexp 'bullet))))))))) 913 (list (list bullet-regexp 'bullet)))))))
914 (footnote--regenerate-alist)))
915
916(defun footnote--regenerate-alist ()
917 (save-excursion
918 (goto-char (point-min))
919 (when (re-search-forward footnote-section-tag-regexp nil t)
920 (setq footnote--markers-alist
921 (cl-loop
922 with start-of-footnotes = (match-beginning 0)
923 with regexp = (footnote--current-regexp)
924 for (note text) in
925 (cl-loop for pos = (re-search-forward regexp nil t)
926 while pos
927 collect (list (match-string 1)
928 (copy-marker (match-beginning 0) t)))
929 do (goto-char (point-min))
930 collect (cl-list*
931 (string-to-number note)
932 text
933 (cl-loop
934 for pos = (re-search-forward regexp start-of-footnotes t)
935 while pos
936 when (equal note (match-string 1))
937 collect (copy-marker (match-beginning 0) t))))))))
914 938
915(provide 'footnote) 939(provide 'footnote)
916 940
diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el
index 2680ed7f3a3..c3b351d7bc8 100644
--- a/lisp/mail/rmailedit.el
+++ b/lisp/mail/rmailedit.el
@@ -145,8 +145,9 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
145(declare-function rmail-summary-enable "rmailsum" ()) 145(declare-function rmail-summary-enable "rmailsum" ())
146(declare-function rmail-summary-update-line "rmailsum" (n)) 146(declare-function rmail-summary-update-line "rmailsum" (n))
147 147
148(defun rmail-cease-edit () 148(defun rmail-cease-edit (&optional abort)
149 "Finish editing message; switch back to Rmail proper." 149 "Finish editing message; switch back to Rmail proper.
150If ABORT, this is the result of aborting an edit."
150 (interactive) 151 (interactive)
151 (if (rmail-summary-exists) 152 (if (rmail-summary-exists)
152 (with-current-buffer rmail-summary-buffer 153 (with-current-buffer rmail-summary-buffer
@@ -271,6 +272,8 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
271 ;; No match for rmail-mime-charset-pattern, but there was some 272 ;; No match for rmail-mime-charset-pattern, but there was some
272 ;; other Content-Type. We should not insert another. (Bug#4624) 273 ;; other Content-Type. We should not insert another. (Bug#4624)
273 (content-type) 274 (content-type)
275 ;; Don't insert anything if aborting.
276 (abort)
274 ((null old-coding) 277 ((null old-coding)
275 ;; If there was no charset= spec, insert one. 278 ;; If there was no charset= spec, insert one.
276 (backward-char 1) 279 (backward-char 1)
@@ -352,7 +355,7 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
352 (widen) 355 (widen)
353 (delete-region (point-min) (point-max)) 356 (delete-region (point-min) (point-max))
354 (insert rmail-old-text) 357 (insert rmail-old-text)
355 (rmail-cease-edit) 358 (rmail-cease-edit t)
356 (rmail-highlight-headers)) 359 (rmail-highlight-headers))
357 360
358(defun rmail-edit-headers-alist (&optional widen markers) 361(defun rmail-edit-headers-alist (&optional widen markers)
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index 60b67edf85a..d29115a9570 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -51,10 +51,10 @@ Setting this option to nil might speed up the generation of summaries."
51 :group 'rmail-summary) 51 :group 'rmail-summary)
52 52
53(defvar rmail-summary-font-lock-keywords 53(defvar rmail-summary-font-lock-keywords
54 '(("^.....D.*" . font-lock-string-face) ; Deleted. 54 '(("^ *[0-9]+D.*" . font-lock-string-face) ; Deleted.
55 ("^.....-.*" . font-lock-type-face) ; Unread. 55 ("^ *[0-9]+-.*" . font-lock-type-face) ; Unread.
56 ;; Neither of the below will be highlighted if either of the above are: 56 ;; Neither of the below will be highlighted if either of the above are:
57 ("^.....[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date. 57 ("^ *[0-9]+[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date.
58 ("{ \\([^\n}]+\\) }" 1 font-lock-comment-face)) ; Labels. 58 ("{ \\([^\n}]+\\) }" 1 font-lock-comment-face)) ; Labels.
59 "Additional expressions to highlight in Rmail Summary mode.") 59 "Additional expressions to highlight in Rmail Summary mode.")
60 60
diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el
index 35d5884b16c..7cbd42c8ea2 100644
--- a/lisp/mh-e/mh-speed.el
+++ b/lisp/mh-e/mh-speed.el
@@ -125,11 +125,10 @@ With non-nil FORCE, the update is always carried out."
125 ;; Otherwise on to your regular programming 125 ;; Otherwise on to your regular programming
126 (t t))) 126 (t t)))
127 127
128(defun mh-speed-toggle (&rest ignored) 128(defun mh-speed-toggle (&rest _ignored)
129 "Toggle the display of child folders in the speedbar. 129 "Toggle the display of child folders in the speedbar.
130The optional arguments from speedbar are IGNORED." 130The optional arguments from speedbar are IGNORED."
131 (interactive) 131 (interactive)
132 (declare (ignore args))
133 (beginning-of-line) 132 (beginning-of-line)
134 (let ((parent (get-text-property (point) 'mh-folder)) 133 (let ((parent (get-text-property (point) 'mh-folder))
135 (kids-p (get-text-property (point) 'mh-children-p)) 134 (kids-p (get-text-property (point) 'mh-children-p))
@@ -164,11 +163,10 @@ The optional arguments from speedbar are IGNORED."
164 (mh-line-beginning-position) (1+ (line-beginning-position)) 163 (mh-line-beginning-position) (1+ (line-beginning-position))
165 '(mh-expanded t))))))) 164 '(mh-expanded t)))))))
166 165
167(defun mh-speed-view (&rest ignored) 166(defun mh-speed-view (&rest _ignored)
168 "Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder]. 167 "Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder].
169The optional arguments from speedbar are IGNORED." 168The optional arguments from speedbar are IGNORED."
170 (interactive) 169 (interactive)
171 (declare (ignore args))
172 (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) 170 (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder))
173 (range (and (stringp folder) 171 (range (and (stringp folder)
174 (mh-read-range "Scan" folder t nil nil 172 (mh-read-range "Scan" folder t nil nil
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index d131b2bf8c9..e39a4c33b20 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -1050,9 +1050,16 @@ the like."
1050 ;; multi-page isearch support 1050 ;; multi-page isearch support
1051 (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer) 1051 (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer)
1052 (setq truncate-lines t) 1052 (setq truncate-lines t)
1053 (setq-local thing-at-point-provider-alist
1054 (append thing-at-point-provider-alist
1055 '((url . eww--url-at-point))))
1053 (buffer-disable-undo) 1056 (buffer-disable-undo)
1054 (setq buffer-read-only t)) 1057 (setq buffer-read-only t))
1055 1058
1059(defun eww--url-at-point ()
1060 "`thing-at-point' provider function."
1061 (get-text-property (point) 'shr-url))
1062
1056;;;###autoload 1063;;;###autoload
1057(defun eww-browse-url (url &optional new-window) 1064(defun eww-browse-url (url &optional new-window)
1058 "Ask the EWW browser to load URL. 1065 "Ask the EWW browser to load URL.
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index e8ee372cb25..ed3d15377c3 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -181,10 +181,9 @@ The string is used in `tramp-methods'.")
181 `("scpx" 181 `("scpx"
182 (tramp-login-program "ssh") 182 (tramp-login-program "ssh")
183 (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") 183 (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
184 ("-e" "none") ("-t" "-t") ("%h") 184 ("-e" "none") ("-t" "-t")
185 ("%l"))) 185 ("-o" "RemoteCommand='%l'") ("%h")))
186 (tramp-async-args (("-q"))) 186 (tramp-async-args (("-q")))
187 (tramp-direct-async t)
188 (tramp-remote-shell ,tramp-default-remote-shell) 187 (tramp-remote-shell ,tramp-default-remote-shell)
189 (tramp-remote-shell-login ("-l")) 188 (tramp-remote-shell-login ("-l"))
190 (tramp-remote-shell-args ("-c")) 189 (tramp-remote-shell-args ("-c"))
@@ -238,10 +237,9 @@ The string is used in `tramp-methods'.")
238 `("sshx" 237 `("sshx"
239 (tramp-login-program "ssh") 238 (tramp-login-program "ssh")
240 (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") 239 (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
241 ("-e" "none") ("-t" "-t") ("%h") 240 ("-e" "none") ("-t" "-t")
242 ("%l"))) 241 ("-o" "RemoteCommand='%l'") ("%h")))
243 (tramp-async-args (("-q"))) 242 (tramp-async-args (("-q")))
244 (tramp-direct-async t)
245 (tramp-remote-shell ,tramp-default-remote-shell) 243 (tramp-remote-shell ,tramp-default-remote-shell)
246 (tramp-remote-shell-login ("-l")) 244 (tramp-remote-shell-login ("-l"))
247 (tramp-remote-shell-args ("-c")))) 245 (tramp-remote-shell-args ("-c"))))
@@ -2608,23 +2606,19 @@ The method used must be an out-of-band method."
2608(defun tramp-sh-handle-insert-directory 2606(defun tramp-sh-handle-insert-directory
2609 (filename switches &optional wildcard full-directory-p) 2607 (filename switches &optional wildcard full-directory-p)
2610 "Like `insert-directory' for Tramp files." 2608 "Like `insert-directory' for Tramp files."
2611 (setq filename (expand-file-name filename))
2612 (unless switches (setq switches "")) 2609 (unless switches (setq switches ""))
2613 ;; Check, whether directory is accessible. 2610 ;; Check, whether directory is accessible.
2614 (unless wildcard 2611 (unless wildcard
2615 (access-file filename "Reading directory")) 2612 (access-file filename "Reading directory"))
2616 (with-parsed-tramp-file-name filename nil 2613 (with-parsed-tramp-file-name (expand-file-name filename) nil
2617 (if (and (featurep 'ls-lisp) 2614 (if (and (featurep 'ls-lisp)
2618 (not (symbol-value 'ls-lisp-use-insert-directory-program))) 2615 (not (symbol-value 'ls-lisp-use-insert-directory-program)))
2619 (tramp-handle-insert-directory 2616 (tramp-handle-insert-directory
2620 filename switches wildcard full-directory-p) 2617 filename switches wildcard full-directory-p)
2621 (when (stringp switches) 2618 (when (stringp switches)
2622 (setq switches (split-string switches))) 2619 (setq switches (split-string switches)))
2623 (when (tramp-get-ls-command-with ;FIXME: tramp-sh--quoting-style-options? 2620 (setq switches
2624 v "--quoting-style=literal --show-control-chars") 2621 (append switches (split-string (tramp-sh--quoting-style-options v))))
2625 (setq switches
2626 (append
2627 switches '("--quoting-style=literal" "--show-control-chars"))))
2628 (unless (tramp-get-ls-command-with v "--dired") 2622 (unless (tramp-get-ls-command-with v "--dired")
2629 (setq switches (delete "--dired" switches))) 2623 (setq switches (delete "--dired" switches)))
2630 (when wildcard 2624 (when wildcard
@@ -4306,11 +4300,14 @@ file exists and nonzero exit status otherwise."
4306 ;; ensure they have the correct values when the shell starts, not 4300 ;; ensure they have the correct values when the shell starts, not
4307 ;; just processes run within the shell. (Which processes include 4301 ;; just processes run within the shell. (Which processes include
4308 ;; our initial probes to ensure the remote shell is usable.) 4302 ;; our initial probes to ensure the remote shell is usable.)
4303 ;; For the time being, we assume that all shells interpret -i as
4304 ;; interactive shell. Must be the last argument, because (for
4305 ;; example) bash expects long options first.
4309 (tramp-send-command 4306 (tramp-send-command
4310 vec (format 4307 vec (format
4311 (concat 4308 (concat
4312 "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " 4309 "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' "
4313 "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") 4310 "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i")
4314 tramp-terminal-type 4311 tramp-terminal-type
4315 (or (getenv "INSIDE_EMACS") emacs-version) tramp-version 4312 (or (getenv "INSIDE_EMACS") emacs-version) tramp-version
4316 (or (getenv-internal "ENV" tramp-remote-process-environment) "") 4313 (or (getenv-internal "ENV" tramp-remote-process-environment) "")
@@ -5122,7 +5119,7 @@ connection if a previous connection has died for some reason."
5122 options (format-spec options spec) 5119 options (format-spec options spec)
5123 spec (format-spec-make 5120 spec (format-spec-make
5124 ?h l-host ?u l-user ?p l-port ?c options 5121 ?h l-host ?u l-user ?p l-port ?c options
5125 ?l (concat remote-shell " " extra-args)) 5122 ?l (concat remote-shell " " extra-args " -i"))
5126 command 5123 command
5127 (concat 5124 (concat
5128 ;; We do not want to see the trailing local 5125 ;; We do not want to see the trailing local
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 1604e8962c0..c5a74a5c653 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -156,6 +156,7 @@ this variable (\"client min protocol=NT1\") ."
156 "NT_STATUS_NO_SUCH_FILE" 156 "NT_STATUS_NO_SUCH_FILE"
157 "NT_STATUS_NO_SUCH_USER" 157 "NT_STATUS_NO_SUCH_USER"
158 "NT_STATUS_NOT_A_DIRECTORY" 158 "NT_STATUS_NOT_A_DIRECTORY"
159 "NT_STATUS_NOT_SUPPORTED"
159 "NT_STATUS_OBJECT_NAME_COLLISION" 160 "NT_STATUS_OBJECT_NAME_COLLISION"
160 "NT_STATUS_OBJECT_NAME_INVALID" 161 "NT_STATUS_OBJECT_NAME_INVALID"
161 "NT_STATUS_OBJECT_NAME_NOT_FOUND" 162 "NT_STATUS_OBJECT_NAME_NOT_FOUND"
@@ -371,17 +372,17 @@ pass to the OPERATION."
371 (tramp-error 372 (tramp-error
372 v2 'file-error 373 v2 'file-error
373 "add-name-to-file: %s must not be a directory" filename)) 374 "add-name-to-file: %s must not be a directory" filename))
374 ;; Do the 'confirm if exists' thing. 375 ;; Do the 'confirm if exists' thing.
375 (when (file-exists-p newname) 376 (when (file-exists-p newname)
376 ;; What to do? 377 ;; What to do?
377 (if (or (null ok-if-already-exists) ; not allowed to exist 378 (if (or (null ok-if-already-exists) ; not allowed to exist
378 (and (numberp ok-if-already-exists) 379 (and (numberp ok-if-already-exists)
379 (not (yes-or-no-p 380 (not (yes-or-no-p
380 (format 381 (format
381 "File %s already exists; make it a link anyway? " 382 "File %s already exists; make it a link anyway? "
382 v2-localname))))) 383 v2-localname)))))
383 (tramp-error v2 'file-already-exists newname) 384 (tramp-error v2 'file-already-exists newname)
384 (delete-file newname))) 385 (delete-file newname)))
385 ;; We must also flush the cache of the directory, because 386 ;; We must also flush the cache of the directory, because
386 ;; `file-attributes' reads the values from there. 387 ;; `file-attributes' reads the values from there.
387 (tramp-flush-file-properties v2 v2-localname) 388 (tramp-flush-file-properties v2 v2-localname)
@@ -1166,7 +1167,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
1166 (insert " -> " (tramp-compat-file-attribute-type attr)))) 1167 (insert " -> " (tramp-compat-file-attribute-type attr))))
1167 1168
1168 (insert "\n") 1169 (insert "\n")
1169 (forward-line)
1170 (beginning-of-line))) 1170 (beginning-of-line)))
1171 entries)))))) 1171 entries))))))
1172 1172
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 2816c58fe7f..7b34a748822 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -1990,6 +1990,8 @@ the resulting error message."
1990 (tramp-dissect-file-name default-directory) 0 fmt-string arguments) 1990 (tramp-dissect-file-name default-directory) 0 fmt-string arguments)
1991 (apply #'message fmt-string arguments))) 1991 (apply #'message fmt-string arguments)))
1992 1992
1993(put #'tramp-test-message 'tramp-suppress-trace t)
1994
1993;; This function provides traces in case of errors not triggered by 1995;; This function provides traces in case of errors not triggered by
1994;; Tramp functions. 1996;; Tramp functions.
1995(defun tramp-signal-hook-function (error-symbol data) 1997(defun tramp-signal-hook-function (error-symbol data)
@@ -3801,15 +3803,20 @@ It does not support `:stderr'."
3801 (get-buffer-create buffer) 3803 (get-buffer-create buffer)
3802 ;; BUFFER can be nil. We use a temporary buffer. 3804 ;; BUFFER can be nil. We use a temporary buffer.
3803 (generate-new-buffer tramp-temp-buffer-name))) 3805 (generate-new-buffer tramp-temp-buffer-name)))
3804 ;; We use as environment the difference to toplevel
3805 ;; `process-environment'.
3806 (env (mapcar 3806 (env (mapcar
3807 (lambda (elt) 3807 (lambda (elt)
3808 (unless 3808 (when (string-match-p "=" elt) elt))
3809 (member 3809 tramp-remote-process-environment))
3810 elt (default-toplevel-value 'process-environment)) 3810 ;; We use as environment the difference to toplevel
3811 (when (string-match-p "=" elt) elt))) 3811 ;; `process-environment'.
3812 process-environment)) 3812 (env (dolist (elt process-environment env)
3813 (when
3814 (and
3815 (string-match-p "=" elt)
3816 (not
3817 (member
3818 elt (default-toplevel-value 'process-environment))))
3819 (setq env (cons elt env)))))
3813 (env (setenv-internal 3820 (env (setenv-internal
3814 env "INSIDE_EMACS" 3821 env "INSIDE_EMACS"
3815 (concat (or (getenv "INSIDE_EMACS") emacs-version) 3822 (concat (or (getenv "INSIDE_EMACS") emacs-version)
diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el
index 9bcf1d37345..e5941ae652e 100644
--- a/lisp/net/webjump.el
+++ b/lisp/net/webjump.el
@@ -2,9 +2,10 @@
2 2
3;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. 3;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
4 4
5;; Author: Neil W. Van Dyke <nwv@acm.org> 5;; Author: Neil W. Van Dyke <nwv@acm.org>
6;; Created: 09-Aug-1996 6;; Maintainer: emacs-devel@gnu.org
7;; Keywords: comm www 7;; Created: 09-Aug-1996
8;; Keywords: comm www
8 9
9;; This file is part of GNU Emacs. 10;; This file is part of GNU Emacs.
10 11
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index 5bc3049d90f..0602943db20 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -54,26 +54,30 @@
54 "Non-nil means display glyph following character reference. 54 "Non-nil means display glyph following character reference.
55The glyph is displayed in face `nxml-glyph'." 55The glyph is displayed in face `nxml-glyph'."
56 :group 'nxml 56 :group 'nxml
57 :type 'boolean) 57 :type 'boolean
58 :safe #'booleanp)
58 59
59(defcustom nxml-sexp-element-flag t 60(defcustom nxml-sexp-element-flag t
60 "Non-nil means sexp commands treat an element as a single expression." 61 "Non-nil means sexp commands treat an element as a single expression."
61 :version "27.1" ; nil -> t 62 :version "27.1" ; nil -> t
62 :group 'nxml 63 :group 'nxml
63 :type 'boolean) 64 :type 'boolean
65 :safe #'booleanp)
64 66
65(defcustom nxml-slash-auto-complete-flag nil 67(defcustom nxml-slash-auto-complete-flag nil
66 "Non-nil means typing a slash automatically completes the end-tag. 68 "Non-nil means typing a slash automatically completes the end-tag.
67This is used by `nxml-electric-slash'." 69This is used by `nxml-electric-slash'."
68 :group 'nxml 70 :group 'nxml
69 :type 'boolean) 71 :type 'boolean
72 :safe #'booleanp)
70 73
71(defcustom nxml-child-indent 2 74(defcustom nxml-child-indent 2
72 "Indentation for the children of an element relative to the start-tag. 75 "Indentation for the children of an element relative to the start-tag.
73This only applies when the line or lines containing the start-tag contains 76This only applies when the line or lines containing the start-tag contains
74nothing else other than that start-tag." 77nothing else other than that start-tag."
75 :group 'nxml 78 :group 'nxml
76 :type 'integer) 79 :type 'integer
80 :safe #'integerp)
77 81
78(defcustom nxml-attribute-indent 4 82(defcustom nxml-attribute-indent 4
79 "Indentation for the attributes of an element relative to the start-tag. 83 "Indentation for the attributes of an element relative to the start-tag.
@@ -81,12 +85,14 @@ This only applies when the first attribute of a tag starts a line.
81In other cases, the first attribute on one line is indented the same 85In other cases, the first attribute on one line is indented the same
82as the first attribute on the previous line." 86as the first attribute on the previous line."
83 :group 'nxml 87 :group 'nxml
84 :type 'integer) 88 :type 'integer
89 :safe #'integerp)
85 90
86(defcustom nxml-bind-meta-tab-to-complete-flag t 91(defcustom nxml-bind-meta-tab-to-complete-flag t
87 "Non-nil means to use nXML completion in \\[completion-at-point]." 92 "Non-nil means to use nXML completion in \\[completion-at-point]."
88 :group 'nxml 93 :group 'nxml
89 :type 'boolean) 94 :type 'boolean
95 :safe #'booleanp)
90 96
91(defcustom nxml-prefer-utf-16-to-utf-8-flag nil 97(defcustom nxml-prefer-utf-16-to-utf-8-flag nil
92 "Non-nil means prefer UTF-16 to UTF-8 when saving a buffer. 98 "Non-nil means prefer UTF-16 to UTF-8 when saving a buffer.
@@ -94,7 +100,8 @@ This is used only when a buffer does not contain an encoding declaration
94and when its current `buffer-file-coding-system' specifies neither UTF-16 100and when its current `buffer-file-coding-system' specifies neither UTF-16
95nor UTF-8." 101nor UTF-8."
96 :group 'nxml 102 :group 'nxml
97 :type 'boolean) 103 :type 'boolean
104 :safe #'booleanp)
98 105
99(defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type 106(defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type
100 'windows-nt) 107 'windows-nt)
@@ -103,7 +110,8 @@ This is used only for saving a buffer; when reading the byte-order is
103auto-detected. It may be relevant both when there is no encoding declaration 110auto-detected. It may be relevant both when there is no encoding declaration
104and when the encoding declaration specifies `UTF-16'." 111and when the encoding declaration specifies `UTF-16'."
105 :group 'nxml 112 :group 'nxml
106 :type 'boolean) 113 :type 'boolean
114 :safe #'booleanp)
107 115
108(defcustom nxml-default-buffer-file-coding-system nil 116(defcustom nxml-default-buffer-file-coding-system nil
109 "Default value for `buffer-file-coding-system' for a buffer for a new file. 117 "Default value for `buffer-file-coding-system' for a buffer for a new file.
@@ -112,13 +120,15 @@ A value of nil means use the default value of
112A buffer's `buffer-file-coding-system' affects what 120A buffer's `buffer-file-coding-system' affects what
113\\[nxml-insert-xml-declaration] inserts." 121\\[nxml-insert-xml-declaration] inserts."
114 :group 'nxml 122 :group 'nxml
115 :type 'coding-system) 123 :type 'coding-system
124 :safe #'coding-system-p)
116 125
117(defcustom nxml-auto-insert-xml-declaration-flag nil 126(defcustom nxml-auto-insert-xml-declaration-flag nil
118 "Non-nil means automatically insert an XML declaration in a new file. 127 "Non-nil means automatically insert an XML declaration in a new file.
119The XML declaration is inserted using `nxml-insert-xml-declaration'." 128The XML declaration is inserted using `nxml-insert-xml-declaration'."
120 :group 'nxml 129 :group 'nxml
121 :type 'boolean) 130 :type 'boolean
131 :safe #'booleanp)
122 132
123(defface nxml-delimited-data 133(defface nxml-delimited-data
124 '((t (:inherit font-lock-doc-face))) 134 '((t (:inherit font-lock-doc-face)))
diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el
index 147efed0057..0b7d1e454c3 100644
--- a/lisp/obsolete/nnir.el
+++ b/lisp/obsolete/nnir.el
@@ -504,7 +504,6 @@ Add an entry here when adding a new search engine.")
504 ,@(mapcar (lambda (elem) (list 'const (car elem))) 504 ,@(mapcar (lambda (elem) (list 'const (car elem)))
505 nnir-engines))))) 505 nnir-engines)))))
506 506
507
508(defmacro nnir-add-result (dirnam artno score prefix server artlist) 507(defmacro nnir-add-result (dirnam artno score prefix server artlist)
509 "Construct a result vector and add it to ARTLIST. 508 "Construct a result vector and add it to ARTLIST.
510DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to 509DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index 2a2a4978c62..d047dd543c2 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -95,6 +95,12 @@
95 :prefix "perl-" 95 :prefix "perl-"
96 :group 'languages) 96 :group 'languages)
97 97
98(defface perl-non-scalar-variable
99 '((t :inherit font-lock-variable-name-face :underline t))
100 "Face used for non-scalar variables."
101 :version "28.1"
102 :group 'perl)
103
98(defvar perl-mode-abbrev-table nil 104(defvar perl-mode-abbrev-table nil
99 "Abbrev table in use in perl-mode buffers.") 105 "Abbrev table in use in perl-mode buffers.")
100(define-abbrev-table 'perl-mode-abbrev-table ()) 106(define-abbrev-table 'perl-mode-abbrev-table ())
@@ -187,11 +193,12 @@
187 ;; 193 ;;
188 ;; Fontify function, variable and file name references. 194 ;; Fontify function, variable and file name references.
189 ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face) 195 ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face)
190 ;; Additionally underline non-scalar variables. Maybe this is a bad idea. 196 ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable'
197 ;; will underline them by default.
191 ;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face) 198 ;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face)
192 ("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face) 199 ("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face)
193 ("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)" 200 ("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)"
194 (2 (cons font-lock-variable-name-face '(underline)))) 201 (2 'perl-non-scalar-variable))
195 ("<\\(\\sw+\\)>" 1 font-lock-constant-face) 202 ("<\\(\\sw+\\)>" 1 font-lock-constant-face)
196 ;; 203 ;;
197 ;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'. 204 ;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'.
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 06966f33b72..768cd58ae44 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -928,6 +928,7 @@ if one already exists."
928;;;###autoload 928;;;###autoload
929(defun project-async-shell-command () 929(defun project-async-shell-command ()
930 "Run `async-shell-command' in the current project's root directory." 930 "Run `async-shell-command' in the current project's root directory."
931 (declare (interactive-only async-shell-command))
931 (interactive) 932 (interactive)
932 (let ((default-directory (project-root (project-current t)))) 933 (let ((default-directory (project-root (project-current t))))
933 (call-interactively #'async-shell-command))) 934 (call-interactively #'async-shell-command)))
@@ -935,6 +936,7 @@ if one already exists."
935;;;###autoload 936;;;###autoload
936(defun project-shell-command () 937(defun project-shell-command ()
937 "Run `shell-command' in the current project's root directory." 938 "Run `shell-command' in the current project's root directory."
939 (declare (interactive-only shell-command))
938 (interactive) 940 (interactive)
939 (let ((default-directory (project-root (project-current t)))) 941 (let ((default-directory (project-root (project-current t))))
940 (call-interactively #'shell-command))) 942 (call-interactively #'shell-command)))
@@ -972,6 +974,7 @@ loop using the command \\[fileloop-continue]."
972;;;###autoload 974;;;###autoload
973(defun project-compile () 975(defun project-compile ()
974 "Run `compile' in the project root." 976 "Run `compile' in the project root."
977 (declare (interactive-only compile))
975 (interactive) 978 (interactive)
976 (let ((default-directory (project-root (project-current t)))) 979 (let ((default-directory (project-root (project-current t))))
977 (call-interactively #'compile))) 980 (call-interactively #'compile)))
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index a417de32640..cc045a1b2d1 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -1556,7 +1556,7 @@ with your script for an edit-interpret-debug cycle."
1556 (sh-set-shell 1556 (sh-set-shell
1557 (cond ((save-excursion 1557 (cond ((save-excursion
1558 (goto-char (point-min)) 1558 (goto-char (point-min))
1559 (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^ \t\n]+\\)")) 1559 (looking-at auto-mode-interpreter-regexp))
1560 (match-string 2)) 1560 (match-string 2))
1561 ((not buffer-file-name) sh-shell-file) 1561 ((not buffer-file-name) sh-shell-file)
1562 ;; Checks that use `buffer-file-name' follow. 1562 ;; Checks that use `buffer-file-name' follow.
@@ -2927,8 +2927,8 @@ option followed by a colon `:' if the option accepts an argument."
2927(put 'sh-assignment 'delete-selection t) 2927(put 'sh-assignment 'delete-selection t)
2928(defun sh-assignment (arg) 2928(defun sh-assignment (arg)
2929 "Remember preceding identifier for future completion and do self-insert." 2929 "Remember preceding identifier for future completion and do self-insert."
2930 (interactive "p")
2931 (declare (obsolete nil "27.1")) 2930 (declare (obsolete nil "27.1"))
2931 (interactive "p")
2932 (self-insert-command arg) 2932 (self-insert-command arg)
2933 (sh--assignment-collect)) 2933 (sh--assignment-collect))
2934 2934
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index b6778de807d..898cb4fb4c1 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -967,16 +967,15 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
967 (let ((inhibit-read-only t) 967 (let ((inhibit-read-only t)
968 (buffer-undo-list t)) 968 (buffer-undo-list t))
969 (save-excursion 969 (save-excursion
970 (erase-buffer)
971 (condition-case err 970 (condition-case err
972 (xref--insert-xrefs 971 (let ((alist (xref--analyze (funcall xref--fetcher))))
973 (xref--analyze (funcall xref--fetcher))) 972 (erase-buffer)
973 (xref--insert-xrefs alist))
974 (user-error 974 (user-error
975 (insert 975 (insert
976 (propertize 976 (propertize
977 (error-message-string err) 977 (error-message-string err)
978 'face 'error)))) 978 'face 'error)))))))
979 (goto-char (point-min)))))
980 979
981(defun xref-show-definitions-buffer (fetcher alist) 980(defun xref-show-definitions-buffer (fetcher alist)
982 "Show the definitions list in a regular window. 981 "Show the definitions list in a regular window.
@@ -1001,8 +1000,12 @@ When only one definition found, jump to it right away instead."
1001When there is more than one definition, split the selected window 1000When there is more than one definition, split the selected window
1002and show the list in a small window at the bottom. And use a 1001and show the list in a small window at the bottom. And use a
1003local keymap that binds `RET' to `xref-quit-and-goto-xref'." 1002local keymap that binds `RET' to `xref-quit-and-goto-xref'."
1004 (let ((xrefs (funcall fetcher)) 1003 (let* ((xrefs (funcall fetcher))
1005 (dd default-directory)) 1004 (dd default-directory)
1005 ;; XXX: Make percentage customizable maybe?
1006 (max-height (/ (window-height) 2))
1007 (size-fun (lambda (window)
1008 (fit-window-to-buffer window max-height))))
1006 (cond 1009 (cond
1007 ((not (cdr xrefs)) 1010 ((not (cdr xrefs))
1008 (xref-pop-to-location (car xrefs) 1011 (xref-pop-to-location (car xrefs)
@@ -1013,7 +1016,8 @@ local keymap that binds `RET' to `xref-quit-and-goto-xref'."
1013 (xref--transient-buffer-mode) 1016 (xref--transient-buffer-mode)
1014 (xref--show-common-initialize (xref--analyze xrefs) fetcher alist) 1017 (xref--show-common-initialize (xref--analyze xrefs) fetcher alist)
1015 (pop-to-buffer (current-buffer) 1018 (pop-to-buffer (current-buffer)
1016 '(display-buffer-in-direction . ((direction . below)))) 1019 `(display-buffer-in-direction . ((direction . below)
1020 (window-height . ,size-fun))))
1017 (current-buffer)))))) 1021 (current-buffer))))))
1018 1022
1019(define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom 1023(define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom
diff --git a/lisp/replace.el b/lisp/replace.el
index d41dc98a0d9..db5b340631a 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -866,13 +866,10 @@ If nil, uses `regexp-history'."
866 ;; Do not automatically add default to the history for empty input. 866 ;; Do not automatically add default to the history for empty input.
867 (history-add-new-input nil) 867 (history-add-new-input nil)
868 (input (read-from-minibuffer 868 (input (read-from-minibuffer
869 (cond ((string-match-p ":[ \t]*\\'" prompt) 869 (if (string-match-p ":[ \t]*\\'" prompt)
870 prompt) 870 prompt
871 ((and default (> (length default) 0)) 871 (format-prompt prompt (and (length> default 0)
872 (format "%s (default %s): " prompt 872 (query-replace-descr default))))
873 (query-replace-descr default)))
874 (t
875 (format "%s: " prompt)))
876 nil nil nil (or history 'regexp-history) suggestions t))) 873 nil nil nil (or history 'regexp-history) suggestions t)))
877 (if (equal input "") 874 (if (equal input "")
878 ;; Return the default value when the user enters empty input. 875 ;; Return the default value when the user enters empty input.
@@ -2428,23 +2425,27 @@ It is called with three arguments, as if it were
2428 (overlay-put replace-overlay 'priority 1001) ;higher than lazy overlays 2425 (overlay-put replace-overlay 'priority 1001) ;higher than lazy overlays
2429 (overlay-put replace-overlay 'face 'query-replace))) 2426 (overlay-put replace-overlay 'face 'query-replace)))
2430 2427
2431 (when (and query-replace-highlight-submatches 2428 (when (and query-replace-highlight-submatches regexp-flag)
2432 regexp-flag)
2433 (mapc 'delete-overlay replace-submatches-overlays) 2429 (mapc 'delete-overlay replace-submatches-overlays)
2434 (setq replace-submatches-overlays nil) 2430 (setq replace-submatches-overlays nil)
2435 (let ((submatch-data (cddr (butlast (match-data t)))) 2431 ;; 'cddr' removes whole expression match from match-data
2432 (let ((submatch-data (cddr (match-data t)))
2436 (group 0) 2433 (group 0)
2437 ov face) 2434 b e ov face)
2438 (while submatch-data 2435 (while submatch-data
2439 (setq group (1+ group)) 2436 (setq b (pop submatch-data)
2440 (setq ov (make-overlay (pop submatch-data) (pop submatch-data)) 2437 e (pop submatch-data))
2441 face (intern-soft (format "isearch-group-%d" group))) 2438 (when (and (integer-or-marker-p b)
2442 ;; Recycle faces from beginning. 2439 (integer-or-marker-p e))
2443 (unless (facep face) 2440 (setq ov (make-overlay b e)
2444 (setq group 1 face 'isearch-group-1)) 2441 group (1+ group)
2445 (overlay-put ov 'face face) 2442 face (intern-soft (format "isearch-group-%d" group)))
2446 (overlay-put ov 'priority 1002) 2443 ;; Recycle faces from beginning
2447 (push ov replace-submatches-overlays)))) 2444 (unless (facep face)
2445 (setq group 1 face 'isearch-group-1))
2446 (overlay-put ov 'face face)
2447 (overlay-put ov 'priority 1002)
2448 (push ov replace-submatches-overlays)))))
2448 2449
2449 (if query-replace-lazy-highlight 2450 (if query-replace-lazy-highlight
2450 (let ((isearch-string search-string) 2451 (let ((isearch-string search-string)
diff --git a/lisp/simple.el b/lisp/simple.el
index 37c0885dcc5..8d4e4a7a6bb 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -820,9 +820,10 @@ With ARG, perform this action that many times."
820 (delete-horizontal-space t) 820 (delete-horizontal-space t)
821 (unless arg 821 (unless arg
822 (setq arg 1)) 822 (setq arg 1))
823 (dotimes (_ arg) 823 (let ((electric-indent-mode nil))
824 (newline nil t) 824 (dotimes (_ arg)
825 (indent-according-to-mode))) 825 (newline nil t)
826 (indent-according-to-mode))))
826 827
827(defun reindent-then-newline-and-indent () 828(defun reindent-then-newline-and-indent ()
828 "Reindent current line, insert newline, then indent the new line. 829 "Reindent current line, insert newline, then indent the new line.
@@ -832,7 +833,8 @@ In programming language modes, this is the same as TAB.
832In some text modes, where TAB inserts a tab, this indents to the 833In some text modes, where TAB inserts a tab, this indents to the
833column specified by the function `current-left-margin'." 834column specified by the function `current-left-margin'."
834 (interactive "*") 835 (interactive "*")
835 (let ((pos (point))) 836 (let ((pos (point))
837 (electric-indent-mode nil))
836 ;; Be careful to insert the newline before indenting the line. 838 ;; Be careful to insert the newline before indenting the line.
837 ;; Otherwise, the indentation might be wrong. 839 ;; Otherwise, the indentation might be wrong.
838 (newline) 840 (newline)
@@ -7338,10 +7340,7 @@ even beep.)"
7338 ;; of the kill before killing. 7340 ;; of the kill before killing.
7339 (let ((opoint (point)) 7341 (let ((opoint (point))
7340 (kill-whole-line (and kill-whole-line (bolp))) 7342 (kill-whole-line (and kill-whole-line (bolp)))
7341 (orig-y (cdr (nth 2 (posn-at-point)))) 7343 (orig-vlnum (cdr (nth 6 (posn-at-point)))))
7342 ;; FIXME: This tolerance should be zero! It isn't due to a
7343 ;; bug in posn-at-point, see bug#45837.
7344 (tol (/ (line-pixel-height) 2)))
7345 (if arg 7344 (if arg
7346 (vertical-motion (prefix-numeric-value arg)) 7345 (vertical-motion (prefix-numeric-value arg))
7347 (end-of-visual-line 1) 7346 (end-of-visual-line 1)
@@ -7352,8 +7351,8 @@ even beep.)"
7352 ;; end-of-visual-line didn't overshoot due to complications 7351 ;; end-of-visual-line didn't overshoot due to complications
7353 ;; like display or overlay strings, intangible text, etc.: 7352 ;; like display or overlay strings, intangible text, etc.:
7354 ;; otherwise, we don't want to kill a character that's 7353 ;; otherwise, we don't want to kill a character that's
7355 ;; unrelated to the place where the visual line wrapped. 7354 ;; unrelated to the place where the visual line wraps.
7356 (and (< (abs (- (cdr (nth 2 (posn-at-point))) orig-y)) tol) 7355 (and (= (cdr (nth 6 (posn-at-point))) orig-vlnum)
7357 ;; Make sure we delete the character where the line wraps 7356 ;; Make sure we delete the character where the line wraps
7358 ;; under visual-line-mode, be it whitespace or a 7357 ;; under visual-line-mode, be it whitespace or a
7359 ;; character whose category set allows to wrap at it. 7358 ;; character whose category set allows to wrap at it.
diff --git a/lisp/startup.el b/lisp/startup.el
index 9325ab5acff..09635b12990 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1180,6 +1180,7 @@ please check its value")
1180 ;; are dependencies between them. 1180 ;; are dependencies between them.
1181 (nreverse custom-delayed-init-variables)) 1181 (nreverse custom-delayed-init-variables))
1182 (mapc #'custom-reevaluate-setting custom-delayed-init-variables) 1182 (mapc #'custom-reevaluate-setting custom-delayed-init-variables)
1183 (setq custom-delayed-init-variables nil)
1183 1184
1184 ;; Warn for invalid user name. 1185 ;; Warn for invalid user name.
1185 (when init-file-user 1186 (when init-file-user
@@ -1309,12 +1310,6 @@ please check its value")
1309 (startup--setup-quote-display) 1310 (startup--setup-quote-display)
1310 (setq internal--text-quoting-flag t)) 1311 (setq internal--text-quoting-flag t))
1311 1312
1312 ;; Re-evaluate again the predefined variables whose initial value
1313 ;; depends on the runtime context, in case some of them depend on
1314 ;; the window-system features. Example: blink-cursor-mode.
1315 (mapc #'custom-reevaluate-setting custom-delayed-init-variables)
1316 (setq custom-delayed-init-variables nil)
1317
1318 (normal-erase-is-backspace-setup-frame) 1313 (normal-erase-is-backspace-setup-frame)
1319 1314
1320 ;; Register default TTY colors for the case the terminal hasn't a 1315 ;; Register default TTY colors for the case the terminal hasn't a
@@ -1495,13 +1490,13 @@ to reading the init file), or afterwards when the user first
1495opens a graphical frame. 1490opens a graphical frame.
1496 1491
1497This can set the values of `menu-bar-mode', `tool-bar-mode', 1492This can set the values of `menu-bar-mode', `tool-bar-mode',
1498`tab-bar-mode', and `no-blinking-cursor', as well as the `cursor' face. 1493`tab-bar-mode', and `blink-cursor-mode', as well as the `cursor' face.
1499Changed settings will be marked as \"CHANGED outside of Customize\"." 1494Changed settings will be marked as \"CHANGED outside of Customize\"."
1500 (let ((no-vals '("no" "off" "false" "0")) 1495 (let ((no-vals '("no" "off" "false" "0"))
1501 (settings '(("menuBar" "MenuBar" menu-bar-mode nil) 1496 (settings '(("menuBar" "MenuBar" menu-bar-mode nil)
1502 ("toolBar" "ToolBar" tool-bar-mode nil) 1497 ("toolBar" "ToolBar" tool-bar-mode nil)
1503 ("scrollBar" "ScrollBar" scroll-bar-mode nil) 1498 ("scrollBar" "ScrollBar" scroll-bar-mode nil)
1504 ("cursorBlink" "CursorBlink" no-blinking-cursor t)))) 1499 ("cursorBlink" "CursorBlink" blink-cursor-mode nil))))
1505 (dolist (x settings) 1500 (dolist (x settings)
1506 (if (member (x-get-resource (nth 0 x) (nth 1 x)) no-vals) 1501 (if (member (x-get-resource (nth 0 x) (nth 1 x)) no-vals)
1507 (set (nth 2 x) (nth 3 x))))) 1502 (set (nth 2 x) (nth 3 x)))))
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index 5f4dd9ef587..94e9d5c5828 100644
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -120,6 +120,15 @@ The properties returned may include `top', `left', `height', and `width'."
120(define-key global-map [?\s-d] 'isearch-repeat-backward) 120(define-key global-map [?\s-d] 'isearch-repeat-backward)
121(define-key global-map [?\s-e] 'isearch-yank-kill) 121(define-key global-map [?\s-e] 'isearch-yank-kill)
122(define-key global-map [?\s-f] 'isearch-forward) 122(define-key global-map [?\s-f] 'isearch-forward)
123(define-key esc-map [?\s-f] 'isearch-forward-regexp)
124(define-key minibuffer-local-isearch-map [?\s-f]
125 'isearch-forward-exit-minibuffer)
126(define-key isearch-mode-map [?\s-f] 'isearch-repeat-forward)
127(define-key global-map [?\s-F] 'isearch-backward)
128(define-key esc-map [?\s-F] 'isearch-backward-regexp)
129(define-key minibuffer-local-isearch-map [?\s-F]
130 'isearch-reverse-exit-minibuffer)
131(define-key isearch-mode-map [?\s-F] 'isearch-repeat-backward)
123(define-key global-map [?\s-g] 'isearch-repeat-forward) 132(define-key global-map [?\s-g] 'isearch-repeat-forward)
124(define-key global-map [?\s-h] 'ns-do-hide-emacs) 133(define-key global-map [?\s-h] 'ns-do-hide-emacs)
125(define-key global-map [?\s-H] 'ns-do-hide-others) 134(define-key global-map [?\s-H] 'ns-do-hide-others)
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index 98d3a3856ea..820ee38d101 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -159,7 +159,8 @@
159;; ;; This should be before other entries that may return t 159;; ;; This should be before other entries that may return t
160;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries) 160;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries)
161;; 161;;
162;; This module recognizes entries of the form 162;; This module recognizes entries of the form (defined by
163;; `remember-diary-regexp')
163;; 164;;
164;; DIARY: .... 165;; DIARY: ....
165;; 166;;
@@ -410,13 +411,24 @@ The default emulates `current-time-string' for backward compatibility."
410 :group 'remember 411 :group 'remember
411 :version "27.1") 412 :version "27.1")
412 413
414(defcustom remember-text-format-function nil
415 "The function to format the remembered text.
416The function receives the remembered text as argument and should
417return the text to be remembered."
418 :type '(choice (const nil) function)
419 :group 'remember
420 :version "28.1")
421
413(defun remember-append-to-file () 422(defun remember-append-to-file ()
414 "Remember, with description DESC, the given TEXT." 423 "Remember, with description DESC, the given TEXT."
415 (let* ((text (buffer-string)) 424 (let* ((text (buffer-string))
416 (desc (remember-buffer-desc)) 425 (desc (remember-buffer-desc))
417 (remember-text (concat "\n" remember-leader-text 426 (remember-text (concat "\n"
418 (format-time-string remember-time-format) 427 (if remember-text-format-function
419 " (" desc ")\n\n" text 428 (funcall remember-text-format-function text)
429 (concat remember-leader-text
430 (format-time-string remember-time-format)
431 " (" desc ")\n\n" text))
420 (save-excursion (goto-char (point-max)) 432 (save-excursion (goto-char (point-max))
421 (if (bolp) nil "\n")))) 433 (if (bolp) nil "\n"))))
422 (buf (find-buffer-visiting remember-data-file))) 434 (buf (find-buffer-visiting remember-data-file)))
@@ -532,17 +544,28 @@ If this is nil, then `diary-file' will be used instead."
532 544
533(autoload 'diary-make-entry "diary-lib") 545(autoload 'diary-make-entry "diary-lib")
534 546
547(defcustom remember-diary-regexp "^DIARY:\\s-*\\(.+\\)"
548 "Regexp to extract diary entries."
549 :type 'regexp
550 :version "28.1")
551
552(defvar diary-file)
553
535;;;###autoload 554;;;###autoload
536(defun remember-diary-extract-entries () 555(defun remember-diary-extract-entries ()
537 "Extract diary entries from the region." 556 "Extract diary entries from the region based on `remember-diary-regexp'."
538 (save-excursion 557 (save-excursion
539 (goto-char (point-min)) 558 (goto-char (point-min))
540 (let (list) 559 (let (list)
541 (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t) 560 (while (re-search-forward remember-diary-regexp nil t)
542 (push (remember-diary-convert-entry (match-string 1)) list)) 561 (push (remember-diary-convert-entry (match-string 1)) list))
543 (when list 562 (when list
544 (diary-make-entry (mapconcat 'identity list "\n") 563 (diary-make-entry (mapconcat 'identity list "\n")
545 nil remember-diary-file)) 564 nil remember-diary-file)
565 (when remember-save-after-remembering
566 (with-current-buffer (find-buffer-visiting (or remember-diary-file
567 diary-file))
568 (save-buffer))))
546 nil))) ;; Continue processing 569 nil))) ;; Continue processing
547 570
548;;; Internal Functions: 571;;; Internal Functions:
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index d3ba941fcc2..c52fcfcc051 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -52,8 +52,30 @@
52 52
53;;; Code: 53;;; Code:
54 54
55(require 'cl-lib)
55(provide 'thingatpt) 56(provide 'thingatpt)
56 57
58(defvar thing-at-point-provider-alist nil
59 "Alist of providers for returning a \"thing\" at point.
60This variable can be set globally, or appended to buffer-locally
61by modes, to provide functions that will return a \"thing\" at
62point. The first provider for the \"thing\" that returns a
63non-nil value wins.
64
65For instance, a major mode could say:
66
67\(setq-local thing-at-point-provider-alist
68 (append thing-at-point-provider-alist
69 \\='((url . my-mode--url-at-point))))
70
71to provide a way to get an `url' at point in that mode. The
72provider functions are called with no parameters at the point in
73question.
74
75\"things\" include `symbol', `list', `sexp', `defun', `filename',
76`url', `email', `uuid', `word', `sentence', `whitespace', `line',
77and `page'.")
78
57;; Basic movement 79;; Basic movement
58 80
59;;;###autoload 81;;;###autoload
@@ -143,11 +165,18 @@ strip text properties from the return value.
143See the file `thingatpt.el' for documentation on how to define 165See the file `thingatpt.el' for documentation on how to define
144a symbol as a valid THING." 166a symbol as a valid THING."
145 (let ((text 167 (let ((text
146 (if (get thing 'thing-at-point) 168 (cond
147 (funcall (get thing 'thing-at-point)) 169 ((cl-loop for (pthing . function) in thing-at-point-provider-alist
170 when (eq pthing thing)
171 for result = (funcall function)
172 when result
173 return result))
174 ((get thing 'thing-at-point)
175 (funcall (get thing 'thing-at-point)))
176 (t
148 (let ((bounds (bounds-of-thing-at-point thing))) 177 (let ((bounds (bounds-of-thing-at-point thing)))
149 (when bounds 178 (when bounds
150 (buffer-substring (car bounds) (cdr bounds))))))) 179 (buffer-substring (car bounds) (cdr bounds))))))))
151 (when (and text no-properties (sequencep text)) 180 (when (and text no-properties (sequencep text))
152 (set-text-properties 0 (length text) nil text)) 181 (set-text-properties 0 (length text) nil text))
153 text)) 182 text))
@@ -218,6 +247,15 @@ The bounds of THING are determined by `bounds-of-thing-at-point'."
218 247
219(put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp) 248(put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp)
220 249
250;; Symbols
251
252(put 'symbol 'beginning-op 'thing-at-point--beginning-of-symbol)
253
254(defun thing-at-point--beginning-of-symbol ()
255 "Move point to the beginning of the current symbol."
256 (and (re-search-backward "\\(\\sw\\|\\s_\\)+")
257 (skip-syntax-backward "w_")))
258
221;; Lists 259;; Lists
222 260
223(put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point) 261(put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point)
diff --git a/lisp/type-break.el b/lisp/type-break.el
index 84c240c9f8c..a6d5cd01702 100644
--- a/lisp/type-break.el
+++ b/lisp/type-break.el
@@ -487,7 +487,7 @@ Return nil if the file is missing or if the time is not a Lisp time value."
487 (goto-char (point-min)) 487 (goto-char (point-min))
488 (read (current-buffer))) 488 (read (current-buffer)))
489 (end-of-file 489 (end-of-file
490 (error "End of file in `%s'" file)))))))) 490 (warn "End of file in `%s'" file))))))))
491 491
492(defun type-break-get-previous-count () 492(defun type-break-get-previous-count ()
493 "Get previous keystroke count from `type-break-file-name'. 493 "Get previous keystroke count from `type-break-file-name'.
@@ -505,7 +505,7 @@ integer."
505 (forward-line 1) 505 (forward-line 1)
506 (read (current-buffer))) 506 (read (current-buffer)))
507 (end-of-file 507 (end-of-file
508 (error "End of file in `%s'" file))))))) 508 (warn "End of file in `%s'" file)))))))
509 file 509 file
510 0))) 510 0)))
511 511
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 6c96d8ca7c4..bc9f11202b1 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -2392,6 +2392,7 @@ If it contains `file', show short logs for files.
2392Not all VC backends support short logs!") 2392Not all VC backends support short logs!")
2393 2393
2394(defvar log-view-vc-fileset) 2394(defvar log-view-vc-fileset)
2395(defvar log-view-message-re)
2395 2396
2396(defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return) 2397(defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return)
2397 "Insert at the end of the current buffer buttons to show more log entries. 2398 "Insert at the end of the current buffer buttons to show more log entries.
@@ -2401,21 +2402,32 @@ Does nothing if IS-START-REVISION is non-nil, or if LIMIT is nil,
2401or if PL-RETURN is `limit-unsupported'." 2402or if PL-RETURN is `limit-unsupported'."
2402 (when (and limit (not (eq 'limit-unsupported pl-return)) 2403 (when (and limit (not (eq 'limit-unsupported pl-return))
2403 (not is-start-revision)) 2404 (not is-start-revision))
2404 (goto-char (point-max)) 2405 (let ((entries 0))
2405 (insert "\n") 2406 (goto-char (point-min))
2406 (insert-text-button "Show 2X entries" 2407 (while (re-search-forward log-view-message-re nil t)
2407 'action (lambda (&rest _ignore) 2408 (cl-incf entries))
2408 (vc-print-log-internal 2409 ;; If we got fewer entries than we asked for, then displaying
2409 log-view-vc-backend log-view-vc-fileset 2410 ;; the "more" buttons isn't useful.
2410 working-revision nil (* 2 limit))) 2411 (when (>= entries limit)
2411 'help-echo "Show the log again, and double the number of log entries shown") 2412 (goto-char (point-max))
2412 (insert " ") 2413 (insert "\n")
2413 (insert-text-button "Show unlimited entries" 2414 (insert-text-button
2414 'action (lambda (&rest _ignore) 2415 "Show 2X entries"
2415 (vc-print-log-internal 2416 'action (lambda (&rest _ignore)
2416 log-view-vc-backend log-view-vc-fileset 2417 (vc-print-log-internal
2417 working-revision nil nil)) 2418 log-view-vc-backend log-view-vc-fileset
2418 'help-echo "Show the log again, including all entries"))) 2419 working-revision nil (* 2 limit)))
2420 'help-echo
2421 "Show the log again, and double the number of log entries shown")
2422 (insert " ")
2423 (insert-text-button
2424 "Show unlimited entries"
2425 'action (lambda (&rest _ignore)
2426 (vc-print-log-internal
2427 log-view-vc-backend log-view-vc-fileset
2428 working-revision nil nil))
2429 'help-echo "Show the log again, including all entries")
2430 (insert "\n")))))
2419 2431
2420(defun vc-print-log-internal (backend files working-revision 2432(defun vc-print-log-internal (backend files working-revision
2421 &optional is-start-revision limit type) 2433 &optional is-start-revision limit type)
diff --git a/lisp/version.el b/lisp/version.el
index fcfc2f8b806..3a3093fdd4a 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -29,14 +29,12 @@
29(defconst emacs-major-version 29(defconst emacs-major-version
30 (progn (string-match "^[0-9]+" emacs-version) 30 (progn (string-match "^[0-9]+" emacs-version)
31 (string-to-number (match-string 0 emacs-version))) 31 (string-to-number (match-string 0 emacs-version)))
32 "Major version number of this version of Emacs. 32 "Major version number of this version of Emacs.")
33This variable first existed in version 19.23.")
34 33
35(defconst emacs-minor-version 34(defconst emacs-minor-version
36 (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) 35 (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
37 (string-to-number (match-string 1 emacs-version))) 36 (string-to-number (match-string 1 emacs-version)))
38 "Minor version number of this version of Emacs. 37 "Minor version number of this version of Emacs.")
39This variable first existed in version 19.23.")
40 38
41(defconst emacs-build-system (system-name) 39(defconst emacs-build-system (system-name)
42 "Name of the system on which Emacs was built, or nil if not available.") 40 "Name of the system on which Emacs was built, or nil if not available.")
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 7dda04eda21..68a0d3d2356 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -4026,17 +4026,19 @@ is inline."
4026 4026
4027;;; The `color' Widget. 4027;;; The `color' Widget.
4028 4028
4029;; Fixme: match
4030(define-widget 'color 'editable-field 4029(define-widget 'color 'editable-field
4031 "Choose a color name (with sample)." 4030 "Choose a color name (with sample)."
4032 :format "%{%t%}: %v (%{sample%})\n" 4031 :format "%{%t%}: %v (%{sample%})\n"
4033 :value-create 'widget-color-value-create 4032 :value-create 'widget-color-value-create
4034 :size 10 4033 :size (1+ (apply #'max 13 ; Longest RGB hex string.
4034 (mapcar #'length (defined-colors))))
4035 :tag "Color" 4035 :tag "Color"
4036 :value "black" 4036 :value "black"
4037 :completions (or facemenu-color-alist (defined-colors)) 4037 :completions (or facemenu-color-alist (defined-colors))
4038 :sample-face-get 'widget-color-sample-face-get 4038 :sample-face-get 'widget-color-sample-face-get
4039 :notify 'widget-color-notify 4039 :notify 'widget-color-notify
4040 :match #'widget-color-match
4041 :validate #'widget-color-validate
4040 :action 'widget-color-action) 4042 :action 'widget-color-action)
4041 4043
4042(defun widget-color-value-create (widget) 4044(defun widget-color-value-create (widget)
@@ -4085,6 +4087,19 @@ is inline."
4085 (overlay-put (widget-get widget :sample-overlay) 4087 (overlay-put (widget-get widget :sample-overlay)
4086 'face (widget-apply widget :sample-face-get)) 4088 'face (widget-apply widget :sample-face-get))
4087 (widget-default-notify widget child event)) 4089 (widget-default-notify widget child event))
4090
4091(defun widget-color-match (_widget value)
4092 "Non-nil if VALUE is a defined color or a RGB hex string."
4093 (and (stringp value)
4094 (or (color-defined-p value)
4095 (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value))))
4096
4097(defun widget-color-validate (widget)
4098 "Check that WIDGET's value is a valid color."
4099 (let ((value (widget-value widget)))
4100 (unless (widget-color-match widget value)
4101 (widget-put widget :error (format "Invalid color: %S" value))
4102 widget)))
4088 4103
4089;;; The Help Echo 4104;;; The Help Echo
4090 4105
diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4
index 475fa15d6bd..0dfb2da9a6a 100644
--- a/m4/canonicalize.m4
+++ b/m4/canonicalize.m4
@@ -1,4 +1,4 @@
1# canonicalize.m4 serial 35 1# canonicalize.m4 serial 37
2 2
3dnl Copyright (C) 2003-2007, 2009-2021 Free Software Foundation, Inc. 3dnl Copyright (C) 2003-2007, 2009-2021 Free Software Foundation, Inc.
4 4
@@ -78,68 +78,106 @@ AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE],
78# so is the latter. 78# so is the latter.
79AC_DEFUN([gl_FUNC_REALPATH_WORKS], 79AC_DEFUN([gl_FUNC_REALPATH_WORKS],
80[ 80[
81 AC_CHECK_FUNCS_ONCE([realpath]) 81 AC_CHECK_FUNCS_ONCE([realpath lstat])
82 AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles 82 AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
83 AC_CACHE_CHECK([whether realpath works], [gl_cv_func_realpath_works], [ 83 AC_CACHE_CHECK([whether realpath works], [gl_cv_func_realpath_works], [
84 rm -rf conftest.a conftest.d 84 rm -rf conftest.a conftest.d
85 touch conftest.a 85 touch conftest.a
86 # Assume that if we have lstat, we can also check symlinks.
87 if test $ac_cv_func_lstat = yes; then
88 ln -s conftest.a conftest.l
89 fi
86 mkdir conftest.d 90 mkdir conftest.d
87 AC_RUN_IFELSE([ 91 AC_RUN_IFELSE([
88 AC_LANG_PROGRAM([[ 92 AC_LANG_PROGRAM([[
89 ]GL_NOCRASH[ 93 ]GL_NOCRASH[
94 #include <errno.h>
90 #include <stdlib.h> 95 #include <stdlib.h>
91 #include <string.h> 96 #include <string.h>
92 ]], [[ 97 ]], [[
93 int result = 0; 98 int result = 0;
99 /* This test fails on Solaris 10. */
94 { 100 {
95 char *name = realpath ("conftest.a", NULL); 101 char *name = realpath ("conftest.a", NULL);
96 if (!(name && *name == '/')) 102 if (!(name && *name == '/'))
97 result |= 1; 103 result |= 1;
98 free (name); 104 free (name);
99 } 105 }
106 /* This test fails on older versions of Cygwin. */
100 { 107 {
101 char *name = realpath ("conftest.b/../conftest.a", NULL); 108 char *name = realpath ("conftest.b/../conftest.a", NULL);
102 if (name != NULL) 109 if (name != NULL)
103 result |= 2; 110 result |= 2;
104 free (name); 111 free (name);
105 } 112 }
113 /* This test fails on Cygwin 2.9. */
114 #if HAVE_LSTAT
115 {
116 char *name = realpath ("conftest.l/../conftest.a", NULL);
117 if (name != NULL || errno != ENOTDIR)
118 result |= 4;
119 free (name);
120 }
121 #endif
122 /* This test fails on Mac OS X 10.13, OpenBSD 6.0. */
106 { 123 {
107 char *name = realpath ("conftest.a/", NULL); 124 char *name = realpath ("conftest.a/", NULL);
108 if (name != NULL) 125 if (name != NULL)
109 result |= 4; 126 result |= 8;
110 free (name); 127 free (name);
111 } 128 }
129 /* This test fails on AIX 7, Solaris 10. */
112 { 130 {
113 char *name1 = realpath (".", NULL); 131 char *name1 = realpath (".", NULL);
114 char *name2 = realpath ("conftest.d//./..", NULL); 132 char *name2 = realpath ("conftest.d//./..", NULL);
115 if (! name1 || ! name2 || strcmp (name1, name2)) 133 if (! name1 || ! name2 || strcmp (name1, name2))
116 result |= 8; 134 result |= 16;
117 free (name1); 135 free (name1);
118 free (name2); 136 free (name2);
119 } 137 }
138 #ifdef __linux__
139 /* On Linux, // is the same as /. See also double-slash-root.m4.
140 realpath() should respect this.
141 This test fails on musl libc 1.2.2. */
142 {
143 char *name = realpath ("//", NULL);
144 if (! name || strcmp (name, "/"))
145 result |= 32;
146 free (name);
147 }
148 #endif
120 return result; 149 return result;
121 ]]) 150 ]])
122 ], 151 ],
123 [gl_cv_func_realpath_works=yes], 152 [gl_cv_func_realpath_works=yes],
124 [gl_cv_func_realpath_works=no], 153 [case $? in
154 32) gl_cv_func_realpath_works=nearly ;;
155 *) gl_cv_func_realpath_works=no ;;
156 esac
157 ],
125 [case "$host_os" in 158 [case "$host_os" in
126 # Guess yes on glibc systems. 159 # Guess yes on glibc systems.
127 *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;; 160 *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;;
128 # Guess yes on musl systems. 161 # Guess 'nearly' on musl systems.
129 *-musl*) gl_cv_func_realpath_works="guessing yes" ;; 162 *-musl*) gl_cv_func_realpath_works="guessing nearly" ;;
163 # Guess no on Cygwin.
164 cygwin*) gl_cv_func_realpath_works="guessing no" ;;
130 # Guess no on native Windows. 165 # Guess no on native Windows.
131 mingw*) gl_cv_func_realpath_works="guessing no" ;; 166 mingw*) gl_cv_func_realpath_works="guessing no" ;;
132 # If we don't know, obey --enable-cross-guesses. 167 # If we don't know, obey --enable-cross-guesses.
133 *) gl_cv_func_realpath_works="$gl_cross_guess_normal" ;; 168 *) gl_cv_func_realpath_works="$gl_cross_guess_normal" ;;
134 esac 169 esac
135 ]) 170 ])
136 rm -rf conftest.a conftest.d 171 rm -rf conftest.a conftest.l conftest.d
137 ]) 172 ])
138 case "$gl_cv_func_realpath_works" in 173 case "$gl_cv_func_realpath_works" in
139 *yes) 174 *yes)
140 AC_DEFINE([FUNC_REALPATH_WORKS], [1], [Define to 1 if realpath() 175 AC_DEFINE([FUNC_REALPATH_WORKS], [1],
141 can malloc memory, always gives an absolute path, and handles 176 [Define to 1 if realpath() can malloc memory, always gives an absolute path, and handles leading slashes and a trailing slash correctly.])
142 trailing slash correctly.]) 177 ;;
178 *nearly)
179 AC_DEFINE([FUNC_REALPATH_NEARLY_WORKS], [1],
180 [Define to 1 if realpath() can malloc memory, always gives an absolute path, and handles a trailing slash correctly.])
143 ;; 181 ;;
144 esac 182 esac
145]) 183])
diff --git a/m4/extensions.m4 b/m4/extensions.m4
index f7333acbd4f..5792a9557a8 100644
--- a/m4/extensions.m4
+++ b/m4/extensions.m4
@@ -1,4 +1,4 @@
1# serial 21 -*- Autoconf -*- 1# serial 22 -*- Autoconf -*-
2# Enable extensions on systems that normally disable them. 2# Enable extensions on systems that normally disable them.
3 3
4# Copyright (C) 2003, 2006-2021 Free Software Foundation, Inc. 4# Copyright (C) 2003, 2006-2021 Free Software Foundation, Inc.
@@ -212,4 +212,16 @@ dnl it should only be defined when necessary.
212AC_DEFUN_ONCE([gl_USE_SYSTEM_EXTENSIONS], 212AC_DEFUN_ONCE([gl_USE_SYSTEM_EXTENSIONS],
213[ 213[
214 AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) 214 AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
215
216 dnl On OpenBSD 6.8 with GCC, the include files contain a couple of
217 dnl definitions that are only activated with an explicit -D_ISOC11_SOURCE.
218 dnl That's because this version of GCC (4.2.1) supports the option
219 dnl '-std=gnu99' but not the option '-std=gnu11'.
220 AC_REQUIRE([AC_CANONICAL_HOST])
221 case "$host_os" in
222 openbsd*)
223 AC_DEFINE([_ISOC11_SOURCE], [1],
224 [Define to enable the declarations of ISO C 11 types and functions.])
225 ;;
226 esac
215]) 227])
diff --git a/m4/fchmodat.m4 b/m4/fchmodat.m4
index 09380327799..66c0e308fcc 100644
--- a/m4/fchmodat.m4
+++ b/m4/fchmodat.m4
@@ -1,4 +1,4 @@
1# fchmodat.m4 serial 5 1# fchmodat.m4 serial 6
2dnl Copyright (C) 2004-2021 Free Software Foundation, Inc. 2dnl Copyright (C) 2004-2021 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,
@@ -16,11 +16,9 @@ AC_DEFUN([gl_FUNC_FCHMODAT],
16 HAVE_FCHMODAT=0 16 HAVE_FCHMODAT=0
17 else 17 else
18 AC_CACHE_CHECK( 18 AC_CACHE_CHECK(
19 [whether fchmodat+AT_SYMLINK_NOFOLLOW works on non-symlinks], 19 [whether fchmodat works],
20 [gl_cv_func_fchmodat_works], 20 [gl_cv_func_fchmodat_works],
21 [dnl This test fails on GNU/Linux with glibc 2.31 (but not on 21 [AC_RUN_IFELSE(
22 dnl GNU/kFreeBSD nor GNU/Hurd) and Cygwin 2.9.
23 AC_RUN_IFELSE(
24 [AC_LANG_PROGRAM( 22 [AC_LANG_PROGRAM(
25 [ 23 [
26 AC_INCLUDES_DEFAULT[ 24 AC_INCLUDES_DEFAULT[
@@ -44,27 +42,49 @@ AC_DEFUN([gl_FUNC_FCHMODAT],
44 [[ 42 [[
45 int permissive = S_IRWXU | S_IRWXG | S_IRWXO; 43 int permissive = S_IRWXU | S_IRWXG | S_IRWXO;
46 int desired = S_IRUSR | S_IWUSR; 44 int desired = S_IRUSR | S_IWUSR;
47 static char const f[] = "conftest.fchmodat"; 45 int result = 0;
46 #define file "conftest.fchmodat"
48 struct stat st; 47 struct stat st;
49 if (creat (f, permissive) < 0) 48 if (creat (file, permissive) < 0)
50 return 1; 49 return 1;
51 if (fchmodat (AT_FDCWD, f, desired, AT_SYMLINK_NOFOLLOW) != 0) 50 /* Test whether fchmodat rejects a trailing slash on a non-directory.
51 This test fails on AIX 7.2. */
52 if (fchmodat (AT_FDCWD, file "/", desired, 0) == 0)
53 result |= 2;
54 /* Test whether fchmodat+AT_SYMLINK_NOFOLLOW works on non-symlinks.
55 This test fails on GNU/Linux with glibc 2.31 (but not on
56 GNU/kFreeBSD nor GNU/Hurd) and Cygwin 2.9. */
57 if (fchmodat (AT_FDCWD, file, desired, AT_SYMLINK_NOFOLLOW) != 0)
58 result |= 4;
59 if (stat (file, &st) != 0)
52 return 1; 60 return 1;
53 if (stat (f, &st) != 0) 61 if ((st.st_mode & permissive) != desired)
54 return 1; 62 result |= 4;
55 return ! ((st.st_mode & permissive) == desired); 63 return result;
56 ]])], 64 ]])],
57 [gl_cv_func_fchmodat_works=yes], 65 [gl_cv_func_fchmodat_works=yes],
58 [gl_cv_func_fchmodat_works=no], 66 [case $? in
67 2) gl_cv_func_fchmodat_works='nearly' ;;
68 *) gl_cv_func_fchmodat_works=no ;;
69 esac
70 ],
59 [case "$host_os" in 71 [case "$host_os" in
60 dnl Guess no on Linux with glibc and Cygwin, yes otherwise. 72 # Guess no on Linux with glibc and Cygwin.
61 linux-gnu* | cygwin*) gl_cv_func_fchmodat_works="guessing no" ;; 73 linux-gnu* | cygwin*) gl_cv_func_fchmodat_works="guessing no" ;;
74 # Guess 'nearly' on AIX.
75 aix*) gl_cv_func_fchmodat_works="guessing nearly" ;;
76 # If we don't know, obey --enable-cross-guesses.
62 *) gl_cv_func_fchmodat_works="$gl_cross_guess_normal" ;; 77 *) gl_cv_func_fchmodat_works="$gl_cross_guess_normal" ;;
63 esac 78 esac
64 ]) 79 ])
65 rm -f conftest.fchmodat]) 80 rm -f conftest.fchmodat])
66 case $gl_cv_func_fchmodat_works in 81 case "$gl_cv_func_fchmodat_works" in
67 *yes) ;; 82 *yes) ;;
83 *nearly)
84 AC_DEFINE([HAVE_NEARLY_WORKING_FCHMODAT], [1],
85 [Define to 1 if fchmodat works, except for the trailing slash handling.])
86 REPLACE_FCHMODAT=1
87 ;;
68 *) 88 *)
69 AC_DEFINE([NEED_FCHMODAT_NONSYMLINK_FIX], [1], 89 AC_DEFINE([NEED_FCHMODAT_NONSYMLINK_FIX], [1],
70 [Define to 1 if fchmodat+AT_SYMLINK_NOFOLLOW does not work right on non-symlinks.]) 90 [Define to 1 if fchmodat+AT_SYMLINK_NOFOLLOW does not work right on non-symlinks.])
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index 535359b2cf6..f2eff10de6d 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -39,11 +39,12 @@ AC_DEFUN([gl_COMMON_BODY], [
39 this syntax with 'extern'. */ 39 this syntax with 'extern'. */
40# define _Noreturn [[noreturn]] 40# define _Noreturn [[noreturn]]
41# elif ((!defined __cplusplus || defined __clang__) \ 41# elif ((!defined __cplusplus || defined __clang__) \
42 && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ 42 && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \
43 || _GL_GNUC_PREREQ (4, 7) \ 43 || (!defined __STRICT_ANSI__ \
44 || (defined __apple_build_version__ \ 44 && (_GL_GNUC_PREREQ (4, 7) \
45 ? 6000000 <= __apple_build_version__ \ 45 || (defined __apple_build_version__ \
46 : 3 < __clang_major__ + (5 <= __clang_minor__)))) 46 ? 6000000 <= __apple_build_version__ \
47 : 3 < __clang_major__ + (5 <= __clang_minor__))))))
47 /* _Noreturn works as-is. */ 48 /* _Noreturn works as-is. */
48# elif _GL_GNUC_PREREQ (2, 8) || defined __clang__ || 0x5110 <= __SUNPRO_C 49# elif _GL_GNUC_PREREQ (2, 8) || defined __clang__ || 0x5110 <= __SUNPRO_C
49# define _Noreturn __attribute__ ((__noreturn__)) 50# define _Noreturn __attribute__ ((__noreturn__))
@@ -66,7 +67,9 @@ AC_DEFUN([gl_COMMON_BODY], [
66#endif]) 67#endif])
67 AH_VERBATIM([attribute], 68 AH_VERBATIM([attribute],
68[/* Attributes. */ 69[/* Attributes. */
69#ifdef __has_attribute 70#if (defined __has_attribute \
71 && (!defined __clang_minor__ \
72 || 3 < __clang_major__ + (5 <= __clang_minor__)))
70# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__) 73# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__)
71#else 74#else
72# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr 75# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index ad109520dd1..cd6f7b4bbdf 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -75,6 +75,7 @@ AC_DEFUN([gl_EARLY],
75 # Code from module dtoastr: 75 # Code from module dtoastr:
76 # Code from module dtotimespec: 76 # Code from module dtotimespec:
77 # Code from module dup2: 77 # Code from module dup2:
78 # Code from module dynarray:
78 # Code from module eloop-threshold: 79 # Code from module eloop-threshold:
79 # Code from module environ: 80 # Code from module environ:
80 # Code from module errno: 81 # Code from module errno:
@@ -517,6 +518,7 @@ AC_DEFUN([gl_INIT],
517 gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=false 518 gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=false
518 gl_gnulib_enabled_cloexec=false 519 gl_gnulib_enabled_cloexec=false
519 gl_gnulib_enabled_dirfd=false 520 gl_gnulib_enabled_dirfd=false
521 gl_gnulib_enabled_dynarray=false
520 gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c=false 522 gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c=false
521 gl_gnulib_enabled_euidaccess=false 523 gl_gnulib_enabled_euidaccess=false
522 gl_gnulib_enabled_getdtablesize=false 524 gl_gnulib_enabled_getdtablesize=false
@@ -564,6 +566,12 @@ AC_DEFUN([gl_INIT],
564 gl_gnulib_enabled_dirfd=true 566 gl_gnulib_enabled_dirfd=true
565 fi 567 fi
566 } 568 }
569 func_gl_gnulib_m4code_dynarray ()
570 {
571 if ! $gl_gnulib_enabled_dynarray; then
572 gl_gnulib_enabled_dynarray=true
573 fi
574 }
567 func_gl_gnulib_m4code_925677f0343de64b89a9f0c790b4104c () 575 func_gl_gnulib_m4code_925677f0343de64b89a9f0c790b4104c ()
568 { 576 {
569 if ! $gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c; then 577 if ! $gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c; then
@@ -797,6 +805,9 @@ AC_DEFUN([gl_INIT],
797 if test $HAVE_READLINKAT = 0 || test $REPLACE_READLINKAT = 1; then 805 if test $HAVE_READLINKAT = 0 || test $REPLACE_READLINKAT = 1; then
798 func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 806 func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7
799 fi 807 fi
808 if test $ac_use_included_regex = yes; then
809 func_gl_gnulib_m4code_dynarray
810 fi
800 if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then 811 if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then
801 func_gl_gnulib_m4code_strtoll 812 func_gl_gnulib_m4code_strtoll
802 fi 813 fi
@@ -819,6 +830,7 @@ AC_DEFUN([gl_INIT],
819 AM_CONDITIONAL([gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b], [$gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b]) 830 AM_CONDITIONAL([gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b], [$gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b])
820 AM_CONDITIONAL([gl_GNULIB_ENABLED_cloexec], [$gl_gnulib_enabled_cloexec]) 831 AM_CONDITIONAL([gl_GNULIB_ENABLED_cloexec], [$gl_gnulib_enabled_cloexec])
821 AM_CONDITIONAL([gl_GNULIB_ENABLED_dirfd], [$gl_gnulib_enabled_dirfd]) 832 AM_CONDITIONAL([gl_GNULIB_ENABLED_dirfd], [$gl_gnulib_enabled_dirfd])
833 AM_CONDITIONAL([gl_GNULIB_ENABLED_dynarray], [$gl_gnulib_enabled_dynarray])
822 AM_CONDITIONAL([gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c], [$gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c]) 834 AM_CONDITIONAL([gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c], [$gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c])
823 AM_CONDITIONAL([gl_GNULIB_ENABLED_euidaccess], [$gl_gnulib_enabled_euidaccess]) 835 AM_CONDITIONAL([gl_GNULIB_ENABLED_euidaccess], [$gl_gnulib_enabled_euidaccess])
824 AM_CONDITIONAL([gl_GNULIB_ENABLED_getdtablesize], [$gl_gnulib_enabled_getdtablesize]) 836 AM_CONDITIONAL([gl_GNULIB_ENABLED_getdtablesize], [$gl_gnulib_enabled_getdtablesize])
@@ -1021,6 +1033,7 @@ AC_DEFUN([gl_FILE_LIST], [
1021 lib/dtoastr.c 1033 lib/dtoastr.c
1022 lib/dtotimespec.c 1034 lib/dtotimespec.c
1023 lib/dup2.c 1035 lib/dup2.c
1036 lib/dynarray.h
1024 lib/eloop-threshold.h 1037 lib/eloop-threshold.h
1025 lib/errno.in.h 1038 lib/errno.in.h
1026 lib/euidaccess.c 1039 lib/euidaccess.c
@@ -1076,6 +1089,13 @@ AC_DEFUN([gl_FILE_LIST], [
1076 lib/libc-config.h 1089 lib/libc-config.h
1077 lib/limits.in.h 1090 lib/limits.in.h
1078 lib/lstat.c 1091 lib/lstat.c
1092 lib/malloc/dynarray-skeleton.c
1093 lib/malloc/dynarray.h
1094 lib/malloc/dynarray_at_failure.c
1095 lib/malloc/dynarray_emplace_enlarge.c
1096 lib/malloc/dynarray_finalize.c
1097 lib/malloc/dynarray_resize.c
1098 lib/malloc/dynarray_resize_clear.c
1079 lib/malloc/scratch_buffer.h 1099 lib/malloc/scratch_buffer.h
1080 lib/malloc/scratch_buffer_dupfree.c 1100 lib/malloc/scratch_buffer_dupfree.c
1081 lib/malloc/scratch_buffer_grow.c 1101 lib/malloc/scratch_buffer_grow.c
diff --git a/m4/nstrftime.m4 b/m4/nstrftime.m4
index 4674442810b..b510554b947 100644
--- a/m4/nstrftime.m4
+++ b/m4/nstrftime.m4
@@ -1,4 +1,4 @@
1# serial 36 1# serial 37
2 2
3# Copyright (C) 1996-1997, 1999-2007, 2009-2021 Free Software Foundation, Inc. 3# Copyright (C) 1996-1997, 1999-2007, 2009-2021 Free Software Foundation, Inc.
4# 4#
@@ -12,7 +12,7 @@ AC_DEFUN([gl_FUNC_GNU_STRFTIME],
12[ 12[
13 AC_REQUIRE([AC_C_RESTRICT]) 13 AC_REQUIRE([AC_C_RESTRICT])
14 14
15 # This defines (or not) HAVE_TZNAME and HAVE_TM_ZONE. 15 # This defines (or not) HAVE_TZNAME and HAVE_STRUCT_TM_TM_ZONE.
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])
diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4
index 18e872f483e..cd666c4a58c 100644
--- a/m4/stddef_h.m4
+++ b/m4/stddef_h.m4
@@ -1,14 +1,19 @@
1dnl A placeholder for <stddef.h>, for platforms that have issues. 1# stddef_h.m4 serial 9
2# stddef_h.m4 serial 7
3dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. 2dnl Copyright (C) 2009-2021 Free Software Foundation, Inc.
4dnl This file is free software; the Free Software Foundation 3dnl This file is free software; the Free Software Foundation
5dnl gives unlimited permission to copy and/or distribute it, 4dnl gives unlimited permission to copy and/or distribute it,
6dnl with or without modifications, as long as this notice is preserved. 5dnl with or without modifications, as long as this notice is preserved.
7 6
7dnl A placeholder for <stddef.h>, for platforms that have issues.
8
8AC_DEFUN([gl_STDDEF_H], 9AC_DEFUN([gl_STDDEF_H],
9[ 10[
10 AC_REQUIRE([gl_STDDEF_H_DEFAULTS]) 11 AC_REQUIRE([gl_STDDEF_H_DEFAULTS])
11 AC_REQUIRE([gt_TYPE_WCHAR_T]) 12 AC_REQUIRE([gt_TYPE_WCHAR_T])
13
14 dnl Persuade OpenBSD <stddef.h> to declare max_align_t.
15 AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
16
12 STDDEF_H= 17 STDDEF_H=
13 18
14 dnl Test whether the type max_align_t exists and whether its alignment 19 dnl Test whether the type max_align_t exists and whether its alignment
@@ -23,6 +28,13 @@ AC_DEFUN([gl_STDDEF_H],
23 int check1[2 * (__alignof__ (double) <= __alignof__ (max_align_t)) - 1]; 28 int check1[2 * (__alignof__ (double) <= __alignof__ (max_align_t)) - 1];
24 int check2[2 * (__alignof__ (long double) <= __alignof__ (max_align_t)) - 1]; 29 int check2[2 * (__alignof__ (long double) <= __alignof__ (max_align_t)) - 1];
25 #endif 30 #endif
31 typedef struct { char a; max_align_t b; } max_helper;
32 typedef struct { char a; long b; } long_helper;
33 typedef struct { char a; double b; } double_helper;
34 typedef struct { char a; long double b; } long_double_helper;
35 int check3[2 * (offsetof (long_helper, b) <= offsetof (max_helper, b)) - 1];
36 int check4[2 * (offsetof (double_helper, b) <= offsetof (max_helper, b)) - 1];
37 int check5[2 * (offsetof (long_double_helper, b) <= offsetof (max_helper, b)) - 1];
26 ]])], 38 ]])],
27 [gl_cv_type_max_align_t=yes], 39 [gl_cv_type_max_align_t=yes],
28 [gl_cv_type_max_align_t=no]) 40 [gl_cv_type_max_align_t=no])
diff --git a/m4/string_h.m4 b/m4/string_h.m4
index 3e65355735c..a4cc5b43783 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 28 8# serial 29
9 9
10# Written by Paul Eggert. 10# Written by Paul Eggert.
11 11
@@ -113,6 +113,7 @@ AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS],
113 HAVE_SIGDESCR_NP=1; AC_SUBST([HAVE_SIGDESCR_NP]) 113 HAVE_SIGDESCR_NP=1; AC_SUBST([HAVE_SIGDESCR_NP])
114 HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL]) 114 HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL])
115 HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP]) 115 HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP])
116 REPLACE_FFSLL=0; AC_SUBST([REPLACE_FFSLL])
116 REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR]) 117 REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR])
117 REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM]) 118 REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM])
118 REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY]) 119 REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY])
diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4
index e8eac71b466..23cbdd28eb2 100644
--- a/m4/sys_stat_h.m4
+++ b/m4/sys_stat_h.m4
@@ -1,4 +1,4 @@
1# sys_stat_h.m4 serial 36 -*- Autoconf -*- 1# sys_stat_h.m4 serial 38 -*- Autoconf -*-
2dnl Copyright (C) 2006-2021 Free Software Foundation, Inc. 2dnl Copyright (C) 2006-2021 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,
@@ -104,7 +104,9 @@ AC_DEFUN([gl_SYS_STAT_H_DEFAULTS],
104 REPLACE_LSTAT=0; AC_SUBST([REPLACE_LSTAT]) 104 REPLACE_LSTAT=0; AC_SUBST([REPLACE_LSTAT])
105 REPLACE_MKDIR=0; AC_SUBST([REPLACE_MKDIR]) 105 REPLACE_MKDIR=0; AC_SUBST([REPLACE_MKDIR])
106 REPLACE_MKFIFO=0; AC_SUBST([REPLACE_MKFIFO]) 106 REPLACE_MKFIFO=0; AC_SUBST([REPLACE_MKFIFO])
107 REPLACE_MKFIFOAT=0; AC_SUBST([REPLACE_MKFIFOAT])
107 REPLACE_MKNOD=0; AC_SUBST([REPLACE_MKNOD]) 108 REPLACE_MKNOD=0; AC_SUBST([REPLACE_MKNOD])
109 REPLACE_MKNODAT=0; AC_SUBST([REPLACE_MKNODAT])
108 REPLACE_STAT=0; AC_SUBST([REPLACE_STAT]) 110 REPLACE_STAT=0; AC_SUBST([REPLACE_STAT])
109 REPLACE_UTIMENSAT=0; AC_SUBST([REPLACE_UTIMENSAT]) 111 REPLACE_UTIMENSAT=0; AC_SUBST([REPLACE_UTIMENSAT])
110]) 112])
diff --git a/m4/time_h.m4 b/m4/time_h.m4
index 07e6967e45b..b6a1aa3bc0f 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-2021 Free Software Foundation, Inc. 3# Copyright (C) 2000-2001, 2003-2007, 2009-2021 Free Software Foundation, Inc.
4 4
5# serial 13 5# serial 15
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,
@@ -25,6 +25,22 @@ AC_DEFUN([gl_HEADER_TIME_H_BODY],
25 AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC]) 25 AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC])
26 26
27 AC_REQUIRE([AC_C_RESTRICT]) 27 AC_REQUIRE([AC_C_RESTRICT])
28
29 AC_CACHE_CHECK([for TIME_UTC in <time.h>],
30 [gl_cv_time_h_has_TIME_UTC],
31 [AC_COMPILE_IFELSE(
32 [AC_LANG_PROGRAM(
33 [[#include <time.h>
34 ]],
35 [[static int x = TIME_UTC; x++;]])],
36 [gl_cv_time_h_has_TIME_UTC=yes],
37 [gl_cv_time_h_has_TIME_UTC=no])])
38 if test $gl_cv_time_h_has_TIME_UTC = yes; then
39 TIME_H_DEFINES_TIME_UTC=1
40 else
41 TIME_H_DEFINES_TIME_UTC=0
42 fi
43 AC_SUBST([TIME_H_DEFINES_TIME_UTC])
28]) 44])
29 45
30dnl Check whether 'struct timespec' is declared 46dnl Check whether 'struct timespec' is declared
@@ -113,6 +129,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS],
113 GNULIB_STRFTIME=0; AC_SUBST([GNULIB_STRFTIME]) 129 GNULIB_STRFTIME=0; AC_SUBST([GNULIB_STRFTIME])
114 GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME]) 130 GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME])
115 GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM]) 131 GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM])
132 GNULIB_TIMESPEC_GET=0; AC_SUBST([GNULIB_TIMESPEC_GET])
116 GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R]) 133 GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R])
117 GNULIB_TIME_RZ=0; AC_SUBST([GNULIB_TIME_RZ]) 134 GNULIB_TIME_RZ=0; AC_SUBST([GNULIB_TIME_RZ])
118 GNULIB_TZSET=0; AC_SUBST([GNULIB_TZSET]) 135 GNULIB_TZSET=0; AC_SUBST([GNULIB_TZSET])
@@ -123,6 +140,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS],
123 HAVE_NANOSLEEP=1; AC_SUBST([HAVE_NANOSLEEP]) 140 HAVE_NANOSLEEP=1; AC_SUBST([HAVE_NANOSLEEP])
124 HAVE_STRPTIME=1; AC_SUBST([HAVE_STRPTIME]) 141 HAVE_STRPTIME=1; AC_SUBST([HAVE_STRPTIME])
125 HAVE_TIMEGM=1; AC_SUBST([HAVE_TIMEGM]) 142 HAVE_TIMEGM=1; AC_SUBST([HAVE_TIMEGM])
143 HAVE_TIMESPEC_GET=1; AC_SUBST([HAVE_TIMESPEC_GET])
126 dnl Even GNU libc does not have timezone_t yet. 144 dnl Even GNU libc does not have timezone_t yet.
127 HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T]) 145 HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T])
128 dnl If another module says to replace or to not replace, do that. 146 dnl If another module says to replace or to not replace, do that.
diff --git a/m4/utimensat.m4 b/m4/utimensat.m4
index bdabe24c568..b5bff1651f3 100644
--- a/m4/utimensat.m4
+++ b/m4/utimensat.m4
@@ -1,4 +1,4 @@
1# serial 7 1# serial 9
2# See if we need to provide utimensat replacement. 2# See if we need to provide utimensat replacement.
3 3
4dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. 4dnl Copyright (C) 2009-2021 Free Software Foundation, Inc.
@@ -12,6 +12,7 @@ AC_DEFUN([gl_FUNC_UTIMENSAT],
12[ 12[
13 AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) 13 AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
14 AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) 14 AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
15 AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
15 AC_CHECK_FUNCS_ONCE([utimensat]) 16 AC_CHECK_FUNCS_ONCE([utimensat])
16 if test $ac_cv_func_utimensat = no; then 17 if test $ac_cv_func_utimensat = no; then
17 HAVE_UTIMENSAT=0 18 HAVE_UTIMENSAT=0
@@ -28,10 +29,19 @@ AC_DEFUN([gl_FUNC_UTIMENSAT],
28 const char *f = "conftest.file"; 29 const char *f = "conftest.file";
29 if (close (creat (f, 0600))) 30 if (close (creat (f, 0600)))
30 return 1; 31 return 1;
32 /* Test whether a trailing slash is handled correctly.
33 This fails on AIX 7.2. */
34 {
35 struct timespec ts[2];
36 ts[0].tv_sec = 345183300; ts[0].tv_nsec = 0;
37 ts[1] = ts[0];
38 if (utimensat (AT_FDCWD, "conftest.file/", ts, 0) == 0)
39 result |= 2;
40 }
31 /* Test whether the AT_SYMLINK_NOFOLLOW flag is supported. */ 41 /* Test whether the AT_SYMLINK_NOFOLLOW flag is supported. */
32 { 42 {
33 if (utimensat (AT_FDCWD, f, NULL, AT_SYMLINK_NOFOLLOW)) 43 if (utimensat (AT_FDCWD, f, NULL, AT_SYMLINK_NOFOLLOW))
34 result |= 2; 44 result |= 4;
35 } 45 }
36 /* Test whether UTIME_NOW and UTIME_OMIT work. */ 46 /* Test whether UTIME_NOW and UTIME_OMIT work. */
37 { 47 {
@@ -41,7 +51,7 @@ AC_DEFUN([gl_FUNC_UTIMENSAT],
41 ts[1].tv_sec = 1; 51 ts[1].tv_sec = 1;
42 ts[1].tv_nsec = UTIME_NOW; 52 ts[1].tv_nsec = UTIME_NOW;
43 if (utimensat (AT_FDCWD, f, ts, 0)) 53 if (utimensat (AT_FDCWD, f, ts, 0))
44 result |= 4; 54 result |= 8;
45 } 55 }
46 sleep (1); 56 sleep (1);
47 { 57 {
@@ -52,19 +62,44 @@ AC_DEFUN([gl_FUNC_UTIMENSAT],
52 ts[1].tv_sec = 1; 62 ts[1].tv_sec = 1;
53 ts[1].tv_nsec = UTIME_OMIT; 63 ts[1].tv_nsec = UTIME_OMIT;
54 if (utimensat (AT_FDCWD, f, ts, 0)) 64 if (utimensat (AT_FDCWD, f, ts, 0))
55 result |= 8;
56 if (stat (f, &st))
57 result |= 16; 65 result |= 16;
58 else if (st.st_ctime < st.st_atime) 66 if (stat (f, &st))
59 result |= 32; 67 result |= 32;
68 else if (st.st_ctime < st.st_atime)
69 result |= 64;
60 } 70 }
61 return result; 71 return result;
62 ]])], 72 ]])],
63 [gl_cv_func_utimensat_works=yes], 73 [gl_cv_func_utimensat_works=yes],
64 [gl_cv_func_utimensat_works=no], 74 [case $? in
65 [gl_cv_func_utimensat_works="guessing yes"])]) 75 2) gl_cv_func_utimensat_works='nearly' ;;
66 if test "$gl_cv_func_utimensat_works" = no; then 76 *) gl_cv_func_utimensat_works=no ;;
67 REPLACE_UTIMENSAT=1 77 esac
68 fi 78 ],
79 [case "$host_os" in
80 # Guess yes on Linux or glibc systems.
81 linux-* | linux | *-gnu* | gnu*)
82 gl_cv_func_utimensat_works="guessing yes" ;;
83 # Guess 'nearly' on AIX.
84 aix*)
85 gl_cv_func_utimensat_works="guessing nearly" ;;
86 # If we don't know, obey --enable-cross-guesses.
87 *)
88 gl_cv_func_utimensat_works="$gl_cross_guess_normal" ;;
89 esac
90 ])
91 ])
92 case "$gl_cv_func_utimensat_works" in
93 *yes)
94 ;;
95 *nearly)
96 AC_DEFINE([HAVE_NEARLY_WORKING_UTIMENSAT], [1],
97 [Define to 1 if utimensat works, except for the trailing slash handling.])
98 REPLACE_UTIMENSAT=1
99 ;;
100 *)
101 REPLACE_UTIMENSAT=1
102 ;;
103 esac
69 fi 104 fi
70]) 105])
diff --git a/src/alloc.c b/src/alloc.c
index 350fec25a02..0ed5b9346f6 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -6122,11 +6122,13 @@ garbage_collect (void)
6122 6122
6123 gc_in_progress = 0; 6123 gc_in_progress = 0;
6124 6124
6125 unblock_input ();
6126
6127 consing_until_gc = gc_threshold 6125 consing_until_gc = gc_threshold
6128 = consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0); 6126 = consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0);
6129 6127
6128 /* Unblock *after* re-setting `consing_until_gc` in case `unblock_input`
6129 signals an error (see bug#43389). */
6130 unblock_input ();
6131
6130 if (garbage_collection_messages && NILP (Vmemory_full)) 6132 if (garbage_collection_messages && NILP (Vmemory_full))
6131 { 6133 {
6132 if (message_p || minibuf_level > 0) 6134 if (message_p || minibuf_level > 0)
diff --git a/src/conf_post.h b/src/conf_post.h
index bd56f29e287..176ab28b21a 100644
--- a/src/conf_post.h
+++ b/src/conf_post.h
@@ -71,7 +71,9 @@ typedef bool bool_bf;
71 It is used only on arguments like cleanup that are handled here. 71 It is used only on arguments like cleanup that are handled here.
72 This macro should be used only in #if expressions, as Oracle 72 This macro should be used only in #if expressions, as Oracle
73 Studio 12.5's __has_attribute does not work in plain code. */ 73 Studio 12.5's __has_attribute does not work in plain code. */
74#ifdef __has_attribute 74#if (defined __has_attribute \
75 && (!defined __clang_minor__ \
76 || 3 < __clang_major__ + (5 <= __clang_minor__)))
75# define HAS_ATTRIBUTE(a) __has_attribute (__##a##__) 77# define HAS_ATTRIBUTE(a) __has_attribute (__##a##__)
76#else 78#else
77# define HAS_ATTRIBUTE(a) HAS_ATTR_##a 79# define HAS_ATTRIBUTE(a) HAS_ATTR_##a
diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in
index 2989b439109..fe52587c1a5 100644
--- a/src/emacs-module.h.in
+++ b/src/emacs-module.h.in
@@ -51,7 +51,9 @@ information how to write modules and use this header file.
51#if 3 < __GNUC__ + (3 <= __GNUC_MINOR__) 51#if 3 < __GNUC__ + (3 <= __GNUC_MINOR__)
52# define EMACS_ATTRIBUTE_NONNULL(...) \ 52# define EMACS_ATTRIBUTE_NONNULL(...) \
53 __attribute__ ((__nonnull__ (__VA_ARGS__))) 53 __attribute__ ((__nonnull__ (__VA_ARGS__)))
54#elif defined __has_attribute 54#elif (defined __has_attribute \
55 && (!defined __clang_minor__ \
56 || 3 < __clang_major__ + (5 <= __clang_minor__)))
55# if __has_attribute (__nonnull__) 57# if __has_attribute (__nonnull__)
56# define EMACS_ATTRIBUTE_NONNULL(...) \ 58# define EMACS_ATTRIBUTE_NONNULL(...) \
57 __attribute__ ((__nonnull__ (__VA_ARGS__))) 59 __attribute__ ((__nonnull__ (__VA_ARGS__)))
diff --git a/src/frame.c b/src/frame.c
index 45ee96e9620..599c4075f88 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -2572,23 +2572,30 @@ before calling this function on it, like this.
2572 int yval = check_integer_range (y, INT_MIN, INT_MAX); 2572 int yval = check_integer_range (y, INT_MIN, INT_MAX);
2573 2573
2574 /* I think this should be done with a hook. */ 2574 /* I think this should be done with a hook. */
2575#ifdef HAVE_WINDOW_SYSTEM
2576 if (FRAME_WINDOW_P (XFRAME (frame))) 2575 if (FRAME_WINDOW_P (XFRAME (frame)))
2577 /* Warping the mouse will cause enternotify and focus events. */ 2576 {
2578 frame_set_mouse_position (XFRAME (frame), xval, yval); 2577#ifdef HAVE_WINDOW_SYSTEM
2579#elif defined MSDOS 2578 /* Warping the mouse will cause enternotify and focus events. */
2580 if (FRAME_MSDOS_P (XFRAME (frame))) 2579 frame_set_mouse_position (XFRAME (frame), xval, yval);
2580#endif /* HAVE_WINDOW_SYSTEM */
2581 }
2582#ifdef MSDOS
2583 else if (FRAME_MSDOS_P (XFRAME (frame)))
2581 { 2584 {
2582 Fselect_frame (frame, Qnil); 2585 Fselect_frame (frame, Qnil);
2583 mouse_moveto (xval, yval); 2586 mouse_moveto (xval, yval);
2584 } 2587 }
2585#elif defined HAVE_GPM 2588#endif /* MSDOS */
2586 Fselect_frame (frame, Qnil); 2589 else
2587 term_mouse_moveto (xval, yval); 2590 {
2591 Fselect_frame (frame, Qnil);
2592#ifdef HAVE_GPM
2593 term_mouse_moveto (xval, yval);
2588#else 2594#else
2589 (void) xval; 2595 (void) xval;
2590 (void) yval; 2596 (void) yval;
2591#endif 2597#endif /* HAVE_GPM */
2598 }
2592 2599
2593 return Qnil; 2600 return Qnil;
2594} 2601}
@@ -2610,23 +2617,31 @@ before calling this function on it, like this.
2610 int yval = check_integer_range (y, INT_MIN, INT_MAX); 2617 int yval = check_integer_range (y, INT_MIN, INT_MAX);
2611 2618
2612 /* I think this should be done with a hook. */ 2619 /* I think this should be done with a hook. */
2613#ifdef HAVE_WINDOW_SYSTEM
2614 if (FRAME_WINDOW_P (XFRAME (frame))) 2620 if (FRAME_WINDOW_P (XFRAME (frame)))
2615 /* Warping the mouse will cause enternotify and focus events. */ 2621 {
2616 frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); 2622 /* Warping the mouse will cause enternotify and focus events. */
2617#elif defined MSDOS 2623#ifdef HAVE_WINDOW_SYSTEM
2618 if (FRAME_MSDOS_P (XFRAME (frame))) 2624 frame_set_mouse_pixel_position (XFRAME (frame), xval, yval);
2625#endif /* HAVE_WINDOW_SYSTEM */
2626 }
2627#ifdef MSDOS
2628 else if (FRAME_MSDOS_P (XFRAME (frame)))
2619 { 2629 {
2620 Fselect_frame (frame, Qnil); 2630 Fselect_frame (frame, Qnil);
2621 mouse_moveto (xval, yval); 2631 mouse_moveto (xval, yval);
2622 } 2632 }
2623#elif defined HAVE_GPM 2633#endif /* MSDOS */
2624 Fselect_frame (frame, Qnil); 2634 else
2625 term_mouse_moveto (xval, yval); 2635 {
2636 Fselect_frame (frame, Qnil);
2637#ifdef HAVE_GPM
2638 term_mouse_moveto (xval, yval);
2626#else 2639#else
2627 (void) xval; 2640 (void) xval;
2628 (void) yval; 2641 (void) yval;
2629#endif 2642#endif /* HAVE_GPM */
2643
2644 }
2630 2645
2631 return Qnil; 2646 return Qnil;
2632} 2647}
diff --git a/src/nsfns.m b/src/nsfns.m
index ae114f83e4d..24ea7d7f63b 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -1487,7 +1487,6 @@ Some window managers may refuse to restack windows. */)
1487 { 1487 {
1488 EmacsWindow *window = (EmacsWindow *)[FRAME_NS_VIEW (f1) window]; 1488 EmacsWindow *window = (EmacsWindow *)[FRAME_NS_VIEW (f1) window];
1489 NSWindow *window2 = [FRAME_NS_VIEW (f2) window]; 1489 NSWindow *window2 = [FRAME_NS_VIEW (f2) window];
1490 BOOL flag = !NILP (above);
1491 1490
1492 if ([window restackWindow:window2 above:!NILP (above)]) 1491 if ([window restackWindow:window2 above:!NILP (above)])
1493 return Qt; 1492 return Qt;
diff --git a/src/nsmenu.m b/src/nsmenu.m
index 8086f56854e..f8219d27026 100644
--- a/src/nsmenu.m
+++ b/src/nsmenu.m
@@ -101,7 +101,6 @@ popup_activated (void)
101static void 101static void
102ns_update_menubar (struct frame *f, bool deep_p) 102ns_update_menubar (struct frame *f, bool deep_p)
103{ 103{
104 NSAutoreleasePool *pool;
105 BOOL needsSet = NO; 104 BOOL needsSet = NO;
106 id menu = [NSApp mainMenu]; 105 id menu = [NSApp mainMenu];
107 bool owfi; 106 bool owfi;
diff --git a/src/nsselect.m b/src/nsselect.m
index 27db9248e46..5ab3ef77fec 100644
--- a/src/nsselect.m
+++ b/src/nsselect.m
@@ -78,7 +78,13 @@ ns_string_to_symbol (NSString *t)
78 return QSECONDARY; 78 return QSECONDARY;
79 if ([t isEqualToString: NSPasteboardTypeString]) 79 if ([t isEqualToString: NSPasteboardTypeString])
80 return QTEXT; 80 return QTEXT;
81 if ([t isEqualToString: NSFilenamesPboardType]) 81 if ([t isEqualToString:
82#if NS_USE_NSPasteboardTypeFileURL != 0
83 NSPasteboardTypeFileURL
84#else
85 NSFilenamesPboardType
86#endif
87 ])
82 return QFILE_NAME; 88 return QFILE_NAME;
83 if ([t isEqualToString: NSPasteboardTypeTabularText]) 89 if ([t isEqualToString: NSPasteboardTypeTabularText])
84 return QTEXT; 90 return QTEXT;
@@ -467,7 +473,12 @@ nxatoms_of_nsselect (void)
467 [NSNumber numberWithLong:0], NXPrimaryPboard, 473 [NSNumber numberWithLong:0], NXPrimaryPboard,
468 [NSNumber numberWithLong:0], NXSecondaryPboard, 474 [NSNumber numberWithLong:0], NXSecondaryPboard,
469 [NSNumber numberWithLong:0], NSPasteboardTypeString, 475 [NSNumber numberWithLong:0], NSPasteboardTypeString,
470 [NSNumber numberWithLong:0], NSFilenamesPboardType, 476 [NSNumber numberWithLong:0],
477#if NS_USE_NSPasteboardTypeFileURL != 0
478 NSPasteboardTypeFileURL,
479#else
480 NSFilenamesPboardType,
481#endif
471 [NSNumber numberWithLong:0], NSPasteboardTypeTabularText, 482 [NSNumber numberWithLong:0], NSPasteboardTypeTabularText,
472 nil] retain]; 483 nil] retain];
473} 484}
diff --git a/src/nsterm.h b/src/nsterm.h
index 2c9d8e85ba9..eae1d0725ea 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -39,6 +39,15 @@ typedef CGFloat EmacsCGFloat;
39typedef float EmacsCGFloat; 39typedef float EmacsCGFloat;
40#endif 40#endif
41 41
42/* NSFilenamesPboardType is deprecated in macOS 10.14, but
43 NSPasteboardTypeFileURL is only available in 10.13 (and GNUstep
44 probably lacks it too). */
45#if defined NS_IMPL_COCOA && MAC_OS_X_VERSION_MIN_REQUIRED >= 101300
46#define NS_USE_NSPasteboardTypeFileURL 1
47#else
48#define NS_USE_NSPasteboardTypeFileURL 0
49#endif
50
42/* ========================================================================== 51/* ==========================================================================
43 52
44 Trace support 53 Trace support
diff --git a/src/nsterm.m b/src/nsterm.m
index 2defb9e2eec..df3934c5c34 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -272,7 +272,9 @@ long context_menu_value = 0;
272 272
273/* display update */ 273/* display update */
274static struct frame *ns_updating_frame; 274static struct frame *ns_updating_frame;
275#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400
275static NSView *focus_view = NULL; 276static NSView *focus_view = NULL;
277#endif
276static int ns_window_num = 0; 278static int ns_window_num = 0;
277static BOOL gsaved = NO; 279static BOOL gsaved = NO;
278static BOOL ns_fake_keydown = NO; 280static BOOL ns_fake_keydown = NO;
@@ -1139,7 +1141,9 @@ ns_update_end (struct frame *f)
1139 external (RIF) call; for whole frame, called after gui_update_window_end 1141 external (RIF) call; for whole frame, called after gui_update_window_end
1140 -------------------------------------------------------------------------- */ 1142 -------------------------------------------------------------------------- */
1141{ 1143{
1144#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400
1142 EmacsView *view = FRAME_NS_VIEW (f); 1145 EmacsView *view = FRAME_NS_VIEW (f);
1146#endif
1143 1147
1144 NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_end"); 1148 NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_end");
1145 1149
@@ -1449,7 +1453,7 @@ ns_ring_bell (struct frame *f)
1449 } 1453 }
1450} 1454}
1451 1455
1452 1456#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400
1453static void 1457static void
1454hide_bell (void) 1458hide_bell (void)
1455/* -------------------------------------------------------------------------- 1459/* --------------------------------------------------------------------------
@@ -1463,6 +1467,7 @@ hide_bell (void)
1463 [bell_view remove]; 1467 [bell_view remove];
1464 } 1468 }
1465} 1469}
1470#endif
1466 1471
1467 1472
1468/* ========================================================================== 1473/* ==========================================================================
@@ -2876,6 +2881,8 @@ ns_get_shifted_character (NSEvent *event)
2876 ========================================================================== */ 2881 ========================================================================== */
2877 2882
2878 2883
2884#if 0
2885/* FIXME: Remove this function. */
2879static void 2886static void
2880ns_redraw_scroll_bars (struct frame *f) 2887ns_redraw_scroll_bars (struct frame *f)
2881{ 2888{
@@ -2890,6 +2897,7 @@ ns_redraw_scroll_bars (struct frame *f)
2890 [view display]; 2897 [view display];
2891 } 2898 }
2892} 2899}
2900#endif
2893 2901
2894 2902
2895void 2903void
@@ -5602,7 +5610,11 @@ ns_term_init (Lisp_Object display_name)
5602 ns_drag_types = [[NSArray arrayWithObjects: 5610 ns_drag_types = [[NSArray arrayWithObjects:
5603 NSPasteboardTypeString, 5611 NSPasteboardTypeString,
5604 NSPasteboardTypeTabularText, 5612 NSPasteboardTypeTabularText,
5613#if NS_USE_NSPasteboardTypeFileURL != 0
5614 NSPasteboardTypeFileURL,
5615#else
5605 NSFilenamesPboardType, 5616 NSFilenamesPboardType,
5617#endif
5606 NSPasteboardTypeURL, nil] retain]; 5618 NSPasteboardTypeURL, nil] retain];
5607 5619
5608 /* If fullscreen is in init/default-frame-alist, focus isn't set 5620 /* If fullscreen is in init/default-frame-alist, focus isn't set
@@ -8395,21 +8407,23 @@ not_in_argv (NSString *arg)
8395 void *pixels = CGBitmapContextGetData (context); 8407 void *pixels = CGBitmapContextGetData (context);
8396 int rowSize = CGBitmapContextGetBytesPerRow (context); 8408 int rowSize = CGBitmapContextGetBytesPerRow (context);
8397 int srcRowSize = NSWidth (srcRect) * scale * bpp; 8409 int srcRowSize = NSWidth (srcRect) * scale * bpp;
8398 void *srcPixels = pixels + (int)(NSMinY (srcRect) * scale * rowSize 8410 void *srcPixels = (char *) pixels
8399 + NSMinX (srcRect) * scale * bpp); 8411 + (int) (NSMinY (srcRect) * scale * rowSize
8400 void *dstPixels = pixels + (int)(NSMinY (dstRect) * scale * rowSize 8412 + NSMinX (srcRect) * scale * bpp);
8401 + NSMinX (dstRect) * scale * bpp); 8413 void *dstPixels = (char *) pixels
8414 + (int) (NSMinY (dstRect) * scale * rowSize
8415 + NSMinX (dstRect) * scale * bpp);
8402 8416
8403 if (NSIntersectsRect (srcRect, dstRect) 8417 if (NSIntersectsRect (srcRect, dstRect)
8404 && NSMinY (srcRect) < NSMinY (dstRect)) 8418 && NSMinY (srcRect) < NSMinY (dstRect))
8405 for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--) 8419 for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--)
8406 memmove (dstPixels + y * rowSize, 8420 memmove ((char *) dstPixels + y * rowSize,
8407 srcPixels + y * rowSize, 8421 (char *) srcPixels + y * rowSize,
8408 srcRowSize); 8422 srcRowSize);
8409 else 8423 else
8410 for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++) 8424 for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++)
8411 memmove (dstPixels + y * rowSize, 8425 memmove ((char *) dstPixels + y * rowSize,
8412 srcPixels + y * rowSize, 8426 (char *) srcPixels + y * rowSize,
8413 srcRowSize); 8427 srcRowSize);
8414 8428
8415#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 8429#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400
@@ -8533,9 +8547,19 @@ not_in_argv (NSString *arg)
8533 { 8547 {
8534 return NO; 8548 return NO;
8535 } 8549 }
8536 /* FIXME: NSFilenamesPboardType is deprecated in 10.14, but the 8550#if NS_USE_NSPasteboardTypeFileURL != 0
8537 NSURL method can only handle one file at a time. Stick with the 8551 else if ([type isEqualToString: NSPasteboardTypeFileURL])
8538 existing code at the moment. */ 8552 {
8553 type_sym = Qfile;
8554
8555 NSArray *urls = [pb readObjectsForClasses: @[[NSURL self]]
8556 options: nil];
8557 NSEnumerator *uenum = [urls objectEnumerator];
8558 NSURL *url;
8559 while ((url = [uenum nextObject]))
8560 strings = Fcons ([[url path] lispString], strings);
8561 }
8562#else // !NS_USE_NSPasteboardTypeFileURL
8539 else if ([type isEqualToString: NSFilenamesPboardType]) 8563 else if ([type isEqualToString: NSFilenamesPboardType])
8540 { 8564 {
8541 NSArray *files; 8565 NSArray *files;
@@ -8551,6 +8575,7 @@ not_in_argv (NSString *arg)
8551 while ( (file = [fenum nextObject]) ) 8575 while ( (file = [fenum nextObject]) )
8552 strings = Fcons ([file lispString], strings); 8576 strings = Fcons ([file lispString], strings);
8553 } 8577 }
8578#endif // !NS_USE_NSPasteboardTypeFileURL
8554 else if ([type isEqualToString: NSPasteboardTypeURL]) 8579 else if ([type isEqualToString: NSPasteboardTypeURL])
8555 { 8580 {
8556 NSURL *url = [NSURL URLFromPasteboard: pb]; 8581 NSURL *url = [NSURL URLFromPasteboard: pb];
@@ -8727,7 +8752,8 @@ not_in_argv (NSString *arg)
8727/* The array returned by [NSWindow parentWindow] may already be 8752/* The array returned by [NSWindow parentWindow] may already be
8728 sorted, but the documentation doesn't tell us whether or not it is, 8753 sorted, but the documentation doesn't tell us whether or not it is,
8729 so to be safe we'll sort it. */ 8754 so to be safe we'll sort it. */
8730NSInteger nswindow_orderedIndex_sort (id w1, id w2, void *c) 8755static NSInteger
8756nswindow_orderedIndex_sort (id w1, id w2, void *c)
8731{ 8757{
8732 NSInteger i1 = [w1 orderedIndex]; 8758 NSInteger i1 = [w1 orderedIndex];
8733 NSInteger i2 = [w2 orderedIndex]; 8759 NSInteger i2 = [w2 orderedIndex];
diff --git a/src/process.c b/src/process.c
index dac7d0440fa..1df4ed9ce03 100644
--- a/src/process.c
+++ b/src/process.c
@@ -283,6 +283,18 @@ static int max_desc;
283 the file descriptor of a socket that is already bound. */ 283 the file descriptor of a socket that is already bound. */
284static int external_sock_fd; 284static int external_sock_fd;
285 285
286/* File descriptor that becomes readable when we receive SIGCHLD. */
287static int child_signal_read_fd = -1;
288/* The write end thereof. The SIGCHLD handler writes to this file
289 descriptor to notify `wait_reading_process_output' of process
290 status changes. */
291static int child_signal_write_fd = -1;
292static void child_signal_init (void);
293#ifndef WINDOWSNT
294static void child_signal_read (int, void *);
295#endif
296static void child_signal_notify (void);
297
286/* Indexed by descriptor, gives the process (if any) for that descriptor. */ 298/* Indexed by descriptor, gives the process (if any) for that descriptor. */
287static Lisp_Object chan_process[FD_SETSIZE]; 299static Lisp_Object chan_process[FD_SETSIZE];
288static void wait_for_socket_fds (Lisp_Object, char const *); 300static void wait_for_socket_fds (Lisp_Object, char const *);
@@ -2060,6 +2072,10 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
2060 Lisp_Object lisp_pty_name = Qnil; 2072 Lisp_Object lisp_pty_name = Qnil;
2061 sigset_t oldset; 2073 sigset_t oldset;
2062 2074
2075 /* Ensure that the SIGCHLD handler can notify
2076 `wait_reading_process_output'. */
2077 child_signal_init ();
2078
2063 inchannel = outchannel = -1; 2079 inchannel = outchannel = -1;
2064 2080
2065 if (p->pty_flag) 2081 if (p->pty_flag)
@@ -5309,6 +5325,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5309 compute_input_wait_mask (&Atemp); 5325 compute_input_wait_mask (&Atemp);
5310 compute_write_mask (&Ctemp); 5326 compute_write_mask (&Ctemp);
5311 5327
5328 /* If a process status has changed, the child signal pipe
5329 will likely be readable. We want to ignore it for now,
5330 because otherwise we wouldn't run into a timeout
5331 below. */
5332 int fd = child_signal_read_fd;
5333 eassert (fd < FD_SETSIZE);
5334 if (0 <= fd)
5335 FD_CLR (fd, &Atemp);
5336
5312 timeout = make_timespec (0, 0); 5337 timeout = make_timespec (0, 0);
5313 if ((thread_select (pselect, max_desc + 1, 5338 if ((thread_select (pselect, max_desc + 1,
5314 &Atemp, 5339 &Atemp,
@@ -5395,6 +5420,14 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5395 check_write = true; 5420 check_write = true;
5396 } 5421 }
5397 5422
5423 /* We have to be informed when we receive a SIGCHLD signal for
5424 an asynchronous process. Otherwise this might deadlock if we
5425 receive a SIGCHLD during `pselect'. */
5426 int child_fd = child_signal_read_fd;
5427 eassert (child_fd < FD_SETSIZE);
5428 if (0 <= child_fd)
5429 FD_SET (child_fd, &Available);
5430
5398 /* If frame size has changed or the window is newly mapped, 5431 /* If frame size has changed or the window is newly mapped,
5399 redisplay now, before we start to wait. There is a race 5432 redisplay now, before we start to wait. There is a race
5400 condition here; if a SIGIO arrives between now and the select 5433 condition here; if a SIGIO arrives between now and the select
@@ -7114,7 +7147,95 @@ process has been transmitted to the serial port. */)
7114 subprocesses which the main thread should not reap. For example, 7147 subprocesses which the main thread should not reap. For example,
7115 if the main thread attempted to reap an already-reaped child, it 7148 if the main thread attempted to reap an already-reaped child, it
7116 might inadvertently reap a GTK-created process that happened to 7149 might inadvertently reap a GTK-created process that happened to
7117 have the same process ID. */ 7150 have the same process ID.
7151
7152 To avoid a deadlock when receiving SIGCHLD while
7153 'wait_reading_process_output' is in 'pselect', the SIGCHLD handler
7154 will notify the `pselect' using a self-pipe. The deadlock could
7155 occur if SIGCHLD is delivered outside of the 'pselect' call, in
7156 which case 'pselect' will not be interrupted by the signal, and
7157 will therefore wait on the process's output descriptor for the
7158 output that will never come.
7159
7160 WINDOWSNT doesn't need this facility because its 'pselect'
7161 emulation (see 'sys_select' in w32proc.c) waits on a subprocess
7162 handle, which becomes signaled when the process exits, and also
7163 because that emulation delays the delivery of the simulated SIGCHLD
7164 until all the output from the subprocess has been consumed. */
7165
7166/* FIXME: On Unix-like systems that have a proper 'pselect'
7167 (HAVE_PSELECT), we should block SIGCHLD in
7168 'wait_reading_process_output' and pass a non-NULL signal mask to
7169 'pselect' to avoid the need for the self-pipe. */
7170
7171/* Set up `child_signal_read_fd' and `child_signal_write_fd'. */
7172
7173static void
7174child_signal_init (void)
7175{
7176 /* Either both are initialized, or both are uninitialized. */
7177 eassert ((child_signal_read_fd < 0) == (child_signal_write_fd < 0));
7178
7179#ifndef WINDOWSNT
7180 if (0 <= child_signal_read_fd)
7181 return; /* already done */
7182
7183 int fds[2];
7184 if (emacs_pipe (fds) < 0)
7185 report_file_error ("Creating pipe for child signal", Qnil);
7186 if (FD_SETSIZE <= fds[0])
7187 {
7188 /* Since we need to `pselect' on the read end, it has to fit
7189 into an `fd_set'. */
7190 emacs_close (fds[0]);
7191 emacs_close (fds[1]);
7192 report_file_errno ("Creating pipe for child signal", Qnil,
7193 EMFILE);
7194 }
7195
7196 /* We leave the file descriptors open until the Emacs process
7197 exits. */
7198 eassert (0 <= fds[0]);
7199 eassert (0 <= fds[1]);
7200 if (fcntl (fds[0], F_SETFL, O_NONBLOCK) != 0)
7201 emacs_perror ("fcntl");
7202 if (fcntl (fds[1], F_SETFL, O_NONBLOCK) != 0)
7203 emacs_perror ("fcntl");
7204 add_read_fd (fds[0], child_signal_read, NULL);
7205 fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD;
7206 child_signal_read_fd = fds[0];
7207 child_signal_write_fd = fds[1];
7208#endif /* !WINDOWSNT */
7209}
7210
7211#ifndef WINDOWSNT
7212/* Consume a process status change. */
7213
7214static void
7215child_signal_read (int fd, void *data)
7216{
7217 eassert (0 <= fd);
7218 eassert (fd == child_signal_read_fd);
7219 char dummy;
7220 if (emacs_read (fd, &dummy, 1) < 0)
7221 emacs_perror ("reading from child signal FD");
7222}
7223#endif /* !WINDOWSNT */
7224
7225/* Notify `wait_reading_process_output' of a process status
7226 change. */
7227
7228static void
7229child_signal_notify (void)
7230{
7231#ifndef WINDOWSNT
7232 int fd = child_signal_write_fd;
7233 eassert (0 <= fd);
7234 char dummy = 0;
7235 if (emacs_write (fd, &dummy, 1) != 1)
7236 emacs_perror ("writing to child signal FD");
7237#endif
7238}
7118 7239
7119/* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing 7240/* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing
7120 its own SIGCHLD handling. On POSIXish systems, glib needs this to 7241 its own SIGCHLD handling. On POSIXish systems, glib needs this to
@@ -7152,6 +7273,7 @@ static void
7152handle_child_signal (int sig) 7273handle_child_signal (int sig)
7153{ 7274{
7154 Lisp_Object tail, proc; 7275 Lisp_Object tail, proc;
7276 bool changed = false;
7155 7277
7156 /* Find the process that signaled us, and record its status. */ 7278 /* Find the process that signaled us, and record its status. */
7157 7279
@@ -7174,6 +7296,7 @@ handle_child_signal (int sig)
7174 eassert (ok); 7296 eassert (ok);
7175 if (child_status_changed (deleted_pid, 0, 0)) 7297 if (child_status_changed (deleted_pid, 0, 0))
7176 { 7298 {
7299 changed = true;
7177 if (STRINGP (XCDR (head))) 7300 if (STRINGP (XCDR (head)))
7178 unlink (SSDATA (XCDR (head))); 7301 unlink (SSDATA (XCDR (head)));
7179 XSETCAR (tail, Qnil); 7302 XSETCAR (tail, Qnil);
@@ -7191,6 +7314,7 @@ handle_child_signal (int sig)
7191 && child_status_changed (p->pid, &status, WUNTRACED | WCONTINUED)) 7314 && child_status_changed (p->pid, &status, WUNTRACED | WCONTINUED))
7192 { 7315 {
7193 /* Change the status of the process that was found. */ 7316 /* Change the status of the process that was found. */
7317 changed = true;
7194 p->tick = ++process_tick; 7318 p->tick = ++process_tick;
7195 p->raw_status = status; 7319 p->raw_status = status;
7196 p->raw_status_new = 1; 7320 p->raw_status_new = 1;
@@ -7210,6 +7334,10 @@ handle_child_signal (int sig)
7210 } 7334 }
7211 } 7335 }
7212 7336
7337 if (changed)
7338 /* Wake up `wait_reading_process_output'. */
7339 child_signal_notify ();
7340
7213 lib_child_handler (sig); 7341 lib_child_handler (sig);
7214#ifdef NS_IMPL_GNUSTEP 7342#ifdef NS_IMPL_GNUSTEP
7215 /* NSTask in GNUstep sets its child handler each time it is called. 7343 /* NSTask in GNUstep sets its child handler each time it is called.
diff --git a/src/term.c b/src/term.c
index a87f9c745ce..1059b0669a7 100644
--- a/src/term.c
+++ b/src/term.c
@@ -790,7 +790,7 @@ tty_write_glyphs (struct frame *f, struct glyph *string, int len)
790 cmcheckmagic (tty); 790 cmcheckmagic (tty);
791} 791}
792 792
793#ifdef HAVE_GPM /* Only used by GPM code. */ 793#ifndef DOS_NT
794 794
795static void 795static void
796tty_write_glyphs_with_face (register struct frame *f, register struct glyph *string, 796tty_write_glyphs_with_face (register struct frame *f, register struct glyph *string,
@@ -847,6 +847,7 @@ tty_write_glyphs_with_face (register struct frame *f, register struct glyph *str
847 847
848 cmcheckmagic (tty); 848 cmcheckmagic (tty);
849} 849}
850
850#endif 851#endif
851 852
852/* An implementation of insert_glyphs for termcap frames. */ 853/* An implementation of insert_glyphs for termcap frames. */
@@ -2380,25 +2381,9 @@ frame's terminal). */)
2380 Mouse 2381 Mouse
2381 ***********************************************************************/ 2382 ***********************************************************************/
2382 2383
2383#ifdef HAVE_GPM 2384#ifndef DOS_NT
2384
2385#ifndef HAVE_WINDOW_SYSTEM
2386void
2387term_mouse_moveto (int x, int y)
2388{
2389 /* TODO: how to set mouse position?
2390 const char *name;
2391 int fd;
2392 name = (const char *) ttyname (0);
2393 fd = emacs_open (name, O_WRONLY, 0);
2394 SOME_FUNCTION (x, y, fd);
2395 emacs_close (fd);
2396 last_mouse_x = x;
2397 last_mouse_y = y; */
2398}
2399#endif /* HAVE_WINDOW_SYSTEM */
2400 2385
2401/* Implementation of draw_row_with_mouse_face for TTY/GPM. */ 2386/* Implementation of draw_row_with_mouse_face for TTY/GPM and macOS. */
2402void 2387void
2403tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, 2388tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row,
2404 int start_hpos, int end_hpos, 2389 int start_hpos, int end_hpos,
@@ -2430,6 +2415,24 @@ tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row,
2430 cursor_to (f, save_y, save_x); 2415 cursor_to (f, save_y, save_x);
2431} 2416}
2432 2417
2418#endif
2419
2420#ifdef HAVE_GPM
2421
2422void
2423term_mouse_moveto (int x, int y)
2424{
2425 /* TODO: how to set mouse position?
2426 const char *name;
2427 int fd;
2428 name = (const char *) ttyname (0);
2429 fd = emacs_open (name, O_WRONLY, 0);
2430 SOME_FUNCTION (x, y, fd);
2431 emacs_close (fd);
2432 last_mouse_x = x;
2433 last_mouse_y = y; */
2434}
2435
2433/* Return the current time, as a Time value. Wrap around on overflow. */ 2436/* Return the current time, as a Time value. Wrap around on overflow. */
2434static Time 2437static Time
2435current_Time (void) 2438current_Time (void)
@@ -4246,8 +4249,8 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\
4246 4249
4247#ifdef HAVE_GPM 4250#ifdef HAVE_GPM
4248 terminal->mouse_position_hook = term_mouse_position; 4251 terminal->mouse_position_hook = term_mouse_position;
4249 tty->mouse_highlight.mouse_face_window = Qnil;
4250#endif 4252#endif
4253 tty->mouse_highlight.mouse_face_window = Qnil;
4251 4254
4252 terminal->kboard = allocate_kboard (Qnil); 4255 terminal->kboard = allocate_kboard (Qnil);
4253 terminal->kboard->reference_count++; 4256 terminal->kboard->reference_count++;
diff --git a/src/termhooks.h b/src/termhooks.h
index 85a47c071b6..3800679e803 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -366,9 +366,7 @@ enum {
366#ifdef HAVE_GPM 366#ifdef HAVE_GPM
367#include <gpm.h> 367#include <gpm.h>
368extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *); 368extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *);
369#ifndef HAVE_WINDOW_SYSTEM
370extern void term_mouse_moveto (int, int); 369extern void term_mouse_moveto (int, int);
371#endif
372 370
373/* The device for which we have enabled gpm support. */ 371/* The device for which we have enabled gpm support. */
374extern struct tty_display_info *gpm_tty; 372extern struct tty_display_info *gpm_tty;
diff --git a/src/window.c b/src/window.c
index e025e0b0821..eb16e2a4338 100644
--- a/src/window.c
+++ b/src/window.c
@@ -2260,7 +2260,7 @@ return value is a list of elements of the form (PARAMETER . VALUE). */)
2260Lisp_Object 2260Lisp_Object
2261window_parameter (struct window *w, Lisp_Object parameter) 2261window_parameter (struct window *w, Lisp_Object parameter)
2262{ 2262{
2263 Lisp_Object result = Fassq (parameter, w->window_parameters); 2263 Lisp_Object result = assq_no_quit (parameter, w->window_parameters);
2264 2264
2265 return CDR_SAFE (result); 2265 return CDR_SAFE (result);
2266} 2266}
diff --git a/src/xdisp.c b/src/xdisp.c
index ea67329cff1..e1e4ff41365 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -20822,9 +20822,8 @@ try_window_id (struct window *w)
20822 + window_wants_header_line (w) 20822 + window_wants_header_line (w)
20823 + window_internal_height (w)); 20823 + window_internal_height (w));
20824 20824
20825#if defined (HAVE_GPM) || defined (MSDOS)
20826 gui_clear_window_mouse_face (w); 20825 gui_clear_window_mouse_face (w);
20827#endif 20826
20828 /* Perform the operation on the screen. */ 20827 /* Perform the operation on the screen. */
20829 if (dvpos > 0) 20828 if (dvpos > 0)
20830 { 20829 {
@@ -31928,9 +31927,8 @@ draw_row_with_mouse_face (struct window *w, int start_x, struct glyph_row *row,
31928 return; 31927 return;
31929 } 31928 }
31930#endif 31929#endif
31931#if defined (HAVE_GPM) || defined (MSDOS) || defined (WINDOWSNT) 31930
31932 tty_draw_row_with_mouse_face (w, row, start_hpos, end_hpos, draw); 31931 tty_draw_row_with_mouse_face (w, row, start_hpos, end_hpos, draw);
31933#endif
31934} 31932}
31935 31933
31936/* Display the active region described by mouse_face_* according to DRAW. */ 31934/* Display the active region described by mouse_face_* according to DRAW. */
diff --git a/test/Makefile.in b/test/Makefile.in
index 849fbbf474e..bfab95b9381 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -253,11 +253,17 @@ endef
253 253
254$(foreach test,${TESTS},$(eval $(call test_template,${test}))) 254$(foreach test,${TESTS},$(eval $(call test_template,${test})))
255 255
256# Get the tests for only a specific directory 256## Get the tests for only a specific directory.
257NET_TESTS := $(patsubst %.el,%,$(wildcard lisp/net/*.el)) 257SUBDIRS = $(sort $(shell find lib-src lisp src -type d ! -path "*resources*" -print))
258LISP_TESTS := $(patsubst %.el,%,$(wildcard lisp/*.el)) 258
259check-net: ${NET_TESTS} 259define subdir_template
260check-lisp: ${LISP_TESTS} 260 .PHONY: check-$(subst /,-,$(1))
261 check-$(subst /,-,$(1)):
262 @${MAKE} check LOGFILES="$(patsubst %.el,%.log, \
263 $(patsubst $(srcdir)/%,%,$(wildcard $(1)/*.el)))"
264endef
265
266$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir))))
261 267
262ifeq (@HAVE_MODULES@, yes) 268ifeq (@HAVE_MODULES@, yes)
263# -fPIC is a no-op on Windows, but causes a compiler warning 269# -fPIC is a no-op on Windows, but causes a compiler warning
@@ -325,10 +331,10 @@ check-doit:
325ifeq ($(TEST_INTERACTIVE), yes) 331ifeq ($(TEST_INTERACTIVE), yes)
326 HOME=$(TEST_HOME) $(emacs) \ 332 HOME=$(TEST_HOME) $(emacs) \
327 -l ert ${ert_opts} \ 333 -l ert ${ert_opts} \
328 $(patsubst %,-l %,$(if $(findstring $(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \ 334 $(patsubst %,-l %,$(if $(findstring $(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \
329 $(TEST_RUN_ERT) 335 $(TEST_RUN_ERT)
330else 336else
331 -@${MAKE} -k ${LOGFILES} 337 -@${MAKE} -k ${LOGFILES}
332 @$(emacs) --batch -l ert --eval \ 338 @$(emacs) --batch -l ert --eval \
333 "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES} 339 "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES}
334endif 340endif
diff --git a/test/README b/test/README
index 38f4a109701..5f3c10adbe1 100644
--- a/test/README
+++ b/test/README
@@ -39,11 +39,10 @@ The Makefile in this directory supports the following targets:
39* make check-all 39* make check-all
40 Like "make check", but run all tests. 40 Like "make check", but run all tests.
41 41
42* make check-lisp 42* make check-<dirname>
43 Like "make check", but run only the tests in test/lisp/*.el 43 Like "make check", but run only the tests in test/<dirname>/*.el.
44 44 <dirname> is a relative directory path, which has replaced "/" by "-",
45* make check-net 45 like in "check-src" or "check-lisp-net".
46 Like "make check", but run only the tests in test/lisp/net/*.el
47 46
48* make <filename> -or- make <filename>.log 47* make <filename> -or- make <filename>.log
49 Run all tests declared in <filename>.el. This includes expensive 48 Run all tests declared in <filename>.el. This includes expensive
@@ -61,7 +60,9 @@ https://www.gnu.org/software/emacs/manual/html_node/ert/Test-Selectors.html
61 60
62You could use predefined selectors of the Makefile. "make <filename> 61You could use predefined selectors of the Makefile. "make <filename>
63SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for <filename>.el 62SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for <filename>.el
64except the tests tagged as expensive or unstable. 63except the tests tagged as expensive or unstable. Other predefined
64selectors are $(SELECTOR_EXPENSIVE) (run all tests except unstable
65ones) and $(SELECTOR_ALL) (run all tests).
65 66
66If your test file contains the tests "test-foo", "test2-foo" and 67If your test file contains the tests "test-foo", "test2-foo" and
67"test-foo-remote", and you want to run only the former two tests, you 68"test-foo-remote", and you want to run only the former two tests, you
diff --git a/test/file-organization.org b/test/file-organization.org
index efc354529c5..7cf5b88d6d0 100644
--- a/test/file-organization.org
+++ b/test/file-organization.org
@@ -17,13 +17,15 @@ Sub-directories are in many cases themed after packages (~gnus~, ~org~,
17~calc~), related functionality (~net~, ~emacs-lisp~, ~progmodes~) or status 17~calc~), related functionality (~net~, ~emacs-lisp~, ~progmodes~) or status
18(~obsolete~). 18(~obsolete~).
19 19
20C source is stored in the ~src~ directory, which is flat. 20C source is stored in the ~src~ directory, which is flat. Source for
21utility programs is stored in the ~lib-src~ directory.
21 22
22** Test Files 23** Test Files
23 24
24Automated tests should be stored in the ~test/lisp~ directory for 25Automated tests should be stored in the ~test/lisp~ directory for
25tests of functionality implemented in Lisp, and in the ~test/src~ 26tests of functionality implemented in Lisp, in the ~test/src~
26directory for functionality implemented in C. Tests should reflect 27directory for functionality implemented in C, and in the
28~test/lib-src~ directory for utility programs. Tests should reflect
27the directory structure of the source tree; so tests for files in the 29the directory structure of the source tree; so tests for files in the
28~lisp/emacs-lisp~ source directory should reside in the 30~lisp/emacs-lisp~ source directory should reside in the
29~test/lisp/emacs-lisp~ directory. 31~test/lisp/emacs-lisp~ directory.
@@ -36,10 +38,10 @@ files of any name which are themselves placed in a directory named
36after the feature with ~-tests~ appended, such as 38after the feature with ~-tests~ appended, such as
37~/test/lisp/emacs-lisp/eieio-tests~ 39~/test/lisp/emacs-lisp/eieio-tests~
38 40
39Similarly, features implemented in C should reside in ~/test/src~ and 41Similarly, tests of features implemented in C should reside in
40be named after the C file with ~-tests.el~ added to the base-name of 42~/test/src~ or in ~test/lib-src~ and be named after the C file with
41the tested source file. Thus, tests for ~src/fileio.c~ should be in 43~-tests.el~ added to the base-name of the tested source file. Thus,
42~test/src/fileio-tests.el~. 44tests for ~src/fileio.c~ should be in ~test/src/fileio-tests.el~.
43 45
44There are also some test materials that cannot be run automatically 46There are also some test materials that cannot be run automatically
45(i.e. via ert). These should be placed in ~/test/manual~; they are 47(i.e. via ert). These should be placed in ~/test/manual~; they are
diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba
index dd41982ad59..421264db9c9 100644
--- a/test/infra/Dockerfile.emba
+++ b/test/infra/Dockerfile.emba
@@ -41,7 +41,7 @@ COPY . /checkout
41WORKDIR /checkout 41WORKDIR /checkout
42RUN ./autogen.sh autoconf 42RUN ./autogen.sh autoconf
43RUN ./configure --without-makeinfo 43RUN ./configure --without-makeinfo
44RUN make bootstrap 44RUN make -j4 bootstrap
45RUN make -j4 45RUN make -j4
46 46
47FROM emacs-base as emacs-filenotify-gio 47FROM emacs-base as emacs-filenotify-gio
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml
new file mode 100644
index 00000000000..5a0ab54e4b9
--- /dev/null
+++ b/test/infra/gitlab-ci.yml
@@ -0,0 +1,245 @@
1# Copyright (C) 2017-2021 Free Software Foundation, Inc.
2#
3# This file is part of GNU Emacs.
4#
5# GNU Emacs is free software: you can redistribute it and/or modify
6# it under the terms of the GNU General Public License as published by
7# the Free Software Foundation, either version 3 of the License, or
8# (at your option) any later version.
9#
10# GNU Emacs is distributed in the hope that it will be useful,
11# but WITHOUT ANY WARRANTY; without even the implied warranty of
12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13# GNU General Public License for more details.
14#
15# You should have received a copy of the GNU General Public License
16# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
17
18# GNU Emacs support for the GitLab protocol for CI
19
20# The presence of this file does not imply any FSF/GNU endorsement of
21# any particular service that uses that protocol. Also, it is intended for
22# evaluation purposes, thus possibly temporary.
23
24# Maintainer: Ted Zlatanov <tzz@lifelogs.com>
25# URL: https://emba.gnu.org/emacs/emacs
26
27# Never run merge request pipelines, they usually duplicate push pipelines
28# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules
29
30# Rules: always run tags and branches named master*, emacs*, feature*, fix*
31# Test that it triggers by pushing a tag: `git tag mytag; git push origin mytag`
32# Test that it triggers by pushing to: feature/emba, feature1, master, master-2, fix/emba, emacs-299, fix-2
33# Test that it doesn't trigger by pushing to: scratch-2, scratch/emba, oldbranch, dev
34workflow:
35 rules:
36 - if: '$CI_PIPELINE_SOURCE == "merge_request_event"'
37 when: never
38 - if: '$CI_COMMIT_TAG'
39 when: always
40 - if: '$CI_COMMIT_BRANCH !~ /^(master|emacs|feature|fix)/'
41 when: never
42 - when: always
43
44variables:
45 GIT_STRATEGY: fetch
46 EMACS_EMBA_CI: 1
47 # # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled
48 # DOCKER_HOST: tcp://docker:2376
49 # DOCKER_TLS_CERTDIR: "/certs"
50 # Put the configuration for each run in a separate directory to avoid conflicts
51 DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}"
52 # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap across multiple builds
53 BUILD_TAG: ${CI_COMMIT_REF_SLUG}
54
55default:
56 image: docker:19.03.12
57 timeout: 3 hours
58 before_script:
59 - docker info
60 - echo "docker registry is ${CI_REGISTRY}"
61 - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY}
62
63.job-template:
64 rules:
65 - changes:
66 - "**/Makefile.in"
67 - .gitlab-ci.yml
68 - aclocal.m4
69 - autogen.sh
70 - configure.ac
71 - lib/*.{h,c}
72 - lisp/**/*.el
73 - src/*.{h,c}
74 - test/infra/*
75 - test/lib-src/*.el
76 - test/lisp/**/*.el
77 - test/src/*.el
78 - changes:
79 # gfilemonitor, kqueue
80 - src/gfilenotify.c
81 - src/kqueue.c
82 # MS Windows
83 - "**/w32*"
84 # GNUstep
85 - lisp/term/ns-win.el
86 - src/ns*.{h,m}
87 - src/macfont.{h,m}
88 when: never
89 # these will be cached across builds
90 cache:
91 key: ${CI_COMMIT_SHA}
92 paths: []
93 policy: pull-push
94 # these will be saved for followup builds
95 artifacts:
96 expire_in: 24 hrs
97 paths: []
98 # - "test/**/*.log"
99 # - "**/*.log"
100 # using the variables for each job
101 script:
102 - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG}
103 # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it
104 - 'export PWD=$(pwd)'
105 - 'docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"'
106
107.build-template:
108 rules:
109 - if: '$CI_PIPELINE_SOURCE == "web"'
110 when: always
111 - changes:
112 - "**/Makefile.in"
113 - .gitlab-ci.yml
114 - aclocal.m4
115 - autogen.sh
116 - configure.ac
117 - lib/*.{h,c}
118 - lisp/emacs-lisp/*.el
119 - src/*.{h,c}
120 - test/infra/*
121 - changes:
122 # gfilemonitor, kqueue
123 - src/gfilenotify.c
124 - src/kqueue.c
125 # MS Windows
126 - "**/w32*"
127 # GNUstep
128 - lisp/term/ns-win.el
129 - src/ns*.{h,m}
130 - src/macfont.{h,m}
131 when: never
132 script:
133 - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba .
134 - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG}
135
136.gnustep-template:
137 rules:
138 - if: '$CI_PIPELINE_SOURCE == "web"'
139 - if: '$CI_PIPELINE_SOURCE == "schedule"'
140 changes:
141 - "**/Makefile.in"
142 - .gitlab-ci.yml
143 - configure.ac
144 - src/ns*.{h,m}
145 - src/macfont.{h,m}
146 - lisp/term/ns-win.el
147 - nextstep/**/*
148 - test/infra/*
149
150.filenotify-gio-template:
151 rules:
152 - if: '$CI_PIPELINE_SOURCE == "web"'
153 - if: '$CI_PIPELINE_SOURCE == "schedule"'
154 changes:
155 - "**/Makefile.in"
156 - .gitlab-ci.yml
157 - lisp/autorevert.el
158 - lisp/filenotify.el
159 - lisp/net/tramp-sh.el
160 - src/gfilenotify.c
161 - test/infra/*
162 - test/lisp/autorevert-tests.el
163 - test/lisp/filenotify-tests.el
164
165stages:
166 - prep-images
167 - build-images
168 - fast
169 - normal
170 - platform-images
171 - platforms
172 - slow
173
174prep-image-base:
175 stage: prep-images
176 extends: [.job-template, .build-template]
177 variables:
178 target: emacs-base
179
180build-image-inotify:
181 stage: build-images
182 extends: [.job-template, .build-template]
183 variables:
184 target: emacs-inotify
185
186test-fast-inotify:
187 stage: fast
188 extends: [.job-template]
189 variables:
190 target: emacs-inotify
191 make_params: "-C test check"
192
193build-image-filenotify-gio:
194 stage: platform-images
195 extends: [.job-template, .build-template, .filenotify-gio-template]
196 variables:
197 target: emacs-filenotify-gio
198
199build-image-gnustep:
200 stage: platform-images
201 extends: [.job-template, .build-template, .gnustep-template]
202 variables:
203 target: emacs-gnustep
204
205test-lisp-inotify:
206 stage: normal
207 extends: [.job-template]
208 variables:
209 target: emacs-inotify
210 make_params: "-C test check-lisp"
211
212test-lisp-net-inotify:
213 stage: normal
214 extends: [.job-template]
215 variables:
216 target: emacs-inotify
217 make_params: "-C test check-lisp-net"
218
219test-filenotify-gio:
220 # This tests file monitor libraries gfilemonitor and gio.
221 stage: platforms
222 extends: [.job-template, .filenotify-gio-template]
223 variables:
224 target: emacs-filenotify-gio
225 make_params: "-k -C test autorevert-tests filenotify-tests"
226
227test-gnustep:
228 # This tests the GNUstep build process
229 stage: platforms
230 extends: [.job-template, .gnustep-template]
231 variables:
232 target: emacs-gnustep
233 make_params: install
234
235test-all-inotify:
236 # This tests also file monitor libraries inotify and inotifywatch.
237 stage: slow
238 extends: [.job-template]
239 rules:
240 # note there's no "changes" section, so this always runs on a schedule
241 - if: '$CI_PIPELINE_SOURCE == "web"'
242 - if: '$CI_PIPELINE_SOURCE == "schedule"'
243 variables:
244 target: emacs-inotify
245 make_params: check-expensive
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el
index 6da515bb2c8..45cf6353960 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -524,8 +524,10 @@ This expects `auto-revert--messages' to be bound by
524 (auto-revert-test--write-file "1-b" file-1) 524 (auto-revert-test--write-file "1-b" file-1)
525 (auto-revert-test--wait-for-buffer-text 525 (auto-revert-test--wait-for-buffer-text
526 buf-1 "1-b" (auto-revert--timeout)) 526 buf-1 "1-b" (auto-revert--timeout))
527 (should (buffer-local-value 527 ;; On emba, `buf-1' is a killed buffer.
528 'auto-revert-notify-watch-descriptor buf-1)) 528 (when (buffer-live-p buf-1)
529 (should (buffer-local-value
530 'auto-revert-notify-watch-descriptor buf-1)))
529 531
530 ;; Write a buffer to a new file, then modify the new file on disk. 532 ;; Write a buffer to a new file, then modify the new file on disk.
531 (with-current-buffer buf-2 533 (with-current-buffer buf-2
@@ -607,11 +609,12 @@ This expects `auto-revert--messages' to be bound by
607 (should auto-revert-mode)) 609 (should auto-revert-mode))
608 610
609 (dotimes (i num-buffers) 611 (dotimes (i num-buffers)
610 (add-to-list 612 (push (make-indirect-buffer
611 'buffers 613 (car buffers)
612 (make-indirect-buffer 614 (format "%s-%d" (buffer-file-name (car buffers)) i)
613 (car buffers) (format "%s-%d" (buffer-file-name (car buffers)) i) 'clone) 615 'clone)
614 'append)) 616 buffers))
617 (setq buffers (nreverse buffers))
615 (dolist (buf buffers) 618 (dolist (buf buffers)
616 (with-current-buffer buf 619 (with-current-buffer buf
617 (should (string-equal (buffer-string) "any text")) 620 (should (string-equal (buffer-string) "any text"))
@@ -638,10 +641,10 @@ This expects `auto-revert--messages' to be bound by
638 (auto-revert-tests--write-file "any text" tmpfile (pop times)) 641 (auto-revert-tests--write-file "any text" tmpfile (pop times))
639 642
640 (dotimes (i num-buffers) 643 (dotimes (i num-buffers)
641 (add-to-list 644 (push (generate-new-buffer
642 'buffers 645 (format "%s-%d" (file-name-nondirectory tmpfile) i))
643 (generate-new-buffer (format "%s-%d" (file-name-nondirectory tmpfile) i)) 646 buffers))
644 'append)) 647 (setq buffers (nreverse buffers))
645 (dolist (buf buffers) 648 (dolist (buf buffers)
646 (with-current-buffer buf 649 (with-current-buffer buf
647 (insert-file-contents tmpfile 'visit) 650 (insert-file-contents tmpfile 'visit)
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el
new file mode 100644
index 00000000000..47481574ea8
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el
@@ -0,0 +1,6 @@
1;; -*- lexical-binding: t; -*-
2
3(defsubst foo-inlineable (foo-var)
4 (+ foo-var 2))
5
6(provide 'foo-inlinable)
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el
new file mode 100644
index 00000000000..5582b2ab0ea
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el
@@ -0,0 +1,17 @@
1;; -*- lexical-binding: t; -*-
2
3;; In this test, we try and make sure that inlined functions's code isn't
4;; mistakenly re-interpreted in the caller's context: we import an
5;; inlinable function from another file where `foo-var' is a normal
6;; lexical variable, and then call(inline) it in a function where
7;; `foo-var' is a dynamically-scoped variable.
8
9(require 'foo-inlinable
10 (expand-file-name "foo-inlinable.el"
11 (file-name-directory
12 (or byte-compile-current-file load-file-name))))
13
14(defvar foo-var)
15
16(defun foo-fun ()
17 (+ (foo-inlineable 5) 1))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index a07af188fac..980b402ca2d 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -617,13 +617,13 @@ Subtests signal errors if something goes wrong."
617(make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") 617(make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99")
618 618
619(bytecomp--define-warning-file-test "warn-obsolete-hook.el" 619(bytecomp--define-warning-file-test "warn-obsolete-hook.el"
620 "bytecomp--tests-obs.*obsolete.*99.99") 620 "bytecomp--tests-obs.*obsolete[^z-a]*99.99")
621 621
622(bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" 622(bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el"
623 "foo-obs.*obsolete.*99.99" t) 623 "foo-obs.*obsolete.*99.99" t)
624 624
625(bytecomp--define-warning-file-test "warn-obsolete-variable.el" 625(bytecomp--define-warning-file-test "warn-obsolete-variable.el"
626 "bytecomp--tests-obs.*obsolete.*99.99") 626 "bytecomp--tests-obs.*obsolete[^z-a]*99.99")
627 627
628(bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" 628(bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el"
629 "bytecomp--tests-obs.*obsolete.*99.99" t) 629 "bytecomp--tests-obs.*obsolete.*99.99" t)
@@ -713,6 +713,10 @@ Subtests signal errors if something goes wrong."
713 "warn-wide-docstring-multiline.el" 713 "warn-wide-docstring-multiline.el"
714 "defvar.*foo.*wider than.*characters") 714 "defvar.*foo.*wider than.*characters")
715 715
716(bytecomp--define-warning-file-test
717 "nowarn-inline-after-defvar.el"
718 "Lexical argument shadows" 'reverse)
719
716 720
717;;;; Macro expansion. 721;;;; Macro expansion.
718 722
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el
index 97a44c43ef7..065ca4fa651 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -543,15 +543,7 @@
543 (apply (lambda (x) (+ x 1)) (list 8))))) 543 (apply (lambda (x) (+ x 1)) (list 8)))))
544 '(5 (6 5) (6 6) 9)))) 544 '(5 (6 5) (6 6) 9))))
545 545
546(defun cl-lib-tests--dummy-function ()
547 ;; Dummy function to see if the file is compiled.
548 t)
549
550(ert-deftest cl-lib-defstruct-record () 546(ert-deftest cl-lib-defstruct-record ()
551 ;; This test fails when compiled, see Bug#24402/27718.
552 :expected-result (if (byte-code-function-p
553 (symbol-function 'cl-lib-tests--dummy-function))
554 :failed :passed)
555 (cl-defstruct foo x) 547 (cl-defstruct foo x)
556 (let ((x (make-foo :x 42))) 548 (let ((x (make-foo :x 42)))
557 (should (recordp x)) 549 (should (recordp x))
@@ -566,6 +558,7 @@
566 (should (eq (type-of x) 'vector)) 558 (should (eq (type-of x) 'vector))
567 559
568 (cl-old-struct-compat-mode 1) 560 (cl-old-struct-compat-mode 1)
561 (defvar cl-struct-foo)
569 (let ((cl-struct-foo (cl--struct-get-class 'foo))) 562 (let ((cl-struct-foo (cl--struct-get-class 'foo)))
570 (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) 563 (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check)
571 (should (eq (type-of x) 'foo)) 564 (should (eq (type-of x) 'foo))
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index 1b06c6e7543..e6f4c097504 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -32,6 +32,10 @@
32 (should (equal (pcase '(2 . 3) ;bug#18554 32 (should (equal (pcase '(2 . 3) ;bug#18554
33 (`(,hd . ,(and (pred atom) tl)) (list hd tl)) 33 (`(,hd . ,(and (pred atom) tl)) (list hd tl))
34 ((pred consp) nil)) 34 ((pred consp) nil))
35 '(2 3)))
36 (should (equal (pcase '(2 . 3)
37 (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl))
38 ((pred consp) nil))
35 '(2 3)))) 39 '(2 3))))
36 40
37(pcase-defmacro pcase-tests-plus (pat n) 41(pcase-defmacro pcase-tests-plus (pat n)
diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el
index 670398354a6..05c7fbe781e 100644
--- a/test/lisp/emacs-lisp/seq-tests.el
+++ b/test/lisp/emacs-lisp/seq-tests.el
@@ -29,6 +29,9 @@
29(require 'ert) 29(require 'ert)
30(require 'seq) 30(require 'seq)
31 31
32(eval-when-compile
33 (require 'cl-lib))
34
32(defmacro with-test-sequences (spec &rest body) 35(defmacro with-test-sequences (spec &rest body)
33 "Successively bind VAR to a list, vector, and string built from SEQ. 36 "Successively bind VAR to a list, vector, and string built from SEQ.
34Evaluate BODY for each created sequence. 37Evaluate BODY for each created sequence.
@@ -108,16 +111,12 @@ Evaluate BODY for each created sequence.
108 '((a 0) (b 1) (c 2) (d 3))))) 111 '((a 0) (b 1) (c 2) (d 3)))))
109 112
110(ert-deftest test-seq-do-indexed () 113(ert-deftest test-seq-do-indexed ()
111 (let ((result nil)) 114 (let (result)
112 (seq-do-indexed (lambda (elt i) 115 (seq-do-indexed (lambda (elt i) (push (list elt i) result)) ())
113 (add-to-list 'result (list elt i))) 116 (should-not result))
114 nil)
115 (should (equal result nil)))
116 (with-test-sequences (seq '(4 5 6)) 117 (with-test-sequences (seq '(4 5 6))
117 (let ((result nil)) 118 (let (result)
118 (seq-do-indexed (lambda (elt i) 119 (seq-do-indexed (lambda (elt i) (push (list elt i) result)) seq)
119 (add-to-list 'result (list elt i)))
120 seq)
121 (should (equal (seq-elt result 0) '(6 2))) 120 (should (equal (seq-elt result 0) '(6 2)))
122 (should (equal (seq-elt result 1) '(5 1))) 121 (should (equal (seq-elt result 1) '(5 1)))
123 (should (equal (seq-elt result 2) '(4 0)))))) 122 (should (equal (seq-elt result 2) '(4 0))))))
@@ -410,12 +409,10 @@ Evaluate BODY for each created sequence.
410 409
411(ert-deftest test-seq-random-elt-take-all () 410(ert-deftest test-seq-random-elt-take-all ()
412 (let ((seq '(a b c d e)) 411 (let ((seq '(a b c d e))
413 (elts '())) 412 elts)
414 (should (= 0 (length elts)))
415 (dotimes (_ 1000) 413 (dotimes (_ 1000)
416 (let ((random-elt (seq-random-elt seq))) 414 (let ((random-elt (seq-random-elt seq)))
417 (add-to-list 'elts 415 (cl-pushnew random-elt elts)))
418 random-elt)))
419 (should (= 5 (length elts))))) 416 (should (= 5 (length elts)))))
420 417
421(ert-deftest test-seq-random-elt-signal-on-empty () 418(ert-deftest test-seq-random-elt-signal-on-empty ()
diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el
index 6e77259fe1b..c0db9c9de17 100644
--- a/test/lisp/faces-tests.el
+++ b/test/lisp/faces-tests.el
@@ -217,5 +217,13 @@
217 )) 217 ))
218 ) 218 )
219 219
220(ert-deftest test-tty-find-type ()
221 (let ((pred (lambda (string)
222 (locate-library (concat "term/" string ".el")))))
223 (should (tty-find-type pred "cygwin"))
224 (should (tty-find-type pred "cygwin-foo"))
225 (should (equal (tty-find-type pred "xterm") "xterm"))
226 (should (equal (tty-find-type pred "screen.xterm") "screen"))))
227
220(provide 'faces-tests) 228(provide 'faces-tests)
221;;; faces-tests.el ends here 229;;; faces-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index ef0968a3385..7757c55c16b 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2272,8 +2272,8 @@ This checks also `file-name-as-directory', `file-name-directory',
2272 (delete-file tmp-name) 2272 (delete-file tmp-name)
2273 (should-not (file-exists-p tmp-name)) 2273 (should-not (file-exists-p tmp-name))
2274 2274
2275 ;; Trashing files doesn't work for crypted remote files. 2275 ;; Trashing files doesn't work on MS Windows, and for crypted remote files.
2276 (unless (tramp--test-crypt-p) 2276 (unless (or (tramp--test-windows-nt-p) (tramp--test-crypt-p))
2277 (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) 2277 (let ((trash-directory (tramp--test-make-temp-name 'local quoted))
2278 (delete-by-moving-to-trash t)) 2278 (delete-by-moving-to-trash t))
2279 (make-directory trash-directory) 2279 (make-directory trash-directory)
@@ -2786,9 +2786,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
2786 (should-not (file-directory-p tmp-name1)) 2786 (should-not (file-directory-p tmp-name1))
2787 2787
2788 ;; Trashing directories works only since Emacs 27.1. It doesn't 2788 ;; Trashing directories works only since Emacs 27.1. It doesn't
2789 ;; work for crypted remote directories and for ange-ftp. 2789 ;; work on MS Windows, for crypted remote directories and for ange-ftp.
2790 (when (and (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) 2790 (when (and (not (tramp--test-windows-nt-p)) (not (tramp--test-crypt-p))
2791 (tramp--test-emacs27-p)) 2791 (not (tramp--test-ftp-p)) (tramp--test-emacs27-p))
2792 (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) 2792 (let ((trash-directory (tramp--test-make-temp-name 'local quoted))
2793 (delete-by-moving-to-trash t)) 2793 (delete-by-moving-to-trash t))
2794 (make-directory trash-directory) 2794 (make-directory trash-directory)
@@ -5247,7 +5247,7 @@ Use direct async.")
5247 ;; order to avoid a question. `explicit-sh-args' echoes the 5247 ;; order to avoid a question. `explicit-sh-args' echoes the
5248 ;; test data. 5248 ;; test data.
5249 (with-current-buffer (get-buffer-create "*shell*") 5249 (with-current-buffer (get-buffer-create "*shell*")
5250 (ignore-errors (kill-process (current-buffer))) 5250 (ignore-errors (kill-process (get-buffer-process (current-buffer))))
5251 (should-not explicit-shell-file-name) 5251 (should-not explicit-shell-file-name)
5252 (call-interactively #'shell) 5252 (call-interactively #'shell)
5253 (with-timeout (10) 5253 (with-timeout (10)
@@ -5720,16 +5720,16 @@ This requires restrictions of file name syntax."
5720 (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) 5720 (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory)
5721 'tramp-ftp-file-name-handler)) 5721 'tramp-ftp-file-name-handler))
5722 5722
5723(defun tramp--test-crypt-p ()
5724 "Check, whether the remote directory is crypted"
5725 (tramp-crypt-file-name-p tramp-test-temporary-file-directory))
5726
5723(defun tramp--test-docker-p () 5727(defun tramp--test-docker-p ()
5724 "Check, whether the docker method is used. 5728 "Check, whether the docker method is used.
5725This does not support some special file names." 5729This does not support some special file names."
5726 (string-equal 5730 (string-equal
5727 "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) 5731 "docker" (file-remote-p tramp-test-temporary-file-directory 'method)))
5728 5732
5729(defun tramp--test-crypt-p ()
5730 "Check, whether the remote directory is crypted"
5731 (tramp-crypt-file-name-p tramp-test-temporary-file-directory))
5732
5733(defun tramp--test-ftp-p () 5733(defun tramp--test-ftp-p ()
5734 "Check, whether an FTP-like method is used. 5734 "Check, whether an FTP-like method is used.
5735This does not support globbing characters in file names (yet)." 5735This does not support globbing characters in file names (yet)."
@@ -5748,7 +5748,7 @@ If optional METHOD is given, it is checked first."
5748 "Check, whether the remote host runs HP-UX. 5748 "Check, whether the remote host runs HP-UX.
5749Several special characters do not work properly there." 5749Several special characters do not work properly there."
5750 ;; We must refill the cache. `file-truename' does it. 5750 ;; We must refill the cache. `file-truename' does it.
5751 (file-truename tramp-test-temporary-file-directory) nil 5751 (file-truename tramp-test-temporary-file-directory)
5752 (string-match-p 5752 (string-match-p
5753 "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" ""))) 5753 "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" "")))
5754 5754
@@ -5757,7 +5757,7 @@ Several special characters do not work properly there."
5757ksh93 makes some strange conversions of non-latin characters into 5757ksh93 makes some strange conversions of non-latin characters into
5758a $'' syntax." 5758a $'' syntax."
5759 ;; We must refill the cache. `file-truename' does it. 5759 ;; We must refill the cache. `file-truename' does it.
5760 (file-truename tramp-test-temporary-file-directory) nil 5760 (file-truename tramp-test-temporary-file-directory)
5761 (string-match-p 5761 (string-match-p
5762 "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" ""))) 5762 "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" "")))
5763 5763
@@ -5787,6 +5787,15 @@ This does not support special file names."
5787 "Check, whether the remote host runs a based method from tramp-sh.el." 5787 "Check, whether the remote host runs a based method from tramp-sh.el."
5788 (tramp-sh-file-name-handler-p tramp-test-vec)) 5788 (tramp-sh-file-name-handler-p tramp-test-vec))
5789 5789
5790(defun tramp--test-sh-no-ls--dired-p ()
5791 "Check, whether the remote host runs a based method from tramp-sh.el.
5792Additionally, ls does not support \"--dired\"."
5793 (and (tramp--test-sh-p)
5794 (with-temp-buffer
5795 ;; We must refill the cache. `insert-directory' does it.
5796 (insert-directory tramp-test-temporary-file-directory "-al")
5797 (not (tramp-get-connection-property tramp-test-vec "ls--dired" nil)))))
5798
5790(defun tramp--test-share-p () 5799(defun tramp--test-share-p ()
5791 "Check, whether the method needs a share." 5800 "Check, whether the method needs a share."
5792 (and (tramp--test-gvfs-p) 5801 (and (tramp--test-gvfs-p)
@@ -6023,17 +6032,20 @@ This requires restrictions of file name syntax."
6023 ;; expanded to <TAB>. 6032 ;; expanded to <TAB>.
6024 (let ((files 6033 (let ((files
6025 (list 6034 (list
6026 (if (or (tramp--test-ange-ftp-p) 6035 (cond ((or (tramp--test-ange-ftp-p)
6027 (tramp--test-gvfs-p) 6036 (tramp--test-gvfs-p)
6028 (tramp--test-rclone-p) 6037 (tramp--test-rclone-p)
6029 (tramp--test-sudoedit-p) 6038 (tramp--test-sudoedit-p)
6030 (tramp--test-windows-nt-or-smb-p)) 6039 (tramp--test-windows-nt-or-smb-p))
6031 "foo bar baz" 6040 "foo bar baz")
6032 (if (or (tramp--test-adb-p) 6041 ((or (tramp--test-adb-p)
6033 (tramp--test-docker-p) 6042 (tramp--test-docker-p)
6034 (eq system-type 'cygwin)) 6043 (eq system-type 'cygwin))
6035 " foo bar baz " 6044 " foo bar baz ")
6036 " foo\tbar baz\t")) 6045 ((tramp--test-sh-no-ls--dired-p)
6046 "\tfoo bar baz\t")
6047 (t " foo\tbar baz\t"))
6048 "@foo@bar@baz@"
6037 "$foo$bar$$baz$" 6049 "$foo$bar$$baz$"
6038 "-foo-bar-baz-" 6050 "-foo-bar-baz-"
6039 "%foo%bar%baz%" 6051 "%foo%bar%baz%"
@@ -6349,6 +6361,7 @@ process sentinels. They shall not disturb each other."
6349 (tramp--test-sh-p))) 6361 (tramp--test-sh-p)))
6350 (skip-unless (not (tramp--test-crypt-p))) 6362 (skip-unless (not (tramp--test-crypt-p)))
6351 (skip-unless (not (tramp--test-docker-p))) 6363 (skip-unless (not (tramp--test-docker-p)))
6364 (skip-unless (not (tramp--test-windows-nt-p)))
6352 6365
6353 (with-timeout 6366 (with-timeout
6354 (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler)) 6367 (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler))
@@ -6358,12 +6371,11 @@ process sentinels. They shall not disturb each other."
6358 (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) 6371 (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh"))
6359 ;; It doesn't work on w32 systems. 6372 ;; It doesn't work on w32 systems.
6360 (watchdog 6373 (watchdog
6361 (unless (tramp--test-windows-nt-p) 6374 (start-process-shell-command
6362 (start-process-shell-command 6375 "*watchdog*" nil
6363 "*watchdog*" nil 6376 (format
6364 (format 6377 "sleep %d; kill -USR1 %d"
6365 "sleep %d; kill -USR1 %d" 6378 tramp--test-asynchronous-requests-timeout (emacs-pid))))
6366 tramp--test-asynchronous-requests-timeout (emacs-pid)))))
6367 (tmp-name (tramp--test-make-temp-name)) 6379 (tmp-name (tramp--test-make-temp-name))
6368 (default-directory tmp-name) 6380 (default-directory tmp-name)
6369 ;; Do not cache Tramp properties. 6381 ;; Do not cache Tramp properties.
diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el
index a10d5dab906..0da0e393535 100644
--- a/test/lisp/progmodes/elisp-mode-tests.el
+++ b/test/lisp/progmodes/elisp-mode-tests.el
@@ -314,7 +314,19 @@
314 (let* ((xref (pop xrefs)) 314 (let* ((xref (pop xrefs))
315 (expected (pop expected-xrefs)) 315 (expected (pop expected-xrefs))
316 (expected-xref (or (when (consp expected) (car expected)) expected)) 316 (expected-xref (or (when (consp expected) (car expected)) expected))
317 (expected-source (when (consp expected) (cdr expected)))) 317 (expected-source (when (consp expected) (cdr expected)))
318 (xref-file (xref-elisp-location-file (oref xref location)))
319 (expected-file (xref-elisp-location-file
320 (oref expected-xref location))))
321
322 ;; Make sure file names compare as strings.
323 (when (file-name-absolute-p xref-file)
324 (setf (xref-elisp-location-file (oref xref location))
325 (file-truename (xref-elisp-location-file (oref xref location)))))
326 (when (file-name-absolute-p expected-file)
327 (setf (xref-elisp-location-file (oref expected-xref location))
328 (file-truename (xref-elisp-location-file
329 (oref expected-xref location)))))
318 330
319 ;; Downcase the filenames for case-insensitive file systems. 331 ;; Downcase the filenames for case-insensitive file systems.
320 (when xref--case-insensitive 332 (when xref--case-insensitive
@@ -822,5 +834,56 @@ to (xref-elisp-test-descr-to-target xref)."
822 (indent-region (point-min) (point-max)) 834 (indent-region (point-min) (point-max))
823 (should (equal (buffer-string) orig))))) 835 (should (equal (buffer-string) orig)))))
824 836
837(defun test--font (form search)
838 (with-temp-buffer
839 (emacs-lisp-mode)
840 (if (stringp form)
841 (insert form)
842 (pp form (current-buffer)))
843 (font-lock-debug-fontify)
844 (goto-char (point-min))
845 (and (re-search-forward search nil t)
846 (get-text-property (match-beginning 1) 'face))))
847
848(ert-deftest test-elisp-font-keywords-1 ()
849 ;; Special form.
850 (should (eq (test--font '(if foo bar) "(\\(if\\)")
851 'font-lock-keyword-face))
852 ;; Macro.
853 (should (eq (test--font '(when foo bar) "(\\(when\\)")
854 'font-lock-keyword-face))
855 (should (eq (test--font '(condition-case nil
856 (foo)
857 (error (if a b)))
858 "(\\(if\\)")
859 'font-lock-keyword-face))
860 (should (eq (test--font '(condition-case nil
861 (foo)
862 (when (if a b)))
863 "(\\(when\\)")
864 'nil)))
865
866(ert-deftest test-elisp-font-keywords-2 ()
867 :expected-result :failed ; FIXME bug#43265
868 (should (eq (test--font '(condition-case nil
869 (foo)
870 (error (when a b)))
871 "(\\(when\\)")
872 'font-lock-keyword-face)))
873
874(ert-deftest test-elisp-font-keywords-3 ()
875 :expected-result :failed ; FIXME bug#43265
876 (should (eq (test--font '(setq a '(if when zot))
877 "(\\(if\\)")
878 nil)))
879
880(ert-deftest test-elisp-font-keywords-if ()
881 :expected-result :failed ; FIXME bug#43265
882 (should (eq (test--font '(condition-case nil
883 (foo)
884 ((if foo) (when a b)))
885 "(\\(if\\)")
886 nil)))
887
825(provide 'elisp-mode-tests) 888(provide 'elisp-mode-tests)
826;;; elisp-mode-tests.el ends here 889;;; elisp-mode-tests.el ends here
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el
index 8c2682a1f13..2db570c97dd 100644
--- a/test/lisp/replace-tests.el
+++ b/test/lisp/replace-tests.el
@@ -587,5 +587,18 @@ bound to HIGHLIGHT-LOCUS."
587 (get-text-property (point) 'occur-target)) 587 (get-text-property (point) 'occur-target))
588 (should (funcall check-overlays has-overlay))))))) 588 (should (funcall check-overlays has-overlay)))))))
589 589
590(ert-deftest replace-regexp-bug45973 ()
591 "Test for https://debbugs.gnu.org/45973 ."
592 (let ((before "1RB 1LC 1RC 1RB 1RD 0LE 1LA 1LD 1RH 0LA")
593 (after "1LB 1RC 1LC 1LB 1LD 0RE 1RA 1RD 1LH 0RA"))
594 (with-temp-buffer
595 (insert before)
596 (goto-char (point-min))
597 (replace-regexp
598 "\\(\\(L\\)\\|\\(R\\)\\)"
599 '(replace-eval-replacement
600 replace-quote
601 (if (match-string 2) "R" "L")))
602 (should (equal (buffer-string) after)))))
590 603
591;;; replace-tests.el ends here 604;;; replace-tests.el ends here
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el
index c43c81af9fd..62a27f09cbd 100644
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -146,4 +146,48 @@ position to retrieve THING.")
146 (should (thing-at-point-looking-at "2abcd")) 146 (should (thing-at-point-looking-at "2abcd"))
147 (should (equal (match-data) m2))))) 147 (should (equal (match-data) m2)))))
148 148
149(ert-deftest test-symbol-thing-1 ()
150 (with-temp-buffer
151 (insert "foo bar zot")
152 (goto-char 4)
153 (should (eq (symbol-at-point) 'foo))
154 (forward-char 1)
155 (should (eq (symbol-at-point) 'bar))
156 (forward-char 1)
157 (should (eq (symbol-at-point) 'bar))
158 (forward-char 1)
159 (should (eq (symbol-at-point) 'bar))
160 (forward-char 1)
161 (should (eq (symbol-at-point) 'bar))
162 (forward-char 1)
163 (should (eq (symbol-at-point) 'zot))))
164
165(ert-deftest test-symbol-thing-2 ()
166 (with-temp-buffer
167 (insert " bar ")
168 (goto-char (point-max))
169 (should (eq (symbol-at-point) nil))
170 (forward-char -1)
171 (should (eq (symbol-at-point) 'bar))))
172
173(ert-deftest test-symbol-thing-2 ()
174 (with-temp-buffer
175 (insert " bar ")
176 (goto-char (point-max))
177 (should (eq (symbol-at-point) nil))
178 (forward-char -1)
179 (should (eq (symbol-at-point) 'bar))))
180
181(ert-deftest test-symbol-thing-3 ()
182 (with-temp-buffer
183 (insert "bar")
184 (goto-char 2)
185 (should (eq (symbol-at-point) 'bar))))
186
187(ert-deftest test-symbol-thing-3 ()
188 (with-temp-buffer
189 (insert "`[[`(")
190 (goto-char 2)
191 (should (eq (symbol-at-point) nil))))
192
149;;; thingatpt.el ends here 193;;; thingatpt.el ends here
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el
index 81488c3df19..4ae3c1917dd 100644
--- a/test/lisp/time-stamp-tests.el
+++ b/test/lisp/time-stamp-tests.el
@@ -262,40 +262,48 @@
262(ert-deftest time-stamp-format-day-of-week () 262(ert-deftest time-stamp-format-day-of-week ()
263 "Test time-stamp formats for named day of week." 263 "Test time-stamp formats for named day of week."
264 (with-time-stamp-test-env 264 (with-time-stamp-test-env
265 ;; implemented and documented since 1997 265 (let ((Mon (format-time-string "%a" ref-time1 t))
266 (should (equal (time-stamp-string "%3a" ref-time1) "Mon")) 266 (MON (format-time-string "%^a" ref-time1 t))
267 (should (equal (time-stamp-string "%#A" ref-time1) "MONDAY")) 267 (Monday (format-time-string "%A" ref-time1 t))
268 ;; documented 1997-2019 268 (MONDAY (format-time-string "%^A" ref-time1 t)))
269 (should (equal (time-stamp-string "%3A" ref-time1) "MON")) 269 ;; implemented and documented since 1997
270 (should (equal (time-stamp-string "%:a" ref-time1) "Monday")) 270 (should (equal (time-stamp-string "%3a" ref-time1) Mon))
271 ;; implemented since 2001, documented since 2019 271 (should (equal (time-stamp-string "%#A" ref-time1) MONDAY))
272 (should (equal (time-stamp-string "%#a" ref-time1) "MON")) 272 ;; documented 1997-2019
273 (should (equal (time-stamp-string "%:A" ref-time1) "Monday")) 273 (should (equal (time-stamp-string "%3A" ref-time1) MON))
274 ;; allowed but undocumented since 2019 (warned 1997-2019) 274 (should (equal (time-stamp-string "%:a" ref-time1) Monday))
275 (should (equal (time-stamp-string "%^A" ref-time1) "MONDAY")) 275 ;; implemented since 2001, documented since 2019
276 ;; warned 1997-2019, changed in 2019 276 (should (equal (time-stamp-string "%#a" ref-time1) MON))
277 (should (equal (time-stamp-string "%a" ref-time1) "Mon")) 277 (should (equal (time-stamp-string "%:A" ref-time1) Monday))
278 (should (equal (time-stamp-string "%^a" ref-time1) "MON")) 278 ;; allowed but undocumented since 2019 (warned 1997-2019)
279 (should (equal (time-stamp-string "%A" ref-time1) "Monday")))) 279 (should (equal (time-stamp-string "%^A" ref-time1) MONDAY))
280 ;; warned 1997-2019, changed in 2019
281 (should (equal (time-stamp-string "%a" ref-time1) Mon))
282 (should (equal (time-stamp-string "%^a" ref-time1) MON))
283 (should (equal (time-stamp-string "%A" ref-time1) Monday)))))
280 284
281(ert-deftest time-stamp-format-month-name () 285(ert-deftest time-stamp-format-month-name ()
282 "Test time-stamp formats for month name." 286 "Test time-stamp formats for month name."
283 (with-time-stamp-test-env 287 (with-time-stamp-test-env
284 ;; implemented and documented since 1997 288 (let ((Jan (format-time-string "%b" ref-time1 t))
285 (should (equal (time-stamp-string "%3b" ref-time1) "Jan")) 289 (JAN (format-time-string "%^b" ref-time1 t))
286 (should (equal (time-stamp-string "%#B" ref-time1) "JANUARY")) 290 (January (format-time-string "%B" ref-time1 t))
287 ;; documented 1997-2019 291 (JANUARY (format-time-string "%^B" ref-time1 t)))
288 (should (equal (time-stamp-string "%3B" ref-time1) "JAN")) 292 ;; implemented and documented since 1997
289 (should (equal (time-stamp-string "%:b" ref-time1) "January")) 293 (should (equal (time-stamp-string "%3b" ref-time1) Jan))
290 ;; implemented since 2001, documented since 2019 294 (should (equal (time-stamp-string "%#B" ref-time1) JANUARY))
291 (should (equal (time-stamp-string "%#b" ref-time1) "JAN")) 295 ;; documented 1997-2019
292 (should (equal (time-stamp-string "%:B" ref-time1) "January")) 296 (should (equal (time-stamp-string "%3B" ref-time1) JAN))
293 ;; allowed but undocumented since 2019 (warned 1997-2019) 297 (should (equal (time-stamp-string "%:b" ref-time1) January))
294 (should (equal (time-stamp-string "%^B" ref-time1) "JANUARY")) 298 ;; implemented since 2001, documented since 2019
295 ;; warned 1997-2019, changed in 2019 299 (should (equal (time-stamp-string "%#b" ref-time1) JAN))
296 (should (equal (time-stamp-string "%b" ref-time1) "Jan")) 300 (should (equal (time-stamp-string "%:B" ref-time1) January))
297 (should (equal (time-stamp-string "%^b" ref-time1) "JAN")) 301 ;; allowed but undocumented since 2019 (warned 1997-2019)
298 (should (equal (time-stamp-string "%B" ref-time1) "January")))) 302 (should (equal (time-stamp-string "%^B" ref-time1) JANUARY))
303 ;; warned 1997-2019, changed in 2019
304 (should (equal (time-stamp-string "%b" ref-time1) Jan))
305 (should (equal (time-stamp-string "%^b" ref-time1) JAN))
306 (should (equal (time-stamp-string "%B" ref-time1) January)))))
299 307
300(ert-deftest time-stamp-format-day-of-month () 308(ert-deftest time-stamp-format-day-of-month ()
301 "Test time-stamp formats for day of month." 309 "Test time-stamp formats for day of month."
@@ -483,14 +491,18 @@
483(ert-deftest time-stamp-format-am-pm () 491(ert-deftest time-stamp-format-am-pm ()
484 "Test time-stamp formats for AM and PM strings." 492 "Test time-stamp formats for AM and PM strings."
485 (with-time-stamp-test-env 493 (with-time-stamp-test-env
486 ;; implemented and documented since 1997 494 (let ((pm (format-time-string "%#p" ref-time1 t))
487 (should (equal (time-stamp-string "%#p" ref-time1) "pm")) 495 (am (format-time-string "%#p" ref-time3 t))
488 (should (equal (time-stamp-string "%#p" ref-time3) "am")) 496 (PM (format-time-string "%p" ref-time1 t))
489 (should (equal (time-stamp-string "%P" ref-time1) "PM")) 497 (AM (format-time-string "%p" ref-time3 t)))
490 (should (equal (time-stamp-string "%P" ref-time3) "AM")) 498 ;; implemented and documented since 1997
491 ;; warned 1997-2019, changed in 2019 499 (should (equal (time-stamp-string "%#p" ref-time1) pm))
492 (should (equal (time-stamp-string "%p" ref-time1) "PM")) 500 (should (equal (time-stamp-string "%#p" ref-time3) am))
493 (should (equal (time-stamp-string "%p" ref-time3) "AM")))) 501 (should (equal (time-stamp-string "%P" ref-time1) PM))
502 (should (equal (time-stamp-string "%P" ref-time3) AM))
503 ;; warned 1997-2019, changed in 2019
504 (should (equal (time-stamp-string "%p" ref-time1) PM))
505 (should (equal (time-stamp-string "%p" ref-time3) AM)))))
494 506
495(ert-deftest time-stamp-format-day-number-in-week () 507(ert-deftest time-stamp-format-day-number-in-week ()
496 "Test time-stamp formats for day number in week." 508 "Test time-stamp formats for day number in week."
@@ -567,10 +579,15 @@
567(ert-deftest time-stamp-format-ignored-modifiers () 579(ert-deftest time-stamp-format-ignored-modifiers ()
568 "Test additional args allowed (but ignored) to allow for future expansion." 580 "Test additional args allowed (but ignored) to allow for future expansion."
569 (with-time-stamp-test-env 581 (with-time-stamp-test-env
570 ;; allowed modifiers 582 (let ((May (format-time-string "%B" ref-time3 t)))
571 (should (equal (time-stamp-string "%.,@-+_ ^(stuff)P" ref-time3) "AM")) 583 ;; allowed modifiers
572 ;; not all punctuation is allowed 584 (should (equal (time-stamp-string "%.,@+ (stuff)B" ref-time3) May))
573 (should-not (equal (time-stamp-string "%&P" ref-time3) "AM")))) 585 ;; parens nest
586 (should (equal (time-stamp-string "%(st(u)ff)B" ref-time3) May))
587 ;; escaped parens do not change the nesting level
588 (should (equal (time-stamp-string "%(st\\)u\\(ff)B" ref-time3) May))
589 ;; not all punctuation is allowed
590 (should-not (equal (time-stamp-string "%&B" ref-time3) May)))))
574 591
575(ert-deftest time-stamp-format-non-conversions () 592(ert-deftest time-stamp-format-non-conversions ()
576 "Test that without a %, the text is copied literally." 593 "Test that without a %, the text is copied literally."
@@ -580,16 +597,22 @@
580(ert-deftest time-stamp-format-string-width () 597(ert-deftest time-stamp-format-string-width ()
581 "Test time-stamp string width modifiers." 598 "Test time-stamp string width modifiers."
582 (with-time-stamp-test-env 599 (with-time-stamp-test-env
583 ;; strings truncate on the right or are blank-padded on the left 600 (let ((May (format-time-string "%b" ref-time3 t))
584 (should (equal (time-stamp-string "%0P" ref-time3) "")) 601 (SUN (format-time-string "%^a" ref-time3 t))
585 (should (equal (time-stamp-string "%1P" ref-time3) "A")) 602 (NOV (format-time-string "%^b" ref-time2 t)))
586 (should (equal (time-stamp-string "%2P" ref-time3) "AM")) 603 ;; strings truncate on the right or are blank-padded on the left
587 (should (equal (time-stamp-string "%3P" ref-time3) " AM")) 604 (should (equal (time-stamp-string "%0b" ref-time3) ""))
588 (should (equal (time-stamp-string "%0%" ref-time3) "")) 605 (should (equal (time-stamp-string "%1b" ref-time3) (substring May 0 1)))
589 (should (equal (time-stamp-string "%1%" ref-time3) "%")) 606 (should (equal (time-stamp-string "%2b" ref-time3) (substring May 0 2)))
590 (should (equal (time-stamp-string "%2%" ref-time3) " %")) 607 (should (equal (time-stamp-string "%3b" ref-time3) May))
591 (should (equal (time-stamp-string "%#3a" ref-time3) "SUN")) 608 (should (equal (time-stamp-string "%4b" ref-time3) (concat " " May)))
592 (should (equal (time-stamp-string "%#3b" ref-time2) "NOV")))) 609 (should (equal (time-stamp-string "%0%" ref-time3) ""))
610 (should (equal (time-stamp-string "%1%" ref-time3) "%"))
611 (should (equal (time-stamp-string "%2%" ref-time3) " %"))
612 (should (equal (time-stamp-string "%9%" ref-time3) " %"))
613 (should (equal (time-stamp-string "%10%" ref-time3) " %"))
614 (should (equal (time-stamp-string "%#3a" ref-time3) SUN))
615 (should (equal (time-stamp-string "%#3b" ref-time2) NOV)))))
593 616
594;;; Tests of helper functions 617;;; Tests of helper functions
595 618
diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el
index 17fdfefce84..f843649784a 100644
--- a/test/lisp/wid-edit-tests.el
+++ b/test/lisp/wid-edit-tests.el
@@ -322,4 +322,15 @@ return nil, even with a non-nil bubblep argument."
322 (widget-backward 1) 322 (widget-backward 1)
323 (should (string= "Second" (widget-value (widget-at)))))) 323 (should (string= "Second" (widget-value (widget-at))))))
324 324
325(ert-deftest widget-test-color-match ()
326 "Test that the :match function for the color widget works."
327 (let ((widget (widget-convert 'color)))
328 (should (widget-apply widget :match "red"))
329 (should (widget-apply widget :match "#fa3"))
330 (should (widget-apply widget :match "#ff0000"))
331 (should (widget-apply widget :match "#111222333"))
332 (should (widget-apply widget :match "#111122223333"))
333 (should-not (widget-apply widget :match "someundefinedcolorihope"))
334 (should-not (widget-apply widget :match "#11223"))))
335
325;;; wid-edit-tests.el ends here 336;;; wid-edit-tests.el ends here
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index 57097cfa052..a3fba8d328b 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -576,11 +576,6 @@ FD_SETSIZE file descriptors (Bug#24325)."
576 (should (memq (process-status process) '(run exit))) 576 (should (memq (process-status process) '(run exit)))
577 (when (process-live-p process) 577 (when (process-live-p process)
578 (process-send-eof process)) 578 (process-send-eof process))
579 ;; FIXME: This `sleep-for' shouldn't be needed. It
580 ;; indicates a bug in Emacs; perhaps SIGCHLD is
581 ;; received in parallel with `accept-process-output',
582 ;; causing the latter to hang.
583 (sleep-for 0.1)
584 (while (accept-process-output process)) 579 (while (accept-process-output process))
585 (should (eq (process-status process) 'exit)) 580 (should (eq (process-status process) 'exit))
586 ;; If there's an error between fork and exec, Emacs 581 ;; If there's an error between fork and exec, Emacs
@@ -739,5 +734,150 @@ Return nil if that can't be determined."
739 (match-string-no-properties 1)))))) 734 (match-string-no-properties 1))))))
740 process-tests--EMFILE-message) 735 process-tests--EMFILE-message)
741 736
737(ert-deftest process-tests/sentinel-called ()
738 "Check that sentinels are called after processes finish"
739 (let ((command (process-tests--emacs-command)))
740 (skip-unless command)
741 (dolist (conn-type '(pipe pty))
742 (ert-info ((format "Connection type: %s" conn-type))
743 (process-tests--with-processes processes
744 (let* ((calls ())
745 (process (make-process
746 :name "echo"
747 :command (process-tests--eval
748 command '(print "first"))
749 :noquery t
750 :connection-type conn-type
751 :coding 'utf-8-unix
752 :sentinel (lambda (process message)
753 (push (list process message)
754 calls)))))
755 (push process processes)
756 (while (accept-process-output process))
757 (should (equal calls
758 (list (list process "finished\n"))))))))))
759
760(ert-deftest process-tests/sentinel-with-multiple-processes ()
761 "Check that sentinels are called in time even when other processes
762have written output."
763 (let ((command (process-tests--emacs-command)))
764 (skip-unless command)
765 (dolist (conn-type '(pipe pty))
766 (ert-info ((format "Connection type: %s" conn-type))
767 (process-tests--with-processes processes
768 (let* ((calls ())
769 (process (make-process
770 :name "echo"
771 :command (process-tests--eval
772 command '(print "first"))
773 :noquery t
774 :connection-type conn-type
775 :coding 'utf-8-unix
776 :sentinel (lambda (process message)
777 (push (list process message)
778 calls)))))
779 (push process processes)
780 (push (make-process
781 :name "bash"
782 :command (process-tests--eval
783 command
784 '(progn (sleep-for 10) (print "second")))
785 :noquery t
786 :connection-type conn-type)
787 processes)
788 (while (accept-process-output process))
789 (should (equal calls
790 (list (list process "finished\n"))))))))))
791
792(ert-deftest process-tests/multiple-threads-waiting ()
793 (skip-unless (fboundp 'make-thread))
794 (with-timeout (60 (ert-fail "Test timed out"))
795 (process-tests--with-processes processes
796 (let ((threads ())
797 (cat (executable-find "cat")))
798 (skip-unless cat)
799 (dotimes (i 10)
800 (let* ((name (format "test %d" i))
801 (process (make-process :name name
802 :command (list cat)
803 :coding 'no-conversion
804 :noquery t
805 :connection-type 'pipe)))
806 (push process processes)
807 (set-process-thread process nil)
808 (push (make-thread
809 (lambda ()
810 (while (accept-process-output process)))
811 name)
812 threads)))
813 (mapc #'process-send-eof processes)
814 (cl-loop for process in processes
815 and thread in threads
816 do
817 (should-not (thread-join thread))
818 (should-not (thread-last-error))
819 (should (eq (process-status process) 'exit))
820 (should (eql (process-exit-status process) 0)))))))
821
822(defun process-tests--eval (command form)
823 "Return a command that evaluates FORM in an Emacs subprocess.
824COMMAND must be a list returned by
825`process-tests--emacs-command'."
826 (let ((print-gensym t)
827 (print-circle t)
828 (print-length nil)
829 (print-level nil)
830 (print-escape-control-characters t)
831 (print-escape-newlines t)
832 (print-escape-multibyte t)
833 (print-escape-nonascii t))
834 `(,@command "--quick" "--batch" ,(format "--eval=%S" form))))
835
836(defun process-tests--emacs-command ()
837 "Return a command to reinvoke the current Emacs instance.
838Return nil if that doesn't appear to be possible."
839 (when-let ((binary (process-tests--emacs-binary))
840 (dump (process-tests--dump-file)))
841 (cons binary
842 (unless (eq dump :not-needed)
843 (list (concat "--dump-file="
844 (file-name-unquote dump)))))))
845
846(defun process-tests--emacs-binary ()
847 "Return the filename of the currently running Emacs binary.
848Return nil if that can't be determined."
849 (and (stringp invocation-name)
850 (not (file-remote-p invocation-name))
851 (not (file-name-absolute-p invocation-name))
852 (stringp invocation-directory)
853 (not (file-remote-p invocation-directory))
854 (file-name-absolute-p invocation-directory)
855 (when-let ((file (process-tests--usable-file-for-reinvoke
856 (expand-file-name invocation-name
857 invocation-directory))))
858 (and (file-executable-p file) file))))
859
860(defun process-tests--dump-file ()
861 "Return the filename of the dump file used to start Emacs.
862Return nil if that can't be determined. Return `:not-needed' if
863Emacs wasn't started with a dump file."
864 (if-let ((stats (and (fboundp 'pdumper-stats) (pdumper-stats))))
865 (when-let ((file (process-tests--usable-file-for-reinvoke
866 (cdr (assq 'dump-file-name stats)))))
867 (and (file-readable-p file) file))
868 :not-needed))
869
870(defun process-tests--usable-file-for-reinvoke (filename)
871 "Return a version of FILENAME that can be used to reinvoke Emacs.
872Return nil if FILENAME doesn't exist."
873 (when (and (stringp filename)
874 (not (file-remote-p filename)))
875 (cl-callf file-truename filename)
876 (and (stringp filename)
877 (not (file-remote-p filename))
878 (file-name-absolute-p filename)
879 (file-regular-p filename)
880 filename)))
881
742(provide 'process-tests) 882(provide 'process-tests)
743;;; process-tests.el ends here 883;;; process-tests.el ends here
diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el
index ec96d777ffb..4e7d2ad8ab2 100644
--- a/test/src/xdisp-tests.el
+++ b/test/src/xdisp-tests.el
@@ -75,31 +75,28 @@
75(ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748 75(ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748
76 (with-temp-buffer 76 (with-temp-buffer
77 (insert "xxx") 77 (insert "xxx")
78 (let* ((window 78 (switch-to-buffer (current-buffer))
79 (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) 79 (let* ((char-width (frame-char-width))
80 (char-width (frame-char-width)) 80 (size (window-text-pixel-size nil t t))
81 (size (window-text-pixel-size nil t t))) 81 (width-in-chars (/ (car size) char-width)))
82 (delete-frame (window-frame window)) 82 (should (equal width-in-chars 3)))))
83 (should (equal (/ (car size) char-width) 3)))))
84 83
85(ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748 84(ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748
86 (with-temp-buffer 85 (with-temp-buffer
87 (insert " xx") 86 (insert " xx")
88 (let* ((window 87 (switch-to-buffer (current-buffer))
89 (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) 88 (let* ((char-width (frame-char-width))
90 (char-width (frame-char-width)) 89 (size (window-text-pixel-size nil t t))
91 (size (window-text-pixel-size nil t t))) 90 (width-in-chars (/ (car size) char-width)))
92 (delete-frame (window-frame window)) 91 (should (equal width-in-chars 3)))))
93 (should (equal (/ (car size) char-width) 3)))))
94 92
95(ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748 93(ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748
96 (with-temp-buffer 94 (with-temp-buffer
97 (insert "xx ") 95 (insert "xx ")
98 (let* ((window 96 (switch-to-buffer (current-buffer))
99 (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) 97 (let* ((char-width (frame-char-width))
100 (char-width (frame-char-width)) 98 (size (window-text-pixel-size nil t t))
101 (size (window-text-pixel-size nil t t))) 99 (width-in-chars (/ (car size) char-width)))
102 (delete-frame (window-frame window)) 100 (should (equal width-in-chars 3)))))
103 (should (equal (/ (car size) char-width) 3)))))
104 101
105;;; xdisp-tests.el ends here 102;;; xdisp-tests.el ends here