procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs into feature/pgtk

Browse source
This commit is contained in:
Yuuki Harano 2021-01-30 23:37:19 +09:00
commit 50c76b844b
294 changed files with 5643 additions and 2784 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.clang-format
View file

@ -1,5 +1,5 @@
Language: Cpp
BasedOnStyle: LLVM
BasedOnStyle: GNU
AlignEscapedNewlinesLeft: true
AlwaysBreakAfterReturnType: TopLevelDefinitions
BreakBeforeBinaryOperators: All

10
admin/notes/unicode
View file

@ -256,15 +256,6 @@ nontrivial changes to the build process.
etc/tutorials/TUTORIAL.ja
* iso-2022-7bit
This file contains multiple Chinese charsets, and converting it
to UTF-8 would lose the charset property and would change the
code's behavior. Although this could be worked around by
propertizing the strings, that hasn't been done.
lisp/international/titdic-cnv.el
* utf-8-emacs
These files contain characters that cannot be encoded in UTF-8.
@ -276,6 +267,7 @@ nontrivial changes to the build process.
lisp/language/tibetan.el
lisp/leim/quail/ethiopic.el
lisp/leim/quail/tibetan.el
lisp/international/titdic-cnv.el
* binary files

6
admin/unidata/unidata-gen.el
View file

@ -1416,7 +1416,8 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
(or elt (user-error "Unknown output file: %s" basename))
(or noninteractive (message "Generating %s..." file))
(with-temp-file file
(insert ";; " copyright "
(insert ";;; " basename " -*- lexical-binding:t -*-
;; " copyright "
;; Generated from Unicode data files by unidata-gen.el.
;; The sources for this file are found in the admin/unidata/ directory in
;; the Emacs sources. The Unicode data files are used under the
@ -1451,7 +1452,8 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
(defun unidata-gen-charprop (&optional charprop-file)
(or charprop-file (setq charprop-file (pop command-line-args-left)))
(with-temp-file charprop-file
(insert ";; Automatically generated by unidata-gen.el.\n"
(insert ";; Automatically generated by unidata-gen.el."
" -*- lexical-binding: t -*-\n"
";; See the admin/unidata/ directory in the Emacs sources.\n")
(dolist (elt unidata-file-alist)
(dolist (proplist (cdr elt))

8
build-aux/config.guess vendored
View file

@ -1,8 +1,8 @@
#! /bin/sh
# Attempt to guess a canonical system name.
# Copyright 1992-2020 Free Software Foundation, Inc.
# Copyright 1992-2021 Free Software Foundation, Inc.
timestamp='2020-12-22'
timestamp='2021-01-01'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@ -50,7 +50,7 @@ version="\
GNU config.guess ($timestamp)
Originally written by Per Bothner.
Copyright 1992-2020 Free Software Foundation, Inc.
Copyright 1992-2021 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
@ -1087,7 +1087,7 @@ EOF
ppcle:Linux:*:*)
echo powerpcle-unknown-linux-"$LIBC"
exit ;;
riscv32:Linux:*:* | riscv64:Linux:*:*)
riscv32:Linux:*:* | riscv32be:Linux:*:* | riscv64:Linux:*:* | riscv64be:Linux:*:*)
echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
s390:Linux:*:* | s390x:Linux:*:*)

10
build-aux/config.sub vendored
View file

@ -1,8 +1,8 @@
#! /bin/sh
# Configuration validation subroutine script.
# Copyright 1992-2020 Free Software Foundation, Inc.
# Copyright 1992-2021 Free Software Foundation, Inc.
timestamp='2020-12-22'
timestamp='2021-01-07'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@ -67,7 +67,7 @@ Report bugs and patches to <config-patches@gnu.org>."
version="\
GNU config.sub ($timestamp)
Copyright 1992-2020 Free Software Foundation, Inc.
Copyright 1992-2021 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
@ -1230,7 +1230,7 @@ case $cpu-$vendor in
| powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \
| pru \
| pyramid \
| riscv | riscv32 | riscv64 \
| riscv | riscv32 | riscv32be | riscv64 | riscv64be \
| rl78 | romp | rs6000 | rx \
| s390 | s390x \
| score \
@ -1687,7 +1687,7 @@ case $os in
musl* | newlib* | uclibc*)
;;
# Likewise for "kernel-libc"
eabi | eabihf | gnueabi | gnueabihf)
eabi* | gnueabi*)
;;
# Now accept the basic system types.
# The portable systems comes first.

2
configure.ac
View file

@ -5977,7 +5977,7 @@ if test $AUTO_DEPEND = yes; then
AS_MKDIR_P([$dir/deps])
done
fi
if $gl_gnulib_enabled_scratch_buffer; then
if $gl_gnulib_enabled_dynarray || $gl_gnulib_enabled_scratch_buffer; then
AS_MKDIR_P([lib/malloc])
if test $AUTO_DEPEND = yes; then
AS_MKDIR_P([lib/deps/malloc])

8
doc/emacs/glossary.texi
View file

@ -1369,10 +1369,14 @@ configurations. @xref{Tab Bars}.
The tab line is a line of tabs at the top of an Emacs window.
Clicking on one of these tabs switches window buffers. @xref{Tab Line}.
@item Tag
A tag is an identifier in a program source. @xref{Xref}.
@anchor{Glossary---Tags Table}
@item Tags Table
A tags table is a file that serves as an index to the function
definitions in one or more other files. @xref{Tags Tables}.
A tags table is a file that serves as an index to identifiers: definitions
of functions, macros, data structures, etc., in one or more other files.
@xref{Tags Tables}.
@item Termscript File
A termscript file contains a record of all characters sent by Emacs to

8
doc/emacs/kmacro.texi
View file

@ -179,6 +179,14 @@ itself counts as the first repetition, since it is executed as you
define it, so @kbd{C-u 4 C-x )} executes the macro immediately 3
additional times.
@findex kdb-macro-redisplay
@kindex C-x C-k Q
While executing a long-running keyboard macro, it can sometimes be
useful to trigger a redisplay (to show how far we've gotten). The
@kbd{C-x C-k Q} can be used for this. As a not very useful example,
@kbd{C-x ( M-f C-x C-k Q C-x )} will create a macro that will
redisplay once per iteration when saying @kbd{C-u 42 C-x e}.
@node Keyboard Macro Ring
@section The Keyboard Macro Ring

20
doc/emacs/maintaining.texi
View file

@ -1994,19 +1994,21 @@ Of course, you should substitute the proper years and copyright holder.
@section Find Identifier References
@cindex xref
@cindex tag
An @dfn{identifier} is a name of a syntactical subunit of the
program: a function, a subroutine, a method, a class, a data type, a
macro, etc. In a programming language, each identifier is a symbol in
the language's syntax. Program development and maintenance requires
capabilities to quickly find where each identifier was defined and
referenced, to rename identifiers across the entire project, etc.
the language's syntax. Identifiers are also known as @dfn{tags}.
These capabilities are also useful for finding references in major
modes other than those defined to support programming languages. For
example, chapters, sections, appendices, etc.@: of a text or a @TeX{}
document can be treated as subunits as well, and their names can be
used as identifiers. In this chapter, we use the term ``identifiers''
to collectively refer to the names of any kind of subunits, in program
Program development and maintenance requires capabilities to quickly
find where each identifier was defined and referenced, to rename
identifiers across the entire project, etc. These capabilities are
also useful for finding references in major modes other than those
defined to support programming languages. For example, chapters,
sections, appendices, etc.@: of a text or a @TeX{} document can be
treated as subunits as well, and their names can be used as
identifiers. In this chapter, we use the term ``identifiers'' to
collectively refer to the names of any kind of subunits, in program
source and in other kinds of text alike.
Emacs provides a unified interface to these capabilities, called

50
doc/lispref/frames.texi
View file

@ -694,9 +694,17 @@ parameter (@pxref{Management Parameters}).
@item Internal Border
The internal border is a border drawn by Emacs around the inner frame
(see below). Its width is specified by the @code{internal-border-width}
frame parameter (@pxref{Layout Parameters}). Its color is specified by
the background of the @code{internal-border} face.
(see below). The specification of its appearance depends on whether
or not the given frame is a child frame (@pxref{Child Frames}).
For normal frames its width is specified by the @code{internal-border-width}
frame parameter (@pxref{Layout Parameters}), and its color is specified by the
background of the @code{internal-border} face.
For child frames its width is specified by the @code{child-frame-border-width}
frame parameter (but will use the @code{internal-border-width} parameter as
fallback), and its color is specified by the background of the
@code{child-frame-border} face.
@item Inner Frame
@cindex inner frame
@ -1790,6 +1798,11 @@ The width in pixels of the frame's outer border (@pxref{Frame Geometry}).
The width in pixels of the frame's internal border (@pxref{Frame
Geometry}).
@vindex child-frame-border-width@r{, a frame parameter}
@item child-frame-border-width
The width in pixels of the frame's internal border (@pxref{Frame
Geometry}) if the given frame is a child frame (@pxref{Child Frames}).
@vindex vertical-scroll-bars@r{, a frame parameter}
@item vertical-scroll-bars
Whether the frame has scroll bars (@pxref{Scroll Bars}) for vertical
@ -2398,7 +2411,7 @@ attribute of the @code{default} face.
@vindex foreground-color@r{, a frame parameter}
@item foreground-color
The color to use for the image of a character. It is equivalent to
The color to use for characters. It is equivalent to
the @code{:foreground} attribute of the @code{default} face.
@vindex background-color@r{, a frame parameter}
@ -3748,10 +3761,31 @@ for instance using the window manager, then this produces a quit and
You can specify the mouse pointer style for particular text or
images using the @code{pointer} text property, and for images with the
@code{:pointer} and @code{:map} image properties. The values you can
use in these properties are @code{text} (or @code{nil}), @code{arrow},
@code{hand}, @code{vdrag}, @code{hdrag}, @code{modeline}, and
@code{hourglass}. @code{text} stands for the usual mouse pointer
style used over text.
use in these properties are in the table below. The actual shapes
may vary between systems; the descriptions are examples.
@table @code
@item text
@itemx nil
The usual mouse pointer style used over text (an ``I''-like shape).
@item arrow
@itemx vdrag
@itemx modeline
An arrow that points north-west.
@item hand
A hand that points upwards.
@item hdrag
A right-left arrow.
@item nhdrag
An up-down arrow.
@item hourglass
A rotating ring.
@end table
Over void parts of the window (parts that do not correspond to any
of the buffer contents), the mouse pointer usually uses the

37
doc/lispref/text.texi
View file

@ -334,6 +334,25 @@ but there is no peace.
(thing-at-point 'whitespace)
@result{} nil
@end example
@defvar thing-at-point-provider-alist
This variable allows users and modes to tweak how
@code{thing-at-point} works. It's an association list of @var{thing}s
and functions (called with zero parameters) to return that thing.
Entries for @var{thing} will be evaluated in turn until a
non-@code{nil} result is returned.
For instance, a major mode could say:
@lisp
(setq-local thing-at-point-provider-alist
(append thing-at-point-provider-alist
'((url . my-mode--url-at-point))))
@end lisp
If no providers have a non-@code{nil} return, the @var{thing} will be
computed the standard way.
@end defvar
@end defun
@node Comparing Text
@ -1422,6 +1441,11 @@ the @code{amalgamating-undo-limit} variable. If this variable is 1,
no changes are amalgamated.
@end defun
A Lisp program can amalgamate a series of changes into a single change
group by calling @code{undo-amalgamate-change-group} (@pxref{Atomic
Changes}). Note that @code{amalgamating-undo-limit} has no effect on
the groups produced by that function.
@defvar undo-auto-current-boundary-timer
Some buffers, such as process buffers, can change even when no
commands are executing. In these cases, @code{undo-boundary} is
@ -5608,6 +5632,19 @@ This function accepts all the changes in the change group specified by
@defun cancel-change-group handle
This function cancels and undoes all the changes in the change group
specified by @var{handle}.
@end defun
You can cause some or all of the changes in a change group to be
considered as a single unit for the purposes of the @code{undo}
commands (@pxref{Undo}) by using @code{undo-amalgamate-change-group}.
@defun undo-amalgamate-change-group
Amalgamate all the changes made in the change-group since the state
identified by @var{handle}. This function removes all undo boundaries
between undo records of changes since the state described by
@var{handle}. Usually, @var{handle} is the handle returned by
@code{prepare-change-group}, in which case all the changes since the
beginning of the change-group are amalgamated into a single undo unit.
@end defun
Your code should use @code{unwind-protect} to make sure the group is

6
doc/misc/message.texi
View file

@ -317,6 +317,12 @@ when forwarding a message.
In non-@code{nil}, only headers that match this regexp will be kept
when forwarding a message. This can also be a list of regexps.
@item message-forward-included-mime-headers
@vindex message-forward-included-mime-headers
In non-@code{nil}, headers that match this regexp will be kept when
forwarding a message as @acronym{MIME}, but @acronym{MML} isn't used.
This can also be a list of regexps.
@item message-make-forward-subject-function
@vindex message-make-forward-subject-function
A list of functions that are called to generate a subject header for

6
doc/misc/org.texi
View file

@ -4071,7 +4071,7 @@ the link. Such a function will be called with the tag as the only
argument.
With the above setting, you could link to a specific bug with
@samp{[[bugzilla:129]]}, search the web for @samp{OrgMode} with @samp{[[google:OrgMode]]},
@samp{[[bugzilla:129]]}, search the web for @samp{OrgMode} with @samp{[[duckduckgo:OrgMode]]},
show the map location of the Free Software Foundation @samp{[[gmap:51
Franklin Street, Boston]]} or of Carsten office @samp{[[omap:Science Park 904,
Amsterdam, The Netherlands]]} and find out what the Org author is doing
@ -4082,8 +4082,8 @@ can define them in the file with
@cindex @samp{LINK}, keyword
@example
#+LINK: bugzilla http://10.1.2.9/bugzilla/show_bug.cgi?id=
#+LINK: google http://www.google.com/search?q=%s
#+LINK: bugzilla http://10.1.2.9/bugzilla/show_bug.cgi?id=
#+LINK: duckduckgo https://duckduckgo.com/?q=%s
@end example
In-buffer completion (see @ref{Completion}) can be used after @samp{[} to

163
doc/misc/texinfo.tex
View file

@ -3,7 +3,7 @@
% Load plain if necessary, i.e., if running under initex.
\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
%
\def\texinfoversion{2020-10-24.12}
\def\texinfoversion{2020-11-25.18}
%
% Copyright 1985, 1986, 1988, 1990-2020 Free Software Foundation, Inc.
%
@ -572,10 +572,9 @@
\fi
}
% @end foo executes the definition of \Efoo.
% But first, it executes a specialized version of \checkenv
%
\parseargdef\end{%
% @end foo calls \checkenv and executes the definition of \Efoo.
\parseargdef\end{
\if 1\csname iscond.#1\endcsname
\else
% The general wording of \badenverr may not be ideal.
@ -2673,8 +2672,6 @@
\definetextfontsizexi
\message{markup,}
% Check if we are currently using a typewriter font. Since all the
% Computer Modern typewriter fonts have zero interword stretch (and
% shrink), and it is reasonable to expect all typewriter fonts to have
@ -2682,68 +2679,14 @@
%
\def\ifmonospace{\ifdim\fontdimen3\font=0pt }
% Markup style infrastructure. \defmarkupstylesetup\INITMACRO will
% define and register \INITMACRO to be called on markup style changes.
% \INITMACRO can check \currentmarkupstyle for the innermost
% style.
\let\currentmarkupstyle\empty
\def\setupmarkupstyle#1{%
\def\currentmarkupstyle{#1}%
\markupstylesetup
}
\let\markupstylesetup\empty
\def\defmarkupstylesetup#1{%
\expandafter\def\expandafter\markupstylesetup
\expandafter{\markupstylesetup #1}%
\def#1%
}
% Markup style setup for left and right quotes.
\defmarkupstylesetup\markupsetuplq{%
\expandafter\let\expandafter \temp
\csname markupsetuplq\currentmarkupstyle\endcsname
\ifx\temp\relax \markupsetuplqdefault \else \temp \fi
}
\defmarkupstylesetup\markupsetuprq{%
\expandafter\let\expandafter \temp
\csname markupsetuprq\currentmarkupstyle\endcsname
\ifx\temp\relax \markupsetuprqdefault \else \temp \fi
}
{
\catcode`\'=\active
\catcode`\`=\active
\gdef\markupsetuplqdefault{\let`\lq}
\gdef\markupsetuprqdefault{\let'\rq}
\gdef\markupsetcodequoteleft{\let`\codequoteleft}
\gdef\markupsetcodequoteright{\let'\codequoteright}
\gdef\setcodequotes{\let`\codequoteleft \let'\codequoteright}
\gdef\setregularquotes{\let`\lq \let'\rq}
}
\let\markupsetuplqcode \markupsetcodequoteleft
\let\markupsetuprqcode \markupsetcodequoteright
%
\let\markupsetuplqexample \markupsetcodequoteleft
\let\markupsetuprqexample \markupsetcodequoteright
%
\let\markupsetuplqkbd \markupsetcodequoteleft
\let\markupsetuprqkbd \markupsetcodequoteright
%
\let\markupsetuplqsamp \markupsetcodequoteleft
\let\markupsetuprqsamp \markupsetcodequoteright
%
\let\markupsetuplqverb \markupsetcodequoteleft
\let\markupsetuprqverb \markupsetcodequoteright
%
\let\markupsetuplqverbatim \markupsetcodequoteleft
\let\markupsetuprqverbatim \markupsetcodequoteright
% Allow an option to not use regular directed right quote/apostrophe
% (char 0x27), but instead the undirected quote from cmtt (char 0x0d).
% The undirected quote is ugly, so don't make it the default, but it
@ -2906,7 +2849,7 @@
}
% @samp.
\def\samp#1{{\setupmarkupstyle{samp}\lq\tclose{#1}\rq\null}}
\def\samp#1{{\setcodequotes\lq\tclose{#1}\rq\null}}
% @indicateurl is \samp, that is, with quotes.
\let\indicateurl=\samp
@ -2949,8 +2892,7 @@
\global\let'=\rq \global\let`=\lq % default definitions
%
\global\def\code{\begingroup
\setupmarkupstyle{code}%
% The following should really be moved into \setupmarkupstyle handlers.
\setcodequotes
\catcode\dashChar=\active \catcode\underChar=\active
\ifallowcodebreaks
\let-\codedash
@ -3104,7 +3046,7 @@
\urefcatcodes
%
\global\def\urefcode{\begingroup
\setupmarkupstyle{code}%
\setcodequotes
\urefcatcodes
\let&\urefcodeamp
\let.\urefcodedot
@ -3225,8 +3167,8 @@
\def\kbdsub#1#2#3\par{%
\def\one{#1}\def\three{#3}\def\threex{??}%
\ifx\one\xkey\ifx\threex\three \key{#2}%
\else{\tclose{\kbdfont\setupmarkupstyle{kbd}\look}}\fi
\else{\tclose{\kbdfont\setupmarkupstyle{kbd}\look}}\fi
\else{\tclose{\kbdfont\setcodequotes\look}}\fi
\else{\tclose{\kbdfont\setcodequotes\look}}\fi
}
% definition of @key that produces a lozenge. Doesn't adjust to text size.
@ -3243,7 +3185,7 @@
% monospace, don't change it; that way, we respect @kbdinputstyle. But
% if it isn't monospace, then use \tt.
%
\def\key#1{{\setupmarkupstyle{key}%
\def\key#1{{\setregularquotes
\nohyphenation
\ifmonospace\else\tt\fi
#1}\null}
@ -3373,16 +3315,20 @@
{\obeylines
\globaldefs=1
\envdef\displaymath{%
\tex
\tex%
\def\thisenv{\displaymath}%
\begingroup\let\end\displaymathend%
$$%
}
\def\Edisplaymath{$$
\def\displaymathend{$$\endgroup\end}%
\def\Edisplaymath{%
\def\thisenv{\tex}%
\end tex
}}
% @inlinefmt{FMTNAME,PROCESSED-TEXT} and @inlineraw{FMTNAME,RAW-TEXT}.
% Ignore unless FMTNAME == tex; then it is like @iftex and @tex,
% except specified as a normal braced arg, so no newlines to worry about.
@ -7144,7 +7090,7 @@
% But \@ or @@ will get a plain @ character.
\envdef\tex{%
\setupmarkupstyle{tex}%
\setregularquotes
\catcode `\\=0 \catcode `\{=1 \catcode `\}=2
\catcode `\$=3 \catcode `\&=4 \catcode `\#=6
\catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie
@ -7370,7 +7316,7 @@
% If you want all examples etc. small: @set dispenvsize small.
% If you want even small examples the full size: @set dispenvsize nosmall.
% This affects the following displayed environments:
% @example, @display, @format, @lisp
% @example, @display, @format, @lisp, @verbatim
%
\def\smallword{small}
\def\nosmallword{nosmall}
@ -7416,9 +7362,9 @@
%
\maketwodispenvdef{lisp}{example}{%
\nonfillstart
\tt\setupmarkupstyle{example}%
\tt\setcodequotes
\let\kbdfont = \kbdexamplefont % Allow @kbd to do something special.
\gobble % eat return
\parsearg\gobble
}
% @display/@smalldisplay: same as @lisp except keep current font.
%
@ -7576,7 +7522,7 @@
\def\setupverb{%
\tt % easiest (and conventionally used) font for verbatim
\def\par{\leavevmode\endgraf}%
\setupmarkupstyle{verb}%
\setcodequotes
\tabeightspaces
% Respect line breaks,
% print special symbols as themselves, and
@ -7617,7 +7563,7 @@
\tt % easiest (and conventionally used) font for verbatim
\def\par{\egroup\leavevmode\box\verbbox\endgraf\starttabbox}%
\tabexpand
\setupmarkupstyle{verbatim}%
\setcodequotes
% Respect line breaks,
% print special symbols as themselves, and
% make each space count.
@ -8036,7 +7982,7 @@
% leave the code in, but it's strange for @var to lead to typewriter.
% Nowadays we recommend @code, since the difference between a ttsl hyphen
% and a tt hyphen is pretty tiny. @code also disables ?` !`.
\def\var##1{{\setupmarkupstyle{var}\ttslanted{##1}}}%
\def\var##1{{\setregularquotes\ttslanted{##1}}}%
#1%
\sl\hyphenchar\font=45
}
@ -8145,11 +8091,18 @@
}
\fi
\let\E=\expandafter
% Used at the time of macro expansion.
% Argument is macro body with arguments substituted
\def\scanmacro#1{%
\newlinechar`\^^M
\def\xeatspaces{\eatspaces}%
% expand the expansion of \eatleadingcr twice to maybe remove a leading
% newline (and \else and \fi tokens), then call \eatspaces on the result.
\def\xeatspaces##1{%
\E\E\E\E\E\E\E\eatspaces\E\E\E\E\E\E\E{\eatleadingcr##1%
}}%
\def\xempty##1{}%
%
% Process the macro body under the current catcode regime.
\scantokens{#1@comment}%
@ -8202,6 +8155,11 @@
\unbrace{\gdef\trim@@@ #1 } #2@{#1}
}
{\catcode`\^^M=\other%
\gdef\eatleadingcr#1{\if\noexpand#1\noexpand^^M\else\E#1\fi}}%
% Warning: this won't work for a delimited argument
% or for an empty argument
% Trim a single trailing ^^M off a string.
{\catcode`\^^M=\other \catcode`\Q=3%
\gdef\eatcr #1{\eatcra #1Q^^MQ}%
@ -8368,6 +8326,7 @@
\let\hash\relax
% \hash is redefined to `#' later to get it into definitions
\let\xeatspaces\relax
\let\xempty\relax
\parsemargdefxxx#1,;,%
\ifnum\paramno<10\relax\else
\paramno0\relax
@ -8379,9 +8338,11 @@
\else \let\next=\parsemargdefxxx
\advance\paramno by 1
\expandafter\edef\csname macarg.\eatspaces{#1}\endcsname
{\xeatspaces{\hash\the\paramno}}%
{\xeatspaces{\hash\the\paramno\noexpand\xempty{}}}%
\edef\paramlist{\paramlist\hash\the\paramno,}%
\fi\next}
% the \xempty{} is to give \eatleadingcr an argument in the case of an
% empty macro argument.
% \parsemacbody, \parsermacbody
%
@ -9107,20 +9068,22 @@
% output the `[mynode]' via the macro below so it can be overridden.
\xrefprintnodename\printedrefname
%
% But we always want a comma and a space:
,\space
%
% output the `page 3'.
\turnoffactive \putwordpage\tie\refx{#1-pg}{}%
% Add a , if xref followed by a space
\if\space\noexpand\tokenafterxref ,%
\else\ifx\ \tokenafterxref ,% @TAB
\else\ifx\*\tokenafterxref ,% @*
\else\ifx\ \tokenafterxref ,% @SPACE
\else\ifx\
\tokenafterxref ,% @NL
\else\ifx\tie\tokenafterxref ,% @tie
\fi\fi\fi\fi\fi\fi
\expandafter\ifx\csname SETtxiomitxrefpg\endcsname\relax
% But we always want a comma and a space:
,\space
%
% output the `page 3'.
\turnoffactive \putwordpage\tie\refx{#1-pg}{}%
% Add a , if xref followed by a space
\if\space\noexpand\tokenafterxref ,%
\else\ifx\ \tokenafterxref ,% @TAB
\else\ifx\*\tokenafterxref ,% @*
\else\ifx\ \tokenafterxref ,% @SPACE
\else\ifx\
\tokenafterxref ,% @NL
\else\ifx\tie\tokenafterxref ,% @tie
\fi\fi\fi\fi\fi\fi
\fi
\fi\fi
\fi
\endlink
@ -9550,7 +9513,7 @@
\def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup
\catcode`\^^M = 5 % in case we're inside an example
\normalturnoffactive % allow _ et al. in names
\def\xprocessmacroarg{\eatspaces}% in case we are being used via a macro
\makevalueexpandable
% If the image is by itself, center it.
\ifvmode
\imagevmodetrue
@ -11603,7 +11566,7 @@
\let> = \activegtr
\let~ = \activetilde
\let^ = \activehat
\markupsetuplqdefault \markupsetuprqdefault
\setregularquotes
\let\b = \strong
\let\i = \smartitalic
% in principle, all other definitions in \tex have to be undone too.
@ -11662,8 +11625,7 @@
@let|=@normalverticalbar
@let~=@normaltilde
@let\=@ttbackslash
@markupsetuplqdefault
@markupsetuprqdefault
@setregularquotes
@unsepspaces
}
}
@ -11756,8 +11718,7 @@
@c Do this last of all since we use ` in the previous @catcode assignments.
@catcode`@'=@active
@catcode`@`=@active
@markupsetuplqdefault
@markupsetuprqdefault
@setregularquotes
@c Local variables:
@c eval: (add-hook 'before-save-hook 'time-stamp)

30
doc/misc/tramp.texi
View file

@ -810,9 +810,10 @@ behavior.
@cindex @option{sshx} method
Works like @option{ssh} but without the extra authentication prompts.
@option{sshx} uses @samp{ssh -t -t @var{host} -l @var{user} /bin/sh}
to open a connection with a ``standard'' login shell. It supports
changing the remote login shell @command{/bin/sh}.
@option{sshx} uses @samp{ssh -t -t -l @var{user} -o
RemoteCommand='/bin/sh -i' @var{host}} to open a connection with a
``standard'' login shell. It supports changing the remote login shell
@command{/bin/sh}.
@strong{Note} that @option{sshx} does not bypass authentication
questions. For example, if the host key of the remote host is not
@ -935,9 +936,10 @@ This method supports the @samp{-p} argument.
@cindex @command{ssh} (with @option{scpx} method)
@option{scpx} is useful to avoid login shell questions. It is similar
in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t
@var{host} -l @var{user} /bin/sh} to open a connection. It supports
changing the remote login shell @command{/bin/sh}.
in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t -l
@var{user} -o RemoteCommand='/bin/sh -i' @var{host}} to open a
connection. It supports changing the remote login shell
@command{/bin/sh}.
@option{scpx} is useful for MS Windows users when @command{ssh}
triggers an error about allocating a pseudo tty. This happens due to
@ -1284,6 +1286,9 @@ This method uses @command{sftp} in order to securely access remote
hosts. @command{sftp} is a more secure option for connecting to hosts
that for security reasons refuse @command{ssh} connections.
When there is a respective entry in your @command{ssh} configuration,
do @emph{not} set the @option{RemoteCommand} option.
@end table
@defopt tramp-gvfs-methods
@ -2220,7 +2225,10 @@ This uses also the settings in @code{tramp-sh-extra-args}.
@vindex RemoteCommand@r{, ssh option}
@strong{Note}: If you use an @option{ssh}-based method for connection,
do @emph{not} set the @option{RemoteCommand} option in your
@command{ssh} configuration, for example to @command{screen}.
@command{ssh} configuration, for example to @command{screen}. On the
other hand, some @option{ssh}-based methods, like @option{sshx} or
@option{scpx}, silently overwrite a @option{RemoteCommand} option of
the configuration file.
@subsection Other remote shell setup hints
@ -3580,13 +3588,16 @@ Furthermore, this approach has the following limitations:
It works only for connection methods defined in @file{tramp-sh.el} and
@file{tramp-adb.el}.
@vindex ControlMaster@r{, ssh option}
@item
It does not support interactive user authentication. With
@option{ssh}-based methods, this can be avoided by using a password
agent like @command{ssh-agent}, using public key authentication, or
using @option{ControlMaster} options.
@item
It cannot be applied for @option{ssh}-based methods, which use the
@option{RemoteCommand} option.
@item
It cannot be killed via @code{interrupt-process}.
@ -3597,8 +3608,7 @@ It does not report the remote terminal name via @code{process-tty-name}.
It does not set process property @code{remote-pid}.
@item
It does not use @code{tramp-remote-path} and
@code{tramp-remote-process-environment}.
It does not use @code{tramp-remote-path}.
@end itemize
In order to gain even more performance, it is recommended to bind

61
etc/NEWS
View file

@ -504,6 +504,12 @@ time zones will use a form like "+0100" instead of "CET".
** Dired
---
*** Behavior change on 'dired-clean-confirm-killing-deleted-buffers'.
Previously, if 'dired-clean-up-buffers-too' was non-nil, and
'dired-clean-confirm-killing-deleted-buffers' was nil, the buffers
wouldn't be killed. This combination will now kill the buffers.
+++
*** New user option 'dired-switches-in-mode-line'.
This user option controls how 'ls' switches are displayed in the mode
@ -721,9 +727,11 @@ not.
---
*** Respect 'message-forward-ignored-headers' more.
Previously, this variable would not be consulted if
'message-forward-show-mml' was nil. It's now always used, except if
'message-forward-show-mml' is 'best', and we're forwarding an
encrypted/signed message.
'message-forward-show-mml' was nil and forwarding as MIME.
+++
*** New user option 'message-forward-included-mime-headers'.
This is used when forwarding messages as MIME, but not using MML.
+++
*** Message now supports the OpenPGP header.
@ -1096,6 +1104,11 @@ If present in 'whitespace-style' (as it is by default), the final
character in the buffer will be highlighted if the buffer doesn't end
with a newline.
---
*** The default 'whitespace-enable-predicate' predicate has changed.
It used to check elements in the list version of
'whitespace-global-modes' with 'eq', but now uses 'derived-mode-p'.
** Texinfo
---
@ -1125,6 +1138,11 @@ bindings, will be aborted, and Emacs will not ask you whether to
enlarge 'max-specpdl-size' to complete the rendering. The default is
t, which preserves the original behavior.
---
*** New user option 'rmail-show-message-set-modified'.
If set non-nil, showing an unseen message will set the Rmail buffer's
modified flag.
** Apropos
*** New commands 'apropos-next-symbol' and 'apropos-previous-symbol'.
@ -1554,9 +1572,31 @@ buttons in it.
This function takes a string and returns a string propertized in a way
that makes it a valid button.
** subr-x
+++
*** A number of new string manipulation functions have been added.
'string-clean-whitespace', 'string-fill', 'string-limit',
'string-lines', 'string-pad' and 'string-chop-newline'.
*** New macro `named-let` that provides Scheme's "named let" looping construct
** thingatpt
+++
*** New variable 'thing-at-point-provider-alist'.
This allows mode-specific alterations to how `thing-at-point' works.
** Miscellaneous
+++
*** New command `C-x C-k Q' to force redisplay in keyboard macros.
---
*** New user option 'remember-diary-regexp'.
---
*** New user option 'remember-text-format-function'.
*** New function 'buffer-line-statistics'.
This function returns some statistics about the line lengths in a buffer.
@ -1587,11 +1627,6 @@ length to a number).
*** New user option 'authinfo-hide-elements'.
This can be set to nil to inhibit hiding passwords in ".authinfo" files.
+++
*** A number of new string manipulation functions have been added.
'string-clean-whitespace', 'string-fill', 'string-limit',
'string-lines', 'string-pad' and 'string-chop-newline'.
+++
*** New variable 'current-minibuffer-command'.
This is like 'this-command', but it is bound recursively when entering
@ -2002,6 +2037,14 @@ hooks 'kill-buffer-hook', 'kill-buffer-query-functions', and
'buffer-list-update-hook' for the temporary buffers they create. This
avoids slowing them down when a lot of these hooks are defined.
** New face 'child-frame-border' and frame parameter 'child-frame-border-width'.
The face and width of child frames borders can now be determined
separately from those of normal frames. To minimize backward
incompatibility, child frames without a 'child-frame-border-width'
parameter will fall back to using 'internal-border-width'. However,
the new 'child-frame-border' face does constitute a breaking change
since child frames' borders no longer use the 'internal-border' face.
---
** The obsolete function 'thread-alive-p' has been removed.
@ -2117,6 +2160,8 @@ obsolete back in Emacs-23.1. The affected functions are:
make-obsolete, define-obsolete-function-alias, make-obsolete-variable,
define-obsolete-variable-alias.
** The variable 'keyboard-type' is obsolete and not dynamically scoped any more
* Lisp Changes in Emacs 28.1

12
leim/leim-ext.el
View file

@ -1,4 +1,4 @@
;; leim-ext.el -- extra leim configuration -*- coding:utf-8; -*-
;; leim-ext.el -- extra leim configuration -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
@ -39,13 +39,13 @@
(eval-after-load "quail/Punct-b5"
'(quail-defrule " " ?　 nil t))
(register-input-method "ucs" "UTF-8" 'ucs-input-activate "U+"
(register-input-method "ucs" "UTF-8" #'ucs-input-activate "U+"
"Unicode input as hex in the form Uxxxx.")
(register-input-method
"korean-hangul"
"UTF-8"
'hangul-input-method-activate
#'hangul-input-method-activate
"한2"
"Hangul 2-Bulsik Input"
'hangul2-input-method
@ -54,7 +54,7 @@
(register-input-method
"korean-hangul3f"
"UTF-8"
'hangul-input-method-activate
#'hangul-input-method-activate
"한3f"
"Hangul 3-Bulsik final Input"
'hangul3-input-method
@ -63,7 +63,7 @@
(register-input-method
"korean-hangul390"
"UTF-8"
'hangul-input-method-activate
#'hangul-input-method-activate
"한390"
"Hangul 3-Bulsik 390 Input"
'hangul390-input-method
@ -72,7 +72,7 @@
(register-input-method
"korean-hangul3"
"UTF-8"
'hangul-input-method-activate
#'hangul-input-method-activate
"한390"
"Hangul 3-Bulsik 390 Input"
'hangul390-input-method

16
lib/_Noreturn.h
View file

@ -26,14 +26,16 @@
AIX system header files and several gnulib header files use precisely
this syntax with 'extern'. */
# define _Noreturn [[noreturn]]
# elif ((!defined __cplusplus || defined __clang__) \
&& (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \
|| 4 < __GNUC__ + (7 <= __GNUC_MINOR__) \
|| (defined __apple_build_version__ \
? 6000000 <= __apple_build_version__ \
: 3 < __clang_major__ + (5 <= __clang_minor__))))
# elif ((!defined __cplusplus || defined __clang__) \
&& (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \
|| (!defined __STRICT_ANSI__ \
&& (__4 < __GNUC__ + (7 <= __GNUC_MINOR__) \
|| (defined __apple_build_version__ \
? 6000000 <= __apple_build_version__ \
: 3 < __clang_major__ + (5 <= __clang_minor__))))))
/* _Noreturn works as-is. */
# elif 2 < __GNUC__ + (8 <= __GNUC_MINOR__) || 0x5110 <= __SUNPRO_C
# elif (2 < __GNUC__ + (8 <= __GNUC_MINOR__) || defined __clang__ \
|| 0x5110 <= __SUNPRO_C)
# define _Noreturn __attribute__ ((__noreturn__))
# elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0)
# define _Noreturn __declspec (noreturn)

25
lib/canonicalize-lgpl.c
View file

@ -85,10 +85,6 @@
# define IF_LINT(Code) /* empty */
#endif
/* True if adding two valid object sizes might overflow idx_t.
As a practical matter, this cannot happen on 64-bit machines. */
enum { NARROW_ADDRESSES = IDX_MAX >> 31 >> 31 == 0 };
#ifndef DOUBLE_SLASH_IS_DISTINCT_ROOT
# define DOUBLE_SLASH_IS_DISTINCT_ROOT false
#endif
@ -145,11 +141,11 @@ suffix_requires_dir_check (char const *end)
macOS 10.13 <https://bugs.gnu.org/30350>, and should also work on
platforms like AIX 7.2 that need at least "/.". */
#if defined _LIBC || defined LSTAT_FOLLOWS_SLASHED_SYMLINK
# if defined _LIBC || defined LSTAT_FOLLOWS_SLASHED_SYMLINK
static char const dir_suffix[] = "/";
#else
# else
static char const dir_suffix[] = "/./";
#endif
# endif
/* Return true if DIR is a searchable dir, false (setting errno) otherwise.
DIREND points to the NUL byte at the end of the DIR string.
@ -191,13 +187,13 @@ get_path_max (void)
to pacify GCC is known; even an explicit #pragma does not pacify GCC.
When the GCC bug is fixed this workaround should be limited to the
broken GCC versions. */
#if __GNUC_PREREQ (10, 1)
# if defined GCC_LINT || defined lint
# if __GNUC_PREREQ (10, 1)
# if defined GCC_LINT || defined lint
__attribute__ ((__noinline__))
# elif __OPTIMIZE__ && !__NO_INLINE__
# define GCC_BOGUS_WRETURN_LOCAL_ADDR
# elif __OPTIMIZE__ && !__NO_INLINE__
# define GCC_BOGUS_WRETURN_LOCAL_ADDR
# endif
# endif
#endif
static char *
realpath_stk (const char *name, char *resolved,
struct scratch_buffer *rname_buf)
@ -343,7 +339,7 @@ realpath_stk (const char *name, char *resolved,
if (end_in_extra_buffer)
end_idx = end - extra_buf;
size_t len = strlen (end);
if (NARROW_ADDRESSES && INT_ADD_OVERFLOW (len, n))
if (INT_ADD_OVERFLOW (len, n))
{
__set_errno (ENOMEM);
goto error_nomem;
@ -443,7 +439,8 @@ __realpath (const char *name, char *resolved)
}
libc_hidden_def (__realpath)
versioned_symbol (libc, __realpath, realpath, GLIBC_2_3);
#endif /* !FUNC_REALPATH_WORKS || defined _LIBC */
#endif /* defined _LIBC || !FUNC_REALPATH_WORKS */
#if SHLIB_COMPAT(libc, GLIBC_2_0, GLIBC_2_3)

192
lib/cdefs.h
View file

@ -25,7 +25,7 @@
/* The GNU libc does not support any K&R compilers or the traditional mode
of ISO C compilers anymore. Check for some of the combinations not
anymore supported. */
supported anymore. */
#if defined __GNUC__ && !defined __STDC__
# error "You need a ISO C conforming compiler to use the glibc headers"
#endif
@ -34,31 +34,26 @@
#undef __P
#undef __PMT
/* Compilers that are not clang may object to
#if defined __clang__ && __has_attribute(...)
even though they do not need to evaluate the right-hand side of the &&. */
#if defined __clang__ && defined __has_attribute
# define __glibc_clang_has_attribute(name) __has_attribute (name)
/* Compilers that lack __has_attribute may object to
#if defined __has_attribute && __has_attribute (...)
even though they do not need to evaluate the right-hand side of the &&.
Similarly for __has_builtin, etc. */
#if (defined __has_attribute \
&& (!defined __clang_minor__ \
|| 3 < __clang_major__ + (5 <= __clang_minor__)))
# define __glibc_has_attribute(attr) __has_attribute (attr)
#else
# define __glibc_clang_has_attribute(name) 0
# define __glibc_has_attribute(attr) 0
#endif
/* Compilers that are not clang may object to
#if defined __clang__ && __has_builtin(...)
even though they do not need to evaluate the right-hand side of the &&. */
#if defined __clang__ && defined __has_builtin
# define __glibc_clang_has_builtin(name) __has_builtin (name)
#ifdef __has_builtin
# define __glibc_has_builtin(name) __has_builtin (name)
#else
# define __glibc_clang_has_builtin(name) 0
# define __glibc_has_builtin(name) 0
#endif
/* Compilers that are not clang may object to
#if defined __clang__ && __has_extension(...)
even though they do not need to evaluate the right-hand side of the &&. */
#if defined __clang__ && defined __has_extension
# define __glibc_clang_has_extension(ext) __has_extension (ext)
#ifdef __has_extension
# define __glibc_has_extension(ext) __has_extension (ext)
#else
# define __glibc_clang_has_extension(ext) 0
# define __glibc_has_extension(ext) 0
#endif
#if defined __GNUC__ || defined __clang__
@ -74,22 +69,26 @@
# endif
/* GCC can always grok prototypes. For C++ programs we add throw()
to help it optimize the function calls. But this works only with
to help it optimize the function calls. But this only works with
gcc 2.8.x and egcs. For gcc 3.4 and up we even mark C functions
as non-throwing using a function attribute since programs can use
the -fexceptions options for C code as well. */
# if !defined __cplusplus \
&& (__GNUC_PREREQ (3, 4) || __glibc_clang_has_attribute (__nothrow__))
&& (__GNUC_PREREQ (3, 4) || __glibc_has_attribute (__nothrow__))
# define __THROW __attribute__ ((__nothrow__ __LEAF))
# define __THROWNL __attribute__ ((__nothrow__))
# define __NTH(fct) __attribute__ ((__nothrow__ __LEAF)) fct
# define __NTHNL(fct) __attribute__ ((__nothrow__)) fct
# else
# if defined __cplusplus && (__GNUC_PREREQ (2,8) || __clang_major >= 4)
# define __THROW throw ()
# define __THROWNL throw ()
# define __NTH(fct) __LEAF_ATTR fct throw ()
# define __NTHNL(fct) fct throw ()
# if __cplusplus >= 201103L
# define __THROW noexcept (true)
# else
# define __THROW throw ()
# endif
# define __THROWNL __THROW
# define __NTH(fct) __LEAF_ATTR fct __THROW
# define __NTHNL(fct) fct __THROW
# else
# define __THROW
# define __THROWNL
@ -142,24 +141,20 @@
#define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1)
#define __bos0(ptr) __builtin_object_size (ptr, 0)
/* Use __builtin_dynamic_object_size at _FORTIFY_SOURCE=3 when available. */
#if __USE_FORTIFY_LEVEL == 3 && __glibc_clang_prereq (9, 0)
# define __glibc_objsize0(__o) __builtin_dynamic_object_size (__o, 0)
# define __glibc_objsize(__o) __builtin_dynamic_object_size (__o, 1)
#else
# define __glibc_objsize0(__o) __bos0 (__o)
# define __glibc_objsize(__o) __bos (__o)
#endif
#if __GNUC_PREREQ (4,3)
# define __warndecl(name, msg) \
extern void name (void) __attribute__((__warning__ (msg)))
# define __warnattr(msg) __attribute__((__warning__ (msg)))
# define __errordecl(name, msg) \
extern void name (void) __attribute__((__error__ (msg)))
#elif __glibc_clang_has_attribute (__diagnose_if__) && 0
/* These definitions are not enabled, because they produce bogus warnings
in the glibc Fortify functions. These functions are written in a style
that works with GCC. In order to work with clang, these functions would
need to be modified. */
# define __warndecl(name, msg) \
extern void name (void) __attribute__((__diagnose_if__ (1, msg, "warning")))
# define __warnattr(msg) __attribute__((__diagnose_if__ (1, msg, "warning")))
# define __errordecl(name, msg) \
extern void name (void) __attribute__((__diagnose_if__ (1, msg, "error")))
#else
# define __warndecl(name, msg) extern void name (void)
# define __warnattr(msg)
# define __errordecl(name, msg) extern void name (void)
#endif
@ -233,7 +228,7 @@
/* At some point during the gcc 2.96 development the `malloc' attribute
for functions was introduced. We don't want to use it unconditionally
(although this would be possible) since it generates warnings. */
#if __GNUC_PREREQ (2,96) || __glibc_clang_has_attribute (__malloc__)
#if __GNUC_PREREQ (2,96) || __glibc_has_attribute (__malloc__)
# define __attribute_malloc__ __attribute__ ((__malloc__))
#else
# define __attribute_malloc__ /* Ignore */
@ -251,23 +246,31 @@
/* At some point during the gcc 2.96 development the `pure' attribute
for functions was introduced. We don't want to use it unconditionally
(although this would be possible) since it generates warnings. */
#if __GNUC_PREREQ (2,96) || __glibc_clang_has_attribute (__pure__)
#if __GNUC_PREREQ (2,96) || __glibc_has_attribute (__pure__)
# define __attribute_pure__ __attribute__ ((__pure__))
#else
# define __attribute_pure__ /* Ignore */
#endif
/* This declaration tells the compiler that the value is constant. */
#if __GNUC_PREREQ (2,5) || __glibc_clang_has_attribute (__const__)
#if __GNUC_PREREQ (2,5) || __glibc_has_attribute (__const__)
# define __attribute_const__ __attribute__ ((__const__))
#else
# define __attribute_const__ /* Ignore */
#endif
#if defined __STDC_VERSION__ && 201710L < __STDC_VERSION__
# define __attribute_maybe_unused__ [[__maybe_unused__]]
#elif __GNUC_PREREQ (2,7) || __glibc_has_attribute (__unused__)
# define __attribute_maybe_unused__ __attribute__ ((__unused__))
#else
# define __attribute_maybe_unused__ /* Ignore */
#endif
/* At some point during the gcc 3.1 development the `used' attribute
for functions was introduced. We don't want to use it unconditionally
(although this would be possible) since it generates warnings. */
#if __GNUC_PREREQ (3,1) || __glibc_clang_has_attribute (__used__)
#if __GNUC_PREREQ (3,1) || __glibc_has_attribute (__used__)
# define __attribute_used__ __attribute__ ((__used__))
# define __attribute_noinline__ __attribute__ ((__noinline__))
#else
@ -276,7 +279,7 @@
#endif
/* Since version 3.2, gcc allows marking deprecated functions. */
#if __GNUC_PREREQ (3,2) || __glibc_clang_has_attribute (__deprecated__)
#if __GNUC_PREREQ (3,2) || __glibc_has_attribute (__deprecated__)
# define __attribute_deprecated__ __attribute__ ((__deprecated__))
#else
# define __attribute_deprecated__ /* Ignore */
@ -285,8 +288,8 @@
/* Since version 4.5, gcc also allows one to specify the message printed
when a deprecated function is used. clang claims to be gcc 4.2, but
may also support this feature. */
#if __GNUC_PREREQ (4,5) || \
__glibc_clang_has_extension (__attribute_deprecated_with_message__)
#if __GNUC_PREREQ (4,5) \
|| __glibc_has_extension (__attribute_deprecated_with_message__)
# define __attribute_deprecated_msg__(msg) \
__attribute__ ((__deprecated__ (msg)))
#else
@ -299,7 +302,7 @@
If several `format_arg' attributes are given for the same function, in
gcc-3.0 and older, all but the last one are ignored. In newer gccs,
all designated arguments are considered. */
#if __GNUC_PREREQ (2,8) || __glibc_clang_has_attribute (__format_arg__)
#if __GNUC_PREREQ (2,8) || __glibc_has_attribute (__format_arg__)
# define __attribute_format_arg__(x) __attribute__ ((__format_arg__ (x)))
#else
# define __attribute_format_arg__(x) /* Ignore */
@ -309,7 +312,7 @@
attribute for functions was introduced. We don't want to use it
unconditionally (although this would be possible) since it
generates warnings. */
#if __GNUC_PREREQ (2,97) || __glibc_clang_has_attribute (__format__)
#if __GNUC_PREREQ (2,97) || __glibc_has_attribute (__format__)
# define __attribute_format_strfmon__(a,b) \
__attribute__ ((__format__ (__strfmon__, a, b)))
#else
@ -317,19 +320,21 @@
#endif
/* The nonnull function attribute marks pointer parameters that
must not be NULL. Do not define __nonnull if it is already defined,
for portability when this file is used in Gnulib. */
must not be NULL. */
#ifndef __nonnull
# if __GNUC_PREREQ (3,3) || __glibc_clang_has_attribute (__nonnull__)
# if __GNUC_PREREQ (3,3) || __glibc_has_attribute (__nonnull__)
# define __nonnull(params) __attribute__ ((__nonnull__ params))
# else
# define __nonnull(params)
# endif
#elif !defined __GLIBC__
# undef __nonnull
# define __nonnull(params) _GL_ATTRIBUTE_NONNULL (params)
#endif
/* If fortification mode, we warn about unused results of certain
function calls which can lead to problems. */
#if __GNUC_PREREQ (3,4) || __glibc_clang_has_attribute (__warn_unused_result__)
#if __GNUC_PREREQ (3,4) || __glibc_has_attribute (__warn_unused_result__)
# define __attribute_warn_unused_result__ \
__attribute__ ((__warn_unused_result__))
# if defined __USE_FORTIFY_LEVEL && __USE_FORTIFY_LEVEL > 0
@ -343,7 +348,7 @@
#endif
/* Forces a function to be always inlined. */
#if __GNUC_PREREQ (3,2) || __glibc_clang_has_attribute (__always_inline__)
#if __GNUC_PREREQ (3,2) || __glibc_has_attribute (__always_inline__)
/* The Linux kernel defines __always_inline in stddef.h (283d7573), and
it conflicts with this definition. Therefore undefine it first to
allow either header to be included first. */
@ -356,7 +361,7 @@
/* Associate error messages with the source location of the call site rather
than with the source location inside the function. */
#if __GNUC_PREREQ (4,3) || __glibc_clang_has_attribute (__artificial__)
#if __GNUC_PREREQ (4,3) || __glibc_has_attribute (__artificial__)
# define __attribute_artificial__ __attribute__ ((__artificial__))
#else
# define __attribute_artificial__ /* Ignore */
@ -433,7 +438,7 @@
# endif
#endif
#if (__GNUC__ >= 3) || __glibc_clang_has_builtin (__builtin_expect)
#if (__GNUC__ >= 3) || __glibc_has_builtin (__builtin_expect)
# define __glibc_unlikely(cond) __builtin_expect ((cond), 0)
# define __glibc_likely(cond) __builtin_expect ((cond), 1)
#else
@ -441,12 +446,6 @@
# define __glibc_likely(cond) (cond)
#endif
#ifdef __has_attribute
# define __glibc_has_attribute(attr) __has_attribute (attr)
#else
# define __glibc_has_attribute(attr) 0
#endif
#if (!defined _Noreturn \
&& (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \
&& !(__GNUC_PREREQ (4,7) \
@ -467,6 +466,16 @@
# define __attribute_nonstring__
#endif
/* Undefine (also defined in libc-symbols.h). */
#undef __attribute_copy__
#if __GNUC_PREREQ (9, 0)
/* Copies attributes from the declaration or type referenced by
the argument. */
# define __attribute_copy__(arg) __attribute__ ((__copy__ (arg)))
#else
# define __attribute_copy__(arg)
#endif
#if (!defined _Static_assert && !defined __cplusplus \
&& (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \
&& (!(__GNUC_PREREQ (4, 6) || __clang_major__ >= 4) \
@ -483,7 +492,37 @@
# include <bits/long-double.h>
#endif
#if defined __LONG_DOUBLE_MATH_OPTIONAL && defined __NO_LONG_DOUBLE_MATH
#if __LDOUBLE_REDIRECTS_TO_FLOAT128_ABI == 1
# ifdef __REDIRECT
/* Alias name defined automatically. */
# define __LDBL_REDIR(name, proto) ... unused__ldbl_redir
# define __LDBL_REDIR_DECL(name) \
extern __typeof (name) name __asm (__ASMNAME ("__" #name "ieee128"));
/* Alias name defined automatically, with leading underscores. */
# define __LDBL_REDIR2_DECL(name) \
extern __typeof (__##name) __##name \
__asm (__ASMNAME ("__" #name "ieee128"));
/* Alias name defined manually. */
# define __LDBL_REDIR1(name, proto, alias) ... unused__ldbl_redir1
# define __LDBL_REDIR1_DECL(name, alias) \
extern __typeof (name) name __asm (__ASMNAME (#alias));
# define __LDBL_REDIR1_NTH(name, proto, alias) \
__REDIRECT_NTH (name, proto, alias)
# define __REDIRECT_NTH_LDBL(name, proto, alias) \
__LDBL_REDIR1_NTH (name, proto, __##alias##ieee128)
/* Unused. */
# define __REDIRECT_LDBL(name, proto, alias) ... unused__redirect_ldbl
# define __LDBL_REDIR_NTH(name, proto) ... unused__ldbl_redir_nth
# else
_Static_assert (0, "IEEE 128-bits long double requires redirection on this platform");
# endif
#elif defined __LONG_DOUBLE_MATH_OPTIONAL && defined __NO_LONG_DOUBLE_MATH
# define __LDBL_COMPAT 1
# ifdef __REDIRECT
# define __LDBL_REDIR1(name, proto, alias) __REDIRECT (name, proto, alias)
@ -492,6 +531,8 @@
# define __LDBL_REDIR1_NTH(name, proto, alias) __REDIRECT_NTH (name, proto, alias)
# define __LDBL_REDIR_NTH(name, proto) \
__LDBL_REDIR1_NTH (name, proto, __nldbl_##name)
# define __LDBL_REDIR2_DECL(name) \
extern __typeof (__##name) __##name __asm (__ASMNAME ("__nldbl___" #name));
# define __LDBL_REDIR1_DECL(name, alias) \
extern __typeof (name) name __asm (__ASMNAME (#alias));
# define __LDBL_REDIR_DECL(name) \
@ -502,11 +543,13 @@
__LDBL_REDIR1_NTH (name, proto, __nldbl_##alias)
# endif
#endif
#if !defined __LDBL_COMPAT || !defined __REDIRECT
#if (!defined __LDBL_COMPAT && __LDOUBLE_REDIRECTS_TO_FLOAT128_ABI == 0) \
|| !defined __REDIRECT
# define __LDBL_REDIR1(name, proto, alias) name proto
# define __LDBL_REDIR(name, proto) name proto
# define __LDBL_REDIR1_NTH(name, proto, alias) name proto __THROW
# define __LDBL_REDIR_NTH(name, proto) name proto __THROW
# define __LDBL_REDIR2_DECL(name)
# define __LDBL_REDIR_DECL(name)
# ifdef __REDIRECT
# define __REDIRECT_LDBL(name, proto, alias) __REDIRECT (name, proto, alias)
@ -537,7 +580,7 @@
check is required to enable the use of generic selection. */
#if !defined __cplusplus \
&& (__GNUC_PREREQ (4, 9) \
|| __glibc_clang_has_extension (c_generic_selections) \
|| __glibc_has_extension (c_generic_selections) \
|| (!defined __GNUC__ && defined __STDC_VERSION__ \
&& __STDC_VERSION__ >= 201112L))
# define __HAVE_GENERIC_SELECTION 1
@ -545,4 +588,23 @@
# define __HAVE_GENERIC_SELECTION 0
#endif
#if __GNUC_PREREQ (10, 0)
/* Designates a 1-based positional argument ref-index of pointer type
that can be used to access size-index elements of the pointed-to
array according to access mode, or at least one element when
size-index is not provided:
access (access-mode, <ref-index> [, <size-index>]) */
#define __attr_access(x) __attribute__ ((__access__ x))
#else
# define __attr_access(x)
#endif
/* Specify that a function such as setjmp or vfork may return
twice. */
#if __GNUC_PREREQ (4, 1)
# define __attribute_returns_twice__ __attribute__ ((__returns_twice__))
#else
# define __attribute_returns_twice__ /* Ignore. */
#endif
#endif /* sys/cdefs.h */

3
lib/dirent.in.h
View file

@ -154,7 +154,8 @@ _GL_WARN_ON_USE (closedir, "closedir is not portable - "
/* Return the file descriptor associated with the given directory stream,
or -1 if none exists. */
# if @REPLACE_DIRFD@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
/* On kLIBC, dirfd() is a macro that does not work. Undefine it. */
# if !(defined __cplusplus && defined GNULIB_NAMESPACE) || defined dirfd
# undef dirfd
# define dirfd rpl_dirfd
# endif

31
lib/dynarray.h Normal file
View file

@ -0,0 +1,31 @@
/* Type-safe arrays which grow dynamically.
Copyright 2021 Free Software Foundation, Inc.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>. */
/* Written by Paul Eggert, 2021. */
#ifndef _GL_DYNARRAY_H
#define _GL_DYNARRAY_H
#include <libc-config.h>
#define __libc_dynarray_at_failure gl_dynarray_at_failure
#define __libc_dynarray_emplace_enlarge gl_dynarray_emplace_enlarge
#define __libc_dynarray_finalize gl_dynarray_finalize
#define __libc_dynarray_resize_clear gl_dynarray_resize_clear
#define __libc_dynarray_resize gl_dynarray_resize
#include <malloc/dynarray.h>
#endif /* _GL_DYNARRAY_H */

16
lib/explicit_bzero.c
View file

@ -54,11 +54,21 @@ explicit_bzero (void *s, size_t len)
explicit_memset (s, '\0', len);
#elif HAVE_MEMSET_S
(void) memset_s (s, len, '\0', len);
#else
#elif defined __GNUC__ && !defined __clang__
memset (s, '\0', len);
# if defined __GNUC__ && !defined __clang__
/* Compiler barrier. */
asm volatile ("" ::: "memory");
# endif
#elif defined __clang__
memset (s, '\0', len);
/* Compiler barrier. */
/* With asm ("" ::: "memory") LLVM analyzes uses of 's' and finds that the
whole thing is dead and eliminates it. Use 'g' to work around this
problem. See <https://bugs.llvm.org/show_bug.cgi?id=15495#c11>. */
__asm__ volatile ("" : : "g"(s) : "memory");
#else
/* Invoke memset through a volatile function pointer. This defeats compiler
optimizations. */
void * (* const volatile volatile_memset) (void *, int, size_t) = memset;
(void) volatile_memset (s, '\0', len);
#endif
}

17
lib/fchmodat.c
View file

@ -38,6 +38,7 @@ orig_fchmodat (int dir, char const *file, mode_t mode, int flags)
#include <fcntl.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#ifdef __osf__
@ -63,6 +64,22 @@ orig_fchmodat (int dir, char const *file, mode_t mode, int flags)
int
fchmodat (int dir, char const *file, mode_t mode, int flags)
{
# if HAVE_NEARLY_WORKING_FCHMODAT
/* Correct the trailing slash handling. */
size_t len = strlen (file);
if (len && file[len - 1] == '/')
{
struct stat st;
if (fstatat (dir, file, &st, flags & AT_SYMLINK_NOFOLLOW) < 0)
return -1;
if (!S_ISDIR (st.st_mode))
{
errno = ENOTDIR;
return -1;
}
}
# endif
# if NEED_FCHMODAT_NONSYMLINK_FIX
if (flags == AT_SYMLINK_NOFOLLOW)
{

14
lib/free.c
View file

@ -27,7 +27,21 @@ void
rpl_free (void *p)
#undef free
{
#if defined __GNUC__ && !defined __clang__
/* An invalid GCC optimization
<https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98396>
would optimize away the assignments in the code below, when link-time
optimization (LTO) is enabled. Make the code more complicated, so that
GCC does not grok how to optimize it. */
int err[2];
err[0] = errno;
err[1] = errno;
errno = 0;
free (p);
errno = err[errno == 0];
#else
int err = errno;
free (p);
errno = err;
#endif
}

27
lib/gnulib.mk.in
View file

@ -516,6 +516,7 @@ GNULIB_SYMLINK = @GNULIB_SYMLINK@
GNULIB_SYMLINKAT = @GNULIB_SYMLINKAT@
GNULIB_SYSTEM_POSIX = @GNULIB_SYSTEM_POSIX@
GNULIB_TIMEGM = @GNULIB_TIMEGM@
GNULIB_TIMESPEC_GET = @GNULIB_TIMESPEC_GET@
GNULIB_TIME_R = @GNULIB_TIME_R@
GNULIB_TIME_RZ = @GNULIB_TIME_RZ@
GNULIB_TMPFILE = @GNULIB_TMPFILE@
@ -746,6 +747,7 @@ HAVE_SYS_SELECT_H = @HAVE_SYS_SELECT_H@
HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@
HAVE_SYS_TYPES_H = @HAVE_SYS_TYPES_H@
HAVE_TIMEGM = @HAVE_TIMEGM@
HAVE_TIMESPEC_GET = @HAVE_TIMESPEC_GET@
HAVE_TIMEZONE_T = @HAVE_TIMEZONE_T@
HAVE_TYPE_VOLATILE_SIG_ATOMIC_T = @HAVE_TYPE_VOLATILE_SIG_ATOMIC_T@
HAVE_UNISTD_H = @HAVE_UNISTD_H@
@ -949,6 +951,7 @@ REPLACE_FCNTL = @REPLACE_FCNTL@
REPLACE_FDOPEN = @REPLACE_FDOPEN@
REPLACE_FDOPENDIR = @REPLACE_FDOPENDIR@
REPLACE_FFLUSH = @REPLACE_FFLUSH@
REPLACE_FFSLL = @REPLACE_FFSLL@
REPLACE_FOPEN = @REPLACE_FOPEN@
REPLACE_FPRINTF = @REPLACE_FPRINTF@
REPLACE_FPURGE = @REPLACE_FPURGE@
@ -989,7 +992,9 @@ REPLACE_MEMCHR = @REPLACE_MEMCHR@
REPLACE_MEMMEM = @REPLACE_MEMMEM@
REPLACE_MKDIR = @REPLACE_MKDIR@
REPLACE_MKFIFO = @REPLACE_MKFIFO@
REPLACE_MKFIFOAT = @REPLACE_MKFIFOAT@
REPLACE_MKNOD = @REPLACE_MKNOD@
REPLACE_MKNODAT = @REPLACE_MKNODAT@
REPLACE_MKSTEMP = @REPLACE_MKSTEMP@
REPLACE_MKTIME = @REPLACE_MKTIME@
REPLACE_NANOSLEEP = @REPLACE_NANOSLEEP@
@ -1087,6 +1092,7 @@ SYSTEM_TYPE = @SYSTEM_TYPE@
SYS_TIME_H_DEFINES_STRUCT_TIMESPEC = @SYS_TIME_H_DEFINES_STRUCT_TIMESPEC@
TERMCAP_OBJ = @TERMCAP_OBJ@
TIME_H_DEFINES_STRUCT_TIMESPEC = @TIME_H_DEFINES_STRUCT_TIMESPEC@
TIME_H_DEFINES_TIME_UTC = @TIME_H_DEFINES_TIME_UTC@
TOOLKIT_LIBW = @TOOLKIT_LIBW@
UINT32_MAX_LT_UINTMAX_MAX = @UINT32_MAX_LT_UINTMAX_MAX@
UINT64_MAX_EQ_ULONG_MAX = @UINT64_MAX_EQ_ULONG_MAX@
@ -1171,6 +1177,7 @@ gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1 = @gl_GNULIB_ENABLED_a9786850
gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36@
gl_GNULIB_ENABLED_cloexec = @gl_GNULIB_ENABLED_cloexec@
gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@
gl_GNULIB_ENABLED_dynarray = @gl_GNULIB_ENABLED_dynarray@
gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@
gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@
gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@
@ -1584,6 +1591,20 @@ EXTRA_libgnu_a_SOURCES += dup2.c
endif
## end gnulib module dup2
## begin gnulib module dynarray
ifeq (,$(OMIT_GNULIB_MODULE_dynarray))
ifneq (,$(gl_GNULIB_ENABLED_dynarray))
libgnu_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
endif
EXTRA_DIST += dynarray.h malloc/dynarray-skeleton.c malloc/dynarray.h
EXTRA_libgnu_a_SOURCES += malloc/dynarray-skeleton.c
endif
## end gnulib module dynarray
## begin gnulib module eloop-threshold
ifeq (,$(OMIT_GNULIB_MODULE_eloop-threshold))
@ -3036,6 +3057,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''HAVE_SIGDESCR_NP''@|$(HAVE_SIGDESCR_NP)|g' \
-e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \
-e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \
-e 's|@''REPLACE_FFSLL''@|$(REPLACE_FFSLL)|g' \
-e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \
-e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \
-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
-e 's|@''REPLACE_LSTAT''@|$(REPLACE_LSTAT)|g' \
-e 's|@''REPLACE_MKDIR''@|$(REPLACE_MKDIR)|g' \
-e 's|@''REPLACE_MKFIFO''@|$(REPLACE_MKFIFO)|g' \
-e 's|@''REPLACE_MKFIFOAT''@|$(REPLACE_MKFIFOAT)|g' \
-e 's|@''REPLACE_MKNOD''@|$(REPLACE_MKNOD)|g' \
-e 's|@''REPLACE_MKNODAT''@|$(REPLACE_MKNODAT)|g' \
-e 's|@''REPLACE_STAT''@|$(REPLACE_STAT)|g' \
-e 's|@''REPLACE_UTIMENSAT''@|$(REPLACE_UTIMENSAT)|g' \
-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) $(
-e 's/@''GNULIB_STRFTIME''@/$(GNULIB_STRFTIME)/g' \
-e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \
-e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \
-e 's/@''GNULIB_TIMESPEC_GET''@/$(GNULIB_TIMESPEC_GET)/g' \
-e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \
-e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \
-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) $(
-e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \
-e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \
-e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \
-e 's|@''HAVE_TIMESPEC_GET''@|$(HAVE_TIMESPEC_GET)|g' \
-e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \
-e 's|@''REPLACE_CTIME''@|$(REPLACE_CTIME)|g' \
-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) $(
-e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \
-e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \
-e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \
-e 's|@''TIME_H_DEFINES_TIME_UTC''@|$(TIME_H_DEFINES_TIME_UTC)|g' \
-e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
-e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \

171
lib/libc-config.h
View file

@ -71,107 +71,112 @@
# endif
#endif
/* Prepare to include <cdefs.h>, which is our copy of glibc
<sys/cdefs.h>. */
#ifndef __attribute_maybe_unused__
/* <sys/cdefs.h> either does not exist, or is too old for Gnulib.
Prepare to include <cdefs.h>, which is Gnulib's version of a
more-recent glibc <sys/cdefs.h>. */
/* Define _FEATURES_H so that <cdefs.h> does not include <features.h>. */
#ifndef _FEATURES_H
# define _FEATURES_H 1
#endif
# ifndef _FEATURES_H
# define _FEATURES_H 1
# endif
/* Define __WORDSIZE so that <cdefs.h> does not attempt to include
nonexistent files. Make it a syntax error, since Gnulib does not
use __WORDSIZE now, and if Gnulib uses it later the syntax error
will let us know that __WORDSIZE needs configuring. */
#ifndef __WORDSIZE
# define __WORDSIZE %%%
#endif
# ifndef __WORDSIZE
# define __WORDSIZE %%%
# endif
/* Undef the macros unconditionally defined by our copy of glibc
<sys/cdefs.h>, so that they do not clash with any system-defined
versions. */
#undef _SYS_CDEFS_H
#undef __ASMNAME
#undef __ASMNAME2
#undef __BEGIN_DECLS
#undef __CONCAT
#undef __END_DECLS
#undef __HAVE_GENERIC_SELECTION
#undef __LDBL_COMPAT
#undef __LDBL_REDIR
#undef __LDBL_REDIR1
#undef __LDBL_REDIR1_DECL
#undef __LDBL_REDIR1_NTH
#undef __LDBL_REDIR_DECL
#undef __LDBL_REDIR_NTH
#undef __LEAF
#undef __LEAF_ATTR
#undef __NTH
#undef __NTHNL
#undef __P
#undef __PMT
#undef __REDIRECT
#undef __REDIRECT_LDBL
#undef __REDIRECT_NTH
#undef __REDIRECT_NTHNL
#undef __REDIRECT_NTH_LDBL
#undef __STRING
#undef __THROW
#undef __THROWNL
#undef __always_inline
#undef __attribute__
#undef __attribute_alloc_size__
#undef __attribute_artificial__
#undef __attribute_const__
#undef __attribute_deprecated__
#undef __attribute_deprecated_msg__
#undef __attribute_format_arg__
#undef __attribute_format_strfmon__
#undef __attribute_malloc__
#undef __attribute_noinline__
#undef __attribute_nonstring__
#undef __attribute_pure__
#undef __attribute_used__
#undef __attribute_warn_unused_result__
#undef __bos
#undef __bos0
#undef __errordecl
#undef __extension__
#undef __extern_always_inline
#undef __extern_inline
#undef __flexarr
#undef __fortify_function
#undef __glibc_c99_flexarr_available
#undef __glibc_clang_has_extension
#undef __glibc_likely
#undef __glibc_macro_warning
#undef __glibc_macro_warning1
#undef __glibc_unlikely
#undef __inline
#undef __ptr_t
#undef __restrict
#undef __restrict_arr
#undef __va_arg_pack
#undef __va_arg_pack_len
#undef __warnattr
#undef __warndecl
# undef _SYS_CDEFS_H
# undef __ASMNAME
# undef __ASMNAME2
# undef __BEGIN_DECLS
# undef __CONCAT
# undef __END_DECLS
# undef __HAVE_GENERIC_SELECTION
# undef __LDBL_COMPAT
# undef __LDBL_REDIR
# undef __LDBL_REDIR1
# undef __LDBL_REDIR1_DECL
# undef __LDBL_REDIR1_NTH
# undef __LDBL_REDIR2_DECL
# undef __LDBL_REDIR_DECL
# undef __LDBL_REDIR_NTH
# undef __LEAF
# undef __LEAF_ATTR
# undef __NTH
# undef __NTHNL
# undef __REDIRECT
# undef __REDIRECT_LDBL
# undef __REDIRECT_NTH
# undef __REDIRECT_NTHNL
# undef __REDIRECT_NTH_LDBL
# undef __STRING
# undef __THROW
# undef __THROWNL
# undef __attr_access
# undef __attribute__
# undef __attribute_alloc_size__
# undef __attribute_artificial__
# undef __attribute_const__
# undef __attribute_deprecated__
# undef __attribute_deprecated_msg__
# undef __attribute_format_arg__
# undef __attribute_format_strfmon__
# undef __attribute_malloc__
# undef __attribute_noinline__
# undef __attribute_nonstring__
# undef __attribute_pure__
# undef __attribute_returns_twice__
# undef __attribute_used__
# undef __attribute_warn_unused_result__
# undef __bos
# undef __bos0
# undef __errordecl
# undef __extension__
# undef __extern_always_inline
# undef __extern_inline
# undef __flexarr
# undef __fortify_function
# undef __glibc_c99_flexarr_available
# undef __glibc_has_attribute
# undef __glibc_has_builtin
# undef __glibc_has_extension
# undef __glibc_macro_warning
# undef __glibc_macro_warning1
# undef __glibc_objsize
# undef __glibc_objsize0
# undef __glibc_unlikely
# undef __inline
# undef __ptr_t
# undef __restrict
# undef __restrict_arr
# undef __va_arg_pack
# undef __va_arg_pack_len
# undef __warnattr
/* Include our copy of glibc <sys/cdefs.h>. */
#include <cdefs.h>
# include <cdefs.h>
/* <cdefs.h> __inline is too pessimistic for non-GCC. */
#undef __inline
#ifndef HAVE___INLINE
# if 199901 <= __STDC_VERSION__ || defined inline
# define __inline inline
# else
# define __inline
# undef __inline
# ifndef HAVE___INLINE
# if 199901 <= __STDC_VERSION__ || defined inline
# define __inline inline
# else
# define __inline
# endif
# endif
#endif
#endif /* defined __glibc_likely */
/* A substitute for glibc <libc-symbols.h>, good enough for Gnulib. */
#define attribute_hidden
#define libc_hidden_proto(name, ...)
#define libc_hidden_proto(name)
#define libc_hidden_def(name)
#define libc_hidden_weak(name)
#define libc_hidden_ver(local, name)

525
lib/malloc/dynarray-skeleton.c Normal file
View file

@ -0,0 +1,525 @@
/* Type-safe arrays which grow dynamically.
Copyright (C) 2017-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public
License along with the GNU C Library; if not, see
<https://www.gnu.org/licenses/>. */
/* Pre-processor macros which act as parameters:
DYNARRAY_STRUCT
The struct tag of dynamic array to be defined.
DYNARRAY_ELEMENT
The type name of the element type. Elements are copied
as if by memcpy, and can change address as the dynamic
array grows.
DYNARRAY_PREFIX
The prefix of the functions which are defined.
The following parameters are optional:
DYNARRAY_ELEMENT_FREE
DYNARRAY_ELEMENT_FREE (E) is evaluated to deallocate the
contents of elements. E is of type DYNARRAY_ELEMENT *.
DYNARRAY_ELEMENT_INIT
DYNARRAY_ELEMENT_INIT (E) is evaluated to initialize a new
element. E is of type DYNARRAY_ELEMENT *.
If DYNARRAY_ELEMENT_FREE but not DYNARRAY_ELEMENT_INIT is
defined, new elements are automatically zero-initialized.
Otherwise, new elements have undefined contents.
DYNARRAY_INITIAL_SIZE
The size of the statically allocated array (default:
at least 2, more elements if they fit into 128 bytes).
Must be a preprocessor constant. If DYNARRAY_INITIAL_SIZE is 0,
there is no statically allocated array at, and all non-empty
arrays are heap-allocated.
DYNARRAY_FINAL_TYPE
The name of the type which holds the final array. If not
defined, is PREFIX##finalize not provided. DYNARRAY_FINAL_TYPE
must be a struct type, with members of type DYNARRAY_ELEMENT and
size_t at the start (in this order).
These macros are undefined after this header file has been
included.
The following types are provided (their members are private to the
dynarray implementation):
struct DYNARRAY_STRUCT
The following functions are provided:
void DYNARRAY_PREFIX##init (struct DYNARRAY_STRUCT *);
void DYNARRAY_PREFIX##free (struct DYNARRAY_STRUCT *);
bool DYNARRAY_PREFIX##has_failed (const struct DYNARRAY_STRUCT *);
void DYNARRAY_PREFIX##mark_failed (struct DYNARRAY_STRUCT *);
size_t DYNARRAY_PREFIX##size (const struct DYNARRAY_STRUCT *);
DYNARRAY_ELEMENT *DYNARRAY_PREFIX##begin (const struct DYNARRAY_STRUCT *);
DYNARRAY_ELEMENT *DYNARRAY_PREFIX##end (const struct DYNARRAY_STRUCT *);
DYNARRAY_ELEMENT *DYNARRAY_PREFIX##at (struct DYNARRAY_STRUCT *, size_t);
void DYNARRAY_PREFIX##add (struct DYNARRAY_STRUCT *, DYNARRAY_ELEMENT);
DYNARRAY_ELEMENT *DYNARRAY_PREFIX##emplace (struct DYNARRAY_STRUCT *);
bool DYNARRAY_PREFIX##resize (struct DYNARRAY_STRUCT *, size_t);
void DYNARRAY_PREFIX##remove_last (struct DYNARRAY_STRUCT *);
void DYNARRAY_PREFIX##clear (struct DYNARRAY_STRUCT *);
The following functions are provided are provided if the
prerequisites are met:
bool DYNARRAY_PREFIX##finalize (struct DYNARRAY_STRUCT *,
DYNARRAY_FINAL_TYPE *);
(if DYNARRAY_FINAL_TYPE is defined)
DYNARRAY_ELEMENT *DYNARRAY_PREFIX##finalize (struct DYNARRAY_STRUCT *,
size_t *);
(if DYNARRAY_FINAL_TYPE is not defined)
*/
#include <malloc/dynarray.h>
#include <errno.h>
#include <stdlib.h>
#include <string.h>
#ifndef DYNARRAY_STRUCT
# error "DYNARRAY_STRUCT must be defined"
#endif
#ifndef DYNARRAY_ELEMENT
# error "DYNARRAY_ELEMENT must be defined"
#endif
#ifndef DYNARRAY_PREFIX
# error "DYNARRAY_PREFIX must be defined"
#endif
#ifdef DYNARRAY_INITIAL_SIZE
# if DYNARRAY_INITIAL_SIZE < 0
# error "DYNARRAY_INITIAL_SIZE must be non-negative"
# endif
# if DYNARRAY_INITIAL_SIZE > 0
# define DYNARRAY_HAVE_SCRATCH 1
# else
# define DYNARRAY_HAVE_SCRATCH 0
# endif
#else
/* Provide a reasonable default which limits the size of
DYNARRAY_STRUCT. */
# define DYNARRAY_INITIAL_SIZE \
(sizeof (DYNARRAY_ELEMENT) > 64 ? 2 : 128 / sizeof (DYNARRAY_ELEMENT))
# define DYNARRAY_HAVE_SCRATCH 1
#endif
/* Public type definitions. */
/* All fields of this struct are private to the implementation. */
struct DYNARRAY_STRUCT
{
union
{
struct dynarray_header dynarray_abstract;
struct
{
/* These fields must match struct dynarray_header. */
size_t used;
size_t allocated;
DYNARRAY_ELEMENT *array;
} dynarray_header;
} u;
#if DYNARRAY_HAVE_SCRATCH
/* Initial inline allocation. */
DYNARRAY_ELEMENT scratch[DYNARRAY_INITIAL_SIZE];
#endif
};
/* Internal use only: Helper macros. */
/* Ensure macro-expansion of DYNARRAY_PREFIX. */
#define DYNARRAY_CONCAT0(prefix, name) prefix##name
#define DYNARRAY_CONCAT1(prefix, name) DYNARRAY_CONCAT0(prefix, name)
#define DYNARRAY_NAME(name) DYNARRAY_CONCAT1(DYNARRAY_PREFIX, name)
/* Use DYNARRAY_FREE instead of DYNARRAY_NAME (free),
so that Gnulib does not change 'free' to 'rpl_free'. */
#define DYNARRAY_FREE DYNARRAY_CONCAT1 (DYNARRAY_NAME (f), ree)
/* Address of the scratch buffer if any. */
#if DYNARRAY_HAVE_SCRATCH
# define DYNARRAY_SCRATCH(list) (list)->scratch
#else
# define DYNARRAY_SCRATCH(list) NULL
#endif
/* Internal use only: Helper functions. */
/* Internal function. Call DYNARRAY_ELEMENT_FREE with the array
elements. Name mangling needed due to the DYNARRAY_ELEMENT_FREE
macro expansion. */
static inline void
DYNARRAY_NAME (free__elements__) (DYNARRAY_ELEMENT *__dynarray_array,
size_t __dynarray_used)
{
#ifdef DYNARRAY_ELEMENT_FREE
for (size_t __dynarray_i = 0; __dynarray_i < __dynarray_used; ++__dynarray_i)
DYNARRAY_ELEMENT_FREE (&__dynarray_array[__dynarray_i]);
#endif /* DYNARRAY_ELEMENT_FREE */
}
/* Internal function. Free the non-scratch array allocation. */
static inline void
DYNARRAY_NAME (free__array__) (struct DYNARRAY_STRUCT *list)
{
#if DYNARRAY_HAVE_SCRATCH
if (list->u.dynarray_header.array != list->scratch)
free (list->u.dynarray_header.array);
#else
free (list->u.dynarray_header.array);
#endif
}
/* Public functions. */
/* Initialize a dynamic array object. This must be called before any
use of the object. */
__nonnull ((1))
static void
DYNARRAY_NAME (init) (struct DYNARRAY_STRUCT *list)
{
list->u.dynarray_header.used = 0;
list->u.dynarray_header.allocated = DYNARRAY_INITIAL_SIZE;
list->u.dynarray_header.array = DYNARRAY_SCRATCH (list);
}
/* Deallocate the dynamic array and its elements. */
__attribute_maybe_unused__ __nonnull ((1))
static void
DYNARRAY_FREE (struct DYNARRAY_STRUCT *list)
{
DYNARRAY_NAME (free__elements__)
(list->u.dynarray_header.array, list->u.dynarray_header.used);
DYNARRAY_NAME (free__array__) (list);
DYNARRAY_NAME (init) (list);
}
/* Return true if the dynamic array is in an error state. */
__nonnull ((1))
static inline bool
DYNARRAY_NAME (has_failed) (const struct DYNARRAY_STRUCT *list)
{
return list->u.dynarray_header.allocated == __dynarray_error_marker ();
}
/* Mark the dynamic array as failed. All elements are deallocated as
a side effect. */
__nonnull ((1))
static void
DYNARRAY_NAME (mark_failed) (struct DYNARRAY_STRUCT *list)
{
DYNARRAY_NAME (free__elements__)
(list->u.dynarray_header.array, list->u.dynarray_header.used);
DYNARRAY_NAME (free__array__) (list);
list->u.dynarray_header.array = DYNARRAY_SCRATCH (list);
list->u.dynarray_header.used = 0;
list->u.dynarray_header.allocated = __dynarray_error_marker ();
}
/* Return the number of elements which have been added to the dynamic
array. */
__nonnull ((1))
static inline size_t
DYNARRAY_NAME (size) (const struct DYNARRAY_STRUCT *list)
{
return list->u.dynarray_header.used;
}
/* Return a pointer to the array element at INDEX. Terminate the
process if INDEX is out of bounds. */
__nonnull ((1))
static inline DYNARRAY_ELEMENT *
DYNARRAY_NAME (at) (struct DYNARRAY_STRUCT *list, size_t index)
{
if (__glibc_unlikely (index >= DYNARRAY_NAME (size) (list)))
__libc_dynarray_at_failure (DYNARRAY_NAME (size) (list), index);
return list->u.dynarray_header.array + index;
}
/* Return a pointer to the first array element, if any. For a
zero-length array, the pointer can be NULL even though the dynamic
array has not entered the failure state. */
__nonnull ((1))
static inline DYNARRAY_ELEMENT *
DYNARRAY_NAME (begin) (struct DYNARRAY_STRUCT *list)
{
return list->u.dynarray_header.array;
}
/* Return a pointer one element past the last array element. For a
zero-length array, the pointer can be NULL even though the dynamic
array has not entered the failure state. */
__nonnull ((1))
static inline DYNARRAY_ELEMENT *
DYNARRAY_NAME (end) (struct DYNARRAY_STRUCT *list)
{
return list->u.dynarray_header.array + list->u.dynarray_header.used;
}
/* Internal function. Slow path for the add function below. */
static void
DYNARRAY_NAME (add__) (struct DYNARRAY_STRUCT *list, DYNARRAY_ELEMENT item)
{
if (__glibc_unlikely
(!__libc_dynarray_emplace_enlarge (&list->u.dynarray_abstract,
DYNARRAY_SCRATCH (list),
sizeof (DYNARRAY_ELEMENT))))
{
DYNARRAY_NAME (mark_failed) (list);
return;
}
/* Copy the new element and increase the array length. */
list->u.dynarray_header.array[list->u.dynarray_header.used++] = item;
}
/* Add ITEM at the end of the array, enlarging it by one element.
Mark *LIST as failed if the dynamic array allocation size cannot be
increased. */
__nonnull ((1))
static inline void
DYNARRAY_NAME (add) (struct DYNARRAY_STRUCT *list, DYNARRAY_ELEMENT item)
{
/* Do nothing in case of previous error. */
if (DYNARRAY_NAME (has_failed) (list))
return;
/* Enlarge the array if necessary. */
if (__glibc_unlikely (list->u.dynarray_header.used
== list->u.dynarray_header.allocated))
{
DYNARRAY_NAME (add__) (list, item);
return;
}
/* Copy the new element and increase the array length. */
list->u.dynarray_header.array[list->u.dynarray_header.used++] = item;
}
/* Internal function. Building block for the emplace functions below.
Assumes space for one more element in *LIST. */
static inline DYNARRAY_ELEMENT *
DYNARRAY_NAME (emplace__tail__) (struct DYNARRAY_STRUCT *list)
{
DYNARRAY_ELEMENT *result
= &list->u.dynarray_header.array[list->u.dynarray_header.used];
++list->u.dynarray_header.used;
#if defined (DYNARRAY_ELEMENT_INIT)
DYNARRAY_ELEMENT_INIT (result);
#elif defined (DYNARRAY_ELEMENT_FREE)
memset (result, 0, sizeof (*result));
#endif
return result;
}
/* Internal function. Slow path for the emplace function below. */
static DYNARRAY_ELEMENT *
DYNARRAY_NAME (emplace__) (struct DYNARRAY_STRUCT *list)
{
if (__glibc_unlikely
(!__libc_dynarray_emplace_enlarge (&list->u.dynarray_abstract,
DYNARRAY_SCRATCH (list),
sizeof (DYNARRAY_ELEMENT))))
{
DYNARRAY_NAME (mark_failed) (list);
return NULL;
}
return DYNARRAY_NAME (emplace__tail__) (list);
}
/* Allocate a place for a new element in *LIST and return a pointer to
it. The pointer can be NULL if the dynamic array cannot be
enlarged due to a memory allocation failure. */
__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1))
static
/* Avoid inlining with the larger initialization code. */
#if !(defined (DYNARRAY_ELEMENT_INIT) || defined (DYNARRAY_ELEMENT_FREE))
inline
#endif
DYNARRAY_ELEMENT *
DYNARRAY_NAME (emplace) (struct DYNARRAY_STRUCT *list)
{
/* Do nothing in case of previous error. */
if (DYNARRAY_NAME (has_failed) (list))
return NULL;
/* Enlarge the array if necessary. */
if (__glibc_unlikely (list->u.dynarray_header.used
== list->u.dynarray_header.allocated))
return (DYNARRAY_NAME (emplace__) (list));
return DYNARRAY_NAME (emplace__tail__) (list);
}
/* Change the size of *LIST to SIZE. If SIZE is larger than the
existing size, new elements are added (which can be initialized).
Otherwise, the list is truncated, and elements are freed. Return
false on memory allocation failure (and mark *LIST as failed). */
__attribute_maybe_unused__ __nonnull ((1))
static bool
DYNARRAY_NAME (resize) (struct DYNARRAY_STRUCT *list, size_t size)
{
if (size > list->u.dynarray_header.used)
{
bool ok;
#if defined (DYNARRAY_ELEMENT_INIT)
/* The new elements have to be initialized. */
size_t old_size = list->u.dynarray_header.used;
ok = __libc_dynarray_resize (&list->u.dynarray_abstract,
size, DYNARRAY_SCRATCH (list),
sizeof (DYNARRAY_ELEMENT));
if (ok)
for (size_t i = old_size; i < size; ++i)
{
DYNARRAY_ELEMENT_INIT (&list->u.dynarray_header.array[i]);
}
#elif defined (DYNARRAY_ELEMENT_FREE)
/* Zero initialization is needed so that the elements can be
safely freed. */
ok = __libc_dynarray_resize_clear
(&list->u.dynarray_abstract, size,
DYNARRAY_SCRATCH (list), sizeof (DYNARRAY_ELEMENT));
#else
ok = __libc_dynarray_resize (&list->u.dynarray_abstract,
size, DYNARRAY_SCRATCH (list),
sizeof (DYNARRAY_ELEMENT));
#endif
if (__glibc_unlikely (!ok))
DYNARRAY_NAME (mark_failed) (list);
return ok;
}
else
{
/* The list has shrunk in size. Free the removed elements. */
DYNARRAY_NAME (free__elements__)
(list->u.dynarray_header.array + size,
list->u.dynarray_header.used - size);
list->u.dynarray_header.used = size;
return true;
}
}
/* Remove the last element of LIST if it is present. */
__attribute_maybe_unused__ __nonnull ((1))
static void
DYNARRAY_NAME (remove_last) (struct DYNARRAY_STRUCT *list)
{
/* used > 0 implies that the array is the non-failed state. */
if (list->u.dynarray_header.used > 0)
{
size_t new_length = list->u.dynarray_header.used - 1;
#ifdef DYNARRAY_ELEMENT_FREE
DYNARRAY_ELEMENT_FREE (&list->u.dynarray_header.array[new_length]);
#endif
list->u.dynarray_header.used = new_length;
}
}
/* Remove all elements from the list. The elements are freed, but the
list itself is not. */
__attribute_maybe_unused__ __nonnull ((1))
static void
DYNARRAY_NAME (clear) (struct DYNARRAY_STRUCT *list)
{
/* free__elements__ does nothing if the list is in the failed
state. */
DYNARRAY_NAME (free__elements__)
(list->u.dynarray_header.array, list->u.dynarray_header.used);
list->u.dynarray_header.used = 0;
}
#ifdef DYNARRAY_FINAL_TYPE
/* Transfer the dynamic array to a permanent location at *RESULT.
Returns true on success on false on allocation failure. In either
case, *LIST is re-initialized and can be reused. A NULL pointer is
stored in *RESULT if LIST refers to an empty list. On success, the
pointer in *RESULT is heap-allocated and must be deallocated using
free. */
__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1, 2))
static bool
DYNARRAY_NAME (finalize) (struct DYNARRAY_STRUCT *list,
DYNARRAY_FINAL_TYPE *result)
{
struct dynarray_finalize_result res;
if (__libc_dynarray_finalize (&list->u.dynarray_abstract,
DYNARRAY_SCRATCH (list),
sizeof (DYNARRAY_ELEMENT), &res))
{
/* On success, the result owns all the data. */
DYNARRAY_NAME (init) (list);
*result = (DYNARRAY_FINAL_TYPE) { res.array, res.length };
return true;
}
else
{
/* On error, we need to free all data. */
DYNARRAY_FREE (list);
errno = ENOMEM;
return false;
}
}
#else /* !DYNARRAY_FINAL_TYPE */
/* Transfer the dynamic array to a heap-allocated array and return a
pointer to it. The pointer is NULL if memory allocation fails, or
if the array is empty, so this function should be used only for
arrays which are known not be empty (usually because they always
have a sentinel at the end). If LENGTHP is not NULL, the array
length is written to *LENGTHP. *LIST is re-initialized and can be
reused. */
__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1))
static DYNARRAY_ELEMENT *
DYNARRAY_NAME (finalize) (struct DYNARRAY_STRUCT *list, size_t *lengthp)
{
struct dynarray_finalize_result res;
if (__libc_dynarray_finalize (&list->u.dynarray_abstract,
DYNARRAY_SCRATCH (list),
sizeof (DYNARRAY_ELEMENT), &res))
{
/* On success, the result owns all the data. */
DYNARRAY_NAME (init) (list);
if (lengthp != NULL)
*lengthp = res.length;
return res.array;
}
else
{
/* On error, we need to free all data. */
DYNARRAY_FREE (list);
errno = ENOMEM;
return NULL;
}
}
#endif /* !DYNARRAY_FINAL_TYPE */
/* Undo macro definitions. */
#undef DYNARRAY_CONCAT0
#undef DYNARRAY_CONCAT1
#undef DYNARRAY_NAME
#undef DYNARRAY_SCRATCH
#undef DYNARRAY_HAVE_SCRATCH
#undef DYNARRAY_STRUCT
#undef DYNARRAY_ELEMENT
#undef DYNARRAY_PREFIX
#undef DYNARRAY_ELEMENT_FREE
#undef DYNARRAY_ELEMENT_INIT
#undef DYNARRAY_INITIAL_SIZE
#undef DYNARRAY_FINAL_TYPE

178
lib/malloc/dynarray.h Normal file
View file

@ -0,0 +1,178 @@
/* Type-safe arrays which grow dynamically. Shared definitions.
Copyright (C) 2017-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public
License along with the GNU C Library; if not, see
<https://www.gnu.org/licenses/>. */
/* To use the dynarray facility, you need to include
<malloc/dynarray-skeleton.c> and define the parameter macros
documented in that file.
A minimal example which provides a growing list of integers can be
defined like this:
struct int_array
{
// Pointer to result array followed by its length,
// as required by DYNARRAY_FINAL_TYPE.
int *array;
size_t length;
};
#define DYNARRAY_STRUCT dynarray_int
#define DYNARRAY_ELEMENT int
#define DYNARRAY_PREFIX dynarray_int_
#define DYNARRAY_FINAL_TYPE struct int_array
#include <malloc/dynarray-skeleton.c>
To create a three-element array with elements 1, 2, 3, use this
code:
struct dynarray_int dyn;
dynarray_int_init (&dyn);
for (int i = 1; i <= 3; ++i)
{
int *place = dynarray_int_emplace (&dyn);
assert (place != NULL);
*place = i;
}
struct int_array result;
bool ok = dynarray_int_finalize (&dyn, &result);
assert (ok);
assert (result.length == 3);
assert (result.array[0] == 1);
assert (result.array[1] == 2);
assert (result.array[2] == 3);
free (result.array);
If the elements contain resources which must be freed, define
DYNARRAY_ELEMENT_FREE appropriately, like this:
struct str_array
{
char **array;
size_t length;
};
#define DYNARRAY_STRUCT dynarray_str
#define DYNARRAY_ELEMENT char *
#define DYNARRAY_ELEMENT_FREE(ptr) free (*ptr)
#define DYNARRAY_PREFIX dynarray_str_
#define DYNARRAY_FINAL_TYPE struct str_array
#include <malloc/dynarray-skeleton.c>
Compared to scratch buffers, dynamic arrays have the following
features:
- They have an element type, and are not just an untyped buffer of
bytes.
- When growing, previously stored elements are preserved. (It is
expected that scratch_buffer_grow_preserve and
scratch_buffer_set_array_size eventually go away because all
current users are moved to dynamic arrays.)
- Scratch buffers have a more aggressive growth policy because
growing them typically means a retry of an operation (across an
NSS service module boundary), which is expensive.
- For the same reason, scratch buffers have a much larger initial
stack allocation. */
#ifndef _DYNARRAY_H
#define _DYNARRAY_H
#include <stdbool.h>
#include <stddef.h>
#include <string.h>
struct dynarray_header
{
size_t used;
size_t allocated;
void *array;
};
/* Marker used in the allocated member to indicate that an error was
encountered. */
static inline size_t
__dynarray_error_marker (void)
{
return -1;
}
/* Internal function. See the has_failed function in
dynarray-skeleton.c. */
static inline bool
__dynarray_error (struct dynarray_header *list)
{
return list->allocated == __dynarray_error_marker ();
}
/* Internal function. Enlarge the dynamically allocated area of the
array to make room for one more element. SCRATCH is a pointer to
the scratch area (which is not heap-allocated and must not be
freed). ELEMENT_SIZE is the size, in bytes, of one element.
Return false on failure, true on success. */
bool __libc_dynarray_emplace_enlarge (struct dynarray_header *,
void *scratch, size_t element_size);
/* Internal function. Enlarge the dynamically allocated area of the
array to make room for at least SIZE elements (which must be larger
than the existing used part of the dynamic array). SCRATCH is a
pointer to the scratch area (which is not heap-allocated and must
not be freed). ELEMENT_SIZE is the size, in bytes, of one element.
Return false on failure, true on success. */
bool __libc_dynarray_resize (struct dynarray_header *, size_t size,
void *scratch, size_t element_size);
/* Internal function. Like __libc_dynarray_resize, but clear the new
part of the dynamic array. */
bool __libc_dynarray_resize_clear (struct dynarray_header *, size_t size,
void *scratch, size_t element_size);
/* Internal type. */
struct dynarray_finalize_result
{
void *array;
size_t length;
};
/* Internal function. Copy the dynamically-allocated area to an
explicitly-sized heap allocation. SCRATCH is a pointer to the
embedded scratch space. ELEMENT_SIZE is the size, in bytes, of the
element type. On success, true is returned, and pointer and length
are written to *RESULT. On failure, false is returned. The caller
has to take care of some of the memory management; this function is
expected to be called from dynarray-skeleton.c. */
bool __libc_dynarray_finalize (struct dynarray_header *list, void *scratch,
size_t element_size,
struct dynarray_finalize_result *result);
/* Internal function. Terminate the process after an index error.
SIZE is the number of elements of the dynamic array. INDEX is the
lookup index which triggered the failure. */
_Noreturn void __libc_dynarray_at_failure (size_t size, size_t index);
#ifndef _ISOMAC
libc_hidden_proto (__libc_dynarray_emplace_enlarge)
libc_hidden_proto (__libc_dynarray_resize)
libc_hidden_proto (__libc_dynarray_resize_clear)
libc_hidden_proto (__libc_dynarray_finalize)
libc_hidden_proto (__libc_dynarray_at_failure)
#endif
#endif /* _DYNARRAY_H */

35
lib/malloc/dynarray_at_failure.c Normal file
View file

@ -0,0 +1,35 @@
/* Report an dynamic array index out of bounds condition.
Copyright (C) 2017-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public
License along with the GNU C Library; if not, see
<https://www.gnu.org/licenses/>. */
#include <dynarray.h>
#include <stdio.h>
#include <stdlib.h>
void
__libc_dynarray_at_failure (size_t size, size_t index)
{
#ifdef _LIBC
char buf[200];
__snprintf (buf, sizeof (buf), "Fatal glibc error: "
"array index %zu not less than array length %zu\n",
index, size);
#else
abort ();
#endif
}
libc_hidden_def (__libc_dynarray_at_failure)

73
lib/malloc/dynarray_emplace_enlarge.c Normal file
View file

@ -0,0 +1,73 @@
/* Increase the size of a dynamic array in preparation of an emplace operation.
Copyright (C) 2017-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public
License along with the GNU C Library; if not, see
<https://www.gnu.org/licenses/>. */
#include <dynarray.h>
#include <errno.h>
#include <intprops.h>
#include <stdlib.h>
#include <string.h>
bool
__libc_dynarray_emplace_enlarge (struct dynarray_header *list,
void *scratch, size_t element_size)
{
size_t new_allocated;
if (list->allocated == 0)
{
/* No scratch buffer provided. Choose a reasonable default
size. */
if (element_size < 4)
new_allocated = 16;
else if (element_size < 8)
new_allocated = 8;
else
new_allocated = 4;
}
else
/* Increase the allocated size, using an exponential growth
policy. */
{
new_allocated = list->allocated + list->allocated / 2 + 1;
if (new_allocated <= list->allocated)
{
/* Overflow. */
__set_errno (ENOMEM);
return false;
}
}
size_t new_size;
if (INT_MULTIPLY_WRAPV (new_allocated, element_size, &new_size))
return false;
void *new_array;
if (list->array == scratch)
{
/* The previous array was not heap-allocated. */
new_array = malloc (new_size);
if (new_array != NULL && list->array != NULL)
memcpy (new_array, list->array, list->used * element_size);
}
else
new_array = realloc (list->array, new_size);
if (new_array == NULL)
return false;
list->array = new_array;
list->allocated = new_allocated;
return true;
}
libc_hidden_def (__libc_dynarray_emplace_enlarge)

62
lib/malloc/dynarray_finalize.c Normal file
View file

@ -0,0 +1,62 @@
/* Copy the dynamically-allocated area to an explicitly-sized heap allocation.
Copyright (C) 2017-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public
License along with the GNU C Library; if not, see
<https://www.gnu.org/licenses/>. */
#include <dynarray.h>
#include <stdlib.h>
#include <string.h>
bool
__libc_dynarray_finalize (struct dynarray_header *list,
void *scratch, size_t element_size,
struct dynarray_finalize_result *result)
{
if (__dynarray_error (list))
/* The caller will reported the deferred error. */
return false;
size_t used = list->used;
/* Empty list. */
if (used == 0)
{
/* An empty list could still be backed by a heap-allocated
array. Free it if necessary. */
if (list->array != scratch)
free (list->array);
*result = (struct dynarray_finalize_result) { NULL, 0 };
return true;
}
size_t allocation_size = used * element_size;
void *heap_array = malloc (allocation_size);
if (heap_array != NULL)
{
/* The new array takes ownership of the strings. */
if (list->array != NULL)
memcpy (heap_array, list->array, allocation_size);
if (list->array != scratch)
free (list->array);
*result = (struct dynarray_finalize_result)
{ .array = heap_array, .length = used };
return true;
}
else
/* The caller will perform the freeing operation. */
return false;
}
libc_hidden_def (__libc_dynarray_finalize)

64
lib/malloc/dynarray_resize.c Normal file
View file

@ -0,0 +1,64 @@
/* Increase the size of a dynamic array.
Copyright (C) 2017-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public
License along with the GNU C Library; if not, see
<https://www.gnu.org/licenses/>. */
#include <dynarray.h>
#include <errno.h>
#include <intprops.h>
#include <stdlib.h>
#include <string.h>
bool
__libc_dynarray_resize (struct dynarray_header *list, size_t size,
void *scratch, size_t element_size)
{
/* The existing allocation provides sufficient room. */
if (size <= list->allocated)
{
list->used = size;
return true;
}
/* Otherwise, use size as the new allocation size. The caller is
expected to provide the final size of the array, so there is no
over-allocation here. */
size_t new_size_bytes;
if (INT_MULTIPLY_WRAPV (size, element_size, &new_size_bytes))
{
/* Overflow. */
__set_errno (ENOMEM);
return false;
}
void *new_array;
if (list->array == scratch)
{
/* The previous array was not heap-allocated. */
new_array = malloc (new_size_bytes);
if (new_array != NULL && list->array != NULL)
memcpy (new_array, list->array, list->used * element_size);
}
else
new_array = realloc (list->array, new_size_bytes);
if (new_array == NULL)
return false;
list->array = new_array;
list->allocated = size;
list->used = size;
return true;
}
libc_hidden_def (__libc_dynarray_resize)

35
lib/malloc/dynarray_resize_clear.c Normal file
View file

@ -0,0 +1,35 @@
/* Increase the size of a dynamic array and clear the new part.
Copyright (C) 2017-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public
License along with the GNU C Library; if not, see
<https://www.gnu.org/licenses/>. */
#include <dynarray.h>
#include <string.h>
bool
__libc_dynarray_resize_clear (struct dynarray_header *list, size_t size,
void *scratch, size_t element_size)
{
size_t old_size = list->used;
if (!__libc_dynarray_resize (list, size, scratch, element_size))
return false;
/* __libc_dynarray_resize already checked for overflow. */
char *array = list->array;
memset (array + (old_size * element_size), 0,
(size - old_size) * element_size);
return true;
}
libc_hidden_def (__libc_dynarray_resize_clear)

2
lib/malloc/scratch_buffer_grow.c
View file

@ -1,5 +1,5 @@
/* Variable-sized buffer with on-stack default allocation.
Copyright (C) 2015-2020 Free Software Foundation, Inc.
Copyright (C) 2015-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or

2
lib/malloc/scratch_buffer_grow_preserve.c
View file

@ -1,5 +1,5 @@
/* Variable-sized buffer with on-stack default allocation.
Copyright (C) 2015-2020 Free Software Foundation, Inc.
Copyright (C) 2015-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or

2
lib/malloc/scratch_buffer_set_array_size.c
View file

@ -1,5 +1,5 @@
/* Variable-sized buffer with on-stack default allocation.
Copyright (C) 2015-2020 Free Software Foundation, Inc.
Copyright (C) 2015-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or

2
lib/mini-gmp.c
View file

@ -4521,7 +4521,7 @@ mpz_export (void *r, size_t *countp, int order, size_t size, int endian,
mp_size_t un;
if (nails != 0)
gmp_die ("mpz_import: Nails not supported.");
gmp_die ("mpz_export: Nails not supported.");
assert (order == 1 || order == -1);
assert (endian >= -1 && endian <= 1);

2
lib/mktime-internal.h
View file

@ -1,5 +1,5 @@
/* Internals of mktime and related functions
Copyright 2016-2020 Free Software Foundation, Inc.
Copyright 2016-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Paul Eggert <eggert@cs.ucla.edu>.

6
lib/nstrftime.c
View file

@ -19,7 +19,7 @@
# define USE_IN_EXTENDED_LOCALE_MODEL 1
# define HAVE_STRUCT_ERA_ENTRY 1
# define HAVE_TM_GMTOFF 1
# define HAVE_TM_ZONE 1
# define HAVE_STRUCT_TM_TM_ZONE 1
# define HAVE_TZNAME 1
# include "../locale/localeinfo.h"
#else
@ -499,7 +499,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
#endif
zone = NULL;
#if HAVE_TM_ZONE
#if HAVE_STRUCT_TM_TM_ZONE
/* The POSIX test suite assumes that setting
the environment variable TZ to a new value before calling strftime()
will influence the result (the %Z format) even if the information in
@ -516,7 +516,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
}
else
{
# if !HAVE_TM_ZONE
# if !HAVE_STRUCT_TM_TM_ZONE
/* Infer the zone name from *TZ instead of from TZNAME. */
tzname_vec = tz->tzname_copy;
# endif

2
lib/regex.c
View file

@ -1,5 +1,5 @@
/* Extended regular expression matching and search library.
Copyright (C) 2002-2020 Free Software Foundation, Inc.
Copyright (C) 2002-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.

26
lib/regex_internal.h
View file

@ -32,6 +32,7 @@
#include <stdbool.h>
#include <stdint.h>
#include <dynarray.h>
#include <intprops.h>
#include <verify.h>
@ -444,25 +445,6 @@ typedef struct re_dfa_t re_dfa_t;
#define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx))
#define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx))
#if defined _LIBC || HAVE_ALLOCA
# include <alloca.h>
#endif
#ifndef _LIBC
# if HAVE_ALLOCA
/* The OS usually guarantees only one guard page at the bottom of the stack,
and a page size can be as small as 4096 bytes. So we cannot safely
allocate anything larger than 4096 bytes. Also care for the possibility
of a few compiler-allocated temporary stack slots. */
# define __libc_use_alloca(n) ((n) < 4032)
# else
/* alloca is implemented with malloc, so just use malloc. */
# define __libc_use_alloca(n) 0
# undef alloca
# define alloca(n) malloc (n)
# endif
#endif
#ifdef _LIBC
# define MALLOC_0_IS_NONNULL 1
#elif !defined MALLOC_0_IS_NONNULL
@ -848,12 +830,14 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx)
}
#endif /* RE_ENABLE_I18N */
#ifndef FALLTHROUGH
# if (__GNUC__ >= 7) || (__clang_major__ >= 10)
#ifdef _LIBC
# if __GNUC__ >= 7
# define FALLTHROUGH __attribute__ ((__fallthrough__))
# else
# define FALLTHROUGH ((void) 0)
# endif
#else
# include "attribute.h"
#endif
#endif /* _REGEX_INTERNAL_H */

117
lib/regexec.c
View file

@ -1,5 +1,5 @@
/* Extended regular expression matching and search library.
Copyright (C) 2002-2020 Free Software Foundation, Inc.
Copyright (C) 2002-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.
@ -1355,6 +1355,12 @@ pop_fail_stack (struct re_fail_stack_t *fs, Idx *pidx, Idx nregs,
return fs->stack[num].node;
}
#define DYNARRAY_STRUCT regmatch_list
#define DYNARRAY_ELEMENT regmatch_t
#define DYNARRAY_PREFIX regmatch_list_
#include <malloc/dynarray-skeleton.c>
/* Set the positions where the subexpressions are starts/ends to registers
PMATCH.
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,
re_node_set eps_via_nodes;
struct re_fail_stack_t *fs;
struct re_fail_stack_t fs_body = { 0, 2, NULL };
regmatch_t *prev_idx_match;
bool prev_idx_match_malloced = false;
struct regmatch_list prev_match;
regmatch_list_init (&prev_match);
DEBUG_ASSERT (nmatch > 1);
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,
cur_node = dfa->init_node;
re_node_set_init_empty (&eps_via_nodes);
if (__libc_use_alloca (nmatch * sizeof (regmatch_t)))
prev_idx_match = (regmatch_t *) alloca (nmatch * sizeof (regmatch_t));
else
if (!regmatch_list_resize (&prev_match, nmatch))
{
prev_idx_match = re_malloc (regmatch_t, nmatch);
if (prev_idx_match == NULL)
{
free_fail_stack_return (fs);
return REG_ESPACE;
}
prev_idx_match_malloced = true;
regmatch_list_free (&prev_match);
free_fail_stack_return (fs);
return REG_ESPACE;
}
regmatch_t *prev_idx_match = regmatch_list_begin (&prev_match);
memcpy (prev_idx_match, pmatch, sizeof (regmatch_t) * nmatch);
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,
if (reg_idx == nmatch)
{
re_node_set_free (&eps_via_nodes);
if (prev_idx_match_malloced)
re_free (prev_idx_match);
regmatch_list_free (&prev_match);
return free_fail_stack_return (fs);
}
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,
else
{
re_node_set_free (&eps_via_nodes);
if (prev_idx_match_malloced)
re_free (prev_idx_match);
regmatch_list_free (&prev_match);
return REG_NOERROR;
}
}
@ -1442,8 +1441,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
if (__glibc_unlikely (cur_node == -2))
{
re_node_set_free (&eps_via_nodes);
if (prev_idx_match_malloced)
re_free (prev_idx_match);
regmatch_list_free (&prev_match);
free_fail_stack_return (fs);
return REG_ESPACE;
}
@ -1453,15 +1451,13 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
else
{
re_node_set_free (&eps_via_nodes);
if (prev_idx_match_malloced)
re_free (prev_idx_match);
regmatch_list_free (&prev_match);
return REG_NOMATCH;
}
}
}
re_node_set_free (&eps_via_nodes);
if (prev_idx_match_malloced)
re_free (prev_idx_match);
regmatch_list_free (&prev_match);
return free_fail_stack_return (fs);
}
@ -3251,7 +3247,7 @@ expand_bkref_cache (re_match_context_t *mctx, re_node_set *cur_nodes,
/* Build transition table for the state.
Return true if successful. */
static bool
static bool __attribute_noinline__
build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
{
reg_errcode_t err;
@ -3259,36 +3255,20 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
int ch;
bool need_word_trtable = false;
bitset_word_t elem, mask;
bool dests_node_malloced = false;
bool dest_states_malloced = false;
Idx ndests; /* Number of the destination states from 'state'. */
re_dfastate_t **trtable;
re_dfastate_t **dest_states = NULL, **dest_states_word, **dest_states_nl;
re_node_set follows, *dests_node;
bitset_t *dests_ch;
re_dfastate_t *dest_states[SBC_MAX];
re_dfastate_t *dest_states_word[SBC_MAX];
re_dfastate_t *dest_states_nl[SBC_MAX];
re_node_set follows;
bitset_t acceptable;
struct dests_alloc
{
re_node_set dests_node[SBC_MAX];
bitset_t dests_ch[SBC_MAX];
} *dests_alloc;
/* We build DFA states which corresponds to the destination nodes
from 'state'. 'dests_node[i]' represents the nodes which i-th
destination state contains, and 'dests_ch[i]' represents the
characters which i-th destination state accepts. */
if (__libc_use_alloca (sizeof (struct dests_alloc)))
dests_alloc = (struct dests_alloc *) alloca (sizeof (struct dests_alloc));
else
{
dests_alloc = re_malloc (struct dests_alloc, 1);
if (__glibc_unlikely (dests_alloc == NULL))
return false;
dests_node_malloced = true;
}
dests_node = dests_alloc->dests_node;
dests_ch = dests_alloc->dests_ch;
re_node_set dests_node[SBC_MAX];
bitset_t dests_ch[SBC_MAX];
/* Initialize transition table. */
state->word_trtable = state->trtable = NULL;
@ -3298,8 +3278,6 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
ndests = group_nodes_into_DFAstates (dfa, state, dests_node, dests_ch);
if (__glibc_unlikely (ndests <= 0))
{
if (dests_node_malloced)
re_free (dests_alloc);
/* Return false in case of an error, true otherwise. */
if (ndests == 0)
{
@ -3314,38 +3292,14 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
err = re_node_set_alloc (&follows, ndests + 1);
if (__glibc_unlikely (err != REG_NOERROR))
goto out_free;
/* Avoid arithmetic overflow in size calculation. */
size_t ndests_max
= ((SIZE_MAX - (sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX)
/ (3 * sizeof (re_dfastate_t *)));
if (__glibc_unlikely (ndests_max < ndests))
goto out_free;
if (__libc_use_alloca ((sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX
+ ndests * 3 * sizeof (re_dfastate_t *)))
dest_states = (re_dfastate_t **)
alloca (ndests * 3 * sizeof (re_dfastate_t *));
else
{
dest_states = re_malloc (re_dfastate_t *, ndests * 3);
if (__glibc_unlikely (dest_states == NULL))
{
out_free:
if (dest_states_malloced)
re_free (dest_states);
re_node_set_free (&follows);
for (i = 0; i < ndests; ++i)
re_node_set_free (dests_node + i);
if (dests_node_malloced)
re_free (dests_alloc);
return false;
}
dest_states_malloced = true;
out_free:
re_node_set_free (&follows);
for (i = 0; i < ndests; ++i)
re_node_set_free (dests_node + i);
return false;
}
dest_states_word = dest_states + ndests;
dest_states_nl = dest_states_word + ndests;
bitset_empty (acceptable);
/* Then build the states for all destinations. */
@ -3470,16 +3424,9 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
}
}
if (dest_states_malloced)
re_free (dest_states);
re_node_set_free (&follows);
for (i = 0; i < ndests; ++i)
re_node_set_free (dests_node + i);
if (dests_node_malloced)
re_free (dests_alloc);
return true;
}

1
lib/scratch_buffer.h
View file

@ -21,6 +21,7 @@
#include <libc-config.h>
#define __libc_scratch_buffer_dupfree gl_scratch_buffer_dupfree
#define __libc_scratch_buffer_grow gl_scratch_buffer_grow
#define __libc_scratch_buffer_grow_preserve gl_scratch_buffer_grow_preserve
#define __libc_scratch_buffer_set_array_size gl_scratch_buffer_set_array_size

23
lib/stddef.in.h
View file

@ -49,6 +49,23 @@
# ifndef _@GUARD_PREFIX@_STDDEF_H
/* On AIX 7.2, with xlc in 64-bit mode, <stddef.h> defines max_align_t to a
type with alignment 4, but 'long' has alignment 8. */
# if defined _AIX && defined _ARCH_PPC64
# if !GNULIB_defined_max_align_t
# ifdef _MAX_ALIGN_T
/* /usr/include/stddef.h has already defined max_align_t. Override it. */
typedef long rpl_max_align_t;
# define max_align_t rpl_max_align_t
# else
/* Prevent /usr/include/stddef.h from defining max_align_t. */
typedef long max_align_t;
# define _MAX_ALIGN_T
# endif
# define GNULIB_defined_max_align_t 1
# endif
# endif
/* The include_next requires a split double-inclusion guard. */
# @INCLUDE_NEXT@ @NEXT_STDDEF_H@
@ -86,8 +103,10 @@
we are currently compiling with gcc.
On MSVC, max_align_t is defined only in C++ mode, after <cstddef> was
included. Its definition is good since it has an alignment of 8 (on x86
and x86_64). */
#if defined _MSC_VER && defined __cplusplus
and x86_64).
Similarly on OS/2 kLIBC. */
#if (defined _MSC_VER || (defined __KLIBC__ && !defined __LIBCN__)) \
&& defined __cplusplus
# include <cstddef>
#else
# if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T)

20
lib/string.in.h
View file

@ -69,6 +69,14 @@
# include <unistd.h>
#endif
/* AIX 7.2 declares ffsl and ffsll in <strings.h>, not in <string.h>. */
/* But in any case avoid namespace pollution on glibc systems. */
#if ((@GNULIB_FFSL@ || @GNULIB_FFSLL@ || defined GNULIB_POSIXCHECK) \
&& defined _AIX) \
&& ! defined __GLIBC__
# include <strings.h>
#endif
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* 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");
/* Find the index of the least-significant set bit. */
#if @GNULIB_FFSLL@
# if !@HAVE_FFSLL@
# if @REPLACE_FFSLL@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# define ffsll rpl_ffsll
# endif
_GL_FUNCDECL_RPL (ffsll, int, (long long int i));
_GL_CXXALIAS_RPL (ffsll, int, (long long int i));
# else
# if !@HAVE_FFSLL@
_GL_FUNCDECL_SYS (ffsll, int, (long long int i));
# endif
# endif
_GL_CXXALIAS_SYS (ffsll, int, (long long int i));
# endif
_GL_CXXALIASWARN (ffsll);
#elif defined GNULIB_POSIXCHECK
# undef ffsll

30
lib/sys_stat.in.h
View file

@ -713,11 +713,21 @@ _GL_WARN_ON_USE (mkfifo, "mkfifo is not portable - "
#if @GNULIB_MKFIFOAT@
# if !@HAVE_MKFIFOAT@
# if @REPLACE_MKFIFOAT@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef mkfifoat
# define mkfifoat rpl_mkfifoat
# endif
_GL_FUNCDECL_RPL (mkfifoat, int, (int fd, char const *file, mode_t mode)
_GL_ARG_NONNULL ((2)));
_GL_CXXALIAS_RPL (mkfifoat, int, (int fd, char const *file, mode_t mode));
# else
# if !@HAVE_MKFIFOAT@
_GL_FUNCDECL_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode)
_GL_ARG_NONNULL ((2)));
# endif
# endif
_GL_CXXALIAS_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode));
# endif
_GL_CXXALIASWARN (mkfifoat);
#elif defined GNULIB_POSIXCHECK
# undef mkfifoat
@ -756,13 +766,25 @@ _GL_WARN_ON_USE (mknod, "mknod is not portable - "
#if @GNULIB_MKNODAT@
# if !@HAVE_MKNODAT@
# if @REPLACE_MKNODAT@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef mknodat
# define mknodat rpl_mknodat
# endif
_GL_FUNCDECL_RPL (mknodat, int,
(int fd, char const *file, mode_t mode, dev_t dev)
_GL_ARG_NONNULL ((2)));
_GL_CXXALIAS_RPL (mknodat, int,
(int fd, char const *file, mode_t mode, dev_t dev));
# else
# if !@HAVE_MKNODAT@
_GL_FUNCDECL_SYS (mknodat, int,
(int fd, char const *file, mode_t mode, dev_t dev)
_GL_ARG_NONNULL ((2)));
# endif
# endif
_GL_CXXALIAS_SYS (mknodat, int,
(int fd, char const *file, mode_t mode, dev_t dev));
# endif
_GL_CXXALIASWARN (mknodat);
#elif defined GNULIB_POSIXCHECK
# undef mknodat

27
lib/tempname.c
View file

@ -22,6 +22,7 @@
#include <sys/types.h>
#include <assert.h>
#include <stdbool.h>
#include <errno.h>
@ -61,7 +62,8 @@
# define __gen_tempname gen_tempname
# define __mkdir mkdir
# define __open open
# define __lxstat64(version, file, buf) lstat (file, buf)
# define __lstat64(file, buf) lstat (file, buf)
# define __stat64(file, buf) stat (file, buf)
# define __getrandom getrandom
# define __clock_gettime64 clock_gettime
# define __timespec64 timespec
@ -76,13 +78,14 @@ typedef uint_fast64_t random_value;
#define BASE_62_POWER (62LL * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62)
static random_value
random_bits (random_value var)
random_bits (random_value var, bool use_getrandom)
{
random_value r;
if (__getrandom (&r, sizeof r, 0) == sizeof r)
/* Without GRND_NONBLOCK it can be blocked for minutes on some systems. */
if (use_getrandom && __getrandom (&r, sizeof r, GRND_NONBLOCK) == sizeof r)
return r;
#if _LIBC || (defined CLOCK_MONOTONIC && HAVE_CLOCK_GETTIME)
/* Add entropy if getrandom is not supported. */
/* Add entropy if getrandom did not work. */
struct __timespec64 tv;
__clock_gettime64 (CLOCK_MONOTONIC, &tv);
var ^= tv.tv_nsec;
@ -96,7 +99,7 @@ static int
direxists (const char *dir)
{
struct_stat64 buf;
return __xstat64 (_STAT_VER, dir, &buf) == 0 && S_ISDIR (buf.st_mode);
return __stat64 (dir, &buf) == 0 && S_ISDIR (buf.st_mode);
}
/* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is
@ -188,7 +191,7 @@ try_nocreate (char *tmpl, void *flags _GL_UNUSED)
{
struct_stat64 st;
if (__lxstat64 (_STAT_VER, tmpl, &st) == 0 || errno == EOVERFLOW)
if (__lstat64 (tmpl, &st) == 0 || errno == EOVERFLOW)
__set_errno (EEXIST);
return errno == ENOENT ? 0 : -1;
}
@ -267,6 +270,13 @@ try_tempname_len (char *tmpl, int suffixlen, void *args,
/* How many random base-62 digits can currently be extracted from V. */
int vdigits = 0;
/* Whether to consume entropy when acquiring random bits. On the
first try it's worth the entropy cost with __GT_NOCREATE, which
is inherently insecure and can use the entropy to make it a bit
less secure. On the (rare) second and later attempts it might
help against DoS attacks. */
bool use_getrandom = tryfunc == try_nocreate;
/* Least unfair value for V. If V is less than this, V can generate
BASE_62_DIGITS digits fairly. Otherwise it might be biased. */
random_value const unfair_min
@ -290,7 +300,10 @@ try_tempname_len (char *tmpl, int suffixlen, void *args,
if (vdigits == 0)
{
do
v = random_bits (v);
{
v = random_bits (v, use_getrandom);
use_getrandom = true;
}
while (unfair_min <= v);
vdigits = BASE_62_DIGITS;

2
lib/time-internal.h
View file

@ -24,7 +24,7 @@ struct tm_zone
members are zero. */
struct tm_zone *next;
#if HAVE_TZNAME && !HAVE_TM_ZONE
#if HAVE_TZNAME && !HAVE_STRUCT_TM_TM_ZONE
/* Copies of recent strings taken from tzname[0] and tzname[1].
The copies are in ABBRS, so that they survive tzset. Null if unknown. */
char *tzname_copy[2];

19
lib/time.in.h
View file

@ -101,6 +101,25 @@ struct __time_t_must_be_integral {
# define GNULIB_defined_struct_time_t_must_be_integral 1
# endif
/* Define TIME_UTC, a positive integer constant used for timespec_get(). */
# if ! @TIME_H_DEFINES_TIME_UTC@
# if !GNULIB_defined_TIME_UTC
# define TIME_UTC 1
# define GNULIB_defined_TIME_UTC 1
# endif
# endif
/* Set *TS to the current time, and return BASE.
Upon failure, return 0. */
# if @GNULIB_TIMESPEC_GET@
# if ! @HAVE_TIMESPEC_GET@
_GL_FUNCDECL_SYS (timespec_get, int, (struct timespec *ts, int base)
_GL_ARG_NONNULL ((1)));
# endif
_GL_CXXALIAS_SYS (timespec_get, int, (struct timespec *ts, int base));
_GL_CXXALIASWARN (timespec_get);
# endif
/* Sleep for at least RQTP seconds unless interrupted, If interrupted,
return -1 and store the remaining time into RMTP. See
<https://pubs.opengroup.org/onlinepubs/9699919799/functions/nanosleep.html>. */

16
lib/time_rz.c
View file

@ -71,7 +71,7 @@ tzalloc (char const *name)
if (tz)
{
tz->next = NULL;
#if HAVE_TZNAME && !HAVE_TM_ZONE
#if HAVE_TZNAME && !HAVE_STRUCT_TM_TM_ZONE
tz->tzname_copy[0] = tz->tzname_copy[1] = NULL;
#endif
tz->tz_is_set = !!name;
@ -83,13 +83,13 @@ tzalloc (char const *name)
}
/* Save into TZ any nontrivial time zone abbreviation used by TM, and
update *TM (if HAVE_TM_ZONE) or *TZ (if !HAVE_TM_ZONE &&
HAVE_TZNAME) if they use the abbreviation. Return true if
successful, false (setting errno) otherwise. */
update *TM (if HAVE_STRUCT_TM_TM_ZONE) or *TZ (if
!HAVE_STRUCT_TM_TM_ZONE && HAVE_TZNAME) if they use the abbreviation.
Return true if successful, false (setting errno) otherwise. */
static bool
save_abbr (timezone_t tz, struct tm *tm)
{
#if HAVE_TM_ZONE || HAVE_TZNAME
#if HAVE_STRUCT_TM_TM_ZONE || HAVE_TZNAME
char const *zone = NULL;
char *zone_copy = (char *) "";
@ -97,7 +97,7 @@ save_abbr (timezone_t tz, struct tm *tm)
int tzname_index = -1;
# endif
# if HAVE_TM_ZONE
# if HAVE_STRUCT_TM_TM_ZONE
zone = tm->tm_zone;
# endif
@ -145,7 +145,7 @@ save_abbr (timezone_t tz, struct tm *tm)
}
/* Replace the zone name so that its lifetime matches that of TZ. */
# if HAVE_TM_ZONE
# if HAVE_STRUCT_TM_TM_ZONE
tm->tm_zone = zone_copy;
# else
if (0 <= tzname_index)
@ -303,7 +303,7 @@ mktime_z (timezone_t tz, struct tm *tm)
tm_1.tm_isdst = tm->tm_isdst;
time_t t = mktime (&tm_1);
bool ok = 0 <= tm_1.tm_yday;
#if HAVE_TM_ZONE || HAVE_TZNAME
#if HAVE_STRUCT_TM_TM_ZONE || HAVE_TZNAME
ok = ok && save_abbr (tz, &tm_1);
#endif
if (revert_tz (old_tz) && ok)

2
lib/timegm.c
View file

@ -1,6 +1,6 @@
/* Convert UTC calendar time to simple time. Like mktime but assumes UTC.
Copyright (C) 1994-2020 Free Software Foundation, Inc.
Copyright (C) 1994-2021 Free Software Foundation, Inc.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or

19
lib/utimens.c
View file

@ -27,6 +27,7 @@
#include <errno.h>
#include <fcntl.h>
#include <stdbool.h>
#include <string.h>
#include <sys/stat.h>
#include <sys/time.h>
#include <unistd.h>
@ -52,7 +53,9 @@
/* Avoid recursion with rpl_futimens or rpl_utimensat. */
#undef futimens
#undef utimensat
#if !HAVE_NEARLY_WORKING_UTIMENSAT
# undef utimensat
#endif
/* Solaris 9 mistakenly succeeds when given a non-directory with a
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])
# if HAVE_UTIMENSAT
if (fd < 0)
{
# if defined __APPLE__ && defined __MACH__
size_t len = strlen (file);
if (len > 0 && file[len - 1] == '/')
{
struct stat statbuf;
if (stat (file, &statbuf) < 0)
return -1;
if (!S_ISDIR (statbuf.st_mode))
{
errno = ENOTDIR;
return -1;
}
}
# endif
result = utimensat (AT_FDCWD, file, ts, 0);
# ifdef __linux__
/* Work around a kernel bug:

101
lib/utimensat.c
View file

@ -24,14 +24,40 @@
#include <errno.h>
#include <fcntl.h>
#include <stdlib.h>
#include <string.h>
#include <sys/stat.h>
#include "stat-time.h"
#include "timespec.h"
#include "utimens.h"
#if HAVE_UTIMENSAT
#if HAVE_NEARLY_WORKING_UTIMENSAT
/* Use the original utimensat(), but correct the trailing slash handling. */
int
rpl_utimensat (int fd, char const *file, struct timespec const times[2],
int flag)
# undef utimensat
{
size_t len = strlen (file);
if (len && file[len - 1] == '/')
{
struct stat st;
if (fstatat (fd, file, &st, flag & AT_SYMLINK_NOFOLLOW) < 0)
return -1;
if (!S_ISDIR (st.st_mode))
{
errno = ENOTDIR;
return -1;
}
}
return utimensat (fd, file, times, flag);
}
#else
# if HAVE_UTIMENSAT
/* If we have a native utimensat, but are compiling this file, then
utimensat was defined to rpl_utimensat by our replacement
@ -42,24 +68,25 @@
local_utimensat provides the fallback manipulation. */
static int local_utimensat (int, char const *, struct timespec const[2], int);
# define AT_FUNC_NAME local_utimensat
# define AT_FUNC_NAME local_utimensat
/* Like utimensat, but work around native bugs. */
int
rpl_utimensat (int fd, char const *file, struct timespec const times[2],
int flag)
# undef utimensat
{
# if defined __linux__ || defined __sun
# if defined __linux__ || defined __sun
struct timespec ts[2];
# endif
# endif
/* See comments in utimens.c for details. */
static int utimensat_works_really; /* 0 = unknown, 1 = yes, -1 = no. */
if (0 <= utimensat_works_really)
{
int result;
# if defined __linux__ || defined __sun
# if defined __linux__ || defined __sun
struct stat st;
/* As recently as Linux kernel 2.6.32 (Dec 2009), several file
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],
ts[1] = times[1];
times = ts;
}
# ifdef __hppa__
# ifdef __hppa__
/* Linux kernel 2.6.22.19 on hppa does not reject invalid tv_nsec
values. */
else if (times
@ -104,8 +131,36 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2],
errno = EINVAL;
return -1;
}
# endif
# endif
# if defined __APPLE__ && defined __MACH__
/* macOS 10.13 does not reject invalid tv_nsec values either. */
if (times
&& ((times[0].tv_nsec != UTIME_OMIT
&& times[0].tv_nsec != UTIME_NOW
&& ! (0 <= times[0].tv_nsec
&& times[0].tv_nsec < TIMESPEC_HZ))
|| (times[1].tv_nsec != UTIME_OMIT
&& times[1].tv_nsec != UTIME_NOW
&& ! (0 <= times[1].tv_nsec
&& times[1].tv_nsec < TIMESPEC_HZ))))
{
errno = EINVAL;
return -1;
}
size_t len = strlen (file);
if (len > 0 && file[len - 1] == '/')
{
struct stat statbuf;
if (fstatat (fd, file, &statbuf, 0) < 0)
return -1;
if (!S_ISDIR (statbuf.st_mode))
{
errno = ENOTDIR;
return -1;
}
}
# endif
# endif
result = utimensat (fd, file, times, flag);
/* Linux kernel 2.6.25 has a bug where it returns EINVAL for
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],
return local_utimensat (fd, file, times, flag);
}
#else /* !HAVE_UTIMENSAT */
# else /* !HAVE_UTIMENSAT */
# define AT_FUNC_NAME utimensat
# define AT_FUNC_NAME utimensat
#endif /* !HAVE_UTIMENSAT */
# endif /* !HAVE_UTIMENSAT */
/* Set the access and modification timestamps of FILE to be
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],
Return 0 on success, -1 (setting errno) on failure. */
/* AT_FUNC_NAME is now utimensat or local_utimensat. */
#define AT_FUNC_F1 lutimens
#define AT_FUNC_F2 utimens
#define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW
#define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag
#define AT_FUNC_POST_FILE_ARGS , ts
#include "at-func.c"
#undef AT_FUNC_NAME
#undef AT_FUNC_F1
#undef AT_FUNC_F2
#undef AT_FUNC_USE_F1_COND
#undef AT_FUNC_POST_FILE_PARAM_DECLS
#undef AT_FUNC_POST_FILE_ARGS
# define AT_FUNC_F1 lutimens
# define AT_FUNC_F2 utimens
# define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW
# define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag
# define AT_FUNC_POST_FILE_ARGS , ts
# include "at-func.c"
# undef AT_FUNC_NAME
# undef AT_FUNC_F1
# undef AT_FUNC_F2
# undef AT_FUNC_USE_F1_COND
# undef AT_FUNC_POST_FILE_PARAM_DECLS
# undef AT_FUNC_POST_FILE_ARGS
#endif /* !HAVE_NEARLY_WORKING_UTIMENSAT */

28
lib/verify.h
View file

@ -22,16 +22,10 @@
/* Define _GL_HAVE__STATIC_ASSERT to 1 if _Static_assert (R, DIAGNOSTIC)
works as per C11. This is supported by GCC 4.6.0 and later, in C
mode, and by clang (also in C++ mode).
works as per C11. This is supported by GCC 4.6.0+ and by clang 4+.
Define _GL_HAVE__STATIC_ASSERT1 to 1 if _Static_assert (R) works as
per C2X. This is supported by GCC 9.1 and later, and by clang in
C++1z mode.
Define _GL_HAVE_STATIC_ASSERT1 if static_assert (R) works as per
C++17. This is supported by GCC 9.1 and later, and by clang in
C++1z mode.
per C2X. This is supported by GCC 9.1+.
Support compilers claiming conformance to the relevant standard,
and also support GCC when not pedantic. If we were willing to slow
@ -47,18 +41,6 @@
|| (!defined __STRICT_ANSI__ && 9 <= __GNUC__))
# define _GL_HAVE__STATIC_ASSERT1 1
# endif
#else
# if 4 <= __clang_major__
# define _GL_HAVE__STATIC_ASSERT 1
# endif
# if 4 <= __clang_major__ && 201411 <= __cpp_static_assert
# define _GL_HAVE__STATIC_ASSERT1 1
# endif
# if 201703L <= __cplusplus \
|| 9 <= __GNUC__ \
|| (4 <= __clang_major__ && 201411 <= __cpp_static_assert)
# define _GL_HAVE_STATIC_ASSERT1 1
# endif
#endif
/* FreeBSD 9.1 <sys/cdefs.h>, included by <stddef.h> and lots of other
@ -225,7 +207,9 @@ template <int w>
Unfortunately, unlike C11, this implementation must appear as an
ordinary declaration, and cannot appear inside struct { ... }. */
#if defined _GL_HAVE__STATIC_ASSERT
#if 200410 <= __cpp_static_assert
# define _GL_VERIFY(R, DIAGNOSTIC, ...) static_assert (R, DIAGNOSTIC)
#elif defined _GL_HAVE__STATIC_ASSERT
# define _GL_VERIFY(R, DIAGNOSTIC, ...) _Static_assert (R, DIAGNOSTIC)
#else
# define _GL_VERIFY(R, DIAGNOSTIC, ...) \
@ -239,7 +223,7 @@ template <int w>
# define _Static_assert(...) \
_GL_VERIFY (__VA_ARGS__, "static assertion failed", -)
# endif
# if !defined _GL_HAVE_STATIC_ASSERT1 && !defined static_assert
# if __cpp_static_assert < 201411 && !defined static_assert
# define static_assert _Static_assert /* C11 requires this #define. */
# endif
#endif

2
lisp/auth-source.el
View file

@ -588,7 +588,7 @@ Here's an example:
\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\")
(A . \"default A\")))
(auth-source-creation-prompts
\\='((password . \"Enter IMAP password for %h:%p: \"))))
\\='((secret . \"Enter IMAP password for %h:%p: \"))))
(auth-source-search :host \\='(\"nonesuch\" \"twosuch\") :type \\='netrc :max 1
:P \"pppp\" :Q \"qqqq\"
:create \\='(A B Q)))

101
lisp/autorevert.el
View file

@ -355,10 +355,9 @@ the list of old buffers.")
(add-hook 'after-set-visited-file-name-hook
#'auto-revert-set-visited-file-name)
(defvar auto-revert--buffers-by-watch-descriptor
(make-hash-table :test 'equal)
"A hash table mapping notification descriptors to lists of buffers.
The buffers use that descriptor for auto-revert notifications.
(defvar auto-revert--buffer-by-watch-descriptor nil
"An association list mapping notification descriptors to buffers.
The buffer uses that descriptor for auto-revert notifications.
The key is equal to `auto-revert-notify-watch-descriptor' in each
buffer.")
@ -630,16 +629,12 @@ will use an up-to-date value of `auto-revert-interval'."
(defun auto-revert-notify-rm-watch ()
"Disable file notification for current buffer's associated file."
(let ((desc auto-revert-notify-watch-descriptor)
(table auto-revert--buffers-by-watch-descriptor))
(when desc
(let ((buffers (delq (current-buffer) (gethash desc table))))
(if buffers
(puthash desc buffers table)
(remhash desc table)))
(ignore-errors
(file-notify-rm-watch desc))
(remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t)))
(when-let ((desc auto-revert-notify-watch-descriptor))
(setq auto-revert--buffer-by-watch-descriptor
(assoc-delete-all desc auto-revert--buffer-by-watch-descriptor))
(ignore-errors
(file-notify-rm-watch desc))
(remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t))
(setq auto-revert-notify-watch-descriptor nil
auto-revert-notify-modified-p nil))
@ -660,13 +655,10 @@ will use an up-to-date value of `auto-revert-interval'."
(if buffer-file-name '(change attribute-change) '(change))
'auto-revert-notify-handler))))
(when auto-revert-notify-watch-descriptor
(setq auto-revert-notify-modified-p t)
(puthash
auto-revert-notify-watch-descriptor
(cons (current-buffer)
(gethash auto-revert-notify-watch-descriptor
auto-revert--buffers-by-watch-descriptor))
auto-revert--buffers-by-watch-descriptor)
(setq auto-revert-notify-modified-p t
auto-revert--buffer-by-watch-descriptor
(cons (cons auto-revert-notify-watch-descriptor (current-buffer))
auto-revert--buffer-by-watch-descriptor))
(add-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch nil t))))
;; If we have file notifications, we want to update the auto-revert buffers
@ -696,8 +688,8 @@ system.")
(action (nth 1 event))
(file (nth 2 event))
(file1 (nth 3 event)) ;; Target of `renamed'.
(buffers (gethash descriptor
auto-revert--buffers-by-watch-descriptor)))
(buffer (alist-get descriptor auto-revert--buffer-by-watch-descriptor
nil nil #'equal)))
;; Check, that event is meant for us.
(cl-assert descriptor)
;; Since we watch a directory, a file name must be returned.
@ -706,9 +698,9 @@ system.")
(when auto-revert-debug
(message "auto-revert-notify-handler %S" event))
(if (eq action 'stopped)
;; File notification has stopped. Continue with polling.
(cl-dolist (buffer buffers)
(when (buffer-live-p buffer)
(if (eq action 'stopped)
;; File notification has stopped. Continue with polling.
(with-current-buffer buffer
(when (or
;; A buffer associated with a file.
@ -721,38 +713,35 @@ system.")
(auto-revert-notify-rm-watch)
;; Restart the timer if it wasn't running.
(unless auto-revert-timer
(auto-revert-set-timer)))))
(auto-revert-set-timer))))
;; Loop over all buffers, in order to find the intended one.
(cl-dolist (buffer buffers)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(when (or
;; A buffer associated with a file.
(and (stringp buffer-file-name)
(or
(and (memq
action '(attribute-changed changed created))
(string-equal
(file-name-nondirectory file)
(file-name-nondirectory buffer-file-name)))
(and (eq action 'renamed)
(string-equal
(file-name-nondirectory file1)
(file-name-nondirectory buffer-file-name)))))
;; A buffer w/o a file, like dired.
(and (null buffer-file-name)
(memq action '(created renamed deleted))))
;; Mark buffer modified.
(setq auto-revert-notify-modified-p t)
(with-current-buffer buffer
(when (or
;; A buffer associated with a file.
(and (stringp buffer-file-name)
(or
(and (memq
action '(attribute-changed changed created))
(string-equal
(file-name-nondirectory file)
(file-name-nondirectory buffer-file-name)))
(and (eq action 'renamed)
(string-equal
(file-name-nondirectory file1)
(file-name-nondirectory buffer-file-name)))))
;; A buffer w/o a file, like dired.
(and (null buffer-file-name)
(memq action '(created renamed deleted))))
;; Mark buffer modified.
(setq auto-revert-notify-modified-p t)
;; Revert the buffer now if we're not locked out.
(unless auto-revert--lockout-timer
(auto-revert-handler)
(setq auto-revert--lockout-timer
(run-with-timer
auto-revert--lockout-interval nil
#'auto-revert--end-lockout buffer)))))))))))
;; Revert the buffer now if we're not locked out.
(unless auto-revert--lockout-timer
(auto-revert-handler)
(setq auto-revert--lockout-timer
(run-with-timer
auto-revert--lockout-interval nil
#'auto-revert--end-lockout buffer))))))))))
(defun auto-revert--end-lockout (buffer)
"End the lockout period after a notification.

6
lisp/calc/calc-graph.el
View file

@ -1136,11 +1136,11 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(if penbl "linespoints" "lines")
(if penbl "points" "dots"))))
(if (and pstyle (> pstyle 0))
(insert " "
(insert " ls "
(if (and lstyle (> lstyle 0)) (int-to-string lstyle) "1")
" " (int-to-string pstyle))
" ps " (int-to-string pstyle))
(if (and lstyle (> lstyle 0))
(insert " " (int-to-string lstyle)))))))
(insert " ls " (int-to-string lstyle)))))))
(calc-graph-view-commands))
(defun calc-graph-zero-x (flag)

13
lisp/calc/calccomp.el
View file

@ -822,9 +822,16 @@
(if (setq spfn (get calc-language 'math-func-formatter))
(funcall spfn func a)
(list 'horiz func calc-function-open
(math-compose-vector (cdr a) ", " 0)
calc-function-close))))))))))
(let ((args (math-compose-vector (cdr a) ", " 0)))
(if (and (member calc-function-open '("(" "[" "{"))
(member calc-function-close '(")" "]" "}")))
(list 'horiz func
(math--comp-bracket
(string-to-char calc-function-open)
(string-to-char calc-function-close)
args))
(list 'horiz func calc-function-open
args calc-function-close))))))))))))
(defun math-prod-first-term (x)

28
lisp/calendar/cal-bahai.el
View file

@ -1,4 +1,4 @@
;;; cal-bahai.el --- calendar functions for the Bahá’í calendar.
;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@ -124,9 +124,10 @@ Defaults to today's date if DATE is not given."
(y (calendar-extract-year bahai-date)))
(if (< y 1)
"" ; pre-Bahai
(let* ((m (calendar-extract-month bahai-date))
(d (calendar-extract-day bahai-date))
(monthname (if (and (= m 19)
(let ((m (calendar-extract-month bahai-date))
(d (calendar-extract-day bahai-date)))
(calendar-dlet*
((monthname (if (and (= m 19)
(<= d 0))
"Ayyám-i-Há"
(aref calendar-bahai-month-name-array (1- m))))
@ -137,8 +138,8 @@ Defaults to today's date if DATE is not given."
(year (number-to-string y))
(month (number-to-string m))
dayname)
;; Can't call calendar-date-string because of monthname oddity.
(mapconcat 'eval calendar-date-display-form "")))))
;; Can't call calendar-date-string because of monthname oddity.
(mapconcat #'eval calendar-date-display-form ""))))))
;;;###cal-autoload
(defun calendar-bahai-print-date ()
@ -153,13 +154,12 @@ Defaults to today's date if DATE is not given."
"Interactively read the arguments for a Bahá’í date command.
Reads a year, month and day."
(let* ((today (calendar-current-date))
(year (calendar-read
"Bahá’í calendar year (not 0): "
(year (calendar-read-sexp
"Bahá’í calendar year (not 0)"
(lambda (x) (not (zerop x)))
(number-to-string
(calendar-extract-year
(calendar-bahai-from-absolute
(calendar-absolute-from-gregorian today))))))
(calendar-extract-year
(calendar-bahai-from-absolute
(calendar-absolute-from-gregorian today)))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read
@ -169,8 +169,8 @@ Reads a year, month and day."
nil t)
(calendar-make-alist calendar-bahai-month-name-array
1))))
(day (calendar-read "Bahá’í calendar day (1-19): "
(lambda (x) (and (< 0 x) (<= x 19))))))
(day (calendar-read-sexp "Bahá’í calendar day (1-19)"
(lambda (x) (and (< 0 x) (<= x 19))))))
(list (list month day year))))
;;;###cal-autoload

45
lisp/calendar/cal-china.el
View file

@ -1,4 +1,4 @@
;;; cal-china.el --- calendar functions for the Chinese calendar
;;; cal-china.el --- calendar functions for the Chinese calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@ -185,7 +185,9 @@ N congruent to 1 gives the first name, N congruent to 2 gives the second name,
(defun calendar-chinese-zodiac-sign-on-or-after (d)
"Absolute date of first new Zodiac sign on or after absolute date D.
The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
(let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
(with-suppressed-warnings ((lexical year))
(defvar year))
(let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
(calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year
(calendar-daylight-time-offset
calendar-chinese-daylight-time-offset)
@ -207,6 +209,8 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
(defun calendar-chinese-new-moon-on-or-after (d)
"Absolute date of first new moon on or after absolute date D."
(with-suppressed-warnings ((lexical year))
(defvar year))
(let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
(calendar-time-zone (eval calendar-chinese-time-zone))
(calendar-daylight-time-offset
@ -602,14 +606,14 @@ Echo Chinese date unless NOECHO is non-nil."
(interactive
(let* ((c (calendar-chinese-from-absolute
(calendar-absolute-from-gregorian (calendar-current-date))))
(cycle (calendar-read
"Chinese calendar cycle number (>44): "
(cycle (calendar-read-sexp
"Chinese calendar cycle number (>44)"
(lambda (x) (> x 44))
(number-to-string (car c))))
(year (calendar-read
"Year in Chinese cycle (1..60): "
(car c)))
(year (calendar-read-sexp
"Year in Chinese cycle (1..60)"
(lambda (x) (and (<= 1 x) (<= x 60)))
(number-to-string (cadr c))))
(cadr c)))
(month-list (calendar-chinese-months-to-alist
(calendar-chinese-months cycle year)))
(month (cdr (assoc
@ -624,9 +628,11 @@ Echo Chinese date unless NOECHO is non-nil."
(list cycle year month 1))))))
30
29))
(day (calendar-read
(format "Chinese calendar day (1-%d): " last)
(lambda (x) (and (<= 1 x) (<= x last))))))
(day (calendar-read-sexp
"Chinese calendar day (1-%d)"
(lambda (x) (and (<= 1 x) (<= x last)))
nil
last)))
(list (list cycle year month day))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-chinese-to-absolute date)))
@ -663,17 +669,17 @@ Echo Chinese date unless NOECHO is non-nil."
["正月" "二月" "三月" "四月" "五月" "六月"
"七月" "八月" "九月" "十月" "冬月" "臘月"])
;;; NOTE: In the diary the cycle and year of a Chinese date is
;;; combined using this formula: (+ (* cycle 100) year).
;; NOTE: In the diary the cycle and year of a Chinese date is
;; combined using this formula: (+ (* cycle 100) year).
;;;
;;; These two functions convert to and back from this representation.
(defun calendar-chinese-from-absolute-for-diary (date)
(pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date)))
;; These two functions convert to and back from this representation.
(defun calendar-chinese-from-absolute-for-diary (thedate)
(pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute thedate)))
;; Note: For leap months M is a float.
(list (floor m) d (+ (* c 100) y))))
(defun calendar-chinese-to-absolute-for-diary (date &optional prefer-leap)
(pcase-let* ((`(,m ,d ,y) date)
(defun calendar-chinese-to-absolute-for-diary (thedate &optional prefer-leap)
(pcase-let* ((`(,m ,d ,y) thedate)
(cycle (floor y 100))
(year (mod y 100))
(months (calendar-chinese-months cycle year))
@ -691,7 +697,8 @@ Echo Chinese date unless NOECHO is non-nil."
(unless (zerop month)
(calendar-mark-1 month day year
#'calendar-chinese-from-absolute-for-diary
(lambda (date) (calendar-chinese-to-absolute-for-diary date t))
(lambda (thedate)
(calendar-chinese-to-absolute-for-diary thedate t))
color)))
;;;###cal-autoload

56
lisp/calendar/cal-coptic.el
View file

@ -1,4 +1,4 @@
;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars
;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@ -116,12 +116,13 @@ Defaults to today's date if DATE is not given."
(m (calendar-extract-month coptic-date)))
(if (< y 1)
""
(let ((monthname (aref calendar-coptic-month-name-array (1- m)))
(day (number-to-string (calendar-extract-day coptic-date)))
(dayname nil)
(month (number-to-string m))
(year (number-to-string y)))
(mapconcat 'eval calendar-date-display-form "")))))
(calendar-dlet*
((monthname (aref calendar-coptic-month-name-array (1- m)))
(day (number-to-string (calendar-extract-day coptic-date)))
(dayname nil)
(month (number-to-string m))
(year (number-to-string y)))
(mapconcat #'eval calendar-date-display-form "")))))
;;;###cal-autoload
(defun calendar-coptic-print-date ()
@ -136,13 +137,13 @@ Defaults to today's date if DATE is not given."
"Interactively read the arguments for a Coptic date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
(year (calendar-read
(format "%s calendar year (>0): " calendar-coptic-name)
(year (calendar-read-sexp
"%s calendar year (>0)"
(lambda (x) (> x 0))
(number-to-string
(calendar-extract-year
(calendar-coptic-from-absolute
(calendar-absolute-from-gregorian today))))))
(calendar-extract-year
(calendar-coptic-from-absolute
(calendar-absolute-from-gregorian today)))
calendar-coptic-name))
(completion-ignore-case t)
(month (cdr (assoc-string
(completing-read
@ -151,11 +152,14 @@ Reads a year, month, and day."
(append calendar-coptic-month-name-array nil))
nil t)
(calendar-make-alist calendar-coptic-month-name-array
1) t)))
1)
t)))
(last (calendar-coptic-last-day-of-month month year))
(day (calendar-read
(format "%s calendar day (1-%d): " calendar-coptic-name last)
(lambda (x) (and (< 0 x) (<= x last))))))
(day (calendar-read-sexp
"%s calendar day (1-%d)"
(lambda (x) (and (< 0 x) (<= x last)))
nil
calendar-coptic-name last)))
(list (list month day year))))
;;;###cal-autoload
@ -194,30 +198,30 @@ Echo Coptic date unless NOECHO is t."
(defconst calendar-ethiopic-name "Ethiopic"
"Used in some message strings.")
(defun calendar-ethiopic-to-absolute (date)
(defun calendar-ethiopic-to-absolute (thedate)
"Compute absolute date from Ethiopic date DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch))
(calendar-coptic-to-absolute date)))
(calendar-coptic-to-absolute thedate)))
(defun calendar-ethiopic-from-absolute (date)
(defun calendar-ethiopic-from-absolute (thedate)
"Compute the Ethiopic equivalent for absolute date DATE.
The result is a list of the form (MONTH DAY YEAR).
The absolute date is the number of days elapsed since the imaginary
Gregorian date Sunday, December 31, 1 BC."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch))
(calendar-coptic-from-absolute date)))
(calendar-coptic-from-absolute thedate)))
;;;###cal-autoload
(defun calendar-ethiopic-date-string (&optional date)
(defun calendar-ethiopic-date-string (&optional thedate)
"String of Ethiopic date of Gregorian DATE.
Returns the empty string if DATE is pre-Ethiopic calendar.
Defaults to today's date if DATE is not given."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch)
(calendar-coptic-name calendar-ethiopic-name)
(calendar-coptic-month-name-array calendar-ethiopic-month-name-array))
(calendar-coptic-date-string date)))
(calendar-coptic-date-string thedate)))
;;;###cal-autoload
(defun calendar-ethiopic-print-date ()
@ -229,8 +233,8 @@ Defaults to today's date if DATE is not given."
(call-interactively 'calendar-coptic-print-date)))
;;;###cal-autoload
(defun calendar-ethiopic-goto-date (date &optional noecho)
"Move cursor to Ethiopic date DATE.
(defun calendar-ethiopic-goto-date (thedate &optional noecho)
"Move cursor to Ethiopic date THEDATE.
Echo Ethiopic date unless NOECHO is t."
(interactive
(let ((calendar-coptic-epoch calendar-ethiopic-epoch)
@ -238,7 +242,7 @@ Echo Ethiopic date unless NOECHO is t."
(calendar-coptic-month-name-array calendar-ethiopic-month-name-array))
(calendar-coptic-read-date)))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-ethiopic-to-absolute date)))
(calendar-ethiopic-to-absolute thedate)))
(or noecho (calendar-ethiopic-print-date)))
;; To be called from diary-list-sexp-entries, where DATE is bound.

76
lisp/calendar/cal-french.el
View file

@ -1,4 +1,4 @@
;;; cal-french.el --- calendar functions for the French Revolutionary calendar
;;; cal-french.el --- calendar functions for the French Revolutionary calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free
;; Software Foundation, Inc.
@ -35,54 +35,45 @@
(defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792))
"Absolute date of start of French Revolutionary calendar = Sept 22, 1792.")
(defconst calendar-french-month-name-array
["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
"Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]
"Array of month names in the French calendar.")
(define-obsolete-variable-alias 'calendar-french-multibyte-month-name-array
'calendar-french-month-name-array "28.1")
(defconst calendar-french-multibyte-month-name-array
(defconst calendar-french-month-name-array
["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
"Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
"Array of multibyte month names in the French calendar.")
"Array of month names in the French calendar.")
(defconst calendar-french-day-name-array
["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
"Octidi" "Nonidi" "Decadi"]
"Array of day names in the French calendar.")
(defconst calendar-french-special-days-array
["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
"de la Re'volution"]
"Array of special day names in the French calendar.")
(define-obsolete-variable-alias 'calendar-french-multibyte-special-days-array
'calendar-french-special-days-array "28.1")
(defconst calendar-french-multibyte-special-days-array
(defconst calendar-french-special-days-array
["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
"de la Révolution"]
"Array of multibyte special day names in the French calendar.")
"Array of special day names in the French calendar.")
(defun calendar-french-accents-p ()
"Return non-nil if diacritical marks are available."
(and (or window-system
(terminal-coding-system))
(or enable-multibyte-characters
(and (char-table-p standard-display-table)
(equal (aref standard-display-table 161) [161])))))
(declare (obsolete nil "28.1"))
t)
(defun calendar-french-month-name-array ()
"Return the array of month names, depending on whether accents are available."
(if (calendar-french-accents-p)
calendar-french-multibyte-month-name-array
calendar-french-month-name-array))
(declare (obsolete "use the variable of the same name instead" "28.1"))
calendar-french-month-name-array)
(defun calendar-french-day-name-array ()
"Return the array of day names."
(declare (obsolete "use the variable of the same name instead" "28.1"))
calendar-french-day-name-array)
(defun calendar-french-special-days-array ()
"Return the special day names, depending on whether accents are available."
(if (calendar-french-accents-p)
calendar-french-multibyte-special-days-array
calendar-french-special-days-array))
(declare (obsolete "use the variable of the same name instead" "28.1"))
calendar-french-special-days-array)
(defun calendar-french-leap-year-p (year)
"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."
(d (calendar-extract-day french-date)))
(cond
((< y 1) "")
((= m 13) (format (if (calendar-french-accents-p)
"Jour %s de l'Année %d de la Révolution"
"Jour %s de l'Anne'e %d de la Re'volution")
(aref (calendar-french-special-days-array) (1- d))
((= m 13) (format "Jour %s de l'Année %d de la Révolution"
(aref calendar-french-special-days-array (1- d))
y))
(t (format
(if (calendar-french-accents-p)
"%d %s an %d de la Révolution"
"%d %s an %d de la Re'volution")
"%d %s an %d de la Révolution"
d
(aref (calendar-french-month-name-array) (1- m))
(aref calendar-french-month-name-array (1- m))
y)))))
;;;###cal-autoload
@ -198,19 +185,16 @@ Defaults to today's date if DATE is not given."
"Move cursor to French Revolutionary date DATE.
Echo French Revolutionary date unless NOECHO is non-nil."
(interactive
(let* ((months (calendar-french-month-name-array))
(special-days (calendar-french-special-days-array))
(let* ((months calendar-french-month-name-array)
(special-days calendar-french-special-days-array)
(year (progn
(calendar-read
(if (calendar-french-accents-p)
"Année de la Révolution (>0): "
"Anne'e de la Re'volution (>0): ")
(calendar-read-sexp
"Année de la Révolution (>0)"
(lambda (x) (> x 0))
(number-to-string
(calendar-extract-year
(calendar-french-from-absolute
(calendar-absolute-from-gregorian
(calendar-current-date))))))))
(calendar-extract-year
(calendar-french-from-absolute
(calendar-absolute-from-gregorian
(calendar-current-date)))))))
(month-list
(mapcar 'list
(append months
@ -234,8 +218,8 @@ Echo French Revolutionary date unless NOECHO is non-nil."
(calendar-make-alist month-list 1 'car) t)))
(day (if (> month 12)
(- month 12)
(calendar-read
"Jour (1-30): "
(calendar-read-sexp
"Jour (1-30)"
(lambda (x) (and (<= 1 x) (<= x 30))))))
(month (if (> month 12) 13 month)))
(list (list month day year))))

68
lisp/calendar/cal-hebrew.el
View file

@ -1,4 +1,4 @@
;;; cal-hebrew.el --- calendar functions for the Hebrew calendar
;;; cal-hebrew.el --- calendar functions for the Hebrew calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@ -225,13 +225,12 @@ Driven by the variable `calendar-date-display-form'."
"Interactively read the arguments for a Hebrew date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
(year (calendar-read
"Hebrew calendar year (>3760): "
(year (calendar-read-sexp
"Hebrew calendar year (>3760)"
(lambda (x) (> x 3760))
(number-to-string
(calendar-extract-year
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian today))))))
(calendar-extract-year
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian today)))))
(month-array (if (calendar-hebrew-leap-year-p year)
calendar-hebrew-month-name-array-leap-year
calendar-hebrew-month-name-array-common-year))
@ -258,10 +257,11 @@ Reads a year, month, and day."
(last (calendar-hebrew-last-day-of-month month year))
(first (if (and (= year 3761) (= month 10))
18 1))
(day (calendar-read
(format "Hebrew calendar day (%d-%d): "
first last)
(lambda (x) (and (<= first x) (<= x last))))))
(day (calendar-read-sexp
"Hebrew calendar day (%d-%d)"
(lambda (x) (and (<= first x) (<= x last)))
nil
first last)))
(list (list month day year))))
;;;###cal-autoload
@ -399,19 +399,20 @@ is non-nil."
(list m (calendar-last-day-of-month m y) y))))))
(abs-h (calendar-hebrew-to-absolute (list 9 25 h-y)))
(ord ["first" "second" "third" "fourth" "fifth" "sixth"
"seventh" "eighth"])
han)
"seventh" "eighth"]))
(holiday-filter-visible-calendar
(if (or all calendar-hebrew-all-holidays-flag)
(append
(list
(list (calendar-gregorian-from-absolute (1- abs-h))
"Erev Hanukkah"))
(dotimes (i 8 (nreverse han))
(push (list
(calendar-gregorian-from-absolute (+ abs-h i))
(format "Hanukkah (%s day)" (aref ord i)))
han)))
(let (han)
(dotimes (i 8)
(push (list
(calendar-gregorian-from-absolute (+ abs-h i))
(format "Hanukkah (%s day)" (aref ord i)))
han))
(nreverse han)))
(list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah")))))))
;;;###holiday-autoload
@ -681,10 +682,10 @@ from the cursor position."
(if (equal (current-buffer) (get-buffer calendar-buffer))
(calendar-cursor-to-date t)
(let* ((today (calendar-current-date))
(year (calendar-read
"Year of death (>0): "
(year (calendar-read-sexp
"Year of death (>0)"
(lambda (x) (> x 0))
(number-to-string (calendar-extract-year today))))
(calendar-extract-year today)))
(month-array calendar-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@ -694,20 +695,23 @@ from the cursor position."
nil t)
(calendar-make-alist month-array 1) t)))
(last (calendar-last-day-of-month month year))
(day (calendar-read
(format "Day of death (1-%d): " last)
(lambda (x) (and (< 0 x) (<= x last))))))
(day (calendar-read-sexp
"Day of death (1-%d)"
(lambda (x) (and (< 0 x) (<= x last)))
nil
last)))
(list month day year))))
(death-year (calendar-extract-year death-date))
(start-year (calendar-read
(format "Starting year of Yahrzeit table (>%d): "
death-year)
(start-year (calendar-read-sexp
"Starting year of Yahrzeit table (>%d)"
(lambda (x) (> x death-year))
(number-to-string (1+ death-year))))
(end-year (calendar-read
(format "Ending year of Yahrzeit table (>=%d): "
start-year)
(lambda (x) (>= x start-year)))))
(1+ death-year)
death-year))
(end-year (calendar-read-sexp
"Ending year of Yahrzeit table (>=%d)"
(lambda (x) (>= x start-year))
nil
start-year)))
(list death-date start-year end-year)))
(message "Computing Yahrzeits...")
(let* ((h-date (calendar-hebrew-from-absolute

19
lisp/calendar/cal-html.el
View file

@ -1,4 +1,4 @@
;;; cal-html.el --- functions for printing HTML calendars
;;; cal-html.el --- functions for printing HTML calendars -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@ -250,7 +250,7 @@ Contains links to previous and next month and year, and current minical."
calendar-week-start-day))
7))
(monthpage-name (cal-html-monthpage-name month year))
date)
) ;; date
;; Start writing table.
(insert (cal-html-comment "MINICAL")
(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."
(insert cal-html-e-tablerow-string
cal-html-b-tablerow-string)))
;; End empty slots (for some browsers like konqueror).
(dotimes (i end-blank-days)
(dotimes (_ end-blank-days)
(insert
cal-html-b-tabledata-string
cal-html-e-tabledata-string)))
@ -431,12 +431,11 @@ holidays in HOLIDAY-LIST."
;;; User commands.
;;;###cal-autoload
(defun cal-html-cursor-month (month year dir &optional event)
(defun cal-html-cursor-month (month year dir &optional _event)
"Write an HTML calendar file for numeric MONTH of four-digit YEAR.
The output directory DIR is created if necessary. Interactively,
MONTH and YEAR are taken from the calendar cursor position, or from
the position specified by EVENT. Note that any existing output files
are overwritten."
MONTH and YEAR are taken from the calendar cursor position.
Note that any existing output files are overwritten."
(interactive (let* ((event last-nonmenu-event)
(date (calendar-cursor-to-date t event))
(month (calendar-extract-month date))
@ -446,11 +445,11 @@ are overwritten."
(cal-html-one-month month year dir))
;;;###cal-autoload
(defun cal-html-cursor-year (year dir &optional event)
(defun cal-html-cursor-year (year dir &optional _event)
"Write HTML calendar files (index and monthly pages) for four-digit YEAR.
The output directory DIR is created if necessary. Interactively,
YEAR is taken from the calendar cursor position, or from the position
specified by EVENT. Note that any existing output files are overwritten."
YEAR is taken from the calendar cursor position.
Note that any existing output files are overwritten."
(interactive (let* ((event last-nonmenu-event)
(year (calendar-extract-year
(calendar-cursor-to-date t event))))

25
lisp/calendar/cal-islam.el
View file

@ -1,4 +1,4 @@
;;; cal-islam.el --- calendar functions for the Islamic calendar
;;; cal-islam.el --- calendar functions for the Islamic calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@ -67,8 +67,8 @@
"Absolute date of Islamic DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(let* ((month (calendar-extract-month date))
(day (calendar-extract-day date))
(let* (;;(month (calendar-extract-month date))
;;(day (calendar-extract-day date))
(year (calendar-extract-year date))
(y (% year 30))
(leap-years-in-cycle (cond ((< y 3) 0)
@ -143,13 +143,12 @@ Driven by the variable `calendar-date-display-form'."
"Interactively read the arguments for an Islamic date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
(year (calendar-read
"Islamic calendar year (>0): "
(year (calendar-read-sexp
"Islamic calendar year (>0)"
(lambda (x) (> x 0))
(number-to-string
(calendar-extract-year
(calendar-islamic-from-absolute
(calendar-absolute-from-gregorian today))))))
(calendar-extract-year
(calendar-islamic-from-absolute
(calendar-absolute-from-gregorian today)))))
(month-array calendar-islamic-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@ -159,9 +158,11 @@ Reads a year, month, and day."
nil t)
(calendar-make-alist month-array 1) t)))
(last (calendar-islamic-last-day-of-month month year))
(day (calendar-read
(format "Islamic calendar day (1-%d): " last)
(lambda (x) (and (< 0 x) (<= x last))))))
(day (calendar-read-sexp
"Islamic calendar day (1-%d)"
(lambda (x) (and (< 0 x) (<= x last)))
nil
last)))
(list (list month day year))))
;;;###cal-autoload

21
lisp/calendar/cal-iso.el
View file

@ -1,4 +1,4 @@
;;; cal-iso.el --- calendar functions for the ISO calendar
;;; cal-iso.el --- calendar functions for the ISO calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@ -92,22 +92,23 @@ date Sunday, December 31, 1 BC."
"Interactively read the arguments for an ISO date command.
Reads a year and week, and if DAYFLAG is non-nil a day (otherwise
taken to be 1)."
(let* ((year (calendar-read
"ISO calendar year (>0): "
(let* ((year (calendar-read-sexp
"ISO calendar year (>0)"
(lambda (x) (> x 0))
(number-to-string (calendar-extract-year
(calendar-current-date)))))
(calendar-extract-year (calendar-current-date))))
(no-weeks (calendar-extract-month
(calendar-iso-from-absolute
(1-
(calendar-dayname-on-or-before
1 (calendar-absolute-from-gregorian
(list 1 4 (1+ year))))))))
(week (calendar-read
(format "ISO calendar week (1-%d): " no-weeks)
(lambda (x) (and (> x 0) (<= x no-weeks)))))
(day (if dayflag (calendar-read
"ISO day (1-7): "
(week (calendar-read-sexp
"ISO calendar week (1-%d)"
(lambda (x) (and (> x 0) (<= x no-weeks)))
nil
no-weeks))
(day (if dayflag (calendar-read-sexp
"ISO day (1-7)"
(lambda (x) (and (<= 1 x) (<= x 7))))
1)))
(list (list week day year))))

26
lisp/calendar/cal-julian.el
View file

@ -95,14 +95,13 @@ Driven by the variable `calendar-date-display-form'."
"Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil."
(interactive
(let* ((today (calendar-current-date))
(year (calendar-read
"Julian calendar year (>0): "
(year (calendar-read-sexp
"Julian calendar year (>0)"
(lambda (x) (> x 0))
(number-to-string
(calendar-extract-year
(calendar-julian-from-absolute
(calendar-absolute-from-gregorian
today))))))
(calendar-extract-year
(calendar-julian-from-absolute
(calendar-absolute-from-gregorian
today)))))
(month-array calendar-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@ -115,12 +114,13 @@ Driven by the variable `calendar-date-display-form'."
(if (and (zerop (% year 4)) (= month 2))
29
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
(day (calendar-read
(format "Julian calendar day (%d-%d): "
(if (and (= year 1) (= month 1)) 3 1) last)
(day (calendar-read-sexp
"Julian calendar day (%d-%d)"
(lambda (x)
(and (< (if (and (= year 1) (= month 1)) 2 0) x)
(<= x last))))))
(<= x last)))
nil
(if (and (= year 1) (= month 1)) 3 1) last)))
(list (list month day year))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-julian-to-absolute date)))
@ -173,8 +173,8 @@ Defaults to today's date if DATE is not given."
(defun calendar-astro-goto-day-number (daynumber &optional noecho)
"Move cursor to astronomical (Julian) DAYNUMBER.
Echo astronomical (Julian) day number unless NOECHO is non-nil."
(interactive (list (calendar-read
"Astronomical (Julian) day number (>1721425): "
(interactive (list (calendar-read-sexp
"Astronomical (Julian) day number (>1721425)"
(lambda (x) (> x 1721425)))))
(calendar-goto-date
(calendar-gregorian-from-absolute

10
lisp/calendar/cal-mayan.el
View file

@ -1,4 +1,4 @@
;;; cal-mayan.el --- calendar functions for the Mayan calendars
;;; cal-mayan.el --- calendar functions for the Mayan calendars -*- lexical-binding: t; -*-
;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software
;; Foundation, Inc.
@ -135,8 +135,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
(defun calendar-mayan-read-haab-date ()
"Prompt for a Mayan haab date."
(let* ((completion-ignore-case t)
(haab-day (calendar-read
"Haab kin (0-19): "
(haab-day (calendar-read-sexp
"Haab kin (0-19)"
(lambda (x) (and (>= x 0) (< x 20)))))
(haab-month-list (append calendar-mayan-haab-month-name-array
(and (< haab-day 5) '("Uayeb"))))
@ -151,8 +151,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
(defun calendar-mayan-read-tzolkin-date ()
"Prompt for a Mayan tzolkin date."
(let* ((completion-ignore-case t)
(tzolkin-count (calendar-read
"Tzolkin kin (1-13): "
(tzolkin-count (calendar-read-sexp
"Tzolkin kin (1-13)"
(lambda (x) (and (> x 0) (< x 14)))))
(tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
(tzolkin-name (cdr

4
lisp/calendar/cal-menu.el
View file

@ -1,4 +1,4 @@
;;; cal-menu.el --- calendar functions for menu bar and popup menu support
;;; cal-menu.el --- calendar functions for menu bar and popup menu support -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
@ -183,6 +183,8 @@ Signals an error if popups are unavailable."
;; Autoloaded in diary-lib.
(declare-function calendar-check-holidays "holidays" (date))
(defvar diary-list-include-blanks)
(defun calendar-mouse-view-diary-entries (&optional date diary event)
"Pop up menu of diary entries for mouse-selected date.
Use optional DATE and alternative file DIARY. EVENT is the event

17
lisp/calendar/cal-move.el
View file

@ -1,4 +1,4 @@
;;; cal-move.el --- calendar functions for movement in the calendar
;;; cal-move.el --- calendar functions for movement in the calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@ -386,15 +386,16 @@ Moves forward if ARG is negative."
"Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil.
Negative DAY counts backward from end of year."
(interactive
(let* ((year (calendar-read
"Year (>0): "
(let* ((year (calendar-read-sexp
"Year (>0)"
(lambda (x) (> x 0))
(number-to-string (calendar-extract-year
(calendar-current-date)))))
(calendar-extract-year (calendar-current-date))))
(last (if (calendar-leap-year-p year) 366 365))
(day (calendar-read
(format "Day number (+/- 1-%d): " last)
(lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))))))
(day (calendar-read-sexp
"Day number (+/- 1-%d)"
(lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))
nil
last)))
(list year day)))
(calendar-goto-date
(calendar-gregorian-from-absolute

30
lisp/calendar/cal-persia.el
View file

@ -1,4 +1,4 @@
;;; cal-persia.el --- calendar functions for the Persian calendar
;;; cal-persia.el --- calendar functions for the Persian calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
@ -139,13 +139,14 @@ Gregorian date Sunday, December 31, 1 BC."
(calendar-absolute-from-gregorian
(or date (calendar-current-date)))))
(y (calendar-extract-year persian-date))
(m (calendar-extract-month persian-date))
(monthname (aref calendar-persian-month-name-array (1- m)))
(m (calendar-extract-month persian-date)))
(calendar-dlet*
((monthname (aref calendar-persian-month-name-array (1- m)))
(day (number-to-string (calendar-extract-day persian-date)))
(year (number-to-string y))
(month (number-to-string m))
dayname)
(mapconcat 'eval calendar-date-display-form "")))
(mapconcat #'eval calendar-date-display-form ""))))
;;;###cal-autoload
(defun calendar-persian-print-date ()
@ -157,14 +158,13 @@ Gregorian date Sunday, December 31, 1 BC."
(defun calendar-persian-read-date ()
"Interactively read the arguments for a Persian date command.
Reads a year, month, and day."
(let* ((year (calendar-read
"Persian calendar year (not 0): "
(let* ((year (calendar-read-sexp
"Persian calendar year (not 0)"
(lambda (x) (not (zerop x)))
(number-to-string
(calendar-extract-year
(calendar-persian-from-absolute
(calendar-absolute-from-gregorian
(calendar-current-date)))))))
(calendar-extract-year
(calendar-persian-from-absolute
(calendar-absolute-from-gregorian
(calendar-current-date))))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read
@ -175,9 +175,11 @@ Reads a year, month, and day."
(calendar-make-alist calendar-persian-month-name-array
1))))
(last (calendar-persian-last-day-of-month month year))
(day (calendar-read
(format "Persian calendar day (1-%d): " last)
(lambda (x) (and (< 0 x) (<= x last))))))
(day (calendar-read-sexp
"Persian calendar day (1-%d)"
(lambda (x) (and (< 0 x) (<= x last)))
nil
last)))
(list (list month day year))))
;;;###cal-autoload

85
lisp/calendar/cal-tex.el
View file

@ -1,4 +1,4 @@
;;; cal-tex.el --- calendar functions for printing calendars with LaTeX
;;; cal-tex.el --- calendar functions for printing calendars with LaTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@ -248,6 +248,8 @@ This definition is the heart of the calendar!")
(autoload 'diary-list-entries "diary-lib")
(defvar diary-list-include-blanks)
(defun cal-tex-list-diary-entries (d1 d2)
"Generate a list of all diary-entries from absolute date D1 to D2."
(let (diary-list-include-blanks)
@ -591,6 +593,8 @@ indicates a buffer position to use instead of point."
LaTeX commands are inserted for the days of the MONTH in YEAR.
Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS
are included. Each day is formatted using format DAY-FORMAT."
(with-suppressed-warnings ((lexical date))
(defvar date)) ;For `cal-tex-daily-string'.
(let ((blank-days ; at start of month
(mod
(- (calendar-day-of-week (list month 1 year))
@ -605,7 +609,7 @@ are included. Each day is formatted using format DAY-FORMAT."
(insert (format day-format (cal-tex-month-name month) j))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
(cal-tex-arg (eval cal-tex-daily-string))
(cal-tex-arg (eval cal-tex-daily-string t))
(cal-tex-arg)
(cal-tex-comment))
(when (and (zerop (mod (+ j blank-days) 7))
@ -885,13 +889,15 @@ argument EVENT specifies a different buffer position."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
(with-suppressed-warnings ((lexical date))
(defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
(month (calendar-extract-month date))
(year (calendar-extract-year date))
;; (year (calendar-extract-year date))
(day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
@ -932,7 +938,7 @@ argument EVENT specifies a different buffer position."
(insert ": ")
(cal-tex-large-bf s))
(cal-tex-hfill)
(insert " " (eval cal-tex-daily-string))
(insert " " (eval cal-tex-daily-string t))
(cal-tex-e-parbox)
(cal-tex-nl)
(cal-tex-noindent)
@ -951,7 +957,8 @@ argument EVENT specifies a different buffer position."
(cal-tex-e-parbox "2cm")
(cal-tex-nl)
(setq month (calendar-extract-month date)
year (calendar-extract-year date)))
;; year (calendar-extract-year date)
))
(cal-tex-e-parbox)
(unless (= i (1- n))
(run-hooks 'cal-tex-week-hook)
@ -961,13 +968,16 @@ argument EVENT specifies a different buffer position."
;; TODO respect cal-tex-daily-start,end?
;; Using different numbers of hours will probably break some layouts.
(defun cal-tex-week-hours (date holidays height)
"Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT.
(defun cal-tex-week-hours (thedate holidays height)
"Insert hourly entries for THEDATE with HOLIDAYS, with line height HEIGHT.
Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours
shown are hard-coded to 8-12, 13-17."
(let ((month (calendar-extract-month date))
(with-suppressed-warnings ((lexical date))
(defvar date)) ;For `cal-tex-daily-string'.
(let ((date thedate)
(month (calendar-extract-month date))
(day (calendar-extract-day date))
(year (calendar-extract-year date))
;; (year (calendar-extract-year date))
morning afternoon s)
(cal-tex-comment "begin cal-tex-week-hours")
(cal-tex-cmd "\\ \\\\[-.2cm]")
@ -983,7 +993,7 @@ shown are hard-coded to 8-12, 13-17."
(insert ": ")
(cal-tex-large-bf s))
(cal-tex-hfill)
(insert " " (eval cal-tex-daily-string))
(insert " " (eval cal-tex-daily-string t))
(cal-tex-e-parbox)
(cal-tex-nl "-.3cm")
(cal-tex-rule "0pt" "6.8in" ".2mm")
@ -1088,14 +1098,16 @@ shown are hard-coded to 8-12, 13-17."
(defun cal-tex-weekly-common (n event &optional filofax)
"Common code for weekly calendars."
(or n (setq n 1))
(with-suppressed-warnings ((lexical date))
(defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
(month (calendar-extract-month date))
(year (calendar-extract-year date))
(day (calendar-extract-day date))
;; (month (calendar-extract-month date))
;; (year (calendar-extract-year date))
;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@ -1161,7 +1173,7 @@ shown are hard-coded to 8-12, 13-17."
(cal-tex-arg (number-to-string (calendar-extract-day date)))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
(cal-tex-arg (eval cal-tex-daily-string))
(cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
(setq date (cal-tex-incr-date date)))
(insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")
@ -1258,14 +1270,16 @@ Optional EVENT indicates a buffer position to use instead of point."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
(with-suppressed-warnings ((lexical date))
(defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
calendar-week-start-day
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
(month (calendar-extract-month date))
(year (calendar-extract-year date))
(day (calendar-extract-day date))
;; (month (calendar-extract-month date))
;; (year (calendar-extract-year date))
;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@ -1311,7 +1325,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(cal-tex-arg (number-to-string (calendar-extract-day date)))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
(cal-tex-arg (eval cal-tex-daily-string))
(cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
(setq date (cal-tex-incr-date date)))
(unless (= i (1- n))
@ -1342,14 +1356,16 @@ Optional EVENT indicates a buffer position to use instead of point."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
(with-suppressed-warnings ((lexical date))
(defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
(month (calendar-extract-month date))
(year (calendar-extract-year date))
(day (calendar-extract-day date))
;; (month (calendar-extract-month date))
;; (year (calendar-extract-year date))
;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@ -1383,11 +1399,11 @@ Optional EVENT indicates a buffer position to use instead of point."
"\\leftday")))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t))
(cal-tex-arg (eval cal-tex-daily-string))
(cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
(if cal-tex-rules
(insert "\\linesfill\n")
(insert "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
(insert (if cal-tex-rules
"\\linesfill\n"
"\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
(cal-tex-newpage)
(setq date (cal-tex-incr-date date)))
(insert "%\n")
@ -1397,11 +1413,11 @@ Optional EVENT indicates a buffer position to use instead of point."
(insert "\\weekend")
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t))
(cal-tex-arg (eval cal-tex-daily-string))
(cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
(if cal-tex-rules
(insert "\\linesfill\n")
(insert "\\vfill"))
(insert (if cal-tex-rules
"\\linesfill\n"
"\\vfill"))
(setq date (cal-tex-incr-date date)))
(or cal-tex-rules
(insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
@ -1442,12 +1458,15 @@ a buffer position to use instead of point."
(cal-tex-end-document)
(run-hooks 'cal-tex-hook)))
(defun cal-tex-daily-page (date)
"Make a calendar page for Gregorian DATE on 8.5 by 11 paper.
(defun cal-tex-daily-page (thedate)
"Make a calendar page for Gregorian THEDATE on 8.5 by 11 paper.
Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces
hourly sections for the period specified by `cal-tex-daily-start'
and `cal-tex-daily-end'."
(let ((month-name (cal-tex-month-name (calendar-extract-month date)))
(with-suppressed-warnings ((lexical date))
(defvar date)) ;For `cal-tex-daily-string'.
(let ((date thedate)
(month-name (cal-tex-month-name (calendar-extract-month date)))
(i (1- cal-tex-daily-start))
hour)
(cal-tex-banner "cal-tex-daily-page")
@ -1459,7 +1478,7 @@ and `cal-tex-daily-end'."
(cal-tex-bf month-name )
(cal-tex-e-parbox)
(cal-tex-hspace "1cm")
(cal-tex-scriptsize (eval cal-tex-daily-string))
(cal-tex-scriptsize (eval cal-tex-daily-string t))
(cal-tex-hspace "3.5cm")
(cal-tex-e-makebox)
(cal-tex-hfill)

2
lisp/calendar/cal-x.el
View file

@ -1,4 +1,4 @@
;;; cal-x.el --- calendar windows in dedicated frames
;;; cal-x.el --- calendar windows in dedicated frames -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.

57
lisp/calendar/calendar.el
View file

@ -112,6 +112,8 @@
;;; Code:
(eval-when-compile (require 'subr-x))
(load "cal-loaddefs" nil t)
;; Calendar has historically relied heavily on dynamic scoping.
@ -1459,7 +1461,7 @@ Optional integers MON and YR are used instead of today's date."
Inserts STRING so that it ends at INDENT. STRING is either a
literal string, or a sexp to evaluate to return such. Truncates
STRING to length TRUNCATE, and ensures a trailing space."
(if (not (ignore-errors (stringp (setq string (eval string)))))
(if (not (ignore-errors (stringp (setq string (eval string t)))))
(calendar-move-to-column indent)
(if (> (string-width string) truncate)
(setq string (truncate-string-to-width string truncate)))
@ -1526,7 +1528,7 @@ first INDENT characters on the line."
(format (format "%%%dd" calendar-day-digit-width) day)
'mouse-face 'highlight
'help-echo (calendar-dlet* ((day day) (month month) (year year))
(eval calendar-date-echo-text))
(eval calendar-date-echo-text t))
;; 'date property prevents intermonth text confusing re-searches.
;; (Tried intangible, it did not really work.)
'date t)
@ -2054,23 +2056,40 @@ With argument ARG, jump to mark, pop it, and put point at end of ring."
(error "%s not available in the calendar"
(global-key-binding (this-command-keys))))
(defun calendar-read-sexp (prompt predicate &optional default &rest args)
"Return an object read from the minibuffer.
Passes PROMPT, DEFAULT, and ARGS to `format-prompt' to build
the actual prompt. PREDICATE is called with a single value (the object
the user entered) and it should return non-nil if that value is a valid choice.
DEFAULT is the default value to use."
(unless (stringp default) (setq default (format "%S" default)))
(named-let query ()
;; The call to `read-from-minibuffer' is copied from `read-minibuffer',
;; except it's changed to use the DEFAULT arg instead of INITIAL-CONTENTS.
(let ((value (read-from-minibuffer
(apply #'format-prompt prompt default args)
nil minibuffer-local-map t 'minibuffer-history default)))
(if (funcall predicate value)
value
(query)))))
(defun calendar-read (prompt acceptable &optional initial-contents)
"Return an object read from the minibuffer.
Prompt with the string PROMPT and use the function ACCEPTABLE to decide
if entered item is acceptable. If non-nil, optional third arg
INITIAL-CONTENTS is a string to insert in the minibuffer before reading."
(declare (obsolete calendar-read-sexp "28.1"))
(let ((value (read-minibuffer prompt initial-contents)))
(while (not (funcall acceptable value))
(setq value (read-minibuffer prompt initial-contents)))
value))
(defun calendar-customized-p (symbol)
"Return non-nil if SYMBOL has been customized."
(and (default-boundp symbol)
(let ((standard (get symbol 'standard-value)))
(and standard
(not (equal (eval (car standard)) (default-value symbol)))))))
(not (equal (eval (car standard) t) (default-value symbol)))))))
(defun calendar-abbrev-construct (full &optional maxlen)
"From sequence FULL, return a vector of abbreviations.
@ -2284,32 +2303,38 @@ arguments SEQUENCES."
(append (list sequence) sequences))
(reverse alist)))
(defun calendar-read-date (&optional noday)
(defun calendar-read-date (&optional noday default-date)
"Prompt for Gregorian date. Return a list (month day year).
If optional NODAY is t, does not ask for day, but just returns
\(month 1 year); if NODAY is any other non-nil value the value
returned is (month year)."
(let* ((year (calendar-read
"Year (>0): "
(lambda (x) (> x 0))
(number-to-string (calendar-extract-year
(calendar-current-date)))))
(unless default-date (setq default-date (calendar-current-date)))
(let* ((defyear (calendar-extract-year default-date))
(year (calendar-read-sexp "Year (>0)"
(lambda (x) (> x 0))
defyear))
(month-array calendar-month-name-array)
(defmon (aref month-array (1- (calendar-extract-month default-date))))
(completion-ignore-case t)
(month (cdr (assoc-string
(completing-read
"Month name: "
(mapcar #'list (append month-array nil))
nil t)
(completing-read
(format-prompt "Month name" defmon)
(append month-array nil)
nil t nil nil defmon)
(calendar-make-alist month-array 1) t)))
(defday (calendar-extract-day default-date))
(last (calendar-last-day-of-month month year)))
(if noday
(if (eq noday t)
(list month 1 year)
(list month year))
(list month
(calendar-read (format "Day (1-%d): " last)
(lambda (x) (and (< 0 x) (<= x last))))
(calendar-read-sexp "Day (1-%d)"
(lambda (x) (and (< 0 x) (<= x last)))
;; Don't offer today's day as default
;; if it's not valid for the chosen
;; month/year.
(if (<= defday last) defday) last)
year))))
(defun calendar-interval (mon1 yr1 mon2 yr2)

4
lisp/calendar/diary-lib.el
View file

@ -2221,8 +2221,8 @@ Prefix argument ARG makes the entry nonmarking."
(diary-make-entry
(format "%s(diary-cyclic %d %s)"
diary-sexp-entry-symbol
(calendar-read "Repeat every how many days: "
(lambda (x) (> x 0)))
(calendar-read-sexp "Repeat every how many days"
(lambda (x) (> x 0)))
(calendar-date-string (calendar-cursor-to-date t) nil t))
arg)))

15
lisp/calendar/holidays.el
View file

@ -423,16 +423,15 @@ of a holiday list.
The optional LABEL is used to label the buffer created."
(interactive
(let* ((start-year (calendar-read
"Starting year of holidays (>0): "
(let* ((start-year (calendar-read-sexp
"Starting year of holidays (>0)"
(lambda (x) (> x 0))
(number-to-string (calendar-extract-year
(calendar-current-date)))))
(end-year (calendar-read
(format "Ending year (inclusive) of holidays (>=%s): "
start-year)
(calendar-extract-year (calendar-current-date))))
(end-year (calendar-read-sexp
"Ending year (inclusive) of holidays (>=%s)"
(lambda (x) (>= x start-year))
(number-to-string start-year)))
start-year
start-year))
(completion-ignore-case t)
(lists
(list

7
lisp/dired-aux.el
View file

@ -1168,7 +1168,10 @@ ARGS are command switches passed to PROGRAM.")
("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o")
("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o")
("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o")
("\\.zip\\'" . "zip %o -r --filesync %i"))
("\\.tar\\.lz\\'" . "tar -cf - %i | lzip -c9 > %o")
("\\.tar\\.lzo\\'" . "tar -cf - %i | lzop -c9 > %o")
("\\.zip\\'" . "zip %o -r --filesync %i")
("\\.pax\\'" . "pax -wf %o %i"))
"Control the compression shell command for `dired-do-compress-to'.
Each element is (REGEXP . CMD), where REGEXP is the name of the
@ -1176,7 +1179,7 @@ archive to which you want to compress, and CMD is the
corresponding command.
Within CMD, %i denotes the input file(s), and %o denotes the
output file. %i path(s) are relative, while %o is absolute.")
output file. %i path(s) are relative, while %o is absolute.")
;;;###autoload
(defun dired-do-compress-to ()

21
lisp/dired.el
View file

@ -3532,18 +3532,21 @@ confirmation. To disable the confirmation, see
(when (and (featurep 'dired-x) dired-clean-up-buffers-too)
(let ((buf (get-file-buffer fn)))
(and buf
(and dired-clean-confirm-killing-deleted-buffers
(funcall #'y-or-n-p
(format "Kill buffer of %s, too? "
(file-name-nondirectory fn))))
(or (and dired-clean-confirm-killing-deleted-buffers
(funcall #'y-or-n-p
(format "Kill buffer of %s, too? "
(file-name-nondirectory fn))))
(not dired-clean-confirm-killing-deleted-buffers))
(kill-buffer buf)))
(let ((buf-list (dired-buffers-for-dir (expand-file-name fn))))
(and buf-list
(and dired-clean-confirm-killing-deleted-buffers
(y-or-n-p (format (ngettext "Kill Dired buffer of %s, too? "
"Kill Dired buffers of %s, too? "
(length buf-list))
(file-name-nondirectory fn))))
(or (and dired-clean-confirm-killing-deleted-buffers
(y-or-n-p (format
(ngettext "Kill Dired buffer of %s, too? "
"Kill Dired buffers of %s, too? "
(length buf-list))
(file-name-nondirectory fn))))
(not dired-clean-confirm-killing-deleted-buffers))
(dolist (buf buf-list)
(kill-buffer buf))))))

112
lisp/emacs-lisp/bindat.el
View file

@ -1,4 +1,4 @@
;;; bindat.el --- binary data structure packing and unpacking.
;;; bindat.el --- binary data structure packing and unpacking. -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@ -198,7 +198,7 @@
(defun bindat--unpack-u8 ()
(prog1
(aref bindat-raw bindat-idx)
(aref bindat-raw bindat-idx)
(setq bindat-idx (1+ bindat-idx))))
(defun bindat--unpack-u16 ()
@ -276,6 +276,8 @@
(t nil)))
(defun bindat--unpack-group (spec)
(with-suppressed-warnings ((lexical last))
(defvar last))
(let (struct last)
(while spec
(let* ((item (car spec))
@ -287,11 +289,11 @@
data)
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)))))
(setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)))))
(setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
(setq len (eval (car (cdr len)))))
(setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
@ -304,48 +306,51 @@
(cond
((eq type 'eval)
(if field
(setq data (eval len))
(eval len)))
(setq data (eval len t))
(eval len t)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
(setq data (bindat--unpack-group (eval len))))
(setq data (bindat--unpack-group (eval len t))))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
(setq data (cons (bindat--unpack-group (nthcdr tail item)) data))
(push (bindat--unpack-group (nthcdr tail item)) data)
(setq index (1+ index)))
(setq data (nreverse data))))
((eq type 'union)
(with-suppressed-warnings ((lexical tag))
(defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
(and (consp cc) (eval cc)))
(and (consp cc) (eval cc t)))
(setq data (bindat--unpack-group (cdr case))
cases nil)))))
(t
(setq data (bindat--unpack-item type len vectype)
last data)))
(if data
(if field
(setq struct (cons (cons field data) struct))
(setq struct (append data struct))))))
(setq struct (if field
(cons (cons field data) struct)
(append data struct))))))
struct))
(defun bindat-unpack (spec bindat-raw &optional bindat-idx)
"Return structured data according to SPEC for binary data in BINDAT-RAW.
BINDAT-RAW is a unibyte string or vector.
Optional third arg BINDAT-IDX specifies the starting offset in BINDAT-RAW."
(when (multibyte-string-p bindat-raw)
(defun bindat-unpack (spec raw &optional idx)
"Return structured data according to SPEC for binary data in RAW.
RAW is a unibyte string or vector.
Optional third arg IDX specifies the starting offset in RAW."
(when (multibyte-string-p raw)
(error "String is multibyte"))
(unless bindat-idx (setq bindat-idx 0))
(bindat--unpack-group spec))
(let ((bindat-idx (or idx 0))
(bindat-raw raw))
(bindat--unpack-group spec)))
(defun bindat-get-field (struct &rest field)
"In structured data STRUCT, return value of field named FIELD.
@ -373,6 +378,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(ip . 4)))
(defun bindat--length-group (struct spec)
(with-suppressed-warnings ((lexical last))
(defvar last))
(let (last)
(while spec
(let* ((item (car spec))
@ -383,32 +390,31 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(tail 3))
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)))))
(setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)))))
(setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
(setq len (eval (car (cdr len)))))
(setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
type field
field nil))
(if (and (consp len) (not (eq type 'eval)))
(setq len (apply 'bindat-get-field struct len)))
(setq len (apply #'bindat-get-field struct len)))
(if (not len)
(setq len 1))
(while (eq type 'vec)
(let ((vlen 1))
(if (consp vectype)
(setq len (* len (nth 1 vectype))
type (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil))))
(if (consp vectype)
(setq len (* len (nth 1 vectype))
type (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil)))
(cond
((eq type 'eval)
(if field
(setq struct (cons (cons field (eval len)) struct))
(eval len)))
(setq struct (cons (cons field (eval len t)) struct))
(eval len t)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
@ -416,7 +422,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
(bindat--length-group
(if field (bindat-get-field struct field) struct) (eval len)))
(if field (bindat-get-field struct field) struct) (eval len t)))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
@ -425,13 +431,15 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(nthcdr tail item))
(setq index (1+ index)))))
((eq type 'union)
(with-suppressed-warnings ((lexical tag))
(defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
(and (consp cc) (eval cc)))
(and (consp cc) (eval cc t)))
(progn
(bindat--length-group struct (cdr case))
(setq cases nil))))))
@ -536,6 +544,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (+ bindat-idx len)))))
(defun bindat--pack-group (struct spec)
(with-suppressed-warnings ((lexical last))
(defvar last))
(let (last)
(while spec
(let* ((item (car spec))
@ -546,11 +556,11 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(tail 3))
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)))))
(setq field (eval (car (cdr field)) t)))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)))))
(setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
(setq len (eval (car (cdr len)))))
(setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
@ -563,8 +573,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(cond
((eq type 'eval)
(if field
(setq struct (cons (cons field (eval len)) struct))
(eval len)))
(setq struct (cons (cons field (eval len t)) struct))
(eval len t)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
@ -572,7 +582,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
(bindat--pack-group
(if field (bindat-get-field struct field) struct) (eval len)))
(if field (bindat-get-field struct field) struct) (eval len t)))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
@ -581,13 +591,15 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(nthcdr tail item))
(setq index (1+ index)))))
((eq type 'union)
(with-suppressed-warnings ((lexical tag))
(defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
(and (consp cc) (eval cc)))
(and (consp cc) (eval cc t)))
(progn
(bindat--pack-group struct (cdr case))
(setq cases nil))))))
@ -596,19 +608,19 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(bindat--pack-item last type len vectype)
))))))
(defun bindat-pack (spec struct &optional bindat-raw bindat-idx)
(defun bindat-pack (spec struct &optional raw idx)
"Return binary data packed according to SPEC for structured data STRUCT.
Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to
Optional third arg RAW is a pre-allocated unibyte string or vector to
pack into.
Optional fourth arg BINDAT-IDX is the starting offset into BINDAT-RAW."
(when (multibyte-string-p bindat-raw)
Optional fourth arg IDX is the starting offset into RAW."
(when (multibyte-string-p raw)
(error "Pre-allocated string is multibyte"))
(let ((no-return bindat-raw))
(unless bindat-idx (setq bindat-idx 0))
(unless bindat-raw
(setq bindat-raw (make-string (+ bindat-idx (bindat-length spec struct)) 0)))
(let* ((bindat-idx (or idx 0))
(bindat-raw
(or raw
(make-string (+ bindat-idx (bindat-length spec struct)) 0))))
(bindat--pack-group struct spec)
(if no-return nil bindat-raw)))
(if raw nil bindat-raw)))
;; Misc. format conversions

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

File diff suppressed because it is too large Load diff

16
lisp/emacs-lisp/byte-run.el
View file

@ -232,8 +232,11 @@ The return value is undefined.
#'(lambda (x)
(let ((f (cdr (assq (car x) macro-declarations-alist))))
(if f (apply (car f) name arglist (cdr x))
(message "Warning: Unknown macro property %S in %S"
(car x) name))))
(macroexp--warn-and-return
(format-message
"Unknown macro property %S in %S"
(car x) name)
nil))))
decls)))
;; Refresh font-lock if this is a new macro, or it is an
;; existing macro whose 'no-font-lock-keyword declaration
@ -301,9 +304,12 @@ The return value is undefined.
(cdr body)
body)))
nil)
(t (message "Warning: Unknown defun property `%S' in %S"
(car x) name)))))
decls))
(t
(macroexp--warn-and-return
(format-message "Unknown defun property `%S' in %S"
(car x) name)
nil)))))
decls))
(def (list 'defalias
(list 'quote name)
(list 'function

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

@ -2505,7 +2505,8 @@ list that represents a doc string reference.
(when (memq sym byte-compile-lexical-variables)
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
(byte-compile-warn "Variable `%S' declared after its first use" sym))
(when (byte-compile-warning-enabled-p 'lexical sym)
(byte-compile-warn "Variable `%S' declared after its first use" sym)))
(push sym byte-compile-bound-variables)
(push sym byte-compile--seen-defvars))

11
lisp/emacs-lisp/checkdoc.el
View file

@ -241,7 +241,12 @@ system. Possible values are:
defun - Spell-check when style checking a single defun.
buffer - Spell-check when style checking the whole buffer.
interactive - Spell-check during any interactive check.
t - Always spell-check."
t - Always spell-check.
There is a list of Lisp-specific words which checkdoc will
install into Ispell on the fly, but only if Ispell is not already
running. Use `ispell-kill-ispell' to make checkdoc restart it
with these words enabled."
:type '(choice (const nil)
(const defun)
(const buffer)
@ -2357,7 +2362,9 @@ Code:, and others referenced in the style guide."
(checkdoc-create-error
(format "The footer should be: (provide '%s)\\n;;; %s%s ends here"
fn fn fe)
(1- (point-max)) (point-max)))))
;; The buffer may be empty.
(max (point-min) (1- (point-max)))
(point-max)))))
err))
;; The below checks will not return errors if the user says NO

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

@ -1,4 +1,4 @@
;;; crm.el --- read multiple strings with completion
;;; crm.el --- read multiple strings with completion -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1993-2021 Free Software Foundation, Inc.

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

@ -1,4 +1,4 @@
;;; derived.el --- allow inheritance of major modes
;;; derived.el --- allow inheritance of major modes -*- lexical-binding: t; -*-
;; (formerly mode-clone.el)
;; Copyright (C) 1993-1994, 1999, 2001-2021 Free Software Foundation,

2
lisp/emacs-lisp/eieio-opt.el
View file

@ -1,4 +1,4 @@
;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 1998-2003, 2005, 2008-2021 Free Software
;; Foundation, Inc.

9
lisp/emacs-lisp/generic.el
View file

@ -1,4 +1,4 @@
;;; generic.el --- defining simple major modes with comment and font-lock
;;; generic.el --- defining simple major modes with comment and font-lock -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
;;
@ -245,7 +245,6 @@ Some generic modes are defined in `generic-x.el'."
"Set up comment functionality for generic mode."
(let ((chars nil)
(comstyles)
(comstyle "")
(comment-start nil))
;; Go through all the comments.
@ -269,14 +268,16 @@ Some generic modes are defined in `generic-x.el'."
;; Store the relevant info but don't update yet.
(push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars)
(push (cons c1 (concat (cdr (assoc c1 chars))
(concat "2" comstyle))) chars)))
(concat "2" comstyle)))
chars)))
(if (= (length end) 1)
(modify-syntax-entry (aref end 0)
(concat ">" comstyle) st)
(let ((c0 (aref end 0)) (c1 (aref end 1)))
;; Store the relevant info but don't update yet.
(push (cons c0 (concat (cdr (assoc c0 chars))
(concat "3" comstyle))) chars)
(concat "3" comstyle)))
chars)
(push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars)))))
;; Process the chars that were part of a 2-char comment marker

29
lisp/emacs-lisp/helper.el
View file

@ -1,4 +1,4 @@
;;; helper.el --- utility help package supporting help in electric modes
;;; helper.el --- utility help package supporting help in electric modes -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@ -39,20 +39,19 @@
;; keymap either.
(defvar Helper-help-map nil)
(if Helper-help-map
nil
(setq Helper-help-map (make-keymap))
;(fillarray Helper-help-map 'undefined)
(define-key Helper-help-map "m" 'Helper-describe-mode)
(define-key Helper-help-map "b" 'Helper-describe-bindings)
(define-key Helper-help-map "c" 'Helper-describe-key-briefly)
(define-key Helper-help-map "k" 'Helper-describe-key)
;(define-key Helper-help-map "f" 'Helper-describe-function)
;(define-key Helper-help-map "v" 'Helper-describe-variable)
(define-key Helper-help-map "?" 'Helper-help-options)
(define-key Helper-help-map (char-to-string help-char) 'Helper-help-options)
(fset 'Helper-help-map Helper-help-map))
(defvar Helper-help-map
(let ((map (make-sparse-keymap)))
;(fillarray map 'undefined)
(define-key map "m" 'Helper-describe-mode)
(define-key map "b" 'Helper-describe-bindings)
(define-key map "c" 'Helper-describe-key-briefly)
(define-key map "k" 'Helper-describe-key)
;(define-key map "f" 'Helper-describe-function)
;(define-key map "v" 'Helper-describe-variable)
(define-key map "?" 'Helper-help-options)
(define-key map (char-to-string help-char) 'Helper-help-options)
(fset 'Helper-help-map map)
map))
(defun Helper-help-scroller ()
(let ((blurb (or (and (boundp 'Helper-return-blurb)

81
lisp/emacs-lisp/lisp-mode.el
View file

@ -200,42 +200,54 @@
res))
(defun lisp--el-non-funcall-position-p (pos)
"Heuristically determine whether POS is an evaluated position."
(declare (obsolete lisp--el-funcall-position-p "28.1"))
(not (lisp--el-funcall-position-p pos)))
(defun lisp--el-funcall-position-p (pos)
"Heuristically determine whether POS is an evaluated position."
(save-match-data
(save-excursion
(ignore-errors
(goto-char pos)
;; '(lambda ..) is not a funcall position, but #'(lambda ...) is.
(or (and (eql (char-before) ?\')
(not (eql (char-before (1- (point))) ?#)))
(let* ((ppss (syntax-ppss))
(paren-posns (nth 9 ppss))
(parent
(when paren-posns
(goto-char (car (last paren-posns))) ;(up-list -1)
(cond
((ignore-errors
(and (eql (char-after) ?\()
(when (cdr paren-posns)
(goto-char (car (last paren-posns 2)))
(looking-at "(\\_<let\\*?\\_>"))))
(goto-char (match-end 0))
'let)
((looking-at
(rx "("
(group-n 1 (+ (or (syntax w) (syntax _))))
symbol-end))
(prog1 (intern-soft (match-string-no-properties 1))
(goto-char (match-end 1))))))))
(or (eq parent 'declare)
(and (eq parent 'let)
(progn
(forward-sexp 1)
(< pos (point))))
(and (eq parent 'condition-case)
(progn
(forward-sexp 2)
(< (point) pos))))))))))
(if (eql (char-before) ?\')
(eql (char-before (1- (point))) ?#)
(let* ((ppss (syntax-ppss))
(paren-posns (nth 9 ppss))
(parent
(when paren-posns
(goto-char (car (last paren-posns))) ;(up-list -1)
(cond
((ignore-errors
(and (eql (char-after) ?\()
(when (cdr paren-posns)
(goto-char (car (last paren-posns 2)))
(looking-at "(\\_<let\\*?\\_>"))))
(goto-char (match-end 0))
'let)
((looking-at
(rx "("
(group-n 1 (+ (or (syntax w) (syntax _))))
symbol-end))
(prog1 (intern-soft (match-string-no-properties 1))
(goto-char (match-end 1))))))))
(pcase parent
('declare nil)
('let
(forward-sexp 1)
(>= pos (point)))
('condition-case
;; If (cdr paren-posns), then we're in the BODY
;; of HANDLERS.
(or (cdr paren-posns)
(progn
(forward-sexp 1)
;; If we're in the second form, then we're in
;; a funcall position.
(< (point) pos (progn (forward-sexp 1)
(point))))))
(_ t))))))))
(defun lisp--el-match-keyword (limit)
;; FIXME: Move to elisp-mode.el.
@ -245,11 +257,9 @@
(concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>"))
limit t)
(let ((sym (intern-soft (match-string 1))))
(when (or (special-form-p sym)
(and (macrop sym)
(not (get sym 'no-font-lock-keyword))
(not (lisp--el-non-funcall-position-p
(match-beginning 0)))))
(when (and (or (special-form-p sym) (macrop sym))
(not (get sym 'no-font-lock-keyword))
(lisp--el-funcall-position-p (match-beginning 0)))
(throw 'found t))))))
(defmacro let-when-compile (bindings &rest body)
@ -765,6 +775,7 @@ or to switch back to an existing one."
(setq-local find-tag-default-function 'lisp-find-tag-default)
(setq-local comment-start-skip
"\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *")
(setq-local comment-end "|#")
(setq imenu-case-fold-search t))
(defun lisp-find-tag-default ()

53
lisp/emacs-lisp/macroexp.el
View file

@ -127,7 +127,7 @@ and also to avoid outputting the warning during normal execution."
(cond
((null msg) form)
((macroexp--compiling-p)
(if (gethash form macroexp--warned)
(if (and (consp form) (gethash form macroexp--warned))
;; Already wrapped this exp with a warning: avoid inf-looping
;; where we keep adding the same warning onto `form' because
;; macroexpand-all gets right back to macroexpanding `form'.
@ -138,9 +138,10 @@ and also to avoid outputting the warning during normal execution."
,form)))
(t
(unless compile-only
(message "%s%s" (if (stringp load-file-name)
(concat (file-relative-name load-file-name) ": ")
"")
(message "%sWarning: %s"
(if (stringp load-file-name)
(concat (file-relative-name load-file-name) ": ")
"")
msg))
form))))
@ -180,8 +181,9 @@ and also to avoid outputting the warning during normal execution."
(defun macroexp-macroexpand (form env)
"Like `macroexpand' but checking obsolescence."
(let ((new-form
(macroexpand form env)))
(let* ((macroexpand-all-environment env)
(new-form
(macroexpand form env)))
(if (and (not (eq form new-form)) ;It was a macro call.
(car-safe form)
(symbolp (car form))
@ -239,9 +241,22 @@ Assumes the caller has bound `macroexpand-all-environment'."
form))
(`(,(and fun `(lambda . ,_)) . ,args)
;; Embedded lambda in function position.
(macroexp--cons (macroexp--all-forms fun 2)
(macroexp--all-forms args)
form))
;; If the byte-optimizer is loaded, try to unfold this,
;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer
;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
;; creation of a closure, thus resulting in much better code.
(let ((newform (if (not (fboundp 'byte-compile-unfold-lambda))
'macroexp--not-unfolded
;; Don't unfold if byte-opt is not yet loaded.
(byte-compile-unfold-lambda form))))
(if (or (eq newform 'macroexp--not-unfolded)
(eq newform form))
;; Unfolding failed for some reason, avoid infinite recursion.
(macroexp--cons (macroexp--all-forms fun 2)
(macroexp--all-forms args)
form)
(macroexp--expand-all newform))))
;; The following few cases are for normal function calls that
;; are known to funcall one of their arguments. The byte
;; compiler has traditionally handled these functions specially
@ -255,17 +270,21 @@ Assumes the caller has bound `macroexpand-all-environment'."
(macroexp--warn-and-return
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
(macroexp--expand-all `(,fun ,f . ,args))))
(macroexp--expand-all `(,fun #',f . ,args))))
;; Second arg is a function:
(`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
(macroexp--warn-and-return
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
(macroexp--expand-all `(,fun ,arg1 ,f . ,args))))
(`(funcall #',(and f (pred symbolp)) . ,args)
;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
;; has a compiler-macro.
(macroexp--expand-all `(,f . ,args)))
(macroexp--expand-all `(,fun ,arg1 #',f . ,args))))
(`(funcall ,exp . ,args)
(let ((eexp (macroexp--expand-all exp))
(eargs (macroexp--all-forms args)))
;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
;; has a compiler-macro, or to unfold it.
(pcase eexp
(`#',f (macroexp--expand-all `(,f . ,eargs)))
(_ `(funcall ,eexp . ,eargs)))))
(`(,func . ,_)
;; Macro expand compiler macros. This cannot be delayed to
;; byte-optimize-form because the output of the compiler-macro can
@ -358,12 +377,12 @@ Never returns an empty list."
(t
`(cond (,test ,@(macroexp-unprogn then))
(,(nth 1 else) ,@(macroexp-unprogn (nth 2 else)))
(t ,@(nthcdr 3 else))))))
,@(let ((def (nthcdr 3 else))) (if def `((t ,@def))))))))
((eq (car-safe else) 'cond)
`(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else)))
;; Invert the test if that lets us reduce the depth of the tree.
((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
(t `(if ,test ,then ,@(macroexp-unprogn else)))))
(t `(if ,test ,then ,@(if else (macroexp-unprogn else))))))
(defmacro macroexp-let2 (test sym exp &rest body)
"Evaluate BODY with SYM bound to an expression for EXP's value.

2
lisp/emacs-lisp/package-x.el
View file

@ -1,4 +1,4 @@
;;; package-x.el --- Package extras
;;; package-x.el --- Package extras -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.

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

@ -3260,9 +3260,9 @@ To unhide a package, type
`\\[customize-variable] RET package-hidden-regexps'.
Type \\[package-menu-toggle-hiding] to toggle package hiding."
(declare (interactive-only "change `package-hidden-regexps' instead."))
(interactive)
(package--ensure-package-menu-mode)
(declare (interactive-only "change `package-hidden-regexps' instead."))
(let* ((name (when (derived-mode-p 'package-menu-mode)
(concat "\\`" (regexp-quote (symbol-name (package-desc-name
(tabulated-list-get-id))))

44
lisp/emacs-lisp/pcase.el
View file

@ -683,11 +683,6 @@ A and B can be one of:
;; and catch at least the easy cases such as (bug#14773).
(not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
'(:pcase--succeed . :pcase--fail))
;; In case UPAT is of the form (pred (not PRED))
((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
(let* ((test (cadr (cadr upat)))
(res (pcase--split-pred vars `(pred ,test) pat)))
(cons (cdr res) (car res))))
;; In case PAT is of the form (pred (not PRED))
((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
(let* ((test (cadr (cadr pat)))
@ -696,19 +691,34 @@ A and B can be one of:
((eq x :pcase--fail) :pcase--succeed)))))
(cons (funcall reverse (car res))
(funcall reverse (cdr res)))))
((and (eq 'pred (car upat))
(let ((otherpred
(cond ((eq 'pred (car-safe pat)) (cadr pat))
((not (eq 'quote (car-safe pat))) nil)
((consp (cadr pat)) #'consp)
((stringp (cadr pat)) #'stringp)
((vectorp (cadr pat)) #'vectorp)
((byte-code-function-p (cadr pat))
#'byte-code-function-p))))
(pcase--mutually-exclusive-p (cadr upat) otherpred)))
;; All the rest below presumes UPAT is of the form (pred ...).
((not (eq 'pred (car upat))) nil)
;; In case UPAT is of the form (pred (not PRED))
((eq 'not (car-safe (cadr upat)))
(let* ((test (cadr (cadr upat)))
(res (pcase--split-pred vars `(pred ,test) pat)))
(cons (cdr res) (car res))))
((let ((otherpred
(cond ((eq 'pred (car-safe pat)) (cadr pat))
((not (eq 'quote (car-safe pat))) nil)
((consp (cadr pat)) #'consp)
((stringp (cadr pat)) #'stringp)
((vectorp (cadr pat)) #'vectorp)
((byte-code-function-p (cadr pat))
#'byte-code-function-p))))
(pcase--mutually-exclusive-p (cadr upat) otherpred))
'(:pcase--fail . nil))
((and (eq 'pred (car upat))
(eq 'quote (car-safe pat))
;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
;; try and preserve the info we get from that memq test.
((and (eq 'pcase--flip (car-safe (cadr upat)))
(memq (cadr (cadr upat)) '(memq member memql))
(eq 'quote (car-safe (nth 2 (cadr upat))))
(eq 'quote (car-safe pat)))
(let ((set (cadr (nth 2 (cadr upat)))))
(if (member (cadr pat) set)
'(nil . :pcase--fail)
'(:pcase--fail . nil))))
((and (eq 'quote (car-safe pat))
(symbolp (cadr upat))
(or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
(get (cadr upat) 'side-effect-free)

51
lisp/emacs-lisp/regi.el
View file

@ -1,4 +1,4 @@
;;; regi.el --- REGular expression Interpreting engine
;;; regi.el --- REGular expression Interpreting engine -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
@ -153,7 +153,7 @@ useful information:
;; set up the narrowed region
(and start
end
(let* ((tstart start)
(let* (;; (tstart start)
(start (min start end))
(end (max start end)))
(narrow-to-region
@ -206,30 +206,33 @@ useful information:
;; if the line matched, package up the argument list and
;; funcall the FUNC
(if match-p
(let* ((curline (buffer-substring
(regi-pos 'bol)
(regi-pos 'eol)))
(curframe current-frame)
(curentry entry)
(result (eval func))
(step (or (cdr (assq 'step result)) 1))
)
;; changing frame on the fly?
(if (assq 'frame result)
(setq working-frame (cdr (assq 'frame result))))
(with-suppressed-warnings
((lexical curframe curentry curline))
(defvar curframe) (defvar curentry) (defvar curline)
(let* ((curline (buffer-substring
(regi-pos 'bol)
(regi-pos 'eol)))
(curframe current-frame)
(curentry entry)
(result (eval func))
(step (or (cdr (assq 'step result)) 1))
)
;; changing frame on the fly?
(if (assq 'frame result)
(setq working-frame (cdr (assq 'frame result))))
;; continue processing current frame?
(if (memq 'continue result)
(setq current-frame (cdr current-frame))
(forward-line step)
(setq current-frame working-frame))
;; continue processing current frame?
(if (memq 'continue result)
(setq current-frame (cdr current-frame))
(forward-line step)
(setq current-frame working-frame))
;; abort current frame?
(if (memq 'abort result)
(progn
(setq donep t)
(throw 'regi-throw-top t)))
) ; end-let
;; abort current frame?
(if (memq 'abort result)
(progn
(setq donep t)
(throw 'regi-throw-top t)))
)) ; end-let
;; else if no match occurred, then process the next
;; frame-entry on the current line

22
lisp/emacs-lisp/shadow.el
View file

@ -1,4 +1,4 @@
;;; shadow.el --- locate Emacs Lisp file shadowings
;;; shadow.el --- locate Emacs Lisp file shadowings -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@ -58,8 +58,7 @@
(defcustom load-path-shadows-compare-text nil
"If non-nil, then shadowing files are reported only if their text differs.
This is slower, but filters out some innocuous shadowing."
:type 'boolean
:group 'lisp-shadow)
:type 'boolean)
(defun load-path-shadows-find (&optional path)
"Return a list of Emacs Lisp files that create shadows.
@ -78,8 +77,7 @@ See the documentation for `list-load-path-shadows' for further information."
dir-case-insensitive ; `file-name-case-insensitive-p' of dir.
curr-files ; This dir's Emacs Lisp files.
orig-dir ; Where the file was first seen.
files-seen-this-dir ; Files seen so far in this dir.
file) ; The current file.
files-seen-this-dir) ; Files seen so far in this dir.
(dolist (pp (or path load-path))
(setq dir (directory-file-name (file-truename (or pp "."))))
(if (member dir true-names)
@ -109,7 +107,7 @@ See the documentation for `list-load-path-shadows' for further information."
(dolist (file curr-files)
(if (string-match "\\.gz$" file)
(if (string-match "\\.gz\\'" file)
(setq file (substring file 0 -3)))
(setq file (substring
file 0 (if (string= (substring file -1) "c") -4 -3)))
@ -125,9 +123,13 @@ See the documentation for `list-load-path-shadows' for further information."
;; XXX.elc (or vice-versa) when they are in the same directory.
(setq files-seen-this-dir (cons file files-seen-this-dir))
(if (setq orig-dir (assoc file files
(when dir-case-insensitive
(lambda (f1 f2) (eq (compare-strings f1 nil nil f2 nil nil t) t)))))
(if (setq orig-dir
(assoc file files
(when dir-case-insensitive
(lambda (f1 f2)
(eq (compare-strings f1 nil nil
f2 nil nil t)
t)))))
;; This file was seen before, we have a shadowing.
;; Report it unless the files are identical.
(let ((base1 (concat (cdr orig-dir) "/" (car orig-dir)))
@ -142,7 +144,7 @@ See the documentation for `list-load-path-shadows' for further information."
(append shadows (list base1 base2)))))
;; Not seen before, add it to the list of seen files.
(setq files (cons (cons file dir) files)))))))
(push (cons file dir) files))))))
;; Return the list of shadowings.
shadows))

22
lisp/emacs-lisp/subr-x.el
View file

@ -389,6 +389,28 @@ it makes no sense to convert it to a string using
(set-buffer source-buffer)
(replace-buffer-contents tmp-buffer max-secs max-costs)))))))))
(defmacro named-let (name bindings &rest body)
"Looping construct taken from Scheme.
Like `let', bind variables in BINDINGS and then evaluate BODY,
but with the twist that BODY can evaluate itself recursively by
calling NAME, where the arguments passed to NAME are used
as the new values of the bound variables in the recursive invocation."
(declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
(require 'cl-lib)
(let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))
(aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)))
;; According to the Scheme semantics of named let, `name' is not in scope
;; while evaluating the expressions in `bindings', and for this reason, the
;; "initial" function call below needs to be outside of the `cl-labels'.
;; When the "self-tco" eliminates all recursive calls, the `cl-labels'
;; expands to a lambda which the byte-compiler then combines with the
;; funcall to make a `let' so we end up with a plain `while' loop and no
;; remaining `lambda' at all.
`(funcall
(cl-labels ((,name ,fargs . ,body)) #',name)
. ,aargs)))
(provide 'subr-x)
;;; subr-x.el ends here

32
lisp/emacs-lisp/tcover-ses.el
View file

@ -1,4 +1,4 @@
;;;; testcover-ses.el -- Example use of `testcover' to test "SES"
;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@ -19,21 +19,14 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; FIXME: Convert to ERT and move to `test/'?
;;; Code:
(require 'testcover)
(defvar ses-initial-global-parameters)
(defvar ses-mode-map)
(declare-function ses-set-curcell "ses")
(declare-function ses-update-cells "ses")
(declare-function ses-load "ses")
(declare-function ses-vector-delete "ses")
(declare-function ses-create-header-string "ses")
(declare-function ses-read-cell "ses")
(declare-function ses-read-symbol "ses")
(declare-function ses-command-hook "ses")
(declare-function ses-jump "ses")
(require 'ses)
;;;Here are some macros that exercise SES. Set `pause' to t if you want the
;;;macros to pause after each step.
@ -652,6 +645,7 @@ spreadsheet files with invalid formatting."
(testcover-start "ses.el" t))
(require 'unsafep)) ;In case user has safe-functions = t!
(defvar ses--curcell-overlay)
;;;#########################################################################
(defun ses-exercise ()
@ -674,8 +668,8 @@ spreadsheet files with invalid formatting."
(ses-load))
;;ses-vector-delete is always called from buffer-undo-list with the same
;;symbol as argument. We'll give it a different one here.
(let ((x [1 2 3]))
(ses-vector-delete 'x 0 0))
(dlet ((tcover-ses--x [1 2 3]))
(ses-vector-delete 'tcover-ses--x 0 0))
;;ses-create-header-string behaves differently in a non-window environment
;;but we always test under windows.
(let ((window-system (not window-system)))
@ -704,7 +698,7 @@ spreadsheet files with invalid formatting."
(ses-mode)))))
;;Test error-handling in command hook, outside a macro.
;;This will ring the bell.
(let (curcell-overlay)
(let (ses--curcell-overlay)
(ses-command-hook))
;;Due to use of run-with-timer, ses-command-hook sometimes gets called
;;after we switch to another buffer.
@ -720,4 +714,4 @@ spreadsheet files with invalid formatting."
;;Could do this here: (testcover-end "ses.el")
(message "Done"))
;; testcover-ses.el ends here.
;;; testcover-ses.el ends here.

9
lisp/emacs-lisp/unsafep.el
View file

@ -1,4 +1,4 @@
;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate
;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@ -129,15 +129,16 @@ in the parse.")
(put x 'safe-function t))
;;;###autoload
(defun unsafep (form &optional unsafep-vars)
(defun unsafep (form &optional vars)
"Return nil if evaluating FORM couldn't possibly do any harm.
Otherwise result is a reason why FORM is unsafe.
UNSAFEP-VARS is a list of symbols with local bindings."
VARS is a list of symbols with local bindings like `unsafep-vars'."
(catch 'unsafep
(if (or (eq safe-functions t) ;User turned off safety-checking
(atom form)) ;Atoms are never unsafe
(throw 'unsafep nil))
(let* ((fun (car form))
(let* ((unsafep-vars vars)
(fun (car form))
(reason (unsafep-function fun))
arg)
(cond

8
lisp/emulation/cua-gmrk.el
View file

@ -87,9 +87,11 @@
(defun cua-toggle-global-mark (stay)
"Set or cancel the global marker.
When the global marker is set, CUA cut and copy commands will automatically
insert the deleted or copied text before the global marker, even when the
global marker is in another buffer.
When the global marker is set, CUA cut and copy commands will
automatically insert the inserted, deleted or copied text before
the global marker, even when the global marker is in another
buffer.
If the global marker isn't set, set the global marker at point in the current
buffer. Otherwise jump to the global marker position and cancel it.
With prefix argument, don't jump to global mark when canceling it."

Some files were not shown because too many files have changed in this diff Show more