diff options
| author | Andrea Corallo | 2021-01-24 21:05:33 +0100 |
|---|---|---|
| committer | Andrea Corallo | 2021-01-24 21:05:33 +0100 |
| commit | b8d3ae78c54db7c7bb65d367a80f9be3d8744c48 (patch) | |
| tree | 982f190d1dd79685c43a9829dd66e6a7cbbd0c67 | |
| parent | 0ffb3dfaa483b0c5cf1f7f367efcb5e9c041ab53 (diff) | |
| parent | e5aaa1251cfb9d6d18682a5eda137a2e12ca4213 (diff) | |
| download | emacs-b8d3ae78c54db7c7bb65d367a80f9be3d8744c48.tar.gz emacs-b8d3ae78c54db7c7bb65d367a80f9be3d8744c48.zip | |
Merge remote-tracking branch 'savannah/master' into native-comp
194 files changed, 5187 insertions, 2655 deletions
diff --git a/.clang-format b/.clang-format index 9ab09a86ff2..44200a39952 100644 --- a/.clang-format +++ b/.clang-format | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | Language: Cpp | 1 | Language: Cpp |
| 2 | BasedOnStyle: LLVM | 2 | BasedOnStyle: GNU |
| 3 | AlignEscapedNewlinesLeft: true | 3 | AlignEscapedNewlinesLeft: true |
| 4 | AlwaysBreakAfterReturnType: TopLevelDefinitions | 4 | AlwaysBreakAfterReturnType: TopLevelDefinitions |
| 5 | BreakBeforeBinaryOperators: All | 5 | BreakBeforeBinaryOperators: All |
diff --git a/.gitignore b/.gitignore index 63fa4203b58..4c7c1ad61b7 100644 --- a/.gitignore +++ b/.gitignore | |||
| @@ -299,4 +299,3 @@ nt/emacs.rc | |||
| 299 | nt/emacsclient.rc | 299 | nt/emacsclient.rc |
| 300 | src/gdb.ini | 300 | src/gdb.ini |
| 301 | /var/ | 301 | /var/ |
| 302 | src/fingerprint.c | ||
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1be92cff161..acc1649bdab 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | # Copyright (C) 2017-2021 Free Software Foundation, Inc. | 1 | # Copyright (C) 2021 Free Software Foundation, Inc. |
| 2 | # | 2 | # |
| 3 | # This file is part of GNU Emacs. | 3 | # This file is part of GNU Emacs. |
| 4 | # | 4 | # |
| @@ -194,3 +194,5 @@ test-all: | |||
| 194 | variables: | 194 | variables: |
| 195 | target: emacs-inotify | 195 | target: emacs-inotify |
| 196 | make_params: check-expensive | 196 | make_params: check-expensive |
| 197 | # Just load from test/infra, to keep build automation files there. | ||
| 198 | include: '/test/infra/gitlab-ci.yml' | ||
diff --git a/build-aux/config.guess b/build-aux/config.guess index 7f748177972..f7727026b70 100755 --- a/build-aux/config.guess +++ b/build-aux/config.guess | |||
| @@ -1,8 +1,8 @@ | |||
| 1 | #! /bin/sh | 1 | #! /bin/sh |
| 2 | # Attempt to guess a canonical system name. | 2 | # Attempt to guess a canonical system name. |
| 3 | # Copyright 1992-2020 Free Software Foundation, Inc. | 3 | # Copyright 1992-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | timestamp='2020-12-22' | 5 | timestamp='2021-01-01' |
| 6 | 6 | ||
| 7 | # This file is free software; you can redistribute it and/or modify it | 7 | # This file is free software; you can redistribute it and/or modify it |
| 8 | # under the terms of the GNU General Public License as published by | 8 | # under the terms of the GNU General Public License as published by |
| @@ -50,7 +50,7 @@ version="\ | |||
| 50 | GNU config.guess ($timestamp) | 50 | GNU config.guess ($timestamp) |
| 51 | 51 | ||
| 52 | Originally written by Per Bothner. | 52 | Originally written by Per Bothner. |
| 53 | Copyright 1992-2020 Free Software Foundation, Inc. | 53 | Copyright 1992-2021 Free Software Foundation, Inc. |
| 54 | 54 | ||
| 55 | This is free software; see the source for copying conditions. There is NO | 55 | This is free software; see the source for copying conditions. There is NO |
| 56 | warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." | 56 | warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." |
| @@ -1087,7 +1087,7 @@ EOF | |||
| 1087 | ppcle:Linux:*:*) | 1087 | ppcle:Linux:*:*) |
| 1088 | echo powerpcle-unknown-linux-"$LIBC" | 1088 | echo powerpcle-unknown-linux-"$LIBC" |
| 1089 | exit ;; | 1089 | exit ;; |
| 1090 | riscv32:Linux:*:* | riscv64:Linux:*:*) | 1090 | riscv32:Linux:*:* | riscv32be:Linux:*:* | riscv64:Linux:*:* | riscv64be:Linux:*:*) |
| 1091 | echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" | 1091 | echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" |
| 1092 | exit ;; | 1092 | exit ;; |
| 1093 | s390:Linux:*:* | s390x:Linux:*:*) | 1093 | s390:Linux:*:* | s390x:Linux:*:*) |
diff --git a/build-aux/config.sub b/build-aux/config.sub index 90bb8aeda63..b0f8492348d 100755 --- a/build-aux/config.sub +++ b/build-aux/config.sub | |||
| @@ -1,8 +1,8 @@ | |||
| 1 | #! /bin/sh | 1 | #! /bin/sh |
| 2 | # Configuration validation subroutine script. | 2 | # Configuration validation subroutine script. |
| 3 | # Copyright 1992-2020 Free Software Foundation, Inc. | 3 | # Copyright 1992-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | timestamp='2020-12-22' | 5 | timestamp='2021-01-07' |
| 6 | 6 | ||
| 7 | # This file is free software; you can redistribute it and/or modify it | 7 | # This file is free software; you can redistribute it and/or modify it |
| 8 | # under the terms of the GNU General Public License as published by | 8 | # under the terms of the GNU General Public License as published by |
| @@ -67,7 +67,7 @@ Report bugs and patches to <config-patches@gnu.org>." | |||
| 67 | version="\ | 67 | version="\ |
| 68 | GNU config.sub ($timestamp) | 68 | GNU config.sub ($timestamp) |
| 69 | 69 | ||
| 70 | Copyright 1992-2020 Free Software Foundation, Inc. | 70 | Copyright 1992-2021 Free Software Foundation, Inc. |
| 71 | 71 | ||
| 72 | This is free software; see the source for copying conditions. There is NO | 72 | This is free software; see the source for copying conditions. There is NO |
| 73 | warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." | 73 | warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." |
| @@ -1230,7 +1230,7 @@ case $cpu-$vendor in | |||
| 1230 | | powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \ | 1230 | | powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \ |
| 1231 | | pru \ | 1231 | | pru \ |
| 1232 | | pyramid \ | 1232 | | pyramid \ |
| 1233 | | riscv | riscv32 | riscv64 \ | 1233 | | riscv | riscv32 | riscv32be | riscv64 | riscv64be \ |
| 1234 | | rl78 | romp | rs6000 | rx \ | 1234 | | rl78 | romp | rs6000 | rx \ |
| 1235 | | s390 | s390x \ | 1235 | | s390 | s390x \ |
| 1236 | | score \ | 1236 | | score \ |
| @@ -1687,7 +1687,7 @@ case $os in | |||
| 1687 | musl* | newlib* | uclibc*) | 1687 | musl* | newlib* | uclibc*) |
| 1688 | ;; | 1688 | ;; |
| 1689 | # Likewise for "kernel-libc" | 1689 | # Likewise for "kernel-libc" |
| 1690 | eabi | eabihf | gnueabi | gnueabihf) | 1690 | eabi* | gnueabi*) |
| 1691 | ;; | 1691 | ;; |
| 1692 | # Now accept the basic system types. | 1692 | # Now accept the basic system types. |
| 1693 | # The portable systems comes first. | 1693 | # The portable systems comes first. |
diff --git a/configure.ac b/configure.ac index 1bff666ad50..4691d5785a6 100644 --- a/configure.ac +++ b/configure.ac | |||
| @@ -6011,7 +6011,7 @@ if test $AUTO_DEPEND = yes; then | |||
| 6011 | AS_MKDIR_P([$dir/deps]) | 6011 | AS_MKDIR_P([$dir/deps]) |
| 6012 | done | 6012 | done |
| 6013 | fi | 6013 | fi |
| 6014 | if $gl_gnulib_enabled_scratch_buffer; then | 6014 | if $gl_gnulib_enabled_dynarray || $gl_gnulib_enabled_scratch_buffer; then |
| 6015 | AS_MKDIR_P([lib/malloc]) | 6015 | AS_MKDIR_P([lib/malloc]) |
| 6016 | if test $AUTO_DEPEND = yes; then | 6016 | if test $AUTO_DEPEND = yes; then |
| 6017 | AS_MKDIR_P([lib/deps/malloc]) | 6017 | AS_MKDIR_P([lib/deps/malloc]) |
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 55bcddb31aa..80e9eb7dd8e 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi | |||
| @@ -557,8 +557,9 @@ Likewise, it makes no sense to bind keyword symbols | |||
| 557 | 557 | ||
| 558 | @item (pred @var{function}) | 558 | @item (pred @var{function}) |
| 559 | Matches if the predicate @var{function} returns non-@code{nil} | 559 | Matches if the predicate @var{function} returns non-@code{nil} |
| 560 | when called on @var{expval}. | 560 | when called on @var{expval}. The test can be negated with the syntax |
| 561 | the predicate @var{function} can have one of the following forms: | 561 | @code{(pred (not @var{function}))}. |
| 562 | The predicate @var{function} can have one of the following forms: | ||
| 562 | 563 | ||
| 563 | @table @asis | 564 | @table @asis |
| 564 | @item function name (a symbol) | 565 | @item function name (a symbol) |
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 37bab7ea9bc..55d179b8753 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi | |||
| @@ -2852,9 +2852,8 @@ Here is how to insert an item called @samp{Work} in the @samp{Signals} | |||
| 2852 | menu of Shell mode, after the item @code{break}: | 2852 | menu of Shell mode, after the item @code{break}: |
| 2853 | 2853 | ||
| 2854 | @example | 2854 | @example |
| 2855 | (define-key-after | 2855 | (define-key-after shell-mode-map [menu-bar signals work] |
| 2856 | (lookup-key shell-mode-map [menu-bar signals]) | 2856 | '("Work" . work-command) 'break) |
| 2857 | [work] '("Work" . work-command) 'break) | ||
| 2858 | @end example | 2857 | @end example |
| 2859 | @end defun | 2858 | @end defun |
| 2860 | 2859 | ||
diff --git a/doc/lispref/markers.texi b/doc/lispref/markers.texi index cdd0938b458..b39373f0727 100644 --- a/doc/lispref/markers.texi +++ b/doc/lispref/markers.texi | |||
| @@ -560,7 +560,9 @@ deactivate the mark. If the value is @w{@code{(only . @var{oldval})}}, | |||
| 560 | then @code{transient-mark-mode} is set to the value @var{oldval} after | 560 | then @code{transient-mark-mode} is set to the value @var{oldval} after |
| 561 | any subsequent command that moves point and is not shift-translated | 561 | any subsequent command that moves point and is not shift-translated |
| 562 | (@pxref{Key Sequence Input, shift-translation}), or after any other | 562 | (@pxref{Key Sequence Input, shift-translation}), or after any other |
| 563 | action that would normally deactivate the mark. | 563 | action that would normally deactivate the mark. (Marking a region |
| 564 | with the mouse will temporarily enable @code{transient-mark-mode} in | ||
| 565 | this way.) | ||
| 564 | @end defopt | 566 | @end defopt |
| 565 | 567 | ||
| 566 | @defopt mark-even-if-inactive | 568 | @defopt mark-even-if-inactive |
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 535cebed7a8..6dedaa31f2e 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi | |||
| @@ -729,7 +729,9 @@ coding systems (@pxref{Default Coding Systems}). On the other hand, | |||
| 729 | it will use @var{query-flag} as its query-on-exit flag (@pxref{Query | 729 | it will use @var{query-flag} as its query-on-exit flag (@pxref{Query |
| 730 | Before Exit}). It will be associated with the @var{stderr} buffer | 730 | Before Exit}). It will be associated with the @var{stderr} buffer |
| 731 | (@pxref{Process Buffers}) and send its output (which is the standard | 731 | (@pxref{Process Buffers}) and send its output (which is the standard |
| 732 | error of the main process) there. | 732 | error of the main process) there. To get the process object for the |
| 733 | standard error process, pass the @var{stderr} buffer to | ||
| 734 | @code{get-buffer-process}. | ||
| 733 | 735 | ||
| 734 | If @var{stderr} is a pipe process, Emacs will use it as standard error | 736 | If @var{stderr} is a pipe process, Emacs will use it as standard error |
| 735 | process for the new process. | 737 | process for the new process. |
| @@ -1942,6 +1944,29 @@ code: | |||
| 1942 | (while (accept-process-output stderr-process)) | 1944 | (while (accept-process-output stderr-process)) |
| 1943 | @end example | 1945 | @end example |
| 1944 | 1946 | ||
| 1947 | If you passed a buffer to the @var{stderr} argument of | ||
| 1948 | @code{make-process}, you still have to wait for the standard error | ||
| 1949 | process, like so: | ||
| 1950 | |||
| 1951 | @example | ||
| 1952 | (let* ((stdout (generate-new-buffer "stdout")) | ||
| 1953 | (stderr (generate-new-buffer "stderr")) | ||
| 1954 | (process (make-process :name "test" | ||
| 1955 | :command '("my-program") | ||
| 1956 | :buffer stdout | ||
| 1957 | :stderr stderr)) | ||
| 1958 | (stderr-process (get-buffer-process stderr))) | ||
| 1959 | (unless (and process stderr-process) | ||
| 1960 | (error "Process unexpectedly nil")) | ||
| 1961 | (while (accept-process-output process)) | ||
| 1962 | (while (accept-process-output stderr-process))) | ||
| 1963 | @end example | ||
| 1964 | |||
| 1965 | @noindent | ||
| 1966 | Only when both @code{accept-process-output} forms return @code{nil}, | ||
| 1967 | you can be sure that the process has exited and Emacs has read all its | ||
| 1968 | output. | ||
| 1969 | |||
| 1945 | Reading pending standard error from a process running on a remote host | 1970 | Reading pending standard error from a process running on a remote host |
| 1946 | is not possible this way. | 1971 | is not possible this way. |
| 1947 | 1972 | ||
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 0b567d82c61..14854a5aafa 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi | |||
| @@ -334,6 +334,25 @@ but there is no peace. | |||
| 334 | (thing-at-point 'whitespace) | 334 | (thing-at-point 'whitespace) |
| 335 | @result{} nil | 335 | @result{} nil |
| 336 | @end example | 336 | @end example |
| 337 | |||
| 338 | @defvar thing-at-point-provider-alist | ||
| 339 | This variable allows users and modes to tweak how | ||
| 340 | @code{thing-at-point} works. It's an association list of @var{thing}s | ||
| 341 | and functions (called with zero parameters) to return that thing. | ||
| 342 | Entries for @var{thing} will be evaluated in turn until a | ||
| 343 | non-@code{nil} result is returned. | ||
| 344 | |||
| 345 | For instance, a major mode could say: | ||
| 346 | |||
| 347 | @lisp | ||
| 348 | (setq-local thing-at-point-provider-alist | ||
| 349 | (append thing-at-point-provider-alist | ||
| 350 | '((url . my-mode--url-at-point)))) | ||
| 351 | @end lisp | ||
| 352 | |||
| 353 | If no providers have a non-@code{nil} return, the @var{thing} will be | ||
| 354 | computed the standard way. | ||
| 355 | @end defvar | ||
| 337 | @end defun | 356 | @end defun |
| 338 | 357 | ||
| 339 | @node Comparing Text | 358 | @node Comparing Text |
| @@ -5610,6 +5629,11 @@ This function cancels and undoes all the changes in the change group | |||
| 5610 | specified by @var{handle}. | 5629 | specified by @var{handle}. |
| 5611 | @end defun | 5630 | @end defun |
| 5612 | 5631 | ||
| 5632 | @defun undo-amalgamate-change-group | ||
| 5633 | Amalgamate changes in change-group since @var{handle}. I.e., remove | ||
| 5634 | all undo boundaries between the state of @var{handle} and now. | ||
| 5635 | @end defun | ||
| 5636 | |||
| 5613 | Your code should use @code{unwind-protect} to make sure the group is | 5637 | Your code should use @code{unwind-protect} to make sure the group is |
| 5614 | always finished. The call to @code{activate-change-group} should be | 5638 | always finished. The call to @code{activate-change-group} should be |
| 5615 | inside the @code{unwind-protect}, in case the user types @kbd{C-g} | 5639 | inside the @code{unwind-protect}, in case the user types @kbd{C-g} |
diff --git a/doc/misc/message.texi b/doc/misc/message.texi index f2680b4a797..be6c9a419b2 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi | |||
| @@ -317,6 +317,12 @@ when forwarding a message. | |||
| 317 | In non-@code{nil}, only headers that match this regexp will be kept | 317 | In non-@code{nil}, only headers that match this regexp will be kept |
| 318 | when forwarding a message. This can also be a list of regexps. | 318 | when forwarding a message. This can also be a list of regexps. |
| 319 | 319 | ||
| 320 | @item message-forward-included-mime-headers | ||
| 321 | @vindex message-forward-included-mime-headers | ||
| 322 | In non-@code{nil}, headers that match this regexp will be kept when | ||
| 323 | forwarding a message as @acronym{MIME}, but @acronym{MML} isn't used. | ||
| 324 | This can also be a list of regexps. | ||
| 325 | |||
| 320 | @item message-make-forward-subject-function | 326 | @item message-make-forward-subject-function |
| 321 | @vindex message-make-forward-subject-function | 327 | @vindex message-make-forward-subject-function |
| 322 | A list of functions that are called to generate a subject header for | 328 | A list of functions that are called to generate a subject header for |
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex index 3c7051d1c74..dac7ae3d199 100644 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex | |||
| @@ -3,7 +3,7 @@ | |||
| 3 | % Load plain if necessary, i.e., if running under initex. | 3 | % Load plain if necessary, i.e., if running under initex. |
| 4 | \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi | 4 | \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi |
| 5 | % | 5 | % |
| 6 | \def\texinfoversion{2020-10-24.12} | 6 | \def\texinfoversion{2020-11-25.18} |
| 7 | % | 7 | % |
| 8 | % Copyright 1985, 1986, 1988, 1990-2020 Free Software Foundation, Inc. | 8 | % Copyright 1985, 1986, 1988, 1990-2020 Free Software Foundation, Inc. |
| 9 | % | 9 | % |
| @@ -572,10 +572,9 @@ | |||
| 572 | \fi | 572 | \fi |
| 573 | } | 573 | } |
| 574 | 574 | ||
| 575 | % @end foo executes the definition of \Efoo. | 575 | |
| 576 | % But first, it executes a specialized version of \checkenv | 576 | % @end foo calls \checkenv and executes the definition of \Efoo. |
| 577 | % | 577 | \parseargdef\end{ |
| 578 | \parseargdef\end{% | ||
| 579 | \if 1\csname iscond.#1\endcsname | 578 | \if 1\csname iscond.#1\endcsname |
| 580 | \else | 579 | \else |
| 581 | % The general wording of \badenverr may not be ideal. | 580 | % The general wording of \badenverr may not be ideal. |
| @@ -2673,8 +2672,6 @@ end | |||
| 2673 | \definetextfontsizexi | 2672 | \definetextfontsizexi |
| 2674 | 2673 | ||
| 2675 | 2674 | ||
| 2676 | \message{markup,} | ||
| 2677 | |||
| 2678 | % Check if we are currently using a typewriter font. Since all the | 2675 | % Check if we are currently using a typewriter font. Since all the |
| 2679 | % Computer Modern typewriter fonts have zero interword stretch (and | 2676 | % Computer Modern typewriter fonts have zero interword stretch (and |
| 2680 | % shrink), and it is reasonable to expect all typewriter fonts to have | 2677 | % shrink), and it is reasonable to expect all typewriter fonts to have |
| @@ -2682,68 +2679,14 @@ end | |||
| 2682 | % | 2679 | % |
| 2683 | \def\ifmonospace{\ifdim\fontdimen3\font=0pt } | 2680 | \def\ifmonospace{\ifdim\fontdimen3\font=0pt } |
| 2684 | 2681 | ||
| 2685 | % Markup style infrastructure. \defmarkupstylesetup\INITMACRO will | ||
| 2686 | % define and register \INITMACRO to be called on markup style changes. | ||
| 2687 | % \INITMACRO can check \currentmarkupstyle for the innermost | ||
| 2688 | % style. | ||
| 2689 | |||
| 2690 | \let\currentmarkupstyle\empty | ||
| 2691 | |||
| 2692 | \def\setupmarkupstyle#1{% | ||
| 2693 | \def\currentmarkupstyle{#1}% | ||
| 2694 | \markupstylesetup | ||
| 2695 | } | ||
| 2696 | |||
| 2697 | \let\markupstylesetup\empty | ||
| 2698 | |||
| 2699 | \def\defmarkupstylesetup#1{% | ||
| 2700 | \expandafter\def\expandafter\markupstylesetup | ||
| 2701 | \expandafter{\markupstylesetup #1}% | ||
| 2702 | \def#1% | ||
| 2703 | } | ||
| 2704 | |||
| 2705 | % Markup style setup for left and right quotes. | ||
| 2706 | \defmarkupstylesetup\markupsetuplq{% | ||
| 2707 | \expandafter\let\expandafter \temp | ||
| 2708 | \csname markupsetuplq\currentmarkupstyle\endcsname | ||
| 2709 | \ifx\temp\relax \markupsetuplqdefault \else \temp \fi | ||
| 2710 | } | ||
| 2711 | |||
| 2712 | \defmarkupstylesetup\markupsetuprq{% | ||
| 2713 | \expandafter\let\expandafter \temp | ||
| 2714 | \csname markupsetuprq\currentmarkupstyle\endcsname | ||
| 2715 | \ifx\temp\relax \markupsetuprqdefault \else \temp \fi | ||
| 2716 | } | ||
| 2717 | |||
| 2718 | { | 2682 | { |
| 2719 | \catcode`\'=\active | 2683 | \catcode`\'=\active |
| 2720 | \catcode`\`=\active | 2684 | \catcode`\`=\active |
| 2721 | 2685 | ||
| 2722 | \gdef\markupsetuplqdefault{\let`\lq} | 2686 | \gdef\setcodequotes{\let`\codequoteleft \let'\codequoteright} |
| 2723 | \gdef\markupsetuprqdefault{\let'\rq} | 2687 | \gdef\setregularquotes{\let`\lq \let'\rq} |
| 2724 | |||
| 2725 | \gdef\markupsetcodequoteleft{\let`\codequoteleft} | ||
| 2726 | \gdef\markupsetcodequoteright{\let'\codequoteright} | ||
| 2727 | } | 2688 | } |
| 2728 | 2689 | ||
| 2729 | \let\markupsetuplqcode \markupsetcodequoteleft | ||
| 2730 | \let\markupsetuprqcode \markupsetcodequoteright | ||
| 2731 | % | ||
| 2732 | \let\markupsetuplqexample \markupsetcodequoteleft | ||
| 2733 | \let\markupsetuprqexample \markupsetcodequoteright | ||
| 2734 | % | ||
| 2735 | \let\markupsetuplqkbd \markupsetcodequoteleft | ||
| 2736 | \let\markupsetuprqkbd \markupsetcodequoteright | ||
| 2737 | % | ||
| 2738 | \let\markupsetuplqsamp \markupsetcodequoteleft | ||
| 2739 | \let\markupsetuprqsamp \markupsetcodequoteright | ||
| 2740 | % | ||
| 2741 | \let\markupsetuplqverb \markupsetcodequoteleft | ||
| 2742 | \let\markupsetuprqverb \markupsetcodequoteright | ||
| 2743 | % | ||
| 2744 | \let\markupsetuplqverbatim \markupsetcodequoteleft | ||
| 2745 | \let\markupsetuprqverbatim \markupsetcodequoteright | ||
| 2746 | |||
| 2747 | % Allow an option to not use regular directed right quote/apostrophe | 2690 | % Allow an option to not use regular directed right quote/apostrophe |
| 2748 | % (char 0x27), but instead the undirected quote from cmtt (char 0x0d). | 2691 | % (char 0x27), but instead the undirected quote from cmtt (char 0x0d). |
| 2749 | % The undirected quote is ugly, so don't make it the default, but it | 2692 | % The undirected quote is ugly, so don't make it the default, but it |
| @@ -2906,7 +2849,7 @@ end | |||
| 2906 | } | 2849 | } |
| 2907 | 2850 | ||
| 2908 | % @samp. | 2851 | % @samp. |
| 2909 | \def\samp#1{{\setupmarkupstyle{samp}\lq\tclose{#1}\rq\null}} | 2852 | \def\samp#1{{\setcodequotes\lq\tclose{#1}\rq\null}} |
| 2910 | 2853 | ||
| 2911 | % @indicateurl is \samp, that is, with quotes. | 2854 | % @indicateurl is \samp, that is, with quotes. |
| 2912 | \let\indicateurl=\samp | 2855 | \let\indicateurl=\samp |
| @@ -2949,8 +2892,7 @@ end | |||
| 2949 | \global\let'=\rq \global\let`=\lq % default definitions | 2892 | \global\let'=\rq \global\let`=\lq % default definitions |
| 2950 | % | 2893 | % |
| 2951 | \global\def\code{\begingroup | 2894 | \global\def\code{\begingroup |
| 2952 | \setupmarkupstyle{code}% | 2895 | \setcodequotes |
| 2953 | % The following should really be moved into \setupmarkupstyle handlers. | ||
| 2954 | \catcode\dashChar=\active \catcode\underChar=\active | 2896 | \catcode\dashChar=\active \catcode\underChar=\active |
| 2955 | \ifallowcodebreaks | 2897 | \ifallowcodebreaks |
| 2956 | \let-\codedash | 2898 | \let-\codedash |
| @@ -3104,7 +3046,7 @@ end | |||
| 3104 | \urefcatcodes | 3046 | \urefcatcodes |
| 3105 | % | 3047 | % |
| 3106 | \global\def\urefcode{\begingroup | 3048 | \global\def\urefcode{\begingroup |
| 3107 | \setupmarkupstyle{code}% | 3049 | \setcodequotes |
| 3108 | \urefcatcodes | 3050 | \urefcatcodes |
| 3109 | \let&\urefcodeamp | 3051 | \let&\urefcodeamp |
| 3110 | \let.\urefcodedot | 3052 | \let.\urefcodedot |
| @@ -3225,8 +3167,8 @@ end | |||
| 3225 | \def\kbdsub#1#2#3\par{% | 3167 | \def\kbdsub#1#2#3\par{% |
| 3226 | \def\one{#1}\def\three{#3}\def\threex{??}% | 3168 | \def\one{#1}\def\three{#3}\def\threex{??}% |
| 3227 | \ifx\one\xkey\ifx\threex\three \key{#2}% | 3169 | \ifx\one\xkey\ifx\threex\three \key{#2}% |
| 3228 | \else{\tclose{\kbdfont\setupmarkupstyle{kbd}\look}}\fi | 3170 | \else{\tclose{\kbdfont\setcodequotes\look}}\fi |
| 3229 | \else{\tclose{\kbdfont\setupmarkupstyle{kbd}\look}}\fi | 3171 | \else{\tclose{\kbdfont\setcodequotes\look}}\fi |
| 3230 | } | 3172 | } |
| 3231 | 3173 | ||
| 3232 | % definition of @key that produces a lozenge. Doesn't adjust to text size. | 3174 | % definition of @key that produces a lozenge. Doesn't adjust to text size. |
| @@ -3243,7 +3185,7 @@ end | |||
| 3243 | % monospace, don't change it; that way, we respect @kbdinputstyle. But | 3185 | % monospace, don't change it; that way, we respect @kbdinputstyle. But |
| 3244 | % if it isn't monospace, then use \tt. | 3186 | % if it isn't monospace, then use \tt. |
| 3245 | % | 3187 | % |
| 3246 | \def\key#1{{\setupmarkupstyle{key}% | 3188 | \def\key#1{{\setregularquotes |
| 3247 | \nohyphenation | 3189 | \nohyphenation |
| 3248 | \ifmonospace\else\tt\fi | 3190 | \ifmonospace\else\tt\fi |
| 3249 | #1}\null} | 3191 | #1}\null} |
| @@ -3373,16 +3315,20 @@ end | |||
| 3373 | {\obeylines | 3315 | {\obeylines |
| 3374 | \globaldefs=1 | 3316 | \globaldefs=1 |
| 3375 | \envdef\displaymath{% | 3317 | \envdef\displaymath{% |
| 3376 | \tex | 3318 | \tex% |
| 3377 | \def\thisenv{\displaymath}% | 3319 | \def\thisenv{\displaymath}% |
| 3320 | \begingroup\let\end\displaymathend% | ||
| 3378 | $$% | 3321 | $$% |
| 3379 | } | 3322 | } |
| 3380 | 3323 | ||
| 3381 | \def\Edisplaymath{$$ | 3324 | \def\displaymathend{$$\endgroup\end}% |
| 3325 | |||
| 3326 | \def\Edisplaymath{% | ||
| 3382 | \def\thisenv{\tex}% | 3327 | \def\thisenv{\tex}% |
| 3383 | \end tex | 3328 | \end tex |
| 3384 | }} | 3329 | }} |
| 3385 | 3330 | ||
| 3331 | |||
| 3386 | % @inlinefmt{FMTNAME,PROCESSED-TEXT} and @inlineraw{FMTNAME,RAW-TEXT}. | 3332 | % @inlinefmt{FMTNAME,PROCESSED-TEXT} and @inlineraw{FMTNAME,RAW-TEXT}. |
| 3387 | % Ignore unless FMTNAME == tex; then it is like @iftex and @tex, | 3333 | % Ignore unless FMTNAME == tex; then it is like @iftex and @tex, |
| 3388 | % except specified as a normal braced arg, so no newlines to worry about. | 3334 | % except specified as a normal braced arg, so no newlines to worry about. |
| @@ -7144,7 +7090,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 7144 | % But \@ or @@ will get a plain @ character. | 7090 | % But \@ or @@ will get a plain @ character. |
| 7145 | 7091 | ||
| 7146 | \envdef\tex{% | 7092 | \envdef\tex{% |
| 7147 | \setupmarkupstyle{tex}% | 7093 | \setregularquotes |
| 7148 | \catcode `\\=0 \catcode `\{=1 \catcode `\}=2 | 7094 | \catcode `\\=0 \catcode `\{=1 \catcode `\}=2 |
| 7149 | \catcode `\$=3 \catcode `\&=4 \catcode `\#=6 | 7095 | \catcode `\$=3 \catcode `\&=4 \catcode `\#=6 |
| 7150 | \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie | 7096 | \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie |
| @@ -7370,7 +7316,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 7370 | % If you want all examples etc. small: @set dispenvsize small. | 7316 | % If you want all examples etc. small: @set dispenvsize small. |
| 7371 | % If you want even small examples the full size: @set dispenvsize nosmall. | 7317 | % If you want even small examples the full size: @set dispenvsize nosmall. |
| 7372 | % This affects the following displayed environments: | 7318 | % This affects the following displayed environments: |
| 7373 | % @example, @display, @format, @lisp | 7319 | % @example, @display, @format, @lisp, @verbatim |
| 7374 | % | 7320 | % |
| 7375 | \def\smallword{small} | 7321 | \def\smallword{small} |
| 7376 | \def\nosmallword{nosmall} | 7322 | \def\nosmallword{nosmall} |
| @@ -7416,9 +7362,9 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 7416 | % | 7362 | % |
| 7417 | \maketwodispenvdef{lisp}{example}{% | 7363 | \maketwodispenvdef{lisp}{example}{% |
| 7418 | \nonfillstart | 7364 | \nonfillstart |
| 7419 | \tt\setupmarkupstyle{example}% | 7365 | \tt\setcodequotes |
| 7420 | \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special. | 7366 | \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special. |
| 7421 | \gobble % eat return | 7367 | \parsearg\gobble |
| 7422 | } | 7368 | } |
| 7423 | % @display/@smalldisplay: same as @lisp except keep current font. | 7369 | % @display/@smalldisplay: same as @lisp except keep current font. |
| 7424 | % | 7370 | % |
| @@ -7576,7 +7522,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 7576 | \def\setupverb{% | 7522 | \def\setupverb{% |
| 7577 | \tt % easiest (and conventionally used) font for verbatim | 7523 | \tt % easiest (and conventionally used) font for verbatim |
| 7578 | \def\par{\leavevmode\endgraf}% | 7524 | \def\par{\leavevmode\endgraf}% |
| 7579 | \setupmarkupstyle{verb}% | 7525 | \setcodequotes |
| 7580 | \tabeightspaces | 7526 | \tabeightspaces |
| 7581 | % Respect line breaks, | 7527 | % Respect line breaks, |
| 7582 | % print special symbols as themselves, and | 7528 | % print special symbols as themselves, and |
| @@ -7617,7 +7563,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 7617 | \tt % easiest (and conventionally used) font for verbatim | 7563 | \tt % easiest (and conventionally used) font for verbatim |
| 7618 | \def\par{\egroup\leavevmode\box\verbbox\endgraf\starttabbox}% | 7564 | \def\par{\egroup\leavevmode\box\verbbox\endgraf\starttabbox}% |
| 7619 | \tabexpand | 7565 | \tabexpand |
| 7620 | \setupmarkupstyle{verbatim}% | 7566 | \setcodequotes |
| 7621 | % Respect line breaks, | 7567 | % Respect line breaks, |
| 7622 | % print special symbols as themselves, and | 7568 | % print special symbols as themselves, and |
| 7623 | % make each space count. | 7569 | % make each space count. |
| @@ -8036,7 +7982,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 8036 | % leave the code in, but it's strange for @var to lead to typewriter. | 7982 | % leave the code in, but it's strange for @var to lead to typewriter. |
| 8037 | % Nowadays we recommend @code, since the difference between a ttsl hyphen | 7983 | % Nowadays we recommend @code, since the difference between a ttsl hyphen |
| 8038 | % and a tt hyphen is pretty tiny. @code also disables ?` !`. | 7984 | % and a tt hyphen is pretty tiny. @code also disables ?` !`. |
| 8039 | \def\var##1{{\setupmarkupstyle{var}\ttslanted{##1}}}% | 7985 | \def\var##1{{\setregularquotes\ttslanted{##1}}}% |
| 8040 | #1% | 7986 | #1% |
| 8041 | \sl\hyphenchar\font=45 | 7987 | \sl\hyphenchar\font=45 |
| 8042 | } | 7988 | } |
| @@ -8145,11 +8091,18 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 8145 | } | 8091 | } |
| 8146 | \fi | 8092 | \fi |
| 8147 | 8093 | ||
| 8094 | \let\E=\expandafter | ||
| 8095 | |||
| 8148 | % Used at the time of macro expansion. | 8096 | % Used at the time of macro expansion. |
| 8149 | % Argument is macro body with arguments substituted | 8097 | % Argument is macro body with arguments substituted |
| 8150 | \def\scanmacro#1{% | 8098 | \def\scanmacro#1{% |
| 8151 | \newlinechar`\^^M | 8099 | \newlinechar`\^^M |
| 8152 | \def\xeatspaces{\eatspaces}% | 8100 | % expand the expansion of \eatleadingcr twice to maybe remove a leading |
| 8101 | % newline (and \else and \fi tokens), then call \eatspaces on the result. | ||
| 8102 | \def\xeatspaces##1{% | ||
| 8103 | \E\E\E\E\E\E\E\eatspaces\E\E\E\E\E\E\E{\eatleadingcr##1% | ||
| 8104 | }}% | ||
| 8105 | \def\xempty##1{}% | ||
| 8153 | % | 8106 | % |
| 8154 | % Process the macro body under the current catcode regime. | 8107 | % Process the macro body under the current catcode regime. |
| 8155 | \scantokens{#1@comment}% | 8108 | \scantokens{#1@comment}% |
| @@ -8202,6 +8155,11 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 8202 | \unbrace{\gdef\trim@@@ #1 } #2@{#1} | 8155 | \unbrace{\gdef\trim@@@ #1 } #2@{#1} |
| 8203 | } | 8156 | } |
| 8204 | 8157 | ||
| 8158 | {\catcode`\^^M=\other% | ||
| 8159 | \gdef\eatleadingcr#1{\if\noexpand#1\noexpand^^M\else\E#1\fi}}% | ||
| 8160 | % Warning: this won't work for a delimited argument | ||
| 8161 | % or for an empty argument | ||
| 8162 | |||
| 8205 | % Trim a single trailing ^^M off a string. | 8163 | % Trim a single trailing ^^M off a string. |
| 8206 | {\catcode`\^^M=\other \catcode`\Q=3% | 8164 | {\catcode`\^^M=\other \catcode`\Q=3% |
| 8207 | \gdef\eatcr #1{\eatcra #1Q^^MQ}% | 8165 | \gdef\eatcr #1{\eatcra #1Q^^MQ}% |
| @@ -8368,6 +8326,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 8368 | \let\hash\relax | 8326 | \let\hash\relax |
| 8369 | % \hash is redefined to `#' later to get it into definitions | 8327 | % \hash is redefined to `#' later to get it into definitions |
| 8370 | \let\xeatspaces\relax | 8328 | \let\xeatspaces\relax |
| 8329 | \let\xempty\relax | ||
| 8371 | \parsemargdefxxx#1,;,% | 8330 | \parsemargdefxxx#1,;,% |
| 8372 | \ifnum\paramno<10\relax\else | 8331 | \ifnum\paramno<10\relax\else |
| 8373 | \paramno0\relax | 8332 | \paramno0\relax |
| @@ -8379,9 +8338,11 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 8379 | \else \let\next=\parsemargdefxxx | 8338 | \else \let\next=\parsemargdefxxx |
| 8380 | \advance\paramno by 1 | 8339 | \advance\paramno by 1 |
| 8381 | \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname | 8340 | \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname |
| 8382 | {\xeatspaces{\hash\the\paramno}}% | 8341 | {\xeatspaces{\hash\the\paramno\noexpand\xempty{}}}% |
| 8383 | \edef\paramlist{\paramlist\hash\the\paramno,}% | 8342 | \edef\paramlist{\paramlist\hash\the\paramno,}% |
| 8384 | \fi\next} | 8343 | \fi\next} |
| 8344 | % the \xempty{} is to give \eatleadingcr an argument in the case of an | ||
| 8345 | % empty macro argument. | ||
| 8385 | 8346 | ||
| 8386 | % \parsemacbody, \parsermacbody | 8347 | % \parsemacbody, \parsermacbody |
| 8387 | % | 8348 | % |
| @@ -9107,20 +9068,22 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 9107 | % output the `[mynode]' via the macro below so it can be overridden. | 9068 | % output the `[mynode]' via the macro below so it can be overridden. |
| 9108 | \xrefprintnodename\printedrefname | 9069 | \xrefprintnodename\printedrefname |
| 9109 | % | 9070 | % |
| 9110 | % But we always want a comma and a space: | 9071 | \expandafter\ifx\csname SETtxiomitxrefpg\endcsname\relax |
| 9111 | ,\space | 9072 | % But we always want a comma and a space: |
| 9112 | % | 9073 | ,\space |
| 9113 | % output the `page 3'. | 9074 | % |
| 9114 | \turnoffactive \putwordpage\tie\refx{#1-pg}{}% | 9075 | % output the `page 3'. |
| 9115 | % Add a , if xref followed by a space | 9076 | \turnoffactive \putwordpage\tie\refx{#1-pg}{}% |
| 9116 | \if\space\noexpand\tokenafterxref ,% | 9077 | % Add a , if xref followed by a space |
| 9117 | \else\ifx\ \tokenafterxref ,% @TAB | 9078 | \if\space\noexpand\tokenafterxref ,% |
| 9118 | \else\ifx\*\tokenafterxref ,% @* | 9079 | \else\ifx\ \tokenafterxref ,% @TAB |
| 9119 | \else\ifx\ \tokenafterxref ,% @SPACE | 9080 | \else\ifx\*\tokenafterxref ,% @* |
| 9120 | \else\ifx\ | 9081 | \else\ifx\ \tokenafterxref ,% @SPACE |
| 9121 | \tokenafterxref ,% @NL | 9082 | \else\ifx\ |
| 9122 | \else\ifx\tie\tokenafterxref ,% @tie | 9083 | \tokenafterxref ,% @NL |
| 9123 | \fi\fi\fi\fi\fi\fi | 9084 | \else\ifx\tie\tokenafterxref ,% @tie |
| 9085 | \fi\fi\fi\fi\fi\fi | ||
| 9086 | \fi | ||
| 9124 | \fi\fi | 9087 | \fi\fi |
| 9125 | \fi | 9088 | \fi |
| 9126 | \endlink | 9089 | \endlink |
| @@ -9550,7 +9513,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% | |||
| 9550 | \def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup | 9513 | \def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup |
| 9551 | \catcode`\^^M = 5 % in case we're inside an example | 9514 | \catcode`\^^M = 5 % in case we're inside an example |
| 9552 | \normalturnoffactive % allow _ et al. in names | 9515 | \normalturnoffactive % allow _ et al. in names |
| 9553 | \def\xprocessmacroarg{\eatspaces}% in case we are being used via a macro | 9516 | \makevalueexpandable |
| 9554 | % If the image is by itself, center it. | 9517 | % If the image is by itself, center it. |
| 9555 | \ifvmode | 9518 | \ifvmode |
| 9556 | \imagevmodetrue | 9519 | \imagevmodetrue |
| @@ -11603,7 +11566,7 @@ directory should work if nowhere else does.} | |||
| 11603 | \let> = \activegtr | 11566 | \let> = \activegtr |
| 11604 | \let~ = \activetilde | 11567 | \let~ = \activetilde |
| 11605 | \let^ = \activehat | 11568 | \let^ = \activehat |
| 11606 | \markupsetuplqdefault \markupsetuprqdefault | 11569 | \setregularquotes |
| 11607 | \let\b = \strong | 11570 | \let\b = \strong |
| 11608 | \let\i = \smartitalic | 11571 | \let\i = \smartitalic |
| 11609 | % in principle, all other definitions in \tex have to be undone too. | 11572 | % in principle, all other definitions in \tex have to be undone too. |
| @@ -11662,8 +11625,7 @@ directory should work if nowhere else does.} | |||
| 11662 | @let|=@normalverticalbar | 11625 | @let|=@normalverticalbar |
| 11663 | @let~=@normaltilde | 11626 | @let~=@normaltilde |
| 11664 | @let\=@ttbackslash | 11627 | @let\=@ttbackslash |
| 11665 | @markupsetuplqdefault | 11628 | @setregularquotes |
| 11666 | @markupsetuprqdefault | ||
| 11667 | @unsepspaces | 11629 | @unsepspaces |
| 11668 | } | 11630 | } |
| 11669 | } | 11631 | } |
| @@ -11756,8 +11718,7 @@ directory should work if nowhere else does.} | |||
| 11756 | @c Do this last of all since we use ` in the previous @catcode assignments. | 11718 | @c Do this last of all since we use ` in the previous @catcode assignments. |
| 11757 | @catcode`@'=@active | 11719 | @catcode`@'=@active |
| 11758 | @catcode`@`=@active | 11720 | @catcode`@`=@active |
| 11759 | @markupsetuplqdefault | 11721 | @setregularquotes |
| 11760 | @markupsetuprqdefault | ||
| 11761 | 11722 | ||
| 11762 | @c Local variables: | 11723 | @c Local variables: |
| 11763 | @c eval: (add-hook 'before-save-hook 'time-stamp) | 11724 | @c eval: (add-hook 'before-save-hook 'time-stamp) |
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 2c4b792cc21..5d89b065882 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi | |||
| @@ -810,9 +810,10 @@ behavior. | |||
| 810 | @cindex @option{sshx} method | 810 | @cindex @option{sshx} method |
| 811 | 811 | ||
| 812 | Works like @option{ssh} but without the extra authentication prompts. | 812 | Works like @option{ssh} but without the extra authentication prompts. |
| 813 | @option{sshx} uses @samp{ssh -t -t @var{host} -l @var{user} /bin/sh} | 813 | @option{sshx} uses @samp{ssh -t -t -l @var{user} -o |
| 814 | to open a connection with a ``standard'' login shell. It supports | 814 | RemoteCommand='/bin/sh -i' @var{host}} to open a connection with a |
| 815 | changing the remote login shell @command{/bin/sh}. | 815 | ``standard'' login shell. It supports changing the remote login shell |
| 816 | @command{/bin/sh}. | ||
| 816 | 817 | ||
| 817 | @strong{Note} that @option{sshx} does not bypass authentication | 818 | @strong{Note} that @option{sshx} does not bypass authentication |
| 818 | questions. For example, if the host key of the remote host is not | 819 | questions. For example, if the host key of the remote host is not |
| @@ -935,9 +936,10 @@ This method supports the @samp{-p} argument. | |||
| 935 | @cindex @command{ssh} (with @option{scpx} method) | 936 | @cindex @command{ssh} (with @option{scpx} method) |
| 936 | 937 | ||
| 937 | @option{scpx} is useful to avoid login shell questions. It is similar | 938 | @option{scpx} is useful to avoid login shell questions. It is similar |
| 938 | in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t | 939 | in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t -l |
| 939 | @var{host} -l @var{user} /bin/sh} to open a connection. It supports | 940 | @var{user} -o RemoteCommand='/bin/sh -i' @var{host}} to open a |
| 940 | changing the remote login shell @command{/bin/sh}. | 941 | connection. It supports changing the remote login shell |
| 942 | @command{/bin/sh}. | ||
| 941 | 943 | ||
| 942 | @option{scpx} is useful for MS Windows users when @command{ssh} | 944 | @option{scpx} is useful for MS Windows users when @command{ssh} |
| 943 | triggers an error about allocating a pseudo tty. This happens due to | 945 | triggers an error about allocating a pseudo tty. This happens due to |
| @@ -2220,7 +2222,10 @@ This uses also the settings in @code{tramp-sh-extra-args}. | |||
| 2220 | @vindex RemoteCommand@r{, ssh option} | 2222 | @vindex RemoteCommand@r{, ssh option} |
| 2221 | @strong{Note}: If you use an @option{ssh}-based method for connection, | 2223 | @strong{Note}: If you use an @option{ssh}-based method for connection, |
| 2222 | do @emph{not} set the @option{RemoteCommand} option in your | 2224 | do @emph{not} set the @option{RemoteCommand} option in your |
| 2223 | @command{ssh} configuration, for example to @command{screen}. | 2225 | @command{ssh} configuration, for example to @command{screen}. On the |
| 2226 | other hand, some @option{ssh}-based methods, like @option{sshx} or | ||
| 2227 | @option{scpx}, silently overwrite a @option{RemoteCommand} option of | ||
| 2228 | the configuration file. | ||
| 2224 | 2229 | ||
| 2225 | 2230 | ||
| 2226 | @subsection Other remote shell setup hints | 2231 | @subsection Other remote shell setup hints |
| @@ -2369,8 +2374,7 @@ that can identify such questions using | |||
| 2369 | @lisp | 2374 | @lisp |
| 2370 | @group | 2375 | @group |
| 2371 | (defconst my-tramp-prompt-regexp | 2376 | (defconst my-tramp-prompt-regexp |
| 2372 | (concat (regexp-opt '("Enter the birth date of your mother:") t) | 2377 | "Enter the birth date of your mother:\\s-*" |
| 2373 | "\\s-*") | ||
| 2374 | "Regular expression matching my login prompt question.") | 2378 | "Regular expression matching my login prompt question.") |
| 2375 | @end group | 2379 | @end group |
| 2376 | 2380 | ||
| @@ -2389,6 +2393,11 @@ that can identify such questions using | |||
| 2389 | @end group | 2393 | @end group |
| 2390 | @end lisp | 2394 | @end lisp |
| 2391 | 2395 | ||
| 2396 | The regular expressions used in @code{tramp-actions-before-shell} must | ||
| 2397 | match the end of the connection buffer. Due to performance reasons, | ||
| 2398 | this search starts at the end of the buffer, and it is limited to 256 | ||
| 2399 | characters backwards. | ||
| 2400 | |||
| 2392 | 2401 | ||
| 2393 | @item Conflicting names for users and variables in @file{.profile} | 2402 | @item Conflicting names for users and variables in @file{.profile} |
| 2394 | 2403 | ||
| @@ -3576,7 +3585,6 @@ Furthermore, this approach has the following limitations: | |||
| 3576 | It works only for connection methods defined in @file{tramp-sh.el} and | 3585 | It works only for connection methods defined in @file{tramp-sh.el} and |
| 3577 | @file{tramp-adb.el}. | 3586 | @file{tramp-adb.el}. |
| 3578 | 3587 | ||
| 3579 | @vindex ControlMaster@r{, ssh option} | ||
| 3580 | @item | 3588 | @item |
| 3581 | It does not support interactive user authentication. With | 3589 | It does not support interactive user authentication. With |
| 3582 | @option{ssh}-based methods, this can be avoided by using a password | 3590 | @option{ssh}-based methods, this can be avoided by using a password |
| @@ -3584,6 +3592,10 @@ agent like @command{ssh-agent}, using public key authentication, or | |||
| 3584 | using @option{ControlMaster} options. | 3592 | using @option{ControlMaster} options. |
| 3585 | 3593 | ||
| 3586 | @item | 3594 | @item |
| 3595 | It cannot be applied for @option{ssh}-based methods, which use the | ||
| 3596 | @option{RemoteCommand} option. | ||
| 3597 | |||
| 3598 | @item | ||
| 3587 | It cannot be killed via @code{interrupt-process}. | 3599 | It cannot be killed via @code{interrupt-process}. |
| 3588 | 3600 | ||
| 3589 | @item | 3601 | @item |
| @@ -3593,8 +3605,7 @@ It does not report the remote terminal name via @code{process-tty-name}. | |||
| 3593 | It does not set process property @code{remote-pid}. | 3605 | It does not set process property @code{remote-pid}. |
| 3594 | 3606 | ||
| 3595 | @item | 3607 | @item |
| 3596 | It does not use @code{tramp-remote-path} and | 3608 | It does not use @code{tramp-remote-path}. |
| 3597 | @code{tramp-remote-process-environment}. | ||
| 3598 | @end itemize | 3609 | @end itemize |
| 3599 | 3610 | ||
| 3600 | In order to gain even more performance, it is recommended to bind | 3611 | In order to gain even more performance, it is recommended to bind |
| @@ -30,20 +30,16 @@ Bengali (বাংলা) নমস্কার | |||
| 30 | Braille ⠓⠑⠇⠇⠕ | 30 | Braille ⠓⠑⠇⠇⠕ |
| 31 | Burmese (မြန်မာ) မင်္ဂလာပါ | 31 | Burmese (မြန်မာ) မင်္ဂလာပါ |
| 32 | C printf ("Hello, world!\n"); | 32 | C printf ("Hello, world!\n"); |
| 33 | Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨁꨰ | ||
| 33 | Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ | 34 | Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ |
| 34 | Comanche /kəˈmæntʃiː/ Haa marʉ́awe | 35 | Comanche /kəˈmæntʃiː/ Haa marʉ́awe |
| 35 | |||
| 36 | Cree (ᓀᐦᐃᔭᐍᐏᐣ) ᑕᓂᓯ / ᐙᒋᔮ | 36 | Cree (ᓀᐦᐃᔭᐍᐏᐣ) ᑕᓂᓯ / ᐙᒋᔮ |
| 37 | |||
| 38 | Czech (čeština) Dobrý den | 37 | Czech (čeština) Dobrý den |
| 39 | Danish (dansk) Hej / Goddag / Halløj | 38 | Danish (dansk) Hej / Goddag / Halløj |
| 40 | Dutch (Nederlands) Hallo / Dag | 39 | Dutch (Nederlands) Hallo / Dag |
| 41 | Efik /ˈɛfɪk/ Mɔkɔm | 40 | Efik /ˈɛfɪk/ Mɔkɔm |
| 42 | |||
| 43 | Egyptian Hieroglyphs (𓂋𓏤𓈖𓆎𓅓𓏏𓊖) 𓅓𓊵𓏏𓊪, 𓇍𓇋𓂻𓍘𓇋 | 41 | Egyptian Hieroglyphs (𓂋𓏤𓈖𓆎𓅓𓏏𓊖) 𓅓𓊵𓏏𓊪, 𓇍𓇋𓂻𓍘𓇋 |
| 44 | |||
| 45 | Emacs emacs --no-splash -f view-hello-file | 42 | Emacs emacs --no-splash -f view-hello-file |
| 46 | |||
| 47 | Emoji 👋 | 43 | Emoji 👋 |
| 48 | English /ˈɪŋɡlɪʃ/ Hello | 44 | English /ˈɪŋɡlɪʃ/ Hello |
| 49 | Esperanto Saluton (Eĥoŝanĝo ĉiuĵaŭde) | 45 | Esperanto Saluton (Eĥoŝanĝo ĉiuĵaŭde) |
| @@ -59,7 +55,6 @@ Hebrew (עִבְרִית) שָׁלוֹם | |||
| 59 | Hungarian (magyar) Szép jó napot! | 55 | Hungarian (magyar) Szép jó napot! |
| 60 | Hindi (हिंदी) नमस्ते / नमस्कार । | 56 | Hindi (हिंदी) नमस्ते / नमस्कार । |
| 61 | Inuktitut (ᐃᓄᒃᑎᑐᑦ) ᐊᐃ | 57 | Inuktitut (ᐃᓄᒃᑎᑐᑦ) ᐊᐃ |
| 62 | |||
| 63 | Italian (italiano) Ciao / Buon giorno | 58 | Italian (italiano) Ciao / Buon giorno |
| 64 | Javanese (ꦧꦱꦗꦮꦶ) console.log("ꦲꦭꦺꦴ"); | 59 | Javanese (ꦧꦱꦗꦮꦶ) console.log("ꦲꦭꦺꦴ"); |
| 65 | Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ | 60 | Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ |
| @@ -67,7 +62,6 @@ Khmer (ភាសាខ្មែរ) ជំរាបសួរ | |||
| 67 | Lao (ພາສາລາວ) ສະບາຍດີ / ຂໍໃຫ້ໂຊກດີ | 62 | Lao (ພາສາລາວ) ສະບາຍດີ / ຂໍໃຫ້ໂຊກດີ |
| 68 | Malayalam (മലയാളം) നമസ്കാരം | 63 | Malayalam (മലയാളം) നമസ്കാരം |
| 69 | Maldivian (ދިވެހި) އައްސަލާމު ޢަލައިކުމް / ކިހިނެހް؟ | 64 | Maldivian (ދިވެހި) އައްސަލާމު ޢަލައިކުމް / ކިހިނެހް؟ |
| 70 | |||
| 71 | Maltese (il-Malti) Bonġu / Saħħa | 65 | Maltese (il-Malti) Bonġu / Saħħa |
| 72 | Mathematics ∀ p ∈ world • hello p □ | 66 | Mathematics ∀ p ∈ world • hello p □ |
| 73 | Mongolian (монгол хэл) Сайн байна уу? | 67 | Mongolian (монгол хэл) Сайн байна уу? |
| @@ -83,7 +77,6 @@ Swedish (svenska) Hej / Goddag / Hallå | |||
| 83 | Tamil (தமிழ்) வணக்கம் | 77 | Tamil (தமிழ்) வணக்கம் |
| 84 | Telugu (తెలుగు) నమస్కారం | 78 | Telugu (తెలుగు) నమస్కారం |
| 85 | TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ | 79 | TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ |
| 86 | |||
| 87 | Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ | 80 | Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ |
| 88 | Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎ | 81 | Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎ |
| 89 | Tigrigna (ትግርኛ) ሰላማት | 82 | Tigrigna (ትግርኛ) ሰላማት |
| @@ -97,7 +90,6 @@ Vietnamese (tiếng Việt) Chào bạn | |||
| 97 | </x-charset><x-charset><param>chinese-gb2312</param>Chinese (中文,普通话,汉语) 你好 | 90 | </x-charset><x-charset><param>chinese-gb2312</param>Chinese (中文,普通话,汉语) 你好 |
| 98 | </x-charset><x-charset><param>chinese-big5-1</param>Cantonese (粵語,廣東話) 早晨, 你好 | 91 | </x-charset><x-charset><param>chinese-big5-1</param>Cantonese (粵語,廣東話) 早晨, 你好 |
| 99 | </x-charset><x-charset><param>korean-ksc5601</param>Korean (한글) 안녕하세요 / 안녕하십니까 | 92 | </x-charset><x-charset><param>korean-ksc5601</param>Korean (한글) 안녕하세요 / 안녕하십니까 |
| 100 | |||
| 101 | </x-charset> | 93 | </x-charset> |
| 102 | 94 | ||
| 103 | 95 | ||
| @@ -326,6 +326,16 @@ the buffer cycles the whole buffer between "only top-level headings", | |||
| 326 | 326 | ||
| 327 | * Changes in Specialized Modes and Packages in Emacs 28.1 | 327 | * Changes in Specialized Modes and Packages in Emacs 28.1 |
| 328 | 328 | ||
| 329 | ** 'blink-cursor-mode' is now enabled by default regardless of the UI. | ||
| 330 | It used to be enabled when Emacs is started in GUI mode but not when started | ||
| 331 | in text mode. The cursor still only actually blinks in GUI frames. | ||
| 332 | |||
| 333 | ** pcase | ||
| 334 | +++ | ||
| 335 | *** The `pred` pattern can now take the form (pred (not FUN)). | ||
| 336 | This is like (pred (lambda (x) (not (FUN x)))) but results | ||
| 337 | in better code. | ||
| 338 | |||
| 329 | +++ | 339 | +++ |
| 330 | ** profiler.el | 340 | ** profiler.el |
| 331 | The results displayed by 'profiler-report' now have the usage figures | 341 | The results displayed by 'profiler-report' now have the usage figures |
| @@ -346,6 +356,12 @@ When emacsclient connects, Emacs will (by default) output a message | |||
| 346 | about how to exit the client frame. If 'server-client-instructions' | 356 | about how to exit the client frame. If 'server-client-instructions' |
| 347 | is set to nil, this message is inhibited. | 357 | is set to nil, this message is inhibited. |
| 348 | 358 | ||
| 359 | ** Perl mode | ||
| 360 | |||
| 361 | --- | ||
| 362 | *** New face 'perl-non-scalar-variable'. | ||
| 363 | This is used to fontify non-scalar variables. | ||
| 364 | |||
| 349 | ** Python mode | 365 | ** Python mode |
| 350 | 366 | ||
| 351 | *** 'python-shell-interpreter' now defaults to python3 on systems with python3. | 367 | *** 'python-shell-interpreter' now defaults to python3 on systems with python3. |
| @@ -705,9 +721,11 @@ not. | |||
| 705 | --- | 721 | --- |
| 706 | *** Respect 'message-forward-ignored-headers' more. | 722 | *** Respect 'message-forward-ignored-headers' more. |
| 707 | Previously, this variable would not be consulted if | 723 | Previously, this variable would not be consulted if |
| 708 | 'message-forward-show-mml' was nil. It's now always used, except if | 724 | 'message-forward-show-mml' was nil and forwarding as MIME. |
| 709 | 'message-forward-show-mml' is 'best', and we're forwarding an | 725 | |
| 710 | encrypted/signed message. | 726 | +++ |
| 727 | *** New user option 'message-forward-included-mime-headers'. | ||
| 728 | This is used when forwarding messages as MIME, but not using MML. | ||
| 711 | 729 | ||
| 712 | +++ | 730 | +++ |
| 713 | *** Message now supports the OpenPGP header. | 731 | *** Message now supports the OpenPGP header. |
| @@ -821,6 +839,10 @@ so e.g. like 'C-x 8 [' inserts a left single quotation mark, | |||
| 821 | Added a new Mozhi scheme. The inapplicable ITRANS scheme is now | 839 | Added a new Mozhi scheme. The inapplicable ITRANS scheme is now |
| 822 | deprecated. Errors in the Inscript method were corrected. | 840 | deprecated. Errors in the Inscript method were corrected. |
| 823 | 841 | ||
| 842 | --- | ||
| 843 | *** New input method 'cham'. | ||
| 844 | There's also a Cham greeting in 'etc/HELLO'. | ||
| 845 | |||
| 824 | ** Ispell | 846 | ** Ispell |
| 825 | 847 | ||
| 826 | +++ | 848 | +++ |
| @@ -1538,9 +1560,28 @@ buttons in it. | |||
| 1538 | This function takes a string and returns a string propertized in a way | 1560 | This function takes a string and returns a string propertized in a way |
| 1539 | that makes it a valid button. | 1561 | that makes it a valid button. |
| 1540 | 1562 | ||
| 1563 | ** subr-x | ||
| 1564 | +++ | ||
| 1565 | *** A number of new string manipulation functions have been added. | ||
| 1566 | 'string-clean-whitespace', 'string-fill', 'string-limit', | ||
| 1567 | 'string-lines', 'string-pad' and 'string-chop-newline'. | ||
| 1568 | |||
| 1569 | *** New macro `named-let` that provides Scheme's "named let" looping construct | ||
| 1570 | |||
| 1571 | ** thingatpt | ||
| 1572 | |||
| 1573 | +++ | ||
| 1574 | *** New variable 'thing-at-point-provider-alist'. | ||
| 1575 | This allows mode-specific alterations to how `thing-at-point' works. | ||
| 1541 | 1576 | ||
| 1542 | ** Miscellaneous | 1577 | ** Miscellaneous |
| 1543 | 1578 | ||
| 1579 | --- | ||
| 1580 | *** New user option 'remember-diary-regexp'. | ||
| 1581 | |||
| 1582 | --- | ||
| 1583 | *** New user option 'remember-text-format-function'. | ||
| 1584 | |||
| 1544 | *** New function 'buffer-line-statistics'. | 1585 | *** New function 'buffer-line-statistics'. |
| 1545 | This function returns some statistics about the line lengths in a buffer. | 1586 | This function returns some statistics about the line lengths in a buffer. |
| 1546 | 1587 | ||
| @@ -1572,11 +1613,6 @@ length to a number). | |||
| 1572 | This can be set to nil to inhibit hiding passwords in ".authinfo" files. | 1613 | This can be set to nil to inhibit hiding passwords in ".authinfo" files. |
| 1573 | 1614 | ||
| 1574 | +++ | 1615 | +++ |
| 1575 | *** A number of new string manipulation functions have been added. | ||
| 1576 | 'string-clean-whitespace', 'string-fill', 'string-limit', | ||
| 1577 | 'string-lines', 'string-pad' and 'string-chop-newline'. | ||
| 1578 | |||
| 1579 | +++ | ||
| 1580 | *** New variable 'current-minibuffer-command'. | 1616 | *** New variable 'current-minibuffer-command'. |
| 1581 | This is like 'this-command', but it is bound recursively when entering | 1617 | This is like 'this-command', but it is bound recursively when entering |
| 1582 | the minibuffer. | 1618 | the minibuffer. |
diff --git a/etc/NEWS.19 b/etc/NEWS.19 index 43235e0e154..f2cef62971b 100644 --- a/etc/NEWS.19 +++ b/etc/NEWS.19 | |||
| @@ -2824,6 +2824,8 @@ the text of the region according to the new value. | |||
| 2824 | the fill-column has been exceeded; the function can determine on its | 2824 | the fill-column has been exceeded; the function can determine on its |
| 2825 | own whether filling (or justification) is necessary. | 2825 | own whether filling (or justification) is necessary. |
| 2826 | 2826 | ||
| 2827 | **** New helper function 'indent-line-to' | ||
| 2828 | |||
| 2827 | ** Processes | 2829 | ** Processes |
| 2828 | 2830 | ||
| 2829 | *** process-tty-name is a new function that returns the name of the | 2831 | *** process-tty-name is a new function that returns the name of the |
diff --git a/lib/_Noreturn.h b/lib/_Noreturn.h index 38afe1d5672..fb718bc0691 100644 --- a/lib/_Noreturn.h +++ b/lib/_Noreturn.h | |||
| @@ -26,14 +26,16 @@ | |||
| 26 | AIX system header files and several gnulib header files use precisely | 26 | AIX system header files and several gnulib header files use precisely |
| 27 | this syntax with 'extern'. */ | 27 | this syntax with 'extern'. */ |
| 28 | # define _Noreturn [[noreturn]] | 28 | # define _Noreturn [[noreturn]] |
| 29 | # elif ((!defined __cplusplus || defined __clang__) \ | 29 | # elif ((!defined __cplusplus || defined __clang__) \ |
| 30 | && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ | 30 | && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ |
| 31 | || 4 < __GNUC__ + (7 <= __GNUC_MINOR__) \ | 31 | || (!defined __STRICT_ANSI__ \ |
| 32 | || (defined __apple_build_version__ \ | 32 | && (__4 < __GNUC__ + (7 <= __GNUC_MINOR__) \ |
| 33 | ? 6000000 <= __apple_build_version__ \ | 33 | || (defined __apple_build_version__ \ |
| 34 | : 3 < __clang_major__ + (5 <= __clang_minor__)))) | 34 | ? 6000000 <= __apple_build_version__ \ |
| 35 | : 3 < __clang_major__ + (5 <= __clang_minor__)))))) | ||
| 35 | /* _Noreturn works as-is. */ | 36 | /* _Noreturn works as-is. */ |
| 36 | # elif 2 < __GNUC__ + (8 <= __GNUC_MINOR__) || 0x5110 <= __SUNPRO_C | 37 | # elif (2 < __GNUC__ + (8 <= __GNUC_MINOR__) || defined __clang__ \ |
| 38 | || 0x5110 <= __SUNPRO_C) | ||
| 37 | # define _Noreturn __attribute__ ((__noreturn__)) | 39 | # define _Noreturn __attribute__ ((__noreturn__)) |
| 38 | # elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0) | 40 | # elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0) |
| 39 | # define _Noreturn __declspec (noreturn) | 41 | # define _Noreturn __declspec (noreturn) |
diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index b6dc3a447ab..b7dba08994d 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c | |||
| @@ -85,10 +85,6 @@ | |||
| 85 | # define IF_LINT(Code) /* empty */ | 85 | # define IF_LINT(Code) /* empty */ |
| 86 | #endif | 86 | #endif |
| 87 | 87 | ||
| 88 | /* True if adding two valid object sizes might overflow idx_t. | ||
| 89 | As a practical matter, this cannot happen on 64-bit machines. */ | ||
| 90 | enum { NARROW_ADDRESSES = IDX_MAX >> 31 >> 31 == 0 }; | ||
| 91 | |||
| 92 | #ifndef DOUBLE_SLASH_IS_DISTINCT_ROOT | 88 | #ifndef DOUBLE_SLASH_IS_DISTINCT_ROOT |
| 93 | # define DOUBLE_SLASH_IS_DISTINCT_ROOT false | 89 | # define DOUBLE_SLASH_IS_DISTINCT_ROOT false |
| 94 | #endif | 90 | #endif |
| @@ -145,11 +141,11 @@ suffix_requires_dir_check (char const *end) | |||
| 145 | macOS 10.13 <https://bugs.gnu.org/30350>, and should also work on | 141 | macOS 10.13 <https://bugs.gnu.org/30350>, and should also work on |
| 146 | platforms like AIX 7.2 that need at least "/.". */ | 142 | platforms like AIX 7.2 that need at least "/.". */ |
| 147 | 143 | ||
| 148 | #if defined _LIBC || defined LSTAT_FOLLOWS_SLASHED_SYMLINK | 144 | # if defined _LIBC || defined LSTAT_FOLLOWS_SLASHED_SYMLINK |
| 149 | static char const dir_suffix[] = "/"; | 145 | static char const dir_suffix[] = "/"; |
| 150 | #else | 146 | # else |
| 151 | static char const dir_suffix[] = "/./"; | 147 | static char const dir_suffix[] = "/./"; |
| 152 | #endif | 148 | # endif |
| 153 | 149 | ||
| 154 | /* Return true if DIR is a searchable dir, false (setting errno) otherwise. | 150 | /* Return true if DIR is a searchable dir, false (setting errno) otherwise. |
| 155 | DIREND points to the NUL byte at the end of the DIR string. | 151 | DIREND points to the NUL byte at the end of the DIR string. |
| @@ -191,13 +187,13 @@ get_path_max (void) | |||
| 191 | to pacify GCC is known; even an explicit #pragma does not pacify GCC. | 187 | to pacify GCC is known; even an explicit #pragma does not pacify GCC. |
| 192 | When the GCC bug is fixed this workaround should be limited to the | 188 | When the GCC bug is fixed this workaround should be limited to the |
| 193 | broken GCC versions. */ | 189 | broken GCC versions. */ |
| 194 | #if __GNUC_PREREQ (10, 1) | 190 | # if __GNUC_PREREQ (10, 1) |
| 195 | # if defined GCC_LINT || defined lint | 191 | # if defined GCC_LINT || defined lint |
| 196 | __attribute__ ((__noinline__)) | 192 | __attribute__ ((__noinline__)) |
| 197 | # elif __OPTIMIZE__ && !__NO_INLINE__ | 193 | # elif __OPTIMIZE__ && !__NO_INLINE__ |
| 198 | # define GCC_BOGUS_WRETURN_LOCAL_ADDR | 194 | # define GCC_BOGUS_WRETURN_LOCAL_ADDR |
| 195 | # endif | ||
| 199 | # endif | 196 | # endif |
| 200 | #endif | ||
| 201 | static char * | 197 | static char * |
| 202 | realpath_stk (const char *name, char *resolved, | 198 | realpath_stk (const char *name, char *resolved, |
| 203 | struct scratch_buffer *rname_buf) | 199 | struct scratch_buffer *rname_buf) |
| @@ -343,7 +339,7 @@ realpath_stk (const char *name, char *resolved, | |||
| 343 | if (end_in_extra_buffer) | 339 | if (end_in_extra_buffer) |
| 344 | end_idx = end - extra_buf; | 340 | end_idx = end - extra_buf; |
| 345 | size_t len = strlen (end); | 341 | size_t len = strlen (end); |
| 346 | if (NARROW_ADDRESSES && INT_ADD_OVERFLOW (len, n)) | 342 | if (INT_ADD_OVERFLOW (len, n)) |
| 347 | { | 343 | { |
| 348 | __set_errno (ENOMEM); | 344 | __set_errno (ENOMEM); |
| 349 | goto error_nomem; | 345 | goto error_nomem; |
| @@ -443,7 +439,8 @@ __realpath (const char *name, char *resolved) | |||
| 443 | } | 439 | } |
| 444 | libc_hidden_def (__realpath) | 440 | libc_hidden_def (__realpath) |
| 445 | versioned_symbol (libc, __realpath, realpath, GLIBC_2_3); | 441 | versioned_symbol (libc, __realpath, realpath, GLIBC_2_3); |
| 446 | #endif /* !FUNC_REALPATH_WORKS || defined _LIBC */ | 442 | |
| 443 | #endif /* defined _LIBC || !FUNC_REALPATH_WORKS */ | ||
| 447 | 444 | ||
| 448 | 445 | ||
| 449 | #if SHLIB_COMPAT(libc, GLIBC_2_0, GLIBC_2_3) | 446 | #if SHLIB_COMPAT(libc, GLIBC_2_0, GLIBC_2_3) |
diff --git a/lib/cdefs.h b/lib/cdefs.h index 2a3dc9666b9..17a0919cd83 100644 --- a/lib/cdefs.h +++ b/lib/cdefs.h | |||
| @@ -25,7 +25,7 @@ | |||
| 25 | 25 | ||
| 26 | /* The GNU libc does not support any K&R compilers or the traditional mode | 26 | /* The GNU libc does not support any K&R compilers or the traditional mode |
| 27 | of ISO C compilers anymore. Check for some of the combinations not | 27 | of ISO C compilers anymore. Check for some of the combinations not |
| 28 | anymore supported. */ | 28 | supported anymore. */ |
| 29 | #if defined __GNUC__ && !defined __STDC__ | 29 | #if defined __GNUC__ && !defined __STDC__ |
| 30 | # error "You need a ISO C conforming compiler to use the glibc headers" | 30 | # error "You need a ISO C conforming compiler to use the glibc headers" |
| 31 | #endif | 31 | #endif |
| @@ -34,31 +34,26 @@ | |||
| 34 | #undef __P | 34 | #undef __P |
| 35 | #undef __PMT | 35 | #undef __PMT |
| 36 | 36 | ||
| 37 | /* Compilers that are not clang may object to | 37 | /* Compilers that lack __has_attribute may object to |
| 38 | #if defined __clang__ && __has_attribute(...) | 38 | #if defined __has_attribute && __has_attribute (...) |
| 39 | even though they do not need to evaluate the right-hand side of the &&. */ | 39 | even though they do not need to evaluate the right-hand side of the &&. |
| 40 | #if defined __clang__ && defined __has_attribute | 40 | Similarly for __has_builtin, etc. */ |
| 41 | # define __glibc_clang_has_attribute(name) __has_attribute (name) | 41 | #if (defined __has_attribute \ |
| 42 | && (!defined __clang_minor__ \ | ||
| 43 | || 3 < __clang_major__ + (5 <= __clang_minor__))) | ||
| 44 | # define __glibc_has_attribute(attr) __has_attribute (attr) | ||
| 42 | #else | 45 | #else |
| 43 | # define __glibc_clang_has_attribute(name) 0 | 46 | # define __glibc_has_attribute(attr) 0 |
| 44 | #endif | 47 | #endif |
| 45 | 48 | #ifdef __has_builtin | |
| 46 | /* Compilers that are not clang may object to | 49 | # define __glibc_has_builtin(name) __has_builtin (name) |
| 47 | #if defined __clang__ && __has_builtin(...) | ||
| 48 | even though they do not need to evaluate the right-hand side of the &&. */ | ||
| 49 | #if defined __clang__ && defined __has_builtin | ||
| 50 | # define __glibc_clang_has_builtin(name) __has_builtin (name) | ||
| 51 | #else | 50 | #else |
| 52 | # define __glibc_clang_has_builtin(name) 0 | 51 | # define __glibc_has_builtin(name) 0 |
| 53 | #endif | 52 | #endif |
| 54 | 53 | #ifdef __has_extension | |
| 55 | /* Compilers that are not clang may object to | 54 | # define __glibc_has_extension(ext) __has_extension (ext) |
| 56 | #if defined __clang__ && __has_extension(...) | ||
| 57 | even though they do not need to evaluate the right-hand side of the &&. */ | ||
| 58 | #if defined __clang__ && defined __has_extension | ||
| 59 | # define __glibc_clang_has_extension(ext) __has_extension (ext) | ||
| 60 | #else | 55 | #else |
| 61 | # define __glibc_clang_has_extension(ext) 0 | 56 | # define __glibc_has_extension(ext) 0 |
| 62 | #endif | 57 | #endif |
| 63 | 58 | ||
| 64 | #if defined __GNUC__ || defined __clang__ | 59 | #if defined __GNUC__ || defined __clang__ |
| @@ -74,22 +69,26 @@ | |||
| 74 | # endif | 69 | # endif |
| 75 | 70 | ||
| 76 | /* GCC can always grok prototypes. For C++ programs we add throw() | 71 | /* GCC can always grok prototypes. For C++ programs we add throw() |
| 77 | to help it optimize the function calls. But this works only with | 72 | to help it optimize the function calls. But this only works with |
| 78 | gcc 2.8.x and egcs. For gcc 3.4 and up we even mark C functions | 73 | gcc 2.8.x and egcs. For gcc 3.4 and up we even mark C functions |
| 79 | as non-throwing using a function attribute since programs can use | 74 | as non-throwing using a function attribute since programs can use |
| 80 | the -fexceptions options for C code as well. */ | 75 | the -fexceptions options for C code as well. */ |
| 81 | # if !defined __cplusplus \ | 76 | # if !defined __cplusplus \ |
| 82 | && (__GNUC_PREREQ (3, 4) || __glibc_clang_has_attribute (__nothrow__)) | 77 | && (__GNUC_PREREQ (3, 4) || __glibc_has_attribute (__nothrow__)) |
| 83 | # define __THROW __attribute__ ((__nothrow__ __LEAF)) | 78 | # define __THROW __attribute__ ((__nothrow__ __LEAF)) |
| 84 | # define __THROWNL __attribute__ ((__nothrow__)) | 79 | # define __THROWNL __attribute__ ((__nothrow__)) |
| 85 | # define __NTH(fct) __attribute__ ((__nothrow__ __LEAF)) fct | 80 | # define __NTH(fct) __attribute__ ((__nothrow__ __LEAF)) fct |
| 86 | # define __NTHNL(fct) __attribute__ ((__nothrow__)) fct | 81 | # define __NTHNL(fct) __attribute__ ((__nothrow__)) fct |
| 87 | # else | 82 | # else |
| 88 | # if defined __cplusplus && (__GNUC_PREREQ (2,8) || __clang_major >= 4) | 83 | # if defined __cplusplus && (__GNUC_PREREQ (2,8) || __clang_major >= 4) |
| 89 | # define __THROW throw () | 84 | # if __cplusplus >= 201103L |
| 90 | # define __THROWNL throw () | 85 | # define __THROW noexcept (true) |
| 91 | # define __NTH(fct) __LEAF_ATTR fct throw () | 86 | # else |
| 92 | # define __NTHNL(fct) fct throw () | 87 | # define __THROW throw () |
| 88 | # endif | ||
| 89 | # define __THROWNL __THROW | ||
| 90 | # define __NTH(fct) __LEAF_ATTR fct __THROW | ||
| 91 | # define __NTHNL(fct) fct __THROW | ||
| 93 | # else | 92 | # else |
| 94 | # define __THROW | 93 | # define __THROW |
| 95 | # define __THROWNL | 94 | # define __THROWNL |
| @@ -142,24 +141,20 @@ | |||
| 142 | #define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1) | 141 | #define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1) |
| 143 | #define __bos0(ptr) __builtin_object_size (ptr, 0) | 142 | #define __bos0(ptr) __builtin_object_size (ptr, 0) |
| 144 | 143 | ||
| 144 | /* Use __builtin_dynamic_object_size at _FORTIFY_SOURCE=3 when available. */ | ||
| 145 | #if __USE_FORTIFY_LEVEL == 3 && __glibc_clang_prereq (9, 0) | ||
| 146 | # define __glibc_objsize0(__o) __builtin_dynamic_object_size (__o, 0) | ||
| 147 | # define __glibc_objsize(__o) __builtin_dynamic_object_size (__o, 1) | ||
| 148 | #else | ||
| 149 | # define __glibc_objsize0(__o) __bos0 (__o) | ||
| 150 | # define __glibc_objsize(__o) __bos (__o) | ||
| 151 | #endif | ||
| 152 | |||
| 145 | #if __GNUC_PREREQ (4,3) | 153 | #if __GNUC_PREREQ (4,3) |
| 146 | # define __warndecl(name, msg) \ | ||
| 147 | extern void name (void) __attribute__((__warning__ (msg))) | ||
| 148 | # define __warnattr(msg) __attribute__((__warning__ (msg))) | 154 | # define __warnattr(msg) __attribute__((__warning__ (msg))) |
| 149 | # define __errordecl(name, msg) \ | 155 | # define __errordecl(name, msg) \ |
| 150 | extern void name (void) __attribute__((__error__ (msg))) | 156 | extern void name (void) __attribute__((__error__ (msg))) |
| 151 | #elif __glibc_clang_has_attribute (__diagnose_if__) && 0 | ||
| 152 | /* These definitions are not enabled, because they produce bogus warnings | ||
| 153 | in the glibc Fortify functions. These functions are written in a style | ||
| 154 | that works with GCC. In order to work with clang, these functions would | ||
| 155 | need to be modified. */ | ||
| 156 | # define __warndecl(name, msg) \ | ||
| 157 | extern void name (void) __attribute__((__diagnose_if__ (1, msg, "warning"))) | ||
| 158 | # define __warnattr(msg) __attribute__((__diagnose_if__ (1, msg, "warning"))) | ||
| 159 | # define __errordecl(name, msg) \ | ||
| 160 | extern void name (void) __attribute__((__diagnose_if__ (1, msg, "error"))) | ||
| 161 | #else | 157 | #else |
| 162 | # define __warndecl(name, msg) extern void name (void) | ||
| 163 | # define __warnattr(msg) | 158 | # define __warnattr(msg) |
| 164 | # define __errordecl(name, msg) extern void name (void) | 159 | # define __errordecl(name, msg) extern void name (void) |
| 165 | #endif | 160 | #endif |
| @@ -233,7 +228,7 @@ | |||
| 233 | /* At some point during the gcc 2.96 development the `malloc' attribute | 228 | /* At some point during the gcc 2.96 development the `malloc' attribute |
| 234 | for functions was introduced. We don't want to use it unconditionally | 229 | for functions was introduced. We don't want to use it unconditionally |
| 235 | (although this would be possible) since it generates warnings. */ | 230 | (although this would be possible) since it generates warnings. */ |
| 236 | #if __GNUC_PREREQ (2,96) || __glibc_clang_has_attribute (__malloc__) | 231 | #if __GNUC_PREREQ (2,96) || __glibc_has_attribute (__malloc__) |
| 237 | # define __attribute_malloc__ __attribute__ ((__malloc__)) | 232 | # define __attribute_malloc__ __attribute__ ((__malloc__)) |
| 238 | #else | 233 | #else |
| 239 | # define __attribute_malloc__ /* Ignore */ | 234 | # define __attribute_malloc__ /* Ignore */ |
| @@ -251,23 +246,31 @@ | |||
| 251 | /* At some point during the gcc 2.96 development the `pure' attribute | 246 | /* At some point during the gcc 2.96 development the `pure' attribute |
| 252 | for functions was introduced. We don't want to use it unconditionally | 247 | for functions was introduced. We don't want to use it unconditionally |
| 253 | (although this would be possible) since it generates warnings. */ | 248 | (although this would be possible) since it generates warnings. */ |
| 254 | #if __GNUC_PREREQ (2,96) || __glibc_clang_has_attribute (__pure__) | 249 | #if __GNUC_PREREQ (2,96) || __glibc_has_attribute (__pure__) |
| 255 | # define __attribute_pure__ __attribute__ ((__pure__)) | 250 | # define __attribute_pure__ __attribute__ ((__pure__)) |
| 256 | #else | 251 | #else |
| 257 | # define __attribute_pure__ /* Ignore */ | 252 | # define __attribute_pure__ /* Ignore */ |
| 258 | #endif | 253 | #endif |
| 259 | 254 | ||
| 260 | /* This declaration tells the compiler that the value is constant. */ | 255 | /* This declaration tells the compiler that the value is constant. */ |
| 261 | #if __GNUC_PREREQ (2,5) || __glibc_clang_has_attribute (__const__) | 256 | #if __GNUC_PREREQ (2,5) || __glibc_has_attribute (__const__) |
| 262 | # define __attribute_const__ __attribute__ ((__const__)) | 257 | # define __attribute_const__ __attribute__ ((__const__)) |
| 263 | #else | 258 | #else |
| 264 | # define __attribute_const__ /* Ignore */ | 259 | # define __attribute_const__ /* Ignore */ |
| 265 | #endif | 260 | #endif |
| 266 | 261 | ||
| 262 | #if defined __STDC_VERSION__ && 201710L < __STDC_VERSION__ | ||
| 263 | # define __attribute_maybe_unused__ [[__maybe_unused__]] | ||
| 264 | #elif __GNUC_PREREQ (2,7) || __glibc_has_attribute (__unused__) | ||
| 265 | # define __attribute_maybe_unused__ __attribute__ ((__unused__)) | ||
| 266 | #else | ||
| 267 | # define __attribute_maybe_unused__ /* Ignore */ | ||
| 268 | #endif | ||
| 269 | |||
| 267 | /* At some point during the gcc 3.1 development the `used' attribute | 270 | /* At some point during the gcc 3.1 development the `used' attribute |
| 268 | for functions was introduced. We don't want to use it unconditionally | 271 | for functions was introduced. We don't want to use it unconditionally |
| 269 | (although this would be possible) since it generates warnings. */ | 272 | (although this would be possible) since it generates warnings. */ |
| 270 | #if __GNUC_PREREQ (3,1) || __glibc_clang_has_attribute (__used__) | 273 | #if __GNUC_PREREQ (3,1) || __glibc_has_attribute (__used__) |
| 271 | # define __attribute_used__ __attribute__ ((__used__)) | 274 | # define __attribute_used__ __attribute__ ((__used__)) |
| 272 | # define __attribute_noinline__ __attribute__ ((__noinline__)) | 275 | # define __attribute_noinline__ __attribute__ ((__noinline__)) |
| 273 | #else | 276 | #else |
| @@ -276,7 +279,7 @@ | |||
| 276 | #endif | 279 | #endif |
| 277 | 280 | ||
| 278 | /* Since version 3.2, gcc allows marking deprecated functions. */ | 281 | /* Since version 3.2, gcc allows marking deprecated functions. */ |
| 279 | #if __GNUC_PREREQ (3,2) || __glibc_clang_has_attribute (__deprecated__) | 282 | #if __GNUC_PREREQ (3,2) || __glibc_has_attribute (__deprecated__) |
| 280 | # define __attribute_deprecated__ __attribute__ ((__deprecated__)) | 283 | # define __attribute_deprecated__ __attribute__ ((__deprecated__)) |
| 281 | #else | 284 | #else |
| 282 | # define __attribute_deprecated__ /* Ignore */ | 285 | # define __attribute_deprecated__ /* Ignore */ |
| @@ -285,8 +288,8 @@ | |||
| 285 | /* Since version 4.5, gcc also allows one to specify the message printed | 288 | /* Since version 4.5, gcc also allows one to specify the message printed |
| 286 | when a deprecated function is used. clang claims to be gcc 4.2, but | 289 | when a deprecated function is used. clang claims to be gcc 4.2, but |
| 287 | may also support this feature. */ | 290 | may also support this feature. */ |
| 288 | #if __GNUC_PREREQ (4,5) || \ | 291 | #if __GNUC_PREREQ (4,5) \ |
| 289 | __glibc_clang_has_extension (__attribute_deprecated_with_message__) | 292 | || __glibc_has_extension (__attribute_deprecated_with_message__) |
| 290 | # define __attribute_deprecated_msg__(msg) \ | 293 | # define __attribute_deprecated_msg__(msg) \ |
| 291 | __attribute__ ((__deprecated__ (msg))) | 294 | __attribute__ ((__deprecated__ (msg))) |
| 292 | #else | 295 | #else |
| @@ -299,7 +302,7 @@ | |||
| 299 | If several `format_arg' attributes are given for the same function, in | 302 | If several `format_arg' attributes are given for the same function, in |
| 300 | gcc-3.0 and older, all but the last one are ignored. In newer gccs, | 303 | gcc-3.0 and older, all but the last one are ignored. In newer gccs, |
| 301 | all designated arguments are considered. */ | 304 | all designated arguments are considered. */ |
| 302 | #if __GNUC_PREREQ (2,8) || __glibc_clang_has_attribute (__format_arg__) | 305 | #if __GNUC_PREREQ (2,8) || __glibc_has_attribute (__format_arg__) |
| 303 | # define __attribute_format_arg__(x) __attribute__ ((__format_arg__ (x))) | 306 | # define __attribute_format_arg__(x) __attribute__ ((__format_arg__ (x))) |
| 304 | #else | 307 | #else |
| 305 | # define __attribute_format_arg__(x) /* Ignore */ | 308 | # define __attribute_format_arg__(x) /* Ignore */ |
| @@ -309,7 +312,7 @@ | |||
| 309 | attribute for functions was introduced. We don't want to use it | 312 | attribute for functions was introduced. We don't want to use it |
| 310 | unconditionally (although this would be possible) since it | 313 | unconditionally (although this would be possible) since it |
| 311 | generates warnings. */ | 314 | generates warnings. */ |
| 312 | #if __GNUC_PREREQ (2,97) || __glibc_clang_has_attribute (__format__) | 315 | #if __GNUC_PREREQ (2,97) || __glibc_has_attribute (__format__) |
| 313 | # define __attribute_format_strfmon__(a,b) \ | 316 | # define __attribute_format_strfmon__(a,b) \ |
| 314 | __attribute__ ((__format__ (__strfmon__, a, b))) | 317 | __attribute__ ((__format__ (__strfmon__, a, b))) |
| 315 | #else | 318 | #else |
| @@ -317,19 +320,21 @@ | |||
| 317 | #endif | 320 | #endif |
| 318 | 321 | ||
| 319 | /* The nonnull function attribute marks pointer parameters that | 322 | /* The nonnull function attribute marks pointer parameters that |
| 320 | must not be NULL. Do not define __nonnull if it is already defined, | 323 | must not be NULL. */ |
| 321 | for portability when this file is used in Gnulib. */ | ||
| 322 | #ifndef __nonnull | 324 | #ifndef __nonnull |
| 323 | # if __GNUC_PREREQ (3,3) || __glibc_clang_has_attribute (__nonnull__) | 325 | # if __GNUC_PREREQ (3,3) || __glibc_has_attribute (__nonnull__) |
| 324 | # define __nonnull(params) __attribute__ ((__nonnull__ params)) | 326 | # define __nonnull(params) __attribute__ ((__nonnull__ params)) |
| 325 | # else | 327 | # else |
| 326 | # define __nonnull(params) | 328 | # define __nonnull(params) |
| 327 | # endif | 329 | # endif |
| 330 | #elif !defined __GLIBC__ | ||
| 331 | # undef __nonnull | ||
| 332 | # define __nonnull(params) _GL_ATTRIBUTE_NONNULL (params) | ||
| 328 | #endif | 333 | #endif |
| 329 | 334 | ||
| 330 | /* If fortification mode, we warn about unused results of certain | 335 | /* If fortification mode, we warn about unused results of certain |
| 331 | function calls which can lead to problems. */ | 336 | function calls which can lead to problems. */ |
| 332 | #if __GNUC_PREREQ (3,4) || __glibc_clang_has_attribute (__warn_unused_result__) | 337 | #if __GNUC_PREREQ (3,4) || __glibc_has_attribute (__warn_unused_result__) |
| 333 | # define __attribute_warn_unused_result__ \ | 338 | # define __attribute_warn_unused_result__ \ |
| 334 | __attribute__ ((__warn_unused_result__)) | 339 | __attribute__ ((__warn_unused_result__)) |
| 335 | # if defined __USE_FORTIFY_LEVEL && __USE_FORTIFY_LEVEL > 0 | 340 | # if defined __USE_FORTIFY_LEVEL && __USE_FORTIFY_LEVEL > 0 |
| @@ -343,7 +348,7 @@ | |||
| 343 | #endif | 348 | #endif |
| 344 | 349 | ||
| 345 | /* Forces a function to be always inlined. */ | 350 | /* Forces a function to be always inlined. */ |
| 346 | #if __GNUC_PREREQ (3,2) || __glibc_clang_has_attribute (__always_inline__) | 351 | #if __GNUC_PREREQ (3,2) || __glibc_has_attribute (__always_inline__) |
| 347 | /* The Linux kernel defines __always_inline in stddef.h (283d7573), and | 352 | /* The Linux kernel defines __always_inline in stddef.h (283d7573), and |
| 348 | it conflicts with this definition. Therefore undefine it first to | 353 | it conflicts with this definition. Therefore undefine it first to |
| 349 | allow either header to be included first. */ | 354 | allow either header to be included first. */ |
| @@ -356,7 +361,7 @@ | |||
| 356 | 361 | ||
| 357 | /* Associate error messages with the source location of the call site rather | 362 | /* Associate error messages with the source location of the call site rather |
| 358 | than with the source location inside the function. */ | 363 | than with the source location inside the function. */ |
| 359 | #if __GNUC_PREREQ (4,3) || __glibc_clang_has_attribute (__artificial__) | 364 | #if __GNUC_PREREQ (4,3) || __glibc_has_attribute (__artificial__) |
| 360 | # define __attribute_artificial__ __attribute__ ((__artificial__)) | 365 | # define __attribute_artificial__ __attribute__ ((__artificial__)) |
| 361 | #else | 366 | #else |
| 362 | # define __attribute_artificial__ /* Ignore */ | 367 | # define __attribute_artificial__ /* Ignore */ |
| @@ -433,7 +438,7 @@ | |||
| 433 | # endif | 438 | # endif |
| 434 | #endif | 439 | #endif |
| 435 | 440 | ||
| 436 | #if (__GNUC__ >= 3) || __glibc_clang_has_builtin (__builtin_expect) | 441 | #if (__GNUC__ >= 3) || __glibc_has_builtin (__builtin_expect) |
| 437 | # define __glibc_unlikely(cond) __builtin_expect ((cond), 0) | 442 | # define __glibc_unlikely(cond) __builtin_expect ((cond), 0) |
| 438 | # define __glibc_likely(cond) __builtin_expect ((cond), 1) | 443 | # define __glibc_likely(cond) __builtin_expect ((cond), 1) |
| 439 | #else | 444 | #else |
| @@ -441,12 +446,6 @@ | |||
| 441 | # define __glibc_likely(cond) (cond) | 446 | # define __glibc_likely(cond) (cond) |
| 442 | #endif | 447 | #endif |
| 443 | 448 | ||
| 444 | #ifdef __has_attribute | ||
| 445 | # define __glibc_has_attribute(attr) __has_attribute (attr) | ||
| 446 | #else | ||
| 447 | # define __glibc_has_attribute(attr) 0 | ||
| 448 | #endif | ||
| 449 | |||
| 450 | #if (!defined _Noreturn \ | 449 | #if (!defined _Noreturn \ |
| 451 | && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \ | 450 | && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \ |
| 452 | && !(__GNUC_PREREQ (4,7) \ | 451 | && !(__GNUC_PREREQ (4,7) \ |
| @@ -467,6 +466,16 @@ | |||
| 467 | # define __attribute_nonstring__ | 466 | # define __attribute_nonstring__ |
| 468 | #endif | 467 | #endif |
| 469 | 468 | ||
| 469 | /* Undefine (also defined in libc-symbols.h). */ | ||
| 470 | #undef __attribute_copy__ | ||
| 471 | #if __GNUC_PREREQ (9, 0) | ||
| 472 | /* Copies attributes from the declaration or type referenced by | ||
| 473 | the argument. */ | ||
| 474 | # define __attribute_copy__(arg) __attribute__ ((__copy__ (arg))) | ||
| 475 | #else | ||
| 476 | # define __attribute_copy__(arg) | ||
| 477 | #endif | ||
| 478 | |||
| 470 | #if (!defined _Static_assert && !defined __cplusplus \ | 479 | #if (!defined _Static_assert && !defined __cplusplus \ |
| 471 | && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \ | 480 | && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \ |
| 472 | && (!(__GNUC_PREREQ (4, 6) || __clang_major__ >= 4) \ | 481 | && (!(__GNUC_PREREQ (4, 6) || __clang_major__ >= 4) \ |
| @@ -483,7 +492,37 @@ | |||
| 483 | # include <bits/long-double.h> | 492 | # include <bits/long-double.h> |
| 484 | #endif | 493 | #endif |
| 485 | 494 | ||
| 486 | #if defined __LONG_DOUBLE_MATH_OPTIONAL && defined __NO_LONG_DOUBLE_MATH | 495 | #if __LDOUBLE_REDIRECTS_TO_FLOAT128_ABI == 1 |
| 496 | # ifdef __REDIRECT | ||
| 497 | |||
| 498 | /* Alias name defined automatically. */ | ||
| 499 | # define __LDBL_REDIR(name, proto) ... unused__ldbl_redir | ||
| 500 | # define __LDBL_REDIR_DECL(name) \ | ||
| 501 | extern __typeof (name) name __asm (__ASMNAME ("__" #name "ieee128")); | ||
| 502 | |||
| 503 | /* Alias name defined automatically, with leading underscores. */ | ||
| 504 | # define __LDBL_REDIR2_DECL(name) \ | ||
| 505 | extern __typeof (__##name) __##name \ | ||
| 506 | __asm (__ASMNAME ("__" #name "ieee128")); | ||
| 507 | |||
| 508 | /* Alias name defined manually. */ | ||
| 509 | # define __LDBL_REDIR1(name, proto, alias) ... unused__ldbl_redir1 | ||
| 510 | # define __LDBL_REDIR1_DECL(name, alias) \ | ||
| 511 | extern __typeof (name) name __asm (__ASMNAME (#alias)); | ||
| 512 | |||
| 513 | # define __LDBL_REDIR1_NTH(name, proto, alias) \ | ||
| 514 | __REDIRECT_NTH (name, proto, alias) | ||
| 515 | # define __REDIRECT_NTH_LDBL(name, proto, alias) \ | ||
| 516 | __LDBL_REDIR1_NTH (name, proto, __##alias##ieee128) | ||
| 517 | |||
| 518 | /* Unused. */ | ||
| 519 | # define __REDIRECT_LDBL(name, proto, alias) ... unused__redirect_ldbl | ||
| 520 | # define __LDBL_REDIR_NTH(name, proto) ... unused__ldbl_redir_nth | ||
| 521 | |||
| 522 | # else | ||
| 523 | _Static_assert (0, "IEEE 128-bits long double requires redirection on this platform"); | ||
| 524 | # endif | ||
| 525 | #elif defined __LONG_DOUBLE_MATH_OPTIONAL && defined __NO_LONG_DOUBLE_MATH | ||
| 487 | # define __LDBL_COMPAT 1 | 526 | # define __LDBL_COMPAT 1 |
| 488 | # ifdef __REDIRECT | 527 | # ifdef __REDIRECT |
| 489 | # define __LDBL_REDIR1(name, proto, alias) __REDIRECT (name, proto, alias) | 528 | # define __LDBL_REDIR1(name, proto, alias) __REDIRECT (name, proto, alias) |
| @@ -492,6 +531,8 @@ | |||
| 492 | # define __LDBL_REDIR1_NTH(name, proto, alias) __REDIRECT_NTH (name, proto, alias) | 531 | # define __LDBL_REDIR1_NTH(name, proto, alias) __REDIRECT_NTH (name, proto, alias) |
| 493 | # define __LDBL_REDIR_NTH(name, proto) \ | 532 | # define __LDBL_REDIR_NTH(name, proto) \ |
| 494 | __LDBL_REDIR1_NTH (name, proto, __nldbl_##name) | 533 | __LDBL_REDIR1_NTH (name, proto, __nldbl_##name) |
| 534 | # define __LDBL_REDIR2_DECL(name) \ | ||
| 535 | extern __typeof (__##name) __##name __asm (__ASMNAME ("__nldbl___" #name)); | ||
| 495 | # define __LDBL_REDIR1_DECL(name, alias) \ | 536 | # define __LDBL_REDIR1_DECL(name, alias) \ |
| 496 | extern __typeof (name) name __asm (__ASMNAME (#alias)); | 537 | extern __typeof (name) name __asm (__ASMNAME (#alias)); |
| 497 | # define __LDBL_REDIR_DECL(name) \ | 538 | # define __LDBL_REDIR_DECL(name) \ |
| @@ -502,11 +543,13 @@ | |||
| 502 | __LDBL_REDIR1_NTH (name, proto, __nldbl_##alias) | 543 | __LDBL_REDIR1_NTH (name, proto, __nldbl_##alias) |
| 503 | # endif | 544 | # endif |
| 504 | #endif | 545 | #endif |
| 505 | #if !defined __LDBL_COMPAT || !defined __REDIRECT | 546 | #if (!defined __LDBL_COMPAT && __LDOUBLE_REDIRECTS_TO_FLOAT128_ABI == 0) \ |
| 547 | || !defined __REDIRECT | ||
| 506 | # define __LDBL_REDIR1(name, proto, alias) name proto | 548 | # define __LDBL_REDIR1(name, proto, alias) name proto |
| 507 | # define __LDBL_REDIR(name, proto) name proto | 549 | # define __LDBL_REDIR(name, proto) name proto |
| 508 | # define __LDBL_REDIR1_NTH(name, proto, alias) name proto __THROW | 550 | # define __LDBL_REDIR1_NTH(name, proto, alias) name proto __THROW |
| 509 | # define __LDBL_REDIR_NTH(name, proto) name proto __THROW | 551 | # define __LDBL_REDIR_NTH(name, proto) name proto __THROW |
| 552 | # define __LDBL_REDIR2_DECL(name) | ||
| 510 | # define __LDBL_REDIR_DECL(name) | 553 | # define __LDBL_REDIR_DECL(name) |
| 511 | # ifdef __REDIRECT | 554 | # ifdef __REDIRECT |
| 512 | # define __REDIRECT_LDBL(name, proto, alias) __REDIRECT (name, proto, alias) | 555 | # define __REDIRECT_LDBL(name, proto, alias) __REDIRECT (name, proto, alias) |
| @@ -537,7 +580,7 @@ | |||
| 537 | check is required to enable the use of generic selection. */ | 580 | check is required to enable the use of generic selection. */ |
| 538 | #if !defined __cplusplus \ | 581 | #if !defined __cplusplus \ |
| 539 | && (__GNUC_PREREQ (4, 9) \ | 582 | && (__GNUC_PREREQ (4, 9) \ |
| 540 | || __glibc_clang_has_extension (c_generic_selections) \ | 583 | || __glibc_has_extension (c_generic_selections) \ |
| 541 | || (!defined __GNUC__ && defined __STDC_VERSION__ \ | 584 | || (!defined __GNUC__ && defined __STDC_VERSION__ \ |
| 542 | && __STDC_VERSION__ >= 201112L)) | 585 | && __STDC_VERSION__ >= 201112L)) |
| 543 | # define __HAVE_GENERIC_SELECTION 1 | 586 | # define __HAVE_GENERIC_SELECTION 1 |
| @@ -545,4 +588,23 @@ | |||
| 545 | # define __HAVE_GENERIC_SELECTION 0 | 588 | # define __HAVE_GENERIC_SELECTION 0 |
| 546 | #endif | 589 | #endif |
| 547 | 590 | ||
| 591 | #if __GNUC_PREREQ (10, 0) | ||
| 592 | /* Designates a 1-based positional argument ref-index of pointer type | ||
| 593 | that can be used to access size-index elements of the pointed-to | ||
| 594 | array according to access mode, or at least one element when | ||
| 595 | size-index is not provided: | ||
| 596 | access (access-mode, <ref-index> [, <size-index>]) */ | ||
| 597 | #define __attr_access(x) __attribute__ ((__access__ x)) | ||
| 598 | #else | ||
| 599 | # define __attr_access(x) | ||
| 600 | #endif | ||
| 601 | |||
| 602 | /* Specify that a function such as setjmp or vfork may return | ||
| 603 | twice. */ | ||
| 604 | #if __GNUC_PREREQ (4, 1) | ||
| 605 | # define __attribute_returns_twice__ __attribute__ ((__returns_twice__)) | ||
| 606 | #else | ||
| 607 | # define __attribute_returns_twice__ /* Ignore. */ | ||
| 608 | #endif | ||
| 609 | |||
| 548 | #endif /* sys/cdefs.h */ | 610 | #endif /* sys/cdefs.h */ |
diff --git a/lib/dirent.in.h b/lib/dirent.in.h index 2e2c5119a11..4666972b150 100644 --- a/lib/dirent.in.h +++ b/lib/dirent.in.h | |||
| @@ -154,7 +154,8 @@ _GL_WARN_ON_USE (closedir, "closedir is not portable - " | |||
| 154 | /* Return the file descriptor associated with the given directory stream, | 154 | /* Return the file descriptor associated with the given directory stream, |
| 155 | or -1 if none exists. */ | 155 | or -1 if none exists. */ |
| 156 | # if @REPLACE_DIRFD@ | 156 | # if @REPLACE_DIRFD@ |
| 157 | # if !(defined __cplusplus && defined GNULIB_NAMESPACE) | 157 | /* On kLIBC, dirfd() is a macro that does not work. Undefine it. */ |
| 158 | # if !(defined __cplusplus && defined GNULIB_NAMESPACE) || defined dirfd | ||
| 158 | # undef dirfd | 159 | # undef dirfd |
| 159 | # define dirfd rpl_dirfd | 160 | # define dirfd rpl_dirfd |
| 160 | # endif | 161 | # endif |
diff --git a/lib/dynarray.h b/lib/dynarray.h new file mode 100644 index 00000000000..6da3e87e55f --- /dev/null +++ b/lib/dynarray.h | |||
| @@ -0,0 +1,31 @@ | |||
| 1 | /* Type-safe arrays which grow dynamically. | ||
| 2 | Copyright 2021 Free Software Foundation, Inc. | ||
| 3 | |||
| 4 | This program is free software: you can redistribute it and/or modify | ||
| 5 | it under the terms of the GNU General Public License as published by | ||
| 6 | the Free Software Foundation; either version 3 of the License, or | ||
| 7 | (at your option) any later version. | ||
| 8 | |||
| 9 | This program is distributed in the hope that it will be useful, | ||
| 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 12 | GNU General Public License for more details. | ||
| 13 | |||
| 14 | You should have received a copy of the GNU General Public License | ||
| 15 | along with this program. If not, see <https://www.gnu.org/licenses/>. */ | ||
| 16 | |||
| 17 | /* Written by Paul Eggert, 2021. */ | ||
| 18 | |||
| 19 | #ifndef _GL_DYNARRAY_H | ||
| 20 | #define _GL_DYNARRAY_H | ||
| 21 | |||
| 22 | #include <libc-config.h> | ||
| 23 | |||
| 24 | #define __libc_dynarray_at_failure gl_dynarray_at_failure | ||
| 25 | #define __libc_dynarray_emplace_enlarge gl_dynarray_emplace_enlarge | ||
| 26 | #define __libc_dynarray_finalize gl_dynarray_finalize | ||
| 27 | #define __libc_dynarray_resize_clear gl_dynarray_resize_clear | ||
| 28 | #define __libc_dynarray_resize gl_dynarray_resize | ||
| 29 | #include <malloc/dynarray.h> | ||
| 30 | |||
| 31 | #endif /* _GL_DYNARRAY_H */ | ||
diff --git a/lib/explicit_bzero.c b/lib/explicit_bzero.c index feea4446c06..f50ed0875d7 100644 --- a/lib/explicit_bzero.c +++ b/lib/explicit_bzero.c | |||
| @@ -54,11 +54,21 @@ explicit_bzero (void *s, size_t len) | |||
| 54 | explicit_memset (s, '\0', len); | 54 | explicit_memset (s, '\0', len); |
| 55 | #elif HAVE_MEMSET_S | 55 | #elif HAVE_MEMSET_S |
| 56 | (void) memset_s (s, len, '\0', len); | 56 | (void) memset_s (s, len, '\0', len); |
| 57 | #else | 57 | #elif defined __GNUC__ && !defined __clang__ |
| 58 | memset (s, '\0', len); | 58 | memset (s, '\0', len); |
| 59 | # if defined __GNUC__ && !defined __clang__ | ||
| 60 | /* Compiler barrier. */ | 59 | /* Compiler barrier. */ |
| 61 | asm volatile ("" ::: "memory"); | 60 | asm volatile ("" ::: "memory"); |
| 62 | # endif | 61 | #elif defined __clang__ |
| 62 | memset (s, '\0', len); | ||
| 63 | /* Compiler barrier. */ | ||
| 64 | /* With asm ("" ::: "memory") LLVM analyzes uses of 's' and finds that the | ||
| 65 | whole thing is dead and eliminates it. Use 'g' to work around this | ||
| 66 | problem. See <https://bugs.llvm.org/show_bug.cgi?id=15495#c11>. */ | ||
| 67 | __asm__ volatile ("" : : "g"(s) : "memory"); | ||
| 68 | #else | ||
| 69 | /* Invoke memset through a volatile function pointer. This defeats compiler | ||
| 70 | optimizations. */ | ||
| 71 | void * (* const volatile volatile_memset) (void *, int, size_t) = memset; | ||
| 72 | (void) volatile_memset (s, '\0', len); | ||
| 63 | #endif | 73 | #endif |
| 64 | } | 74 | } |
diff --git a/lib/fchmodat.c b/lib/fchmodat.c index d27c0d7734a..eb6e2242fdd 100644 --- a/lib/fchmodat.c +++ b/lib/fchmodat.c | |||
| @@ -38,6 +38,7 @@ orig_fchmodat (int dir, char const *file, mode_t mode, int flags) | |||
| 38 | #include <fcntl.h> | 38 | #include <fcntl.h> |
| 39 | #include <stdio.h> | 39 | #include <stdio.h> |
| 40 | #include <stdlib.h> | 40 | #include <stdlib.h> |
| 41 | #include <string.h> | ||
| 41 | #include <unistd.h> | 42 | #include <unistd.h> |
| 42 | 43 | ||
| 43 | #ifdef __osf__ | 44 | #ifdef __osf__ |
| @@ -63,6 +64,22 @@ orig_fchmodat (int dir, char const *file, mode_t mode, int flags) | |||
| 63 | int | 64 | int |
| 64 | fchmodat (int dir, char const *file, mode_t mode, int flags) | 65 | fchmodat (int dir, char const *file, mode_t mode, int flags) |
| 65 | { | 66 | { |
| 67 | # if HAVE_NEARLY_WORKING_FCHMODAT | ||
| 68 | /* Correct the trailing slash handling. */ | ||
| 69 | size_t len = strlen (file); | ||
| 70 | if (len && file[len - 1] == '/') | ||
| 71 | { | ||
| 72 | struct stat st; | ||
| 73 | if (fstatat (dir, file, &st, flags & AT_SYMLINK_NOFOLLOW) < 0) | ||
| 74 | return -1; | ||
| 75 | if (!S_ISDIR (st.st_mode)) | ||
| 76 | { | ||
| 77 | errno = ENOTDIR; | ||
| 78 | return -1; | ||
| 79 | } | ||
| 80 | } | ||
| 81 | # endif | ||
| 82 | |||
| 66 | # if NEED_FCHMODAT_NONSYMLINK_FIX | 83 | # if NEED_FCHMODAT_NONSYMLINK_FIX |
| 67 | if (flags == AT_SYMLINK_NOFOLLOW) | 84 | if (flags == AT_SYMLINK_NOFOLLOW) |
| 68 | { | 85 | { |
diff --git a/lib/free.c b/lib/free.c index 135c3eb16bc..5c89787aba1 100644 --- a/lib/free.c +++ b/lib/free.c | |||
| @@ -27,7 +27,21 @@ void | |||
| 27 | rpl_free (void *p) | 27 | rpl_free (void *p) |
| 28 | #undef free | 28 | #undef free |
| 29 | { | 29 | { |
| 30 | #if defined __GNUC__ && !defined __clang__ | ||
| 31 | /* An invalid GCC optimization | ||
| 32 | <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98396> | ||
| 33 | would optimize away the assignments in the code below, when link-time | ||
| 34 | optimization (LTO) is enabled. Make the code more complicated, so that | ||
| 35 | GCC does not grok how to optimize it. */ | ||
| 36 | int err[2]; | ||
| 37 | err[0] = errno; | ||
| 38 | err[1] = errno; | ||
| 39 | errno = 0; | ||
| 40 | free (p); | ||
| 41 | errno = err[errno == 0]; | ||
| 42 | #else | ||
| 30 | int err = errno; | 43 | int err = errno; |
| 31 | free (p); | 44 | free (p); |
| 32 | errno = err; | 45 | errno = err; |
| 46 | #endif | ||
| 33 | } | 47 | } |
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index c457ac61209..07736f9b8bc 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in | |||
| @@ -516,6 +516,7 @@ GNULIB_SYMLINK = @GNULIB_SYMLINK@ | |||
| 516 | GNULIB_SYMLINKAT = @GNULIB_SYMLINKAT@ | 516 | GNULIB_SYMLINKAT = @GNULIB_SYMLINKAT@ |
| 517 | GNULIB_SYSTEM_POSIX = @GNULIB_SYSTEM_POSIX@ | 517 | GNULIB_SYSTEM_POSIX = @GNULIB_SYSTEM_POSIX@ |
| 518 | GNULIB_TIMEGM = @GNULIB_TIMEGM@ | 518 | GNULIB_TIMEGM = @GNULIB_TIMEGM@ |
| 519 | GNULIB_TIMESPEC_GET = @GNULIB_TIMESPEC_GET@ | ||
| 519 | GNULIB_TIME_R = @GNULIB_TIME_R@ | 520 | GNULIB_TIME_R = @GNULIB_TIME_R@ |
| 520 | GNULIB_TIME_RZ = @GNULIB_TIME_RZ@ | 521 | GNULIB_TIME_RZ = @GNULIB_TIME_RZ@ |
| 521 | GNULIB_TMPFILE = @GNULIB_TMPFILE@ | 522 | GNULIB_TMPFILE = @GNULIB_TMPFILE@ |
| @@ -746,6 +747,7 @@ HAVE_SYS_SELECT_H = @HAVE_SYS_SELECT_H@ | |||
| 746 | HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@ | 747 | HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@ |
| 747 | HAVE_SYS_TYPES_H = @HAVE_SYS_TYPES_H@ | 748 | HAVE_SYS_TYPES_H = @HAVE_SYS_TYPES_H@ |
| 748 | HAVE_TIMEGM = @HAVE_TIMEGM@ | 749 | HAVE_TIMEGM = @HAVE_TIMEGM@ |
| 750 | HAVE_TIMESPEC_GET = @HAVE_TIMESPEC_GET@ | ||
| 749 | HAVE_TIMEZONE_T = @HAVE_TIMEZONE_T@ | 751 | HAVE_TIMEZONE_T = @HAVE_TIMEZONE_T@ |
| 750 | HAVE_TYPE_VOLATILE_SIG_ATOMIC_T = @HAVE_TYPE_VOLATILE_SIG_ATOMIC_T@ | 752 | HAVE_TYPE_VOLATILE_SIG_ATOMIC_T = @HAVE_TYPE_VOLATILE_SIG_ATOMIC_T@ |
| 751 | HAVE_UNISTD_H = @HAVE_UNISTD_H@ | 753 | HAVE_UNISTD_H = @HAVE_UNISTD_H@ |
| @@ -949,6 +951,7 @@ REPLACE_FCNTL = @REPLACE_FCNTL@ | |||
| 949 | REPLACE_FDOPEN = @REPLACE_FDOPEN@ | 951 | REPLACE_FDOPEN = @REPLACE_FDOPEN@ |
| 950 | REPLACE_FDOPENDIR = @REPLACE_FDOPENDIR@ | 952 | REPLACE_FDOPENDIR = @REPLACE_FDOPENDIR@ |
| 951 | REPLACE_FFLUSH = @REPLACE_FFLUSH@ | 953 | REPLACE_FFLUSH = @REPLACE_FFLUSH@ |
| 954 | REPLACE_FFSLL = @REPLACE_FFSLL@ | ||
| 952 | REPLACE_FOPEN = @REPLACE_FOPEN@ | 955 | REPLACE_FOPEN = @REPLACE_FOPEN@ |
| 953 | REPLACE_FPRINTF = @REPLACE_FPRINTF@ | 956 | REPLACE_FPRINTF = @REPLACE_FPRINTF@ |
| 954 | REPLACE_FPURGE = @REPLACE_FPURGE@ | 957 | REPLACE_FPURGE = @REPLACE_FPURGE@ |
| @@ -989,7 +992,9 @@ REPLACE_MEMCHR = @REPLACE_MEMCHR@ | |||
| 989 | REPLACE_MEMMEM = @REPLACE_MEMMEM@ | 992 | REPLACE_MEMMEM = @REPLACE_MEMMEM@ |
| 990 | REPLACE_MKDIR = @REPLACE_MKDIR@ | 993 | REPLACE_MKDIR = @REPLACE_MKDIR@ |
| 991 | REPLACE_MKFIFO = @REPLACE_MKFIFO@ | 994 | REPLACE_MKFIFO = @REPLACE_MKFIFO@ |
| 995 | REPLACE_MKFIFOAT = @REPLACE_MKFIFOAT@ | ||
| 992 | REPLACE_MKNOD = @REPLACE_MKNOD@ | 996 | REPLACE_MKNOD = @REPLACE_MKNOD@ |
| 997 | REPLACE_MKNODAT = @REPLACE_MKNODAT@ | ||
| 993 | REPLACE_MKSTEMP = @REPLACE_MKSTEMP@ | 998 | REPLACE_MKSTEMP = @REPLACE_MKSTEMP@ |
| 994 | REPLACE_MKTIME = @REPLACE_MKTIME@ | 999 | REPLACE_MKTIME = @REPLACE_MKTIME@ |
| 995 | REPLACE_NANOSLEEP = @REPLACE_NANOSLEEP@ | 1000 | REPLACE_NANOSLEEP = @REPLACE_NANOSLEEP@ |
| @@ -1087,6 +1092,7 @@ SYSTEM_TYPE = @SYSTEM_TYPE@ | |||
| 1087 | SYS_TIME_H_DEFINES_STRUCT_TIMESPEC = @SYS_TIME_H_DEFINES_STRUCT_TIMESPEC@ | 1092 | SYS_TIME_H_DEFINES_STRUCT_TIMESPEC = @SYS_TIME_H_DEFINES_STRUCT_TIMESPEC@ |
| 1088 | TERMCAP_OBJ = @TERMCAP_OBJ@ | 1093 | TERMCAP_OBJ = @TERMCAP_OBJ@ |
| 1089 | TIME_H_DEFINES_STRUCT_TIMESPEC = @TIME_H_DEFINES_STRUCT_TIMESPEC@ | 1094 | TIME_H_DEFINES_STRUCT_TIMESPEC = @TIME_H_DEFINES_STRUCT_TIMESPEC@ |
| 1095 | TIME_H_DEFINES_TIME_UTC = @TIME_H_DEFINES_TIME_UTC@ | ||
| 1090 | TOOLKIT_LIBW = @TOOLKIT_LIBW@ | 1096 | TOOLKIT_LIBW = @TOOLKIT_LIBW@ |
| 1091 | UINT32_MAX_LT_UINTMAX_MAX = @UINT32_MAX_LT_UINTMAX_MAX@ | 1097 | UINT32_MAX_LT_UINTMAX_MAX = @UINT32_MAX_LT_UINTMAX_MAX@ |
| 1092 | UINT64_MAX_EQ_ULONG_MAX = @UINT64_MAX_EQ_ULONG_MAX@ | 1098 | UINT64_MAX_EQ_ULONG_MAX = @UINT64_MAX_EQ_ULONG_MAX@ |
| @@ -1171,6 +1177,7 @@ gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1 = @gl_GNULIB_ENABLED_a9786850 | |||
| 1171 | gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36@ | 1177 | gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36@ |
| 1172 | gl_GNULIB_ENABLED_cloexec = @gl_GNULIB_ENABLED_cloexec@ | 1178 | gl_GNULIB_ENABLED_cloexec = @gl_GNULIB_ENABLED_cloexec@ |
| 1173 | gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@ | 1179 | gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@ |
| 1180 | gl_GNULIB_ENABLED_dynarray = @gl_GNULIB_ENABLED_dynarray@ | ||
| 1174 | gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@ | 1181 | gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@ |
| 1175 | gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@ | 1182 | gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@ |
| 1176 | gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@ | 1183 | gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@ |
| @@ -1584,6 +1591,20 @@ EXTRA_libgnu_a_SOURCES += dup2.c | |||
| 1584 | endif | 1591 | endif |
| 1585 | ## end gnulib module dup2 | 1592 | ## end gnulib module dup2 |
| 1586 | 1593 | ||
| 1594 | ## begin gnulib module dynarray | ||
| 1595 | ifeq (,$(OMIT_GNULIB_MODULE_dynarray)) | ||
| 1596 | |||
| 1597 | ifneq (,$(gl_GNULIB_ENABLED_dynarray)) | ||
| 1598 | 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 | ||
| 1599 | |||
| 1600 | endif | ||
| 1601 | EXTRA_DIST += dynarray.h malloc/dynarray-skeleton.c malloc/dynarray.h | ||
| 1602 | |||
| 1603 | EXTRA_libgnu_a_SOURCES += malloc/dynarray-skeleton.c | ||
| 1604 | |||
| 1605 | endif | ||
| 1606 | ## end gnulib module dynarray | ||
| 1607 | |||
| 1587 | ## begin gnulib module eloop-threshold | 1608 | ## begin gnulib module eloop-threshold |
| 1588 | ifeq (,$(OMIT_GNULIB_MODULE_eloop-threshold)) | 1609 | ifeq (,$(OMIT_GNULIB_MODULE_eloop-threshold)) |
| 1589 | 1610 | ||
| @@ -3036,6 +3057,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H | |||
| 3036 | -e 's|@''HAVE_SIGDESCR_NP''@|$(HAVE_SIGDESCR_NP)|g' \ | 3057 | -e 's|@''HAVE_SIGDESCR_NP''@|$(HAVE_SIGDESCR_NP)|g' \ |
| 3037 | -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \ | 3058 | -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \ |
| 3038 | -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \ | 3059 | -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \ |
| 3060 | -e 's|@''REPLACE_FFSLL''@|$(REPLACE_FFSLL)|g' \ | ||
| 3039 | -e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \ | 3061 | -e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \ |
| 3040 | -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \ | 3062 | -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \ |
| 3041 | -e 's|@''REPLACE_STPNCPY''@|$(REPLACE_STPNCPY)|g' \ | 3063 | -e 's|@''REPLACE_STPNCPY''@|$(REPLACE_STPNCPY)|g' \ |
| @@ -3237,7 +3259,9 @@ sys/stat.h: sys_stat.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNU | |||
| 3237 | -e 's|@''REPLACE_LSTAT''@|$(REPLACE_LSTAT)|g' \ | 3259 | -e 's|@''REPLACE_LSTAT''@|$(REPLACE_LSTAT)|g' \ |
| 3238 | -e 's|@''REPLACE_MKDIR''@|$(REPLACE_MKDIR)|g' \ | 3260 | -e 's|@''REPLACE_MKDIR''@|$(REPLACE_MKDIR)|g' \ |
| 3239 | -e 's|@''REPLACE_MKFIFO''@|$(REPLACE_MKFIFO)|g' \ | 3261 | -e 's|@''REPLACE_MKFIFO''@|$(REPLACE_MKFIFO)|g' \ |
| 3262 | -e 's|@''REPLACE_MKFIFOAT''@|$(REPLACE_MKFIFOAT)|g' \ | ||
| 3240 | -e 's|@''REPLACE_MKNOD''@|$(REPLACE_MKNOD)|g' \ | 3263 | -e 's|@''REPLACE_MKNOD''@|$(REPLACE_MKNOD)|g' \ |
| 3264 | -e 's|@''REPLACE_MKNODAT''@|$(REPLACE_MKNODAT)|g' \ | ||
| 3241 | -e 's|@''REPLACE_STAT''@|$(REPLACE_STAT)|g' \ | 3265 | -e 's|@''REPLACE_STAT''@|$(REPLACE_STAT)|g' \ |
| 3242 | -e 's|@''REPLACE_UTIMENSAT''@|$(REPLACE_UTIMENSAT)|g' \ | 3266 | -e 's|@''REPLACE_UTIMENSAT''@|$(REPLACE_UTIMENSAT)|g' \ |
| 3243 | -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ | 3267 | -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ |
| @@ -3350,6 +3374,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( | |||
| 3350 | -e 's/@''GNULIB_STRFTIME''@/$(GNULIB_STRFTIME)/g' \ | 3374 | -e 's/@''GNULIB_STRFTIME''@/$(GNULIB_STRFTIME)/g' \ |
| 3351 | -e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \ | 3375 | -e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \ |
| 3352 | -e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \ | 3376 | -e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \ |
| 3377 | -e 's/@''GNULIB_TIMESPEC_GET''@/$(GNULIB_TIMESPEC_GET)/g' \ | ||
| 3353 | -e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \ | 3378 | -e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \ |
| 3354 | -e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \ | 3379 | -e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \ |
| 3355 | -e 's/@''GNULIB_TZSET''@/$(GNULIB_TZSET)/g' \ | 3380 | -e 's/@''GNULIB_TZSET''@/$(GNULIB_TZSET)/g' \ |
| @@ -3358,6 +3383,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( | |||
| 3358 | -e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \ | 3383 | -e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \ |
| 3359 | -e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \ | 3384 | -e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \ |
| 3360 | -e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \ | 3385 | -e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \ |
| 3386 | -e 's|@''HAVE_TIMESPEC_GET''@|$(HAVE_TIMESPEC_GET)|g' \ | ||
| 3361 | -e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \ | 3387 | -e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \ |
| 3362 | -e 's|@''REPLACE_CTIME''@|$(REPLACE_CTIME)|g' \ | 3388 | -e 's|@''REPLACE_CTIME''@|$(REPLACE_CTIME)|g' \ |
| 3363 | -e 's|@''REPLACE_GMTIME''@|$(REPLACE_GMTIME)|g' \ | 3389 | -e 's|@''REPLACE_GMTIME''@|$(REPLACE_GMTIME)|g' \ |
| @@ -3372,6 +3398,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( | |||
| 3372 | -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ | 3398 | -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ |
| 3373 | -e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ | 3399 | -e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ |
| 3374 | -e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \ | 3400 | -e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \ |
| 3401 | -e 's|@''TIME_H_DEFINES_TIME_UTC''@|$(TIME_H_DEFINES_TIME_UTC)|g' \ | ||
| 3375 | -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ | 3402 | -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ |
| 3376 | -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ | 3403 | -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ |
| 3377 | -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ | 3404 | -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ |
diff --git a/lib/libc-config.h b/lib/libc-config.h index d4e29951f35..c0eac707cfd 100644 --- a/lib/libc-config.h +++ b/lib/libc-config.h | |||
| @@ -71,107 +71,112 @@ | |||
| 71 | # endif | 71 | # endif |
| 72 | #endif | 72 | #endif |
| 73 | 73 | ||
| 74 | 74 | #ifndef __attribute_maybe_unused__ | |
| 75 | /* Prepare to include <cdefs.h>, which is our copy of glibc | 75 | /* <sys/cdefs.h> either does not exist, or is too old for Gnulib. |
| 76 | <sys/cdefs.h>. */ | 76 | Prepare to include <cdefs.h>, which is Gnulib's version of a |
| 77 | more-recent glibc <sys/cdefs.h>. */ | ||
| 77 | 78 | ||
| 78 | /* Define _FEATURES_H so that <cdefs.h> does not include <features.h>. */ | 79 | /* Define _FEATURES_H so that <cdefs.h> does not include <features.h>. */ |
| 79 | #ifndef _FEATURES_H | 80 | # ifndef _FEATURES_H |
| 80 | # define _FEATURES_H 1 | 81 | # define _FEATURES_H 1 |
| 81 | #endif | 82 | # endif |
| 82 | /* Define __WORDSIZE so that <cdefs.h> does not attempt to include | 83 | /* Define __WORDSIZE so that <cdefs.h> does not attempt to include |
| 83 | nonexistent files. Make it a syntax error, since Gnulib does not | 84 | nonexistent files. Make it a syntax error, since Gnulib does not |
| 84 | use __WORDSIZE now, and if Gnulib uses it later the syntax error | 85 | use __WORDSIZE now, and if Gnulib uses it later the syntax error |
| 85 | will let us know that __WORDSIZE needs configuring. */ | 86 | will let us know that __WORDSIZE needs configuring. */ |
| 86 | #ifndef __WORDSIZE | 87 | # ifndef __WORDSIZE |
| 87 | # define __WORDSIZE %%% | 88 | # define __WORDSIZE %%% |
| 88 | #endif | 89 | # endif |
| 89 | /* Undef the macros unconditionally defined by our copy of glibc | 90 | /* Undef the macros unconditionally defined by our copy of glibc |
| 90 | <sys/cdefs.h>, so that they do not clash with any system-defined | 91 | <sys/cdefs.h>, so that they do not clash with any system-defined |
| 91 | versions. */ | 92 | versions. */ |
| 92 | #undef _SYS_CDEFS_H | 93 | # undef _SYS_CDEFS_H |
| 93 | #undef __ASMNAME | 94 | # undef __ASMNAME |
| 94 | #undef __ASMNAME2 | 95 | # undef __ASMNAME2 |
| 95 | #undef __BEGIN_DECLS | 96 | # undef __BEGIN_DECLS |
| 96 | #undef __CONCAT | 97 | # undef __CONCAT |
| 97 | #undef __END_DECLS | 98 | # undef __END_DECLS |
| 98 | #undef __HAVE_GENERIC_SELECTION | 99 | # undef __HAVE_GENERIC_SELECTION |
| 99 | #undef __LDBL_COMPAT | 100 | # undef __LDBL_COMPAT |
| 100 | #undef __LDBL_REDIR | 101 | # undef __LDBL_REDIR |
| 101 | #undef __LDBL_REDIR1 | 102 | # undef __LDBL_REDIR1 |
| 102 | #undef __LDBL_REDIR1_DECL | 103 | # undef __LDBL_REDIR1_DECL |
| 103 | #undef __LDBL_REDIR1_NTH | 104 | # undef __LDBL_REDIR1_NTH |
| 104 | #undef __LDBL_REDIR_DECL | 105 | # undef __LDBL_REDIR2_DECL |
| 105 | #undef __LDBL_REDIR_NTH | 106 | # undef __LDBL_REDIR_DECL |
| 106 | #undef __LEAF | 107 | # undef __LDBL_REDIR_NTH |
| 107 | #undef __LEAF_ATTR | 108 | # undef __LEAF |
| 108 | #undef __NTH | 109 | # undef __LEAF_ATTR |
| 109 | #undef __NTHNL | 110 | # undef __NTH |
| 110 | #undef __P | 111 | # undef __NTHNL |
| 111 | #undef __PMT | 112 | # undef __REDIRECT |
| 112 | #undef __REDIRECT | 113 | # undef __REDIRECT_LDBL |
| 113 | #undef __REDIRECT_LDBL | 114 | # undef __REDIRECT_NTH |
| 114 | #undef __REDIRECT_NTH | 115 | # undef __REDIRECT_NTHNL |
| 115 | #undef __REDIRECT_NTHNL | 116 | # undef __REDIRECT_NTH_LDBL |
| 116 | #undef __REDIRECT_NTH_LDBL | 117 | # undef __STRING |
| 117 | #undef __STRING | 118 | # undef __THROW |
| 118 | #undef __THROW | 119 | # undef __THROWNL |
| 119 | #undef __THROWNL | 120 | # undef __attr_access |
| 120 | #undef __always_inline | 121 | # undef __attribute__ |
| 121 | #undef __attribute__ | 122 | # undef __attribute_alloc_size__ |
| 122 | #undef __attribute_alloc_size__ | 123 | # undef __attribute_artificial__ |
| 123 | #undef __attribute_artificial__ | 124 | # undef __attribute_const__ |
| 124 | #undef __attribute_const__ | 125 | # undef __attribute_deprecated__ |
| 125 | #undef __attribute_deprecated__ | 126 | # undef __attribute_deprecated_msg__ |
| 126 | #undef __attribute_deprecated_msg__ | 127 | # undef __attribute_format_arg__ |
| 127 | #undef __attribute_format_arg__ | 128 | # undef __attribute_format_strfmon__ |
| 128 | #undef __attribute_format_strfmon__ | 129 | # undef __attribute_malloc__ |
| 129 | #undef __attribute_malloc__ | 130 | # undef __attribute_noinline__ |
| 130 | #undef __attribute_noinline__ | 131 | # undef __attribute_nonstring__ |
| 131 | #undef __attribute_nonstring__ | 132 | # undef __attribute_pure__ |
| 132 | #undef __attribute_pure__ | 133 | # undef __attribute_returns_twice__ |
| 133 | #undef __attribute_used__ | 134 | # undef __attribute_used__ |
| 134 | #undef __attribute_warn_unused_result__ | 135 | # undef __attribute_warn_unused_result__ |
| 135 | #undef __bos | 136 | # undef __bos |
| 136 | #undef __bos0 | 137 | # undef __bos0 |
| 137 | #undef __errordecl | 138 | # undef __errordecl |
| 138 | #undef __extension__ | 139 | # undef __extension__ |
| 139 | #undef __extern_always_inline | 140 | # undef __extern_always_inline |
| 140 | #undef __extern_inline | 141 | # undef __extern_inline |
| 141 | #undef __flexarr | 142 | # undef __flexarr |
| 142 | #undef __fortify_function | 143 | # undef __fortify_function |
| 143 | #undef __glibc_c99_flexarr_available | 144 | # undef __glibc_c99_flexarr_available |
| 144 | #undef __glibc_clang_has_extension | 145 | # undef __glibc_has_attribute |
| 145 | #undef __glibc_likely | 146 | # undef __glibc_has_builtin |
| 146 | #undef __glibc_macro_warning | 147 | # undef __glibc_has_extension |
| 147 | #undef __glibc_macro_warning1 | 148 | # undef __glibc_macro_warning |
| 148 | #undef __glibc_unlikely | 149 | # undef __glibc_macro_warning1 |
| 149 | #undef __inline | 150 | # undef __glibc_objsize |
| 150 | #undef __ptr_t | 151 | # undef __glibc_objsize0 |
| 151 | #undef __restrict | 152 | # undef __glibc_unlikely |
| 152 | #undef __restrict_arr | 153 | # undef __inline |
| 153 | #undef __va_arg_pack | 154 | # undef __ptr_t |
| 154 | #undef __va_arg_pack_len | 155 | # undef __restrict |
| 155 | #undef __warnattr | 156 | # undef __restrict_arr |
| 156 | #undef __warndecl | 157 | # undef __va_arg_pack |
| 158 | # undef __va_arg_pack_len | ||
| 159 | # undef __warnattr | ||
| 157 | 160 | ||
| 158 | /* Include our copy of glibc <sys/cdefs.h>. */ | 161 | /* Include our copy of glibc <sys/cdefs.h>. */ |
| 159 | #include <cdefs.h> | 162 | # include <cdefs.h> |
| 160 | 163 | ||
| 161 | /* <cdefs.h> __inline is too pessimistic for non-GCC. */ | 164 | /* <cdefs.h> __inline is too pessimistic for non-GCC. */ |
| 162 | #undef __inline | 165 | # undef __inline |
| 163 | #ifndef HAVE___INLINE | 166 | # ifndef HAVE___INLINE |
| 164 | # if 199901 <= __STDC_VERSION__ || defined inline | 167 | # if 199901 <= __STDC_VERSION__ || defined inline |
| 165 | # define __inline inline | 168 | # define __inline inline |
| 166 | # else | 169 | # else |
| 167 | # define __inline | 170 | # define __inline |
| 171 | # endif | ||
| 168 | # endif | 172 | # endif |
| 169 | #endif | 173 | |
| 174 | #endif /* defined __glibc_likely */ | ||
| 170 | 175 | ||
| 171 | 176 | ||
| 172 | /* A substitute for glibc <libc-symbols.h>, good enough for Gnulib. */ | 177 | /* A substitute for glibc <libc-symbols.h>, good enough for Gnulib. */ |
| 173 | #define attribute_hidden | 178 | #define attribute_hidden |
| 174 | #define libc_hidden_proto(name, ...) | 179 | #define libc_hidden_proto(name) |
| 175 | #define libc_hidden_def(name) | 180 | #define libc_hidden_def(name) |
| 176 | #define libc_hidden_weak(name) | 181 | #define libc_hidden_weak(name) |
| 177 | #define libc_hidden_ver(local, name) | 182 | #define libc_hidden_ver(local, name) |
diff --git a/lib/malloc/dynarray-skeleton.c b/lib/malloc/dynarray-skeleton.c new file mode 100644 index 00000000000..4995fd1c049 --- /dev/null +++ b/lib/malloc/dynarray-skeleton.c | |||
| @@ -0,0 +1,525 @@ | |||
| 1 | /* Type-safe arrays which grow dynamically. | ||
| 2 | Copyright (C) 2017-2021 Free Software Foundation, Inc. | ||
| 3 | This file is part of the GNU C Library. | ||
| 4 | |||
| 5 | The GNU C Library is free software; you can redistribute it and/or | ||
| 6 | modify it under the terms of the GNU General Public | ||
| 7 | License as published by the Free Software Foundation; either | ||
| 8 | version 3 of the License, or (at your option) any later version. | ||
| 9 | |||
| 10 | The GNU C Library is distributed in the hope that it will be useful, | ||
| 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
| 13 | General Public License for more details. | ||
| 14 | |||
| 15 | You should have received a copy of the GNU General Public | ||
| 16 | License along with the GNU C Library; if not, see | ||
| 17 | <https://www.gnu.org/licenses/>. */ | ||
| 18 | |||
| 19 | /* Pre-processor macros which act as parameters: | ||
| 20 | |||
| 21 | DYNARRAY_STRUCT | ||
| 22 | The struct tag of dynamic array to be defined. | ||
| 23 | DYNARRAY_ELEMENT | ||
| 24 | The type name of the element type. Elements are copied | ||
| 25 | as if by memcpy, and can change address as the dynamic | ||
| 26 | array grows. | ||
| 27 | DYNARRAY_PREFIX | ||
| 28 | The prefix of the functions which are defined. | ||
| 29 | |||
| 30 | The following parameters are optional: | ||
| 31 | |||
| 32 | DYNARRAY_ELEMENT_FREE | ||
| 33 | DYNARRAY_ELEMENT_FREE (E) is evaluated to deallocate the | ||
| 34 | contents of elements. E is of type DYNARRAY_ELEMENT *. | ||
| 35 | DYNARRAY_ELEMENT_INIT | ||
| 36 | DYNARRAY_ELEMENT_INIT (E) is evaluated to initialize a new | ||
| 37 | element. E is of type DYNARRAY_ELEMENT *. | ||
| 38 | If DYNARRAY_ELEMENT_FREE but not DYNARRAY_ELEMENT_INIT is | ||
| 39 | defined, new elements are automatically zero-initialized. | ||
| 40 | Otherwise, new elements have undefined contents. | ||
| 41 | DYNARRAY_INITIAL_SIZE | ||
| 42 | The size of the statically allocated array (default: | ||
| 43 | at least 2, more elements if they fit into 128 bytes). | ||
| 44 | Must be a preprocessor constant. If DYNARRAY_INITIAL_SIZE is 0, | ||
| 45 | there is no statically allocated array at, and all non-empty | ||
| 46 | arrays are heap-allocated. | ||
| 47 | DYNARRAY_FINAL_TYPE | ||
| 48 | The name of the type which holds the final array. If not | ||
| 49 | defined, is PREFIX##finalize not provided. DYNARRAY_FINAL_TYPE | ||
| 50 | must be a struct type, with members of type DYNARRAY_ELEMENT and | ||
| 51 | size_t at the start (in this order). | ||
| 52 | |||
| 53 | These macros are undefined after this header file has been | ||
| 54 | included. | ||
| 55 | |||
| 56 | The following types are provided (their members are private to the | ||
| 57 | dynarray implementation): | ||
| 58 | |||
| 59 | struct DYNARRAY_STRUCT | ||
| 60 | |||
| 61 | The following functions are provided: | ||
| 62 | |||
| 63 | void DYNARRAY_PREFIX##init (struct DYNARRAY_STRUCT *); | ||
| 64 | void DYNARRAY_PREFIX##free (struct DYNARRAY_STRUCT *); | ||
| 65 | bool DYNARRAY_PREFIX##has_failed (const struct DYNARRAY_STRUCT *); | ||
| 66 | void DYNARRAY_PREFIX##mark_failed (struct DYNARRAY_STRUCT *); | ||
| 67 | size_t DYNARRAY_PREFIX##size (const struct DYNARRAY_STRUCT *); | ||
| 68 | DYNARRAY_ELEMENT *DYNARRAY_PREFIX##begin (const struct DYNARRAY_STRUCT *); | ||
| 69 | DYNARRAY_ELEMENT *DYNARRAY_PREFIX##end (const struct DYNARRAY_STRUCT *); | ||
| 70 | DYNARRAY_ELEMENT *DYNARRAY_PREFIX##at (struct DYNARRAY_STRUCT *, size_t); | ||
| 71 | void DYNARRAY_PREFIX##add (struct DYNARRAY_STRUCT *, DYNARRAY_ELEMENT); | ||
| 72 | DYNARRAY_ELEMENT *DYNARRAY_PREFIX##emplace (struct DYNARRAY_STRUCT *); | ||
| 73 | bool DYNARRAY_PREFIX##resize (struct DYNARRAY_STRUCT *, size_t); | ||
| 74 | void DYNARRAY_PREFIX##remove_last (struct DYNARRAY_STRUCT *); | ||
| 75 | void DYNARRAY_PREFIX##clear (struct DYNARRAY_STRUCT *); | ||
| 76 | |||
| 77 | The following functions are provided are provided if the | ||
| 78 | prerequisites are met: | ||
| 79 | |||
| 80 | bool DYNARRAY_PREFIX##finalize (struct DYNARRAY_STRUCT *, | ||
| 81 | DYNARRAY_FINAL_TYPE *); | ||
| 82 | (if DYNARRAY_FINAL_TYPE is defined) | ||
| 83 | DYNARRAY_ELEMENT *DYNARRAY_PREFIX##finalize (struct DYNARRAY_STRUCT *, | ||
| 84 | size_t *); | ||
| 85 | (if DYNARRAY_FINAL_TYPE is not defined) | ||
| 86 | */ | ||
| 87 | |||
| 88 | #include <malloc/dynarray.h> | ||
| 89 | |||
| 90 | #include <errno.h> | ||
| 91 | #include <stdlib.h> | ||
| 92 | #include <string.h> | ||
| 93 | |||
| 94 | #ifndef DYNARRAY_STRUCT | ||
| 95 | # error "DYNARRAY_STRUCT must be defined" | ||
| 96 | #endif | ||
| 97 | |||
| 98 | #ifndef DYNARRAY_ELEMENT | ||
| 99 | # error "DYNARRAY_ELEMENT must be defined" | ||
| 100 | #endif | ||
| 101 | |||
| 102 | #ifndef DYNARRAY_PREFIX | ||
| 103 | # error "DYNARRAY_PREFIX must be defined" | ||
| 104 | #endif | ||
| 105 | |||
| 106 | #ifdef DYNARRAY_INITIAL_SIZE | ||
| 107 | # if DYNARRAY_INITIAL_SIZE < 0 | ||
| 108 | # error "DYNARRAY_INITIAL_SIZE must be non-negative" | ||
| 109 | # endif | ||
| 110 | # if DYNARRAY_INITIAL_SIZE > 0 | ||
| 111 | # define DYNARRAY_HAVE_SCRATCH 1 | ||
| 112 | # else | ||
| 113 | # define DYNARRAY_HAVE_SCRATCH 0 | ||
| 114 | # endif | ||
| 115 | #else | ||
| 116 | /* Provide a reasonable default which limits the size of | ||
| 117 | DYNARRAY_STRUCT. */ | ||
| 118 | # define DYNARRAY_INITIAL_SIZE \ | ||
| 119 | (sizeof (DYNARRAY_ELEMENT) > 64 ? 2 : 128 / sizeof (DYNARRAY_ELEMENT)) | ||
| 120 | # define DYNARRAY_HAVE_SCRATCH 1 | ||
| 121 | #endif | ||
| 122 | |||
| 123 | /* Public type definitions. */ | ||
| 124 | |||
| 125 | /* All fields of this struct are private to the implementation. */ | ||
| 126 | struct DYNARRAY_STRUCT | ||
| 127 | { | ||
| 128 | union | ||
| 129 | { | ||
| 130 | struct dynarray_header dynarray_abstract; | ||
| 131 | struct | ||
| 132 | { | ||
| 133 | /* These fields must match struct dynarray_header. */ | ||
| 134 | size_t used; | ||
| 135 | size_t allocated; | ||
| 136 | DYNARRAY_ELEMENT *array; | ||
| 137 | } dynarray_header; | ||
| 138 | } u; | ||
| 139 | |||
| 140 | #if DYNARRAY_HAVE_SCRATCH | ||
| 141 | /* Initial inline allocation. */ | ||
| 142 | DYNARRAY_ELEMENT scratch[DYNARRAY_INITIAL_SIZE]; | ||
| 143 | #endif | ||
| 144 | }; | ||
| 145 | |||
| 146 | /* Internal use only: Helper macros. */ | ||
| 147 | |||
| 148 | /* Ensure macro-expansion of DYNARRAY_PREFIX. */ | ||
| 149 | #define DYNARRAY_CONCAT0(prefix, name) prefix##name | ||
| 150 | #define DYNARRAY_CONCAT1(prefix, name) DYNARRAY_CONCAT0(prefix, name) | ||
| 151 | #define DYNARRAY_NAME(name) DYNARRAY_CONCAT1(DYNARRAY_PREFIX, name) | ||
| 152 | |||
| 153 | /* Use DYNARRAY_FREE instead of DYNARRAY_NAME (free), | ||
| 154 | so that Gnulib does not change 'free' to 'rpl_free'. */ | ||
| 155 | #define DYNARRAY_FREE DYNARRAY_CONCAT1 (DYNARRAY_NAME (f), ree) | ||
| 156 | |||
| 157 | /* Address of the scratch buffer if any. */ | ||
| 158 | #if DYNARRAY_HAVE_SCRATCH | ||
| 159 | # define DYNARRAY_SCRATCH(list) (list)->scratch | ||
| 160 | #else | ||
| 161 | # define DYNARRAY_SCRATCH(list) NULL | ||
| 162 | #endif | ||
| 163 | |||
| 164 | /* Internal use only: Helper functions. */ | ||
| 165 | |||
| 166 | /* Internal function. Call DYNARRAY_ELEMENT_FREE with the array | ||
| 167 | elements. Name mangling needed due to the DYNARRAY_ELEMENT_FREE | ||
| 168 | macro expansion. */ | ||
| 169 | static inline void | ||
| 170 | DYNARRAY_NAME (free__elements__) (DYNARRAY_ELEMENT *__dynarray_array, | ||
| 171 | size_t __dynarray_used) | ||
| 172 | { | ||
| 173 | #ifdef DYNARRAY_ELEMENT_FREE | ||
| 174 | for (size_t __dynarray_i = 0; __dynarray_i < __dynarray_used; ++__dynarray_i) | ||
| 175 | DYNARRAY_ELEMENT_FREE (&__dynarray_array[__dynarray_i]); | ||
| 176 | #endif /* DYNARRAY_ELEMENT_FREE */ | ||
| 177 | } | ||
| 178 | |||
| 179 | /* Internal function. Free the non-scratch array allocation. */ | ||
| 180 | static inline void | ||
| 181 | DYNARRAY_NAME (free__array__) (struct DYNARRAY_STRUCT *list) | ||
| 182 | { | ||
| 183 | #if DYNARRAY_HAVE_SCRATCH | ||
| 184 | if (list->u.dynarray_header.array != list->scratch) | ||
| 185 | free (list->u.dynarray_header.array); | ||
| 186 | #else | ||
| 187 | free (list->u.dynarray_header.array); | ||
| 188 | #endif | ||
| 189 | } | ||
| 190 | |||
| 191 | /* Public functions. */ | ||
| 192 | |||
| 193 | /* Initialize a dynamic array object. This must be called before any | ||
| 194 | use of the object. */ | ||
| 195 | __nonnull ((1)) | ||
| 196 | static void | ||
| 197 | DYNARRAY_NAME (init) (struct DYNARRAY_STRUCT *list) | ||
| 198 | { | ||
| 199 | list->u.dynarray_header.used = 0; | ||
| 200 | list->u.dynarray_header.allocated = DYNARRAY_INITIAL_SIZE; | ||
| 201 | list->u.dynarray_header.array = DYNARRAY_SCRATCH (list); | ||
| 202 | } | ||
| 203 | |||
| 204 | /* Deallocate the dynamic array and its elements. */ | ||
| 205 | __attribute_maybe_unused__ __nonnull ((1)) | ||
| 206 | static void | ||
| 207 | DYNARRAY_FREE (struct DYNARRAY_STRUCT *list) | ||
| 208 | { | ||
| 209 | DYNARRAY_NAME (free__elements__) | ||
| 210 | (list->u.dynarray_header.array, list->u.dynarray_header.used); | ||
| 211 | DYNARRAY_NAME (free__array__) (list); | ||
| 212 | DYNARRAY_NAME (init) (list); | ||
| 213 | } | ||
| 214 | |||
| 215 | /* Return true if the dynamic array is in an error state. */ | ||
| 216 | __nonnull ((1)) | ||
| 217 | static inline bool | ||
| 218 | DYNARRAY_NAME (has_failed) (const struct DYNARRAY_STRUCT *list) | ||
| 219 | { | ||
| 220 | return list->u.dynarray_header.allocated == __dynarray_error_marker (); | ||
| 221 | } | ||
| 222 | |||
| 223 | /* Mark the dynamic array as failed. All elements are deallocated as | ||
| 224 | a side effect. */ | ||
| 225 | __nonnull ((1)) | ||
| 226 | static void | ||
| 227 | DYNARRAY_NAME (mark_failed) (struct DYNARRAY_STRUCT *list) | ||
| 228 | { | ||
| 229 | DYNARRAY_NAME (free__elements__) | ||
| 230 | (list->u.dynarray_header.array, list->u.dynarray_header.used); | ||
| 231 | DYNARRAY_NAME (free__array__) (list); | ||
| 232 | list->u.dynarray_header.array = DYNARRAY_SCRATCH (list); | ||
| 233 | list->u.dynarray_header.used = 0; | ||
| 234 | list->u.dynarray_header.allocated = __dynarray_error_marker (); | ||
| 235 | } | ||
| 236 | |||
| 237 | /* Return the number of elements which have been added to the dynamic | ||
| 238 | array. */ | ||
| 239 | __nonnull ((1)) | ||
| 240 | static inline size_t | ||
| 241 | DYNARRAY_NAME (size) (const struct DYNARRAY_STRUCT *list) | ||
| 242 | { | ||
| 243 | return list->u.dynarray_header.used; | ||
| 244 | } | ||
| 245 | |||
| 246 | /* Return a pointer to the array element at INDEX. Terminate the | ||
| 247 | process if INDEX is out of bounds. */ | ||
| 248 | __nonnull ((1)) | ||
| 249 | static inline DYNARRAY_ELEMENT * | ||
| 250 | DYNARRAY_NAME (at) (struct DYNARRAY_STRUCT *list, size_t index) | ||
| 251 | { | ||
| 252 | if (__glibc_unlikely (index >= DYNARRAY_NAME (size) (list))) | ||
| 253 | __libc_dynarray_at_failure (DYNARRAY_NAME (size) (list), index); | ||
| 254 | return list->u.dynarray_header.array + index; | ||
| 255 | } | ||
| 256 | |||
| 257 | /* Return a pointer to the first array element, if any. For a | ||
| 258 | zero-length array, the pointer can be NULL even though the dynamic | ||
| 259 | array has not entered the failure state. */ | ||
| 260 | __nonnull ((1)) | ||
| 261 | static inline DYNARRAY_ELEMENT * | ||
| 262 | DYNARRAY_NAME (begin) (struct DYNARRAY_STRUCT *list) | ||
| 263 | { | ||
| 264 | return list->u.dynarray_header.array; | ||
| 265 | } | ||
| 266 | |||
| 267 | /* Return a pointer one element past the last array element. For a | ||
| 268 | zero-length array, the pointer can be NULL even though the dynamic | ||
| 269 | array has not entered the failure state. */ | ||
| 270 | __nonnull ((1)) | ||
| 271 | static inline DYNARRAY_ELEMENT * | ||
| 272 | DYNARRAY_NAME (end) (struct DYNARRAY_STRUCT *list) | ||
| 273 | { | ||
| 274 | return list->u.dynarray_header.array + list->u.dynarray_header.used; | ||
| 275 | } | ||
| 276 | |||
| 277 | /* Internal function. Slow path for the add function below. */ | ||
| 278 | static void | ||
| 279 | DYNARRAY_NAME (add__) (struct DYNARRAY_STRUCT *list, DYNARRAY_ELEMENT item) | ||
| 280 | { | ||
| 281 | if (__glibc_unlikely | ||
| 282 | (!__libc_dynarray_emplace_enlarge (&list->u.dynarray_abstract, | ||
| 283 | DYNARRAY_SCRATCH (list), | ||
| 284 | sizeof (DYNARRAY_ELEMENT)))) | ||
| 285 | { | ||
| 286 | DYNARRAY_NAME (mark_failed) (list); | ||
| 287 | return; | ||
| 288 | } | ||
| 289 | |||
| 290 | /* Copy the new element and increase the array length. */ | ||
| 291 | list->u.dynarray_header.array[list->u.dynarray_header.used++] = item; | ||
| 292 | } | ||
| 293 | |||
| 294 | /* Add ITEM at the end of the array, enlarging it by one element. | ||
| 295 | Mark *LIST as failed if the dynamic array allocation size cannot be | ||
| 296 | increased. */ | ||
| 297 | __nonnull ((1)) | ||
| 298 | static inline void | ||
| 299 | DYNARRAY_NAME (add) (struct DYNARRAY_STRUCT *list, DYNARRAY_ELEMENT item) | ||
| 300 | { | ||
| 301 | /* Do nothing in case of previous error. */ | ||
| 302 | if (DYNARRAY_NAME (has_failed) (list)) | ||
| 303 | return; | ||
| 304 | |||
| 305 | /* Enlarge the array if necessary. */ | ||
| 306 | if (__glibc_unlikely (list->u.dynarray_header.used | ||
| 307 | == list->u.dynarray_header.allocated)) | ||
| 308 | { | ||
| 309 | DYNARRAY_NAME (add__) (list, item); | ||
| 310 | return; | ||
| 311 | } | ||
| 312 | |||
| 313 | /* Copy the new element and increase the array length. */ | ||
| 314 | list->u.dynarray_header.array[list->u.dynarray_header.used++] = item; | ||
| 315 | } | ||
| 316 | |||
| 317 | /* Internal function. Building block for the emplace functions below. | ||
| 318 | Assumes space for one more element in *LIST. */ | ||
| 319 | static inline DYNARRAY_ELEMENT * | ||
| 320 | DYNARRAY_NAME (emplace__tail__) (struct DYNARRAY_STRUCT *list) | ||
| 321 | { | ||
| 322 | DYNARRAY_ELEMENT *result | ||
| 323 | = &list->u.dynarray_header.array[list->u.dynarray_header.used]; | ||
| 324 | ++list->u.dynarray_header.used; | ||
| 325 | #if defined (DYNARRAY_ELEMENT_INIT) | ||
| 326 | DYNARRAY_ELEMENT_INIT (result); | ||
| 327 | #elif defined (DYNARRAY_ELEMENT_FREE) | ||
| 328 | memset (result, 0, sizeof (*result)); | ||
| 329 | #endif | ||
| 330 | return result; | ||
| 331 | } | ||
| 332 | |||
| 333 | /* Internal function. Slow path for the emplace function below. */ | ||
| 334 | static DYNARRAY_ELEMENT * | ||
| 335 | DYNARRAY_NAME (emplace__) (struct DYNARRAY_STRUCT *list) | ||
| 336 | { | ||
| 337 | if (__glibc_unlikely | ||
| 338 | (!__libc_dynarray_emplace_enlarge (&list->u.dynarray_abstract, | ||
| 339 | DYNARRAY_SCRATCH (list), | ||
| 340 | sizeof (DYNARRAY_ELEMENT)))) | ||
| 341 | { | ||
| 342 | DYNARRAY_NAME (mark_failed) (list); | ||
| 343 | return NULL; | ||
| 344 | } | ||
| 345 | return DYNARRAY_NAME (emplace__tail__) (list); | ||
| 346 | } | ||
| 347 | |||
| 348 | /* Allocate a place for a new element in *LIST and return a pointer to | ||
| 349 | it. The pointer can be NULL if the dynamic array cannot be | ||
| 350 | enlarged due to a memory allocation failure. */ | ||
| 351 | __attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1)) | ||
| 352 | static | ||
| 353 | /* Avoid inlining with the larger initialization code. */ | ||
| 354 | #if !(defined (DYNARRAY_ELEMENT_INIT) || defined (DYNARRAY_ELEMENT_FREE)) | ||
| 355 | inline | ||
| 356 | #endif | ||
| 357 | DYNARRAY_ELEMENT * | ||
| 358 | DYNARRAY_NAME (emplace) (struct DYNARRAY_STRUCT *list) | ||
| 359 | { | ||
| 360 | /* Do nothing in case of previous error. */ | ||
| 361 | if (DYNARRAY_NAME (has_failed) (list)) | ||
| 362 | return NULL; | ||
| 363 | |||
| 364 | /* Enlarge the array if necessary. */ | ||
| 365 | if (__glibc_unlikely (list->u.dynarray_header.used | ||
| 366 | == list->u.dynarray_header.allocated)) | ||
| 367 | return (DYNARRAY_NAME (emplace__) (list)); | ||
| 368 | return DYNARRAY_NAME (emplace__tail__) (list); | ||
| 369 | } | ||
| 370 | |||
| 371 | /* Change the size of *LIST to SIZE. If SIZE is larger than the | ||
| 372 | existing size, new elements are added (which can be initialized). | ||
| 373 | Otherwise, the list is truncated, and elements are freed. Return | ||
| 374 | false on memory allocation failure (and mark *LIST as failed). */ | ||
| 375 | __attribute_maybe_unused__ __nonnull ((1)) | ||
| 376 | static bool | ||
| 377 | DYNARRAY_NAME (resize) (struct DYNARRAY_STRUCT *list, size_t size) | ||
| 378 | { | ||
| 379 | if (size > list->u.dynarray_header.used) | ||
| 380 | { | ||
| 381 | bool ok; | ||
| 382 | #if defined (DYNARRAY_ELEMENT_INIT) | ||
| 383 | /* The new elements have to be initialized. */ | ||
| 384 | size_t old_size = list->u.dynarray_header.used; | ||
| 385 | ok = __libc_dynarray_resize (&list->u.dynarray_abstract, | ||
| 386 | size, DYNARRAY_SCRATCH (list), | ||
| 387 | sizeof (DYNARRAY_ELEMENT)); | ||
| 388 | if (ok) | ||
| 389 | for (size_t i = old_size; i < size; ++i) | ||
| 390 | { | ||
| 391 | DYNARRAY_ELEMENT_INIT (&list->u.dynarray_header.array[i]); | ||
| 392 | } | ||
| 393 | #elif defined (DYNARRAY_ELEMENT_FREE) | ||
| 394 | /* Zero initialization is needed so that the elements can be | ||
| 395 | safely freed. */ | ||
| 396 | ok = __libc_dynarray_resize_clear | ||
| 397 | (&list->u.dynarray_abstract, size, | ||
| 398 | DYNARRAY_SCRATCH (list), sizeof (DYNARRAY_ELEMENT)); | ||
| 399 | #else | ||
| 400 | ok = __libc_dynarray_resize (&list->u.dynarray_abstract, | ||
| 401 | size, DYNARRAY_SCRATCH (list), | ||
| 402 | sizeof (DYNARRAY_ELEMENT)); | ||
| 403 | #endif | ||
| 404 | if (__glibc_unlikely (!ok)) | ||
| 405 | DYNARRAY_NAME (mark_failed) (list); | ||
| 406 | return ok; | ||
| 407 | } | ||
| 408 | else | ||
| 409 | { | ||
| 410 | /* The list has shrunk in size. Free the removed elements. */ | ||
| 411 | DYNARRAY_NAME (free__elements__) | ||
| 412 | (list->u.dynarray_header.array + size, | ||
| 413 | list->u.dynarray_header.used - size); | ||
| 414 | list->u.dynarray_header.used = size; | ||
| 415 | return true; | ||
| 416 | } | ||
| 417 | } | ||
| 418 | |||
| 419 | /* Remove the last element of LIST if it is present. */ | ||
| 420 | __attribute_maybe_unused__ __nonnull ((1)) | ||
| 421 | static void | ||
| 422 | DYNARRAY_NAME (remove_last) (struct DYNARRAY_STRUCT *list) | ||
| 423 | { | ||
| 424 | /* used > 0 implies that the array is the non-failed state. */ | ||
| 425 | if (list->u.dynarray_header.used > 0) | ||
| 426 | { | ||
| 427 | size_t new_length = list->u.dynarray_header.used - 1; | ||
| 428 | #ifdef DYNARRAY_ELEMENT_FREE | ||
| 429 | DYNARRAY_ELEMENT_FREE (&list->u.dynarray_header.array[new_length]); | ||
| 430 | #endif | ||
| 431 | list->u.dynarray_header.used = new_length; | ||
| 432 | } | ||
| 433 | } | ||
| 434 | |||
| 435 | /* Remove all elements from the list. The elements are freed, but the | ||
| 436 | list itself is not. */ | ||
| 437 | __attribute_maybe_unused__ __nonnull ((1)) | ||
| 438 | static void | ||
| 439 | DYNARRAY_NAME (clear) (struct DYNARRAY_STRUCT *list) | ||
| 440 | { | ||
| 441 | /* free__elements__ does nothing if the list is in the failed | ||
| 442 | state. */ | ||
| 443 | DYNARRAY_NAME (free__elements__) | ||
| 444 | (list->u.dynarray_header.array, list->u.dynarray_header.used); | ||
| 445 | list->u.dynarray_header.used = 0; | ||
| 446 | } | ||
| 447 | |||
| 448 | #ifdef DYNARRAY_FINAL_TYPE | ||
| 449 | /* Transfer the dynamic array to a permanent location at *RESULT. | ||
| 450 | Returns true on success on false on allocation failure. In either | ||
| 451 | case, *LIST is re-initialized and can be reused. A NULL pointer is | ||
| 452 | stored in *RESULT if LIST refers to an empty list. On success, the | ||
| 453 | pointer in *RESULT is heap-allocated and must be deallocated using | ||
| 454 | free. */ | ||
| 455 | __attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1, 2)) | ||
| 456 | static bool | ||
| 457 | DYNARRAY_NAME (finalize) (struct DYNARRAY_STRUCT *list, | ||
| 458 | DYNARRAY_FINAL_TYPE *result) | ||
| 459 | { | ||
| 460 | struct dynarray_finalize_result res; | ||
| 461 | if (__libc_dynarray_finalize (&list->u.dynarray_abstract, | ||
| 462 | DYNARRAY_SCRATCH (list), | ||
| 463 | sizeof (DYNARRAY_ELEMENT), &res)) | ||
| 464 | { | ||
| 465 | /* On success, the result owns all the data. */ | ||
| 466 | DYNARRAY_NAME (init) (list); | ||
| 467 | *result = (DYNARRAY_FINAL_TYPE) { res.array, res.length }; | ||
| 468 | return true; | ||
| 469 | } | ||
| 470 | else | ||
| 471 | { | ||
| 472 | /* On error, we need to free all data. */ | ||
| 473 | DYNARRAY_FREE (list); | ||
| 474 | errno = ENOMEM; | ||
| 475 | return false; | ||
| 476 | } | ||
| 477 | } | ||
| 478 | #else /* !DYNARRAY_FINAL_TYPE */ | ||
| 479 | /* Transfer the dynamic array to a heap-allocated array and return a | ||
| 480 | pointer to it. The pointer is NULL if memory allocation fails, or | ||
| 481 | if the array is empty, so this function should be used only for | ||
| 482 | arrays which are known not be empty (usually because they always | ||
| 483 | have a sentinel at the end). If LENGTHP is not NULL, the array | ||
| 484 | length is written to *LENGTHP. *LIST is re-initialized and can be | ||
| 485 | reused. */ | ||
| 486 | __attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1)) | ||
| 487 | static DYNARRAY_ELEMENT * | ||
| 488 | DYNARRAY_NAME (finalize) (struct DYNARRAY_STRUCT *list, size_t *lengthp) | ||
| 489 | { | ||
| 490 | struct dynarray_finalize_result res; | ||
| 491 | if (__libc_dynarray_finalize (&list->u.dynarray_abstract, | ||
| 492 | DYNARRAY_SCRATCH (list), | ||
| 493 | sizeof (DYNARRAY_ELEMENT), &res)) | ||
| 494 | { | ||
| 495 | /* On success, the result owns all the data. */ | ||
| 496 | DYNARRAY_NAME (init) (list); | ||
| 497 | if (lengthp != NULL) | ||
| 498 | *lengthp = res.length; | ||
| 499 | return res.array; | ||
| 500 | } | ||
| 501 | else | ||
| 502 | { | ||
| 503 | /* On error, we need to free all data. */ | ||
| 504 | DYNARRAY_FREE (list); | ||
| 505 | errno = ENOMEM; | ||
| 506 | return NULL; | ||
| 507 | } | ||
| 508 | } | ||
| 509 | #endif /* !DYNARRAY_FINAL_TYPE */ | ||
| 510 | |||
| 511 | /* Undo macro definitions. */ | ||
| 512 | |||
| 513 | #undef DYNARRAY_CONCAT0 | ||
| 514 | #undef DYNARRAY_CONCAT1 | ||
| 515 | #undef DYNARRAY_NAME | ||
| 516 | #undef DYNARRAY_SCRATCH | ||
| 517 | #undef DYNARRAY_HAVE_SCRATCH | ||
| 518 | |||
| 519 | #undef DYNARRAY_STRUCT | ||
| 520 | #undef DYNARRAY_ELEMENT | ||
| 521 | #undef DYNARRAY_PREFIX | ||
| 522 | #undef DYNARRAY_ELEMENT_FREE | ||
| 523 | #undef DYNARRAY_ELEMENT_INIT | ||
| 524 | #undef DYNARRAY_INITIAL_SIZE | ||
| 525 | #undef DYNARRAY_FINAL_TYPE | ||
diff --git a/lib/malloc/dynarray.h b/lib/malloc/dynarray.h new file mode 100644 index 00000000000..84e4394bf32 --- /dev/null +++ b/lib/malloc/dynarray.h | |||
| @@ -0,0 +1,178 @@ | |||
| 1 | /* Type-safe arrays which grow dynamically. Shared definitions. | ||
| 2 | Copyright (C) 2017-2021 Free Software Foundation, Inc. | ||
| 3 | This file is part of the GNU C Library. | ||
| 4 | |||
| 5 | The GNU C Library is free software; you can redistribute it and/or | ||
| 6 | modify it under the terms of the GNU General Public | ||
| 7 | License as published by the Free Software Foundation; either | ||
| 8 | version 3 of the License, or (at your option) any later version. | ||
| 9 | |||
| 10 | The GNU C Library is distributed in the hope that it will be useful, | ||
| 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
| 13 | General Public License for more details. | ||
| 14 | |||
| 15 | You should have received a copy of the GNU General Public | ||
| 16 | License along with the GNU C Library; if not, see | ||
| 17 | <https://www.gnu.org/licenses/>. */ | ||
| 18 | |||
| 19 | /* To use the dynarray facility, you need to include | ||
| 20 | <malloc/dynarray-skeleton.c> and define the parameter macros | ||
| 21 | documented in that file. | ||
| 22 | |||
| 23 | A minimal example which provides a growing list of integers can be | ||
| 24 | defined like this: | ||
| 25 | |||
| 26 | struct int_array | ||
| 27 | { | ||
| 28 | // Pointer to result array followed by its length, | ||
| 29 | // as required by DYNARRAY_FINAL_TYPE. | ||
| 30 | int *array; | ||
| 31 | size_t length; | ||
| 32 | }; | ||
| 33 | |||
| 34 | #define DYNARRAY_STRUCT dynarray_int | ||
| 35 | #define DYNARRAY_ELEMENT int | ||
| 36 | #define DYNARRAY_PREFIX dynarray_int_ | ||
| 37 | #define DYNARRAY_FINAL_TYPE struct int_array | ||
| 38 | #include <malloc/dynarray-skeleton.c> | ||
| 39 | |||
| 40 | To create a three-element array with elements 1, 2, 3, use this | ||
| 41 | code: | ||
| 42 | |||
| 43 | struct dynarray_int dyn; | ||
| 44 | dynarray_int_init (&dyn); | ||
| 45 | for (int i = 1; i <= 3; ++i) | ||
| 46 | { | ||
| 47 | int *place = dynarray_int_emplace (&dyn); | ||
| 48 | assert (place != NULL); | ||
| 49 | *place = i; | ||
| 50 | } | ||
| 51 | struct int_array result; | ||
| 52 | bool ok = dynarray_int_finalize (&dyn, &result); | ||
| 53 | assert (ok); | ||
| 54 | assert (result.length == 3); | ||
| 55 | assert (result.array[0] == 1); | ||
| 56 | assert (result.array[1] == 2); | ||
| 57 | assert (result.array[2] == 3); | ||
| 58 | free (result.array); | ||
| 59 | |||
| 60 | If the elements contain resources which must be freed, define | ||
| 61 | DYNARRAY_ELEMENT_FREE appropriately, like this: | ||
| 62 | |||
| 63 | struct str_array | ||
| 64 | { | ||
| 65 | char **array; | ||
| 66 | size_t length; | ||
| 67 | }; | ||
| 68 | |||
| 69 | #define DYNARRAY_STRUCT dynarray_str | ||
| 70 | #define DYNARRAY_ELEMENT char * | ||
| 71 | #define DYNARRAY_ELEMENT_FREE(ptr) free (*ptr) | ||
| 72 | #define DYNARRAY_PREFIX dynarray_str_ | ||
| 73 | #define DYNARRAY_FINAL_TYPE struct str_array | ||
| 74 | #include <malloc/dynarray-skeleton.c> | ||
| 75 | |||
| 76 | Compared to scratch buffers, dynamic arrays have the following | ||
| 77 | features: | ||
| 78 | |||
| 79 | - They have an element type, and are not just an untyped buffer of | ||
| 80 | bytes. | ||
| 81 | |||
| 82 | - When growing, previously stored elements are preserved. (It is | ||
| 83 | expected that scratch_buffer_grow_preserve and | ||
| 84 | scratch_buffer_set_array_size eventually go away because all | ||
| 85 | current users are moved to dynamic arrays.) | ||
| 86 | |||
| 87 | - Scratch buffers have a more aggressive growth policy because | ||
| 88 | growing them typically means a retry of an operation (across an | ||
| 89 | NSS service module boundary), which is expensive. | ||
| 90 | |||
| 91 | - For the same reason, scratch buffers have a much larger initial | ||
| 92 | stack allocation. */ | ||
| 93 | |||
| 94 | #ifndef _DYNARRAY_H | ||
| 95 | #define _DYNARRAY_H | ||
| 96 | |||
| 97 | #include <stdbool.h> | ||
| 98 | #include <stddef.h> | ||
| 99 | #include <string.h> | ||
| 100 | |||
| 101 | struct dynarray_header | ||
| 102 | { | ||
| 103 | size_t used; | ||
| 104 | size_t allocated; | ||
| 105 | void *array; | ||
| 106 | }; | ||
| 107 | |||
| 108 | /* Marker used in the allocated member to indicate that an error was | ||
| 109 | encountered. */ | ||
| 110 | static inline size_t | ||
| 111 | __dynarray_error_marker (void) | ||
| 112 | { | ||
| 113 | return -1; | ||
| 114 | } | ||
| 115 | |||
| 116 | /* Internal function. See the has_failed function in | ||
| 117 | dynarray-skeleton.c. */ | ||
| 118 | static inline bool | ||
| 119 | __dynarray_error (struct dynarray_header *list) | ||
| 120 | { | ||
| 121 | return list->allocated == __dynarray_error_marker (); | ||
| 122 | } | ||
| 123 | |||
| 124 | /* Internal function. Enlarge the dynamically allocated area of the | ||
| 125 | array to make room for one more element. SCRATCH is a pointer to | ||
| 126 | the scratch area (which is not heap-allocated and must not be | ||
| 127 | freed). ELEMENT_SIZE is the size, in bytes, of one element. | ||
| 128 | Return false on failure, true on success. */ | ||
| 129 | bool __libc_dynarray_emplace_enlarge (struct dynarray_header *, | ||
| 130 | void *scratch, size_t element_size); | ||
| 131 | |||
| 132 | /* Internal function. Enlarge the dynamically allocated area of the | ||
| 133 | array to make room for at least SIZE elements (which must be larger | ||
| 134 | than the existing used part of the dynamic array). SCRATCH is a | ||
| 135 | pointer to the scratch area (which is not heap-allocated and must | ||
| 136 | not be freed). ELEMENT_SIZE is the size, in bytes, of one element. | ||
| 137 | Return false on failure, true on success. */ | ||
| 138 | bool __libc_dynarray_resize (struct dynarray_header *, size_t size, | ||
| 139 | void *scratch, size_t element_size); | ||
| 140 | |||
| 141 | /* Internal function. Like __libc_dynarray_resize, but clear the new | ||
| 142 | part of the dynamic array. */ | ||
| 143 | bool __libc_dynarray_resize_clear (struct dynarray_header *, size_t size, | ||
| 144 | void *scratch, size_t element_size); | ||
| 145 | |||
| 146 | /* Internal type. */ | ||
| 147 | struct dynarray_finalize_result | ||
| 148 | { | ||
| 149 | void *array; | ||
| 150 | size_t length; | ||
| 151 | }; | ||
| 152 | |||
| 153 | /* Internal function. Copy the dynamically-allocated area to an | ||
| 154 | explicitly-sized heap allocation. SCRATCH is a pointer to the | ||
| 155 | embedded scratch space. ELEMENT_SIZE is the size, in bytes, of the | ||
| 156 | element type. On success, true is returned, and pointer and length | ||
| 157 | are written to *RESULT. On failure, false is returned. The caller | ||
| 158 | has to take care of some of the memory management; this function is | ||
| 159 | expected to be called from dynarray-skeleton.c. */ | ||
| 160 | bool __libc_dynarray_finalize (struct dynarray_header *list, void *scratch, | ||
| 161 | size_t element_size, | ||
| 162 | struct dynarray_finalize_result *result); | ||
| 163 | |||
| 164 | |||
| 165 | /* Internal function. Terminate the process after an index error. | ||
| 166 | SIZE is the number of elements of the dynamic array. INDEX is the | ||
| 167 | lookup index which triggered the failure. */ | ||
| 168 | _Noreturn void __libc_dynarray_at_failure (size_t size, size_t index); | ||
| 169 | |||
| 170 | #ifndef _ISOMAC | ||
| 171 | libc_hidden_proto (__libc_dynarray_emplace_enlarge) | ||
| 172 | libc_hidden_proto (__libc_dynarray_resize) | ||
| 173 | libc_hidden_proto (__libc_dynarray_resize_clear) | ||
| 174 | libc_hidden_proto (__libc_dynarray_finalize) | ||
| 175 | libc_hidden_proto (__libc_dynarray_at_failure) | ||
| 176 | #endif | ||
| 177 | |||
| 178 | #endif /* _DYNARRAY_H */ | ||
diff --git a/lib/malloc/dynarray_at_failure.c b/lib/malloc/dynarray_at_failure.c new file mode 100644 index 00000000000..a4424593748 --- /dev/null +++ b/lib/malloc/dynarray_at_failure.c | |||
| @@ -0,0 +1,35 @@ | |||
| 1 | /* Report an dynamic array index out of bounds condition. | ||
| 2 | Copyright (C) 2017-2021 Free Software Foundation, Inc. | ||
| 3 | This file is part of the GNU C Library. | ||
| 4 | |||
| 5 | The GNU C Library is free software; you can redistribute it and/or | ||
| 6 | modify it under the terms of the GNU General Public | ||
| 7 | License as published by the Free Software Foundation; either | ||
| 8 | version 3 of the License, or (at your option) any later version. | ||
| 9 | |||
| 10 | The GNU C Library is distributed in the hope that it will be useful, | ||
| 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
| 13 | General Public License for more details. | ||
| 14 | |||
| 15 | You should have received a copy of the GNU General Public | ||
| 16 | License along with the GNU C Library; if not, see | ||
| 17 | <https://www.gnu.org/licenses/>. */ | ||
| 18 | |||
| 19 | #include <dynarray.h> | ||
| 20 | #include <stdio.h> | ||
| 21 | #include <stdlib.h> | ||
| 22 | |||
| 23 | void | ||
| 24 | __libc_dynarray_at_failure (size_t size, size_t index) | ||
| 25 | { | ||
| 26 | #ifdef _LIBC | ||
| 27 | char buf[200]; | ||
| 28 | __snprintf (buf, sizeof (buf), "Fatal glibc error: " | ||
| 29 | "array index %zu not less than array length %zu\n", | ||
| 30 | index, size); | ||
| 31 | #else | ||
| 32 | abort (); | ||
| 33 | #endif | ||
| 34 | } | ||
| 35 | libc_hidden_def (__libc_dynarray_at_failure) | ||
diff --git a/lib/malloc/dynarray_emplace_enlarge.c b/lib/malloc/dynarray_emplace_enlarge.c new file mode 100644 index 00000000000..7ac4b6db403 --- /dev/null +++ b/lib/malloc/dynarray_emplace_enlarge.c | |||
| @@ -0,0 +1,73 @@ | |||
| 1 | /* Increase the size of a dynamic array in preparation of an emplace operation. | ||
| 2 | Copyright (C) 2017-2021 Free Software Foundation, Inc. | ||
| 3 | This file is part of the GNU C Library. | ||
| 4 | |||
| 5 | The GNU C Library is free software; you can redistribute it and/or | ||
| 6 | modify it under the terms of the GNU General Public | ||
| 7 | License as published by the Free Software Foundation; either | ||
| 8 | version 3 of the License, or (at your option) any later version. | ||
| 9 | |||
| 10 | The GNU C Library is distributed in the hope that it will be useful, | ||
| 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
| 13 | General Public License for more details. | ||
| 14 | |||
| 15 | You should have received a copy of the GNU General Public | ||
| 16 | License along with the GNU C Library; if not, see | ||
| 17 | <https://www.gnu.org/licenses/>. */ | ||
| 18 | |||
| 19 | #include <dynarray.h> | ||
| 20 | #include <errno.h> | ||
| 21 | #include <intprops.h> | ||
| 22 | #include <stdlib.h> | ||
| 23 | #include <string.h> | ||
| 24 | |||
| 25 | bool | ||
| 26 | __libc_dynarray_emplace_enlarge (struct dynarray_header *list, | ||
| 27 | void *scratch, size_t element_size) | ||
| 28 | { | ||
| 29 | size_t new_allocated; | ||
| 30 | if (list->allocated == 0) | ||
| 31 | { | ||
| 32 | /* No scratch buffer provided. Choose a reasonable default | ||
| 33 | size. */ | ||
| 34 | if (element_size < 4) | ||
| 35 | new_allocated = 16; | ||
| 36 | else if (element_size < 8) | ||
| 37 | new_allocated = 8; | ||
| 38 | else | ||
| 39 | new_allocated = 4; | ||
| 40 | } | ||
| 41 | else | ||
| 42 | /* Increase the allocated size, using an exponential growth | ||
| 43 | policy. */ | ||
| 44 | { | ||
| 45 | new_allocated = list->allocated + list->allocated / 2 + 1; | ||
| 46 | if (new_allocated <= list->allocated) | ||
| 47 | { | ||
| 48 | /* Overflow. */ | ||
| 49 | __set_errno (ENOMEM); | ||
| 50 | return false; | ||
| 51 | } | ||
| 52 | } | ||
| 53 | |||
| 54 | size_t new_size; | ||
| 55 | if (INT_MULTIPLY_WRAPV (new_allocated, element_size, &new_size)) | ||
| 56 | return false; | ||
| 57 | void *new_array; | ||
| 58 | if (list->array == scratch) | ||
| 59 | { | ||
| 60 | /* The previous array was not heap-allocated. */ | ||
| 61 | new_array = malloc (new_size); | ||
| 62 | if (new_array != NULL && list->array != NULL) | ||
| 63 | memcpy (new_array, list->array, list->used * element_size); | ||
| 64 | } | ||
| 65 | else | ||
| 66 | new_array = realloc (list->array, new_size); | ||
| 67 | if (new_array == NULL) | ||
| 68 | return false; | ||
| 69 | list->array = new_array; | ||
| 70 | list->allocated = new_allocated; | ||
| 71 | return true; | ||
| 72 | } | ||
| 73 | libc_hidden_def (__libc_dynarray_emplace_enlarge) | ||
diff --git a/lib/malloc/dynarray_finalize.c b/lib/malloc/dynarray_finalize.c new file mode 100644 index 00000000000..be9441e313d --- /dev/null +++ b/lib/malloc/dynarray_finalize.c | |||
| @@ -0,0 +1,62 @@ | |||
| 1 | /* Copy the dynamically-allocated area to an explicitly-sized heap allocation. | ||
| 2 | Copyright (C) 2017-2021 Free Software Foundation, Inc. | ||
| 3 | This file is part of the GNU C Library. | ||
| 4 | |||
| 5 | The GNU C Library is free software; you can redistribute it and/or | ||
| 6 | modify it under the terms of the GNU General Public | ||
| 7 | License as published by the Free Software Foundation; either | ||
| 8 | version 3 of the License, or (at your option) any later version. | ||
| 9 | |||
| 10 | The GNU C Library is distributed in the hope that it will be useful, | ||
| 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
| 13 | General Public License for more details. | ||
| 14 | |||
| 15 | You should have received a copy of the GNU General Public | ||
| 16 | License along with the GNU C Library; if not, see | ||
| 17 | <https://www.gnu.org/licenses/>. */ | ||
| 18 | |||
| 19 | #include <dynarray.h> | ||
| 20 | #include <stdlib.h> | ||
| 21 | #include <string.h> | ||
| 22 | |||
| 23 | bool | ||
| 24 | __libc_dynarray_finalize (struct dynarray_header *list, | ||
| 25 | void *scratch, size_t element_size, | ||
| 26 | struct dynarray_finalize_result *result) | ||
| 27 | { | ||
| 28 | if (__dynarray_error (list)) | ||
| 29 | /* The caller will reported the deferred error. */ | ||
| 30 | return false; | ||
| 31 | |||
| 32 | size_t used = list->used; | ||
| 33 | |||
| 34 | /* Empty list. */ | ||
| 35 | if (used == 0) | ||
| 36 | { | ||
| 37 | /* An empty list could still be backed by a heap-allocated | ||
| 38 | array. Free it if necessary. */ | ||
| 39 | if (list->array != scratch) | ||
| 40 | free (list->array); | ||
| 41 | *result = (struct dynarray_finalize_result) { NULL, 0 }; | ||
| 42 | return true; | ||
| 43 | } | ||
| 44 | |||
| 45 | size_t allocation_size = used * element_size; | ||
| 46 | void *heap_array = malloc (allocation_size); | ||
| 47 | if (heap_array != NULL) | ||
| 48 | { | ||
| 49 | /* The new array takes ownership of the strings. */ | ||
| 50 | if (list->array != NULL) | ||
| 51 | memcpy (heap_array, list->array, allocation_size); | ||
| 52 | if (list->array != scratch) | ||
| 53 | free (list->array); | ||
| 54 | *result = (struct dynarray_finalize_result) | ||
| 55 | { .array = heap_array, .length = used }; | ||
| 56 | return true; | ||
| 57 | } | ||
| 58 | else | ||
| 59 | /* The caller will perform the freeing operation. */ | ||
| 60 | return false; | ||
| 61 | } | ||
| 62 | libc_hidden_def (__libc_dynarray_finalize) | ||
diff --git a/lib/malloc/dynarray_resize.c b/lib/malloc/dynarray_resize.c new file mode 100644 index 00000000000..92bbddd4461 --- /dev/null +++ b/lib/malloc/dynarray_resize.c | |||
| @@ -0,0 +1,64 @@ | |||
| 1 | /* Increase the size of a dynamic array. | ||
| 2 | Copyright (C) 2017-2021 Free Software Foundation, Inc. | ||
| 3 | This file is part of the GNU C Library. | ||
| 4 | |||
| 5 | The GNU C Library is free software; you can redistribute it and/or | ||
| 6 | modify it under the terms of the GNU General Public | ||
| 7 | License as published by the Free Software Foundation; either | ||
| 8 | version 3 of the License, or (at your option) any later version. | ||
| 9 | |||
| 10 | The GNU C Library is distributed in the hope that it will be useful, | ||
| 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
| 13 | General Public License for more details. | ||
| 14 | |||
| 15 | You should have received a copy of the GNU General Public | ||
| 16 | License along with the GNU C Library; if not, see | ||
| 17 | <https://www.gnu.org/licenses/>. */ | ||
| 18 | |||
| 19 | #include <dynarray.h> | ||
| 20 | #include <errno.h> | ||
| 21 | #include <intprops.h> | ||
| 22 | #include <stdlib.h> | ||
| 23 | #include <string.h> | ||
| 24 | |||
| 25 | bool | ||
| 26 | __libc_dynarray_resize (struct dynarray_header *list, size_t size, | ||
| 27 | void *scratch, size_t element_size) | ||
| 28 | { | ||
| 29 | /* The existing allocation provides sufficient room. */ | ||
| 30 | if (size <= list->allocated) | ||
| 31 | { | ||
| 32 | list->used = size; | ||
| 33 | return true; | ||
| 34 | } | ||
| 35 | |||
| 36 | /* Otherwise, use size as the new allocation size. The caller is | ||
| 37 | expected to provide the final size of the array, so there is no | ||
| 38 | over-allocation here. */ | ||
| 39 | |||
| 40 | size_t new_size_bytes; | ||
| 41 | if (INT_MULTIPLY_WRAPV (size, element_size, &new_size_bytes)) | ||
| 42 | { | ||
| 43 | /* Overflow. */ | ||
| 44 | __set_errno (ENOMEM); | ||
| 45 | return false; | ||
| 46 | } | ||
| 47 | void *new_array; | ||
| 48 | if (list->array == scratch) | ||
| 49 | { | ||
| 50 | /* The previous array was not heap-allocated. */ | ||
| 51 | new_array = malloc (new_size_bytes); | ||
| 52 | if (new_array != NULL && list->array != NULL) | ||
| 53 | memcpy (new_array, list->array, list->used * element_size); | ||
| 54 | } | ||
| 55 | else | ||
| 56 | new_array = realloc (list->array, new_size_bytes); | ||
| 57 | if (new_array == NULL) | ||
| 58 | return false; | ||
| 59 | list->array = new_array; | ||
| 60 | list->allocated = size; | ||
| 61 | list->used = size; | ||
| 62 | return true; | ||
| 63 | } | ||
| 64 | libc_hidden_def (__libc_dynarray_resize) | ||
diff --git a/lib/malloc/dynarray_resize_clear.c b/lib/malloc/dynarray_resize_clear.c new file mode 100644 index 00000000000..99c2cc87c31 --- /dev/null +++ b/lib/malloc/dynarray_resize_clear.c | |||
| @@ -0,0 +1,35 @@ | |||
| 1 | /* Increase the size of a dynamic array and clear the new part. | ||
| 2 | Copyright (C) 2017-2021 Free Software Foundation, Inc. | ||
| 3 | This file is part of the GNU C Library. | ||
| 4 | |||
| 5 | The GNU C Library is free software; you can redistribute it and/or | ||
| 6 | modify it under the terms of the GNU General Public | ||
| 7 | License as published by the Free Software Foundation; either | ||
| 8 | version 3 of the License, or (at your option) any later version. | ||
| 9 | |||
| 10 | The GNU C Library is distributed in the hope that it will be useful, | ||
| 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
| 13 | General Public License for more details. | ||
| 14 | |||
| 15 | You should have received a copy of the GNU General Public | ||
| 16 | License along with the GNU C Library; if not, see | ||
| 17 | <https://www.gnu.org/licenses/>. */ | ||
| 18 | |||
| 19 | #include <dynarray.h> | ||
| 20 | #include <string.h> | ||
| 21 | |||
| 22 | bool | ||
| 23 | __libc_dynarray_resize_clear (struct dynarray_header *list, size_t size, | ||
| 24 | void *scratch, size_t element_size) | ||
| 25 | { | ||
| 26 | size_t old_size = list->used; | ||
| 27 | if (!__libc_dynarray_resize (list, size, scratch, element_size)) | ||
| 28 | return false; | ||
| 29 | /* __libc_dynarray_resize already checked for overflow. */ | ||
| 30 | char *array = list->array; | ||
| 31 | memset (array + (old_size * element_size), 0, | ||
| 32 | (size - old_size) * element_size); | ||
| 33 | return true; | ||
| 34 | } | ||
| 35 | libc_hidden_def (__libc_dynarray_resize_clear) | ||
diff --git a/lib/malloc/scratch_buffer_grow.c b/lib/malloc/scratch_buffer_grow.c index 41befe3d65f..e7606d81cd7 100644 --- a/lib/malloc/scratch_buffer_grow.c +++ b/lib/malloc/scratch_buffer_grow.c | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | /* Variable-sized buffer with on-stack default allocation. | 1 | /* Variable-sized buffer with on-stack default allocation. |
| 2 | Copyright (C) 2015-2020 Free Software Foundation, Inc. | 2 | Copyright (C) 2015-2021 Free Software Foundation, Inc. |
| 3 | This file is part of the GNU C Library. | 3 | This file is part of the GNU C Library. |
| 4 | 4 | ||
| 5 | The GNU C Library is free software; you can redistribute it and/or | 5 | The GNU C Library is free software; you can redistribute it and/or |
diff --git a/lib/malloc/scratch_buffer_grow_preserve.c b/lib/malloc/scratch_buffer_grow_preserve.c index aef232938d5..59f8c710001 100644 --- a/lib/malloc/scratch_buffer_grow_preserve.c +++ b/lib/malloc/scratch_buffer_grow_preserve.c | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | /* Variable-sized buffer with on-stack default allocation. | 1 | /* Variable-sized buffer with on-stack default allocation. |
| 2 | Copyright (C) 2015-2020 Free Software Foundation, Inc. | 2 | Copyright (C) 2015-2021 Free Software Foundation, Inc. |
| 3 | This file is part of the GNU C Library. | 3 | This file is part of the GNU C Library. |
| 4 | 4 | ||
| 5 | The GNU C Library is free software; you can redistribute it and/or | 5 | The GNU C Library is free software; you can redistribute it and/or |
diff --git a/lib/malloc/scratch_buffer_set_array_size.c b/lib/malloc/scratch_buffer_set_array_size.c index 5f5e4c24f5a..e2b9f31211a 100644 --- a/lib/malloc/scratch_buffer_set_array_size.c +++ b/lib/malloc/scratch_buffer_set_array_size.c | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | /* Variable-sized buffer with on-stack default allocation. | 1 | /* Variable-sized buffer with on-stack default allocation. |
| 2 | Copyright (C) 2015-2020 Free Software Foundation, Inc. | 2 | Copyright (C) 2015-2021 Free Software Foundation, Inc. |
| 3 | This file is part of the GNU C Library. | 3 | This file is part of the GNU C Library. |
| 4 | 4 | ||
| 5 | The GNU C Library is free software; you can redistribute it and/or | 5 | The GNU C Library is free software; you can redistribute it and/or |
diff --git a/lib/mini-gmp.c b/lib/mini-gmp.c index d34fe525e4c..de061e673ac 100644 --- a/lib/mini-gmp.c +++ b/lib/mini-gmp.c | |||
| @@ -4521,7 +4521,7 @@ mpz_export (void *r, size_t *countp, int order, size_t size, int endian, | |||
| 4521 | mp_size_t un; | 4521 | mp_size_t un; |
| 4522 | 4522 | ||
| 4523 | if (nails != 0) | 4523 | if (nails != 0) |
| 4524 | gmp_die ("mpz_import: Nails not supported."); | 4524 | gmp_die ("mpz_export: Nails not supported."); |
| 4525 | 4525 | ||
| 4526 | assert (order == 1 || order == -1); | 4526 | assert (order == 1 || order == -1); |
| 4527 | assert (endian >= -1 && endian <= 1); | 4527 | assert (endian >= -1 && endian <= 1); |
diff --git a/lib/mktime-internal.h b/lib/mktime-internal.h index b765a37ee34..9c447bd7b05 100644 --- a/lib/mktime-internal.h +++ b/lib/mktime-internal.h | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | /* Internals of mktime and related functions | 1 | /* Internals of mktime and related functions |
| 2 | Copyright 2016-2020 Free Software Foundation, Inc. | 2 | Copyright 2016-2021 Free Software Foundation, Inc. |
| 3 | This file is part of the GNU C Library. | 3 | This file is part of the GNU C Library. |
| 4 | Contributed by Paul Eggert <eggert@cs.ucla.edu>. | 4 | Contributed by Paul Eggert <eggert@cs.ucla.edu>. |
| 5 | 5 | ||
diff --git a/lib/nstrftime.c b/lib/nstrftime.c index 8ba6975552b..2f5e4fbe639 100644 --- a/lib/nstrftime.c +++ b/lib/nstrftime.c | |||
| @@ -19,7 +19,7 @@ | |||
| 19 | # define USE_IN_EXTENDED_LOCALE_MODEL 1 | 19 | # define USE_IN_EXTENDED_LOCALE_MODEL 1 |
| 20 | # define HAVE_STRUCT_ERA_ENTRY 1 | 20 | # define HAVE_STRUCT_ERA_ENTRY 1 |
| 21 | # define HAVE_TM_GMTOFF 1 | 21 | # define HAVE_TM_GMTOFF 1 |
| 22 | # define HAVE_TM_ZONE 1 | 22 | # define HAVE_STRUCT_TM_TM_ZONE 1 |
| 23 | # define HAVE_TZNAME 1 | 23 | # define HAVE_TZNAME 1 |
| 24 | # include "../locale/localeinfo.h" | 24 | # include "../locale/localeinfo.h" |
| 25 | #else | 25 | #else |
| @@ -499,7 +499,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) | |||
| 499 | #endif | 499 | #endif |
| 500 | 500 | ||
| 501 | zone = NULL; | 501 | zone = NULL; |
| 502 | #if HAVE_TM_ZONE | 502 | #if HAVE_STRUCT_TM_TM_ZONE |
| 503 | /* The POSIX test suite assumes that setting | 503 | /* The POSIX test suite assumes that setting |
| 504 | the environment variable TZ to a new value before calling strftime() | 504 | the environment variable TZ to a new value before calling strftime() |
| 505 | will influence the result (the %Z format) even if the information in | 505 | will influence the result (the %Z format) even if the information in |
| @@ -516,7 +516,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) | |||
| 516 | } | 516 | } |
| 517 | else | 517 | else |
| 518 | { | 518 | { |
| 519 | # if !HAVE_TM_ZONE | 519 | # if !HAVE_STRUCT_TM_TM_ZONE |
| 520 | /* Infer the zone name from *TZ instead of from TZNAME. */ | 520 | /* Infer the zone name from *TZ instead of from TZNAME. */ |
| 521 | tzname_vec = tz->tzname_copy; | 521 | tzname_vec = tz->tzname_copy; |
| 522 | # endif | 522 | # endif |
diff --git a/lib/regex.c b/lib/regex.c index 88173bb1052..f76a416b3b5 100644 --- a/lib/regex.c +++ b/lib/regex.c | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | /* Extended regular expression matching and search library. | 1 | /* Extended regular expression matching and search library. |
| 2 | Copyright (C) 2002-2020 Free Software Foundation, Inc. | 2 | Copyright (C) 2002-2021 Free Software Foundation, Inc. |
| 3 | This file is part of the GNU C Library. | 3 | This file is part of the GNU C Library. |
| 4 | Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. | 4 | Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. |
| 5 | 5 | ||
diff --git a/lib/regex_internal.h b/lib/regex_internal.h index be2fa4fe78e..4c634edcbfa 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h | |||
| @@ -32,6 +32,7 @@ | |||
| 32 | #include <stdbool.h> | 32 | #include <stdbool.h> |
| 33 | #include <stdint.h> | 33 | #include <stdint.h> |
| 34 | 34 | ||
| 35 | #include <dynarray.h> | ||
| 35 | #include <intprops.h> | 36 | #include <intprops.h> |
| 36 | #include <verify.h> | 37 | #include <verify.h> |
| 37 | 38 | ||
| @@ -444,25 +445,6 @@ typedef struct re_dfa_t re_dfa_t; | |||
| 444 | #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) | 445 | #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) |
| 445 | #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) | 446 | #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) |
| 446 | 447 | ||
| 447 | #if defined _LIBC || HAVE_ALLOCA | ||
| 448 | # include <alloca.h> | ||
| 449 | #endif | ||
| 450 | |||
| 451 | #ifndef _LIBC | ||
| 452 | # if HAVE_ALLOCA | ||
| 453 | /* The OS usually guarantees only one guard page at the bottom of the stack, | ||
| 454 | and a page size can be as small as 4096 bytes. So we cannot safely | ||
| 455 | allocate anything larger than 4096 bytes. Also care for the possibility | ||
| 456 | of a few compiler-allocated temporary stack slots. */ | ||
| 457 | # define __libc_use_alloca(n) ((n) < 4032) | ||
| 458 | # else | ||
| 459 | /* alloca is implemented with malloc, so just use malloc. */ | ||
| 460 | # define __libc_use_alloca(n) 0 | ||
| 461 | # undef alloca | ||
| 462 | # define alloca(n) malloc (n) | ||
| 463 | # endif | ||
| 464 | #endif | ||
| 465 | |||
| 466 | #ifdef _LIBC | 448 | #ifdef _LIBC |
| 467 | # define MALLOC_0_IS_NONNULL 1 | 449 | # define MALLOC_0_IS_NONNULL 1 |
| 468 | #elif !defined MALLOC_0_IS_NONNULL | 450 | #elif !defined MALLOC_0_IS_NONNULL |
| @@ -848,12 +830,14 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx) | |||
| 848 | } | 830 | } |
| 849 | #endif /* RE_ENABLE_I18N */ | 831 | #endif /* RE_ENABLE_I18N */ |
| 850 | 832 | ||
| 851 | #ifndef FALLTHROUGH | 833 | #ifdef _LIBC |
| 852 | # if (__GNUC__ >= 7) || (__clang_major__ >= 10) | 834 | # if __GNUC__ >= 7 |
| 853 | # define FALLTHROUGH __attribute__ ((__fallthrough__)) | 835 | # define FALLTHROUGH __attribute__ ((__fallthrough__)) |
| 854 | # else | 836 | # else |
| 855 | # define FALLTHROUGH ((void) 0) | 837 | # define FALLTHROUGH ((void) 0) |
| 856 | # endif | 838 | # endif |
| 839 | #else | ||
| 840 | # include "attribute.h" | ||
| 857 | #endif | 841 | #endif |
| 858 | 842 | ||
| 859 | #endif /* _REGEX_INTERNAL_H */ | 843 | #endif /* _REGEX_INTERNAL_H */ |
diff --git a/lib/regexec.c b/lib/regexec.c index 395e37db591..15dc57bd0e6 100644 --- a/lib/regexec.c +++ b/lib/regexec.c | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | /* Extended regular expression matching and search library. | 1 | /* Extended regular expression matching and search library. |
| 2 | Copyright (C) 2002-2020 Free Software Foundation, Inc. | 2 | Copyright (C) 2002-2021 Free Software Foundation, Inc. |
| 3 | This file is part of the GNU C Library. | 3 | This file is part of the GNU C Library. |
| 4 | Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. | 4 | Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. |
| 5 | 5 | ||
| @@ -1355,6 +1355,12 @@ pop_fail_stack (struct re_fail_stack_t *fs, Idx *pidx, Idx nregs, | |||
| 1355 | return fs->stack[num].node; | 1355 | return fs->stack[num].node; |
| 1356 | } | 1356 | } |
| 1357 | 1357 | ||
| 1358 | |||
| 1359 | #define DYNARRAY_STRUCT regmatch_list | ||
| 1360 | #define DYNARRAY_ELEMENT regmatch_t | ||
| 1361 | #define DYNARRAY_PREFIX regmatch_list_ | ||
| 1362 | #include <malloc/dynarray-skeleton.c> | ||
| 1363 | |||
| 1358 | /* Set the positions where the subexpressions are starts/ends to registers | 1364 | /* Set the positions where the subexpressions are starts/ends to registers |
| 1359 | PMATCH. | 1365 | PMATCH. |
| 1360 | Note: We assume that pmatch[0] is already set, and | 1366 | Note: We assume that pmatch[0] is already set, and |
| @@ -1370,8 +1376,8 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, | |||
| 1370 | re_node_set eps_via_nodes; | 1376 | re_node_set eps_via_nodes; |
| 1371 | struct re_fail_stack_t *fs; | 1377 | struct re_fail_stack_t *fs; |
| 1372 | struct re_fail_stack_t fs_body = { 0, 2, NULL }; | 1378 | struct re_fail_stack_t fs_body = { 0, 2, NULL }; |
| 1373 | regmatch_t *prev_idx_match; | 1379 | struct regmatch_list prev_match; |
| 1374 | bool prev_idx_match_malloced = false; | 1380 | regmatch_list_init (&prev_match); |
| 1375 | 1381 | ||
| 1376 | DEBUG_ASSERT (nmatch > 1); | 1382 | DEBUG_ASSERT (nmatch > 1); |
| 1377 | DEBUG_ASSERT (mctx->state_log != NULL); | 1383 | DEBUG_ASSERT (mctx->state_log != NULL); |
| @@ -1388,18 +1394,13 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, | |||
| 1388 | cur_node = dfa->init_node; | 1394 | cur_node = dfa->init_node; |
| 1389 | re_node_set_init_empty (&eps_via_nodes); | 1395 | re_node_set_init_empty (&eps_via_nodes); |
| 1390 | 1396 | ||
| 1391 | if (__libc_use_alloca (nmatch * sizeof (regmatch_t))) | 1397 | if (!regmatch_list_resize (&prev_match, nmatch)) |
| 1392 | prev_idx_match = (regmatch_t *) alloca (nmatch * sizeof (regmatch_t)); | ||
| 1393 | else | ||
| 1394 | { | 1398 | { |
| 1395 | prev_idx_match = re_malloc (regmatch_t, nmatch); | 1399 | regmatch_list_free (&prev_match); |
| 1396 | if (prev_idx_match == NULL) | 1400 | free_fail_stack_return (fs); |
| 1397 | { | 1401 | return REG_ESPACE; |
| 1398 | free_fail_stack_return (fs); | ||
| 1399 | return REG_ESPACE; | ||
| 1400 | } | ||
| 1401 | prev_idx_match_malloced = true; | ||
| 1402 | } | 1402 | } |
| 1403 | regmatch_t *prev_idx_match = regmatch_list_begin (&prev_match); | ||
| 1403 | memcpy (prev_idx_match, pmatch, sizeof (regmatch_t) * nmatch); | 1404 | memcpy (prev_idx_match, pmatch, sizeof (regmatch_t) * nmatch); |
| 1404 | 1405 | ||
| 1405 | for (idx = pmatch[0].rm_so; idx <= pmatch[0].rm_eo ;) | 1406 | for (idx = pmatch[0].rm_so; idx <= pmatch[0].rm_eo ;) |
| @@ -1417,8 +1418,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, | |||
| 1417 | if (reg_idx == nmatch) | 1418 | if (reg_idx == nmatch) |
| 1418 | { | 1419 | { |
| 1419 | re_node_set_free (&eps_via_nodes); | 1420 | re_node_set_free (&eps_via_nodes); |
| 1420 | if (prev_idx_match_malloced) | 1421 | regmatch_list_free (&prev_match); |
| 1421 | re_free (prev_idx_match); | ||
| 1422 | return free_fail_stack_return (fs); | 1422 | return free_fail_stack_return (fs); |
| 1423 | } | 1423 | } |
| 1424 | cur_node = pop_fail_stack (fs, &idx, nmatch, pmatch, | 1424 | cur_node = pop_fail_stack (fs, &idx, nmatch, pmatch, |
| @@ -1427,8 +1427,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, | |||
| 1427 | else | 1427 | else |
| 1428 | { | 1428 | { |
| 1429 | re_node_set_free (&eps_via_nodes); | 1429 | re_node_set_free (&eps_via_nodes); |
| 1430 | if (prev_idx_match_malloced) | 1430 | regmatch_list_free (&prev_match); |
| 1431 | re_free (prev_idx_match); | ||
| 1432 | return REG_NOERROR; | 1431 | return REG_NOERROR; |
| 1433 | } | 1432 | } |
| 1434 | } | 1433 | } |
| @@ -1442,8 +1441,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, | |||
| 1442 | if (__glibc_unlikely (cur_node == -2)) | 1441 | if (__glibc_unlikely (cur_node == -2)) |
| 1443 | { | 1442 | { |
| 1444 | re_node_set_free (&eps_via_nodes); | 1443 | re_node_set_free (&eps_via_nodes); |
| 1445 | if (prev_idx_match_malloced) | 1444 | regmatch_list_free (&prev_match); |
| 1446 | re_free (prev_idx_match); | ||
| 1447 | free_fail_stack_return (fs); | 1445 | free_fail_stack_return (fs); |
| 1448 | return REG_ESPACE; | 1446 | return REG_ESPACE; |
| 1449 | } | 1447 | } |
| @@ -1453,15 +1451,13 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, | |||
| 1453 | else | 1451 | else |
| 1454 | { | 1452 | { |
| 1455 | re_node_set_free (&eps_via_nodes); | 1453 | re_node_set_free (&eps_via_nodes); |
| 1456 | if (prev_idx_match_malloced) | 1454 | regmatch_list_free (&prev_match); |
| 1457 | re_free (prev_idx_match); | ||
| 1458 | return REG_NOMATCH; | 1455 | return REG_NOMATCH; |
| 1459 | } | 1456 | } |
| 1460 | } | 1457 | } |
| 1461 | } | 1458 | } |
| 1462 | re_node_set_free (&eps_via_nodes); | 1459 | re_node_set_free (&eps_via_nodes); |
| 1463 | if (prev_idx_match_malloced) | 1460 | regmatch_list_free (&prev_match); |
| 1464 | re_free (prev_idx_match); | ||
| 1465 | return free_fail_stack_return (fs); | 1461 | return free_fail_stack_return (fs); |
| 1466 | } | 1462 | } |
| 1467 | 1463 | ||
| @@ -3251,7 +3247,7 @@ expand_bkref_cache (re_match_context_t *mctx, re_node_set *cur_nodes, | |||
| 3251 | /* Build transition table for the state. | 3247 | /* Build transition table for the state. |
| 3252 | Return true if successful. */ | 3248 | Return true if successful. */ |
| 3253 | 3249 | ||
| 3254 | static bool | 3250 | static bool __attribute_noinline__ |
| 3255 | build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) | 3251 | build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) |
| 3256 | { | 3252 | { |
| 3257 | reg_errcode_t err; | 3253 | reg_errcode_t err; |
| @@ -3259,36 +3255,20 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) | |||
| 3259 | int ch; | 3255 | int ch; |
| 3260 | bool need_word_trtable = false; | 3256 | bool need_word_trtable = false; |
| 3261 | bitset_word_t elem, mask; | 3257 | bitset_word_t elem, mask; |
| 3262 | bool dests_node_malloced = false; | ||
| 3263 | bool dest_states_malloced = false; | ||
| 3264 | Idx ndests; /* Number of the destination states from 'state'. */ | 3258 | Idx ndests; /* Number of the destination states from 'state'. */ |
| 3265 | re_dfastate_t **trtable; | 3259 | re_dfastate_t **trtable; |
| 3266 | re_dfastate_t **dest_states = NULL, **dest_states_word, **dest_states_nl; | 3260 | re_dfastate_t *dest_states[SBC_MAX]; |
| 3267 | re_node_set follows, *dests_node; | 3261 | re_dfastate_t *dest_states_word[SBC_MAX]; |
| 3268 | bitset_t *dests_ch; | 3262 | re_dfastate_t *dest_states_nl[SBC_MAX]; |
| 3263 | re_node_set follows; | ||
| 3269 | bitset_t acceptable; | 3264 | bitset_t acceptable; |
| 3270 | 3265 | ||
| 3271 | struct dests_alloc | ||
| 3272 | { | ||
| 3273 | re_node_set dests_node[SBC_MAX]; | ||
| 3274 | bitset_t dests_ch[SBC_MAX]; | ||
| 3275 | } *dests_alloc; | ||
| 3276 | |||
| 3277 | /* We build DFA states which corresponds to the destination nodes | 3266 | /* We build DFA states which corresponds to the destination nodes |
| 3278 | from 'state'. 'dests_node[i]' represents the nodes which i-th | 3267 | from 'state'. 'dests_node[i]' represents the nodes which i-th |
| 3279 | destination state contains, and 'dests_ch[i]' represents the | 3268 | destination state contains, and 'dests_ch[i]' represents the |
| 3280 | characters which i-th destination state accepts. */ | 3269 | characters which i-th destination state accepts. */ |
| 3281 | if (__libc_use_alloca (sizeof (struct dests_alloc))) | 3270 | re_node_set dests_node[SBC_MAX]; |
| 3282 | dests_alloc = (struct dests_alloc *) alloca (sizeof (struct dests_alloc)); | 3271 | bitset_t dests_ch[SBC_MAX]; |
| 3283 | else | ||
| 3284 | { | ||
| 3285 | dests_alloc = re_malloc (struct dests_alloc, 1); | ||
| 3286 | if (__glibc_unlikely (dests_alloc == NULL)) | ||
| 3287 | return false; | ||
| 3288 | dests_node_malloced = true; | ||
| 3289 | } | ||
| 3290 | dests_node = dests_alloc->dests_node; | ||
| 3291 | dests_ch = dests_alloc->dests_ch; | ||
| 3292 | 3272 | ||
| 3293 | /* Initialize transition table. */ | 3273 | /* Initialize transition table. */ |
| 3294 | state->word_trtable = state->trtable = NULL; | 3274 | state->word_trtable = state->trtable = NULL; |
| @@ -3298,8 +3278,6 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) | |||
| 3298 | ndests = group_nodes_into_DFAstates (dfa, state, dests_node, dests_ch); | 3278 | ndests = group_nodes_into_DFAstates (dfa, state, dests_node, dests_ch); |
| 3299 | if (__glibc_unlikely (ndests <= 0)) | 3279 | if (__glibc_unlikely (ndests <= 0)) |
| 3300 | { | 3280 | { |
| 3301 | if (dests_node_malloced) | ||
| 3302 | re_free (dests_alloc); | ||
| 3303 | /* Return false in case of an error, true otherwise. */ | 3281 | /* Return false in case of an error, true otherwise. */ |
| 3304 | if (ndests == 0) | 3282 | if (ndests == 0) |
| 3305 | { | 3283 | { |
| @@ -3314,38 +3292,14 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) | |||
| 3314 | 3292 | ||
| 3315 | err = re_node_set_alloc (&follows, ndests + 1); | 3293 | err = re_node_set_alloc (&follows, ndests + 1); |
| 3316 | if (__glibc_unlikely (err != REG_NOERROR)) | 3294 | if (__glibc_unlikely (err != REG_NOERROR)) |
| 3317 | goto out_free; | ||
| 3318 | |||
| 3319 | /* Avoid arithmetic overflow in size calculation. */ | ||
| 3320 | size_t ndests_max | ||
| 3321 | = ((SIZE_MAX - (sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX) | ||
| 3322 | / (3 * sizeof (re_dfastate_t *))); | ||
| 3323 | if (__glibc_unlikely (ndests_max < ndests)) | ||
| 3324 | goto out_free; | ||
| 3325 | |||
| 3326 | if (__libc_use_alloca ((sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX | ||
| 3327 | + ndests * 3 * sizeof (re_dfastate_t *))) | ||
| 3328 | dest_states = (re_dfastate_t **) | ||
| 3329 | alloca (ndests * 3 * sizeof (re_dfastate_t *)); | ||
| 3330 | else | ||
| 3331 | { | 3295 | { |
| 3332 | dest_states = re_malloc (re_dfastate_t *, ndests * 3); | 3296 | out_free: |
| 3333 | if (__glibc_unlikely (dest_states == NULL)) | 3297 | re_node_set_free (&follows); |
| 3334 | { | 3298 | for (i = 0; i < ndests; ++i) |
| 3335 | out_free: | 3299 | re_node_set_free (dests_node + i); |
| 3336 | if (dest_states_malloced) | 3300 | return false; |
| 3337 | re_free (dest_states); | ||
| 3338 | re_node_set_free (&follows); | ||
| 3339 | for (i = 0; i < ndests; ++i) | ||
| 3340 | re_node_set_free (dests_node + i); | ||
| 3341 | if (dests_node_malloced) | ||
| 3342 | re_free (dests_alloc); | ||
| 3343 | return false; | ||
| 3344 | } | ||
| 3345 | dest_states_malloced = true; | ||
| 3346 | } | 3301 | } |
| 3347 | dest_states_word = dest_states + ndests; | 3302 | |
| 3348 | dest_states_nl = dest_states_word + ndests; | ||
| 3349 | bitset_empty (acceptable); | 3303 | bitset_empty (acceptable); |
| 3350 | 3304 | ||
| 3351 | /* Then build the states for all destinations. */ | 3305 | /* Then build the states for all destinations. */ |
| @@ -3470,16 +3424,9 @@ out_free: | |||
| 3470 | } | 3424 | } |
| 3471 | } | 3425 | } |
| 3472 | 3426 | ||
| 3473 | if (dest_states_malloced) | ||
| 3474 | re_free (dest_states); | ||
| 3475 | |||
| 3476 | re_node_set_free (&follows); | 3427 | re_node_set_free (&follows); |
| 3477 | for (i = 0; i < ndests; ++i) | 3428 | for (i = 0; i < ndests; ++i) |
| 3478 | re_node_set_free (dests_node + i); | 3429 | re_node_set_free (dests_node + i); |
| 3479 | |||
| 3480 | if (dests_node_malloced) | ||
| 3481 | re_free (dests_alloc); | ||
| 3482 | |||
| 3483 | return true; | 3430 | return true; |
| 3484 | } | 3431 | } |
| 3485 | 3432 | ||
diff --git a/lib/scratch_buffer.h b/lib/scratch_buffer.h index 3e2b5ef27db..603b0d65d0a 100644 --- a/lib/scratch_buffer.h +++ b/lib/scratch_buffer.h | |||
| @@ -21,6 +21,7 @@ | |||
| 21 | 21 | ||
| 22 | #include <libc-config.h> | 22 | #include <libc-config.h> |
| 23 | 23 | ||
| 24 | #define __libc_scratch_buffer_dupfree gl_scratch_buffer_dupfree | ||
| 24 | #define __libc_scratch_buffer_grow gl_scratch_buffer_grow | 25 | #define __libc_scratch_buffer_grow gl_scratch_buffer_grow |
| 25 | #define __libc_scratch_buffer_grow_preserve gl_scratch_buffer_grow_preserve | 26 | #define __libc_scratch_buffer_grow_preserve gl_scratch_buffer_grow_preserve |
| 26 | #define __libc_scratch_buffer_set_array_size gl_scratch_buffer_set_array_size | 27 | #define __libc_scratch_buffer_set_array_size gl_scratch_buffer_set_array_size |
diff --git a/lib/stddef.in.h b/lib/stddef.in.h index ba7195a9102..0f506a5b18b 100644 --- a/lib/stddef.in.h +++ b/lib/stddef.in.h | |||
| @@ -49,6 +49,23 @@ | |||
| 49 | 49 | ||
| 50 | # ifndef _@GUARD_PREFIX@_STDDEF_H | 50 | # ifndef _@GUARD_PREFIX@_STDDEF_H |
| 51 | 51 | ||
| 52 | /* On AIX 7.2, with xlc in 64-bit mode, <stddef.h> defines max_align_t to a | ||
| 53 | type with alignment 4, but 'long' has alignment 8. */ | ||
| 54 | # if defined _AIX && defined _ARCH_PPC64 | ||
| 55 | # if !GNULIB_defined_max_align_t | ||
| 56 | # ifdef _MAX_ALIGN_T | ||
| 57 | /* /usr/include/stddef.h has already defined max_align_t. Override it. */ | ||
| 58 | typedef long rpl_max_align_t; | ||
| 59 | # define max_align_t rpl_max_align_t | ||
| 60 | # else | ||
| 61 | /* Prevent /usr/include/stddef.h from defining max_align_t. */ | ||
| 62 | typedef long max_align_t; | ||
| 63 | # define _MAX_ALIGN_T | ||
| 64 | # endif | ||
| 65 | # define GNULIB_defined_max_align_t 1 | ||
| 66 | # endif | ||
| 67 | # endif | ||
| 68 | |||
| 52 | /* The include_next requires a split double-inclusion guard. */ | 69 | /* The include_next requires a split double-inclusion guard. */ |
| 53 | 70 | ||
| 54 | # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ | 71 | # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ |
| @@ -86,8 +103,10 @@ | |||
| 86 | we are currently compiling with gcc. | 103 | we are currently compiling with gcc. |
| 87 | On MSVC, max_align_t is defined only in C++ mode, after <cstddef> was | 104 | On MSVC, max_align_t is defined only in C++ mode, after <cstddef> was |
| 88 | included. Its definition is good since it has an alignment of 8 (on x86 | 105 | included. Its definition is good since it has an alignment of 8 (on x86 |
| 89 | and x86_64). */ | 106 | and x86_64). |
| 90 | #if defined _MSC_VER && defined __cplusplus | 107 | Similarly on OS/2 kLIBC. */ |
| 108 | #if (defined _MSC_VER || (defined __KLIBC__ && !defined __LIBCN__)) \ | ||
| 109 | && defined __cplusplus | ||
| 91 | # include <cstddef> | 110 | # include <cstddef> |
| 92 | #else | 111 | #else |
| 93 | # if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T) | 112 | # if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T) |
diff --git a/lib/string.in.h b/lib/string.in.h index 9f68e77c767..c76c1820b36 100644 --- a/lib/string.in.h +++ b/lib/string.in.h | |||
| @@ -69,6 +69,14 @@ | |||
| 69 | # include <unistd.h> | 69 | # include <unistd.h> |
| 70 | #endif | 70 | #endif |
| 71 | 71 | ||
| 72 | /* AIX 7.2 declares ffsl and ffsll in <strings.h>, not in <string.h>. */ | ||
| 73 | /* But in any case avoid namespace pollution on glibc systems. */ | ||
| 74 | #if ((@GNULIB_FFSL@ || @GNULIB_FFSLL@ || defined GNULIB_POSIXCHECK) \ | ||
| 75 | && defined _AIX) \ | ||
| 76 | && ! defined __GLIBC__ | ||
| 77 | # include <strings.h> | ||
| 78 | #endif | ||
| 79 | |||
| 72 | /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ | 80 | /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ |
| 73 | 81 | ||
| 74 | /* The definition of _GL_ARG_NONNULL is copied here. */ | 82 | /* The definition of _GL_ARG_NONNULL is copied here. */ |
| @@ -110,10 +118,18 @@ _GL_WARN_ON_USE (ffsl, "ffsl is not portable - use the ffsl module"); | |||
| 110 | 118 | ||
| 111 | /* Find the index of the least-significant set bit. */ | 119 | /* Find the index of the least-significant set bit. */ |
| 112 | #if @GNULIB_FFSLL@ | 120 | #if @GNULIB_FFSLL@ |
| 113 | # if !@HAVE_FFSLL@ | 121 | # if @REPLACE_FFSLL@ |
| 122 | # if !(defined __cplusplus && defined GNULIB_NAMESPACE) | ||
| 123 | # define ffsll rpl_ffsll | ||
| 124 | # endif | ||
| 125 | _GL_FUNCDECL_RPL (ffsll, int, (long long int i)); | ||
| 126 | _GL_CXXALIAS_RPL (ffsll, int, (long long int i)); | ||
| 127 | # else | ||
| 128 | # if !@HAVE_FFSLL@ | ||
| 114 | _GL_FUNCDECL_SYS (ffsll, int, (long long int i)); | 129 | _GL_FUNCDECL_SYS (ffsll, int, (long long int i)); |
| 115 | # endif | 130 | # endif |
| 116 | _GL_CXXALIAS_SYS (ffsll, int, (long long int i)); | 131 | _GL_CXXALIAS_SYS (ffsll, int, (long long int i)); |
| 132 | # endif | ||
| 117 | _GL_CXXALIASWARN (ffsll); | 133 | _GL_CXXALIASWARN (ffsll); |
| 118 | #elif defined GNULIB_POSIXCHECK | 134 | #elif defined GNULIB_POSIXCHECK |
| 119 | # undef ffsll | 135 | # undef ffsll |
diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h index ccdb5cbd143..13d12943cd0 100644 --- a/lib/sys_stat.in.h +++ b/lib/sys_stat.in.h | |||
| @@ -713,11 +713,21 @@ _GL_WARN_ON_USE (mkfifo, "mkfifo is not portable - " | |||
| 713 | 713 | ||
| 714 | 714 | ||
| 715 | #if @GNULIB_MKFIFOAT@ | 715 | #if @GNULIB_MKFIFOAT@ |
| 716 | # if !@HAVE_MKFIFOAT@ | 716 | # if @REPLACE_MKFIFOAT@ |
| 717 | # if !(defined __cplusplus && defined GNULIB_NAMESPACE) | ||
| 718 | # undef mkfifoat | ||
| 719 | # define mkfifoat rpl_mkfifoat | ||
| 720 | # endif | ||
| 721 | _GL_FUNCDECL_RPL (mkfifoat, int, (int fd, char const *file, mode_t mode) | ||
| 722 | _GL_ARG_NONNULL ((2))); | ||
| 723 | _GL_CXXALIAS_RPL (mkfifoat, int, (int fd, char const *file, mode_t mode)); | ||
| 724 | # else | ||
| 725 | # if !@HAVE_MKFIFOAT@ | ||
| 717 | _GL_FUNCDECL_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode) | 726 | _GL_FUNCDECL_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode) |
| 718 | _GL_ARG_NONNULL ((2))); | 727 | _GL_ARG_NONNULL ((2))); |
| 719 | # endif | 728 | # endif |
| 720 | _GL_CXXALIAS_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode)); | 729 | _GL_CXXALIAS_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode)); |
| 730 | # endif | ||
| 721 | _GL_CXXALIASWARN (mkfifoat); | 731 | _GL_CXXALIASWARN (mkfifoat); |
| 722 | #elif defined GNULIB_POSIXCHECK | 732 | #elif defined GNULIB_POSIXCHECK |
| 723 | # undef mkfifoat | 733 | # undef mkfifoat |
| @@ -756,13 +766,25 @@ _GL_WARN_ON_USE (mknod, "mknod is not portable - " | |||
| 756 | 766 | ||
| 757 | 767 | ||
| 758 | #if @GNULIB_MKNODAT@ | 768 | #if @GNULIB_MKNODAT@ |
| 759 | # if !@HAVE_MKNODAT@ | 769 | # if @REPLACE_MKNODAT@ |
| 770 | # if !(defined __cplusplus && defined GNULIB_NAMESPACE) | ||
| 771 | # undef mknodat | ||
| 772 | # define mknodat rpl_mknodat | ||
| 773 | # endif | ||
| 774 | _GL_FUNCDECL_RPL (mknodat, int, | ||
| 775 | (int fd, char const *file, mode_t mode, dev_t dev) | ||
| 776 | _GL_ARG_NONNULL ((2))); | ||
| 777 | _GL_CXXALIAS_RPL (mknodat, int, | ||
| 778 | (int fd, char const *file, mode_t mode, dev_t dev)); | ||
| 779 | # else | ||
| 780 | # if !@HAVE_MKNODAT@ | ||
| 760 | _GL_FUNCDECL_SYS (mknodat, int, | 781 | _GL_FUNCDECL_SYS (mknodat, int, |
| 761 | (int fd, char const *file, mode_t mode, dev_t dev) | 782 | (int fd, char const *file, mode_t mode, dev_t dev) |
| 762 | _GL_ARG_NONNULL ((2))); | 783 | _GL_ARG_NONNULL ((2))); |
| 763 | # endif | 784 | # endif |
| 764 | _GL_CXXALIAS_SYS (mknodat, int, | 785 | _GL_CXXALIAS_SYS (mknodat, int, |
| 765 | (int fd, char const *file, mode_t mode, dev_t dev)); | 786 | (int fd, char const *file, mode_t mode, dev_t dev)); |
| 787 | # endif | ||
| 766 | _GL_CXXALIASWARN (mknodat); | 788 | _GL_CXXALIASWARN (mknodat); |
| 767 | #elif defined GNULIB_POSIXCHECK | 789 | #elif defined GNULIB_POSIXCHECK |
| 768 | # undef mknodat | 790 | # undef mknodat |
diff --git a/lib/tempname.c b/lib/tempname.c index 3d91deef1e1..e243483eaf8 100644 --- a/lib/tempname.c +++ b/lib/tempname.c | |||
| @@ -22,6 +22,7 @@ | |||
| 22 | 22 | ||
| 23 | #include <sys/types.h> | 23 | #include <sys/types.h> |
| 24 | #include <assert.h> | 24 | #include <assert.h> |
| 25 | #include <stdbool.h> | ||
| 25 | 26 | ||
| 26 | #include <errno.h> | 27 | #include <errno.h> |
| 27 | 28 | ||
| @@ -61,7 +62,8 @@ | |||
| 61 | # define __gen_tempname gen_tempname | 62 | # define __gen_tempname gen_tempname |
| 62 | # define __mkdir mkdir | 63 | # define __mkdir mkdir |
| 63 | # define __open open | 64 | # define __open open |
| 64 | # define __lxstat64(version, file, buf) lstat (file, buf) | 65 | # define __lstat64(file, buf) lstat (file, buf) |
| 66 | # define __stat64(file, buf) stat (file, buf) | ||
| 65 | # define __getrandom getrandom | 67 | # define __getrandom getrandom |
| 66 | # define __clock_gettime64 clock_gettime | 68 | # define __clock_gettime64 clock_gettime |
| 67 | # define __timespec64 timespec | 69 | # define __timespec64 timespec |
| @@ -76,13 +78,14 @@ typedef uint_fast64_t random_value; | |||
| 76 | #define BASE_62_POWER (62LL * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62) | 78 | #define BASE_62_POWER (62LL * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62) |
| 77 | 79 | ||
| 78 | static random_value | 80 | static random_value |
| 79 | random_bits (random_value var) | 81 | random_bits (random_value var, bool use_getrandom) |
| 80 | { | 82 | { |
| 81 | random_value r; | 83 | random_value r; |
| 82 | if (__getrandom (&r, sizeof r, 0) == sizeof r) | 84 | /* Without GRND_NONBLOCK it can be blocked for minutes on some systems. */ |
| 85 | if (use_getrandom && __getrandom (&r, sizeof r, GRND_NONBLOCK) == sizeof r) | ||
| 83 | return r; | 86 | return r; |
| 84 | #if _LIBC || (defined CLOCK_MONOTONIC && HAVE_CLOCK_GETTIME) | 87 | #if _LIBC || (defined CLOCK_MONOTONIC && HAVE_CLOCK_GETTIME) |
| 85 | /* Add entropy if getrandom is not supported. */ | 88 | /* Add entropy if getrandom did not work. */ |
| 86 | struct __timespec64 tv; | 89 | struct __timespec64 tv; |
| 87 | __clock_gettime64 (CLOCK_MONOTONIC, &tv); | 90 | __clock_gettime64 (CLOCK_MONOTONIC, &tv); |
| 88 | var ^= tv.tv_nsec; | 91 | var ^= tv.tv_nsec; |
| @@ -96,7 +99,7 @@ static int | |||
| 96 | direxists (const char *dir) | 99 | direxists (const char *dir) |
| 97 | { | 100 | { |
| 98 | struct_stat64 buf; | 101 | struct_stat64 buf; |
| 99 | return __xstat64 (_STAT_VER, dir, &buf) == 0 && S_ISDIR (buf.st_mode); | 102 | return __stat64 (dir, &buf) == 0 && S_ISDIR (buf.st_mode); |
| 100 | } | 103 | } |
| 101 | 104 | ||
| 102 | /* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is | 105 | /* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is |
| @@ -188,7 +191,7 @@ try_nocreate (char *tmpl, void *flags _GL_UNUSED) | |||
| 188 | { | 191 | { |
| 189 | struct_stat64 st; | 192 | struct_stat64 st; |
| 190 | 193 | ||
| 191 | if (__lxstat64 (_STAT_VER, tmpl, &st) == 0 || errno == EOVERFLOW) | 194 | if (__lstat64 (tmpl, &st) == 0 || errno == EOVERFLOW) |
| 192 | __set_errno (EEXIST); | 195 | __set_errno (EEXIST); |
| 193 | return errno == ENOENT ? 0 : -1; | 196 | return errno == ENOENT ? 0 : -1; |
| 194 | } | 197 | } |
| @@ -267,6 +270,13 @@ try_tempname_len (char *tmpl, int suffixlen, void *args, | |||
| 267 | /* How many random base-62 digits can currently be extracted from V. */ | 270 | /* How many random base-62 digits can currently be extracted from V. */ |
| 268 | int vdigits = 0; | 271 | int vdigits = 0; |
| 269 | 272 | ||
| 273 | /* Whether to consume entropy when acquiring random bits. On the | ||
| 274 | first try it's worth the entropy cost with __GT_NOCREATE, which | ||
| 275 | is inherently insecure and can use the entropy to make it a bit | ||
| 276 | less secure. On the (rare) second and later attempts it might | ||
| 277 | help against DoS attacks. */ | ||
| 278 | bool use_getrandom = tryfunc == try_nocreate; | ||
| 279 | |||
| 270 | /* Least unfair value for V. If V is less than this, V can generate | 280 | /* Least unfair value for V. If V is less than this, V can generate |
| 271 | BASE_62_DIGITS digits fairly. Otherwise it might be biased. */ | 281 | BASE_62_DIGITS digits fairly. Otherwise it might be biased. */ |
| 272 | random_value const unfair_min | 282 | random_value const unfair_min |
| @@ -290,7 +300,10 @@ try_tempname_len (char *tmpl, int suffixlen, void *args, | |||
| 290 | if (vdigits == 0) | 300 | if (vdigits == 0) |
| 291 | { | 301 | { |
| 292 | do | 302 | do |
| 293 | v = random_bits (v); | 303 | { |
| 304 | v = random_bits (v, use_getrandom); | ||
| 305 | use_getrandom = true; | ||
| 306 | } | ||
| 294 | while (unfair_min <= v); | 307 | while (unfair_min <= v); |
| 295 | 308 | ||
| 296 | vdigits = BASE_62_DIGITS; | 309 | vdigits = BASE_62_DIGITS; |
diff --git a/lib/time-internal.h b/lib/time-internal.h index 63a3f9e3db1..067ee729eda 100644 --- a/lib/time-internal.h +++ b/lib/time-internal.h | |||
| @@ -24,7 +24,7 @@ struct tm_zone | |||
| 24 | members are zero. */ | 24 | members are zero. */ |
| 25 | struct tm_zone *next; | 25 | struct tm_zone *next; |
| 26 | 26 | ||
| 27 | #if HAVE_TZNAME && !HAVE_TM_ZONE | 27 | #if HAVE_TZNAME && !HAVE_STRUCT_TM_TM_ZONE |
| 28 | /* Copies of recent strings taken from tzname[0] and tzname[1]. | 28 | /* Copies of recent strings taken from tzname[0] and tzname[1]. |
| 29 | The copies are in ABBRS, so that they survive tzset. Null if unknown. */ | 29 | The copies are in ABBRS, so that they survive tzset. Null if unknown. */ |
| 30 | char *tzname_copy[2]; | 30 | char *tzname_copy[2]; |
diff --git a/lib/time.in.h b/lib/time.in.h index 958dc0bd292..1385980cdf5 100644 --- a/lib/time.in.h +++ b/lib/time.in.h | |||
| @@ -101,6 +101,25 @@ struct __time_t_must_be_integral { | |||
| 101 | # define GNULIB_defined_struct_time_t_must_be_integral 1 | 101 | # define GNULIB_defined_struct_time_t_must_be_integral 1 |
| 102 | # endif | 102 | # endif |
| 103 | 103 | ||
| 104 | /* Define TIME_UTC, a positive integer constant used for timespec_get(). */ | ||
| 105 | # if ! @TIME_H_DEFINES_TIME_UTC@ | ||
| 106 | # if !GNULIB_defined_TIME_UTC | ||
| 107 | # define TIME_UTC 1 | ||
| 108 | # define GNULIB_defined_TIME_UTC 1 | ||
| 109 | # endif | ||
| 110 | # endif | ||
| 111 | |||
| 112 | /* Set *TS to the current time, and return BASE. | ||
| 113 | Upon failure, return 0. */ | ||
| 114 | # if @GNULIB_TIMESPEC_GET@ | ||
| 115 | # if ! @HAVE_TIMESPEC_GET@ | ||
| 116 | _GL_FUNCDECL_SYS (timespec_get, int, (struct timespec *ts, int base) | ||
| 117 | _GL_ARG_NONNULL ((1))); | ||
| 118 | # endif | ||
| 119 | _GL_CXXALIAS_SYS (timespec_get, int, (struct timespec *ts, int base)); | ||
| 120 | _GL_CXXALIASWARN (timespec_get); | ||
| 121 | # endif | ||
| 122 | |||
| 104 | /* Sleep for at least RQTP seconds unless interrupted, If interrupted, | 123 | /* Sleep for at least RQTP seconds unless interrupted, If interrupted, |
| 105 | return -1 and store the remaining time into RMTP. See | 124 | return -1 and store the remaining time into RMTP. See |
| 106 | <https://pubs.opengroup.org/onlinepubs/9699919799/functions/nanosleep.html>. */ | 125 | <https://pubs.opengroup.org/onlinepubs/9699919799/functions/nanosleep.html>. */ |
diff --git a/lib/time_rz.c b/lib/time_rz.c index 65e20cc5661..3ac053c6219 100644 --- a/lib/time_rz.c +++ b/lib/time_rz.c | |||
| @@ -71,7 +71,7 @@ tzalloc (char const *name) | |||
| 71 | if (tz) | 71 | if (tz) |
| 72 | { | 72 | { |
| 73 | tz->next = NULL; | 73 | tz->next = NULL; |
| 74 | #if HAVE_TZNAME && !HAVE_TM_ZONE | 74 | #if HAVE_TZNAME && !HAVE_STRUCT_TM_TM_ZONE |
| 75 | tz->tzname_copy[0] = tz->tzname_copy[1] = NULL; | 75 | tz->tzname_copy[0] = tz->tzname_copy[1] = NULL; |
| 76 | #endif | 76 | #endif |
| 77 | tz->tz_is_set = !!name; | 77 | tz->tz_is_set = !!name; |
| @@ -83,13 +83,13 @@ tzalloc (char const *name) | |||
| 83 | } | 83 | } |
| 84 | 84 | ||
| 85 | /* Save into TZ any nontrivial time zone abbreviation used by TM, and | 85 | /* Save into TZ any nontrivial time zone abbreviation used by TM, and |
| 86 | update *TM (if HAVE_TM_ZONE) or *TZ (if !HAVE_TM_ZONE && | 86 | update *TM (if HAVE_STRUCT_TM_TM_ZONE) or *TZ (if |
| 87 | HAVE_TZNAME) if they use the abbreviation. Return true if | 87 | !HAVE_STRUCT_TM_TM_ZONE && HAVE_TZNAME) if they use the abbreviation. |
| 88 | successful, false (setting errno) otherwise. */ | 88 | Return true if successful, false (setting errno) otherwise. */ |
| 89 | static bool | 89 | static bool |
| 90 | save_abbr (timezone_t tz, struct tm *tm) | 90 | save_abbr (timezone_t tz, struct tm *tm) |
| 91 | { | 91 | { |
| 92 | #if HAVE_TM_ZONE || HAVE_TZNAME | 92 | #if HAVE_STRUCT_TM_TM_ZONE || HAVE_TZNAME |
| 93 | char const *zone = NULL; | 93 | char const *zone = NULL; |
| 94 | char *zone_copy = (char *) ""; | 94 | char *zone_copy = (char *) ""; |
| 95 | 95 | ||
| @@ -97,7 +97,7 @@ save_abbr (timezone_t tz, struct tm *tm) | |||
| 97 | int tzname_index = -1; | 97 | int tzname_index = -1; |
| 98 | # endif | 98 | # endif |
| 99 | 99 | ||
| 100 | # if HAVE_TM_ZONE | 100 | # if HAVE_STRUCT_TM_TM_ZONE |
| 101 | zone = tm->tm_zone; | 101 | zone = tm->tm_zone; |
| 102 | # endif | 102 | # endif |
| 103 | 103 | ||
| @@ -145,7 +145,7 @@ save_abbr (timezone_t tz, struct tm *tm) | |||
| 145 | } | 145 | } |
| 146 | 146 | ||
| 147 | /* Replace the zone name so that its lifetime matches that of TZ. */ | 147 | /* Replace the zone name so that its lifetime matches that of TZ. */ |
| 148 | # if HAVE_TM_ZONE | 148 | # if HAVE_STRUCT_TM_TM_ZONE |
| 149 | tm->tm_zone = zone_copy; | 149 | tm->tm_zone = zone_copy; |
| 150 | # else | 150 | # else |
| 151 | if (0 <= tzname_index) | 151 | if (0 <= tzname_index) |
| @@ -303,7 +303,7 @@ mktime_z (timezone_t tz, struct tm *tm) | |||
| 303 | tm_1.tm_isdst = tm->tm_isdst; | 303 | tm_1.tm_isdst = tm->tm_isdst; |
| 304 | time_t t = mktime (&tm_1); | 304 | time_t t = mktime (&tm_1); |
| 305 | bool ok = 0 <= tm_1.tm_yday; | 305 | bool ok = 0 <= tm_1.tm_yday; |
| 306 | #if HAVE_TM_ZONE || HAVE_TZNAME | 306 | #if HAVE_STRUCT_TM_TM_ZONE || HAVE_TZNAME |
| 307 | ok = ok && save_abbr (tz, &tm_1); | 307 | ok = ok && save_abbr (tz, &tm_1); |
| 308 | #endif | 308 | #endif |
| 309 | if (revert_tz (old_tz) && ok) | 309 | if (revert_tz (old_tz) && ok) |
diff --git a/lib/timegm.c b/lib/timegm.c index fa30943084d..e4127e71c0b 100644 --- a/lib/timegm.c +++ b/lib/timegm.c | |||
| @@ -1,6 +1,6 @@ | |||
| 1 | /* Convert UTC calendar time to simple time. Like mktime but assumes UTC. | 1 | /* Convert UTC calendar time to simple time. Like mktime but assumes UTC. |
| 2 | 2 | ||
| 3 | Copyright (C) 1994-2020 Free Software Foundation, Inc. | 3 | Copyright (C) 1994-2021 Free Software Foundation, Inc. |
| 4 | This file is part of the GNU C Library. | 4 | This file is part of the GNU C Library. |
| 5 | 5 | ||
| 6 | The GNU C Library is free software; you can redistribute it and/or | 6 | The GNU C Library is free software; you can redistribute it and/or |
diff --git a/lib/utimens.c b/lib/utimens.c index 5bbae058132..44d1ea003e2 100644 --- a/lib/utimens.c +++ b/lib/utimens.c | |||
| @@ -27,6 +27,7 @@ | |||
| 27 | #include <errno.h> | 27 | #include <errno.h> |
| 28 | #include <fcntl.h> | 28 | #include <fcntl.h> |
| 29 | #include <stdbool.h> | 29 | #include <stdbool.h> |
| 30 | #include <string.h> | ||
| 30 | #include <sys/stat.h> | 31 | #include <sys/stat.h> |
| 31 | #include <sys/time.h> | 32 | #include <sys/time.h> |
| 32 | #include <unistd.h> | 33 | #include <unistd.h> |
| @@ -52,7 +53,9 @@ | |||
| 52 | 53 | ||
| 53 | /* Avoid recursion with rpl_futimens or rpl_utimensat. */ | 54 | /* Avoid recursion with rpl_futimens or rpl_utimensat. */ |
| 54 | #undef futimens | 55 | #undef futimens |
| 55 | #undef utimensat | 56 | #if !HAVE_NEARLY_WORKING_UTIMENSAT |
| 57 | # undef utimensat | ||
| 58 | #endif | ||
| 56 | 59 | ||
| 57 | /* Solaris 9 mistakenly succeeds when given a non-directory with a | 60 | /* Solaris 9 mistakenly succeeds when given a non-directory with a |
| 58 | trailing slash. Force the use of rpl_stat for a fix. */ | 61 | trailing slash. Force the use of rpl_stat for a fix. */ |
| @@ -246,6 +249,20 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2]) | |||
| 246 | # if HAVE_UTIMENSAT | 249 | # if HAVE_UTIMENSAT |
| 247 | if (fd < 0) | 250 | if (fd < 0) |
| 248 | { | 251 | { |
| 252 | # if defined __APPLE__ && defined __MACH__ | ||
| 253 | size_t len = strlen (file); | ||
| 254 | if (len > 0 && file[len - 1] == '/') | ||
| 255 | { | ||
| 256 | struct stat statbuf; | ||
| 257 | if (stat (file, &statbuf) < 0) | ||
| 258 | return -1; | ||
| 259 | if (!S_ISDIR (statbuf.st_mode)) | ||
| 260 | { | ||
| 261 | errno = ENOTDIR; | ||
| 262 | return -1; | ||
| 263 | } | ||
| 264 | } | ||
| 265 | # endif | ||
| 249 | result = utimensat (AT_FDCWD, file, ts, 0); | 266 | result = utimensat (AT_FDCWD, file, ts, 0); |
| 250 | # ifdef __linux__ | 267 | # ifdef __linux__ |
| 251 | /* Work around a kernel bug: | 268 | /* Work around a kernel bug: |
diff --git a/lib/utimensat.c b/lib/utimensat.c index 2cea64f6982..9fdecd681f6 100644 --- a/lib/utimensat.c +++ b/lib/utimensat.c | |||
| @@ -24,14 +24,40 @@ | |||
| 24 | #include <errno.h> | 24 | #include <errno.h> |
| 25 | #include <fcntl.h> | 25 | #include <fcntl.h> |
| 26 | #include <stdlib.h> | 26 | #include <stdlib.h> |
| 27 | #include <string.h> | ||
| 28 | #include <sys/stat.h> | ||
| 27 | 29 | ||
| 28 | #include "stat-time.h" | 30 | #include "stat-time.h" |
| 29 | #include "timespec.h" | 31 | #include "timespec.h" |
| 30 | #include "utimens.h" | 32 | #include "utimens.h" |
| 31 | 33 | ||
| 32 | #if HAVE_UTIMENSAT | 34 | #if HAVE_NEARLY_WORKING_UTIMENSAT |
| 33 | 35 | ||
| 36 | /* Use the original utimensat(), but correct the trailing slash handling. */ | ||
| 37 | int | ||
| 38 | rpl_utimensat (int fd, char const *file, struct timespec const times[2], | ||
| 39 | int flag) | ||
| 34 | # undef utimensat | 40 | # undef utimensat |
| 41 | { | ||
| 42 | size_t len = strlen (file); | ||
| 43 | if (len && file[len - 1] == '/') | ||
| 44 | { | ||
| 45 | struct stat st; | ||
| 46 | if (fstatat (fd, file, &st, flag & AT_SYMLINK_NOFOLLOW) < 0) | ||
| 47 | return -1; | ||
| 48 | if (!S_ISDIR (st.st_mode)) | ||
| 49 | { | ||
| 50 | errno = ENOTDIR; | ||
| 51 | return -1; | ||
| 52 | } | ||
| 53 | } | ||
| 54 | |||
| 55 | return utimensat (fd, file, times, flag); | ||
| 56 | } | ||
| 57 | |||
| 58 | #else | ||
| 59 | |||
| 60 | # if HAVE_UTIMENSAT | ||
| 35 | 61 | ||
| 36 | /* If we have a native utimensat, but are compiling this file, then | 62 | /* If we have a native utimensat, but are compiling this file, then |
| 37 | utimensat was defined to rpl_utimensat by our replacement | 63 | utimensat was defined to rpl_utimensat by our replacement |
| @@ -42,24 +68,25 @@ | |||
| 42 | local_utimensat provides the fallback manipulation. */ | 68 | local_utimensat provides the fallback manipulation. */ |
| 43 | 69 | ||
| 44 | static int local_utimensat (int, char const *, struct timespec const[2], int); | 70 | static int local_utimensat (int, char const *, struct timespec const[2], int); |
| 45 | # define AT_FUNC_NAME local_utimensat | 71 | # define AT_FUNC_NAME local_utimensat |
| 46 | 72 | ||
| 47 | /* Like utimensat, but work around native bugs. */ | 73 | /* Like utimensat, but work around native bugs. */ |
| 48 | 74 | ||
| 49 | int | 75 | int |
| 50 | rpl_utimensat (int fd, char const *file, struct timespec const times[2], | 76 | rpl_utimensat (int fd, char const *file, struct timespec const times[2], |
| 51 | int flag) | 77 | int flag) |
| 78 | # undef utimensat | ||
| 52 | { | 79 | { |
| 53 | # if defined __linux__ || defined __sun | 80 | # if defined __linux__ || defined __sun |
| 54 | struct timespec ts[2]; | 81 | struct timespec ts[2]; |
| 55 | # endif | 82 | # endif |
| 56 | 83 | ||
| 57 | /* See comments in utimens.c for details. */ | 84 | /* See comments in utimens.c for details. */ |
| 58 | static int utimensat_works_really; /* 0 = unknown, 1 = yes, -1 = no. */ | 85 | static int utimensat_works_really; /* 0 = unknown, 1 = yes, -1 = no. */ |
| 59 | if (0 <= utimensat_works_really) | 86 | if (0 <= utimensat_works_really) |
| 60 | { | 87 | { |
| 61 | int result; | 88 | int result; |
| 62 | # if defined __linux__ || defined __sun | 89 | # if defined __linux__ || defined __sun |
| 63 | struct stat st; | 90 | struct stat st; |
| 64 | /* As recently as Linux kernel 2.6.32 (Dec 2009), several file | 91 | /* As recently as Linux kernel 2.6.32 (Dec 2009), several file |
| 65 | systems (xfs, ntfs-3g) have bugs with a single UTIME_OMIT, | 92 | systems (xfs, ntfs-3g) have bugs with a single UTIME_OMIT, |
| @@ -90,7 +117,7 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2], | |||
| 90 | ts[1] = times[1]; | 117 | ts[1] = times[1]; |
| 91 | times = ts; | 118 | times = ts; |
| 92 | } | 119 | } |
| 93 | # ifdef __hppa__ | 120 | # ifdef __hppa__ |
| 94 | /* Linux kernel 2.6.22.19 on hppa does not reject invalid tv_nsec | 121 | /* Linux kernel 2.6.22.19 on hppa does not reject invalid tv_nsec |
| 95 | values. */ | 122 | values. */ |
| 96 | else if (times | 123 | else if (times |
| @@ -104,8 +131,36 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2], | |||
| 104 | errno = EINVAL; | 131 | errno = EINVAL; |
| 105 | return -1; | 132 | return -1; |
| 106 | } | 133 | } |
| 134 | # endif | ||
| 135 | # endif | ||
| 136 | # if defined __APPLE__ && defined __MACH__ | ||
| 137 | /* macOS 10.13 does not reject invalid tv_nsec values either. */ | ||
| 138 | if (times | ||
| 139 | && ((times[0].tv_nsec != UTIME_OMIT | ||
| 140 | && times[0].tv_nsec != UTIME_NOW | ||
| 141 | && ! (0 <= times[0].tv_nsec | ||
| 142 | && times[0].tv_nsec < TIMESPEC_HZ)) | ||
| 143 | || (times[1].tv_nsec != UTIME_OMIT | ||
| 144 | && times[1].tv_nsec != UTIME_NOW | ||
| 145 | && ! (0 <= times[1].tv_nsec | ||
| 146 | && times[1].tv_nsec < TIMESPEC_HZ)))) | ||
| 147 | { | ||
| 148 | errno = EINVAL; | ||
| 149 | return -1; | ||
| 150 | } | ||
| 151 | size_t len = strlen (file); | ||
| 152 | if (len > 0 && file[len - 1] == '/') | ||
| 153 | { | ||
| 154 | struct stat statbuf; | ||
| 155 | if (fstatat (fd, file, &statbuf, 0) < 0) | ||
| 156 | return -1; | ||
| 157 | if (!S_ISDIR (statbuf.st_mode)) | ||
| 158 | { | ||
| 159 | errno = ENOTDIR; | ||
| 160 | return -1; | ||
| 161 | } | ||
| 162 | } | ||
| 107 | # endif | 163 | # endif |
| 108 | # endif | ||
| 109 | result = utimensat (fd, file, times, flag); | 164 | result = utimensat (fd, file, times, flag); |
| 110 | /* Linux kernel 2.6.25 has a bug where it returns EINVAL for | 165 | /* Linux kernel 2.6.25 has a bug where it returns EINVAL for |
| 111 | UTIME_NOW or UTIME_OMIT with non-zero tv_sec, which | 166 | UTIME_NOW or UTIME_OMIT with non-zero tv_sec, which |
| @@ -129,11 +184,11 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2], | |||
| 129 | return local_utimensat (fd, file, times, flag); | 184 | return local_utimensat (fd, file, times, flag); |
| 130 | } | 185 | } |
| 131 | 186 | ||
| 132 | #else /* !HAVE_UTIMENSAT */ | 187 | # else /* !HAVE_UTIMENSAT */ |
| 133 | 188 | ||
| 134 | # define AT_FUNC_NAME utimensat | 189 | # define AT_FUNC_NAME utimensat |
| 135 | 190 | ||
| 136 | #endif /* !HAVE_UTIMENSAT */ | 191 | # endif /* !HAVE_UTIMENSAT */ |
| 137 | 192 | ||
| 138 | /* Set the access and modification timestamps of FILE to be | 193 | /* Set the access and modification timestamps of FILE to be |
| 139 | TIMESPEC[0] and TIMESPEC[1], respectively; relative to directory | 194 | TIMESPEC[0] and TIMESPEC[1], respectively; relative to directory |
| @@ -146,15 +201,17 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2], | |||
| 146 | Return 0 on success, -1 (setting errno) on failure. */ | 201 | Return 0 on success, -1 (setting errno) on failure. */ |
| 147 | 202 | ||
| 148 | /* AT_FUNC_NAME is now utimensat or local_utimensat. */ | 203 | /* AT_FUNC_NAME is now utimensat or local_utimensat. */ |
| 149 | #define AT_FUNC_F1 lutimens | 204 | # define AT_FUNC_F1 lutimens |
| 150 | #define AT_FUNC_F2 utimens | 205 | # define AT_FUNC_F2 utimens |
| 151 | #define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW | 206 | # define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW |
| 152 | #define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag | 207 | # define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag |
| 153 | #define AT_FUNC_POST_FILE_ARGS , ts | 208 | # define AT_FUNC_POST_FILE_ARGS , ts |
| 154 | #include "at-func.c" | 209 | # include "at-func.c" |
| 155 | #undef AT_FUNC_NAME | 210 | # undef AT_FUNC_NAME |
| 156 | #undef AT_FUNC_F1 | 211 | # undef AT_FUNC_F1 |
| 157 | #undef AT_FUNC_F2 | 212 | # undef AT_FUNC_F2 |
| 158 | #undef AT_FUNC_USE_F1_COND | 213 | # undef AT_FUNC_USE_F1_COND |
| 159 | #undef AT_FUNC_POST_FILE_PARAM_DECLS | 214 | # undef AT_FUNC_POST_FILE_PARAM_DECLS |
| 160 | #undef AT_FUNC_POST_FILE_ARGS | 215 | # undef AT_FUNC_POST_FILE_ARGS |
| 216 | |||
| 217 | #endif /* !HAVE_NEARLY_WORKING_UTIMENSAT */ | ||
diff --git a/lib/verify.h b/lib/verify.h index 3cdcdca5671..65514c34b9e 100644 --- a/lib/verify.h +++ b/lib/verify.h | |||
| @@ -22,16 +22,10 @@ | |||
| 22 | 22 | ||
| 23 | 23 | ||
| 24 | /* Define _GL_HAVE__STATIC_ASSERT to 1 if _Static_assert (R, DIAGNOSTIC) | 24 | /* Define _GL_HAVE__STATIC_ASSERT to 1 if _Static_assert (R, DIAGNOSTIC) |
| 25 | works as per C11. This is supported by GCC 4.6.0 and later, in C | 25 | works as per C11. This is supported by GCC 4.6.0+ and by clang 4+. |
| 26 | mode, and by clang (also in C++ mode). | ||
| 27 | 26 | ||
| 28 | Define _GL_HAVE__STATIC_ASSERT1 to 1 if _Static_assert (R) works as | 27 | Define _GL_HAVE__STATIC_ASSERT1 to 1 if _Static_assert (R) works as |
| 29 | per C2X. This is supported by GCC 9.1 and later, and by clang in | 28 | per C2X. This is supported by GCC 9.1+. |
| 30 | C++1z mode. | ||
| 31 | |||
| 32 | Define _GL_HAVE_STATIC_ASSERT1 if static_assert (R) works as per | ||
| 33 | C++17. This is supported by GCC 9.1 and later, and by clang in | ||
| 34 | C++1z mode. | ||
| 35 | 29 | ||
| 36 | Support compilers claiming conformance to the relevant standard, | 30 | Support compilers claiming conformance to the relevant standard, |
| 37 | and also support GCC when not pedantic. If we were willing to slow | 31 | and also support GCC when not pedantic. If we were willing to slow |
| @@ -47,18 +41,6 @@ | |||
| 47 | || (!defined __STRICT_ANSI__ && 9 <= __GNUC__)) | 41 | || (!defined __STRICT_ANSI__ && 9 <= __GNUC__)) |
| 48 | # define _GL_HAVE__STATIC_ASSERT1 1 | 42 | # define _GL_HAVE__STATIC_ASSERT1 1 |
| 49 | # endif | 43 | # endif |
| 50 | #else | ||
| 51 | # if 4 <= __clang_major__ | ||
| 52 | # define _GL_HAVE__STATIC_ASSERT 1 | ||
| 53 | # endif | ||
| 54 | # if 4 <= __clang_major__ && 201411 <= __cpp_static_assert | ||
| 55 | # define _GL_HAVE__STATIC_ASSERT1 1 | ||
| 56 | # endif | ||
| 57 | # if 201703L <= __cplusplus \ | ||
| 58 | || 9 <= __GNUC__ \ | ||
| 59 | || (4 <= __clang_major__ && 201411 <= __cpp_static_assert) | ||
| 60 | # define _GL_HAVE_STATIC_ASSERT1 1 | ||
| 61 | # endif | ||
| 62 | #endif | 44 | #endif |
| 63 | 45 | ||
| 64 | /* FreeBSD 9.1 <sys/cdefs.h>, included by <stddef.h> and lots of other | 46 | /* FreeBSD 9.1 <sys/cdefs.h>, included by <stddef.h> and lots of other |
| @@ -225,7 +207,9 @@ template <int w> | |||
| 225 | Unfortunately, unlike C11, this implementation must appear as an | 207 | Unfortunately, unlike C11, this implementation must appear as an |
| 226 | ordinary declaration, and cannot appear inside struct { ... }. */ | 208 | ordinary declaration, and cannot appear inside struct { ... }. */ |
| 227 | 209 | ||
| 228 | #if defined _GL_HAVE__STATIC_ASSERT | 210 | #if 200410 <= __cpp_static_assert |
| 211 | # define _GL_VERIFY(R, DIAGNOSTIC, ...) static_assert (R, DIAGNOSTIC) | ||
| 212 | #elif defined _GL_HAVE__STATIC_ASSERT | ||
| 229 | # define _GL_VERIFY(R, DIAGNOSTIC, ...) _Static_assert (R, DIAGNOSTIC) | 213 | # define _GL_VERIFY(R, DIAGNOSTIC, ...) _Static_assert (R, DIAGNOSTIC) |
| 230 | #else | 214 | #else |
| 231 | # define _GL_VERIFY(R, DIAGNOSTIC, ...) \ | 215 | # define _GL_VERIFY(R, DIAGNOSTIC, ...) \ |
| @@ -239,7 +223,7 @@ template <int w> | |||
| 239 | # define _Static_assert(...) \ | 223 | # define _Static_assert(...) \ |
| 240 | _GL_VERIFY (__VA_ARGS__, "static assertion failed", -) | 224 | _GL_VERIFY (__VA_ARGS__, "static assertion failed", -) |
| 241 | # endif | 225 | # endif |
| 242 | # if !defined _GL_HAVE_STATIC_ASSERT1 && !defined static_assert | 226 | # if __cpp_static_assert < 201411 && !defined static_assert |
| 243 | # define static_assert _Static_assert /* C11 requires this #define. */ | 227 | # define static_assert _Static_assert /* C11 requires this #define. */ |
| 244 | # endif | 228 | # endif |
| 245 | #endif | 229 | #endif |
diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el index ea79bfa69a0..fda0b4bbedb 100644 --- a/lisp/calc/calc-embed.el +++ b/lisp/calc/calc-embed.el | |||
| @@ -651,6 +651,8 @@ The command \\[yank] can retrieve it from there." | |||
| 651 | (defvar calc-embed-prev-modes) | 651 | (defvar calc-embed-prev-modes) |
| 652 | 652 | ||
| 653 | (defun calc-embedded-set-modes (gmodes modes local-modes &optional temp) | 653 | (defun calc-embedded-set-modes (gmodes modes local-modes &optional temp) |
| 654 | (defvar the-language) | ||
| 655 | (defvar the-display-just) | ||
| 654 | (let ((the-language (calc-embedded-language)) | 656 | (let ((the-language (calc-embedded-language)) |
| 655 | (the-display-just (calc-embedded-justify)) | 657 | (the-display-just (calc-embedded-justify)) |
| 656 | (v gmodes) | 658 | (v gmodes) |
diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index b4b2d4cc4f4..0117f449dd5 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el | |||
| @@ -2181,7 +2181,7 @@ order to Calc's." | |||
| 2181 | v math-read-big-baseline)) | 2181 | v math-read-big-baseline)) |
| 2182 | 2182 | ||
| 2183 | ;; Small radical sign. | 2183 | ;; Small radical sign. |
| 2184 | ((and (= other-char ?V) | 2184 | ((and (memq other-char '(?V ?√)) |
| 2185 | (= (math-read-big-char (1+ math-rb-h1) (1- v)) ?\_)) | 2185 | (= (math-read-big-char (1+ math-rb-h1) (1- v)) ?\_)) |
| 2186 | (setq h (1+ math-rb-h1)) | 2186 | (setq h (1+ math-rb-h1)) |
| 2187 | (math-read-big-emptyp math-rb-h1 math-rb-v1 h (1- v) nil t) | 2187 | (math-read-big-emptyp math-rb-h1 math-rb-v1 h (1- v) nil t) |
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index d684c7ba97f..ec09abb34c4 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el | |||
| @@ -2144,7 +2144,7 @@ the United States." | |||
| 2144 | (let ((w (split-window nil (/ (* (window-width) 2) 3) t))) | 2144 | (let ((w (split-window nil (/ (* (window-width) 2) 3) t))) |
| 2145 | (set-window-buffer w calc-trail-buffer) | 2145 | (set-window-buffer w calc-trail-buffer) |
| 2146 | (and calc-make-windows-dedicated | 2146 | (and calc-make-windows-dedicated |
| 2147 | (set-window-dedicated-p nil t)))) | 2147 | (set-window-dedicated-p w t)))) |
| 2148 | (calc-wrapper | 2148 | (calc-wrapper |
| 2149 | (setq overlay-arrow-string calc-trail-overlay | 2149 | (setq overlay-arrow-string calc-trail-overlay |
| 2150 | overlay-arrow-position calc-trail-pointer) | 2150 | overlay-arrow-position calc-trail-pointer) |
diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index 07e70cad0a8..bd81d7fe406 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el | |||
| @@ -138,19 +138,19 @@ | |||
| 138 | (math-format-number (nth 2 aa)))))) | 138 | (math-format-number (nth 2 aa)))))) |
| 139 | (if (= calc-number-radix 10) | 139 | (if (= calc-number-radix 10) |
| 140 | c | 140 | c |
| 141 | (list 'horiz "(" c | 141 | (list 'subscr (math--comp-round-bracket c) |
| 142 | (list 'subscr ")" | 142 | (int-to-string calc-number-radix)))) |
| 143 | (int-to-string calc-number-radix))))) | ||
| 144 | (math-format-number a))) | 143 | (math-format-number a))) |
| 145 | (if (not (eq calc-language 'big)) | 144 | (if (not (eq calc-language 'big)) |
| 146 | (math-format-number a prec) | 145 | (math-format-number a prec) |
| 147 | (if (memq (car-safe a) '(cplx polar)) | 146 | (if (memq (car-safe a) '(cplx polar)) |
| 148 | (if (math-zerop (nth 2 a)) | 147 | (if (math-zerop (nth 2 a)) |
| 149 | (math-compose-expr (nth 1 a) prec) | 148 | (math-compose-expr (nth 1 a) prec) |
| 150 | (list 'horiz "(" | 149 | (math--comp-round-bracket |
| 151 | (math-compose-expr (nth 1 a) 0) | 150 | (list 'horiz |
| 152 | (if (eq (car a) 'cplx) ", " "; ") | 151 | (math-compose-expr (nth 1 a) 0) |
| 153 | (math-compose-expr (nth 2 a) 0) ")")) | 152 | (if (eq (car a) 'cplx) ", " "; ") |
| 153 | (math-compose-expr (nth 2 a) 0)))) | ||
| 154 | (if (or (= calc-number-radix 10) | 154 | (if (or (= calc-number-radix 10) |
| 155 | (not (Math-realp a)) | 155 | (not (Math-realp a)) |
| 156 | (and calc-group-digits | 156 | (and calc-group-digits |
| @@ -340,12 +340,13 @@ | |||
| 340 | (funcall spfn a prec) | 340 | (funcall spfn a prec) |
| 341 | (math-compose-var a))))) | 341 | (math-compose-var a))))) |
| 342 | ((eq (car a) 'intv) | 342 | ((eq (car a) 'intv) |
| 343 | (list 'horiz | 343 | (math--comp-bracket |
| 344 | (if (memq (nth 1 a) '(0 1)) "(" "[") | 344 | (if (memq (nth 1 a) '(0 1)) ?\( ?\[) |
| 345 | (math-compose-expr (nth 2 a) 0) | 345 | (if (memq (nth 1 a) '(0 2)) ?\) ?\]) |
| 346 | " .. " | 346 | (list 'horiz |
| 347 | (math-compose-expr (nth 3 a) 0) | 347 | (math-compose-expr (nth 2 a) 0) |
| 348 | (if (memq (nth 1 a) '(0 2)) ")" "]"))) | 348 | " .. " |
| 349 | (math-compose-expr (nth 3 a) 0)))) | ||
| 349 | ((eq (car a) 'date) | 350 | ((eq (car a) 'date) |
| 350 | (if (eq (car calc-date-format) 'X) | 351 | (if (eq (car calc-date-format) 'X) |
| 351 | (math-format-date a) | 352 | (math-format-date a) |
| @@ -377,7 +378,7 @@ | |||
| 377 | (and (eq (car-safe (nth 1 a)) 'cplx) | 378 | (and (eq (car-safe (nth 1 a)) 'cplx) |
| 378 | (math-negp (nth 1 (nth 1 a))) | 379 | (math-negp (nth 1 (nth 1 a))) |
| 379 | (eq (nth 2 (nth 1 a)) 0))) | 380 | (eq (nth 2 (nth 1 a)) 0))) |
| 380 | (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")") | 381 | (math--comp-round-bracket (math-compose-expr (nth 1 a) 0)) |
| 381 | (math-compose-expr (nth 1 a) 201)) | 382 | (math-compose-expr (nth 1 a) 201)) |
| 382 | (let ((calc-language 'flat) | 383 | (let ((calc-language 'flat) |
| 383 | (calc-number-radix 10) | 384 | (calc-number-radix 10) |
| @@ -444,7 +445,7 @@ | |||
| 444 | (if (> prec (nth 2 a)) | 445 | (if (> prec (nth 2 a)) |
| 445 | (if (setq spfn (get calc-language 'math-big-parens)) | 446 | (if (setq spfn (get calc-language 'math-big-parens)) |
| 446 | (list 'horiz (car spfn) c (cdr spfn)) | 447 | (list 'horiz (car spfn) c (cdr spfn)) |
| 447 | (list 'horiz "(" c ")")) | 448 | (math--comp-round-bracket c)) |
| 448 | c))) | 449 | c))) |
| 449 | ((and (eq (car a) 'calcFunc-choriz) | 450 | ((and (eq (car a) 'calcFunc-choriz) |
| 450 | (not (eq calc-language 'unform)) | 451 | (not (eq calc-language 'unform)) |
| @@ -612,7 +613,7 @@ | |||
| 612 | (list 'horiz "{left ( " | 613 | (list 'horiz "{left ( " |
| 613 | (math-compose-expr a -1) | 614 | (math-compose-expr a -1) |
| 614 | " right )}"))) | 615 | " right )}"))) |
| 615 | (list 'horiz "(" (math-compose-expr a 0) ")")))) | 616 | (math--comp-round-bracket (math-compose-expr a 0))))) |
| 616 | ((and (memq calc-language '(tex latex)) | 617 | ((and (memq calc-language '(tex latex)) |
| 617 | (memq (car a) '(/ calcFunc-choose calcFunc-evalto)) | 618 | (memq (car a) '(/ calcFunc-choose calcFunc-evalto)) |
| 618 | (>= prec 0)) | 619 | (>= prec 0)) |
| @@ -638,7 +639,7 @@ | |||
| 638 | (rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1 op) '/)))) | 639 | (rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1 op) '/)))) |
| 639 | (and (equal (car op) "^") | 640 | (and (equal (car op) "^") |
| 640 | (eq (math-comp-first-char lhs) ?-) | 641 | (eq (math-comp-first-char lhs) ?-) |
| 641 | (setq lhs (list 'horiz "(" lhs ")"))) | 642 | (setq lhs (math--comp-round-bracket lhs))) |
| 642 | (and (memq calc-language '(tex latex)) | 643 | (and (memq calc-language '(tex latex)) |
| 643 | (or (equal (car op) "^") (equal (car op) "_")) | 644 | (or (equal (car op) "^") (equal (car op) "_")) |
| 644 | (not (and (stringp rhs) (= (length rhs) 1))) | 645 | (not (and (stringp rhs) (= (length rhs) 1))) |
| @@ -721,7 +722,7 @@ | |||
| 721 | (list 'horiz "{left ( " | 722 | (list 'horiz "{left ( " |
| 722 | (math-compose-expr a -1) | 723 | (math-compose-expr a -1) |
| 723 | " right )}"))) | 724 | " right )}"))) |
| 724 | (list 'horiz "(" (math-compose-expr a 0) ")")))) | 725 | (math--comp-round-bracket (math-compose-expr a 0))))) |
| 725 | (t | 726 | (t |
| 726 | (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op)))) | 727 | (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op)))) |
| 727 | (list 'horiz | 728 | (list 'horiz |
| @@ -759,7 +760,7 @@ | |||
| 759 | (list 'horiz "{left ( " | 760 | (list 'horiz "{left ( " |
| 760 | (math-compose-expr a -1) | 761 | (math-compose-expr a -1) |
| 761 | " right )}"))) | 762 | " right )}"))) |
| 762 | (list 'horiz "(" (math-compose-expr a 0) ")")))) | 763 | (math--comp-round-bracket (math-compose-expr a 0))))) |
| 763 | (t | 764 | (t |
| 764 | (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op)))) | 765 | (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op)))) |
| 765 | (list 'horiz | 766 | (list 'horiz |
| @@ -821,9 +822,16 @@ | |||
| 821 | (if (setq spfn (get calc-language 'math-func-formatter)) | 822 | (if (setq spfn (get calc-language 'math-func-formatter)) |
| 822 | (funcall spfn func a) | 823 | (funcall spfn func a) |
| 823 | 824 | ||
| 824 | (list 'horiz func calc-function-open | 825 | (let ((args (math-compose-vector (cdr a) ", " 0))) |
| 825 | (math-compose-vector (cdr a) ", " 0) | 826 | (if (and (member calc-function-open '("(" "[" "{")) |
| 826 | calc-function-close)))))))))) | 827 | (member calc-function-close '(")" "]" "}"))) |
| 828 | (list 'horiz func | ||
| 829 | (math--comp-bracket | ||
| 830 | (string-to-char calc-function-open) | ||
| 831 | (string-to-char calc-function-close) | ||
| 832 | args)) | ||
| 833 | (list 'horiz func calc-function-open | ||
| 834 | args calc-function-close)))))))))))) | ||
| 827 | 835 | ||
| 828 | 836 | ||
| 829 | (defun math-prod-first-term (x) | 837 | (defun math-prod-first-term (x) |
| @@ -966,6 +974,69 @@ | |||
| 966 | (and (memq (car a) '(^ calcFunc-subscr)) | 974 | (and (memq (car a) '(^ calcFunc-subscr)) |
| 967 | (math-tex-expr-is-flat (nth 1 a))))) | 975 | (math-tex-expr-is-flat (nth 1 a))))) |
| 968 | 976 | ||
| 977 | ;; FIXME: maybe try box drawing chars if big bracket chars are unavailable, | ||
| 978 | ;; like ┌ ┐n | ||
| 979 | ;; │a + b│ ┌ a + b ┐n | ||
| 980 | ;; │-----│ or │ ----- │ ? | ||
| 981 | ;; │ c │ └ c ┘ | ||
| 982 | ;; └ ┘ | ||
| 983 | ;; They are more common than the chars below, but look a bit square. | ||
| 984 | ;; Rounded corners exist but are less commonly available. | ||
| 985 | |||
| 986 | (defconst math--big-bracket-alist | ||
| 987 | '((?\( . (?⎛ ?⎝ ?⎜)) | ||
| 988 | (?\) . (?⎞ ?⎠ ?⎟)) | ||
| 989 | (?\[ . (?⎡ ?⎣ ?⎢)) | ||
| 990 | (?\] . (?⎤ ?⎦ ?⎥)) | ||
| 991 | (?\{ . (?⎧ ?⎩ ?⎪ ?⎨)) | ||
| 992 | (?\} . (?⎫ ?⎭ ?⎪ ?⎬))) | ||
| 993 | "Alist mapping bracket chars to (UPPER LOWER EXTENSION MIDPIECE). | ||
| 994 | Not all brackets have midpieces.") | ||
| 995 | |||
| 996 | (defun math--big-bracket (bracket-char height baseline) | ||
| 997 | "Composition for BRACKET-CHAR of HEIGHT with BASELINE." | ||
| 998 | (if (<= height 1) | ||
| 999 | (char-to-string bracket-char) | ||
| 1000 | (let ((pieces (cdr (assq bracket-char math--big-bracket-alist)))) | ||
| 1001 | (if (memq nil (mapcar #'char-displayable-p pieces)) | ||
| 1002 | (char-to-string bracket-char) | ||
| 1003 | (let* ((upper (nth 0 pieces)) | ||
| 1004 | (lower (nth 1 pieces)) | ||
| 1005 | (extension (nth 2 pieces)) | ||
| 1006 | (midpiece (nth 3 pieces))) | ||
| 1007 | (cons 'vleft ; alignment doesn't matter; width is 1 char | ||
| 1008 | (cons baseline | ||
| 1009 | (mapcar | ||
| 1010 | #'char-to-string | ||
| 1011 | (append | ||
| 1012 | (list upper) | ||
| 1013 | (if midpiece | ||
| 1014 | (let ((lower-ext (/ (- height 3) 2))) | ||
| 1015 | (append | ||
| 1016 | (make-list (- height 3 lower-ext) extension) | ||
| 1017 | (list midpiece) | ||
| 1018 | (make-list lower-ext extension))) | ||
| 1019 | (make-list (- height 2) extension)) | ||
| 1020 | (list lower)))))))))) | ||
| 1021 | |||
| 1022 | (defun math--comp-bracket (left-bracket right-bracket comp) | ||
| 1023 | "Put the composition COMP inside LEFT-BRACKET and RIGHT-BRACKET." | ||
| 1024 | (if (eq calc-language 'big) | ||
| 1025 | (let ((height (math-comp-height comp)) | ||
| 1026 | (baseline (1- (math-comp-ascent comp)))) | ||
| 1027 | (list 'horiz | ||
| 1028 | (math--big-bracket left-bracket height baseline) | ||
| 1029 | comp | ||
| 1030 | (math--big-bracket right-bracket height baseline))) | ||
| 1031 | (list 'horiz | ||
| 1032 | (char-to-string left-bracket) | ||
| 1033 | comp | ||
| 1034 | (char-to-string right-bracket)))) | ||
| 1035 | |||
| 1036 | (defun math--comp-round-bracket (comp) | ||
| 1037 | "Put the composition COMP inside plain brackets." | ||
| 1038 | (math--comp-bracket ?\( ?\) comp)) | ||
| 1039 | |||
| 969 | (put 'calcFunc-log 'math-compose-big #'math-compose-log) | 1040 | (put 'calcFunc-log 'math-compose-big #'math-compose-log) |
| 970 | (defun math-compose-log (a _prec) | 1041 | (defun math-compose-log (a _prec) |
| 971 | (and (= (length a) 3) | 1042 | (and (= (length a) 3) |
| @@ -973,18 +1044,14 @@ | |||
| 973 | (list 'subscr "log" | 1044 | (list 'subscr "log" |
| 974 | (let ((calc-language 'flat)) | 1045 | (let ((calc-language 'flat)) |
| 975 | (math-compose-expr (nth 2 a) 1000))) | 1046 | (math-compose-expr (nth 2 a) 1000))) |
| 976 | "(" | 1047 | (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000))))) |
| 977 | (math-compose-expr (nth 1 a) 1000) | ||
| 978 | ")"))) | ||
| 979 | 1048 | ||
| 980 | (put 'calcFunc-log10 'math-compose-big #'math-compose-log10) | 1049 | (put 'calcFunc-log10 'math-compose-big #'math-compose-log10) |
| 981 | (defun math-compose-log10 (a _prec) | 1050 | (defun math-compose-log10 (a _prec) |
| 982 | (and (= (length a) 2) | 1051 | (and (= (length a) 2) |
| 983 | (list 'horiz | 1052 | (list 'horiz |
| 984 | (list 'subscr "log" "10") | 1053 | (list 'subscr "log" "10") |
| 985 | "(" | 1054 | (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000))))) |
| 986 | (math-compose-expr (nth 1 a) 1000) | ||
| 987 | ")"))) | ||
| 988 | 1055 | ||
| 989 | (put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv) | 1056 | (put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv) |
| 990 | (put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv) | 1057 | (put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv) |
| @@ -1027,12 +1094,9 @@ | |||
| 1027 | (defun math-compose-choose (a _prec) | 1094 | (defun math-compose-choose (a _prec) |
| 1028 | (let ((a1 (math-compose-expr (nth 1 a) 0)) | 1095 | (let ((a1 (math-compose-expr (nth 1 a) 0)) |
| 1029 | (a2 (math-compose-expr (nth 2 a) 0))) | 1096 | (a2 (math-compose-expr (nth 2 a) 0))) |
| 1030 | (list 'horiz | 1097 | (math--comp-round-bracket (list 'vcent |
| 1031 | "(" | 1098 | (+ (math-comp-height a1)) |
| 1032 | (list 'vcent | 1099 | a1 " " a2)))) |
| 1033 | (math-comp-height a1) | ||
| 1034 | a1 " " a2) | ||
| 1035 | ")"))) | ||
| 1036 | 1100 | ||
| 1037 | (put 'calcFunc-integ 'math-compose-big #'math-compose-integ) | 1101 | (put 'calcFunc-integ 'math-compose-big #'math-compose-integ) |
| 1038 | (defun math-compose-integ (a prec) | 1102 | (defun math-compose-integ (a prec) |
| @@ -1052,9 +1116,12 @@ | |||
| 1052 | "d%s" | 1116 | "d%s" |
| 1053 | (nth 1 (nth 2 a))))) | 1117 | (nth 1 (nth 2 a))))) |
| 1054 | (nth 1 a)) 185)) | 1118 | (nth 1 a)) 185)) |
| 1055 | (calc-language 'flat) | 1119 | (low (and (nth 3 a) |
| 1056 | (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) | 1120 | (let ((calc-language 'flat)) |
| 1057 | (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))) | 1121 | (math-compose-expr (nth 3 a) 0)))) |
| 1122 | (high (and (nth 4 a) | ||
| 1123 | (let ((calc-language 'flat)) | ||
| 1124 | (math-compose-expr (nth 4 a) 0)))) | ||
| 1058 | ;; Check if we have Unicode integral top/bottom parts. | 1125 | ;; Check if we have Unicode integral top/bottom parts. |
| 1059 | (fancy (and (char-displayable-p ?⌠) | 1126 | (fancy (and (char-displayable-p ?⌠) |
| 1060 | (char-displayable-p ?⌡))) | 1127 | (char-displayable-p ?⌡))) |
| @@ -1066,40 +1133,47 @@ | |||
| 1066 | ((char-displayable-p ?│) "│ ") | 1133 | ((char-displayable-p ?│) "│ ") |
| 1067 | ;; U+007C VERTICAL LINE | 1134 | ;; U+007C VERTICAL LINE |
| 1068 | (t "| ")))) | 1135 | (t "| ")))) |
| 1069 | (list 'horiz | 1136 | (let ((comp |
| 1070 | (if parens "(" "") | 1137 | (list 'horiz |
| 1071 | (append (list 'vcent (if fancy | 1138 | (append (list 'vcent (if fancy |
| 1072 | (if high 2 1) | 1139 | (if high 2 1) |
| 1073 | (if high 3 2))) | 1140 | (if high 3 2))) |
| 1074 | (and high (list (if fancy | 1141 | (and high (list (if fancy |
| 1075 | (list 'horiz high " ") | 1142 | (list 'horiz high " ") |
| 1076 | (list 'horiz " " high)))) | 1143 | (list 'horiz " " high)))) |
| 1077 | (if fancy | 1144 | (if fancy |
| 1078 | (list "⌠ " fancy-stem "⌡ ") | 1145 | (list "⌠ " fancy-stem "⌡ ") |
| 1079 | '(" /" | 1146 | '(" /" |
| 1080 | " | " | 1147 | " | " |
| 1081 | " | " | 1148 | " | " |
| 1082 | " | " | 1149 | " | " |
| 1083 | "/ ")) | 1150 | "/ ")) |
| 1084 | (and low (list (if fancy | 1151 | (and low (list (if fancy |
| 1085 | (list 'horiz low " ") | 1152 | (list 'horiz low " ") |
| 1086 | (list 'horiz low " "))))) | 1153 | (list 'horiz low " "))))) |
| 1087 | expr | 1154 | expr |
| 1088 | (if over | 1155 | (if over |
| 1089 | "" | 1156 | "" |
| 1090 | (list 'horiz " d" var)) | 1157 | (list 'horiz " d" var))))) |
| 1091 | (if parens ")" ""))))) | 1158 | (if parens |
| 1159 | (math--comp-round-bracket comp) | ||
| 1160 | comp))))) | ||
| 1092 | 1161 | ||
| 1093 | (put 'calcFunc-sum 'math-compose-big #'math-compose-sum) | 1162 | (put 'calcFunc-sum 'math-compose-big #'math-compose-sum) |
| 1094 | (defun math-compose-sum (a prec) | 1163 | (defun math-compose-sum (a prec) |
| 1095 | (and (memq (length a) '(3 5 6)) | 1164 | (and (memq (length a) '(3 5 6)) |
| 1096 | (let* ((expr (math-compose-expr (nth 1 a) 185)) | 1165 | (let* ((expr (math-compose-expr (nth 1 a) 185)) |
| 1097 | (calc-language 'flat) | 1166 | (var |
| 1098 | (var (math-compose-expr (nth 2 a) 0)) | 1167 | (let ((calc-language 'flat)) |
| 1099 | (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) | 1168 | (math-compose-expr (nth 2 a) 0))) |
| 1100 | (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) | 1169 | (low (and (nth 3 a) |
| 1101 | (list 'horiz | 1170 | (let ((calc-language 'flat)) |
| 1102 | (if (memq prec '(180 201)) "(" "") | 1171 | (math-compose-expr (nth 3 a) 0)))) |
| 1172 | (high (and (nth 4 a) | ||
| 1173 | (let ((calc-language 'flat)) | ||
| 1174 | (math-compose-vector (nthcdr 4 a) ", " 0)))) | ||
| 1175 | (comp | ||
| 1176 | (list 'horiz | ||
| 1103 | (append (list 'vcent (if high 3 2)) | 1177 | (append (list 'vcent (if high 3 2)) |
| 1104 | (and high (list high)) | 1178 | (and high (list high)) |
| 1105 | '("---- " | 1179 | '("---- " |
| @@ -1112,32 +1186,42 @@ | |||
| 1112 | (list var))) | 1186 | (list var))) |
| 1113 | (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) | 1187 | (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) |
| 1114 | " " "") | 1188 | " " "") |
| 1115 | expr | 1189 | expr))) |
| 1116 | (if (memq prec '(180 201)) ")" ""))))) | 1190 | (if (memq prec '(180 201)) |
| 1191 | (math--comp-round-bracket comp) | ||
| 1192 | comp)))) | ||
| 1117 | 1193 | ||
| 1118 | (put 'calcFunc-prod 'math-compose-big #'math-compose-prod) | 1194 | (put 'calcFunc-prod 'math-compose-big #'math-compose-prod) |
| 1119 | (defun math-compose-prod (a prec) | 1195 | (defun math-compose-prod (a prec) |
| 1120 | (and (memq (length a) '(3 5 6)) | 1196 | (and (memq (length a) '(3 5 6)) |
| 1121 | (let* ((expr (math-compose-expr (nth 1 a) 198)) | 1197 | (let* ((expr (math-compose-expr (nth 1 a) 198)) |
| 1122 | (calc-language 'flat) | 1198 | (var |
| 1123 | (var (math-compose-expr (nth 2 a) 0)) | 1199 | (let ((calc-language 'flat)) |
| 1124 | (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) | 1200 | (math-compose-expr (nth 2 a) 0))) |
| 1125 | (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) | 1201 | (low (and (nth 3 a) |
| 1126 | (list 'horiz | 1202 | (let ((calc-language 'flat)) |
| 1127 | (if (memq prec '(196 201)) "(" "") | 1203 | (math-compose-expr (nth 3 a) 0)))) |
| 1128 | (append (list 'vcent (if high 3 2)) | 1204 | (high (and (nth 4 a) |
| 1129 | (and high (list high)) | 1205 | (let ((calc-language 'flat)) |
| 1130 | '("----- " | 1206 | (math-compose-vector (nthcdr 4 a) ", " 0)))) |
| 1131 | " | | " | 1207 | (comp |
| 1132 | " | | " | 1208 | (list 'horiz |
| 1133 | " | | ") | 1209 | (append (list 'vcent (if high 3 2)) |
| 1134 | (if low | 1210 | (and high (list high)) |
| 1135 | (list (list 'horiz var " = " low)) | 1211 | '("----- " |
| 1136 | (list var))) | 1212 | " | | " |
| 1137 | (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) | 1213 | " | | " |
| 1138 | " " "") | 1214 | " | | ") |
| 1139 | expr | 1215 | (if low |
| 1140 | (if (memq prec '(196 201)) ")" ""))))) | 1216 | (list (list 'horiz var " = " low)) |
| 1217 | (list var))) | ||
| 1218 | (if (memq (car-safe (nth 1 a)) | ||
| 1219 | '(calcFunc-sum calcFunc-prod)) | ||
| 1220 | " " "") | ||
| 1221 | expr))) | ||
| 1222 | (if (memq prec '(196 201)) | ||
| 1223 | (math--comp-round-bracket comp) | ||
| 1224 | comp)))) | ||
| 1141 | 1225 | ||
| 1142 | ;; The variables math-svo-c, math-svo-wid and math-svo-off are local | 1226 | ;; The variables math-svo-c, math-svo-wid and math-svo-off are local |
| 1143 | ;; to math-stack-value-offset in calc.el, but are used by | 1227 | ;; to math-stack-value-offset in calc.el, but are used by |
diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index 22e4cdbcd52..c2e4205c0bc 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. | 1 | ;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -124,9 +124,10 @@ Defaults to today's date if DATE is not given." | |||
| 124 | (y (calendar-extract-year bahai-date))) | 124 | (y (calendar-extract-year bahai-date))) |
| 125 | (if (< y 1) | 125 | (if (< y 1) |
| 126 | "" ; pre-Bahai | 126 | "" ; pre-Bahai |
| 127 | (let* ((m (calendar-extract-month bahai-date)) | 127 | (let ((m (calendar-extract-month bahai-date)) |
| 128 | (d (calendar-extract-day bahai-date)) | 128 | (d (calendar-extract-day bahai-date))) |
| 129 | (monthname (if (and (= m 19) | 129 | (calendar-dlet* |
| 130 | ((monthname (if (and (= m 19) | ||
| 130 | (<= d 0)) | 131 | (<= d 0)) |
| 131 | "Ayyám-i-Há" | 132 | "Ayyám-i-Há" |
| 132 | (aref calendar-bahai-month-name-array (1- m)))) | 133 | (aref calendar-bahai-month-name-array (1- m)))) |
| @@ -137,8 +138,8 @@ Defaults to today's date if DATE is not given." | |||
| 137 | (year (number-to-string y)) | 138 | (year (number-to-string y)) |
| 138 | (month (number-to-string m)) | 139 | (month (number-to-string m)) |
| 139 | dayname) | 140 | dayname) |
| 140 | ;; Can't call calendar-date-string because of monthname oddity. | 141 | ;; Can't call calendar-date-string because of monthname oddity. |
| 141 | (mapconcat 'eval calendar-date-display-form ""))))) | 142 | (mapconcat #'eval calendar-date-display-form "")))))) |
| 142 | 143 | ||
| 143 | ;;;###cal-autoload | 144 | ;;;###cal-autoload |
| 144 | (defun calendar-bahai-print-date () | 145 | (defun calendar-bahai-print-date () |
| @@ -153,13 +154,12 @@ Defaults to today's date if DATE is not given." | |||
| 153 | "Interactively read the arguments for a Bahá’í date command. | 154 | "Interactively read the arguments for a Bahá’í date command. |
| 154 | Reads a year, month and day." | 155 | Reads a year, month and day." |
| 155 | (let* ((today (calendar-current-date)) | 156 | (let* ((today (calendar-current-date)) |
| 156 | (year (calendar-read | 157 | (year (calendar-read-sexp |
| 157 | "Bahá’í calendar year (not 0): " | 158 | "Bahá’í calendar year (not 0)" |
| 158 | (lambda (x) (not (zerop x))) | 159 | (lambda (x) (not (zerop x))) |
| 159 | (number-to-string | 160 | (calendar-extract-year |
| 160 | (calendar-extract-year | 161 | (calendar-bahai-from-absolute |
| 161 | (calendar-bahai-from-absolute | 162 | (calendar-absolute-from-gregorian today))))) |
| 162 | (calendar-absolute-from-gregorian today)))))) | ||
| 163 | (completion-ignore-case t) | 163 | (completion-ignore-case t) |
| 164 | (month (cdr (assoc | 164 | (month (cdr (assoc |
| 165 | (completing-read | 165 | (completing-read |
| @@ -169,8 +169,8 @@ Reads a year, month and day." | |||
| 169 | nil t) | 169 | nil t) |
| 170 | (calendar-make-alist calendar-bahai-month-name-array | 170 | (calendar-make-alist calendar-bahai-month-name-array |
| 171 | 1)))) | 171 | 1)))) |
| 172 | (day (calendar-read "Bahá’í calendar day (1-19): " | 172 | (day (calendar-read-sexp "Bahá’í calendar day (1-19)" |
| 173 | (lambda (x) (and (< 0 x) (<= x 19)))))) | 173 | (lambda (x) (and (< 0 x) (<= x 19)))))) |
| 174 | (list (list month day year)))) | 174 | (list (list month day year)))) |
| 175 | 175 | ||
| 176 | ;;;###cal-autoload | 176 | ;;;###cal-autoload |
diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index 7e5d0c46e11..9a28984a7ab 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-china.el --- calendar functions for the Chinese calendar | 1 | ;;; cal-china.el --- calendar functions for the Chinese calendar -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -185,7 +185,9 @@ N congruent to 1 gives the first name, N congruent to 2 gives the second name, | |||
| 185 | (defun calendar-chinese-zodiac-sign-on-or-after (d) | 185 | (defun calendar-chinese-zodiac-sign-on-or-after (d) |
| 186 | "Absolute date of first new Zodiac sign on or after absolute date D. | 186 | "Absolute date of first new Zodiac sign on or after absolute date D. |
| 187 | The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." | 187 | The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." |
| 188 | (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) | 188 | (with-suppressed-warnings ((lexical year)) |
| 189 | (defvar year)) | ||
| 190 | (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) | ||
| 189 | (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year | 191 | (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year |
| 190 | (calendar-daylight-time-offset | 192 | (calendar-daylight-time-offset |
| 191 | calendar-chinese-daylight-time-offset) | 193 | calendar-chinese-daylight-time-offset) |
| @@ -207,6 +209,8 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." | |||
| 207 | 209 | ||
| 208 | (defun calendar-chinese-new-moon-on-or-after (d) | 210 | (defun calendar-chinese-new-moon-on-or-after (d) |
| 209 | "Absolute date of first new moon on or after absolute date D." | 211 | "Absolute date of first new moon on or after absolute date D." |
| 212 | (with-suppressed-warnings ((lexical year)) | ||
| 213 | (defvar year)) | ||
| 210 | (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) | 214 | (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) |
| 211 | (calendar-time-zone (eval calendar-chinese-time-zone)) | 215 | (calendar-time-zone (eval calendar-chinese-time-zone)) |
| 212 | (calendar-daylight-time-offset | 216 | (calendar-daylight-time-offset |
| @@ -602,14 +606,14 @@ Echo Chinese date unless NOECHO is non-nil." | |||
| 602 | (interactive | 606 | (interactive |
| 603 | (let* ((c (calendar-chinese-from-absolute | 607 | (let* ((c (calendar-chinese-from-absolute |
| 604 | (calendar-absolute-from-gregorian (calendar-current-date)))) | 608 | (calendar-absolute-from-gregorian (calendar-current-date)))) |
| 605 | (cycle (calendar-read | 609 | (cycle (calendar-read-sexp |
| 606 | "Chinese calendar cycle number (>44): " | 610 | "Chinese calendar cycle number (>44)" |
| 607 | (lambda (x) (> x 44)) | 611 | (lambda (x) (> x 44)) |
| 608 | (number-to-string (car c)))) | 612 | (car c))) |
| 609 | (year (calendar-read | 613 | (year (calendar-read-sexp |
| 610 | "Year in Chinese cycle (1..60): " | 614 | "Year in Chinese cycle (1..60)" |
| 611 | (lambda (x) (and (<= 1 x) (<= x 60))) | 615 | (lambda (x) (and (<= 1 x) (<= x 60))) |
| 612 | (number-to-string (cadr c)))) | 616 | (cadr c))) |
| 613 | (month-list (calendar-chinese-months-to-alist | 617 | (month-list (calendar-chinese-months-to-alist |
| 614 | (calendar-chinese-months cycle year))) | 618 | (calendar-chinese-months cycle year))) |
| 615 | (month (cdr (assoc | 619 | (month (cdr (assoc |
| @@ -624,9 +628,11 @@ Echo Chinese date unless NOECHO is non-nil." | |||
| 624 | (list cycle year month 1)))))) | 628 | (list cycle year month 1)))))) |
| 625 | 30 | 629 | 30 |
| 626 | 29)) | 630 | 29)) |
| 627 | (day (calendar-read | 631 | (day (calendar-read-sexp |
| 628 | (format "Chinese calendar day (1-%d): " last) | 632 | "Chinese calendar day (1-%d)" |
| 629 | (lambda (x) (and (<= 1 x) (<= x last)))))) | 633 | (lambda (x) (and (<= 1 x) (<= x last))) |
| 634 | nil | ||
| 635 | last))) | ||
| 630 | (list (list cycle year month day)))) | 636 | (list (list cycle year month day)))) |
| 631 | (calendar-goto-date (calendar-gregorian-from-absolute | 637 | (calendar-goto-date (calendar-gregorian-from-absolute |
| 632 | (calendar-chinese-to-absolute date))) | 638 | (calendar-chinese-to-absolute date))) |
| @@ -663,17 +669,17 @@ Echo Chinese date unless NOECHO is non-nil." | |||
| 663 | ["正月" "二月" "三月" "四月" "五月" "六月" | 669 | ["正月" "二月" "三月" "四月" "五月" "六月" |
| 664 | "七月" "八月" "九月" "十月" "冬月" "臘月"]) | 670 | "七月" "八月" "九月" "十月" "冬月" "臘月"]) |
| 665 | 671 | ||
| 666 | ;;; NOTE: In the diary the cycle and year of a Chinese date is | 672 | ;; NOTE: In the diary the cycle and year of a Chinese date is |
| 667 | ;;; combined using this formula: (+ (* cycle 100) year). | 673 | ;; combined using this formula: (+ (* cycle 100) year). |
| 668 | ;;; | 674 | ;;; |
| 669 | ;;; These two functions convert to and back from this representation. | 675 | ;; These two functions convert to and back from this representation. |
| 670 | (defun calendar-chinese-from-absolute-for-diary (date) | 676 | (defun calendar-chinese-from-absolute-for-diary (thedate) |
| 671 | (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date))) | 677 | (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute thedate))) |
| 672 | ;; Note: For leap months M is a float. | 678 | ;; Note: For leap months M is a float. |
| 673 | (list (floor m) d (+ (* c 100) y)))) | 679 | (list (floor m) d (+ (* c 100) y)))) |
| 674 | 680 | ||
| 675 | (defun calendar-chinese-to-absolute-for-diary (date &optional prefer-leap) | 681 | (defun calendar-chinese-to-absolute-for-diary (thedate &optional prefer-leap) |
| 676 | (pcase-let* ((`(,m ,d ,y) date) | 682 | (pcase-let* ((`(,m ,d ,y) thedate) |
| 677 | (cycle (floor y 100)) | 683 | (cycle (floor y 100)) |
| 678 | (year (mod y 100)) | 684 | (year (mod y 100)) |
| 679 | (months (calendar-chinese-months cycle year)) | 685 | (months (calendar-chinese-months cycle year)) |
| @@ -691,7 +697,8 @@ Echo Chinese date unless NOECHO is non-nil." | |||
| 691 | (unless (zerop month) | 697 | (unless (zerop month) |
| 692 | (calendar-mark-1 month day year | 698 | (calendar-mark-1 month day year |
| 693 | #'calendar-chinese-from-absolute-for-diary | 699 | #'calendar-chinese-from-absolute-for-diary |
| 694 | (lambda (date) (calendar-chinese-to-absolute-for-diary date t)) | 700 | (lambda (thedate) |
| 701 | (calendar-chinese-to-absolute-for-diary thedate t)) | ||
| 695 | color))) | 702 | color))) |
| 696 | 703 | ||
| 697 | ;;;###cal-autoload | 704 | ;;;###cal-autoload |
diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el index 3461f3259b9..346585e1817 100644 --- a/lisp/calendar/cal-coptic.el +++ b/lisp/calendar/cal-coptic.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars | 1 | ;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -116,12 +116,13 @@ Defaults to today's date if DATE is not given." | |||
| 116 | (m (calendar-extract-month coptic-date))) | 116 | (m (calendar-extract-month coptic-date))) |
| 117 | (if (< y 1) | 117 | (if (< y 1) |
| 118 | "" | 118 | "" |
| 119 | (let ((monthname (aref calendar-coptic-month-name-array (1- m))) | 119 | (calendar-dlet* |
| 120 | (day (number-to-string (calendar-extract-day coptic-date))) | 120 | ((monthname (aref calendar-coptic-month-name-array (1- m))) |
| 121 | (dayname nil) | 121 | (day (number-to-string (calendar-extract-day coptic-date))) |
| 122 | (month (number-to-string m)) | 122 | (dayname nil) |
| 123 | (year (number-to-string y))) | 123 | (month (number-to-string m)) |
| 124 | (mapconcat 'eval calendar-date-display-form ""))))) | 124 | (year (number-to-string y))) |
| 125 | (mapconcat #'eval calendar-date-display-form ""))))) | ||
| 125 | 126 | ||
| 126 | ;;;###cal-autoload | 127 | ;;;###cal-autoload |
| 127 | (defun calendar-coptic-print-date () | 128 | (defun calendar-coptic-print-date () |
| @@ -136,13 +137,13 @@ Defaults to today's date if DATE is not given." | |||
| 136 | "Interactively read the arguments for a Coptic date command. | 137 | "Interactively read the arguments for a Coptic date command. |
| 137 | Reads a year, month, and day." | 138 | Reads a year, month, and day." |
| 138 | (let* ((today (calendar-current-date)) | 139 | (let* ((today (calendar-current-date)) |
| 139 | (year (calendar-read | 140 | (year (calendar-read-sexp |
| 140 | (format "%s calendar year (>0): " calendar-coptic-name) | 141 | "%s calendar year (>0)" |
| 141 | (lambda (x) (> x 0)) | 142 | (lambda (x) (> x 0)) |
| 142 | (number-to-string | 143 | (calendar-extract-year |
| 143 | (calendar-extract-year | 144 | (calendar-coptic-from-absolute |
| 144 | (calendar-coptic-from-absolute | 145 | (calendar-absolute-from-gregorian today))) |
| 145 | (calendar-absolute-from-gregorian today)))))) | 146 | calendar-coptic-name)) |
| 146 | (completion-ignore-case t) | 147 | (completion-ignore-case t) |
| 147 | (month (cdr (assoc-string | 148 | (month (cdr (assoc-string |
| 148 | (completing-read | 149 | (completing-read |
| @@ -151,11 +152,14 @@ Reads a year, month, and day." | |||
| 151 | (append calendar-coptic-month-name-array nil)) | 152 | (append calendar-coptic-month-name-array nil)) |
| 152 | nil t) | 153 | nil t) |
| 153 | (calendar-make-alist calendar-coptic-month-name-array | 154 | (calendar-make-alist calendar-coptic-month-name-array |
| 154 | 1) t))) | 155 | 1) |
| 156 | t))) | ||
| 155 | (last (calendar-coptic-last-day-of-month month year)) | 157 | (last (calendar-coptic-last-day-of-month month year)) |
| 156 | (day (calendar-read | 158 | (day (calendar-read-sexp |
| 157 | (format "%s calendar day (1-%d): " calendar-coptic-name last) | 159 | "%s calendar day (1-%d)" |
| 158 | (lambda (x) (and (< 0 x) (<= x last)))))) | 160 | (lambda (x) (and (< 0 x) (<= x last))) |
| 161 | nil | ||
| 162 | calendar-coptic-name last))) | ||
| 159 | (list (list month day year)))) | 163 | (list (list month day year)))) |
| 160 | 164 | ||
| 161 | ;;;###cal-autoload | 165 | ;;;###cal-autoload |
| @@ -194,30 +198,30 @@ Echo Coptic date unless NOECHO is t." | |||
| 194 | (defconst calendar-ethiopic-name "Ethiopic" | 198 | (defconst calendar-ethiopic-name "Ethiopic" |
| 195 | "Used in some message strings.") | 199 | "Used in some message strings.") |
| 196 | 200 | ||
| 197 | (defun calendar-ethiopic-to-absolute (date) | 201 | (defun calendar-ethiopic-to-absolute (thedate) |
| 198 | "Compute absolute date from Ethiopic date DATE. | 202 | "Compute absolute date from Ethiopic date DATE. |
| 199 | The absolute date is the number of days elapsed since the (imaginary) | 203 | The absolute date is the number of days elapsed since the (imaginary) |
| 200 | Gregorian date Sunday, December 31, 1 BC." | 204 | Gregorian date Sunday, December 31, 1 BC." |
| 201 | (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) | 205 | (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) |
| 202 | (calendar-coptic-to-absolute date))) | 206 | (calendar-coptic-to-absolute thedate))) |
| 203 | 207 | ||
| 204 | (defun calendar-ethiopic-from-absolute (date) | 208 | (defun calendar-ethiopic-from-absolute (thedate) |
| 205 | "Compute the Ethiopic equivalent for absolute date DATE. | 209 | "Compute the Ethiopic equivalent for absolute date DATE. |
| 206 | The result is a list of the form (MONTH DAY YEAR). | 210 | The result is a list of the form (MONTH DAY YEAR). |
| 207 | The absolute date is the number of days elapsed since the imaginary | 211 | The absolute date is the number of days elapsed since the imaginary |
| 208 | Gregorian date Sunday, December 31, 1 BC." | 212 | Gregorian date Sunday, December 31, 1 BC." |
| 209 | (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) | 213 | (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) |
| 210 | (calendar-coptic-from-absolute date))) | 214 | (calendar-coptic-from-absolute thedate))) |
| 211 | 215 | ||
| 212 | ;;;###cal-autoload | 216 | ;;;###cal-autoload |
| 213 | (defun calendar-ethiopic-date-string (&optional date) | 217 | (defun calendar-ethiopic-date-string (&optional thedate) |
| 214 | "String of Ethiopic date of Gregorian DATE. | 218 | "String of Ethiopic date of Gregorian DATE. |
| 215 | Returns the empty string if DATE is pre-Ethiopic calendar. | 219 | Returns the empty string if DATE is pre-Ethiopic calendar. |
| 216 | Defaults to today's date if DATE is not given." | 220 | Defaults to today's date if DATE is not given." |
| 217 | (let ((calendar-coptic-epoch calendar-ethiopic-epoch) | 221 | (let ((calendar-coptic-epoch calendar-ethiopic-epoch) |
| 218 | (calendar-coptic-name calendar-ethiopic-name) | 222 | (calendar-coptic-name calendar-ethiopic-name) |
| 219 | (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) | 223 | (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) |
| 220 | (calendar-coptic-date-string date))) | 224 | (calendar-coptic-date-string thedate))) |
| 221 | 225 | ||
| 222 | ;;;###cal-autoload | 226 | ;;;###cal-autoload |
| 223 | (defun calendar-ethiopic-print-date () | 227 | (defun calendar-ethiopic-print-date () |
| @@ -229,8 +233,8 @@ Defaults to today's date if DATE is not given." | |||
| 229 | (call-interactively 'calendar-coptic-print-date))) | 233 | (call-interactively 'calendar-coptic-print-date))) |
| 230 | 234 | ||
| 231 | ;;;###cal-autoload | 235 | ;;;###cal-autoload |
| 232 | (defun calendar-ethiopic-goto-date (date &optional noecho) | 236 | (defun calendar-ethiopic-goto-date (thedate &optional noecho) |
| 233 | "Move cursor to Ethiopic date DATE. | 237 | "Move cursor to Ethiopic date THEDATE. |
| 234 | Echo Ethiopic date unless NOECHO is t." | 238 | Echo Ethiopic date unless NOECHO is t." |
| 235 | (interactive | 239 | (interactive |
| 236 | (let ((calendar-coptic-epoch calendar-ethiopic-epoch) | 240 | (let ((calendar-coptic-epoch calendar-ethiopic-epoch) |
| @@ -238,7 +242,7 @@ Echo Ethiopic date unless NOECHO is t." | |||
| 238 | (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) | 242 | (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) |
| 239 | (calendar-coptic-read-date))) | 243 | (calendar-coptic-read-date))) |
| 240 | (calendar-goto-date (calendar-gregorian-from-absolute | 244 | (calendar-goto-date (calendar-gregorian-from-absolute |
| 241 | (calendar-ethiopic-to-absolute date))) | 245 | (calendar-ethiopic-to-absolute thedate))) |
| 242 | (or noecho (calendar-ethiopic-print-date))) | 246 | (or noecho (calendar-ethiopic-print-date))) |
| 243 | 247 | ||
| 244 | ;; To be called from diary-list-sexp-entries, where DATE is bound. | 248 | ;; To be called from diary-list-sexp-entries, where DATE is bound. |
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index e759b5dad95..639bae700cc 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-french.el --- calendar functions for the French Revolutionary calendar | 1 | ;;; cal-french.el --- calendar functions for the French Revolutionary calendar -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free | 3 | ;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free |
| 4 | ;; Software Foundation, Inc. | 4 | ;; Software Foundation, Inc. |
| @@ -35,54 +35,45 @@ | |||
| 35 | (defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792)) | 35 | (defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792)) |
| 36 | "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.") | 36 | "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.") |
| 37 | 37 | ||
| 38 | (defconst calendar-french-month-name-array | 38 | (define-obsolete-variable-alias 'calendar-french-multibyte-month-name-array |
| 39 | ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se" | 39 | 'calendar-french-month-name-array "28.1") |
| 40 | "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"] | ||
| 41 | "Array of month names in the French calendar.") | ||
| 42 | 40 | ||
| 43 | (defconst calendar-french-multibyte-month-name-array | 41 | (defconst calendar-french-month-name-array |
| 44 | ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" | 42 | ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" |
| 45 | "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"] | 43 | "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"] |
| 46 | "Array of multibyte month names in the French calendar.") | 44 | "Array of month names in the French calendar.") |
| 47 | 45 | ||
| 48 | (defconst calendar-french-day-name-array | 46 | (defconst calendar-french-day-name-array |
| 49 | ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" | 47 | ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" |
| 50 | "Octidi" "Nonidi" "Decadi"] | 48 | "Octidi" "Nonidi" "Decadi"] |
| 51 | "Array of day names in the French calendar.") | 49 | "Array of day names in the French calendar.") |
| 52 | 50 | ||
| 53 | (defconst calendar-french-special-days-array | 51 | (define-obsolete-variable-alias 'calendar-french-multibyte-special-days-array |
| 54 | ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses" | 52 | 'calendar-french-special-days-array "28.1") |
| 55 | "de la Re'volution"] | ||
| 56 | "Array of special day names in the French calendar.") | ||
| 57 | 53 | ||
| 58 | (defconst calendar-french-multibyte-special-days-array | 54 | (defconst calendar-french-special-days-array |
| 59 | ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses" | 55 | ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses" |
| 60 | "de la Révolution"] | 56 | "de la Révolution"] |
| 61 | "Array of multibyte special day names in the French calendar.") | 57 | "Array of special day names in the French calendar.") |
| 62 | 58 | ||
| 63 | (defun calendar-french-accents-p () | 59 | (defun calendar-french-accents-p () |
| 64 | "Return non-nil if diacritical marks are available." | 60 | (declare (obsolete nil "28.1")) |
| 65 | (and (or window-system | 61 | t) |
| 66 | (terminal-coding-system)) | ||
| 67 | (or enable-multibyte-characters | ||
| 68 | (and (char-table-p standard-display-table) | ||
| 69 | (equal (aref standard-display-table 161) [161]))))) | ||
| 70 | 62 | ||
| 71 | (defun calendar-french-month-name-array () | 63 | (defun calendar-french-month-name-array () |
| 72 | "Return the array of month names, depending on whether accents are available." | 64 | "Return the array of month names, depending on whether accents are available." |
| 73 | (if (calendar-french-accents-p) | 65 | (declare (obsolete "use the variable of the same name instead" "28.1")) |
| 74 | calendar-french-multibyte-month-name-array | 66 | calendar-french-month-name-array) |
| 75 | calendar-french-month-name-array)) | ||
| 76 | 67 | ||
| 77 | (defun calendar-french-day-name-array () | 68 | (defun calendar-french-day-name-array () |
| 78 | "Return the array of day names." | 69 | "Return the array of day names." |
| 70 | (declare (obsolete "use the variable of the same name instead" "28.1")) | ||
| 79 | calendar-french-day-name-array) | 71 | calendar-french-day-name-array) |
| 80 | 72 | ||
| 81 | (defun calendar-french-special-days-array () | 73 | (defun calendar-french-special-days-array () |
| 82 | "Return the special day names, depending on whether accents are available." | 74 | "Return the special day names, depending on whether accents are available." |
| 83 | (if (calendar-french-accents-p) | 75 | (declare (obsolete "use the variable of the same name instead" "28.1")) |
| 84 | calendar-french-multibyte-special-days-array | 76 | calendar-french-special-days-array) |
| 85 | calendar-french-special-days-array)) | ||
| 86 | 77 | ||
| 87 | (defun calendar-french-leap-year-p (year) | 78 | (defun calendar-french-leap-year-p (year) |
| 88 | "True if YEAR is a leap year on the French Revolutionary calendar. | 79 | "True if YEAR is a leap year on the French Revolutionary calendar. |
| @@ -171,17 +162,13 @@ Defaults to today's date if DATE is not given." | |||
| 171 | (d (calendar-extract-day french-date))) | 162 | (d (calendar-extract-day french-date))) |
| 172 | (cond | 163 | (cond |
| 173 | ((< y 1) "") | 164 | ((< y 1) "") |
| 174 | ((= m 13) (format (if (calendar-french-accents-p) | 165 | ((= m 13) (format "Jour %s de l'Année %d de la Révolution" |
| 175 | "Jour %s de l'Année %d de la Révolution" | 166 | (aref calendar-french-special-days-array (1- d)) |
| 176 | "Jour %s de l'Anne'e %d de la Re'volution") | ||
| 177 | (aref (calendar-french-special-days-array) (1- d)) | ||
| 178 | y)) | 167 | y)) |
| 179 | (t (format | 168 | (t (format |
| 180 | (if (calendar-french-accents-p) | 169 | "%d %s an %d de la Révolution" |
| 181 | "%d %s an %d de la Révolution" | ||
| 182 | "%d %s an %d de la Re'volution") | ||
| 183 | d | 170 | d |
| 184 | (aref (calendar-french-month-name-array) (1- m)) | 171 | (aref calendar-french-month-name-array (1- m)) |
| 185 | y))))) | 172 | y))))) |
| 186 | 173 | ||
| 187 | ;;;###cal-autoload | 174 | ;;;###cal-autoload |
| @@ -198,19 +185,16 @@ Defaults to today's date if DATE is not given." | |||
| 198 | "Move cursor to French Revolutionary date DATE. | 185 | "Move cursor to French Revolutionary date DATE. |
| 199 | Echo French Revolutionary date unless NOECHO is non-nil." | 186 | Echo French Revolutionary date unless NOECHO is non-nil." |
| 200 | (interactive | 187 | (interactive |
| 201 | (let* ((months (calendar-french-month-name-array)) | 188 | (let* ((months calendar-french-month-name-array) |
| 202 | (special-days (calendar-french-special-days-array)) | 189 | (special-days calendar-french-special-days-array) |
| 203 | (year (progn | 190 | (year (progn |
| 204 | (calendar-read | 191 | (calendar-read-sexp |
| 205 | (if (calendar-french-accents-p) | 192 | "Année de la Révolution (>0)" |
| 206 | "Année de la Révolution (>0): " | ||
| 207 | "Anne'e de la Re'volution (>0): ") | ||
| 208 | (lambda (x) (> x 0)) | 193 | (lambda (x) (> x 0)) |
| 209 | (number-to-string | 194 | (calendar-extract-year |
| 210 | (calendar-extract-year | 195 | (calendar-french-from-absolute |
| 211 | (calendar-french-from-absolute | 196 | (calendar-absolute-from-gregorian |
| 212 | (calendar-absolute-from-gregorian | 197 | (calendar-current-date))))))) |
| 213 | (calendar-current-date)))))))) | ||
| 214 | (month-list | 198 | (month-list |
| 215 | (mapcar 'list | 199 | (mapcar 'list |
| 216 | (append months | 200 | (append months |
| @@ -234,8 +218,8 @@ Echo French Revolutionary date unless NOECHO is non-nil." | |||
| 234 | (calendar-make-alist month-list 1 'car) t))) | 218 | (calendar-make-alist month-list 1 'car) t))) |
| 235 | (day (if (> month 12) | 219 | (day (if (> month 12) |
| 236 | (- month 12) | 220 | (- month 12) |
| 237 | (calendar-read | 221 | (calendar-read-sexp |
| 238 | "Jour (1-30): " | 222 | "Jour (1-30)" |
| 239 | (lambda (x) (and (<= 1 x) (<= x 30)))))) | 223 | (lambda (x) (and (<= 1 x) (<= x 30)))))) |
| 240 | (month (if (> month 12) 13 month))) | 224 | (month (if (> month 12) 13 month))) |
| 241 | (list (list month day year)))) | 225 | (list (list month day year)))) |
diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index bcc80f0877b..50b4fc363bb 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-hebrew.el --- calendar functions for the Hebrew calendar | 1 | ;;; cal-hebrew.el --- calendar functions for the Hebrew calendar -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -225,13 +225,12 @@ Driven by the variable `calendar-date-display-form'." | |||
| 225 | "Interactively read the arguments for a Hebrew date command. | 225 | "Interactively read the arguments for a Hebrew date command. |
| 226 | Reads a year, month, and day." | 226 | Reads a year, month, and day." |
| 227 | (let* ((today (calendar-current-date)) | 227 | (let* ((today (calendar-current-date)) |
| 228 | (year (calendar-read | 228 | (year (calendar-read-sexp |
| 229 | "Hebrew calendar year (>3760): " | 229 | "Hebrew calendar year (>3760)" |
| 230 | (lambda (x) (> x 3760)) | 230 | (lambda (x) (> x 3760)) |
| 231 | (number-to-string | 231 | (calendar-extract-year |
| 232 | (calendar-extract-year | 232 | (calendar-hebrew-from-absolute |
| 233 | (calendar-hebrew-from-absolute | 233 | (calendar-absolute-from-gregorian today))))) |
| 234 | (calendar-absolute-from-gregorian today)))))) | ||
| 235 | (month-array (if (calendar-hebrew-leap-year-p year) | 234 | (month-array (if (calendar-hebrew-leap-year-p year) |
| 236 | calendar-hebrew-month-name-array-leap-year | 235 | calendar-hebrew-month-name-array-leap-year |
| 237 | calendar-hebrew-month-name-array-common-year)) | 236 | calendar-hebrew-month-name-array-common-year)) |
| @@ -258,10 +257,11 @@ Reads a year, month, and day." | |||
| 258 | (last (calendar-hebrew-last-day-of-month month year)) | 257 | (last (calendar-hebrew-last-day-of-month month year)) |
| 259 | (first (if (and (= year 3761) (= month 10)) | 258 | (first (if (and (= year 3761) (= month 10)) |
| 260 | 18 1)) | 259 | 18 1)) |
| 261 | (day (calendar-read | 260 | (day (calendar-read-sexp |
| 262 | (format "Hebrew calendar day (%d-%d): " | 261 | "Hebrew calendar day (%d-%d)" |
| 263 | first last) | 262 | (lambda (x) (and (<= first x) (<= x last))) |
| 264 | (lambda (x) (and (<= first x) (<= x last)))))) | 263 | nil |
| 264 | first last))) | ||
| 265 | (list (list month day year)))) | 265 | (list (list month day year)))) |
| 266 | 266 | ||
| 267 | ;;;###cal-autoload | 267 | ;;;###cal-autoload |
| @@ -399,19 +399,20 @@ is non-nil." | |||
| 399 | (list m (calendar-last-day-of-month m y) y)))))) | 399 | (list m (calendar-last-day-of-month m y) y)))))) |
| 400 | (abs-h (calendar-hebrew-to-absolute (list 9 25 h-y))) | 400 | (abs-h (calendar-hebrew-to-absolute (list 9 25 h-y))) |
| 401 | (ord ["first" "second" "third" "fourth" "fifth" "sixth" | 401 | (ord ["first" "second" "third" "fourth" "fifth" "sixth" |
| 402 | "seventh" "eighth"]) | 402 | "seventh" "eighth"])) |
| 403 | han) | ||
| 404 | (holiday-filter-visible-calendar | 403 | (holiday-filter-visible-calendar |
| 405 | (if (or all calendar-hebrew-all-holidays-flag) | 404 | (if (or all calendar-hebrew-all-holidays-flag) |
| 406 | (append | 405 | (append |
| 407 | (list | 406 | (list |
| 408 | (list (calendar-gregorian-from-absolute (1- abs-h)) | 407 | (list (calendar-gregorian-from-absolute (1- abs-h)) |
| 409 | "Erev Hanukkah")) | 408 | "Erev Hanukkah")) |
| 410 | (dotimes (i 8 (nreverse han)) | 409 | (let (han) |
| 411 | (push (list | 410 | (dotimes (i 8) |
| 412 | (calendar-gregorian-from-absolute (+ abs-h i)) | 411 | (push (list |
| 413 | (format "Hanukkah (%s day)" (aref ord i))) | 412 | (calendar-gregorian-from-absolute (+ abs-h i)) |
| 414 | han))) | 413 | (format "Hanukkah (%s day)" (aref ord i))) |
| 414 | han)) | ||
| 415 | (nreverse han))) | ||
| 415 | (list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah"))))))) | 416 | (list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah"))))))) |
| 416 | 417 | ||
| 417 | ;;;###holiday-autoload | 418 | ;;;###holiday-autoload |
| @@ -681,10 +682,10 @@ from the cursor position." | |||
| 681 | (if (equal (current-buffer) (get-buffer calendar-buffer)) | 682 | (if (equal (current-buffer) (get-buffer calendar-buffer)) |
| 682 | (calendar-cursor-to-date t) | 683 | (calendar-cursor-to-date t) |
| 683 | (let* ((today (calendar-current-date)) | 684 | (let* ((today (calendar-current-date)) |
| 684 | (year (calendar-read | 685 | (year (calendar-read-sexp |
| 685 | "Year of death (>0): " | 686 | "Year of death (>0)" |
| 686 | (lambda (x) (> x 0)) | 687 | (lambda (x) (> x 0)) |
| 687 | (number-to-string (calendar-extract-year today)))) | 688 | (calendar-extract-year today))) |
| 688 | (month-array calendar-month-name-array) | 689 | (month-array calendar-month-name-array) |
| 689 | (completion-ignore-case t) | 690 | (completion-ignore-case t) |
| 690 | (month (cdr (assoc-string | 691 | (month (cdr (assoc-string |
| @@ -694,20 +695,23 @@ from the cursor position." | |||
| 694 | nil t) | 695 | nil t) |
| 695 | (calendar-make-alist month-array 1) t))) | 696 | (calendar-make-alist month-array 1) t))) |
| 696 | (last (calendar-last-day-of-month month year)) | 697 | (last (calendar-last-day-of-month month year)) |
| 697 | (day (calendar-read | 698 | (day (calendar-read-sexp |
| 698 | (format "Day of death (1-%d): " last) | 699 | "Day of death (1-%d)" |
| 699 | (lambda (x) (and (< 0 x) (<= x last)))))) | 700 | (lambda (x) (and (< 0 x) (<= x last))) |
| 701 | nil | ||
| 702 | last))) | ||
| 700 | (list month day year)))) | 703 | (list month day year)))) |
| 701 | (death-year (calendar-extract-year death-date)) | 704 | (death-year (calendar-extract-year death-date)) |
| 702 | (start-year (calendar-read | 705 | (start-year (calendar-read-sexp |
| 703 | (format "Starting year of Yahrzeit table (>%d): " | 706 | "Starting year of Yahrzeit table (>%d)" |
| 704 | death-year) | ||
| 705 | (lambda (x) (> x death-year)) | 707 | (lambda (x) (> x death-year)) |
| 706 | (number-to-string (1+ death-year)))) | 708 | (1+ death-year) |
| 707 | (end-year (calendar-read | 709 | death-year)) |
| 708 | (format "Ending year of Yahrzeit table (>=%d): " | 710 | (end-year (calendar-read-sexp |
| 709 | start-year) | 711 | "Ending year of Yahrzeit table (>=%d)" |
| 710 | (lambda (x) (>= x start-year))))) | 712 | (lambda (x) (>= x start-year)) |
| 713 | nil | ||
| 714 | start-year))) | ||
| 711 | (list death-date start-year end-year))) | 715 | (list death-date start-year end-year))) |
| 712 | (message "Computing Yahrzeits...") | 716 | (message "Computing Yahrzeits...") |
| 713 | (let* ((h-date (calendar-hebrew-from-absolute | 717 | (let* ((h-date (calendar-hebrew-from-absolute |
diff --git a/lisp/calendar/cal-html.el b/lisp/calendar/cal-html.el index 3d7cc938437..e5810c3f027 100644 --- a/lisp/calendar/cal-html.el +++ b/lisp/calendar/cal-html.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-html.el --- functions for printing HTML calendars | 1 | ;;; cal-html.el --- functions for printing HTML calendars -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -250,7 +250,7 @@ Contains links to previous and next month and year, and current minical." | |||
| 250 | calendar-week-start-day)) | 250 | calendar-week-start-day)) |
| 251 | 7)) | 251 | 7)) |
| 252 | (monthpage-name (cal-html-monthpage-name month year)) | 252 | (monthpage-name (cal-html-monthpage-name month year)) |
| 253 | date) | 253 | ) ;; date |
| 254 | ;; Start writing table. | 254 | ;; Start writing table. |
| 255 | (insert (cal-html-comment "MINICAL") | 255 | (insert (cal-html-comment "MINICAL") |
| 256 | (cal-html-b-table "class=minical border=1 align=center")) | 256 | (cal-html-b-table "class=minical border=1 align=center")) |
| @@ -276,7 +276,7 @@ Contains links to previous and next month and year, and current minical." | |||
| 276 | (insert cal-html-e-tablerow-string | 276 | (insert cal-html-e-tablerow-string |
| 277 | cal-html-b-tablerow-string))) | 277 | cal-html-b-tablerow-string))) |
| 278 | ;; End empty slots (for some browsers like konqueror). | 278 | ;; End empty slots (for some browsers like konqueror). |
| 279 | (dotimes (i end-blank-days) | 279 | (dotimes (_ end-blank-days) |
| 280 | (insert | 280 | (insert |
| 281 | cal-html-b-tabledata-string | 281 | cal-html-b-tabledata-string |
| 282 | cal-html-e-tabledata-string))) | 282 | cal-html-e-tabledata-string))) |
| @@ -431,12 +431,11 @@ holidays in HOLIDAY-LIST." | |||
| 431 | ;;; User commands. | 431 | ;;; User commands. |
| 432 | 432 | ||
| 433 | ;;;###cal-autoload | 433 | ;;;###cal-autoload |
| 434 | (defun cal-html-cursor-month (month year dir &optional event) | 434 | (defun cal-html-cursor-month (month year dir &optional _event) |
| 435 | "Write an HTML calendar file for numeric MONTH of four-digit YEAR. | 435 | "Write an HTML calendar file for numeric MONTH of four-digit YEAR. |
| 436 | The output directory DIR is created if necessary. Interactively, | 436 | The output directory DIR is created if necessary. Interactively, |
| 437 | MONTH and YEAR are taken from the calendar cursor position, or from | 437 | MONTH and YEAR are taken from the calendar cursor position. |
| 438 | the position specified by EVENT. Note that any existing output files | 438 | Note that any existing output files are overwritten." |
| 439 | are overwritten." | ||
| 440 | (interactive (let* ((event last-nonmenu-event) | 439 | (interactive (let* ((event last-nonmenu-event) |
| 441 | (date (calendar-cursor-to-date t event)) | 440 | (date (calendar-cursor-to-date t event)) |
| 442 | (month (calendar-extract-month date)) | 441 | (month (calendar-extract-month date)) |
| @@ -446,11 +445,11 @@ are overwritten." | |||
| 446 | (cal-html-one-month month year dir)) | 445 | (cal-html-one-month month year dir)) |
| 447 | 446 | ||
| 448 | ;;;###cal-autoload | 447 | ;;;###cal-autoload |
| 449 | (defun cal-html-cursor-year (year dir &optional event) | 448 | (defun cal-html-cursor-year (year dir &optional _event) |
| 450 | "Write HTML calendar files (index and monthly pages) for four-digit YEAR. | 449 | "Write HTML calendar files (index and monthly pages) for four-digit YEAR. |
| 451 | The output directory DIR is created if necessary. Interactively, | 450 | The output directory DIR is created if necessary. Interactively, |
| 452 | YEAR is taken from the calendar cursor position, or from the position | 451 | YEAR is taken from the calendar cursor position. |
| 453 | specified by EVENT. Note that any existing output files are overwritten." | 452 | Note that any existing output files are overwritten." |
| 454 | (interactive (let* ((event last-nonmenu-event) | 453 | (interactive (let* ((event last-nonmenu-event) |
| 455 | (year (calendar-extract-year | 454 | (year (calendar-extract-year |
| 456 | (calendar-cursor-to-date t event)))) | 455 | (calendar-cursor-to-date t event)))) |
diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index d256310ba6c..45c6ffa7bd7 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-islam.el --- calendar functions for the Islamic calendar | 1 | ;;; cal-islam.el --- calendar functions for the Islamic calendar -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -67,8 +67,8 @@ | |||
| 67 | "Absolute date of Islamic DATE. | 67 | "Absolute date of Islamic DATE. |
| 68 | The absolute date is the number of days elapsed since the (imaginary) | 68 | The absolute date is the number of days elapsed since the (imaginary) |
| 69 | Gregorian date Sunday, December 31, 1 BC." | 69 | Gregorian date Sunday, December 31, 1 BC." |
| 70 | (let* ((month (calendar-extract-month date)) | 70 | (let* (;;(month (calendar-extract-month date)) |
| 71 | (day (calendar-extract-day date)) | 71 | ;;(day (calendar-extract-day date)) |
| 72 | (year (calendar-extract-year date)) | 72 | (year (calendar-extract-year date)) |
| 73 | (y (% year 30)) | 73 | (y (% year 30)) |
| 74 | (leap-years-in-cycle (cond ((< y 3) 0) | 74 | (leap-years-in-cycle (cond ((< y 3) 0) |
| @@ -143,13 +143,12 @@ Driven by the variable `calendar-date-display-form'." | |||
| 143 | "Interactively read the arguments for an Islamic date command. | 143 | "Interactively read the arguments for an Islamic date command. |
| 144 | Reads a year, month, and day." | 144 | Reads a year, month, and day." |
| 145 | (let* ((today (calendar-current-date)) | 145 | (let* ((today (calendar-current-date)) |
| 146 | (year (calendar-read | 146 | (year (calendar-read-sexp |
| 147 | "Islamic calendar year (>0): " | 147 | "Islamic calendar year (>0)" |
| 148 | (lambda (x) (> x 0)) | 148 | (lambda (x) (> x 0)) |
| 149 | (number-to-string | 149 | (calendar-extract-year |
| 150 | (calendar-extract-year | 150 | (calendar-islamic-from-absolute |
| 151 | (calendar-islamic-from-absolute | 151 | (calendar-absolute-from-gregorian today))))) |
| 152 | (calendar-absolute-from-gregorian today)))))) | ||
| 153 | (month-array calendar-islamic-month-name-array) | 152 | (month-array calendar-islamic-month-name-array) |
| 154 | (completion-ignore-case t) | 153 | (completion-ignore-case t) |
| 155 | (month (cdr (assoc-string | 154 | (month (cdr (assoc-string |
| @@ -159,9 +158,11 @@ Reads a year, month, and day." | |||
| 159 | nil t) | 158 | nil t) |
| 160 | (calendar-make-alist month-array 1) t))) | 159 | (calendar-make-alist month-array 1) t))) |
| 161 | (last (calendar-islamic-last-day-of-month month year)) | 160 | (last (calendar-islamic-last-day-of-month month year)) |
| 162 | (day (calendar-read | 161 | (day (calendar-read-sexp |
| 163 | (format "Islamic calendar day (1-%d): " last) | 162 | "Islamic calendar day (1-%d)" |
| 164 | (lambda (x) (and (< 0 x) (<= x last)))))) | 163 | (lambda (x) (and (< 0 x) (<= x last))) |
| 164 | nil | ||
| 165 | last))) | ||
| 165 | (list (list month day year)))) | 166 | (list (list month day year)))) |
| 166 | 167 | ||
| 167 | ;;;###cal-autoload | 168 | ;;;###cal-autoload |
diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el index 956433e4a20..90f57c25e9d 100644 --- a/lisp/calendar/cal-iso.el +++ b/lisp/calendar/cal-iso.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-iso.el --- calendar functions for the ISO calendar | 1 | ;;; cal-iso.el --- calendar functions for the ISO calendar -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -92,22 +92,23 @@ date Sunday, December 31, 1 BC." | |||
| 92 | "Interactively read the arguments for an ISO date command. | 92 | "Interactively read the arguments for an ISO date command. |
| 93 | Reads a year and week, and if DAYFLAG is non-nil a day (otherwise | 93 | Reads a year and week, and if DAYFLAG is non-nil a day (otherwise |
| 94 | taken to be 1)." | 94 | taken to be 1)." |
| 95 | (let* ((year (calendar-read | 95 | (let* ((year (calendar-read-sexp |
| 96 | "ISO calendar year (>0): " | 96 | "ISO calendar year (>0)" |
| 97 | (lambda (x) (> x 0)) | 97 | (lambda (x) (> x 0)) |
| 98 | (number-to-string (calendar-extract-year | 98 | (calendar-extract-year (calendar-current-date)))) |
| 99 | (calendar-current-date))))) | ||
| 100 | (no-weeks (calendar-extract-month | 99 | (no-weeks (calendar-extract-month |
| 101 | (calendar-iso-from-absolute | 100 | (calendar-iso-from-absolute |
| 102 | (1- | 101 | (1- |
| 103 | (calendar-dayname-on-or-before | 102 | (calendar-dayname-on-or-before |
| 104 | 1 (calendar-absolute-from-gregorian | 103 | 1 (calendar-absolute-from-gregorian |
| 105 | (list 1 4 (1+ year)))))))) | 104 | (list 1 4 (1+ year)))))))) |
| 106 | (week (calendar-read | 105 | (week (calendar-read-sexp |
| 107 | (format "ISO calendar week (1-%d): " no-weeks) | 106 | "ISO calendar week (1-%d)" |
| 108 | (lambda (x) (and (> x 0) (<= x no-weeks))))) | 107 | (lambda (x) (and (> x 0) (<= x no-weeks))) |
| 109 | (day (if dayflag (calendar-read | 108 | nil |
| 110 | "ISO day (1-7): " | 109 | no-weeks)) |
| 110 | (day (if dayflag (calendar-read-sexp | ||
| 111 | "ISO day (1-7)" | ||
| 111 | (lambda (x) (and (<= 1 x) (<= x 7)))) | 112 | (lambda (x) (and (<= 1 x) (<= x 7)))) |
| 112 | 1))) | 113 | 1))) |
| 113 | (list (list week day year)))) | 114 | (list (list week day year)))) |
diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el index 235b4d00900..47880a4e974 100644 --- a/lisp/calendar/cal-julian.el +++ b/lisp/calendar/cal-julian.el | |||
| @@ -95,14 +95,13 @@ Driven by the variable `calendar-date-display-form'." | |||
| 95 | "Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil." | 95 | "Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil." |
| 96 | (interactive | 96 | (interactive |
| 97 | (let* ((today (calendar-current-date)) | 97 | (let* ((today (calendar-current-date)) |
| 98 | (year (calendar-read | 98 | (year (calendar-read-sexp |
| 99 | "Julian calendar year (>0): " | 99 | "Julian calendar year (>0)" |
| 100 | (lambda (x) (> x 0)) | 100 | (lambda (x) (> x 0)) |
| 101 | (number-to-string | 101 | (calendar-extract-year |
| 102 | (calendar-extract-year | 102 | (calendar-julian-from-absolute |
| 103 | (calendar-julian-from-absolute | 103 | (calendar-absolute-from-gregorian |
| 104 | (calendar-absolute-from-gregorian | 104 | today))))) |
| 105 | today)))))) | ||
| 106 | (month-array calendar-month-name-array) | 105 | (month-array calendar-month-name-array) |
| 107 | (completion-ignore-case t) | 106 | (completion-ignore-case t) |
| 108 | (month (cdr (assoc-string | 107 | (month (cdr (assoc-string |
| @@ -115,12 +114,13 @@ Driven by the variable `calendar-date-display-form'." | |||
| 115 | (if (and (zerop (% year 4)) (= month 2)) | 114 | (if (and (zerop (% year 4)) (= month 2)) |
| 116 | 29 | 115 | 29 |
| 117 | (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) | 116 | (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) |
| 118 | (day (calendar-read | 117 | (day (calendar-read-sexp |
| 119 | (format "Julian calendar day (%d-%d): " | 118 | "Julian calendar day (%d-%d)" |
| 120 | (if (and (= year 1) (= month 1)) 3 1) last) | ||
| 121 | (lambda (x) | 119 | (lambda (x) |
| 122 | (and (< (if (and (= year 1) (= month 1)) 2 0) x) | 120 | (and (< (if (and (= year 1) (= month 1)) 2 0) x) |
| 123 | (<= x last)))))) | 121 | (<= x last))) |
| 122 | nil | ||
| 123 | (if (and (= year 1) (= month 1)) 3 1) last))) | ||
| 124 | (list (list month day year)))) | 124 | (list (list month day year)))) |
| 125 | (calendar-goto-date (calendar-gregorian-from-absolute | 125 | (calendar-goto-date (calendar-gregorian-from-absolute |
| 126 | (calendar-julian-to-absolute date))) | 126 | (calendar-julian-to-absolute date))) |
| @@ -173,8 +173,8 @@ Defaults to today's date if DATE is not given." | |||
| 173 | (defun calendar-astro-goto-day-number (daynumber &optional noecho) | 173 | (defun calendar-astro-goto-day-number (daynumber &optional noecho) |
| 174 | "Move cursor to astronomical (Julian) DAYNUMBER. | 174 | "Move cursor to astronomical (Julian) DAYNUMBER. |
| 175 | Echo astronomical (Julian) day number unless NOECHO is non-nil." | 175 | Echo astronomical (Julian) day number unless NOECHO is non-nil." |
| 176 | (interactive (list (calendar-read | 176 | (interactive (list (calendar-read-sexp |
| 177 | "Astronomical (Julian) day number (>1721425): " | 177 | "Astronomical (Julian) day number (>1721425)" |
| 178 | (lambda (x) (> x 1721425))))) | 178 | (lambda (x) (> x 1721425))))) |
| 179 | (calendar-goto-date | 179 | (calendar-goto-date |
| 180 | (calendar-gregorian-from-absolute | 180 | (calendar-gregorian-from-absolute |
diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el index 8d894ebd986..9a221921130 100644 --- a/lisp/calendar/cal-mayan.el +++ b/lisp/calendar/cal-mayan.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-mayan.el --- calendar functions for the Mayan calendars | 1 | ;;; cal-mayan.el --- calendar functions for the Mayan calendars -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software | 3 | ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software |
| 4 | ;; Foundation, Inc. | 4 | ;; Foundation, Inc. |
| @@ -135,8 +135,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using | |||
| 135 | (defun calendar-mayan-read-haab-date () | 135 | (defun calendar-mayan-read-haab-date () |
| 136 | "Prompt for a Mayan haab date." | 136 | "Prompt for a Mayan haab date." |
| 137 | (let* ((completion-ignore-case t) | 137 | (let* ((completion-ignore-case t) |
| 138 | (haab-day (calendar-read | 138 | (haab-day (calendar-read-sexp |
| 139 | "Haab kin (0-19): " | 139 | "Haab kin (0-19)" |
| 140 | (lambda (x) (and (>= x 0) (< x 20))))) | 140 | (lambda (x) (and (>= x 0) (< x 20))))) |
| 141 | (haab-month-list (append calendar-mayan-haab-month-name-array | 141 | (haab-month-list (append calendar-mayan-haab-month-name-array |
| 142 | (and (< haab-day 5) '("Uayeb")))) | 142 | (and (< haab-day 5) '("Uayeb")))) |
| @@ -151,8 +151,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using | |||
| 151 | (defun calendar-mayan-read-tzolkin-date () | 151 | (defun calendar-mayan-read-tzolkin-date () |
| 152 | "Prompt for a Mayan tzolkin date." | 152 | "Prompt for a Mayan tzolkin date." |
| 153 | (let* ((completion-ignore-case t) | 153 | (let* ((completion-ignore-case t) |
| 154 | (tzolkin-count (calendar-read | 154 | (tzolkin-count (calendar-read-sexp |
| 155 | "Tzolkin kin (1-13): " | 155 | "Tzolkin kin (1-13)" |
| 156 | (lambda (x) (and (> x 0) (< x 14))))) | 156 | (lambda (x) (and (> x 0) (< x 14))))) |
| 157 | (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) | 157 | (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) |
| 158 | (tzolkin-name (cdr | 158 | (tzolkin-name (cdr |
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index a30c681a897..497f3329055 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-menu.el --- calendar functions for menu bar and popup menu support | 1 | ;;; cal-menu.el --- calendar functions for menu bar and popup menu support -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -183,6 +183,8 @@ Signals an error if popups are unavailable." | |||
| 183 | ;; Autoloaded in diary-lib. | 183 | ;; Autoloaded in diary-lib. |
| 184 | (declare-function calendar-check-holidays "holidays" (date)) | 184 | (declare-function calendar-check-holidays "holidays" (date)) |
| 185 | 185 | ||
| 186 | (defvar diary-list-include-blanks) | ||
| 187 | |||
| 186 | (defun calendar-mouse-view-diary-entries (&optional date diary event) | 188 | (defun calendar-mouse-view-diary-entries (&optional date diary event) |
| 187 | "Pop up menu of diary entries for mouse-selected date. | 189 | "Pop up menu of diary entries for mouse-selected date. |
| 188 | Use optional DATE and alternative file DIARY. EVENT is the event | 190 | Use optional DATE and alternative file DIARY. EVENT is the event |
diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el index 710ce37ccbf..9294362cb43 100644 --- a/lisp/calendar/cal-move.el +++ b/lisp/calendar/cal-move.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-move.el --- calendar functions for movement in the calendar | 1 | ;;; cal-move.el --- calendar functions for movement in the calendar -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -386,15 +386,16 @@ Moves forward if ARG is negative." | |||
| 386 | "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil. | 386 | "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil. |
| 387 | Negative DAY counts backward from end of year." | 387 | Negative DAY counts backward from end of year." |
| 388 | (interactive | 388 | (interactive |
| 389 | (let* ((year (calendar-read | 389 | (let* ((year (calendar-read-sexp |
| 390 | "Year (>0): " | 390 | "Year (>0)" |
| 391 | (lambda (x) (> x 0)) | 391 | (lambda (x) (> x 0)) |
| 392 | (number-to-string (calendar-extract-year | 392 | (calendar-extract-year (calendar-current-date)))) |
| 393 | (calendar-current-date))))) | ||
| 394 | (last (if (calendar-leap-year-p year) 366 365)) | 393 | (last (if (calendar-leap-year-p year) 366 365)) |
| 395 | (day (calendar-read | 394 | (day (calendar-read-sexp |
| 396 | (format "Day number (+/- 1-%d): " last) | 395 | "Day number (+/- 1-%d)" |
| 397 | (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))))) | 396 | (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))) |
| 397 | nil | ||
| 398 | last))) | ||
| 398 | (list year day))) | 399 | (list year day))) |
| 399 | (calendar-goto-date | 400 | (calendar-goto-date |
| 400 | (calendar-gregorian-from-absolute | 401 | (calendar-gregorian-from-absolute |
diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el index a9c99fedbdb..ca37d803224 100644 --- a/lisp/calendar/cal-persia.el +++ b/lisp/calendar/cal-persia.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-persia.el --- calendar functions for the Persian calendar | 1 | ;;; cal-persia.el --- calendar functions for the Persian calendar -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -139,13 +139,14 @@ Gregorian date Sunday, December 31, 1 BC." | |||
| 139 | (calendar-absolute-from-gregorian | 139 | (calendar-absolute-from-gregorian |
| 140 | (or date (calendar-current-date))))) | 140 | (or date (calendar-current-date))))) |
| 141 | (y (calendar-extract-year persian-date)) | 141 | (y (calendar-extract-year persian-date)) |
| 142 | (m (calendar-extract-month persian-date)) | 142 | (m (calendar-extract-month persian-date))) |
| 143 | (monthname (aref calendar-persian-month-name-array (1- m))) | 143 | (calendar-dlet* |
| 144 | ((monthname (aref calendar-persian-month-name-array (1- m))) | ||
| 144 | (day (number-to-string (calendar-extract-day persian-date))) | 145 | (day (number-to-string (calendar-extract-day persian-date))) |
| 145 | (year (number-to-string y)) | 146 | (year (number-to-string y)) |
| 146 | (month (number-to-string m)) | 147 | (month (number-to-string m)) |
| 147 | dayname) | 148 | dayname) |
| 148 | (mapconcat 'eval calendar-date-display-form ""))) | 149 | (mapconcat #'eval calendar-date-display-form "")))) |
| 149 | 150 | ||
| 150 | ;;;###cal-autoload | 151 | ;;;###cal-autoload |
| 151 | (defun calendar-persian-print-date () | 152 | (defun calendar-persian-print-date () |
| @@ -157,14 +158,13 @@ Gregorian date Sunday, December 31, 1 BC." | |||
| 157 | (defun calendar-persian-read-date () | 158 | (defun calendar-persian-read-date () |
| 158 | "Interactively read the arguments for a Persian date command. | 159 | "Interactively read the arguments for a Persian date command. |
| 159 | Reads a year, month, and day." | 160 | Reads a year, month, and day." |
| 160 | (let* ((year (calendar-read | 161 | (let* ((year (calendar-read-sexp |
| 161 | "Persian calendar year (not 0): " | 162 | "Persian calendar year (not 0)" |
| 162 | (lambda (x) (not (zerop x))) | 163 | (lambda (x) (not (zerop x))) |
| 163 | (number-to-string | 164 | (calendar-extract-year |
| 164 | (calendar-extract-year | 165 | (calendar-persian-from-absolute |
| 165 | (calendar-persian-from-absolute | 166 | (calendar-absolute-from-gregorian |
| 166 | (calendar-absolute-from-gregorian | 167 | (calendar-current-date)))))) |
| 167 | (calendar-current-date))))))) | ||
| 168 | (completion-ignore-case t) | 168 | (completion-ignore-case t) |
| 169 | (month (cdr (assoc | 169 | (month (cdr (assoc |
| 170 | (completing-read | 170 | (completing-read |
| @@ -175,9 +175,11 @@ Reads a year, month, and day." | |||
| 175 | (calendar-make-alist calendar-persian-month-name-array | 175 | (calendar-make-alist calendar-persian-month-name-array |
| 176 | 1)))) | 176 | 1)))) |
| 177 | (last (calendar-persian-last-day-of-month month year)) | 177 | (last (calendar-persian-last-day-of-month month year)) |
| 178 | (day (calendar-read | 178 | (day (calendar-read-sexp |
| 179 | (format "Persian calendar day (1-%d): " last) | 179 | "Persian calendar day (1-%d)" |
| 180 | (lambda (x) (and (< 0 x) (<= x last)))))) | 180 | (lambda (x) (and (< 0 x) (<= x last))) |
| 181 | nil | ||
| 182 | last))) | ||
| 181 | (list (list month day year)))) | 183 | (list (list month day year)))) |
| 182 | 184 | ||
| 183 | ;;;###cal-autoload | 185 | ;;;###cal-autoload |
diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el index 9df9f4cbedf..f5932014dd9 100644 --- a/lisp/calendar/cal-tex.el +++ b/lisp/calendar/cal-tex.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-tex.el --- calendar functions for printing calendars with LaTeX | 1 | ;;; cal-tex.el --- calendar functions for printing calendars with LaTeX -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -248,6 +248,8 @@ This definition is the heart of the calendar!") | |||
| 248 | 248 | ||
| 249 | (autoload 'diary-list-entries "diary-lib") | 249 | (autoload 'diary-list-entries "diary-lib") |
| 250 | 250 | ||
| 251 | (defvar diary-list-include-blanks) | ||
| 252 | |||
| 251 | (defun cal-tex-list-diary-entries (d1 d2) | 253 | (defun cal-tex-list-diary-entries (d1 d2) |
| 252 | "Generate a list of all diary-entries from absolute date D1 to D2." | 254 | "Generate a list of all diary-entries from absolute date D1 to D2." |
| 253 | (let (diary-list-include-blanks) | 255 | (let (diary-list-include-blanks) |
| @@ -591,6 +593,8 @@ indicates a buffer position to use instead of point." | |||
| 591 | LaTeX commands are inserted for the days of the MONTH in YEAR. | 593 | LaTeX commands are inserted for the days of the MONTH in YEAR. |
| 592 | Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS | 594 | Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS |
| 593 | are included. Each day is formatted using format DAY-FORMAT." | 595 | are included. Each day is formatted using format DAY-FORMAT." |
| 596 | (with-suppressed-warnings ((lexical date)) | ||
| 597 | (defvar date)) ;For `cal-tex-daily-string'. | ||
| 594 | (let ((blank-days ; at start of month | 598 | (let ((blank-days ; at start of month |
| 595 | (mod | 599 | (mod |
| 596 | (- (calendar-day-of-week (list month 1 year)) | 600 | (- (calendar-day-of-week (list month 1 year)) |
| @@ -605,7 +609,7 @@ are included. Each day is formatted using format DAY-FORMAT." | |||
| 605 | (insert (format day-format (cal-tex-month-name month) j)) | 609 | (insert (format day-format (cal-tex-month-name month) j)) |
| 606 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) | 610 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) |
| 607 | (cal-tex-arg (cal-tex-latexify-list holidays date)) | 611 | (cal-tex-arg (cal-tex-latexify-list holidays date)) |
| 608 | (cal-tex-arg (eval cal-tex-daily-string)) | 612 | (cal-tex-arg (eval cal-tex-daily-string t)) |
| 609 | (cal-tex-arg) | 613 | (cal-tex-arg) |
| 610 | (cal-tex-comment)) | 614 | (cal-tex-comment)) |
| 611 | (when (and (zerop (mod (+ j blank-days) 7)) | 615 | (when (and (zerop (mod (+ j blank-days) 7)) |
| @@ -885,13 +889,15 @@ argument EVENT specifies a different buffer position." | |||
| 885 | (interactive (list (prefix-numeric-value current-prefix-arg) | 889 | (interactive (list (prefix-numeric-value current-prefix-arg) |
| 886 | last-nonmenu-event)) | 890 | last-nonmenu-event)) |
| 887 | (or n (setq n 1)) | 891 | (or n (setq n 1)) |
| 892 | (with-suppressed-warnings ((lexical date)) | ||
| 893 | (defvar date)) ;For `cal-tex-daily-string'. | ||
| 888 | (let* ((date (calendar-gregorian-from-absolute | 894 | (let* ((date (calendar-gregorian-from-absolute |
| 889 | (calendar-dayname-on-or-before | 895 | (calendar-dayname-on-or-before |
| 890 | 1 | 896 | 1 |
| 891 | (calendar-absolute-from-gregorian | 897 | (calendar-absolute-from-gregorian |
| 892 | (calendar-cursor-to-date t event))))) | 898 | (calendar-cursor-to-date t event))))) |
| 893 | (month (calendar-extract-month date)) | 899 | (month (calendar-extract-month date)) |
| 894 | (year (calendar-extract-year date)) | 900 | ;; (year (calendar-extract-year date)) |
| 895 | (day (calendar-extract-day date)) | 901 | (day (calendar-extract-day date)) |
| 896 | (d1 (calendar-absolute-from-gregorian date)) | 902 | (d1 (calendar-absolute-from-gregorian date)) |
| 897 | (d2 (+ (* 7 n) d1)) | 903 | (d2 (+ (* 7 n) d1)) |
| @@ -932,7 +938,7 @@ argument EVENT specifies a different buffer position." | |||
| 932 | (insert ": ") | 938 | (insert ": ") |
| 933 | (cal-tex-large-bf s)) | 939 | (cal-tex-large-bf s)) |
| 934 | (cal-tex-hfill) | 940 | (cal-tex-hfill) |
| 935 | (insert " " (eval cal-tex-daily-string)) | 941 | (insert " " (eval cal-tex-daily-string t)) |
| 936 | (cal-tex-e-parbox) | 942 | (cal-tex-e-parbox) |
| 937 | (cal-tex-nl) | 943 | (cal-tex-nl) |
| 938 | (cal-tex-noindent) | 944 | (cal-tex-noindent) |
| @@ -951,7 +957,8 @@ argument EVENT specifies a different buffer position." | |||
| 951 | (cal-tex-e-parbox "2cm") | 957 | (cal-tex-e-parbox "2cm") |
| 952 | (cal-tex-nl) | 958 | (cal-tex-nl) |
| 953 | (setq month (calendar-extract-month date) | 959 | (setq month (calendar-extract-month date) |
| 954 | year (calendar-extract-year date))) | 960 | ;; year (calendar-extract-year date) |
| 961 | )) | ||
| 955 | (cal-tex-e-parbox) | 962 | (cal-tex-e-parbox) |
| 956 | (unless (= i (1- n)) | 963 | (unless (= i (1- n)) |
| 957 | (run-hooks 'cal-tex-week-hook) | 964 | (run-hooks 'cal-tex-week-hook) |
| @@ -961,13 +968,16 @@ argument EVENT specifies a different buffer position." | |||
| 961 | 968 | ||
| 962 | ;; TODO respect cal-tex-daily-start,end? | 969 | ;; TODO respect cal-tex-daily-start,end? |
| 963 | ;; Using different numbers of hours will probably break some layouts. | 970 | ;; Using different numbers of hours will probably break some layouts. |
| 964 | (defun cal-tex-week-hours (date holidays height) | 971 | (defun cal-tex-week-hours (thedate holidays height) |
| 965 | "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT. | 972 | "Insert hourly entries for THEDATE with HOLIDAYS, with line height HEIGHT. |
| 966 | Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours | 973 | Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours |
| 967 | shown are hard-coded to 8-12, 13-17." | 974 | shown are hard-coded to 8-12, 13-17." |
| 968 | (let ((month (calendar-extract-month date)) | 975 | (with-suppressed-warnings ((lexical date)) |
| 976 | (defvar date)) ;For `cal-tex-daily-string'. | ||
| 977 | (let ((date thedate) | ||
| 978 | (month (calendar-extract-month date)) | ||
| 969 | (day (calendar-extract-day date)) | 979 | (day (calendar-extract-day date)) |
| 970 | (year (calendar-extract-year date)) | 980 | ;; (year (calendar-extract-year date)) |
| 971 | morning afternoon s) | 981 | morning afternoon s) |
| 972 | (cal-tex-comment "begin cal-tex-week-hours") | 982 | (cal-tex-comment "begin cal-tex-week-hours") |
| 973 | (cal-tex-cmd "\\ \\\\[-.2cm]") | 983 | (cal-tex-cmd "\\ \\\\[-.2cm]") |
| @@ -983,7 +993,7 @@ shown are hard-coded to 8-12, 13-17." | |||
| 983 | (insert ": ") | 993 | (insert ": ") |
| 984 | (cal-tex-large-bf s)) | 994 | (cal-tex-large-bf s)) |
| 985 | (cal-tex-hfill) | 995 | (cal-tex-hfill) |
| 986 | (insert " " (eval cal-tex-daily-string)) | 996 | (insert " " (eval cal-tex-daily-string t)) |
| 987 | (cal-tex-e-parbox) | 997 | (cal-tex-e-parbox) |
| 988 | (cal-tex-nl "-.3cm") | 998 | (cal-tex-nl "-.3cm") |
| 989 | (cal-tex-rule "0pt" "6.8in" ".2mm") | 999 | (cal-tex-rule "0pt" "6.8in" ".2mm") |
| @@ -1088,14 +1098,16 @@ shown are hard-coded to 8-12, 13-17." | |||
| 1088 | (defun cal-tex-weekly-common (n event &optional filofax) | 1098 | (defun cal-tex-weekly-common (n event &optional filofax) |
| 1089 | "Common code for weekly calendars." | 1099 | "Common code for weekly calendars." |
| 1090 | (or n (setq n 1)) | 1100 | (or n (setq n 1)) |
| 1101 | (with-suppressed-warnings ((lexical date)) | ||
| 1102 | (defvar date)) ;For `cal-tex-daily-string'. | ||
| 1091 | (let* ((date (calendar-gregorian-from-absolute | 1103 | (let* ((date (calendar-gregorian-from-absolute |
| 1092 | (calendar-dayname-on-or-before | 1104 | (calendar-dayname-on-or-before |
| 1093 | 1 | 1105 | 1 |
| 1094 | (calendar-absolute-from-gregorian | 1106 | (calendar-absolute-from-gregorian |
| 1095 | (calendar-cursor-to-date t event))))) | 1107 | (calendar-cursor-to-date t event))))) |
| 1096 | (month (calendar-extract-month date)) | 1108 | ;; (month (calendar-extract-month date)) |
| 1097 | (year (calendar-extract-year date)) | 1109 | ;; (year (calendar-extract-year date)) |
| 1098 | (day (calendar-extract-day date)) | 1110 | ;; (day (calendar-extract-day date)) |
| 1099 | (d1 (calendar-absolute-from-gregorian date)) | 1111 | (d1 (calendar-absolute-from-gregorian date)) |
| 1100 | (d2 (+ (* 7 n) d1)) | 1112 | (d2 (+ (* 7 n) d1)) |
| 1101 | (holidays (if cal-tex-holidays | 1113 | (holidays (if cal-tex-holidays |
| @@ -1161,7 +1173,7 @@ shown are hard-coded to 8-12, 13-17." | |||
| 1161 | (cal-tex-arg (number-to-string (calendar-extract-day date))) | 1173 | (cal-tex-arg (number-to-string (calendar-extract-day date))) |
| 1162 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) | 1174 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) |
| 1163 | (cal-tex-arg (cal-tex-latexify-list holidays date)) | 1175 | (cal-tex-arg (cal-tex-latexify-list holidays date)) |
| 1164 | (cal-tex-arg (eval cal-tex-daily-string)) | 1176 | (cal-tex-arg (eval cal-tex-daily-string t)) |
| 1165 | (insert "%\n") | 1177 | (insert "%\n") |
| 1166 | (setq date (cal-tex-incr-date date))) | 1178 | (setq date (cal-tex-incr-date date))) |
| 1167 | (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n") | 1179 | (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n") |
| @@ -1258,14 +1270,16 @@ Optional EVENT indicates a buffer position to use instead of point." | |||
| 1258 | (interactive (list (prefix-numeric-value current-prefix-arg) | 1270 | (interactive (list (prefix-numeric-value current-prefix-arg) |
| 1259 | last-nonmenu-event)) | 1271 | last-nonmenu-event)) |
| 1260 | (or n (setq n 1)) | 1272 | (or n (setq n 1)) |
| 1273 | (with-suppressed-warnings ((lexical date)) | ||
| 1274 | (defvar date)) ;For `cal-tex-daily-string'. | ||
| 1261 | (let* ((date (calendar-gregorian-from-absolute | 1275 | (let* ((date (calendar-gregorian-from-absolute |
| 1262 | (calendar-dayname-on-or-before | 1276 | (calendar-dayname-on-or-before |
| 1263 | calendar-week-start-day | 1277 | calendar-week-start-day |
| 1264 | (calendar-absolute-from-gregorian | 1278 | (calendar-absolute-from-gregorian |
| 1265 | (calendar-cursor-to-date t event))))) | 1279 | (calendar-cursor-to-date t event))))) |
| 1266 | (month (calendar-extract-month date)) | 1280 | ;; (month (calendar-extract-month date)) |
| 1267 | (year (calendar-extract-year date)) | 1281 | ;; (year (calendar-extract-year date)) |
| 1268 | (day (calendar-extract-day date)) | 1282 | ;; (day (calendar-extract-day date)) |
| 1269 | (d1 (calendar-absolute-from-gregorian date)) | 1283 | (d1 (calendar-absolute-from-gregorian date)) |
| 1270 | (d2 (+ (* 7 n) d1)) | 1284 | (d2 (+ (* 7 n) d1)) |
| 1271 | (holidays (if cal-tex-holidays | 1285 | (holidays (if cal-tex-holidays |
| @@ -1311,7 +1325,7 @@ Optional EVENT indicates a buffer position to use instead of point." | |||
| 1311 | (cal-tex-arg (number-to-string (calendar-extract-day date))) | 1325 | (cal-tex-arg (number-to-string (calendar-extract-day date))) |
| 1312 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) | 1326 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) |
| 1313 | (cal-tex-arg (cal-tex-latexify-list holidays date)) | 1327 | (cal-tex-arg (cal-tex-latexify-list holidays date)) |
| 1314 | (cal-tex-arg (eval cal-tex-daily-string)) | 1328 | (cal-tex-arg (eval cal-tex-daily-string t)) |
| 1315 | (insert "%\n") | 1329 | (insert "%\n") |
| 1316 | (setq date (cal-tex-incr-date date))) | 1330 | (setq date (cal-tex-incr-date date))) |
| 1317 | (unless (= i (1- n)) | 1331 | (unless (= i (1- n)) |
| @@ -1342,14 +1356,16 @@ Optional EVENT indicates a buffer position to use instead of point." | |||
| 1342 | (interactive (list (prefix-numeric-value current-prefix-arg) | 1356 | (interactive (list (prefix-numeric-value current-prefix-arg) |
| 1343 | last-nonmenu-event)) | 1357 | last-nonmenu-event)) |
| 1344 | (or n (setq n 1)) | 1358 | (or n (setq n 1)) |
| 1359 | (with-suppressed-warnings ((lexical date)) | ||
| 1360 | (defvar date)) ;For `cal-tex-daily-string'. | ||
| 1345 | (let* ((date (calendar-gregorian-from-absolute | 1361 | (let* ((date (calendar-gregorian-from-absolute |
| 1346 | (calendar-dayname-on-or-before | 1362 | (calendar-dayname-on-or-before |
| 1347 | 1 | 1363 | 1 |
| 1348 | (calendar-absolute-from-gregorian | 1364 | (calendar-absolute-from-gregorian |
| 1349 | (calendar-cursor-to-date t event))))) | 1365 | (calendar-cursor-to-date t event))))) |
| 1350 | (month (calendar-extract-month date)) | 1366 | ;; (month (calendar-extract-month date)) |
| 1351 | (year (calendar-extract-year date)) | 1367 | ;; (year (calendar-extract-year date)) |
| 1352 | (day (calendar-extract-day date)) | 1368 | ;; (day (calendar-extract-day date)) |
| 1353 | (d1 (calendar-absolute-from-gregorian date)) | 1369 | (d1 (calendar-absolute-from-gregorian date)) |
| 1354 | (d2 (+ (* 7 n) d1)) | 1370 | (d2 (+ (* 7 n) d1)) |
| 1355 | (holidays (if cal-tex-holidays | 1371 | (holidays (if cal-tex-holidays |
| @@ -1383,11 +1399,11 @@ Optional EVENT indicates a buffer position to use instead of point." | |||
| 1383 | "\\leftday"))) | 1399 | "\\leftday"))) |
| 1384 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) | 1400 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) |
| 1385 | (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) | 1401 | (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) |
| 1386 | (cal-tex-arg (eval cal-tex-daily-string)) | 1402 | (cal-tex-arg (eval cal-tex-daily-string t)) |
| 1387 | (insert "%\n") | 1403 | (insert "%\n") |
| 1388 | (if cal-tex-rules | 1404 | (insert (if cal-tex-rules |
| 1389 | (insert "\\linesfill\n") | 1405 | "\\linesfill\n" |
| 1390 | (insert "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) | 1406 | "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) |
| 1391 | (cal-tex-newpage) | 1407 | (cal-tex-newpage) |
| 1392 | (setq date (cal-tex-incr-date date))) | 1408 | (setq date (cal-tex-incr-date date))) |
| 1393 | (insert "%\n") | 1409 | (insert "%\n") |
| @@ -1397,11 +1413,11 @@ Optional EVENT indicates a buffer position to use instead of point." | |||
| 1397 | (insert "\\weekend") | 1413 | (insert "\\weekend") |
| 1398 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) | 1414 | (cal-tex-arg (cal-tex-latexify-list diary-list date)) |
| 1399 | (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) | 1415 | (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) |
| 1400 | (cal-tex-arg (eval cal-tex-daily-string)) | 1416 | (cal-tex-arg (eval cal-tex-daily-string t)) |
| 1401 | (insert "%\n") | 1417 | (insert "%\n") |
| 1402 | (if cal-tex-rules | 1418 | (insert (if cal-tex-rules |
| 1403 | (insert "\\linesfill\n") | 1419 | "\\linesfill\n" |
| 1404 | (insert "\\vfill")) | 1420 | "\\vfill")) |
| 1405 | (setq date (cal-tex-incr-date date))) | 1421 | (setq date (cal-tex-incr-date date))) |
| 1406 | (or cal-tex-rules | 1422 | (or cal-tex-rules |
| 1407 | (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) | 1423 | (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) |
| @@ -1442,12 +1458,15 @@ a buffer position to use instead of point." | |||
| 1442 | (cal-tex-end-document) | 1458 | (cal-tex-end-document) |
| 1443 | (run-hooks 'cal-tex-hook))) | 1459 | (run-hooks 'cal-tex-hook))) |
| 1444 | 1460 | ||
| 1445 | (defun cal-tex-daily-page (date) | 1461 | (defun cal-tex-daily-page (thedate) |
| 1446 | "Make a calendar page for Gregorian DATE on 8.5 by 11 paper. | 1462 | "Make a calendar page for Gregorian THEDATE on 8.5 by 11 paper. |
| 1447 | Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces | 1463 | Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces |
| 1448 | hourly sections for the period specified by `cal-tex-daily-start' | 1464 | hourly sections for the period specified by `cal-tex-daily-start' |
| 1449 | and `cal-tex-daily-end'." | 1465 | and `cal-tex-daily-end'." |
| 1450 | (let ((month-name (cal-tex-month-name (calendar-extract-month date))) | 1466 | (with-suppressed-warnings ((lexical date)) |
| 1467 | (defvar date)) ;For `cal-tex-daily-string'. | ||
| 1468 | (let ((date thedate) | ||
| 1469 | (month-name (cal-tex-month-name (calendar-extract-month date))) | ||
| 1451 | (i (1- cal-tex-daily-start)) | 1470 | (i (1- cal-tex-daily-start)) |
| 1452 | hour) | 1471 | hour) |
| 1453 | (cal-tex-banner "cal-tex-daily-page") | 1472 | (cal-tex-banner "cal-tex-daily-page") |
| @@ -1459,7 +1478,7 @@ and `cal-tex-daily-end'." | |||
| 1459 | (cal-tex-bf month-name ) | 1478 | (cal-tex-bf month-name ) |
| 1460 | (cal-tex-e-parbox) | 1479 | (cal-tex-e-parbox) |
| 1461 | (cal-tex-hspace "1cm") | 1480 | (cal-tex-hspace "1cm") |
| 1462 | (cal-tex-scriptsize (eval cal-tex-daily-string)) | 1481 | (cal-tex-scriptsize (eval cal-tex-daily-string t)) |
| 1463 | (cal-tex-hspace "3.5cm") | 1482 | (cal-tex-hspace "3.5cm") |
| 1464 | (cal-tex-e-makebox) | 1483 | (cal-tex-e-makebox) |
| 1465 | (cal-tex-hfill) | 1484 | (cal-tex-hfill) |
diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el index 1c19a60db10..ca303ce39ae 100644 --- a/lisp/calendar/cal-x.el +++ b/lisp/calendar/cal-x.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cal-x.el --- calendar windows in dedicated frames | 1 | ;;; cal-x.el --- calendar windows in dedicated frames -*- lexical-binding: t; -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 21cea212e18..3f9fe1c9d8f 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el | |||
| @@ -112,6 +112,8 @@ | |||
| 112 | 112 | ||
| 113 | ;;; Code: | 113 | ;;; Code: |
| 114 | 114 | ||
| 115 | (eval-when-compile (require 'subr-x)) | ||
| 116 | |||
| 115 | (load "cal-loaddefs" nil t) | 117 | (load "cal-loaddefs" nil t) |
| 116 | 118 | ||
| 117 | ;; Calendar has historically relied heavily on dynamic scoping. | 119 | ;; Calendar has historically relied heavily on dynamic scoping. |
| @@ -1459,7 +1461,7 @@ Optional integers MON and YR are used instead of today's date." | |||
| 1459 | Inserts STRING so that it ends at INDENT. STRING is either a | 1461 | Inserts STRING so that it ends at INDENT. STRING is either a |
| 1460 | literal string, or a sexp to evaluate to return such. Truncates | 1462 | literal string, or a sexp to evaluate to return such. Truncates |
| 1461 | STRING to length TRUNCATE, and ensures a trailing space." | 1463 | STRING to length TRUNCATE, and ensures a trailing space." |
| 1462 | (if (not (ignore-errors (stringp (setq string (eval string))))) | 1464 | (if (not (ignore-errors (stringp (setq string (eval string t))))) |
| 1463 | (calendar-move-to-column indent) | 1465 | (calendar-move-to-column indent) |
| 1464 | (if (> (string-width string) truncate) | 1466 | (if (> (string-width string) truncate) |
| 1465 | (setq string (truncate-string-to-width string truncate))) | 1467 | (setq string (truncate-string-to-width string truncate))) |
| @@ -1526,7 +1528,7 @@ first INDENT characters on the line." | |||
| 1526 | (format (format "%%%dd" calendar-day-digit-width) day) | 1528 | (format (format "%%%dd" calendar-day-digit-width) day) |
| 1527 | 'mouse-face 'highlight | 1529 | 'mouse-face 'highlight |
| 1528 | 'help-echo (calendar-dlet* ((day day) (month month) (year year)) | 1530 | 'help-echo (calendar-dlet* ((day day) (month month) (year year)) |
| 1529 | (eval calendar-date-echo-text)) | 1531 | (eval calendar-date-echo-text t)) |
| 1530 | ;; 'date property prevents intermonth text confusing re-searches. | 1532 | ;; 'date property prevents intermonth text confusing re-searches. |
| 1531 | ;; (Tried intangible, it did not really work.) | 1533 | ;; (Tried intangible, it did not really work.) |
| 1532 | 'date t) | 1534 | 'date t) |
| @@ -2054,23 +2056,40 @@ With argument ARG, jump to mark, pop it, and put point at end of ring." | |||
| 2054 | (error "%s not available in the calendar" | 2056 | (error "%s not available in the calendar" |
| 2055 | (global-key-binding (this-command-keys)))) | 2057 | (global-key-binding (this-command-keys)))) |
| 2056 | 2058 | ||
| 2059 | (defun calendar-read-sexp (prompt predicate &optional default &rest args) | ||
| 2060 | "Return an object read from the minibuffer. | ||
| 2061 | Passes PROMPT, DEFAULT, and ARGS to `format-prompt' to build | ||
| 2062 | the actual prompt. PREDICATE is called with a single value (the object | ||
| 2063 | the user entered) and it should return non-nil if that value is a valid choice. | ||
| 2064 | DEFAULT is the default value to use." | ||
| 2065 | (unless (stringp default) (setq default (format "%S" default))) | ||
| 2066 | (named-let query () | ||
| 2067 | ;; The call to `read-from-minibuffer' is copied from `read-minibuffer', | ||
| 2068 | ;; except it's changed to use the DEFAULT arg instead of INITIAL-CONTENTS. | ||
| 2069 | (let ((value (read-from-minibuffer | ||
| 2070 | (apply #'format-prompt prompt default args) | ||
| 2071 | nil minibuffer-local-map t 'minibuffer-history default))) | ||
| 2072 | (if (funcall predicate value) | ||
| 2073 | value | ||
| 2074 | (query))))) | ||
| 2075 | |||
| 2057 | (defun calendar-read (prompt acceptable &optional initial-contents) | 2076 | (defun calendar-read (prompt acceptable &optional initial-contents) |
| 2058 | "Return an object read from the minibuffer. | 2077 | "Return an object read from the minibuffer. |
| 2059 | Prompt with the string PROMPT and use the function ACCEPTABLE to decide | 2078 | Prompt with the string PROMPT and use the function ACCEPTABLE to decide |
| 2060 | if entered item is acceptable. If non-nil, optional third arg | 2079 | if entered item is acceptable. If non-nil, optional third arg |
| 2061 | INITIAL-CONTENTS is a string to insert in the minibuffer before reading." | 2080 | INITIAL-CONTENTS is a string to insert in the minibuffer before reading." |
| 2081 | (declare (obsolete calendar-read-sexp "28.1")) | ||
| 2062 | (let ((value (read-minibuffer prompt initial-contents))) | 2082 | (let ((value (read-minibuffer prompt initial-contents))) |
| 2063 | (while (not (funcall acceptable value)) | 2083 | (while (not (funcall acceptable value)) |
| 2064 | (setq value (read-minibuffer prompt initial-contents))) | 2084 | (setq value (read-minibuffer prompt initial-contents))) |
| 2065 | value)) | 2085 | value)) |
| 2066 | 2086 | ||
| 2067 | |||
| 2068 | (defun calendar-customized-p (symbol) | 2087 | (defun calendar-customized-p (symbol) |
| 2069 | "Return non-nil if SYMBOL has been customized." | 2088 | "Return non-nil if SYMBOL has been customized." |
| 2070 | (and (default-boundp symbol) | 2089 | (and (default-boundp symbol) |
| 2071 | (let ((standard (get symbol 'standard-value))) | 2090 | (let ((standard (get symbol 'standard-value))) |
| 2072 | (and standard | 2091 | (and standard |
| 2073 | (not (equal (eval (car standard)) (default-value symbol))))))) | 2092 | (not (equal (eval (car standard) t) (default-value symbol))))))) |
| 2074 | 2093 | ||
| 2075 | (defun calendar-abbrev-construct (full &optional maxlen) | 2094 | (defun calendar-abbrev-construct (full &optional maxlen) |
| 2076 | "From sequence FULL, return a vector of abbreviations. | 2095 | "From sequence FULL, return a vector of abbreviations. |
| @@ -2284,32 +2303,38 @@ arguments SEQUENCES." | |||
| 2284 | (append (list sequence) sequences)) | 2303 | (append (list sequence) sequences)) |
| 2285 | (reverse alist))) | 2304 | (reverse alist))) |
| 2286 | 2305 | ||
| 2287 | (defun calendar-read-date (&optional noday) | 2306 | (defun calendar-read-date (&optional noday default-date) |
| 2288 | "Prompt for Gregorian date. Return a list (month day year). | 2307 | "Prompt for Gregorian date. Return a list (month day year). |
| 2289 | If optional NODAY is t, does not ask for day, but just returns | 2308 | If optional NODAY is t, does not ask for day, but just returns |
| 2290 | \(month 1 year); if NODAY is any other non-nil value the value | 2309 | \(month 1 year); if NODAY is any other non-nil value the value |
| 2291 | returned is (month year)." | 2310 | returned is (month year)." |
| 2292 | (let* ((year (calendar-read | 2311 | (unless default-date (setq default-date (calendar-current-date))) |
| 2293 | "Year (>0): " | 2312 | (let* ((defyear (calendar-extract-year default-date)) |
| 2294 | (lambda (x) (> x 0)) | 2313 | (year (calendar-read-sexp "Year (>0)" |
| 2295 | (number-to-string (calendar-extract-year | 2314 | (lambda (x) (> x 0)) |
| 2296 | (calendar-current-date))))) | 2315 | defyear)) |
| 2297 | (month-array calendar-month-name-array) | 2316 | (month-array calendar-month-name-array) |
| 2317 | (defmon (aref month-array (1- (calendar-extract-month default-date)))) | ||
| 2298 | (completion-ignore-case t) | 2318 | (completion-ignore-case t) |
| 2299 | (month (cdr (assoc-string | 2319 | (month (cdr (assoc-string |
| 2300 | (completing-read | 2320 | (completing-read |
| 2301 | "Month name: " | 2321 | (format-prompt "Month name" defmon) |
| 2302 | (mapcar #'list (append month-array nil)) | 2322 | (append month-array nil) |
| 2303 | nil t) | 2323 | nil t nil nil defmon) |
| 2304 | (calendar-make-alist month-array 1) t))) | 2324 | (calendar-make-alist month-array 1) t))) |
| 2325 | (defday (calendar-extract-day default-date)) | ||
| 2305 | (last (calendar-last-day-of-month month year))) | 2326 | (last (calendar-last-day-of-month month year))) |
| 2306 | (if noday | 2327 | (if noday |
| 2307 | (if (eq noday t) | 2328 | (if (eq noday t) |
| 2308 | (list month 1 year) | 2329 | (list month 1 year) |
| 2309 | (list month year)) | 2330 | (list month year)) |
| 2310 | (list month | 2331 | (list month |
| 2311 | (calendar-read (format "Day (1-%d): " last) | 2332 | (calendar-read-sexp "Day (1-%d)" |
| 2312 | (lambda (x) (and (< 0 x) (<= x last)))) | 2333 | (lambda (x) (and (< 0 x) (<= x last))) |
| 2334 | ;; Don't offer today's day as default | ||
| 2335 | ;; if it's not valid for the chosen | ||
| 2336 | ;; month/year. | ||
| 2337 | (if (<= defday last) defday) last) | ||
| 2313 | year)))) | 2338 | year)))) |
| 2314 | 2339 | ||
| 2315 | (defun calendar-interval (mon1 yr1 mon2 yr2) | 2340 | (defun calendar-interval (mon1 yr1 mon2 yr2) |
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index aad70161f9f..4efa3669967 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el | |||
| @@ -2221,8 +2221,8 @@ Prefix argument ARG makes the entry nonmarking." | |||
| 2221 | (diary-make-entry | 2221 | (diary-make-entry |
| 2222 | (format "%s(diary-cyclic %d %s)" | 2222 | (format "%s(diary-cyclic %d %s)" |
| 2223 | diary-sexp-entry-symbol | 2223 | diary-sexp-entry-symbol |
| 2224 | (calendar-read "Repeat every how many days: " | 2224 | (calendar-read-sexp "Repeat every how many days" |
| 2225 | (lambda (x) (> x 0))) | 2225 | (lambda (x) (> x 0))) |
| 2226 | (calendar-date-string (calendar-cursor-to-date t) nil t)) | 2226 | (calendar-date-string (calendar-cursor-to-date t) nil t)) |
| 2227 | arg))) | 2227 | arg))) |
| 2228 | 2228 | ||
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index 932993beba0..4bc17de3067 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el | |||
| @@ -423,16 +423,15 @@ of a holiday list. | |||
| 423 | 423 | ||
| 424 | The optional LABEL is used to label the buffer created." | 424 | The optional LABEL is used to label the buffer created." |
| 425 | (interactive | 425 | (interactive |
| 426 | (let* ((start-year (calendar-read | 426 | (let* ((start-year (calendar-read-sexp |
| 427 | "Starting year of holidays (>0): " | 427 | "Starting year of holidays (>0)" |
| 428 | (lambda (x) (> x 0)) | 428 | (lambda (x) (> x 0)) |
| 429 | (number-to-string (calendar-extract-year | 429 | (calendar-extract-year (calendar-current-date)))) |
| 430 | (calendar-current-date))))) | 430 | (end-year (calendar-read-sexp |
| 431 | (end-year (calendar-read | 431 | "Ending year (inclusive) of holidays (>=%s)" |
| 432 | (format "Ending year (inclusive) of holidays (>=%s): " | ||
| 433 | start-year) | ||
| 434 | (lambda (x) (>= x start-year)) | 432 | (lambda (x) (>= x start-year)) |
| 435 | (number-to-string start-year))) | 433 | start-year |
| 434 | start-year)) | ||
| 436 | (completion-ignore-case t) | 435 | (completion-ignore-case t) |
| 437 | (lists | 436 | (lists |
| 438 | (list | 437 | (list |
diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el index 7799746e0c4..810d6ef3bd4 100644 --- a/lisp/cedet/ede/base.el +++ b/lisp/cedet/ede/base.el | |||
| @@ -160,16 +160,13 @@ and querying them will cause the actual project to get loaded.") | |||
| 160 | ;; Projects can also affect how EDE works, by changing what appears in | 160 | ;; Projects can also affect how EDE works, by changing what appears in |
| 161 | ;; the EDE menu, or how some keys are bound. | 161 | ;; the EDE menu, or how some keys are bound. |
| 162 | ;; | 162 | ;; |
| 163 | (unless (fboundp 'ede-target-list-p) | ||
| 164 | (cl-deftype ede-target-list () '(list-of ede-target))) | ||
| 165 | |||
| 166 | (defclass ede-project (ede-project-placeholder) | 163 | (defclass ede-project (ede-project-placeholder) |
| 167 | ((subproj :initform nil | 164 | ((subproj :initform nil |
| 168 | :type list | 165 | :type list |
| 169 | :documentation "Sub projects controlled by this project. | 166 | :documentation "Sub projects controlled by this project. |
| 170 | For Automake based projects, each directory is treated as a project.") | 167 | For Automake based projects, each directory is treated as a project.") |
| 171 | (targets :initarg :targets | 168 | (targets :initarg :targets |
| 172 | :type ede-target-list | 169 | :type (list-of ede-target) |
| 173 | :custom (repeat (object :objectcreatefcn ede-new-target-custom)) | 170 | :custom (repeat (object :objectcreatefcn ede-new-target-custom)) |
| 174 | :label "Local Targets" | 171 | :label "Local Targets" |
| 175 | :group (targets) | 172 | :group (targets) |
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el index 59628ebf4c9..4af8b4104f5 100644 --- a/lisp/cedet/ede/proj.el +++ b/lisp/cedet/ede/proj.el | |||
| @@ -184,7 +184,7 @@ Target variables are always renamed such as foo_CFLAGS, then included into | |||
| 184 | commands where the variable would usually appear.") | 184 | commands where the variable would usually appear.") |
| 185 | (rules :initarg :rules | 185 | (rules :initarg :rules |
| 186 | :initform nil | 186 | :initform nil |
| 187 | :type list | 187 | :type (list-of ede-makefile-rule) |
| 188 | :custom (repeat (object :objecttype ede-makefile-rule)) | 188 | :custom (repeat (object :objecttype ede-makefile-rule)) |
| 189 | :label "Additional Rules" | 189 | :label "Additional Rules" |
| 190 | :group (make) | 190 | :group (make) |
diff --git a/lisp/comint.el b/lisp/comint.el index 53153af7d27..e52d67d0e50 100644 --- a/lisp/comint.el +++ b/lisp/comint.el | |||
| @@ -3863,7 +3863,11 @@ REGEXP-GROUP is the regular expression group in REGEXP to use." | |||
| 3863 | (push (buffer-substring-no-properties | 3863 | (push (buffer-substring-no-properties |
| 3864 | (match-beginning regexp-group) | 3864 | (match-beginning regexp-group) |
| 3865 | (match-end regexp-group)) | 3865 | (match-end regexp-group)) |
| 3866 | results)) | 3866 | results) |
| 3867 | (when (zerop (length (match-string 0))) | ||
| 3868 | ;; If the regexp can be empty (for instance, "^.*$"), we | ||
| 3869 | ;; don't advance, so ensure forward progress. | ||
| 3870 | (forward-line 1))) | ||
| 3867 | (nreverse results)))) | 3871 | (nreverse results)))) |
| 3868 | 3872 | ||
| 3869 | ;; Converting process modes to use comint mode | 3873 | ;; Converting process modes to use comint mode |
diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 0293d34d1cd..27fdb723441 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el | |||
| @@ -880,7 +880,7 @@ since it could result in memory overflow and make Emacs crash." | |||
| 880 | ;; Don't re-add to custom-delayed-init-variables post-startup. | 880 | ;; Don't re-add to custom-delayed-init-variables post-startup. |
| 881 | (unless after-init-time | 881 | (unless after-init-time |
| 882 | ;; Note this is the _only_ initialize property we handle. | 882 | ;; Note this is the _only_ initialize property we handle. |
| 883 | (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay) | 883 | (if (eq (cadr (memq :initialize rest)) #'custom-initialize-delay) |
| 884 | ;; These vars are defined early and should hence be initialized | 884 | ;; These vars are defined early and should hence be initialized |
| 885 | ;; early, even if this file happens to be loaded late. so add them | 885 | ;; early, even if this file happens to be loaded late. so add them |
| 886 | ;; to the end of custom-delayed-init-variables. Otherwise, | 886 | ;; to the end of custom-delayed-init-variables. Otherwise, |
diff --git a/lisp/custom.el b/lisp/custom.el index 58ecd0439ad..5e354c4c595 100644 --- a/lisp/custom.el +++ b/lisp/custom.el | |||
| @@ -125,17 +125,7 @@ This is used in files that are preloaded (or for autoloaded | |||
| 125 | variables), so that the initialization is done in the run-time | 125 | variables), so that the initialization is done in the run-time |
| 126 | context rather than the build-time context. This also has the | 126 | context rather than the build-time context. This also has the |
| 127 | side-effect that the (delayed) initialization is performed with | 127 | side-effect that the (delayed) initialization is performed with |
| 128 | the :set function. | 128 | the :set function." |
| 129 | |||
| 130 | For variables in preloaded files, you can simply use this | ||
| 131 | function for the :initialize property. For autoloaded variables, | ||
| 132 | you will also need to add an autoload stanza calling this | ||
| 133 | function, and another one setting the standard-value property. | ||
| 134 | Or you can wrap the defcustom in a progn, to force the autoloader | ||
| 135 | to include all of it." ; see eg vc-sccs-search-project-dir | ||
| 136 | ;; No longer true: | ||
| 137 | ;; "See `send-mail-function' in sendmail.el for an example." | ||
| 138 | |||
| 139 | ;; Defvar it so as to mark it special, etc (bug#25770). | 129 | ;; Defvar it so as to mark it special, etc (bug#25770). |
| 140 | (internal--define-uninitialized-variable symbol) | 130 | (internal--define-uninitialized-variable symbol) |
| 141 | 131 | ||
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 5a96742fda9..c765e4be45d 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el | |||
| @@ -1168,7 +1168,10 @@ ARGS are command switches passed to PROGRAM.") | |||
| 1168 | ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o") | 1168 | ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o") |
| 1169 | ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o") | 1169 | ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o") |
| 1170 | ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o") | 1170 | ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o") |
| 1171 | ("\\.zip\\'" . "zip %o -r --filesync %i")) | 1171 | ("\\.tar\\.lz\\'" . "tar -cf - %i | lzip -c9 > %o") |
| 1172 | ("\\.tar\\.lzo\\'" . "tar -cf - %i | lzop -c9 > %o") | ||
| 1173 | ("\\.zip\\'" . "zip %o -r --filesync %i") | ||
| 1174 | ("\\.pax\\'" . "pax -wf %o %i")) | ||
| 1172 | "Control the compression shell command for `dired-do-compress-to'. | 1175 | "Control the compression shell command for `dired-do-compress-to'. |
| 1173 | 1176 | ||
| 1174 | Each element is (REGEXP . CMD), where REGEXP is the name of the | 1177 | Each element is (REGEXP . CMD), where REGEXP is the name of the |
diff --git a/lisp/dired-x.el b/lisp/dired-x.el index aebffe339eb..5a52eccbbe3 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el | |||
| @@ -1483,7 +1483,7 @@ a prefix argument, when it offers the filename near point as a default." | |||
| 1483 | ;;; Internal functions. | 1483 | ;;; Internal functions. |
| 1484 | 1484 | ||
| 1485 | ;; Fixme: This should probably use `thing-at-point'. -- fx | 1485 | ;; Fixme: This should probably use `thing-at-point'. -- fx |
| 1486 | (define-obsolete-function-alias 'dired-file-name-at-point | 1486 | (define-obsolete-function-alias 'dired-filename-at-point |
| 1487 | #'dired-x-guess-file-name-at-point "28.1") | 1487 | #'dired-x-guess-file-name-at-point "28.1") |
| 1488 | (defun dired-x-guess-file-name-at-point () | 1488 | (defun dired-x-guess-file-name-at-point () |
| 1489 | "Return the filename closest to point, expanded. | 1489 | "Return the filename closest to point, expanded. |
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index cf89456541e..66a117fccc8 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el | |||
| @@ -284,8 +284,10 @@ | |||
| 284 | ;; If `fn' is from the same file, it has already | 284 | ;; If `fn' is from the same file, it has already |
| 285 | ;; been preprocessed! | 285 | ;; been preprocessed! |
| 286 | `(function ,fn) | 286 | `(function ,fn) |
| 287 | (byte-compile-preprocess | 287 | ;; Try and process it "in its original environment". |
| 288 | (byte-compile--reify-function fn))))) | 288 | (let ((byte-compile-bound-variables nil)) |
| 289 | (byte-compile-preprocess | ||
| 290 | (byte-compile--reify-function fn)))))) | ||
| 289 | (if (eq (car-safe newfn) 'function) | 291 | (if (eq (car-safe newfn) 'function) |
| 290 | (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) | 292 | (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) |
| 291 | ;; This can happen because of macroexp-warn-and-return &co. | 293 | ;; This can happen because of macroexp-warn-and-return &co. |
| @@ -374,185 +376,184 @@ | |||
| 374 | ;; the important aspect is that they are subrs that don't evaluate all of | 376 | ;; the important aspect is that they are subrs that don't evaluate all of |
| 375 | ;; their args.) | 377 | ;; their args.) |
| 376 | ;; | 378 | ;; |
| 377 | (let ((fn (car-safe form)) | 379 | ;; FIXME: There are a bunch of `byte-compile-warn' here which arguably |
| 378 | tmp) | 380 | ;; have no place in an optimizer: the corresponding tests should be |
| 379 | (cond ((not (consp form)) | 381 | ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'. |
| 380 | (if (not (and for-effect | 382 | (let ((fn (car-safe form))) |
| 381 | (or byte-compile-delete-errors | 383 | (pcase form |
| 382 | (not (symbolp form)) | 384 | ((pred (not consp)) |
| 383 | (eq form t)))) | 385 | (if (not (and for-effect |
| 384 | form)) | 386 | (or byte-compile-delete-errors |
| 385 | ((eq fn 'quote) | 387 | (not (symbolp form)) |
| 386 | (if (cdr (cdr form)) | 388 | (eq form t)))) |
| 387 | (byte-compile-warn "malformed quote form: `%s'" | 389 | form)) |
| 388 | (prin1-to-string form))) | 390 | (`(quote . ,v) |
| 389 | ;; map (quote nil) to nil to simplify optimizer logic. | 391 | (if (cdr v) |
| 390 | ;; map quoted constants to nil if for-effect (just because). | 392 | (byte-compile-warn "malformed quote form: `%s'" |
| 391 | (and (nth 1 form) | 393 | (prin1-to-string form))) |
| 392 | (not for-effect) | 394 | ;; Map (quote nil) to nil to simplify optimizer logic. |
| 393 | form)) | 395 | ;; Map quoted constants to nil if for-effect (just because). |
| 394 | ((memq fn '(let let*)) | 396 | (and (car v) |
| 395 | ;; recursively enter the optimizer for the bindings and body | 397 | (not for-effect) |
| 396 | ;; of a let or let*. This for depth-firstness: forms that | 398 | form)) |
| 397 | ;; are more deeply nested are optimized first. | 399 | (`(,(or 'let 'let*) . ,(or `(,bindings . ,exps) pcase--dontcare)) |
| 398 | (cons fn | 400 | ;; Recursively enter the optimizer for the bindings and body |
| 401 | ;; of a let or let*. This for depth-firstness: forms that | ||
| 402 | ;; are more deeply nested are optimized first. | ||
| 403 | (cons fn | ||
| 399 | (cons | 404 | (cons |
| 400 | (mapcar (lambda (binding) | 405 | (mapcar (lambda (binding) |
| 401 | (if (symbolp binding) | 406 | (if (symbolp binding) |
| 402 | binding | 407 | binding |
| 403 | (if (cdr (cdr binding)) | 408 | (if (cdr (cdr binding)) |
| 404 | (byte-compile-warn "malformed let binding: `%s'" | 409 | (byte-compile-warn "malformed let binding: `%s'" |
| 405 | (prin1-to-string binding))) | 410 | (prin1-to-string binding))) |
| 406 | (list (car binding) | 411 | (list (car binding) |
| 407 | (byte-optimize-form (nth 1 binding) nil)))) | 412 | (byte-optimize-form (nth 1 binding) nil)))) |
| 408 | (nth 1 form)) | 413 | bindings) |
| 409 | (byte-optimize-body (cdr (cdr form)) for-effect)))) | 414 | (byte-optimize-body exps for-effect)))) |
| 410 | ((eq fn 'cond) | 415 | (`(cond . ,clauses) |
| 411 | (cons fn | 416 | (cons fn |
| 412 | (mapcar (lambda (clause) | 417 | (mapcar (lambda (clause) |
| 413 | (if (consp clause) | 418 | (if (consp clause) |
| 414 | (cons | 419 | (cons |
| 415 | (byte-optimize-form (car clause) nil) | 420 | (byte-optimize-form (car clause) nil) |
| 416 | (byte-optimize-body (cdr clause) for-effect)) | 421 | (byte-optimize-body (cdr clause) for-effect)) |
| 417 | (byte-compile-warn "malformed cond form: `%s'" | 422 | (byte-compile-warn "malformed cond form: `%s'" |
| 418 | (prin1-to-string clause)) | 423 | (prin1-to-string clause)) |
| 419 | clause)) | 424 | clause)) |
| 420 | (cdr form)))) | 425 | clauses))) |
| 421 | ((eq fn 'progn) | 426 | (`(progn . ,exps) |
| 422 | ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. | 427 | ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. |
| 423 | (if (cdr (cdr form)) | 428 | (if (cdr exps) |
| 424 | (macroexp-progn (byte-optimize-body (cdr form) for-effect)) | 429 | (macroexp-progn (byte-optimize-body exps for-effect)) |
| 425 | (byte-optimize-form (nth 1 form) for-effect))) | 430 | (byte-optimize-form (car exps) for-effect))) |
| 426 | ((eq fn 'prog1) | 431 | (`(prog1 . ,(or `(,exp . ,exps) pcase--dontcare)) |
| 427 | (if (cdr (cdr form)) | 432 | (if exps |
| 428 | (cons 'prog1 | 433 | `(prog1 ,(byte-optimize-form exp for-effect) |
| 429 | (cons (byte-optimize-form (nth 1 form) for-effect) | 434 | . ,(byte-optimize-body exps t)) |
| 430 | (byte-optimize-body (cdr (cdr form)) t))) | 435 | (byte-optimize-form exp for-effect))) |
| 431 | (byte-optimize-form (nth 1 form) for-effect))) | 436 | |
| 432 | 437 | (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) | |
| 433 | ((memq fn '(save-excursion save-restriction save-current-buffer)) | 438 | ;; Those subrs which have an implicit progn; it's not quite good |
| 434 | ;; those subrs which have an implicit progn; it's not quite good | 439 | ;; enough to treat these like normal function calls. |
| 435 | ;; enough to treat these like normal function calls. | 440 | ;; This can turn (save-excursion ...) into (save-excursion) which |
| 436 | ;; This can turn (save-excursion ...) into (save-excursion) which | 441 | ;; will be optimized away in the lap-optimize pass. |
| 437 | ;; will be optimized away in the lap-optimize pass. | 442 | (cons fn (byte-optimize-body exps for-effect))) |
| 438 | (cons fn (byte-optimize-body (cdr form) for-effect))) | 443 | |
| 439 | 444 | (`(if ,test ,then . ,else) | |
| 440 | ((eq fn 'if) | 445 | `(if ,(byte-optimize-form test nil) |
| 441 | (when (< (length form) 3) | 446 | ,(byte-optimize-form then for-effect) |
| 442 | (byte-compile-warn "too few arguments for `if'")) | 447 | . ,(byte-optimize-body else for-effect))) |
| 443 | (cons fn | 448 | (`(if . ,_) |
| 444 | (cons (byte-optimize-form (nth 1 form) nil) | 449 | (byte-compile-warn "too few arguments for `if'")) |
| 445 | (cons | 450 | |
| 446 | (byte-optimize-form (nth 2 form) for-effect) | 451 | (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. |
| 447 | (byte-optimize-body (nthcdr 3 form) for-effect))))) | 452 | ;; Take forms off the back until we can't any more. |
| 448 | 453 | ;; In the future it could conceivably be a problem that the | |
| 449 | ((memq fn '(and or)) ; Remember, and/or are control structures. | 454 | ;; subexpressions of these forms are optimized in the reverse |
| 450 | ;; Take forms off the back until we can't any more. | 455 | ;; order, but it's ok for now. |
| 451 | ;; In the future it could conceivably be a problem that the | 456 | (if for-effect |
| 452 | ;; subexpressions of these forms are optimized in the reverse | 457 | (let ((backwards (reverse exps))) |
| 453 | ;; order, but it's ok for now. | 458 | (while (and backwards |
| 454 | (if for-effect | 459 | (null (setcar backwards |
| 455 | (let ((backwards (reverse (cdr form)))) | 460 | (byte-optimize-form (car backwards) |
| 456 | (while (and backwards | 461 | for-effect)))) |
| 457 | (null (setcar backwards | 462 | (setq backwards (cdr backwards))) |
| 458 | (byte-optimize-form (car backwards) | 463 | (if (and exps (null backwards)) |
| 459 | for-effect)))) | 464 | (byte-compile-log |
| 460 | (setq backwards (cdr backwards))) | 465 | " all subforms of %s called for effect; deleted" form)) |
| 461 | (if (and (cdr form) (null backwards)) | 466 | (and backwards |
| 462 | (byte-compile-log | 467 | (cons fn (nreverse (mapcar #'byte-optimize-form |
| 463 | " all subforms of %s called for effect; deleted" form)) | 468 | backwards))))) |
| 464 | (and backwards | 469 | (cons fn (mapcar #'byte-optimize-form exps)))) |
| 465 | (cons fn (nreverse (mapcar 'byte-optimize-form | 470 | |
| 466 | backwards))))) | 471 | (`(while ,exp . ,exps) |
| 467 | (cons fn (mapcar 'byte-optimize-form (cdr form))))) | 472 | `(while ,(byte-optimize-form exp nil) |
| 468 | 473 | . ,(byte-optimize-body exps t))) | |
| 469 | ((eq fn 'while) | 474 | (`(while . ,_) |
| 470 | (unless (consp (cdr form)) | 475 | (byte-compile-warn "too few arguments for `while'")) |
| 471 | (byte-compile-warn "too few arguments for `while'")) | 476 | |
| 472 | (cons fn | 477 | (`(interactive . ,_) |
| 473 | (cons (byte-optimize-form (cadr form) nil) | 478 | (byte-compile-warn "misplaced interactive spec: `%s'" |
| 474 | (byte-optimize-body (cddr form) t)))) | 479 | (prin1-to-string form)) |
| 475 | 480 | nil) | |
| 476 | ((eq fn 'interactive) | 481 | |
| 477 | (byte-compile-warn "misplaced interactive spec: `%s'" | 482 | (`(function . ,_) |
| 478 | (prin1-to-string form)) | 483 | ;; This forms is compiled as constant or by breaking out |
| 479 | nil) | 484 | ;; all the subexpressions and compiling them separately. |
| 480 | 485 | form) | |
| 481 | ((eq fn 'function) | ||
| 482 | ;; This forms is compiled as constant or by breaking out | ||
| 483 | ;; all the subexpressions and compiling them separately. | ||
| 484 | form) | ||
| 485 | |||
| 486 | ((eq fn 'condition-case) | ||
| 487 | `(condition-case ,(nth 1 form) ;Not evaluated. | ||
| 488 | ,(byte-optimize-form (nth 2 form) for-effect) | ||
| 489 | ,@(mapcar (lambda (clause) | ||
| 490 | `(,(car clause) | ||
| 491 | ,@(byte-optimize-body (cdr clause) for-effect))) | ||
| 492 | (nthcdr 3 form)))) | ||
| 493 | |||
| 494 | ((eq fn 'unwind-protect) | ||
| 495 | ;; the "protected" part of an unwind-protect is compiled (and thus | ||
| 496 | ;; optimized) as a top-level form, so don't do it here. But the | ||
| 497 | ;; non-protected part has the same for-effect status as the | ||
| 498 | ;; unwind-protect itself. (The protected part is always for effect, | ||
| 499 | ;; but that isn't handled properly yet.) | ||
| 500 | (cons fn | ||
| 501 | (cons (byte-optimize-form (nth 1 form) for-effect) | ||
| 502 | (cdr (cdr form))))) | ||
| 503 | |||
| 504 | ((eq fn 'catch) | ||
| 505 | (cons fn | ||
| 506 | (cons (byte-optimize-form (nth 1 form) nil) | ||
| 507 | (byte-optimize-body (cdr form) for-effect)))) | ||
| 508 | |||
| 509 | ((eq fn 'ignore) | ||
| 510 | ;; Don't treat the args to `ignore' as being | ||
| 511 | ;; computed for effect. We want to avoid the warnings | ||
| 512 | ;; that might occur if they were treated that way. | ||
| 513 | ;; However, don't actually bother calling `ignore'. | ||
| 514 | `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) | ||
| 515 | |||
| 516 | ;; Needed as long as we run byte-optimize-form after cconv. | ||
| 517 | ((eq fn 'internal-make-closure) form) | ||
| 518 | |||
| 519 | ((eq (car-safe fn) 'lambda) | ||
| 520 | (let ((newform (byte-compile-unfold-lambda form))) | ||
| 521 | (if (eq newform form) | ||
| 522 | ;; Some error occurred, avoid infinite recursion | ||
| 523 | form | ||
| 524 | (byte-optimize-form newform for-effect)))) | ||
| 525 | |||
| 526 | ((eq (car-safe fn) 'closure) form) | ||
| 527 | |||
| 528 | ((byte-code-function-p fn) | ||
| 529 | (cons fn (mapcar #'byte-optimize-form (cdr form)))) | ||
| 530 | |||
| 531 | ((not (symbolp fn)) | ||
| 532 | (byte-compile-warn "`%s' is a malformed function" | ||
| 533 | (prin1-to-string fn)) | ||
| 534 | form) | ||
| 535 | |||
| 536 | ((and for-effect (setq tmp (get fn 'side-effect-free)) | ||
| 537 | (or byte-compile-delete-errors | ||
| 538 | (eq tmp 'error-free) | ||
| 539 | (progn | ||
| 540 | (byte-compile-warn "value returned from %s is unused" | ||
| 541 | (prin1-to-string form)) | ||
| 542 | nil))) | ||
| 543 | (byte-compile-log " %s called for effect; deleted" fn) | ||
| 544 | ;; appending a nil here might not be necessary, but it can't hurt. | ||
| 545 | (byte-optimize-form | ||
| 546 | (cons 'progn (append (cdr form) '(nil))) t)) | ||
| 547 | 486 | ||
| 548 | (t | 487 | (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare)) |
| 549 | ;; Otherwise, no args can be considered to be for-effect, | 488 | `(condition-case ,var ;Not evaluated. |
| 550 | ;; even if the called function is for-effect, because we | 489 | ,(byte-optimize-form exp for-effect) |
| 551 | ;; don't know anything about that function. | 490 | ,@(mapcar (lambda (clause) |
| 552 | (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) | 491 | `(,(car clause) |
| 553 | (if (get fn 'pure) | 492 | ,@(byte-optimize-body (cdr clause) for-effect))) |
| 554 | (byte-optimize-constant-args form) | 493 | clauses))) |
| 555 | form)))))) | 494 | |
| 495 | (`(unwind-protect . ,(or `(,exp . ,exps) pcase--dontcare)) | ||
| 496 | ;; The "protected" part of an unwind-protect is compiled (and thus | ||
| 497 | ;; optimized) as a top-level form, so don't do it here. But the | ||
| 498 | ;; non-protected part has the same for-effect status as the | ||
| 499 | ;; unwind-protect itself. (The protected part is always for effect, | ||
| 500 | ;; but that isn't handled properly yet.) | ||
| 501 | `(unwind-protect ,(byte-optimize-form exp for-effect) . ,exps)) | ||
| 502 | |||
| 503 | (`(catch . ,(or `(,tag . ,exps) pcase--dontcare)) | ||
| 504 | `(catch ,(byte-optimize-form tag nil) | ||
| 505 | . ,(byte-optimize-body exps for-effect))) | ||
| 506 | |||
| 507 | (`(ignore . ,exps) | ||
| 508 | ;; Don't treat the args to `ignore' as being | ||
| 509 | ;; computed for effect. We want to avoid the warnings | ||
| 510 | ;; that might occur if they were treated that way. | ||
| 511 | ;; However, don't actually bother calling `ignore'. | ||
| 512 | `(prog1 nil . ,(mapcar #'byte-optimize-form exps))) | ||
| 513 | |||
| 514 | ;; Needed as long as we run byte-optimize-form after cconv. | ||
| 515 | (`(internal-make-closure . ,_) form) | ||
| 516 | |||
| 517 | (`((lambda . ,_) . ,_) | ||
| 518 | (let ((newform (byte-compile-unfold-lambda form))) | ||
| 519 | (if (eq newform form) | ||
| 520 | ;; Some error occurred, avoid infinite recursion. | ||
| 521 | form | ||
| 522 | (byte-optimize-form newform for-effect)))) | ||
| 523 | |||
| 524 | ;; FIXME: Strictly speaking, I think this is a bug: (closure...) | ||
| 525 | ;; is a *value* and shouldn't appear in the car. | ||
| 526 | (`((closure . ,_) . ,_) form) | ||
| 527 | |||
| 528 | (`(,(pred byte-code-function-p) . ,exps) | ||
| 529 | (cons fn (mapcar #'byte-optimize-form exps))) | ||
| 530 | |||
| 531 | (`(,(pred (not symbolp)) . ,_) | ||
| 532 | (byte-compile-warn "`%s' is a malformed function" | ||
| 533 | (prin1-to-string fn)) | ||
| 534 | form) | ||
| 535 | |||
| 536 | ((guard (when for-effect | ||
| 537 | (if-let ((tmp (get fn 'side-effect-free))) | ||
| 538 | (or byte-compile-delete-errors | ||
| 539 | (eq tmp 'error-free) | ||
| 540 | (progn | ||
| 541 | (byte-compile-warn "value returned from %s is unused" | ||
| 542 | (prin1-to-string form)) | ||
| 543 | nil))))) | ||
| 544 | (byte-compile-log " %s called for effect; deleted" fn) | ||
| 545 | ;; appending a nil here might not be necessary, but it can't hurt. | ||
| 546 | (byte-optimize-form | ||
| 547 | (cons 'progn (append (cdr form) '(nil))) t)) | ||
| 548 | |||
| 549 | (_ | ||
| 550 | ;; Otherwise, no args can be considered to be for-effect, | ||
| 551 | ;; even if the called function is for-effect, because we | ||
| 552 | ;; don't know anything about that function. | ||
| 553 | (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) | ||
| 554 | (if (get fn 'pure) | ||
| 555 | (byte-optimize-constant-args form) | ||
| 556 | form)))))) | ||
| 556 | 557 | ||
| 557 | (defun byte-optimize-form (form &optional for-effect) | 558 | (defun byte-optimize-form (form &optional for-effect) |
| 558 | "The source-level pass of the optimizer." | 559 | "The source-level pass of the optimizer." |
| @@ -1562,467 +1563,548 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1562 | ;; You may notice that sequences like "dup varset discard" are | 1563 | ;; You may notice that sequences like "dup varset discard" are |
| 1563 | ;; optimized but sequences like "dup varset TAG1: discard" are not. | 1564 | ;; optimized but sequences like "dup varset TAG1: discard" are not. |
| 1564 | ;; You may be tempted to change this; resist that temptation. | 1565 | ;; You may be tempted to change this; resist that temptation. |
| 1565 | (cond ;; | 1566 | (cond |
| 1566 | ;; <side-effect-free> pop --> <deleted> | 1567 | ;; <side-effect-free> pop --> <deleted> |
| 1567 | ;; ...including: | 1568 | ;; ...including: |
| 1568 | ;; const-X pop --> <deleted> | 1569 | ;; const-X pop --> <deleted> |
| 1569 | ;; varref-X pop --> <deleted> | 1570 | ;; varref-X pop --> <deleted> |
| 1570 | ;; dup pop --> <deleted> | 1571 | ;; dup pop --> <deleted> |
| 1571 | ;; | 1572 | ;; |
| 1572 | ((and (eq 'byte-discard (car lap1)) | 1573 | ((and (eq 'byte-discard (car lap1)) |
| 1573 | (memq (car lap0) side-effect-free)) | 1574 | (memq (car lap0) side-effect-free)) |
| 1574 | (setq keep-going t) | 1575 | (setq keep-going t) |
| 1575 | (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) | 1576 | (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) |
| 1576 | (setq rest (cdr rest)) | 1577 | (setq rest (cdr rest)) |
| 1577 | (cond ((= tmp 1) | 1578 | (cond ((= tmp 1) |
| 1578 | (byte-compile-log-lap | 1579 | (byte-compile-log-lap |
| 1579 | " %s discard\t-->\t<deleted>" lap0) | 1580 | " %s discard\t-->\t<deleted>" lap0) |
| 1580 | (setq lap (delq lap0 (delq lap1 lap)))) | 1581 | (setq lap (delq lap0 (delq lap1 lap)))) |
| 1581 | ((= tmp 0) | 1582 | ((= tmp 0) |
| 1582 | (byte-compile-log-lap | 1583 | (byte-compile-log-lap |
| 1583 | " %s discard\t-->\t<deleted> discard" lap0) | 1584 | " %s discard\t-->\t<deleted> discard" lap0) |
| 1584 | (setq lap (delq lap0 lap))) | ||
| 1585 | ((= tmp -1) | ||
| 1586 | (byte-compile-log-lap | ||
| 1587 | " %s discard\t-->\tdiscard discard" lap0) | ||
| 1588 | (setcar lap0 'byte-discard) | ||
| 1589 | (setcdr lap0 0)) | ||
| 1590 | ((error "Optimizer error: too much on the stack")))) | ||
| 1591 | ;; | ||
| 1592 | ;; goto*-X X: --> X: | ||
| 1593 | ;; | ||
| 1594 | ((and (memq (car lap0) byte-goto-ops) | ||
| 1595 | (eq (cdr lap0) lap1)) | ||
| 1596 | (cond ((eq (car lap0) 'byte-goto) | ||
| 1597 | (setq lap (delq lap0 lap)) | ||
| 1598 | (setq tmp "<deleted>")) | ||
| 1599 | ((memq (car lap0) byte-goto-always-pop-ops) | ||
| 1600 | (setcar lap0 (setq tmp 'byte-discard)) | ||
| 1601 | (setcdr lap0 0)) | ||
| 1602 | ((error "Depth conflict at tag %d" (nth 2 lap0)))) | ||
| 1603 | (and (memq byte-optimize-log '(t byte)) | ||
| 1604 | (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" | ||
| 1605 | (nth 1 lap1) (nth 1 lap1) | ||
| 1606 | tmp (nth 1 lap1))) | ||
| 1607 | (setq keep-going t)) | ||
| 1608 | ;; | ||
| 1609 | ;; varset-X varref-X --> dup varset-X | ||
| 1610 | ;; varbind-X varref-X --> dup varbind-X | ||
| 1611 | ;; const/dup varset-X varref-X --> const/dup varset-X const/dup | ||
| 1612 | ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup | ||
| 1613 | ;; The latter two can enable other optimizations. | ||
| 1614 | ;; | ||
| 1615 | ;; For lexical variables, we could do the same | ||
| 1616 | ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 | ||
| 1617 | ;; but this is a very minor gain, since dup is stack-ref-0, | ||
| 1618 | ;; i.e. it's only better if X>5, and even then it comes | ||
| 1619 | ;; at the cost of an extra stack slot. Let's not bother. | ||
| 1620 | ((and (eq 'byte-varref (car lap2)) | ||
| 1621 | (eq (cdr lap1) (cdr lap2)) | ||
| 1622 | (memq (car lap1) '(byte-varset byte-varbind))) | ||
| 1623 | (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) | ||
| 1624 | (not (eq (car lap0) 'byte-constant))) | ||
| 1625 | nil | ||
| 1626 | (setq keep-going t) | ||
| 1627 | (if (memq (car lap0) '(byte-constant byte-dup)) | ||
| 1628 | (progn | ||
| 1629 | (setq tmp (if (or (not tmp) | ||
| 1630 | (macroexp--const-symbol-p | ||
| 1631 | (car (cdr lap0)))) | ||
| 1632 | (cdr lap0) | ||
| 1633 | (byte-compile-get-constant t))) | ||
| 1634 | (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" | ||
| 1635 | lap0 lap1 lap2 lap0 lap1 | ||
| 1636 | (cons (car lap0) tmp)) | ||
| 1637 | (setcar lap2 (car lap0)) | ||
| 1638 | (setcdr lap2 tmp)) | ||
| 1639 | (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) | ||
| 1640 | (setcar lap2 (car lap1)) | ||
| 1641 | (setcar lap1 'byte-dup) | ||
| 1642 | (setcdr lap1 0) | ||
| 1643 | ;; The stack depth gets locally increased, so we will | ||
| 1644 | ;; increase maxdepth in case depth = maxdepth here. | ||
| 1645 | ;; This can cause the third argument to byte-code to | ||
| 1646 | ;; be larger than necessary. | ||
| 1647 | (setq add-depth 1)))) | ||
| 1648 | ;; | ||
| 1649 | ;; dup varset-X discard --> varset-X | ||
| 1650 | ;; dup varbind-X discard --> varbind-X | ||
| 1651 | ;; dup stack-set-X discard --> stack-set-X-1 | ||
| 1652 | ;; (the varbind variant can emerge from other optimizations) | ||
| 1653 | ;; | ||
| 1654 | ((and (eq 'byte-dup (car lap0)) | ||
| 1655 | (eq 'byte-discard (car lap2)) | ||
| 1656 | (memq (car lap1) '(byte-varset byte-varbind | ||
| 1657 | byte-stack-set))) | ||
| 1658 | (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) | ||
| 1659 | (setq keep-going t | ||
| 1660 | rest (cdr rest)) | ||
| 1661 | (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) | ||
| 1662 | (setq lap (delq lap0 (delq lap2 lap)))) | ||
| 1663 | ;; | ||
| 1664 | ;; not goto-X-if-nil --> goto-X-if-non-nil | ||
| 1665 | ;; not goto-X-if-non-nil --> goto-X-if-nil | ||
| 1666 | ;; | ||
| 1667 | ;; it is wrong to do the same thing for the -else-pop variants. | ||
| 1668 | ;; | ||
| 1669 | ((and (eq 'byte-not (car lap0)) | ||
| 1670 | (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) | ||
| 1671 | (byte-compile-log-lap " not %s\t-->\t%s" | ||
| 1672 | lap1 | ||
| 1673 | (cons | ||
| 1674 | (if (eq (car lap1) 'byte-goto-if-nil) | ||
| 1675 | 'byte-goto-if-not-nil | ||
| 1676 | 'byte-goto-if-nil) | ||
| 1677 | (cdr lap1))) | ||
| 1678 | (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) | ||
| 1679 | 'byte-goto-if-not-nil | ||
| 1680 | 'byte-goto-if-nil)) | ||
| 1681 | (setq lap (delq lap0 lap)) | ||
| 1682 | (setq keep-going t)) | ||
| 1683 | ;; | ||
| 1684 | ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: | ||
| 1685 | ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: | ||
| 1686 | ;; | ||
| 1687 | ;; it is wrong to do the same thing for the -else-pop variants. | ||
| 1688 | ;; | ||
| 1689 | ((and (memq (car lap0) | ||
| 1690 | '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX | ||
| 1691 | (eq 'byte-goto (car lap1)) ; gotoY | ||
| 1692 | (eq (cdr lap0) lap2)) ; TAG X | ||
| 1693 | (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) | ||
| 1694 | 'byte-goto-if-not-nil 'byte-goto-if-nil))) | ||
| 1695 | (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" | ||
| 1696 | lap0 lap1 lap2 | ||
| 1697 | (cons inverse (cdr lap1)) lap2) | ||
| 1698 | (setq lap (delq lap0 lap)) | ||
| 1699 | (setcar lap1 inverse) | ||
| 1700 | (setq keep-going t))) | ||
| 1701 | ;; | ||
| 1702 | ;; const goto-if-* --> whatever | ||
| 1703 | ;; | ||
| 1704 | ((and (eq 'byte-constant (car lap0)) | ||
| 1705 | (memq (car lap1) byte-conditional-ops) | ||
| 1706 | ;; If the `byte-constant's cdr is not a cons cell, it has | ||
| 1707 | ;; to be an index into the constant pool); even though | ||
| 1708 | ;; it'll be a constant, that constant is not known yet | ||
| 1709 | ;; (it's typically a free variable of a closure, so will | ||
| 1710 | ;; only be known when the closure will be built at | ||
| 1711 | ;; run-time). | ||
| 1712 | (consp (cdr lap0))) | ||
| 1713 | (cond ((if (memq (car lap1) '(byte-goto-if-nil | ||
| 1714 | byte-goto-if-nil-else-pop)) | ||
| 1715 | (car (cdr lap0)) | ||
| 1716 | (not (car (cdr lap0)))) | ||
| 1717 | (byte-compile-log-lap " %s %s\t-->\t<deleted>" | ||
| 1718 | lap0 lap1) | ||
| 1719 | (setq rest (cdr rest) | ||
| 1720 | lap (delq lap0 (delq lap1 lap)))) | ||
| 1721 | (t | ||
| 1722 | (byte-compile-log-lap " %s %s\t-->\t%s" | ||
| 1723 | lap0 lap1 | ||
| 1724 | (cons 'byte-goto (cdr lap1))) | ||
| 1725 | (when (memq (car lap1) byte-goto-always-pop-ops) | ||
| 1726 | (setq lap (delq lap0 lap))) | ||
| 1727 | (setcar lap1 'byte-goto))) | ||
| 1728 | (setq keep-going t)) | ||
| 1729 | ;; | ||
| 1730 | ;; varref-X varref-X --> varref-X dup | ||
| 1731 | ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup | ||
| 1732 | ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup | ||
| 1733 | ;; We don't optimize the const-X variations on this here, | ||
| 1734 | ;; because that would inhibit some goto optimizations; we | ||
| 1735 | ;; optimize the const-X case after all other optimizations. | ||
| 1736 | ;; | ||
| 1737 | ((and (memq (car lap0) '(byte-varref byte-stack-ref)) | ||
| 1738 | (progn | ||
| 1739 | (setq tmp (cdr rest)) | ||
| 1740 | (setq tmp2 0) | ||
| 1741 | (while (eq (car (car tmp)) 'byte-dup) | ||
| 1742 | (setq tmp2 (1+ tmp2)) | ||
| 1743 | (setq tmp (cdr tmp))) | ||
| 1744 | t) | ||
| 1745 | (eq (if (eq 'byte-stack-ref (car lap0)) | ||
| 1746 | (+ tmp2 1 (cdr lap0)) | ||
| 1747 | (cdr lap0)) | ||
| 1748 | (cdr (car tmp))) | ||
| 1749 | (eq (car lap0) (car (car tmp)))) | ||
| 1750 | (if (memq byte-optimize-log '(t byte)) | ||
| 1751 | (let ((str "")) | ||
| 1752 | (setq tmp2 (cdr rest)) | ||
| 1753 | (while (not (eq tmp tmp2)) | ||
| 1754 | (setq tmp2 (cdr tmp2) | ||
| 1755 | str (concat str " dup"))) | ||
| 1756 | (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" | ||
| 1757 | lap0 str lap0 lap0 str))) | ||
| 1758 | (setq keep-going t) | ||
| 1759 | (setcar (car tmp) 'byte-dup) | ||
| 1760 | (setcdr (car tmp) 0) | ||
| 1761 | (setq rest tmp)) | ||
| 1762 | ;; | ||
| 1763 | ;; TAG1: TAG2: --> TAG1: <deleted> | ||
| 1764 | ;; (and other references to TAG2 are replaced with TAG1) | ||
| 1765 | ;; | ||
| 1766 | ((and (eq (car lap0) 'TAG) | ||
| 1767 | (eq (car lap1) 'TAG)) | ||
| 1768 | (and (memq byte-optimize-log '(t byte)) | ||
| 1769 | (byte-compile-log " adjacent tags %d and %d merged" | ||
| 1770 | (nth 1 lap1) (nth 1 lap0))) | ||
| 1771 | (setq tmp3 lap) | ||
| 1772 | (while (setq tmp2 (rassq lap0 tmp3)) | ||
| 1773 | (setcdr tmp2 lap1) | ||
| 1774 | (setq tmp3 (cdr (memq tmp2 tmp3)))) | ||
| 1775 | (setq lap (delq lap0 lap) | ||
| 1776 | keep-going t) | ||
| 1777 | ;; replace references to tag in jump tables, if any | ||
| 1778 | (dolist (table byte-compile-jump-tables) | ||
| 1779 | (maphash #'(lambda (value tag) | ||
| 1780 | (when (equal tag lap0) | ||
| 1781 | (puthash value lap1 table))) | ||
| 1782 | table))) | ||
| 1783 | ;; | ||
| 1784 | ;; unused-TAG: --> <deleted> | ||
| 1785 | ;; | ||
| 1786 | ((and (eq 'TAG (car lap0)) | ||
| 1787 | (not (rassq lap0 lap)) | ||
| 1788 | ;; make sure this tag isn't used in a jump-table | ||
| 1789 | (cl-loop for table in byte-compile-jump-tables | ||
| 1790 | when (member lap0 (hash-table-values table)) | ||
| 1791 | return nil finally return t)) | ||
| 1792 | (and (memq byte-optimize-log '(t byte)) | ||
| 1793 | (byte-compile-log " unused tag %d removed" (nth 1 lap0))) | ||
| 1794 | (setq lap (delq lap0 lap) | ||
| 1795 | keep-going t)) | ||
| 1796 | ;; | ||
| 1797 | ;; goto ... --> goto <delete until TAG or end> | ||
| 1798 | ;; return ... --> return <delete until TAG or end> | ||
| 1799 | ;; (unless a jump-table is being used, where deleting may affect | ||
| 1800 | ;; other valid case bodies) | ||
| 1801 | ;; | ||
| 1802 | ((and (memq (car lap0) '(byte-goto byte-return)) | ||
| 1803 | (not (memq (car lap1) '(TAG nil))) | ||
| 1804 | ;; FIXME: Instead of deferring simply when jump-tables are | ||
| 1805 | ;; being used, keep a list of tags used for switch tags and | ||
| 1806 | ;; use them instead (see `byte-compile-inline-lapcode'). | ||
| 1807 | (not byte-compile-jump-tables)) | ||
| 1808 | (setq tmp rest) | ||
| 1809 | (let ((i 0) | ||
| 1810 | (opt-p (memq byte-optimize-log '(t lap))) | ||
| 1811 | str deleted) | ||
| 1812 | (while (and (setq tmp (cdr tmp)) | ||
| 1813 | (not (eq 'TAG (car (car tmp))))) | ||
| 1814 | (if opt-p (setq deleted (cons (car tmp) deleted) | ||
| 1815 | str (concat str " %s") | ||
| 1816 | i (1+ i)))) | ||
| 1817 | (if opt-p | ||
| 1818 | (let ((tagstr | ||
| 1819 | (if (eq 'TAG (car (car tmp))) | ||
| 1820 | (format "%d:" (car (cdr (car tmp)))) | ||
| 1821 | (or (car tmp) "")))) | ||
| 1822 | (if (< i 6) | ||
| 1823 | (apply 'byte-compile-log-lap-1 | ||
| 1824 | (concat " %s" str | ||
| 1825 | " %s\t-->\t%s <deleted> %s") | ||
| 1826 | lap0 | ||
| 1827 | (nconc (nreverse deleted) | ||
| 1828 | (list tagstr lap0 tagstr))) | ||
| 1829 | (byte-compile-log-lap | ||
| 1830 | " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" | ||
| 1831 | lap0 i (if (= i 1) "" "s") | ||
| 1832 | tagstr lap0 tagstr)))) | ||
| 1833 | (rplacd rest tmp)) | ||
| 1834 | (setq keep-going t)) | ||
| 1835 | ;; | ||
| 1836 | ;; <safe-op> unbind --> unbind <safe-op> | ||
| 1837 | ;; (this may enable other optimizations.) | ||
| 1838 | ;; | ||
| 1839 | ((and (eq 'byte-unbind (car lap1)) | ||
| 1840 | (memq (car lap0) byte-after-unbind-ops)) | ||
| 1841 | (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) | ||
| 1842 | (setcar rest lap1) | ||
| 1843 | (setcar (cdr rest) lap0) | ||
| 1844 | (setq keep-going t)) | ||
| 1845 | ;; | ||
| 1846 | ;; varbind-X unbind-N --> discard unbind-(N-1) | ||
| 1847 | ;; save-excursion unbind-N --> unbind-(N-1) | ||
| 1848 | ;; save-restriction unbind-N --> unbind-(N-1) | ||
| 1849 | ;; | ||
| 1850 | ((and (eq 'byte-unbind (car lap1)) | ||
| 1851 | (memq (car lap0) '(byte-varbind byte-save-excursion | ||
| 1852 | byte-save-restriction)) | ||
| 1853 | (< 0 (cdr lap1))) | ||
| 1854 | (if (zerop (setcdr lap1 (1- (cdr lap1)))) | ||
| 1855 | (delq lap1 rest)) | ||
| 1856 | (if (eq (car lap0) 'byte-varbind) | ||
| 1857 | (setcar rest (cons 'byte-discard 0)) | ||
| 1858 | (setq lap (delq lap0 lap))) | 1585 | (setq lap (delq lap0 lap))) |
| 1859 | (byte-compile-log-lap " %s %s\t-->\t%s %s" | 1586 | ((= tmp -1) |
| 1860 | lap0 (cons (car lap1) (1+ (cdr lap1))) | 1587 | (byte-compile-log-lap |
| 1861 | (if (eq (car lap0) 'byte-varbind) | 1588 | " %s discard\t-->\tdiscard discard" lap0) |
| 1862 | (car rest) | 1589 | (setcar lap0 'byte-discard) |
| 1863 | (car (cdr rest))) | 1590 | (setcdr lap0 0)) |
| 1864 | (if (and (/= 0 (cdr lap1)) | 1591 | ((error "Optimizer error: too much on the stack")))) |
| 1865 | (eq (car lap0) 'byte-varbind)) | 1592 | ;; |
| 1866 | (car (cdr rest)) | 1593 | ;; goto*-X X: --> X: |
| 1867 | "")) | 1594 | ;; |
| 1868 | (setq keep-going t)) | 1595 | ((and (memq (car lap0) byte-goto-ops) |
| 1869 | ;; | 1596 | (eq (cdr lap0) lap1)) |
| 1870 | ;; goto*-X ... X: goto-Y --> goto*-Y | 1597 | (cond ((eq (car lap0) 'byte-goto) |
| 1871 | ;; goto-X ... X: return --> return | 1598 | (setq lap (delq lap0 lap)) |
| 1872 | ;; | 1599 | (setq tmp "<deleted>")) |
| 1873 | ((and (memq (car lap0) byte-goto-ops) | 1600 | ((memq (car lap0) byte-goto-always-pop-ops) |
| 1874 | (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) | 1601 | (setcar lap0 (setq tmp 'byte-discard)) |
| 1875 | '(byte-goto byte-return))) | 1602 | (setcdr lap0 0)) |
| 1876 | (cond ((and (not (eq tmp lap0)) | 1603 | ((error "Depth conflict at tag %d" (nth 2 lap0)))) |
| 1877 | (or (eq (car lap0) 'byte-goto) | 1604 | (and (memq byte-optimize-log '(t byte)) |
| 1878 | (eq (car tmp) 'byte-goto))) | 1605 | (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" |
| 1879 | (byte-compile-log-lap " %s [%s]\t-->\t%s" | 1606 | (nth 1 lap1) (nth 1 lap1) |
| 1880 | (car lap0) tmp tmp) | 1607 | tmp (nth 1 lap1))) |
| 1881 | (if (eq (car tmp) 'byte-return) | 1608 | (setq keep-going t)) |
| 1882 | (setcar lap0 'byte-return)) | 1609 | ;; |
| 1883 | (setcdr lap0 (cdr tmp)) | 1610 | ;; varset-X varref-X --> dup varset-X |
| 1884 | (setq keep-going t)))) | 1611 | ;; varbind-X varref-X --> dup varbind-X |
| 1885 | ;; | 1612 | ;; const/dup varset-X varref-X --> const/dup varset-X const/dup |
| 1886 | ;; goto-*-else-pop X ... X: goto-if-* --> whatever | 1613 | ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup |
| 1887 | ;; goto-*-else-pop X ... X: discard --> whatever | 1614 | ;; The latter two can enable other optimizations. |
| 1888 | ;; | 1615 | ;; |
| 1889 | ((and (memq (car lap0) '(byte-goto-if-nil-else-pop | 1616 | ;; For lexical variables, we could do the same |
| 1890 | byte-goto-if-not-nil-else-pop)) | 1617 | ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 |
| 1891 | (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) | 1618 | ;; but this is a very minor gain, since dup is stack-ref-0, |
| 1892 | (eval-when-compile | 1619 | ;; i.e. it's only better if X>5, and even then it comes |
| 1893 | (cons 'byte-discard byte-conditional-ops))) | 1620 | ;; at the cost of an extra stack slot. Let's not bother. |
| 1894 | (not (eq lap0 (car tmp)))) | 1621 | ((and (eq 'byte-varref (car lap2)) |
| 1895 | (setq tmp2 (car tmp)) | 1622 | (eq (cdr lap1) (cdr lap2)) |
| 1896 | (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop | 1623 | (memq (car lap1) '(byte-varset byte-varbind))) |
| 1897 | byte-goto-if-nil) | 1624 | (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) |
| 1898 | (byte-goto-if-not-nil-else-pop | 1625 | (not (eq (car lap0) 'byte-constant))) |
| 1899 | byte-goto-if-not-nil)))) | 1626 | nil |
| 1900 | (if (memq (car tmp2) tmp3) | 1627 | (setq keep-going t) |
| 1901 | (progn (setcar lap0 (car tmp2)) | 1628 | (if (memq (car lap0) '(byte-constant byte-dup)) |
| 1902 | (setcdr lap0 (cdr tmp2)) | 1629 | (progn |
| 1903 | (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" | 1630 | (setq tmp (if (or (not tmp) |
| 1904 | (car lap0) tmp2 lap0)) | 1631 | (macroexp--const-symbol-p |
| 1905 | ;; Get rid of the -else-pop's and jump one step further. | 1632 | (car (cdr lap0)))) |
| 1633 | (cdr lap0) | ||
| 1634 | (byte-compile-get-constant t))) | ||
| 1635 | (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" | ||
| 1636 | lap0 lap1 lap2 lap0 lap1 | ||
| 1637 | (cons (car lap0) tmp)) | ||
| 1638 | (setcar lap2 (car lap0)) | ||
| 1639 | (setcdr lap2 tmp)) | ||
| 1640 | (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) | ||
| 1641 | (setcar lap2 (car lap1)) | ||
| 1642 | (setcar lap1 'byte-dup) | ||
| 1643 | (setcdr lap1 0) | ||
| 1644 | ;; The stack depth gets locally increased, so we will | ||
| 1645 | ;; increase maxdepth in case depth = maxdepth here. | ||
| 1646 | ;; This can cause the third argument to byte-code to | ||
| 1647 | ;; be larger than necessary. | ||
| 1648 | (setq add-depth 1)))) | ||
| 1649 | ;; | ||
| 1650 | ;; dup varset-X discard --> varset-X | ||
| 1651 | ;; dup varbind-X discard --> varbind-X | ||
| 1652 | ;; dup stack-set-X discard --> stack-set-X-1 | ||
| 1653 | ;; (the varbind variant can emerge from other optimizations) | ||
| 1654 | ;; | ||
| 1655 | ((and (eq 'byte-dup (car lap0)) | ||
| 1656 | (eq 'byte-discard (car lap2)) | ||
| 1657 | (memq (car lap1) '(byte-varset byte-varbind | ||
| 1658 | byte-stack-set))) | ||
| 1659 | (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) | ||
| 1660 | (setq keep-going t | ||
| 1661 | rest (cdr rest)) | ||
| 1662 | (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) | ||
| 1663 | (setq lap (delq lap0 (delq lap2 lap)))) | ||
| 1664 | ;; | ||
| 1665 | ;; not goto-X-if-nil --> goto-X-if-non-nil | ||
| 1666 | ;; not goto-X-if-non-nil --> goto-X-if-nil | ||
| 1667 | ;; | ||
| 1668 | ;; it is wrong to do the same thing for the -else-pop variants. | ||
| 1669 | ;; | ||
| 1670 | ((and (eq 'byte-not (car lap0)) | ||
| 1671 | (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) | ||
| 1672 | (byte-compile-log-lap " not %s\t-->\t%s" | ||
| 1673 | lap1 | ||
| 1674 | (cons | ||
| 1675 | (if (eq (car lap1) 'byte-goto-if-nil) | ||
| 1676 | 'byte-goto-if-not-nil | ||
| 1677 | 'byte-goto-if-nil) | ||
| 1678 | (cdr lap1))) | ||
| 1679 | (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) | ||
| 1680 | 'byte-goto-if-not-nil | ||
| 1681 | 'byte-goto-if-nil)) | ||
| 1682 | (setq lap (delq lap0 lap)) | ||
| 1683 | (setq keep-going t)) | ||
| 1684 | ;; | ||
| 1685 | ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: | ||
| 1686 | ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: | ||
| 1687 | ;; | ||
| 1688 | ;; it is wrong to do the same thing for the -else-pop variants. | ||
| 1689 | ;; | ||
| 1690 | ((and (memq (car lap0) | ||
| 1691 | '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX | ||
| 1692 | (eq 'byte-goto (car lap1)) ; gotoY | ||
| 1693 | (eq (cdr lap0) lap2)) ; TAG X | ||
| 1694 | (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) | ||
| 1695 | 'byte-goto-if-not-nil 'byte-goto-if-nil))) | ||
| 1696 | (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" | ||
| 1697 | lap0 lap1 lap2 | ||
| 1698 | (cons inverse (cdr lap1)) lap2) | ||
| 1699 | (setq lap (delq lap0 lap)) | ||
| 1700 | (setcar lap1 inverse) | ||
| 1701 | (setq keep-going t))) | ||
| 1702 | ;; | ||
| 1703 | ;; const goto-if-* --> whatever | ||
| 1704 | ;; | ||
| 1705 | ((and (eq 'byte-constant (car lap0)) | ||
| 1706 | (memq (car lap1) byte-conditional-ops) | ||
| 1707 | ;; If the `byte-constant's cdr is not a cons cell, it has | ||
| 1708 | ;; to be an index into the constant pool); even though | ||
| 1709 | ;; it'll be a constant, that constant is not known yet | ||
| 1710 | ;; (it's typically a free variable of a closure, so will | ||
| 1711 | ;; only be known when the closure will be built at | ||
| 1712 | ;; run-time). | ||
| 1713 | (consp (cdr lap0))) | ||
| 1714 | (cond ((if (memq (car lap1) '(byte-goto-if-nil | ||
| 1715 | byte-goto-if-nil-else-pop)) | ||
| 1716 | (car (cdr lap0)) | ||
| 1717 | (not (car (cdr lap0)))) | ||
| 1718 | (byte-compile-log-lap " %s %s\t-->\t<deleted>" | ||
| 1719 | lap0 lap1) | ||
| 1720 | (setq rest (cdr rest) | ||
| 1721 | lap (delq lap0 (delq lap1 lap)))) | ||
| 1722 | (t | ||
| 1723 | (byte-compile-log-lap " %s %s\t-->\t%s" | ||
| 1724 | lap0 lap1 | ||
| 1725 | (cons 'byte-goto (cdr lap1))) | ||
| 1726 | (when (memq (car lap1) byte-goto-always-pop-ops) | ||
| 1727 | (setq lap (delq lap0 lap))) | ||
| 1728 | (setcar lap1 'byte-goto))) | ||
| 1729 | (setq keep-going t)) | ||
| 1730 | ;; | ||
| 1731 | ;; varref-X varref-X --> varref-X dup | ||
| 1732 | ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup | ||
| 1733 | ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup | ||
| 1734 | ;; We don't optimize the const-X variations on this here, | ||
| 1735 | ;; because that would inhibit some goto optimizations; we | ||
| 1736 | ;; optimize the const-X case after all other optimizations. | ||
| 1737 | ;; | ||
| 1738 | ((and (memq (car lap0) '(byte-varref byte-stack-ref)) | ||
| 1739 | (progn | ||
| 1740 | (setq tmp (cdr rest)) | ||
| 1741 | (setq tmp2 0) | ||
| 1742 | (while (eq (car (car tmp)) 'byte-dup) | ||
| 1743 | (setq tmp2 (1+ tmp2)) | ||
| 1744 | (setq tmp (cdr tmp))) | ||
| 1745 | t) | ||
| 1746 | (eq (if (eq 'byte-stack-ref (car lap0)) | ||
| 1747 | (+ tmp2 1 (cdr lap0)) | ||
| 1748 | (cdr lap0)) | ||
| 1749 | (cdr (car tmp))) | ||
| 1750 | (eq (car lap0) (car (car tmp)))) | ||
| 1751 | (if (memq byte-optimize-log '(t byte)) | ||
| 1752 | (let ((str "")) | ||
| 1753 | (setq tmp2 (cdr rest)) | ||
| 1754 | (while (not (eq tmp tmp2)) | ||
| 1755 | (setq tmp2 (cdr tmp2) | ||
| 1756 | str (concat str " dup"))) | ||
| 1757 | (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" | ||
| 1758 | lap0 str lap0 lap0 str))) | ||
| 1759 | (setq keep-going t) | ||
| 1760 | (setcar (car tmp) 'byte-dup) | ||
| 1761 | (setcdr (car tmp) 0) | ||
| 1762 | (setq rest tmp)) | ||
| 1763 | ;; | ||
| 1764 | ;; TAG1: TAG2: --> TAG1: <deleted> | ||
| 1765 | ;; (and other references to TAG2 are replaced with TAG1) | ||
| 1766 | ;; | ||
| 1767 | ((and (eq (car lap0) 'TAG) | ||
| 1768 | (eq (car lap1) 'TAG)) | ||
| 1769 | (and (memq byte-optimize-log '(t byte)) | ||
| 1770 | (byte-compile-log " adjacent tags %d and %d merged" | ||
| 1771 | (nth 1 lap1) (nth 1 lap0))) | ||
| 1772 | (setq tmp3 lap) | ||
| 1773 | (while (setq tmp2 (rassq lap0 tmp3)) | ||
| 1774 | (setcdr tmp2 lap1) | ||
| 1775 | (setq tmp3 (cdr (memq tmp2 tmp3)))) | ||
| 1776 | (setq lap (delq lap0 lap) | ||
| 1777 | keep-going t) | ||
| 1778 | ;; replace references to tag in jump tables, if any | ||
| 1779 | (dolist (table byte-compile-jump-tables) | ||
| 1780 | (maphash #'(lambda (value tag) | ||
| 1781 | (when (equal tag lap0) | ||
| 1782 | (puthash value lap1 table))) | ||
| 1783 | table))) | ||
| 1784 | ;; | ||
| 1785 | ;; unused-TAG: --> <deleted> | ||
| 1786 | ;; | ||
| 1787 | ((and (eq 'TAG (car lap0)) | ||
| 1788 | (not (rassq lap0 lap)) | ||
| 1789 | ;; make sure this tag isn't used in a jump-table | ||
| 1790 | (cl-loop for table in byte-compile-jump-tables | ||
| 1791 | when (member lap0 (hash-table-values table)) | ||
| 1792 | return nil finally return t)) | ||
| 1793 | (and (memq byte-optimize-log '(t byte)) | ||
| 1794 | (byte-compile-log " unused tag %d removed" (nth 1 lap0))) | ||
| 1795 | (setq lap (delq lap0 lap) | ||
| 1796 | keep-going t)) | ||
| 1797 | ;; | ||
| 1798 | ;; goto ... --> goto <delete until TAG or end> | ||
| 1799 | ;; return ... --> return <delete until TAG or end> | ||
| 1800 | ;; (unless a jump-table is being used, where deleting may affect | ||
| 1801 | ;; other valid case bodies) | ||
| 1802 | ;; | ||
| 1803 | ((and (memq (car lap0) '(byte-goto byte-return)) | ||
| 1804 | (not (memq (car lap1) '(TAG nil))) | ||
| 1805 | ;; FIXME: Instead of deferring simply when jump-tables are | ||
| 1806 | ;; being used, keep a list of tags used for switch tags and | ||
| 1807 | ;; use them instead (see `byte-compile-inline-lapcode'). | ||
| 1808 | (not byte-compile-jump-tables)) | ||
| 1809 | (setq tmp rest) | ||
| 1810 | (let ((i 0) | ||
| 1811 | (opt-p (memq byte-optimize-log '(t lap))) | ||
| 1812 | str deleted) | ||
| 1813 | (while (and (setq tmp (cdr tmp)) | ||
| 1814 | (not (eq 'TAG (car (car tmp))))) | ||
| 1815 | (if opt-p (setq deleted (cons (car tmp) deleted) | ||
| 1816 | str (concat str " %s") | ||
| 1817 | i (1+ i)))) | ||
| 1818 | (if opt-p | ||
| 1819 | (let ((tagstr | ||
| 1820 | (if (eq 'TAG (car (car tmp))) | ||
| 1821 | (format "%d:" (car (cdr (car tmp)))) | ||
| 1822 | (or (car tmp) "")))) | ||
| 1823 | (if (< i 6) | ||
| 1824 | (apply 'byte-compile-log-lap-1 | ||
| 1825 | (concat " %s" str | ||
| 1826 | " %s\t-->\t%s <deleted> %s") | ||
| 1827 | lap0 | ||
| 1828 | (nconc (nreverse deleted) | ||
| 1829 | (list tagstr lap0 tagstr))) | ||
| 1830 | (byte-compile-log-lap | ||
| 1831 | " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" | ||
| 1832 | lap0 i (if (= i 1) "" "s") | ||
| 1833 | tagstr lap0 tagstr)))) | ||
| 1834 | (rplacd rest tmp)) | ||
| 1835 | (setq keep-going t)) | ||
| 1836 | ;; | ||
| 1837 | ;; <safe-op> unbind --> unbind <safe-op> | ||
| 1838 | ;; (this may enable other optimizations.) | ||
| 1839 | ;; | ||
| 1840 | ((and (eq 'byte-unbind (car lap1)) | ||
| 1841 | (memq (car lap0) byte-after-unbind-ops)) | ||
| 1842 | (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) | ||
| 1843 | (setcar rest lap1) | ||
| 1844 | (setcar (cdr rest) lap0) | ||
| 1845 | (setq keep-going t)) | ||
| 1846 | ;; | ||
| 1847 | ;; varbind-X unbind-N --> discard unbind-(N-1) | ||
| 1848 | ;; save-excursion unbind-N --> unbind-(N-1) | ||
| 1849 | ;; save-restriction unbind-N --> unbind-(N-1) | ||
| 1850 | ;; | ||
| 1851 | ((and (eq 'byte-unbind (car lap1)) | ||
| 1852 | (memq (car lap0) '(byte-varbind byte-save-excursion | ||
| 1853 | byte-save-restriction)) | ||
| 1854 | (< 0 (cdr lap1))) | ||
| 1855 | (if (zerop (setcdr lap1 (1- (cdr lap1)))) | ||
| 1856 | (delq lap1 rest)) | ||
| 1857 | (if (eq (car lap0) 'byte-varbind) | ||
| 1858 | (setcar rest (cons 'byte-discard 0)) | ||
| 1859 | (setq lap (delq lap0 lap))) | ||
| 1860 | (byte-compile-log-lap " %s %s\t-->\t%s %s" | ||
| 1861 | lap0 (cons (car lap1) (1+ (cdr lap1))) | ||
| 1862 | (if (eq (car lap0) 'byte-varbind) | ||
| 1863 | (car rest) | ||
| 1864 | (car (cdr rest))) | ||
| 1865 | (if (and (/= 0 (cdr lap1)) | ||
| 1866 | (eq (car lap0) 'byte-varbind)) | ||
| 1867 | (car (cdr rest)) | ||
| 1868 | "")) | ||
| 1869 | (setq keep-going t)) | ||
| 1870 | ;; | ||
| 1871 | ;; goto*-X ... X: goto-Y --> goto*-Y | ||
| 1872 | ;; goto-X ... X: return --> return | ||
| 1873 | ;; | ||
| 1874 | ((and (memq (car lap0) byte-goto-ops) | ||
| 1875 | (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) | ||
| 1876 | '(byte-goto byte-return))) | ||
| 1877 | (cond ((and (not (eq tmp lap0)) | ||
| 1878 | (or (eq (car lap0) 'byte-goto) | ||
| 1879 | (eq (car tmp) 'byte-goto))) | ||
| 1880 | (byte-compile-log-lap " %s [%s]\t-->\t%s" | ||
| 1881 | (car lap0) tmp tmp) | ||
| 1882 | (if (eq (car tmp) 'byte-return) | ||
| 1883 | (setcar lap0 'byte-return)) | ||
| 1884 | (setcdr lap0 (cdr tmp)) | ||
| 1885 | (setq keep-going t)))) | ||
| 1886 | ;; | ||
| 1887 | ;; goto-*-else-pop X ... X: goto-if-* --> whatever | ||
| 1888 | ;; goto-*-else-pop X ... X: discard --> whatever | ||
| 1889 | ;; | ||
| 1890 | ((and (memq (car lap0) '(byte-goto-if-nil-else-pop | ||
| 1891 | byte-goto-if-not-nil-else-pop)) | ||
| 1892 | (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) | ||
| 1893 | (eval-when-compile | ||
| 1894 | (cons 'byte-discard byte-conditional-ops))) | ||
| 1895 | (not (eq lap0 (car tmp)))) | ||
| 1896 | (setq tmp2 (car tmp)) | ||
| 1897 | (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop | ||
| 1898 | byte-goto-if-nil) | ||
| 1899 | (byte-goto-if-not-nil-else-pop | ||
| 1900 | byte-goto-if-not-nil)))) | ||
| 1901 | (if (memq (car tmp2) tmp3) | ||
| 1902 | (progn (setcar lap0 (car tmp2)) | ||
| 1903 | (setcdr lap0 (cdr tmp2)) | ||
| 1904 | (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" | ||
| 1905 | (car lap0) tmp2 lap0)) | ||
| 1906 | ;; Get rid of the -else-pop's and jump one step further. | ||
| 1907 | (or (eq 'TAG (car (nth 1 tmp))) | ||
| 1908 | (setcdr tmp (cons (byte-compile-make-tag) | ||
| 1909 | (cdr tmp)))) | ||
| 1910 | (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" | ||
| 1911 | (car lap0) tmp2 (nth 1 tmp3)) | ||
| 1912 | (setcar lap0 (nth 1 tmp3)) | ||
| 1913 | (setcdr lap0 (nth 1 tmp))) | ||
| 1914 | (setq keep-going t)) | ||
| 1915 | ;; | ||
| 1916 | ;; const goto-X ... X: goto-if-* --> whatever | ||
| 1917 | ;; const goto-X ... X: discard --> whatever | ||
| 1918 | ;; | ||
| 1919 | ((and (eq (car lap0) 'byte-constant) | ||
| 1920 | (eq (car lap1) 'byte-goto) | ||
| 1921 | (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) | ||
| 1922 | (eval-when-compile | ||
| 1923 | (cons 'byte-discard byte-conditional-ops))) | ||
| 1924 | (not (eq lap1 (car tmp)))) | ||
| 1925 | (setq tmp2 (car tmp)) | ||
| 1926 | (cond ((when (consp (cdr lap0)) | ||
| 1927 | (memq (car tmp2) | ||
| 1928 | (if (null (car (cdr lap0))) | ||
| 1929 | '(byte-goto-if-nil byte-goto-if-nil-else-pop) | ||
| 1930 | '(byte-goto-if-not-nil | ||
| 1931 | byte-goto-if-not-nil-else-pop)))) | ||
| 1932 | (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" | ||
| 1933 | lap0 tmp2 lap0 tmp2) | ||
| 1934 | (setcar lap1 (car tmp2)) | ||
| 1935 | (setcdr lap1 (cdr tmp2)) | ||
| 1936 | ;; Let next step fix the (const,goto-if*) sequence. | ||
| 1937 | (setq rest (cons nil rest)) | ||
| 1938 | (setq keep-going t)) | ||
| 1939 | ((or (consp (cdr lap0)) | ||
| 1940 | (eq (car tmp2) 'byte-discard)) | ||
| 1941 | ;; Jump one step further | ||
| 1942 | (byte-compile-log-lap | ||
| 1943 | " %s goto [%s]\t-->\t<deleted> goto <skip>" | ||
| 1944 | lap0 tmp2) | ||
| 1906 | (or (eq 'TAG (car (nth 1 tmp))) | 1945 | (or (eq 'TAG (car (nth 1 tmp))) |
| 1907 | (setcdr tmp (cons (byte-compile-make-tag) | 1946 | (setcdr tmp (cons (byte-compile-make-tag) |
| 1908 | (cdr tmp)))) | 1947 | (cdr tmp)))) |
| 1909 | (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" | 1948 | (setcdr lap1 (car (cdr tmp))) |
| 1910 | (car lap0) tmp2 (nth 1 tmp3)) | 1949 | (setq lap (delq lap0 lap)) |
| 1911 | (setcar lap0 (nth 1 tmp3)) | 1950 | (setq keep-going t)))) |
| 1912 | (setcdr lap0 (nth 1 tmp))) | 1951 | ;; |
| 1913 | (setq keep-going t)) | 1952 | ;; X: varref-Y ... varset-Y goto-X --> |
| 1914 | ;; | 1953 | ;; X: varref-Y Z: ... dup varset-Y goto-Z |
| 1915 | ;; const goto-X ... X: goto-if-* --> whatever | 1954 | ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) |
| 1916 | ;; const goto-X ... X: discard --> whatever | 1955 | ;; (This is so usual for while loops that it is worth handling). |
| 1917 | ;; | 1956 | ;; |
| 1918 | ((and (eq (car lap0) 'byte-constant) | 1957 | ;; Here again, we could do it for stack-ref/stack-set, but |
| 1919 | (eq (car lap1) 'byte-goto) | 1958 | ;; that's replacing a stack-ref-Y with a stack-ref-0, which |
| 1920 | (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) | 1959 | ;; is a very minor improvement (if any), at the cost of |
| 1921 | (eval-when-compile | 1960 | ;; more stack use and more byte-code. Let's not do it. |
| 1922 | (cons 'byte-discard byte-conditional-ops))) | 1961 | ;; |
| 1923 | (not (eq lap1 (car tmp)))) | 1962 | ((and (eq (car lap1) 'byte-varset) |
| 1924 | (setq tmp2 (car tmp)) | 1963 | (eq (car lap2) 'byte-goto) |
| 1925 | (cond ((when (consp (cdr lap0)) | 1964 | (not (memq (cdr lap2) rest)) ;Backwards jump |
| 1926 | (memq (car tmp2) | 1965 | (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) |
| 1927 | (if (null (car (cdr lap0))) | 1966 | 'byte-varref) |
| 1928 | '(byte-goto-if-nil byte-goto-if-nil-else-pop) | 1967 | (eq (cdr (car tmp)) (cdr lap1)) |
| 1929 | '(byte-goto-if-not-nil | 1968 | (not (memq (car (cdr lap1)) byte-boolean-vars))) |
| 1930 | byte-goto-if-not-nil-else-pop)))) | 1969 | ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) |
| 1931 | (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" | 1970 | (let ((newtag (byte-compile-make-tag))) |
| 1932 | lap0 tmp2 lap0 tmp2) | 1971 | (byte-compile-log-lap |
| 1933 | (setcar lap1 (car tmp2)) | 1972 | " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" |
| 1934 | (setcdr lap1 (cdr tmp2)) | 1973 | (nth 1 (cdr lap2)) (car tmp) |
| 1935 | ;; Let next step fix the (const,goto-if*) sequence. | 1974 | lap1 lap2 |
| 1936 | (setq rest (cons nil rest)) | 1975 | (nth 1 (cdr lap2)) (car tmp) |
| 1937 | (setq keep-going t)) | 1976 | (nth 1 newtag) 'byte-dup lap1 |
| 1938 | ((or (consp (cdr lap0)) | 1977 | (cons 'byte-goto newtag) |
| 1939 | (eq (car tmp2) 'byte-discard)) | 1978 | ) |
| 1940 | ;; Jump one step further | 1979 | (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) |
| 1941 | (byte-compile-log-lap | 1980 | (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) |
| 1942 | " %s goto [%s]\t-->\t<deleted> goto <skip>" | 1981 | (setq add-depth 1) |
| 1943 | lap0 tmp2) | 1982 | (setq keep-going t)) |
| 1944 | (or (eq 'TAG (car (nth 1 tmp))) | 1983 | ;; |
| 1945 | (setcdr tmp (cons (byte-compile-make-tag) | 1984 | ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: |
| 1946 | (cdr tmp)))) | 1985 | ;; (This can pull the loop test to the end of the loop) |
| 1947 | (setcdr lap1 (car (cdr tmp))) | 1986 | ;; |
| 1948 | (setq lap (delq lap0 lap)) | 1987 | ((and (eq (car lap0) 'byte-goto) |
| 1949 | (setq keep-going t)))) | 1988 | (eq (car lap1) 'TAG) |
| 1950 | ;; | 1989 | (eq lap1 |
| 1951 | ;; X: varref-Y ... varset-Y goto-X --> | 1990 | (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) |
| 1952 | ;; X: varref-Y Z: ... dup varset-Y goto-Z | 1991 | (memq (car (car tmp)) |
| 1953 | ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) | 1992 | '(byte-goto byte-goto-if-nil byte-goto-if-not-nil |
| 1954 | ;; (This is so usual for while loops that it is worth handling). | 1993 | byte-goto-if-nil-else-pop))) |
| 1955 | ;; | 1994 | ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" |
| 1956 | ;; Here again, we could do it for stack-ref/stack-set, but | 1995 | ;; lap0 lap1 (cdr lap0) (car tmp)) |
| 1957 | ;; that's replacing a stack-ref-Y with a stack-ref-0, which | 1996 | (let ((newtag (byte-compile-make-tag))) |
| 1958 | ;; is a very minor improvement (if any), at the cost of | 1997 | (byte-compile-log-lap |
| 1959 | ;; more stack use and more byte-code. Let's not do it. | 1998 | "%s %s: ... %s: %s\t-->\t%s ... %s:" |
| 1960 | ;; | 1999 | lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) |
| 1961 | ((and (eq (car lap1) 'byte-varset) | 2000 | (cons (cdr (assq (car (car tmp)) |
| 1962 | (eq (car lap2) 'byte-goto) | 2001 | '((byte-goto-if-nil . byte-goto-if-not-nil) |
| 1963 | (not (memq (cdr lap2) rest)) ;Backwards jump | 2002 | (byte-goto-if-not-nil . byte-goto-if-nil) |
| 1964 | (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) | 2003 | (byte-goto-if-nil-else-pop . |
| 1965 | 'byte-varref) | 2004 | byte-goto-if-not-nil-else-pop) |
| 1966 | (eq (cdr (car tmp)) (cdr lap1)) | 2005 | (byte-goto-if-not-nil-else-pop . |
| 1967 | (not (memq (car (cdr lap1)) byte-boolean-vars))) | 2006 | byte-goto-if-nil-else-pop)))) |
| 1968 | ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) | 2007 | newtag) |
| 1969 | (let ((newtag (byte-compile-make-tag))) | 2008 | |
| 1970 | (byte-compile-log-lap | 2009 | (nth 1 newtag) |
| 1971 | " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" | 2010 | ) |
| 1972 | (nth 1 (cdr lap2)) (car tmp) | 2011 | (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) |
| 1973 | lap1 lap2 | 2012 | (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) |
| 1974 | (nth 1 (cdr lap2)) (car tmp) | 2013 | ;; We can handle this case but not the -if-not-nil case, |
| 1975 | (nth 1 newtag) 'byte-dup lap1 | 2014 | ;; because we won't know which non-nil constant to push. |
| 1976 | (cons 'byte-goto newtag) | 2015 | (setcdr rest (cons (cons 'byte-constant |
| 1977 | ) | 2016 | (byte-compile-get-constant nil)) |
| 1978 | (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) | 2017 | (cdr rest)))) |
| 1979 | (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) | 2018 | (setcar lap0 (nth 1 (memq (car (car tmp)) |
| 1980 | (setq add-depth 1) | 2019 | '(byte-goto-if-nil-else-pop |
| 1981 | (setq keep-going t)) | 2020 | byte-goto-if-not-nil |
| 1982 | ;; | 2021 | byte-goto-if-nil |
| 1983 | ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: | 2022 | byte-goto-if-not-nil |
| 1984 | ;; (This can pull the loop test to the end of the loop) | 2023 | byte-goto byte-goto)))) |
| 1985 | ;; | 2024 | ) |
| 1986 | ((and (eq (car lap0) 'byte-goto) | 2025 | (setq keep-going t)) |
| 1987 | (eq (car lap1) 'TAG) | 2026 | |
| 1988 | (eq lap1 | 2027 | ;; |
| 1989 | (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) | 2028 | ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos |
| 1990 | (memq (car (car tmp)) | 2029 | ;; stack-set-M [discard/discardN ...] --> discardN |
| 1991 | '(byte-goto byte-goto-if-nil byte-goto-if-not-nil | 2030 | ;; |
| 1992 | byte-goto-if-nil-else-pop))) | 2031 | ((and (eq (car lap0) 'byte-stack-set) |
| 1993 | ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" | 2032 | (memq (car lap1) '(byte-discard byte-discardN)) |
| 1994 | ;; lap0 lap1 (cdr lap0) (car tmp)) | 2033 | (progn |
| 1995 | (let ((newtag (byte-compile-make-tag))) | 2034 | ;; See if enough discard operations follow to expose or |
| 1996 | (byte-compile-log-lap | 2035 | ;; destroy the value stored by the stack-set. |
| 1997 | "%s %s: ... %s: %s\t-->\t%s ... %s:" | 2036 | (setq tmp (cdr rest)) |
| 1998 | lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) | 2037 | (setq tmp2 (1- (cdr lap0))) |
| 1999 | (cons (cdr (assq (car (car tmp)) | 2038 | (setq tmp3 0) |
| 2000 | '((byte-goto-if-nil . byte-goto-if-not-nil) | 2039 | (while (memq (car (car tmp)) '(byte-discard byte-discardN)) |
| 2001 | (byte-goto-if-not-nil . byte-goto-if-nil) | 2040 | (setq tmp3 |
| 2002 | (byte-goto-if-nil-else-pop . | 2041 | (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) |
| 2003 | byte-goto-if-not-nil-else-pop) | 2042 | 1 |
| 2004 | (byte-goto-if-not-nil-else-pop . | 2043 | (cdr (car tmp))))) |
| 2005 | byte-goto-if-nil-else-pop)))) | 2044 | (setq tmp (cdr tmp))) |
| 2006 | newtag) | 2045 | (>= tmp3 tmp2))) |
| 2007 | 2046 | ;; Do the optimization. | |
| 2008 | (nth 1 newtag) | 2047 | (setq lap (delq lap0 lap)) |
| 2009 | ) | 2048 | (setcar lap1 |
| 2010 | (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) | 2049 | (if (= tmp2 tmp3) |
| 2011 | (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) | 2050 | ;; The value stored is the new TOS, so pop one more |
| 2012 | ;; We can handle this case but not the -if-not-nil case, | 2051 | ;; value (to get rid of the old value) using the |
| 2013 | ;; because we won't know which non-nil constant to push. | 2052 | ;; TOS-preserving discard operator. |
| 2014 | (setcdr rest (cons (cons 'byte-constant | 2053 | 'byte-discardN-preserve-tos |
| 2015 | (byte-compile-get-constant nil)) | 2054 | ;; Otherwise, the value stored is lost, so just use a |
| 2016 | (cdr rest)))) | 2055 | ;; normal discard. |
| 2017 | (setcar lap0 (nth 1 (memq (car (car tmp)) | 2056 | 'byte-discardN)) |
| 2018 | '(byte-goto-if-nil-else-pop | 2057 | (setcdr lap1 (1+ tmp3)) |
| 2019 | byte-goto-if-not-nil | 2058 | (setcdr (cdr rest) tmp) |
| 2020 | byte-goto-if-nil | 2059 | (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" |
| 2021 | byte-goto-if-not-nil | 2060 | lap0 lap1)) |
| 2022 | byte-goto byte-goto)))) | 2061 | |
| 2023 | ) | 2062 | ;; |
| 2024 | (setq keep-going t)) | 2063 | ;; discardN-preserve-tos return --> return |
| 2025 | ) | 2064 | ;; dup return --> return |
| 2065 | ;; stack-set-N return --> return ; where N is TOS-1 | ||
| 2066 | ;; | ||
| 2067 | ((and (eq (car lap1) 'byte-return) | ||
| 2068 | (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) | ||
| 2069 | (and (eq (car lap0) 'byte-stack-set) | ||
| 2070 | (= (cdr lap0) 1)))) | ||
| 2071 | (setq keep-going t) | ||
| 2072 | ;; The byte-code interpreter will pop the stack for us, so | ||
| 2073 | ;; we can just leave stuff on it. | ||
| 2074 | (setq lap (delq lap0 lap)) | ||
| 2075 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) | ||
| 2076 | |||
| 2077 | ;; | ||
| 2078 | ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y: | ||
| 2079 | ;; | ||
| 2080 | ((and (eq (car lap0) 'byte-goto) | ||
| 2081 | (setq tmp (cdr (memq (cdr lap0) lap))) | ||
| 2082 | (memq (caar tmp) '(byte-discard byte-discardN | ||
| 2083 | byte-discardN-preserve-tos))) | ||
| 2084 | (byte-compile-log-lap | ||
| 2085 | " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:" | ||
| 2086 | (car tmp) (car tmp)) | ||
| 2087 | (setq keep-going t) | ||
| 2088 | (let* ((newtag (byte-compile-make-tag)) | ||
| 2089 | ;; Make a copy, since we sometimes modify insts in-place! | ||
| 2090 | (newdiscard (cons (caar tmp) (cdar tmp))) | ||
| 2091 | (newjmp (cons (car lap0) newtag))) | ||
| 2092 | (push newtag (cdr tmp)) ;Push new tag after the discard. | ||
| 2093 | (setcar rest newdiscard) | ||
| 2094 | (push newjmp (cdr rest)))) | ||
| 2095 | |||
| 2096 | ;; | ||
| 2097 | ;; const discardN-preserve-tos ==> discardN const | ||
| 2098 | ;; | ||
| 2099 | ((and (eq (car lap0) 'byte-constant) | ||
| 2100 | (eq (car lap1) 'byte-discardN-preserve-tos)) | ||
| 2101 | (setq keep-going t) | ||
| 2102 | (let ((newdiscard (cons 'byte-discardN (cdr lap1)))) | ||
| 2103 | (byte-compile-log-lap | ||
| 2104 | " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0) | ||
| 2105 | (setf (car rest) newdiscard) | ||
| 2106 | (setf (cadr rest) lap0))) | ||
| 2107 | ) | ||
| 2026 | (setq rest (cdr rest))) | 2108 | (setq rest (cdr rest))) |
| 2027 | ) | 2109 | ) |
| 2028 | ;; Cleanup stage: | 2110 | ;; Cleanup stage: |
| @@ -2086,41 +2168,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 2086 | (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) | 2168 | (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) |
| 2087 | 2169 | ||
| 2088 | ;; | 2170 | ;; |
| 2089 | ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos | ||
| 2090 | ;; stack-set-M [discard/discardN ...] --> discardN | ||
| 2091 | ;; | ||
| 2092 | ((and (eq (car lap0) 'byte-stack-set) | ||
| 2093 | (memq (car lap1) '(byte-discard byte-discardN)) | ||
| 2094 | (progn | ||
| 2095 | ;; See if enough discard operations follow to expose or | ||
| 2096 | ;; destroy the value stored by the stack-set. | ||
| 2097 | (setq tmp (cdr rest)) | ||
| 2098 | (setq tmp2 (1- (cdr lap0))) | ||
| 2099 | (setq tmp3 0) | ||
| 2100 | (while (memq (car (car tmp)) '(byte-discard byte-discardN)) | ||
| 2101 | (setq tmp3 | ||
| 2102 | (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) | ||
| 2103 | 1 | ||
| 2104 | (cdr (car tmp))))) | ||
| 2105 | (setq tmp (cdr tmp))) | ||
| 2106 | (>= tmp3 tmp2))) | ||
| 2107 | ;; Do the optimization. | ||
| 2108 | (setq lap (delq lap0 lap)) | ||
| 2109 | (setcar lap1 | ||
| 2110 | (if (= tmp2 tmp3) | ||
| 2111 | ;; The value stored is the new TOS, so pop one more | ||
| 2112 | ;; value (to get rid of the old value) using the | ||
| 2113 | ;; TOS-preserving discard operator. | ||
| 2114 | 'byte-discardN-preserve-tos | ||
| 2115 | ;; Otherwise, the value stored is lost, so just use a | ||
| 2116 | ;; normal discard. | ||
| 2117 | 'byte-discardN)) | ||
| 2118 | (setcdr lap1 (1+ tmp3)) | ||
| 2119 | (setcdr (cdr rest) tmp) | ||
| 2120 | (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" | ||
| 2121 | lap0 lap1)) | ||
| 2122 | |||
| 2123 | ;; | ||
| 2124 | ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> | 2171 | ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> |
| 2125 | ;; discardN-(X+Y) | 2172 | ;; discardN-(X+Y) |
| 2126 | ;; | 2173 | ;; |
| @@ -2147,20 +2194,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 2147 | (setq lap (delq lap0 lap)) | 2194 | (setq lap (delq lap0 lap)) |
| 2148 | (setcdr lap1 (+ (cdr lap0) (cdr lap1))) | 2195 | (setcdr lap1 (+ (cdr lap0) (cdr lap1))) |
| 2149 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) | 2196 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) |
| 2150 | |||
| 2151 | ;; | ||
| 2152 | ;; discardN-preserve-tos return --> return | ||
| 2153 | ;; dup return --> return | ||
| 2154 | ;; stack-set-N return --> return ; where N is TOS-1 | ||
| 2155 | ;; | ||
| 2156 | ((and (eq (car lap1) 'byte-return) | ||
| 2157 | (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) | ||
| 2158 | (and (eq (car lap0) 'byte-stack-set) | ||
| 2159 | (= (cdr lap0) 1)))) | ||
| 2160 | ;; The byte-code interpreter will pop the stack for us, so | ||
| 2161 | ;; we can just leave stuff on it. | ||
| 2162 | (setq lap (delq lap0 lap)) | ||
| 2163 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) | ||
| 2164 | ) | 2197 | ) |
| 2165 | (setq rest (cdr rest))) | 2198 | (setq rest (cdr rest))) |
| 2166 | (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) | 2199 | (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) |
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 3ed299864b7..a3ad43038e7 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el | |||
| @@ -238,8 +238,11 @@ The return value is undefined. | |||
| 238 | #'(lambda (x) | 238 | #'(lambda (x) |
| 239 | (let ((f (cdr (assq (car x) macro-declarations-alist)))) | 239 | (let ((f (cdr (assq (car x) macro-declarations-alist)))) |
| 240 | (if f (apply (car f) name arglist (cdr x)) | 240 | (if f (apply (car f) name arglist (cdr x)) |
| 241 | (message "Warning: Unknown macro property %S in %S" | 241 | (macroexp--warn-and-return |
| 242 | (car x) name)))) | 242 | (format-message |
| 243 | "Unknown macro property %S in %S" | ||
| 244 | (car x) name) | ||
| 245 | nil)))) | ||
| 243 | decls))) | 246 | decls))) |
| 244 | ;; Refresh font-lock if this is a new macro, or it is an | 247 | ;; Refresh font-lock if this is a new macro, or it is an |
| 245 | ;; existing macro whose 'no-font-lock-keyword declaration | 248 | ;; existing macro whose 'no-font-lock-keyword declaration |
| @@ -307,9 +310,12 @@ The return value is undefined. | |||
| 307 | (cdr body) | 310 | (cdr body) |
| 308 | body))) | 311 | body))) |
| 309 | nil) | 312 | nil) |
| 310 | (t (message "Warning: Unknown defun property `%S' in %S" | 313 | (t |
| 311 | (car x) name))))) | 314 | (macroexp--warn-and-return |
| 312 | decls)) | 315 | (format-message "Unknown defun property `%S' in %S" |
| 316 | (car x) name) | ||
| 317 | nil))))) | ||
| 318 | decls)) | ||
| 313 | (def (list 'defalias | 319 | (def (list 'defalias |
| 314 | (list 'quote name) | 320 | (list 'quote name) |
| 315 | (list 'function | 321 | (list 'function |
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 54f8301b085..c0f8db69e51 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el | |||
| @@ -2577,7 +2577,8 @@ list that represents a doc string reference. | |||
| 2577 | (when (memq sym byte-compile-lexical-variables) | 2577 | (when (memq sym byte-compile-lexical-variables) |
| 2578 | (setq byte-compile-lexical-variables | 2578 | (setq byte-compile-lexical-variables |
| 2579 | (delq sym byte-compile-lexical-variables)) | 2579 | (delq sym byte-compile-lexical-variables)) |
| 2580 | (byte-compile-warn "Variable `%S' declared after its first use" sym)) | 2580 | (when (byte-compile-warning-enabled-p 'lexical sym) |
| 2581 | (byte-compile-warn "Variable `%S' declared after its first use" sym))) | ||
| 2581 | (push sym byte-compile-bound-variables) | 2582 | (push sym byte-compile-bound-variables) |
| 2582 | (push sym byte-compile--seen-defvars)) | 2583 | (push sym byte-compile--seen-defvars)) |
| 2583 | 2584 | ||
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 2e204ff7aea..76638ec13b1 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el | |||
| @@ -241,7 +241,12 @@ system. Possible values are: | |||
| 241 | defun - Spell-check when style checking a single defun. | 241 | defun - Spell-check when style checking a single defun. |
| 242 | buffer - Spell-check when style checking the whole buffer. | 242 | buffer - Spell-check when style checking the whole buffer. |
| 243 | interactive - Spell-check during any interactive check. | 243 | interactive - Spell-check during any interactive check. |
| 244 | t - Always spell-check." | 244 | t - Always spell-check. |
| 245 | |||
| 246 | There is a list of Lisp-specific words which checkdoc will | ||
| 247 | install into Ispell on the fly, but only if Ispell is not already | ||
| 248 | running. Use `ispell-kill-ispell' to make checkdoc restart it | ||
| 249 | with these words enabled." | ||
| 245 | :type '(choice (const nil) | 250 | :type '(choice (const nil) |
| 246 | (const defun) | 251 | (const defun) |
| 247 | (const buffer) | 252 | (const buffer) |
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 58517549454..fdbf95319ff 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el | |||
| @@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil." | |||
| 487 | Returns nil if they are." | 487 | Returns nil if they are." |
| 488 | (if (not (eq (type-of a) (type-of b))) | 488 | (if (not (eq (type-of a) (type-of b))) |
| 489 | `(different-types ,a ,b) | 489 | `(different-types ,a ,b) |
| 490 | (pcase-exhaustive a | 490 | (pcase a |
| 491 | ((pred consp) | 491 | ((pred consp) |
| 492 | (let ((a-length (proper-list-p a)) | 492 | (let ((a-length (proper-list-p a)) |
| 493 | (b-length (proper-list-p b))) | 493 | (b-length (proper-list-p b))) |
| @@ -538,7 +538,7 @@ Returns nil if they are." | |||
| 538 | for xi = (ert--explain-equal-rec ai bi) | 538 | for xi = (ert--explain-equal-rec ai bi) |
| 539 | do (when xi (cl-return `(array-elt ,i ,xi))) | 539 | do (when xi (cl-return `(array-elt ,i ,xi))) |
| 540 | finally (cl-assert (equal a b) t)))) | 540 | finally (cl-assert (equal a b) t)))) |
| 541 | ((pred atom) | 541 | (_ |
| 542 | (if (not (equal a b)) | 542 | (if (not (equal a b)) |
| 543 | (if (and (symbolp a) (symbolp b) (string= a b)) | 543 | (if (and (symbolp a) (symbolp b) (string= a b)) |
| 544 | `(different-symbols-with-the-same-name ,a ,b) | 544 | `(different-symbols-with-the-same-name ,a ,b) |
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 37844977f8f..aa49bccc8d0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el | |||
| @@ -127,7 +127,7 @@ and also to avoid outputting the warning during normal execution." | |||
| 127 | (cond | 127 | (cond |
| 128 | ((null msg) form) | 128 | ((null msg) form) |
| 129 | ((macroexp--compiling-p) | 129 | ((macroexp--compiling-p) |
| 130 | (if (gethash form macroexp--warned) | 130 | (if (and (consp form) (gethash form macroexp--warned)) |
| 131 | ;; Already wrapped this exp with a warning: avoid inf-looping | 131 | ;; Already wrapped this exp with a warning: avoid inf-looping |
| 132 | ;; where we keep adding the same warning onto `form' because | 132 | ;; where we keep adding the same warning onto `form' because |
| 133 | ;; macroexpand-all gets right back to macroexpanding `form'. | 133 | ;; macroexpand-all gets right back to macroexpanding `form'. |
| @@ -138,9 +138,10 @@ and also to avoid outputting the warning during normal execution." | |||
| 138 | ,form))) | 138 | ,form))) |
| 139 | (t | 139 | (t |
| 140 | (unless compile-only | 140 | (unless compile-only |
| 141 | (message "%s%s" (if (stringp load-file-name) | 141 | (message "%sWarning: %s" |
| 142 | (concat (file-relative-name load-file-name) ": ") | 142 | (if (stringp load-file-name) |
| 143 | "") | 143 | (concat (file-relative-name load-file-name) ": ") |
| 144 | "") | ||
| 144 | msg)) | 145 | msg)) |
| 145 | form)))) | 146 | form)))) |
| 146 | 147 | ||
| @@ -180,8 +181,9 @@ and also to avoid outputting the warning during normal execution." | |||
| 180 | 181 | ||
| 181 | (defun macroexp-macroexpand (form env) | 182 | (defun macroexp-macroexpand (form env) |
| 182 | "Like `macroexpand' but checking obsolescence." | 183 | "Like `macroexpand' but checking obsolescence." |
| 183 | (let ((new-form | 184 | (let* ((macroexpand-all-environment env) |
| 184 | (macroexpand form env))) | 185 | (new-form |
| 186 | (macroexpand form env))) | ||
| 185 | (if (and (not (eq form new-form)) ;It was a macro call. | 187 | (if (and (not (eq form new-form)) ;It was a macro call. |
| 186 | (car-safe form) | 188 | (car-safe form) |
| 187 | (symbolp (car form)) | 189 | (symbolp (car form)) |
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 125fbe09961..9f155bad394 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el | |||
| @@ -3288,9 +3288,9 @@ To unhide a package, type | |||
| 3288 | `\\[customize-variable] RET package-hidden-regexps'. | 3288 | `\\[customize-variable] RET package-hidden-regexps'. |
| 3289 | 3289 | ||
| 3290 | Type \\[package-menu-toggle-hiding] to toggle package hiding." | 3290 | Type \\[package-menu-toggle-hiding] to toggle package hiding." |
| 3291 | (declare (interactive-only "change `package-hidden-regexps' instead.")) | ||
| 3291 | (interactive) | 3292 | (interactive) |
| 3292 | (package--ensure-package-menu-mode) | 3293 | (package--ensure-package-menu-mode) |
| 3293 | (declare (interactive-only "change `package-hidden-regexps' instead.")) | ||
| 3294 | (let* ((name (when (derived-mode-p 'package-menu-mode) | 3294 | (let* ((name (when (derived-mode-p 'package-menu-mode) |
| 3295 | (concat "\\`" (regexp-quote (symbol-name (package-desc-name | 3295 | (concat "\\`" (regexp-quote (symbol-name (package-desc-name |
| 3296 | (tabulated-list-get-id)))) | 3296 | (tabulated-list-get-id)))) |
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 72ea1ba0188..bfd577c5d14 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el | |||
| @@ -39,10 +39,10 @@ | |||
| 39 | ;; - along these lines, provide patterns to match CL structs. | 39 | ;; - along these lines, provide patterns to match CL structs. |
| 40 | ;; - provide something like (setq VAR) so a var can be set rather than | 40 | ;; - provide something like (setq VAR) so a var can be set rather than |
| 41 | ;; let-bound. | 41 | ;; let-bound. |
| 42 | ;; - provide a way to fallthrough to subsequent cases (not sure what I meant by | 42 | ;; - provide a way to fallthrough to subsequent cases |
| 43 | ;; this :-() | 43 | ;; (e.g. Like Racket's (=> ID). |
| 44 | ;; - try and be more clever to reduce the size of the decision tree, and | 44 | ;; - try and be more clever to reduce the size of the decision tree, and |
| 45 | ;; to reduce the number of leaves that need to be turned into function: | 45 | ;; to reduce the number of leaves that need to be turned into functions: |
| 46 | ;; - first, do the tests shared by all remaining branches (it will have | 46 | ;; - first, do the tests shared by all remaining branches (it will have |
| 47 | ;; to be performed anyway, so better do it first so it's shared). | 47 | ;; to be performed anyway, so better do it first so it's shared). |
| 48 | ;; - then choose the test that discriminates more (?). | 48 | ;; - then choose the test that discriminates more (?). |
| @@ -97,11 +97,15 @@ | |||
| 97 | (declare-function get-edebug-spec "edebug" (symbol)) | 97 | (declare-function get-edebug-spec "edebug" (symbol)) |
| 98 | (declare-function edebug-match "edebug" (cursor specs)) | 98 | (declare-function edebug-match "edebug" (cursor specs)) |
| 99 | 99 | ||
| 100 | (defun pcase--get-macroexpander (s) | ||
| 101 | "Return the macroexpander for pcase pattern head S, or nil" | ||
| 102 | (get s 'pcase-macroexpander)) | ||
| 103 | |||
| 100 | (defun pcase--edebug-match-macro (cursor) | 104 | (defun pcase--edebug-match-macro (cursor) |
| 101 | (let (specs) | 105 | (let (specs) |
| 102 | (mapatoms | 106 | (mapatoms |
| 103 | (lambda (s) | 107 | (lambda (s) |
| 104 | (let ((m (get s 'pcase-macroexpander))) | 108 | (let ((m (pcase--get-macroexpander s))) |
| 105 | (when (and m (get-edebug-spec m)) | 109 | (when (and m (get-edebug-spec m)) |
| 106 | (push (cons (symbol-name s) (get-edebug-spec m)) | 110 | (push (cons (symbol-name s) (get-edebug-spec m)) |
| 107 | specs))))) | 111 | specs))))) |
| @@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms: | |||
| 128 | If a SYMBOL is used twice in the same pattern | 132 | If a SYMBOL is used twice in the same pattern |
| 129 | the second occurrence becomes an `eq'uality test. | 133 | the second occurrence becomes an `eq'uality test. |
| 130 | (pred FUN) matches if FUN called on EXPVAL returns non-nil. | 134 | (pred FUN) matches if FUN called on EXPVAL returns non-nil. |
| 135 | (pred (not FUN)) matches if FUN called on EXPVAL returns nil. | ||
| 131 | (app FUN PAT) matches if FUN called on EXPVAL matches PAT. | 136 | (app FUN PAT) matches if FUN called on EXPVAL matches PAT. |
| 132 | (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. | 137 | (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. |
| 133 | (let PAT EXPR) matches if EXPR matches PAT. | 138 | (let PAT EXPR) matches if EXPR matches PAT. |
| @@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples." | |||
| 193 | (let (more) | 198 | (let (more) |
| 194 | ;; Collect all the extensions. | 199 | ;; Collect all the extensions. |
| 195 | (mapatoms (lambda (symbol) | 200 | (mapatoms (lambda (symbol) |
| 196 | (let ((me (get symbol 'pcase-macroexpander))) | 201 | (let ((me (pcase--get-macroexpander symbol))) |
| 197 | (when me | 202 | (when me |
| 198 | (push (cons symbol me) | 203 | (push (cons symbol me) |
| 199 | more))))) | 204 | more))))) |
| @@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'. | |||
| 424 | ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) | 429 | ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) |
| 425 | ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) | 430 | ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) |
| 426 | (t | 431 | (t |
| 427 | (let* ((expander (get head 'pcase-macroexpander)) | 432 | (let* ((expander (pcase--get-macroexpander head)) |
| 428 | (npat (if expander (apply expander (cdr pat))))) | 433 | (npat (if expander (apply expander (cdr pat))))) |
| 429 | (if (null npat) | 434 | (if (null npat) |
| 430 | (error (if expander | 435 | (error (if expander |
| @@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form: | |||
| 658 | '(:pcase--succeed . nil)))) | 663 | '(:pcase--succeed . nil)))) |
| 659 | 664 | ||
| 660 | (defun pcase--split-pred (vars upat pat) | 665 | (defun pcase--split-pred (vars upat pat) |
| 666 | "Indicate the overlap or mutual-exclusion between UPAT and PAT. | ||
| 667 | More specifically retuns a pair (A . B) where A indicates whether PAT | ||
| 668 | can match when UPAT has matched, and B does the same for the case | ||
| 669 | where UPAT failed to match. | ||
| 670 | A and B can be one of: | ||
| 671 | - nil if we don't know | ||
| 672 | - `:pcase--fail' if UPAT match's result implies that PAT can't match | ||
| 673 | - `:pcase--succeed' if UPAT match's result implies that PAT matches" | ||
| 661 | (let (test) | 674 | (let (test) |
| 662 | (cond | 675 | (cond |
| 663 | ((and (equal upat pat) | 676 | ((and (equal upat pat) |
| @@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form: | |||
| 670 | ;; and catch at least the easy cases such as (bug#14773). | 683 | ;; and catch at least the easy cases such as (bug#14773). |
| 671 | (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) | 684 | (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) |
| 672 | '(:pcase--succeed . :pcase--fail)) | 685 | '(:pcase--succeed . :pcase--fail)) |
| 686 | ;; In case UPAT is of the form (pred (not PRED)) | ||
| 687 | ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat)))) | ||
| 688 | (let* ((test (cadr (cadr upat))) | ||
| 689 | (res (pcase--split-pred vars `(pred ,test) pat))) | ||
| 690 | (cons (cdr res) (car res)))) | ||
| 691 | ;; In case PAT is of the form (pred (not PRED)) | ||
| 692 | ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat)))) | ||
| 693 | (let* ((test (cadr (cadr pat))) | ||
| 694 | (res (pcase--split-pred vars upat `(pred ,test))) | ||
| 695 | (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail) | ||
| 696 | ((eq x :pcase--fail) :pcase--succeed))))) | ||
| 697 | (cons (funcall reverse (car res)) | ||
| 698 | (funcall reverse (cdr res))))) | ||
| 673 | ((and (eq 'pred (car upat)) | 699 | ((and (eq 'pred (car upat)) |
| 674 | (let ((otherpred | 700 | (let ((otherpred |
| 675 | (cond ((eq 'pred (car-safe pat)) (cadr pat)) | 701 | (cond ((eq 'pred (car-safe pat)) (cadr pat)) |
| @@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form: | |||
| 728 | 754 | ||
| 729 | (defun pcase--funcall (fun arg vars) | 755 | (defun pcase--funcall (fun arg vars) |
| 730 | "Build a function call to FUN with arg ARG." | 756 | "Build a function call to FUN with arg ARG." |
| 731 | (if (symbolp fun) | 757 | (cond |
| 732 | `(,fun ,arg) | 758 | ((symbolp fun) `(,fun ,arg)) |
| 759 | ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars))) | ||
| 760 | (t | ||
| 733 | (let* (;; `env' is an upper bound on the bindings we need. | 761 | (let* (;; `env' is an upper bound on the bindings we need. |
| 734 | (env (mapcar (lambda (x) (list (car x) (cdr x))) | 762 | (env (mapcar (lambda (x) (list (car x) (cdr x))) |
| 735 | (macroexp--fgrep vars fun))) | 763 | (macroexp--fgrep vars fun))) |
| @@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form: | |||
| 747 | ;; Let's not replace `vars' in `fun' since it's | 775 | ;; Let's not replace `vars' in `fun' since it's |
| 748 | ;; too difficult to do it right, instead just | 776 | ;; too difficult to do it right, instead just |
| 749 | ;; let-bind `vars' around `fun'. | 777 | ;; let-bind `vars' around `fun'. |
| 750 | `(let* ,env ,call))))) | 778 | `(let* ,env ,call)))))) |
| 751 | 779 | ||
| 752 | (defun pcase--eval (exp vars) | 780 | (defun pcase--eval (exp vars) |
| 753 | "Build an expression that will evaluate EXP." | 781 | "Build an expression that will evaluate EXP." |
diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index 6a483a6d498..0905ac608bb 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el | |||
| @@ -198,9 +198,10 @@ If not found, return nil." | |||
| 198 | (pcase-defmacro radix-tree-leaf (vpat) | 198 | (pcase-defmacro radix-tree-leaf (vpat) |
| 199 | "Pattern which matches a radix-tree leaf. | 199 | "Pattern which matches a radix-tree leaf. |
| 200 | The pattern VPAT is matched against the leaf's carried value." | 200 | The pattern VPAT is matched against the leaf's carried value." |
| 201 | ;; FIXME: We'd like to use a negative pattern (not consp), but pcase | 201 | ;; We used to use `(pred atom)', but `pcase' doesn't understand that |
| 202 | ;; doesn't support it. Using `atom' works but generates sub-optimal code. | 202 | ;; `atom' is equivalent to the negation of `consp' and hence generates |
| 203 | `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) | 203 | ;; suboptimal code. |
| 204 | `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))) | ||
| 204 | 205 | ||
| 205 | (defun radix-tree-iter-subtrees (tree fun) | 206 | (defun radix-tree-iter-subtrees (tree fun) |
| 206 | "Apply FUN to every immediate subtree of radix TREE. | 207 | "Apply FUN to every immediate subtree of radix TREE. |
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index b90227da42f..a4514454c0b 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el | |||
| @@ -389,6 +389,28 @@ it makes no sense to convert it to a string using | |||
| 389 | (set-buffer source-buffer) | 389 | (set-buffer source-buffer) |
| 390 | (replace-buffer-contents tmp-buffer max-secs max-costs))))))))) | 390 | (replace-buffer-contents tmp-buffer max-secs max-costs))))))))) |
| 391 | 391 | ||
| 392 | (defmacro named-let (name bindings &rest body) | ||
| 393 | "Looping construct taken from Scheme. | ||
| 394 | Like `let', bind variables in BINDINGS and then evaluate BODY, | ||
| 395 | but with the twist that BODY can evaluate itself recursively by | ||
| 396 | calling NAME, where the arguments passed to NAME are used | ||
| 397 | as the new values of the bound variables in the recursive invocation." | ||
| 398 | (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body))) | ||
| 399 | (require 'cl-lib) | ||
| 400 | (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings)) | ||
| 401 | (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings))) | ||
| 402 | ;; According to the Scheme semantics of named let, `name' is not in scope | ||
| 403 | ;; while evaluating the expressions in `bindings', and for this reason, the | ||
| 404 | ;; "initial" function call below needs to be outside of the `cl-labels'. | ||
| 405 | ;; When the "self-tco" eliminates all recursive calls, the `cl-labels' | ||
| 406 | ;; expands to a lambda which the byte-compiler then combines with the | ||
| 407 | ;; funcall to make a `let' so we end up with a plain `while' loop and no | ||
| 408 | ;; remaining `lambda' at all. | ||
| 409 | `(funcall | ||
| 410 | (cl-labels ((,name ,fargs . ,body)) #',name) | ||
| 411 | . ,aargs))) | ||
| 412 | |||
| 413 | |||
| 392 | (provide 'subr-x) | 414 | (provide 'subr-x) |
| 393 | 415 | ||
| 394 | ;;; subr-x.el ends here | 416 | ;;; subr-x.el ends here |
diff --git a/lisp/emulation/cua-gmrk.el b/lisp/emulation/cua-gmrk.el index 195bba1f317..6f6b9fce130 100644 --- a/lisp/emulation/cua-gmrk.el +++ b/lisp/emulation/cua-gmrk.el | |||
| @@ -87,9 +87,11 @@ | |||
| 87 | 87 | ||
| 88 | (defun cua-toggle-global-mark (stay) | 88 | (defun cua-toggle-global-mark (stay) |
| 89 | "Set or cancel the global marker. | 89 | "Set or cancel the global marker. |
| 90 | When the global marker is set, CUA cut and copy commands will automatically | 90 | When the global marker is set, CUA cut and copy commands will |
| 91 | insert the deleted or copied text before the global marker, even when the | 91 | automatically insert the inserted, deleted or copied text before |
| 92 | global marker is in another buffer. | 92 | the global marker, even when the global marker is in another |
| 93 | buffer. | ||
| 94 | |||
| 93 | If the global marker isn't set, set the global marker at point in the current | 95 | If the global marker isn't set, set the global marker at point in the current |
| 94 | buffer. Otherwise jump to the global marker position and cancel it. | 96 | buffer. Otherwise jump to the global marker position and cancel it. |
| 95 | With prefix argument, don't jump to global mark when canceling it." | 97 | With prefix argument, don't jump to global mark when canceling it." |
diff --git a/lisp/epa.el b/lisp/epa.el index db2b1271473..197cd92f977 100644 --- a/lisp/epa.el +++ b/lisp/epa.el | |||
| @@ -359,8 +359,8 @@ DOC is documentation text to insert at the start." | |||
| 359 | 359 | ||
| 360 | ;; Find the end of the documentation text at the start. | 360 | ;; Find the end of the documentation text at the start. |
| 361 | ;; Set POINT to where it ends, or nil if ends at eob. | 361 | ;; Set POINT to where it ends, or nil if ends at eob. |
| 362 | (unless (get-text-property point 'epa-list-keys) | 362 | (unless (get-text-property point 'epa-key) |
| 363 | (setq point (next-single-property-change point 'epa-list-keys))) | 363 | (setq point (next-single-property-change point 'epa-key))) |
| 364 | 364 | ||
| 365 | ;; If caller specified documentation text for that, replace the old | 365 | ;; If caller specified documentation text for that, replace the old |
| 366 | ;; documentation text (if any) with what was specified. | 366 | ;; documentation text (if any) with what was specified. |
diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 2609397b0d9..dc5f8f46aba 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el | |||
| @@ -606,9 +606,14 @@ color. The function should accept a single argument, the color name." | |||
| 606 | 606 | ||
| 607 | (defun list-colors-print (list &optional callback) | 607 | (defun list-colors-print (list &optional callback) |
| 608 | (let ((callback-fn | 608 | (let ((callback-fn |
| 609 | (if callback | 609 | ;; Expect CALLBACK to be a function, but allow it to be a form that |
| 610 | `(lambda (button) | 610 | ;; evaluates to a function, for backward-compatibility. (Bug#45831) |
| 611 | (funcall ,callback (button-get button 'color-name)))))) | 611 | (cond ((functionp callback) |
| 612 | (lambda (button) | ||
| 613 | (funcall callback (button-get button 'color-name)))) | ||
| 614 | (callback | ||
| 615 | `(lambda (button) | ||
| 616 | (funcall ,callback (button-get button 'color-name))))))) | ||
| 612 | (dolist (color list) | 617 | (dolist (color list) |
| 613 | (if (consp color) | 618 | (if (consp color) |
| 614 | (if (cdr color) | 619 | (if (cdr color) |
diff --git a/lisp/faces.el b/lisp/faces.el index 4e98338432f..d654b1f0e2a 100644 --- a/lisp/faces.el +++ b/lisp/faces.el | |||
| @@ -2199,7 +2199,7 @@ the above example." | |||
| 2199 | (not (funcall pred type))) | 2199 | (not (funcall pred type))) |
| 2200 | ;; Strip off last hyphen and what follows, then try again | 2200 | ;; Strip off last hyphen and what follows, then try again |
| 2201 | (setq type | 2201 | (setq type |
| 2202 | (if (setq hyphend (string-match-p "[-_][^-_]+$" type)) | 2202 | (if (setq hyphend (string-match-p "[-_.][^-_.]+$" type)) |
| 2203 | (substring type 0 hyphend) | 2203 | (substring type 0 hyphend) |
| 2204 | nil)))) | 2204 | nil)))) |
| 2205 | type) | 2205 | type) |
diff --git a/lisp/files.el b/lisp/files.el index 695afae8c56..e9be7c7e75c 100644 --- a/lisp/files.el +++ b/lisp/files.el | |||
| @@ -4067,7 +4067,7 @@ Return the new variables list." | |||
| 4067 | (subdirs (assq 'subdirs alist))) | 4067 | (subdirs (assq 'subdirs alist))) |
| 4068 | (if (or (not subdirs) | 4068 | (if (or (not subdirs) |
| 4069 | (progn | 4069 | (progn |
| 4070 | (setq alist (delq subdirs alist)) | 4070 | (setq alist (remq subdirs alist)) |
| 4071 | (cdr-safe subdirs)) | 4071 | (cdr-safe subdirs)) |
| 4072 | ;; TODO someone might want to extend this to allow | 4072 | ;; TODO someone might want to extend this to allow |
| 4073 | ;; integer values for subdir, where N means | 4073 | ;; integer values for subdir, where N means |
diff --git a/lisp/font-lock.el b/lisp/font-lock.el index a51434c38c9..a9fc69d419a 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el | |||
| @@ -1104,8 +1104,8 @@ Called with two arguments BEG and END.") | |||
| 1104 | "Reinitialize the font-lock machinery and (re-)fontify the buffer. | 1104 | "Reinitialize the font-lock machinery and (re-)fontify the buffer. |
| 1105 | This functions is a convenience functions when developing font | 1105 | This functions is a convenience functions when developing font |
| 1106 | locking for a mode, and is not meant to be called from lisp functions." | 1106 | locking for a mode, and is not meant to be called from lisp functions." |
| 1107 | (interactive) | ||
| 1108 | (declare (interactive-only t)) | 1107 | (declare (interactive-only t)) |
| 1108 | (interactive) | ||
| 1109 | ;; Make font-lock recalculate all the mode-specific data. | 1109 | ;; Make font-lock recalculate all the mode-specific data. |
| 1110 | (setq font-lock-major-mode nil) | 1110 | (setq font-lock-major-mode nil) |
| 1111 | ;; Make the syntax machinery discard all information. | 1111 | ;; Make the syntax machinery discard all information. |
diff --git a/lisp/frame.el b/lisp/frame.el index e2d7f21a498..06aab269ddd 100644 --- a/lisp/frame.el +++ b/lisp/frame.el | |||
| @@ -2552,13 +2552,15 @@ Use 0 or negative value to blink forever." | |||
| 2552 | This starts the timer `blink-cursor-timer', which makes the cursor blink | 2552 | This starts the timer `blink-cursor-timer', which makes the cursor blink |
| 2553 | if appropriate. It also arranges to cancel that timer when the next | 2553 | if appropriate. It also arranges to cancel that timer when the next |
| 2554 | command starts, by installing a pre-command hook." | 2554 | command starts, by installing a pre-command hook." |
| 2555 | (when (null blink-cursor-timer) | 2555 | (cond |
| 2556 | ((null blink-cursor-mode) (blink-cursor-mode -1)) | ||
| 2557 | ((null blink-cursor-timer) | ||
| 2556 | ;; Set up the timer first, so that if this signals an error, | 2558 | ;; Set up the timer first, so that if this signals an error, |
| 2557 | ;; blink-cursor-end is not added to pre-command-hook. | 2559 | ;; blink-cursor-end is not added to pre-command-hook. |
| 2558 | (setq blink-cursor-blinks-done 1) | 2560 | (setq blink-cursor-blinks-done 1) |
| 2559 | (blink-cursor--start-timer) | 2561 | (blink-cursor--start-timer) |
| 2560 | (add-hook 'pre-command-hook #'blink-cursor-end) | 2562 | (add-hook 'pre-command-hook #'blink-cursor-end) |
| 2561 | (internal-show-cursor nil nil))) | 2563 | (internal-show-cursor nil nil)))) |
| 2562 | 2564 | ||
| 2563 | (defun blink-cursor-timer-function () | 2565 | (defun blink-cursor-timer-function () |
| 2564 | "Timer function of timer `blink-cursor-timer'." | 2566 | "Timer function of timer `blink-cursor-timer'." |
| @@ -2615,7 +2617,7 @@ stopped by `blink-cursor-suspend'. Internally calls | |||
| 2615 | `blink-cursor--should-blink' and returns its result." | 2617 | `blink-cursor--should-blink' and returns its result." |
| 2616 | (let ((should-blink (blink-cursor--should-blink))) | 2618 | (let ((should-blink (blink-cursor--should-blink))) |
| 2617 | (when (and should-blink (not blink-cursor-idle-timer)) | 2619 | (when (and should-blink (not blink-cursor-idle-timer)) |
| 2618 | (remove-hook 'post-command-hook 'blink-cursor-check) | 2620 | (remove-hook 'post-command-hook #'blink-cursor-check) |
| 2619 | (blink-cursor--start-idle-timer)) | 2621 | (blink-cursor--start-idle-timer)) |
| 2620 | should-blink)) | 2622 | should-blink)) |
| 2621 | 2623 | ||
| @@ -2637,16 +2639,16 @@ This command is effective only on graphical frames. On text-only | |||
| 2637 | terminals, cursor blinking is controlled by the terminal." | 2639 | terminals, cursor blinking is controlled by the terminal." |
| 2638 | :init-value (not (or noninteractive | 2640 | :init-value (not (or noninteractive |
| 2639 | no-blinking-cursor | 2641 | no-blinking-cursor |
| 2640 | (eq system-type 'ms-dos) | 2642 | (eq system-type 'ms-dos))) |
| 2641 | (not (display-blink-cursor-p)))) | 2643 | :initialize #'custom-initialize-delay |
| 2642 | :initialize 'custom-initialize-delay | ||
| 2643 | :group 'cursor | 2644 | :group 'cursor |
| 2644 | :global t | 2645 | :global t |
| 2645 | (blink-cursor-suspend) | 2646 | (blink-cursor-suspend) |
| 2646 | (remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) | 2647 | (remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) |
| 2647 | (remove-function after-focus-change-function #'blink-cursor--rescan-frames) | 2648 | (remove-function after-focus-change-function #'blink-cursor--rescan-frames) |
| 2648 | (when blink-cursor-mode | 2649 | (when blink-cursor-mode |
| 2649 | (add-function :after after-focus-change-function #'blink-cursor--rescan-frames) | 2650 | (add-function :after after-focus-change-function |
| 2651 | #'blink-cursor--rescan-frames) | ||
| 2650 | (add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) | 2652 | (add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) |
| 2651 | (blink-cursor-check))) | 2653 | (blink-cursor-check))) |
| 2652 | 2654 | ||
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 56640ea8302..686623029ed 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el | |||
| @@ -1789,6 +1789,7 @@ variables. Returns the first non-nil value found." | |||
| 1789 | . gnus-agent-enable-expiration) | 1789 | . gnus-agent-enable-expiration) |
| 1790 | (agent-predicate . gnus-agent-predicate))))))) | 1790 | (agent-predicate . gnus-agent-predicate))))))) |
| 1791 | 1791 | ||
| 1792 | ;; FIXME: This looks an awful lot like `gnus-agent-retrieve-headers'. | ||
| 1792 | (defun gnus-agent-fetch-headers (group) | 1793 | (defun gnus-agent-fetch-headers (group) |
| 1793 | "Fetch interesting headers into the agent. The group's overview | 1794 | "Fetch interesting headers into the agent. The group's overview |
| 1794 | file will be updated to include the headers while a list of available | 1795 | file will be updated to include the headers while a list of available |
| @@ -1810,10 +1811,9 @@ article numbers will be returned." | |||
| 1810 | (cdr active)))) | 1811 | (cdr active)))) |
| 1811 | (gnus-uncompress-range (gnus-active group))) | 1812 | (gnus-uncompress-range (gnus-active group))) |
| 1812 | (gnus-list-of-unread-articles group))) | 1813 | (gnus-list-of-unread-articles group))) |
| 1813 | (gnus-decode-encoded-word-function 'identity) | ||
| 1814 | (gnus-decode-encoded-address-function 'identity) | ||
| 1815 | (file (gnus-agent-article-name ".overview" group)) | 1814 | (file (gnus-agent-article-name ".overview" group)) |
| 1816 | (file-name-coding-system nnmail-pathname-coding-system)) | 1815 | (file-name-coding-system nnmail-pathname-coding-system) |
| 1816 | headers fetched-headers) | ||
| 1817 | 1817 | ||
| 1818 | (unless fetch-all | 1818 | (unless fetch-all |
| 1819 | ;; Add articles with marks to the list of article headers we want to | 1819 | ;; Add articles with marks to the list of article headers we want to |
| @@ -1824,7 +1824,7 @@ article numbers will be returned." | |||
| 1824 | (dolist (arts (gnus-info-marks (gnus-get-info group))) | 1824 | (dolist (arts (gnus-info-marks (gnus-get-info group))) |
| 1825 | (unless (memq (car arts) '(seen recent killed cache)) | 1825 | (unless (memq (car arts) '(seen recent killed cache)) |
| 1826 | (setq articles (gnus-range-add articles (cdr arts))))) | 1826 | (setq articles (gnus-range-add articles (cdr arts))))) |
| 1827 | (setq articles (sort (gnus-uncompress-sequence articles) '<))) | 1827 | (setq articles (sort (gnus-uncompress-range articles) '<))) |
| 1828 | 1828 | ||
| 1829 | ;; At this point, I have the list of articles to consider for | 1829 | ;; At this point, I have the list of articles to consider for |
| 1830 | ;; fetching. This is the list that I'll return to my caller. Some | 1830 | ;; fetching. This is the list that I'll return to my caller. Some |
| @@ -1867,38 +1867,52 @@ article numbers will be returned." | |||
| 1867 | 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" | 1867 | 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" |
| 1868 | (gnus-compress-sequence articles t))) | 1868 | (gnus-compress-sequence articles t))) |
| 1869 | 1869 | ||
| 1870 | (with-current-buffer nntp-server-buffer | 1870 | ;; Parse known headers from FILE. |
| 1871 | (if articles | 1871 | (if (file-exists-p file) |
| 1872 | (progn | 1872 | (with-current-buffer gnus-agent-overview-buffer |
| 1873 | (gnus-message 8 "Fetching headers for %s..." group) | 1873 | (erase-buffer) |
| 1874 | 1874 | (let ((nnheader-file-coding-system | |
| 1875 | ;; Fetch them. | 1875 | gnus-agent-file-coding-system)) |
| 1876 | (gnus-make-directory (nnheader-translate-file-chars | 1876 | (nnheader-insert-nov-file file (car articles)) |
| 1877 | (file-name-directory file) t)) | 1877 | (with-current-buffer nntp-server-buffer |
| 1878 | 1878 | (erase-buffer) | |
| 1879 | (unless (eq 'nov (gnus-retrieve-headers articles group)) | 1879 | (insert-buffer-substring gnus-agent-overview-buffer) |
| 1880 | (nnvirtual-convert-headers)) | 1880 | (setq headers |
| 1881 | (gnus-agent-check-overview-buffer) | 1881 | (gnus-get-newsgroup-headers-xover |
| 1882 | ;; Move these headers to the overview buffer so that | 1882 | articles nil (buffer-local-value |
| 1883 | ;; gnus-agent-braid-nov can merge them with the contents | 1883 | 'gnus-newsgroup-dependencies |
| 1884 | ;; of FILE. | 1884 | gnus-summary-buffer) |
| 1885 | (copy-to-buffer | 1885 | gnus-newsgroup-name))))) |
| 1886 | gnus-agent-overview-buffer (point-min) (point-max)) | 1886 | (gnus-make-directory (nnheader-translate-file-chars |
| 1887 | ;; NOTE: Call g-a-brand-nov even when the file does not | 1887 | (file-name-directory file) t))) |
| 1888 | ;; exist. As a minimum, it will validate the article | 1888 | |
| 1889 | ;; numbers already in the buffer. | 1889 | ;; Fetch our new headers. |
| 1890 | (gnus-agent-braid-nov articles file) | 1890 | (gnus-message 8 "Fetching headers for %s..." group) |
| 1891 | (let ((coding-system-for-write | 1891 | (if articles |
| 1892 | gnus-agent-file-coding-system)) | 1892 | (setq fetched-headers (gnus-fetch-headers articles))) |
| 1893 | (gnus-agent-check-overview-buffer) | 1893 | |
| 1894 | (write-region (point-min) (point-max) file nil 'silent)) | 1894 | ;; Merge two sets of headers. |
| 1895 | (gnus-agent-update-view-total-fetched-for group t) | 1895 | (setq headers |
| 1896 | (gnus-agent-save-alist group articles nil) | 1896 | (if (and headers fetched-headers) |
| 1897 | articles) | 1897 | (delete-dups |
| 1898 | (ignore-errors | 1898 | (sort (append headers (copy-sequence fetched-headers)) |
| 1899 | (erase-buffer) | 1899 | (lambda (l r) |
| 1900 | (nnheader-insert-file-contents file))))) | 1900 | (< (mail-header-number l) |
| 1901 | articles)) | 1901 | (mail-header-number r))))) |
| 1902 | (or headers fetched-headers))) | ||
| 1903 | |||
| 1904 | ;; Save the new set of headers to FILE. | ||
| 1905 | (let ((coding-system-for-write | ||
| 1906 | gnus-agent-file-coding-system)) | ||
| 1907 | (with-current-buffer gnus-agent-overview-buffer | ||
| 1908 | (goto-char (point-max)) | ||
| 1909 | (mapc #'nnheader-insert-nov fetched-headers) | ||
| 1910 | (sort-numeric-fields 1 (point-min) (point-max)) | ||
| 1911 | (gnus-agent-check-overview-buffer) | ||
| 1912 | (write-region (point-min) (point-max) file nil 'silent)) | ||
| 1913 | (gnus-agent-update-view-total-fetched-for group t) | ||
| 1914 | (gnus-agent-save-alist group articles nil))) | ||
| 1915 | headers)) | ||
| 1902 | 1916 | ||
| 1903 | (defsubst gnus-agent-read-article-number () | 1917 | (defsubst gnus-agent-read-article-number () |
| 1904 | "Read the article number at point. | 1918 | "Read the article number at point. |
| @@ -1924,96 +1938,6 @@ Return nil when a valid article number can not be read." | |||
| 1924 | (set-buffer nntp-server-buffer) | 1938 | (set-buffer nntp-server-buffer) |
| 1925 | (insert-buffer-substring gnus-agent-overview-buffer b e)))) | 1939 | (insert-buffer-substring gnus-agent-overview-buffer b e)))) |
| 1926 | 1940 | ||
| 1927 | (defun gnus-agent-braid-nov (articles file) | ||
| 1928 | "Merge agent overview data with given file. | ||
| 1929 | Takes unvalidated headers for ARTICLES from | ||
| 1930 | `gnus-agent-overview-buffer' and validated headers from the given | ||
| 1931 | FILE and places the combined valid headers into | ||
| 1932 | `nntp-server-buffer'. This function can be used, when file | ||
| 1933 | doesn't exist, to valid the overview buffer." | ||
| 1934 | (let (start last) | ||
| 1935 | (set-buffer gnus-agent-overview-buffer) | ||
| 1936 | (goto-char (point-min)) | ||
| 1937 | (set-buffer nntp-server-buffer) | ||
| 1938 | (erase-buffer) | ||
| 1939 | (when (file-exists-p file) | ||
| 1940 | (nnheader-insert-file-contents file)) | ||
| 1941 | (goto-char (point-max)) | ||
| 1942 | (forward-line -1) | ||
| 1943 | |||
| 1944 | (unless (or (= (point-min) (point-max)) | ||
| 1945 | (< (setq last (read (current-buffer))) (car articles))) | ||
| 1946 | ;; Old and new overlap -- We do it the hard way. | ||
| 1947 | (when (nnheader-find-nov-line (car articles)) | ||
| 1948 | ;; Replacing existing NOV entry | ||
| 1949 | (delete-region (point) (progn (forward-line 1) (point)))) | ||
| 1950 | (gnus-agent-copy-nov-line (pop articles)) | ||
| 1951 | |||
| 1952 | (ignore-errors | ||
| 1953 | (while articles | ||
| 1954 | (while (let ((art (read (current-buffer)))) | ||
| 1955 | (cond ((< art (car articles)) | ||
| 1956 | (forward-line 1) | ||
| 1957 | t) | ||
| 1958 | ((= art (car articles)) | ||
| 1959 | (beginning-of-line) | ||
| 1960 | (delete-region | ||
| 1961 | (point) (progn (forward-line 1) (point))) | ||
| 1962 | nil) | ||
| 1963 | (t | ||
| 1964 | (beginning-of-line) | ||
| 1965 | nil)))) | ||
| 1966 | |||
| 1967 | (gnus-agent-copy-nov-line (pop articles))))) | ||
| 1968 | |||
| 1969 | (goto-char (point-max)) | ||
| 1970 | |||
| 1971 | ;; Append the remaining lines | ||
| 1972 | (when articles | ||
| 1973 | (when last | ||
| 1974 | (set-buffer gnus-agent-overview-buffer) | ||
| 1975 | (setq start (point)) | ||
| 1976 | (set-buffer nntp-server-buffer)) | ||
| 1977 | |||
| 1978 | (let ((p (point))) | ||
| 1979 | (insert-buffer-substring gnus-agent-overview-buffer start) | ||
| 1980 | (goto-char p)) | ||
| 1981 | |||
| 1982 | (setq last (or last -134217728)) | ||
| 1983 | (while (catch 'problems | ||
| 1984 | (let (sort art) | ||
| 1985 | (while (not (eobp)) | ||
| 1986 | (setq art (gnus-agent-read-article-number)) | ||
| 1987 | (cond ((not art) | ||
| 1988 | ;; Bad art num - delete this line | ||
| 1989 | (beginning-of-line) | ||
| 1990 | (delete-region (point) (progn (forward-line 1) (point)))) | ||
| 1991 | ((< art last) | ||
| 1992 | ;; Art num out of order - enable sort | ||
| 1993 | (setq sort t) | ||
| 1994 | (forward-line 1)) | ||
| 1995 | ((= art last) | ||
| 1996 | ;; Bad repeat of art number - delete this line | ||
| 1997 | (beginning-of-line) | ||
| 1998 | (delete-region (point) (progn (forward-line 1) (point)))) | ||
| 1999 | (t | ||
| 2000 | ;; Good art num | ||
| 2001 | (setq last art) | ||
| 2002 | (forward-line 1)))) | ||
| 2003 | (when sort | ||
| 2004 | ;; something is seriously wrong as we simply shouldn't see out-of-order data. | ||
| 2005 | ;; First, we'll fix the sort. | ||
| 2006 | (sort-numeric-fields 1 (point-min) (point-max)) | ||
| 2007 | |||
| 2008 | ;; but now we have to consider that we may have duplicate rows... | ||
| 2009 | ;; so reset to beginning of file | ||
| 2010 | (goto-char (point-min)) | ||
| 2011 | (setq last -134217728) | ||
| 2012 | |||
| 2013 | ;; and throw a code that restarts this scan | ||
| 2014 | (throw 'problems t)) | ||
| 2015 | nil)))))) | ||
| 2016 | |||
| 2017 | ;; Keeps the compiler from warning about the free variable in | 1941 | ;; Keeps the compiler from warning about the free variable in |
| 2018 | ;; gnus-agent-read-agentview. | 1942 | ;; gnus-agent-read-agentview. |
| 2019 | (defvar gnus-agent-read-agentview) | 1943 | (defvar gnus-agent-read-agentview) |
| @@ -2386,10 +2310,9 @@ modified) original contents, they are first saved to their own file." | |||
| 2386 | (gnus-orphan-score gnus-orphan-score) | 2310 | (gnus-orphan-score gnus-orphan-score) |
| 2387 | ;; Maybe some other gnus-summary local variables should also | 2311 | ;; Maybe some other gnus-summary local variables should also |
| 2388 | ;; be put here. | 2312 | ;; be put here. |
| 2389 | 2313 | fetched-headers | |
| 2390 | gnus-headers | 2314 | gnus-headers |
| 2391 | gnus-score | 2315 | gnus-score |
| 2392 | articles | ||
| 2393 | predicate info marks | 2316 | predicate info marks |
| 2394 | ) | 2317 | ) |
| 2395 | (unless (gnus-check-group group) | 2318 | (unless (gnus-check-group group) |
| @@ -2410,38 +2333,35 @@ modified) original contents, they are first saved to their own file." | |||
| 2410 | (setq info (gnus-get-info group))))))) | 2333 | (setq info (gnus-get-info group))))))) |
| 2411 | (when arts | 2334 | (when arts |
| 2412 | (setq marked-articles (nconc (gnus-uncompress-range arts) | 2335 | (setq marked-articles (nconc (gnus-uncompress-range arts) |
| 2413 | marked-articles)) | 2336 | marked-articles)))))) |
| 2414 | )))) | ||
| 2415 | (setq marked-articles (sort marked-articles '<)) | 2337 | (setq marked-articles (sort marked-articles '<)) |
| 2416 | 2338 | ||
| 2417 | ;; Fetch any new articles from the server | 2339 | (setq gnus-newsgroup-dependencies |
| 2418 | (setq articles (gnus-agent-fetch-headers group)) | 2340 | (or gnus-newsgroup-dependencies |
| 2341 | (gnus-make-hashtable))) | ||
| 2419 | 2342 | ||
| 2420 | ;; Merge new articles with marked | 2343 | ;; Fetch headers for any new articles from the server. |
| 2421 | (setq articles (sort (append marked-articles articles) '<)) | 2344 | (setq fetched-headers (gnus-agent-fetch-headers group)) |
| 2422 | 2345 | ||
| 2423 | (when articles | 2346 | (when fetched-headers |
| 2424 | ;; Parse them and see which articles we want to fetch. | ||
| 2425 | (setq gnus-newsgroup-dependencies | ||
| 2426 | (or gnus-newsgroup-dependencies | ||
| 2427 | (gnus-make-hashtable (length articles)))) | ||
| 2428 | (setq gnus-newsgroup-headers | 2347 | (setq gnus-newsgroup-headers |
| 2429 | (or gnus-newsgroup-headers | 2348 | (or gnus-newsgroup-headers |
| 2430 | (gnus-get-newsgroup-headers-xover articles nil nil | 2349 | fetched-headers))) |
| 2431 | group))) | 2350 | (when marked-articles |
| 2432 | ;; `gnus-agent-overview-buffer' may be killed for | 2351 | ;; `gnus-agent-overview-buffer' may be killed for timeout |
| 2433 | ;; timeout reason. If so, recreate it. | 2352 | ;; reason. If so, recreate it. |
| 2434 | (gnus-agent-create-buffer) | 2353 | (gnus-agent-create-buffer) |
| 2435 | 2354 | ||
| 2436 | (setq predicate | 2355 | (setq predicate |
| 2437 | (gnus-get-predicate | 2356 | (gnus-get-predicate |
| 2438 | (gnus-agent-find-parameter group 'agent-predicate))) | 2357 | (gnus-agent-find-parameter group 'agent-predicate))) |
| 2358 | |||
| 2359 | ;; If the selection predicate requires scoring, score each header. | ||
| 2439 | 2360 | ||
| 2440 | ;; If the selection predicate requires scoring, score each header | ||
| 2441 | (unless (memq predicate '(gnus-agent-true gnus-agent-false)) | 2361 | (unless (memq predicate '(gnus-agent-true gnus-agent-false)) |
| 2442 | (let ((score-param | 2362 | (let ((score-param |
| 2443 | (gnus-agent-find-parameter group 'agent-score-file))) | 2363 | (gnus-agent-find-parameter group 'agent-score-file))) |
| 2444 | ;; Translate score-param into real one | 2364 | ;; Translate score-param into real one. |
| 2445 | (cond | 2365 | (cond |
| 2446 | ((not score-param)) | 2366 | ((not score-param)) |
| 2447 | ((eq score-param 'file) | 2367 | ((eq score-param 'file) |
| @@ -3661,11 +3581,9 @@ has been fetched." | |||
| 3661 | (defun gnus-agent-retrieve-headers (articles group &optional fetch-old) | 3581 | (defun gnus-agent-retrieve-headers (articles group &optional fetch-old) |
| 3662 | (save-excursion | 3582 | (save-excursion |
| 3663 | (gnus-agent-create-buffer) | 3583 | (gnus-agent-create-buffer) |
| 3664 | (let ((gnus-decode-encoded-word-function 'identity) | 3584 | (let ((file (gnus-agent-article-name ".overview" group)) |
| 3665 | (gnus-decode-encoded-address-function 'identity) | 3585 | (file-name-coding-system nnmail-pathname-coding-system) |
| 3666 | (file (gnus-agent-article-name ".overview" group)) | 3586 | uncached-articles headers fetched-headers) |
| 3667 | uncached-articles | ||
| 3668 | (file-name-coding-system nnmail-pathname-coding-system)) | ||
| 3669 | (gnus-make-directory (nnheader-translate-file-chars | 3587 | (gnus-make-directory (nnheader-translate-file-chars |
| 3670 | (file-name-directory file) t)) | 3588 | (file-name-directory file) t)) |
| 3671 | 3589 | ||
| @@ -3676,122 +3594,63 @@ has been fetched." | |||
| 3676 | 1) | 3594 | 1) |
| 3677 | (car (last articles)))))) | 3595 | (car (last articles)))))) |
| 3678 | 3596 | ||
| 3679 | ;; Populate temp buffer with known headers | 3597 | ;; See if we've got cached headers for ARTICLES and put them in |
| 3598 | ;; HEADERS. Articles with no cached headers go in | ||
| 3599 | ;; UNCACHED-ARTICLES to be fetched from the server. | ||
| 3680 | (when (file-exists-p file) | 3600 | (when (file-exists-p file) |
| 3681 | (with-current-buffer gnus-agent-overview-buffer | 3601 | (with-current-buffer gnus-agent-overview-buffer |
| 3682 | (erase-buffer) | 3602 | (erase-buffer) |
| 3683 | (let ((nnheader-file-coding-system | 3603 | (let ((nnheader-file-coding-system |
| 3684 | gnus-agent-file-coding-system)) | 3604 | gnus-agent-file-coding-system)) |
| 3685 | (nnheader-insert-nov-file file (car articles))))) | 3605 | (nnheader-insert-nov-file file (car articles)) |
| 3686 | 3606 | (with-current-buffer nntp-server-buffer | |
| 3687 | (if (setq uncached-articles (gnus-agent-uncached-articles articles group | 3607 | (erase-buffer) |
| 3688 | t)) | 3608 | (insert-buffer-substring gnus-agent-overview-buffer) |
| 3689 | (progn | 3609 | (setq headers |
| 3690 | ;; Populate nntp-server-buffer with uncached headers | 3610 | (gnus-get-newsgroup-headers-xover |
| 3691 | (set-buffer nntp-server-buffer) | 3611 | articles nil (buffer-local-value |
| 3692 | (erase-buffer) | 3612 | 'gnus-newsgroup-dependencies |
| 3693 | (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent | 3613 | gnus-summary-buffer) |
| 3694 | (gnus-retrieve-headers | 3614 | gnus-newsgroup-name)))))) |
| 3695 | uncached-articles group)))) | 3615 | |
| 3696 | (nnvirtual-convert-headers)) | 3616 | (setq uncached-articles |
| 3697 | ((eq 'nntp (car gnus-current-select-method)) | 3617 | (gnus-agent-uncached-articles articles group t)) |
| 3698 | ;; The author of gnus-get-newsgroup-headers-xover | 3618 | |
| 3699 | ;; reports that the XOVER command is commonly | 3619 | (when uncached-articles |
| 3700 | ;; unreliable. The problem is that recently | 3620 | (let ((gnus-newsgroup-name group) |
| 3701 | ;; posted articles may not be entered into the | 3621 | gnus-agent) ; Prevent loop. |
| 3702 | ;; NOV database in time to respond to my XOVER | 3622 | ;; Fetch additional headers for the uncached articles. |
| 3703 | ;; query. | 3623 | (setq fetched-headers (gnus-fetch-headers uncached-articles)) |
| 3704 | ;; | 3624 | ;; Merge headers we got from the overview file with our |
| 3705 | ;; I'm going to use his assumption that the NOV | 3625 | ;; newly-fetched headers. |
| 3706 | ;; database is updated in order of ascending | 3626 | (when fetched-headers |
| 3707 | ;; article ID. Therefore, a response containing | 3627 | (setq headers |
| 3708 | ;; article ID N implies that all articles from 1 | 3628 | (delete-dups |
| 3709 | ;; to N-1 are up-to-date. Therefore, missing | 3629 | (sort (append headers (copy-sequence fetched-headers)) |
| 3710 | ;; articles in that range have expired. | 3630 | (lambda (l r) |
| 3711 | 3631 | (< (mail-header-number l) | |
| 3712 | (set-buffer nntp-server-buffer) | 3632 | (mail-header-number r)))))) |
| 3713 | (let* ((fetched-articles (list nil)) | 3633 | |
| 3714 | (tail-fetched-articles fetched-articles) | 3634 | ;; Add the new set of known headers to the overview file. |
| 3715 | (min (car articles)) | ||
| 3716 | (max (car (last articles)))) | ||
| 3717 | |||
| 3718 | ;; Get the list of articles that were fetched | ||
| 3719 | (goto-char (point-min)) | ||
| 3720 | (let ((pm (point-max)) | ||
| 3721 | art) | ||
| 3722 | (while (< (point) pm) | ||
| 3723 | (when (setq art (gnus-agent-read-article-number)) | ||
| 3724 | (gnus-agent-append-to-list tail-fetched-articles art)) | ||
| 3725 | (forward-line 1))) | ||
| 3726 | |||
| 3727 | ;; Clip this list to the headers that will | ||
| 3728 | ;; actually be returned | ||
| 3729 | (setq fetched-articles (gnus-list-range-intersection | ||
| 3730 | (cdr fetched-articles) | ||
| 3731 | (cons min max))) | ||
| 3732 | |||
| 3733 | ;; Clip the uncached articles list to exclude | ||
| 3734 | ;; IDs after the last FETCHED header. The | ||
| 3735 | ;; excluded IDs may be fetchable using HEAD. | ||
| 3736 | (if (car tail-fetched-articles) | ||
| 3737 | (setq uncached-articles | ||
| 3738 | (gnus-list-range-intersection | ||
| 3739 | uncached-articles | ||
| 3740 | (cons (car uncached-articles) | ||
| 3741 | (car tail-fetched-articles))))) | ||
| 3742 | |||
| 3743 | ;; Create the list of articles that were | ||
| 3744 | ;; "successfully" fetched. Success, in this | ||
| 3745 | ;; case, means that the ID should not be | ||
| 3746 | ;; fetched again. In the case of an expired | ||
| 3747 | ;; article, the header will not be fetched. | ||
| 3748 | (setq uncached-articles | ||
| 3749 | (gnus-sorted-nunion fetched-articles | ||
| 3750 | uncached-articles)) | ||
| 3751 | ))) | ||
| 3752 | |||
| 3753 | ;; Erase the temp buffer | ||
| 3754 | (set-buffer gnus-agent-overview-buffer) | ||
| 3755 | (erase-buffer) | ||
| 3756 | |||
| 3757 | ;; Copy the nntp-server-buffer to the temp buffer | ||
| 3758 | (set-buffer nntp-server-buffer) | ||
| 3759 | (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) | ||
| 3760 | |||
| 3761 | ;; Merge the temp buffer with the known headers (found on | ||
| 3762 | ;; disk in FILE) into the nntp-server-buffer | ||
| 3763 | (when uncached-articles | ||
| 3764 | (gnus-agent-braid-nov uncached-articles file)) | ||
| 3765 | |||
| 3766 | ;; Save the new set of known headers to FILE | ||
| 3767 | (set-buffer nntp-server-buffer) | ||
| 3768 | (let ((coding-system-for-write | 3635 | (let ((coding-system-for-write |
| 3769 | gnus-agent-file-coding-system)) | 3636 | gnus-agent-file-coding-system)) |
| 3770 | (gnus-agent-check-overview-buffer) | 3637 | (with-current-buffer gnus-agent-overview-buffer |
| 3771 | (write-region (point-min) (point-max) file nil 'silent)) | 3638 | ;; We stick the new headers in at the end, then |
| 3772 | 3639 | ;; re-sort the whole buffer with | |
| 3773 | (gnus-agent-update-view-total-fetched-for group t) | 3640 | ;; `sort-numeric-fields'. If this turns out to be |
| 3774 | 3641 | ;; slow, we could consider a loop to add the headers | |
| 3775 | ;; Update the group's article alist to include the newly | 3642 | ;; in sorted order to begin with. |
| 3776 | ;; fetched articles. | 3643 | (goto-char (point-max)) |
| 3777 | (gnus-agent-load-alist group) | 3644 | (mapc #'nnheader-insert-nov fetched-headers) |
| 3778 | (gnus-agent-save-alist group uncached-articles nil) | 3645 | (sort-numeric-fields 1 (point-min) (point-max)) |
| 3779 | ) | 3646 | (gnus-agent-check-overview-buffer) |
| 3780 | 3647 | (write-region (point-min) (point-max) file nil 'silent) | |
| 3781 | ;; Copy the temp buffer to the nntp-server-buffer | 3648 | (gnus-agent-update-view-total-fetched-for group t) |
| 3782 | (set-buffer nntp-server-buffer) | 3649 | ;; Update the group's article alist to include the |
| 3783 | (erase-buffer) | 3650 | ;; newly fetched articles. |
| 3784 | (insert-buffer-substring gnus-agent-overview-buffer))) | 3651 | (gnus-agent-load-alist group) |
| 3785 | 3652 | (gnus-agent-save-alist group uncached-articles nil)))))) | |
| 3786 | (if (and fetch-old | 3653 | headers))) |
| 3787 | (not (numberp fetch-old))) | ||
| 3788 | t ; Don't remove anything. | ||
| 3789 | (nnheader-nov-delete-outside-range | ||
| 3790 | (car articles) | ||
| 3791 | (car (last articles))) | ||
| 3792 | t) | ||
| 3793 | |||
| 3794 | 'nov)) | ||
| 3795 | 3654 | ||
| 3796 | (defun gnus-agent-request-article (article group) | 3655 | (defun gnus-agent-request-article (article group) |
| 3797 | "Retrieve ARTICLE in GROUP from the agent cache." | 3656 | "Retrieve ARTICLE in GROUP from the agent cache." |
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index fefd02c7bfb..ed948a26c0b 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el | |||
| @@ -357,8 +357,13 @@ that was fetched." | |||
| 357 | (let ((nntp-server-buffer (current-buffer)) | 357 | (let ((nntp-server-buffer (current-buffer)) |
| 358 | (nnheader-callback-function | 358 | (nnheader-callback-function |
| 359 | (lambda (_arg) | 359 | (lambda (_arg) |
| 360 | (setq gnus-async-header-prefetched | 360 | (setq gnus-async-header-prefetched |
| 361 | (cons group unread))))) | 361 | (cons group unread))))) |
| 362 | ;; FIXME: If header prefetch is ever put into use, we'll | ||
| 363 | ;; have to handle the possibility that | ||
| 364 | ;; `gnus-retrieve-headers' might return a list of header | ||
| 365 | ;; vectors directly, rather than writing them into the | ||
| 366 | ;; current buffer. | ||
| 362 | (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) | 367 | (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) |
| 363 | 368 | ||
| 364 | (defun gnus-async-retrieve-fetched-headers (articles group) | 369 | (defun gnus-async-retrieve-fetched-headers (articles group) |
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 36657e46219..9423d9f2f6b 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el | |||
| @@ -294,49 +294,47 @@ it's not cached." | |||
| 294 | (defun gnus-cache-retrieve-headers (articles group &optional fetch-old) | 294 | (defun gnus-cache-retrieve-headers (articles group &optional fetch-old) |
| 295 | "Retrieve the headers for ARTICLES in GROUP." | 295 | "Retrieve the headers for ARTICLES in GROUP." |
| 296 | (let ((cached | 296 | (let ((cached |
| 297 | (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) | 297 | (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))) |
| 298 | (gnus-newsgroup-name group) | ||
| 299 | (gnus-fetch-old-headers fetch-old)) | ||
| 298 | (if (not cached) | 300 | (if (not cached) |
| 299 | ;; No cached articles here, so we just retrieve them | 301 | ;; No cached articles here, so we just retrieve them |
| 300 | ;; the normal way. | 302 | ;; the normal way. |
| 301 | (let ((gnus-use-cache nil)) | 303 | (let ((gnus-use-cache nil)) |
| 302 | (gnus-retrieve-headers articles group fetch-old)) | 304 | (gnus-retrieve-headers articles group)) |
| 303 | (let ((uncached-articles (gnus-sorted-difference articles cached)) | 305 | (let ((uncached-articles (gnus-sorted-difference articles cached)) |
| 304 | (cache-file (gnus-cache-file-name group ".overview")) | 306 | (cache-file (gnus-cache-file-name group ".overview")) |
| 305 | type | 307 | (file-name-coding-system nnmail-pathname-coding-system) |
| 306 | (file-name-coding-system nnmail-pathname-coding-system)) | 308 | headers) |
| 307 | ;; We first retrieve all the headers that we don't have in | 309 | ;; We first retrieve all the headers that we don't have in |
| 308 | ;; the cache. | 310 | ;; the cache. |
| 309 | (let ((gnus-use-cache nil)) | 311 | (let ((gnus-use-cache nil)) |
| 310 | (when uncached-articles | 312 | (when uncached-articles |
| 311 | (setq type (and articles | 313 | (setq headers (and articles |
| 312 | (gnus-retrieve-headers | 314 | (gnus-fetch-headers uncached-articles))))) |
| 313 | uncached-articles group fetch-old))))) | ||
| 314 | (gnus-cache-save-buffers) | 315 | (gnus-cache-save-buffers) |
| 315 | ;; Then we insert the cached headers. | 316 | ;; Then we include the cached headers. |
| 316 | (save-excursion | 317 | (when (file-exists-p cache-file) |
| 317 | (cond | 318 | (setq headers |
| 318 | ((not (file-exists-p cache-file)) | 319 | (delete-dups |
| 319 | ;; There are no cached headers. | 320 | (sort |
| 320 | type) | 321 | (append headers |
| 321 | ((null type) | 322 | (let ((coding-system-for-read |
| 322 | ;; There were no uncached headers (or retrieval was | 323 | gnus-cache-overview-coding-system)) |
| 323 | ;; unsuccessful), so we use the cached headers exclusively. | 324 | (with-current-buffer nntp-server-buffer |
| 324 | (set-buffer nntp-server-buffer) | 325 | (erase-buffer) |
| 325 | (erase-buffer) | 326 | (insert-file-contents cache-file) |
| 326 | (let ((coding-system-for-read | 327 | (gnus-get-newsgroup-headers-xover |
| 327 | gnus-cache-overview-coding-system)) | 328 | (gnus-sorted-difference |
| 328 | (insert-file-contents cache-file)) | 329 | cached uncached-articles) |
| 329 | 'nov) | 330 | nil (buffer-local-value |
| 330 | ((eq type 'nov) | 331 | 'gnus-newsgroup-dependencies |
| 331 | ;; We have both cached and uncached NOV headers, so we | 332 | gnus-summary-buffer) |
| 332 | ;; braid them. | 333 | group)))) |
| 333 | (gnus-cache-braid-nov group cached) | 334 | (lambda (l r) |
| 334 | type) | 335 | (< (mail-header-number l) |
| 335 | (t | 336 | (mail-header-number r))))))) |
| 336 | ;; We braid HEADs. | 337 | headers)))) |
| 337 | (gnus-cache-braid-heads group (gnus-sorted-intersection | ||
| 338 | cached articles)) | ||
| 339 | type))))))) | ||
| 340 | 338 | ||
| 341 | (defun gnus-cache-enter-article (&optional n) | 339 | (defun gnus-cache-enter-article (&optional n) |
| 342 | "Enter the next N articles into the cache. | 340 | "Enter the next N articles into the cache. |
| @@ -529,70 +527,6 @@ Returns the list of articles removed." | |||
| 529 | (setq gnus-cache-active-altered t))) | 527 | (setq gnus-cache-active-altered t))) |
| 530 | articles))) | 528 | articles))) |
| 531 | 529 | ||
| 532 | (defun gnus-cache-braid-nov (group cached &optional file) | ||
| 533 | (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")) | ||
| 534 | beg end) | ||
| 535 | (gnus-cache-save-buffers) | ||
| 536 | (with-current-buffer cache-buf | ||
| 537 | (erase-buffer) | ||
| 538 | (let ((coding-system-for-read gnus-cache-overview-coding-system) | ||
| 539 | (file-name-coding-system nnmail-pathname-coding-system)) | ||
| 540 | (insert-file-contents | ||
| 541 | (or file (gnus-cache-file-name group ".overview")))) | ||
| 542 | (goto-char (point-min)) | ||
| 543 | (insert "\n") | ||
| 544 | (goto-char (point-min))) | ||
| 545 | (set-buffer nntp-server-buffer) | ||
| 546 | (goto-char (point-min)) | ||
| 547 | (while cached | ||
| 548 | (while (and (not (eobp)) | ||
| 549 | (< (read (current-buffer)) (car cached))) | ||
| 550 | (forward-line 1)) | ||
| 551 | (beginning-of-line) | ||
| 552 | (set-buffer cache-buf) | ||
| 553 | (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") | ||
| 554 | nil t) | ||
| 555 | (setq beg (point-at-bol) | ||
| 556 | end (progn (end-of-line) (point))) | ||
| 557 | (setq beg nil)) | ||
| 558 | (set-buffer nntp-server-buffer) | ||
| 559 | (when beg | ||
| 560 | (insert-buffer-substring cache-buf beg end) | ||
| 561 | (insert "\n")) | ||
| 562 | (setq cached (cdr cached))) | ||
| 563 | (kill-buffer cache-buf))) | ||
| 564 | |||
| 565 | (defun gnus-cache-braid-heads (group cached) | ||
| 566 | (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))) | ||
| 567 | (with-current-buffer cache-buf | ||
| 568 | (erase-buffer)) | ||
| 569 | (set-buffer nntp-server-buffer) | ||
| 570 | (goto-char (point-min)) | ||
| 571 | (dolist (entry cached) | ||
| 572 | (while (and (not (eobp)) | ||
| 573 | (looking-at "2.. +\\([0-9]+\\) ") | ||
| 574 | (< (progn (goto-char (match-beginning 1)) | ||
| 575 | (read (current-buffer))) | ||
| 576 | entry)) | ||
| 577 | (search-forward "\n.\n" nil 'move)) | ||
| 578 | (beginning-of-line) | ||
| 579 | (set-buffer cache-buf) | ||
| 580 | (erase-buffer) | ||
| 581 | (let ((coding-system-for-read gnus-cache-coding-system) | ||
| 582 | (file-name-coding-system nnmail-pathname-coding-system)) | ||
| 583 | (insert-file-contents (gnus-cache-file-name group entry))) | ||
| 584 | (goto-char (point-min)) | ||
| 585 | (insert "220 ") | ||
| 586 | (princ (pop cached) (current-buffer)) | ||
| 587 | (insert " Article retrieved.\n") | ||
| 588 | (search-forward "\n\n" nil 'move) | ||
| 589 | (delete-region (point) (point-max)) | ||
| 590 | (forward-char -1) | ||
| 591 | (insert ".") | ||
| 592 | (set-buffer nntp-server-buffer) | ||
| 593 | (insert-buffer-substring cache-buf)) | ||
| 594 | (kill-buffer cache-buf))) | ||
| 595 | |||
| 596 | ;;;###autoload | 530 | ;;;###autoload |
| 597 | (defun gnus-jog-cache () | 531 | (defun gnus-jog-cache () |
| 598 | "Go through all groups and put the articles into the cache. | 532 | "Go through all groups and put the articles into the cache. |
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index f7c71f43ce8..00b85f546c2 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el | |||
| @@ -30,6 +30,8 @@ | |||
| 30 | 30 | ||
| 31 | (require 'parse-time) | 31 | (require 'parse-time) |
| 32 | (require 'nnimap) | 32 | (require 'nnimap) |
| 33 | (declare-function gnus-fetch-headers "gnus-sum") | ||
| 34 | (defvar gnus-alter-header-function) | ||
| 33 | 35 | ||
| 34 | (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' | 36 | (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' |
| 35 | (autoload 'epg-make-context "epg") | 37 | (autoload 'epg-make-context "epg") |
| @@ -391,8 +393,6 @@ When FULL is t, upload everything, not just a difference from the last full." | |||
| 391 | (gnus-group-refresh-group group)) | 393 | (gnus-group-refresh-group group)) |
| 392 | (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group))))) | 394 | (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group))))) |
| 393 | 395 | ||
| 394 | (defvar gnus-alter-header-function) | ||
| 395 | |||
| 396 | (defun gnus-cloud-add-timestamps (elems) | 396 | (defun gnus-cloud-add-timestamps (elems) |
| 397 | (dolist (elem elems) | 397 | (dolist (elem elems) |
| 398 | (let* ((file-name (plist-get elem :file-name)) | 398 | (let* ((file-name (plist-get elem :file-name)) |
| @@ -407,14 +407,10 @@ When FULL is t, upload everything, not just a difference from the last full." | |||
| 407 | (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) | 407 | (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) |
| 408 | (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) | 408 | (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) |
| 409 | (active (gnus-active group)) | 409 | (active (gnus-active group)) |
| 410 | headers head) | 410 | (gnus-newsgroup-name group) |
| 411 | (when (gnus-retrieve-headers (gnus-uncompress-range active) group) | 411 | (headers (gnus-fetch-headers (gnus-uncompress-range active)))) |
| 412 | (with-current-buffer nntp-server-buffer | 412 | (when gnus-alter-header-function |
| 413 | (goto-char (point-min)) | 413 | (mapc gnus-alter-header-function headers)) |
| 414 | (while (setq head (nnheader-parse-head)) | ||
| 415 | (when gnus-alter-header-function | ||
| 416 | (funcall gnus-alter-header-function head)) | ||
| 417 | (push head headers)))) | ||
| 418 | (sort (nreverse headers) | 414 | (sort (nreverse headers) |
| 419 | (lambda (h1 h2) | 415 | (lambda (h1 h2) |
| 420 | (> (gnus-cloud-chunk-sequence (mail-header-subject h1)) | 416 | (> (gnus-cloud-chunk-sequence (mail-header-subject h1)) |
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 5c6a5b9efd0..44780609af7 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el | |||
| @@ -909,6 +909,7 @@ quirks.") | |||
| 909 | (defclass gnus-search-namazu (gnus-search-indexed) | 909 | (defclass gnus-search-namazu (gnus-search-indexed) |
| 910 | ((index-directory | 910 | ((index-directory |
| 911 | :initarg :index-directory | 911 | :initarg :index-directory |
| 912 | :initform (symbol-value 'gnus-search-namazu-index-directory) | ||
| 912 | :type string | 913 | :type string |
| 913 | :custom directory) | 914 | :custom directory) |
| 914 | (program | 915 | (program |
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index fbdbf41dc05..cf37a1ccdfc 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el | |||
| @@ -637,7 +637,7 @@ the first newsgroup." | |||
| 637 | ;; We subscribe the group by changing its level to `subscribed'. | 637 | ;; We subscribe the group by changing its level to `subscribed'. |
| 638 | (gnus-group-change-level | 638 | (gnus-group-change-level |
| 639 | newsgroup gnus-level-default-subscribed | 639 | newsgroup gnus-level-default-subscribed |
| 640 | gnus-level-killed (or next "dummy.group")) | 640 | gnus-level-killed next) |
| 641 | (gnus-request-update-group-status newsgroup 'subscribe) | 641 | (gnus-request-update-group-status newsgroup 'subscribe) |
| 642 | (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) | 642 | (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) |
| 643 | (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) | 643 | (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) |
| @@ -1282,7 +1282,8 @@ string name) to insert this group before." | |||
| 1282 | (gnus-dribble-enter | 1282 | (gnus-dribble-enter |
| 1283 | (format "(gnus-group-change-level %S %S %S %S %S)" | 1283 | (format "(gnus-group-change-level %S %S %S %S %S)" |
| 1284 | group level oldlevel | 1284 | group level oldlevel |
| 1285 | (cadr (member previous gnus-group-list)) | 1285 | (when previous |
| 1286 | (cadr (member previous gnus-group-list))) | ||
| 1286 | fromkilled))) | 1287 | fromkilled))) |
| 1287 | 1288 | ||
| 1288 | ;; Then we remove the newgroup from any old structures, if needed. | 1289 | ;; Then we remove the newgroup from any old structures, if needed. |
| @@ -1341,9 +1342,10 @@ string name) to insert this group before." | |||
| 1341 | ;; at the head of `gnus-newsrc-alist'. | 1342 | ;; at the head of `gnus-newsrc-alist'. |
| 1342 | (push info (cdr gnus-newsrc-alist)) | 1343 | (push info (cdr gnus-newsrc-alist)) |
| 1343 | (puthash group (list num info) gnus-newsrc-hashtb) | 1344 | (puthash group (list num info) gnus-newsrc-hashtb) |
| 1344 | (when (stringp previous) | 1345 | (when (and previous (stringp previous)) |
| 1345 | (setq previous (gnus-group-entry previous))) | 1346 | (setq previous (gnus-group-entry previous))) |
| 1346 | (let ((idx (or (seq-position gnus-group-list (caadr previous)) | 1347 | (let ((idx (or (and previous |
| 1348 | (seq-position gnus-group-list (caadr previous))) | ||
| 1347 | (length gnus-group-list)))) | 1349 | (length gnus-group-list)))) |
| 1348 | (push group (nthcdr idx gnus-group-list))) | 1350 | (push group (nthcdr idx gnus-group-list))) |
| 1349 | (gnus-dribble-enter | 1351 | (gnus-dribble-enter |
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index b0f9ed4c6f0..5bd58b690af 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el | |||
| @@ -5658,10 +5658,21 @@ or a straight list of headers." | |||
| 5658 | (setf (mail-header-subject header) subject)))))) | 5658 | (setf (mail-header-subject header) subject)))))) |
| 5659 | 5659 | ||
| 5660 | (defun gnus-fetch-headers (articles &optional limit force-new dependencies) | 5660 | (defun gnus-fetch-headers (articles &optional limit force-new dependencies) |
| 5661 | "Fetch headers of ARTICLES." | 5661 | "Fetch headers of ARTICLES. |
| 5662 | This calls the `gnus-retrieve-headers' function of the current | ||
| 5663 | group's backend server. The server can do one of two things: | ||
| 5664 | |||
| 5665 | 1. Write the headers for ARTICLES into the | ||
| 5666 | `nntp-server-buffer' (the current buffer) in a parseable format, or | ||
| 5667 | 2. Return the headers directly as a list of vectors. | ||
| 5668 | |||
| 5669 | In the first case, `gnus-retrieve-headers' returns a symbol | ||
| 5670 | value, either `nov' or `headers'. This value determines which | ||
| 5671 | parsing function is used to read the headers. It is also stored | ||
| 5672 | into the variable `gnus-headers-retrieved-by', which is consulted | ||
| 5673 | later when possibly building full threads." | ||
| 5662 | (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) | 5674 | (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) |
| 5663 | (prog1 | 5675 | (let ((res (setq gnus-headers-retrieved-by |
| 5664 | (pcase (setq gnus-headers-retrieved-by | ||
| 5665 | (gnus-retrieve-headers | 5676 | (gnus-retrieve-headers |
| 5666 | articles gnus-newsgroup-name | 5677 | articles gnus-newsgroup-name |
| 5667 | (or limit | 5678 | (or limit |
| @@ -5671,22 +5682,34 @@ or a straight list of headers." | |||
| 5671 | (not (eq gnus-fetch-old-headers 'some)) | 5682 | (not (eq gnus-fetch-old-headers 'some)) |
| 5672 | (not (numberp gnus-fetch-old-headers))) | 5683 | (not (numberp gnus-fetch-old-headers))) |
| 5673 | (> (length articles) 1)) | 5684 | (> (length articles) 1)) |
| 5674 | gnus-fetch-old-headers)))) | 5685 | gnus-fetch-old-headers)))))) |
| 5675 | ('nov | 5686 | (prog1 |
| 5676 | (gnus-get-newsgroup-headers-xover | 5687 | (pcase res |
| 5677 | articles force-new dependencies gnus-newsgroup-name t)) | 5688 | ('nov |
| 5678 | ('headers | 5689 | (gnus-get-newsgroup-headers-xover |
| 5679 | (gnus-get-newsgroup-headers dependencies force-new)) | 5690 | articles force-new dependencies gnus-newsgroup-name t)) |
| 5680 | ((pred listp) | 5691 | ;; For now, assume that any backend returning its own |
| 5681 | (let ((dependencies | 5692 | ;; headers takes some effort to do so, so return `headers'. |
| 5682 | (or dependencies | 5693 | ((pred listp) |
| 5683 | (with-current-buffer gnus-summary-buffer | 5694 | (setq gnus-headers-retrieved-by 'headers) |
| 5684 | gnus-newsgroup-dependencies)))) | 5695 | (let ((dependencies |
| 5685 | (delq nil (mapcar #'(lambda (header) | 5696 | (or dependencies |
| 5686 | (gnus-dependencies-add-header | 5697 | (buffer-local-value |
| 5687 | header dependencies force-new)) | 5698 | 'gnus-newsgroup-dependencies gnus-summary-buffer)))) |
| 5688 | gnus-headers-retrieved-by))))) | 5699 | (when (functionp gnus-alter-header-function) |
| 5689 | (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name))) | 5700 | (mapc gnus-alter-header-function res)) |
| 5701 | (mapc (lambda (header) | ||
| 5702 | ;; The agent or the cache may have already | ||
| 5703 | ;; registered this header in the dependency | ||
| 5704 | ;; table. | ||
| 5705 | (unless (gethash (mail-header-id header) dependencies) | ||
| 5706 | (gnus-dependencies-add-header | ||
| 5707 | header dependencies force-new))) | ||
| 5708 | res) | ||
| 5709 | res)) | ||
| 5710 | (_ (gnus-get-newsgroup-headers dependencies force-new))) | ||
| 5711 | (gnus-message 7 "Fetching headers for %s...done" | ||
| 5712 | gnus-newsgroup-name)))) | ||
| 5690 | 5713 | ||
| 5691 | (defun gnus-select-newsgroup (group &optional read-all select-articles) | 5714 | (defun gnus-select-newsgroup (group &optional read-all select-articles) |
| 5692 | "Select newsgroup GROUP. | 5715 | "Select newsgroup GROUP. |
| @@ -6443,6 +6466,10 @@ The resulting hash table is returned, or nil if no Xrefs were found." | |||
| 6443 | (unless (gnus-ephemeral-group-p group) | 6466 | (unless (gnus-ephemeral-group-p group) |
| 6444 | (gnus-group-update-group group t)))))) | 6467 | (gnus-group-update-group group t)))))) |
| 6445 | 6468 | ||
| 6469 | ;; FIXME: Refactor this with `gnus-get-newsgroup-headers-xover' and | ||
| 6470 | ;; extract the necessary bits for the direct-header-return case. Also | ||
| 6471 | ;; look at this and see how similar it is to | ||
| 6472 | ;; `nnheader-parse-naked-head'. | ||
| 6446 | (defun gnus-get-newsgroup-headers (&optional dependencies force-new) | 6473 | (defun gnus-get-newsgroup-headers (&optional dependencies force-new) |
| 6447 | (let ((dependencies | 6474 | (let ((dependencies |
| 6448 | (or dependencies | 6475 | (or dependencies |
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 91ab878b22f..4241f30ba9d 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el | |||
| @@ -2388,7 +2388,14 @@ Typical marks are those that make no sense in a standalone back end, | |||
| 2388 | such as a mark that says whether an article is stored in the cache | 2388 | such as a mark that says whether an article is stored in the cache |
| 2389 | \(which doesn't make sense in a standalone back end).") | 2389 | \(which doesn't make sense in a standalone back end).") |
| 2390 | 2390 | ||
| 2391 | (defvar gnus-headers-retrieved-by nil) | 2391 | (defvar gnus-headers-retrieved-by nil |
| 2392 | "Holds the return value of `gnus-retrieve-headers'. | ||
| 2393 | This is either the symbol `nov' or the symbol `headers'. This | ||
| 2394 | value is checked during the summary creation process, when | ||
| 2395 | building threads. A value of `nov' indicates that header | ||
| 2396 | retrieval is relatively cheap and threading is encouraged to | ||
| 2397 | include more old articles. A value of `headers' indicates that | ||
| 2398 | retrieval is expensive and should be minimized.") | ||
| 2392 | (defvar gnus-article-reply nil) | 2399 | (defvar gnus-article-reply nil) |
| 2393 | (defvar gnus-override-method nil) | 2400 | (defvar gnus-override-method nil) |
| 2394 | (defvar gnus-opened-servers nil) | 2401 | (defvar gnus-opened-servers nil) |
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 50e02187484..1409a4384ab 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el | |||
| @@ -47,7 +47,7 @@ | |||
| 47 | (require 'rfc2047) | 47 | (require 'rfc2047) |
| 48 | (require 'puny) | 48 | (require 'puny) |
| 49 | (require 'rmc) ; read-multiple-choice | 49 | (require 'rmc) ; read-multiple-choice |
| 50 | (eval-when-compile (require 'subr-x)) | 50 | (require 'subr-x) |
| 51 | 51 | ||
| 52 | (autoload 'mailclient-send-it "mailclient") | 52 | (autoload 'mailclient-send-it "mailclient") |
| 53 | 53 | ||
| @@ -620,8 +620,8 @@ Done before generating the new subject of a forward." | |||
| 620 | 620 | ||
| 621 | (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" | 621 | (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" |
| 622 | "All headers that match this regexp will be deleted when forwarding a message. | 622 | "All headers that match this regexp will be deleted when forwarding a message. |
| 623 | This variable is not consulted when forwarding encrypted messages | 623 | Also see `message-forward-included-headers' -- both variables are applied. |
| 624 | and `message-forward-show-mml' is `best'. | 624 | In addition, see `message-forward-included-mime-headers'. |
| 625 | 625 | ||
| 626 | This may also be a list of regexps." | 626 | This may also be a list of regexps." |
| 627 | :version "21.1" | 627 | :version "21.1" |
| @@ -637,7 +637,14 @@ This may also be a list of regexps." | |||
| 637 | '("^From:" "^Subject:" "^Date:" "^To:" "^Cc:") | 637 | '("^From:" "^Subject:" "^Date:" "^To:" "^Cc:") |
| 638 | "If non-nil, delete non-matching headers when forwarding a message. | 638 | "If non-nil, delete non-matching headers when forwarding a message. |
| 639 | Only headers that match this regexp will be included. This | 639 | Only headers that match this regexp will be included. This |
| 640 | variable should be a regexp or a list of regexps." | 640 | variable should be a regexp or a list of regexps. |
| 641 | |||
| 642 | Also see `message-forward-ignored-headers' -- both variables are applied. | ||
| 643 | In addition, see `message-forward-included-mime-headers'. | ||
| 644 | |||
| 645 | When forwarding messages as MIME, but when | ||
| 646 | `message-forward-show-mml' results in MML not being used, | ||
| 647 | `message-forward-included-mime-headers' take precedence." | ||
| 641 | :version "27.1" | 648 | :version "27.1" |
| 642 | :group 'message-forwarding | 649 | :group 'message-forwarding |
| 643 | :type '(repeat :value-to-internal (lambda (widget value) | 650 | :type '(repeat :value-to-internal (lambda (widget value) |
| @@ -647,6 +654,24 @@ variable should be a regexp or a list of regexps." | |||
| 647 | (widget-editable-list-match widget value))) | 654 | (widget-editable-list-match widget value))) |
| 648 | regexp)) | 655 | regexp)) |
| 649 | 656 | ||
| 657 | (defcustom message-forward-included-mime-headers | ||
| 658 | '("^Content-Type:" "^MIME-Version:") | ||
| 659 | "When forwarding as MIME, but not using MML, don't delete these headers. | ||
| 660 | Also see `message-forward-ignored-headers' and | ||
| 661 | `message-forward-ignored-headers'. | ||
| 662 | |||
| 663 | When forwarding messages as MIME, but when | ||
| 664 | `message-forward-show-mml' results in MML not being used, | ||
| 665 | `message-forward-included-mime-headers' take precedence." | ||
| 666 | :version "28.1" | ||
| 667 | :group 'message-forwarding | ||
| 668 | :type '(repeat :value-to-internal (lambda (widget value) | ||
| 669 | (custom-split-regexp-maybe value)) | ||
| 670 | :match (lambda (widget value) | ||
| 671 | (or (stringp value) | ||
| 672 | (widget-editable-list-match widget value))) | ||
| 673 | regexp)) | ||
| 674 | |||
| 650 | (defcustom message-ignored-cited-headers "." | 675 | (defcustom message-ignored-cited-headers "." |
| 651 | "Delete these headers from the messages you yank." | 676 | "Delete these headers from the messages you yank." |
| 652 | :group 'message-insertion | 677 | :group 'message-insertion |
| @@ -3057,22 +3082,23 @@ See also `message-forbidden-properties'." | |||
| 3057 | 3082 | ||
| 3058 | (defun message--syntax-propertize (beg end) | 3083 | (defun message--syntax-propertize (beg end) |
| 3059 | "Syntax-propertize certain message text specially." | 3084 | "Syntax-propertize certain message text specially." |
| 3060 | (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$")) | 3085 | (with-syntax-table message-mode-syntax-table |
| 3061 | (smiley-regexp (regexp-opt message-smileys))) | 3086 | (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$")) |
| 3062 | (goto-char beg) | 3087 | (smiley-regexp (regexp-opt message-smileys))) |
| 3063 | (while (search-forward-regexp citation-regexp | 3088 | (goto-char beg) |
| 3064 | end 'noerror) | 3089 | (while (search-forward-regexp citation-regexp |
| 3065 | (let ((start (match-beginning 0)) | 3090 | end 'noerror) |
| 3066 | (end (match-end 0))) | 3091 | (let ((start (match-beginning 0)) |
| 3067 | (add-text-properties start (1+ start) | 3092 | (end (match-end 0))) |
| 3068 | `(syntax-table ,(string-to-syntax "<"))) | 3093 | (add-text-properties start (1+ start) |
| 3069 | (add-text-properties end (min (1+ end) (point-max)) | 3094 | `(syntax-table ,(string-to-syntax "<"))) |
| 3070 | `(syntax-table ,(string-to-syntax ">"))))) | 3095 | (add-text-properties end (min (1+ end) (point-max)) |
| 3071 | (goto-char beg) | 3096 | `(syntax-table ,(string-to-syntax ">"))))) |
| 3072 | (while (search-forward-regexp smiley-regexp | 3097 | (goto-char beg) |
| 3073 | end 'noerror) | 3098 | (while (search-forward-regexp smiley-regexp |
| 3074 | (add-text-properties (match-beginning 0) (match-end 0) | 3099 | end 'noerror) |
| 3075 | `(syntax-table ,(string-to-syntax ".")))))) | 3100 | (add-text-properties (match-beginning 0) (match-end 0) |
| 3101 | `(syntax-table ,(string-to-syntax "."))))))) | ||
| 3076 | 3102 | ||
| 3077 | ;;;###autoload | 3103 | ;;;###autoload |
| 3078 | (define-derived-mode message-mode text-mode "Message" | 3104 | (define-derived-mode message-mode text-mode "Message" |
| @@ -7616,14 +7642,28 @@ Optional DIGEST will use digest to forward." | |||
| 7616 | "-------------------- End of forwarded message --------------------\n") | 7642 | "-------------------- End of forwarded message --------------------\n") |
| 7617 | (message-remove-ignored-headers b e))) | 7643 | (message-remove-ignored-headers b e))) |
| 7618 | 7644 | ||
| 7619 | (defun message-remove-ignored-headers (b e) | 7645 | (defun message-remove-ignored-headers (b e &optional preserve-mime) |
| 7620 | (when (or message-forward-ignored-headers | 7646 | (when (or message-forward-ignored-headers |
| 7621 | message-forward-included-headers) | 7647 | message-forward-included-headers) |
| 7648 | (let ((saved-headers nil)) | ||
| 7622 | (save-restriction | 7649 | (save-restriction |
| 7623 | (narrow-to-region b e) | 7650 | (narrow-to-region b e) |
| 7624 | (goto-char b) | 7651 | (goto-char b) |
| 7625 | (narrow-to-region (point) | 7652 | (narrow-to-region (point) |
| 7626 | (or (search-forward "\n\n" nil t) (point))) | 7653 | (or (search-forward "\n\n" nil t) (point))) |
| 7654 | ;; When forwarding as MIME, preserve some MIME headers. | ||
| 7655 | (when preserve-mime | ||
| 7656 | (let ((headers (buffer-string))) | ||
| 7657 | (with-temp-buffer | ||
| 7658 | (insert headers) | ||
| 7659 | (message-remove-header | ||
| 7660 | (if (listp message-forward-included-mime-headers) | ||
| 7661 | (mapconcat | ||
| 7662 | #'identity (cons "^$" message-forward-included-mime-headers) | ||
| 7663 | "\\|") | ||
| 7664 | message-forward-included-mime-headers) | ||
| 7665 | t nil t) | ||
| 7666 | (setq saved-headers (string-lines (buffer-string) t))))) | ||
| 7627 | (when message-forward-ignored-headers | 7667 | (when message-forward-ignored-headers |
| 7628 | (let ((ignored (if (stringp message-forward-ignored-headers) | 7668 | (let ((ignored (if (stringp message-forward-ignored-headers) |
| 7629 | (list message-forward-ignored-headers) | 7669 | (list message-forward-ignored-headers) |
| @@ -7636,10 +7676,14 @@ Optional DIGEST will use digest to forward." | |||
| 7636 | (mapconcat #'identity (cons "^$" message-forward-included-headers) | 7676 | (mapconcat #'identity (cons "^$" message-forward-included-headers) |
| 7637 | "\\|") | 7677 | "\\|") |
| 7638 | message-forward-included-headers) | 7678 | message-forward-included-headers) |
| 7639 | t nil t))))) | 7679 | t nil t)) |
| 7680 | ;; Insert the MIME headers, if any. | ||
| 7681 | (goto-char (point-max)) | ||
| 7682 | (forward-line -1) | ||
| 7683 | (dolist (header saved-headers) | ||
| 7684 | (insert header "\n")))))) | ||
| 7640 | 7685 | ||
| 7641 | (defun message-forward-make-body-mime (forward-buffer &optional beg end | 7686 | (defun message-forward-make-body-mime (forward-buffer &optional beg end) |
| 7642 | remove-headers) | ||
| 7643 | (let ((b (point))) | 7687 | (let ((b (point))) |
| 7644 | (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") | 7688 | (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") |
| 7645 | (save-restriction | 7689 | (save-restriction |
| @@ -7649,8 +7693,7 @@ Optional DIGEST will use digest to forward." | |||
| 7649 | (goto-char (point-min)) | 7693 | (goto-char (point-min)) |
| 7650 | (when (looking-at "From ") | 7694 | (when (looking-at "From ") |
| 7651 | (replace-match "X-From-Line: ")) | 7695 | (replace-match "X-From-Line: ")) |
| 7652 | (when remove-headers | 7696 | (message-remove-ignored-headers (point-min) (point-max) t) |
| 7653 | (message-remove-ignored-headers (point-min) (point-max))) | ||
| 7654 | (goto-char (point-max))) | 7697 | (goto-char (point-max))) |
| 7655 | (insert "<#/part>\n") | 7698 | (insert "<#/part>\n") |
| 7656 | ;; Consider there is no illegible text. | 7699 | ;; Consider there is no illegible text. |
| @@ -7789,8 +7832,7 @@ is for the internal use." | |||
| 7789 | (message-signed-or-encrypted-p) | 7832 | (message-signed-or-encrypted-p) |
| 7790 | (error t)))))) | 7833 | (error t)))))) |
| 7791 | (message-forward-make-body-mml forward-buffer) | 7834 | (message-forward-make-body-mml forward-buffer) |
| 7792 | (message-forward-make-body-mime | 7835 | (message-forward-make-body-mime forward-buffer)) |
| 7793 | forward-buffer nil nil (not (eq message-forward-show-mml 'best)))) | ||
| 7794 | (message-forward-make-body-plain forward-buffer))) | 7836 | (message-forward-make-body-plain forward-buffer))) |
| 7795 | (message-position-point)) | 7837 | (message-position-point)) |
| 7796 | 7838 | ||
diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index ebececa3ce2..3cdfc749703 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el | |||
| @@ -769,8 +769,24 @@ article number. This function is called narrowed to an article." | |||
| 769 | (let ((headers (nnheader-parse-head t))) | 769 | (let ((headers (nnheader-parse-head t))) |
| 770 | (setf (mail-header-chars headers) chars) | 770 | (setf (mail-header-chars headers) chars) |
| 771 | (setf (mail-header-number headers) number) | 771 | (setf (mail-header-number headers) number) |
| 772 | ;; If there's non-ASCII raw characters in the data, | ||
| 773 | ;; RFC2047-encode them to avoid having arbitrary data in the | ||
| 774 | ;; .overview file. | ||
| 775 | (nnml--encode-headers headers) | ||
| 772 | headers)))) | 776 | headers)))) |
| 773 | 777 | ||
| 778 | (defun nnml--encode-headers (headers) | ||
| 779 | (let ((subject (mail-header-subject headers)) | ||
| 780 | (rfc2047-encoding-type 'mime)) | ||
| 781 | (unless (string-match "\\`[[:ascii:]]*\\'" subject) | ||
| 782 | (setf (mail-header-subject headers) | ||
| 783 | (mail-encode-encoded-word-string subject t)))) | ||
| 784 | (let ((from (mail-header-from headers)) | ||
| 785 | (rfc2047-encoding-type 'address-mime)) | ||
| 786 | (unless (string-match "\\`[[:ascii:]]*\\'" from) | ||
| 787 | (setf (mail-header-from headers) | ||
| 788 | (rfc2047-encode-string from t))))) | ||
| 789 | |||
| 774 | (defun nnml-get-nov-buffer (group &optional incrementalp) | 790 | (defun nnml-get-nov-buffer (group &optional incrementalp) |
| 775 | (let ((buffer (gnus-get-buffer-create | 791 | (let ((buffer (gnus-get-buffer-create |
| 776 | (format " *nnml %soverview %s*" | 792 | (format " *nnml %soverview %s*" |
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 7e10e151a4d..c2bb960f945 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el | |||
| @@ -1209,7 +1209,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the | |||
| 1209 | (read-passwd (format "NNTP (%s@%s) password: " | 1209 | (read-passwd (format "NNTP (%s@%s) password: " |
| 1210 | user nntp-address))))))) | 1210 | user nntp-address))))))) |
| 1211 | (if (not result) | 1211 | (if (not result) |
| 1212 | (signal 'nntp-authinfo-rejected "Password rejected") | 1212 | (error "Password rejected") |
| 1213 | result)))))) | 1213 | result)))))) |
| 1214 | 1214 | ||
| 1215 | ;;; Internal functions. | 1215 | ;;; Internal functions. |
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 1e2feda6365..ba2934351d6 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el | |||
| @@ -101,15 +101,10 @@ It is computed from the marks of individual component groups.") | |||
| 101 | (erase-buffer) | 101 | (erase-buffer) |
| 102 | (if (stringp (car articles)) | 102 | (if (stringp (car articles)) |
| 103 | 'headers | 103 | 'headers |
| 104 | (let ((vbuf (nnheader-set-temp-buffer | 104 | (let ((carticles (nnvirtual-partition-sequence articles)) |
| 105 | (gnus-get-buffer-create " *virtual headers*"))) | ||
| 106 | (carticles (nnvirtual-partition-sequence articles)) | ||
| 107 | (sysname (system-name)) | 105 | (sysname (system-name)) |
| 108 | cgroup carticle article result prefix) | 106 | cgroup headers all-headers article prefix) |
| 109 | (while carticles | 107 | (pcase-dolist (`(,cgroup . ,articles) carticles) |
| 110 | (setq cgroup (caar carticles)) | ||
| 111 | (setq articles (cdar carticles)) | ||
| 112 | (pop carticles) | ||
| 113 | (when (and articles | 108 | (when (and articles |
| 114 | (gnus-check-server | 109 | (gnus-check-server |
| 115 | (gnus-find-method-for-group cgroup) t) | 110 | (gnus-find-method-for-group cgroup) t) |
| @@ -119,69 +114,37 @@ It is computed from the marks of individual component groups.") | |||
| 119 | ;; This is probably evil if people have set | 114 | ;; This is probably evil if people have set |
| 120 | ;; gnus-use-cache to nil themselves, but I | 115 | ;; gnus-use-cache to nil themselves, but I |
| 121 | ;; have no way of finding the true value of it. | 116 | ;; have no way of finding the true value of it. |
| 122 | (let ((gnus-use-cache t)) | 117 | (let ((gnus-use-cache t) |
| 123 | (setq result (gnus-retrieve-headers | 118 | (gnus-newsgroup-name cgroup) |
| 124 | articles cgroup nil)))) | 119 | (gnus-fetch-old-headers nil)) |
| 125 | (set-buffer nntp-server-buffer) | 120 | (setq headers (gnus-fetch-headers articles)))) |
| 126 | ;; If we got HEAD headers, we convert them into NOV | 121 | (erase-buffer) |
| 127 | ;; headers. This is slow, inefficient and, come to think | 122 | ;; Remove all header article numbers from `articles'. |
| 128 | ;; of it, downright evil. So sue me. I couldn't be | 123 | ;; If there's anything left, those are expired or |
| 129 | ;; bothered to write a header parse routine that could | 124 | ;; canceled articles, so we update the component group |
| 130 | ;; parse a mixed HEAD/NOV buffer. | 125 | ;; below. |
| 131 | (when (eq result 'headers) | 126 | (dolist (h headers) |
| 132 | (nnvirtual-convert-headers)) | 127 | (setq articles (delq (mail-header-number h) articles) |
| 133 | (goto-char (point-min)) | 128 | article (nnvirtual-reverse-map-article |
| 134 | (while (not (eobp)) | 129 | cgroup (mail-header-number h))) |
| 135 | (delete-region (point) | 130 | ;; Update all the header numbers according to their |
| 136 | (progn | 131 | ;; reverse mapping, and drop any with no such mapping. |
| 137 | (setq carticle (read nntp-server-buffer)) | 132 | (when article |
| 138 | (point))) | 133 | ;; Do this first, before we re-set the header's |
| 139 | 134 | ;; article number. | |
| 140 | ;; We remove this article from the articles list, if | 135 | (nnvirtual-update-xref-header |
| 141 | ;; anything is left in the articles list after going through | 136 | h cgroup prefix sysname) |
| 142 | ;; the entire buffer, then those articles have been | 137 | (setf (mail-header-number h) article) |
| 143 | ;; expired or canceled, so we appropriately update the | 138 | (push h all-headers))) |
| 144 | ;; component group below. They should be coming up | 139 | ;; Anything left in articles is expired or canceled. |
| 145 | ;; generally in order, so this shouldn't be slow. | 140 | ;; Could be smart and not tell it about articles already |
| 146 | (setq articles (delq carticle articles)) | 141 | ;; known? |
| 147 | 142 | (when articles | |
| 148 | (setq article (nnvirtual-reverse-map-article cgroup carticle)) | 143 | (gnus-group-make-articles-read cgroup articles)))) |
| 149 | (if (null article) | 144 | |
| 150 | ;; This line has no reverse mapping, that means it | 145 | (sort all-headers (lambda (h1 h2) |
| 151 | ;; was an extra article reference returned by nntp. | 146 | (< (mail-header-number h1) |
| 152 | (progn | 147 | (mail-header-number h2))))))))) |
| 153 | (beginning-of-line) | ||
| 154 | (delete-region (point) (progn (forward-line 1) (point)))) | ||
| 155 | ;; Otherwise insert the virtual article number, | ||
| 156 | ;; and clean up the xrefs. | ||
| 157 | (princ article nntp-server-buffer) | ||
| 158 | (nnvirtual-update-xref-header cgroup carticle | ||
| 159 | prefix sysname) | ||
| 160 | (forward-line 1)) | ||
| 161 | ) | ||
| 162 | |||
| 163 | (set-buffer vbuf) | ||
| 164 | (goto-char (point-max)) | ||
| 165 | (insert-buffer-substring nntp-server-buffer)) | ||
| 166 | ;; Anything left in articles is expired or canceled. | ||
| 167 | ;; Could be smart and not tell it about articles already known? | ||
| 168 | (when articles | ||
| 169 | (gnus-group-make-articles-read cgroup articles)) | ||
| 170 | ) | ||
| 171 | |||
| 172 | ;; The headers are ready for reading, so they are inserted into | ||
| 173 | ;; the nntp-server-buffer, which is where Gnus expects to find | ||
| 174 | ;; them. | ||
| 175 | (prog1 | ||
| 176 | (with-current-buffer nntp-server-buffer | ||
| 177 | (erase-buffer) | ||
| 178 | (insert-buffer-substring vbuf) | ||
| 179 | ;; FIX FIX FIX, we should be able to sort faster than | ||
| 180 | ;; this if needed, since each cgroup is sorted, we just | ||
| 181 | ;; need to merge | ||
| 182 | (sort-numeric-fields 1 (point-min) (point-max)) | ||
| 183 | 'nov) | ||
| 184 | (kill-buffer vbuf))))))) | ||
| 185 | 148 | ||
| 186 | 149 | ||
| 187 | (defvoo nnvirtual-last-accessed-component-group nil) | 150 | (defvoo nnvirtual-last-accessed-component-group nil) |
| @@ -372,61 +335,18 @@ It is computed from the marks of individual component groups.") | |||
| 372 | 335 | ||
| 373 | ;;; Internal functions. | 336 | ;;; Internal functions. |
| 374 | 337 | ||
| 375 | (defun nnvirtual-convert-headers () | 338 | (defun nnvirtual-update-xref-header (header group prefix sysname) |
| 376 | "Convert HEAD headers into NOV headers." | 339 | "Add xref to component GROUP to HEADER. |
| 377 | (with-current-buffer nntp-server-buffer | 340 | Also add a server PREFIX any existing xref lines." |
| 378 | (let* ((dependencies (make-hash-table :test #'equal)) | 341 | (let ((bits (split-string (mail-header-xref header) |
| 379 | (headers (gnus-get-newsgroup-headers dependencies))) | 342 | nil t "[[:blank:]]")) |
| 380 | (erase-buffer) | 343 | (art-no (mail-header-number header))) |
| 381 | (mapc 'nnheader-insert-nov headers)))) | 344 | (setf (mail-header-xref header) |
| 382 | 345 | (concat | |
| 383 | 346 | (format "%s %s:%d " sysname group art-no) | |
| 384 | (defun nnvirtual-update-xref-header (group article prefix sysname) | 347 | (mapconcat (lambda (bit) |
| 385 | "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines." | 348 | (concat prefix bit)) |
| 386 | ;; Move to beginning of Xref field, creating a slot if needed. | 349 | bits " "))))) |
| 387 | (beginning-of-line) | ||
| 388 | (looking-at | ||
| 389 | "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") | ||
| 390 | (goto-char (match-end 0)) | ||
| 391 | (unless (search-forward "\t" (point-at-eol) 'move) | ||
| 392 | (insert "\t")) | ||
| 393 | |||
| 394 | ;; Remove any spaces at the beginning of the Xref field. | ||
| 395 | (while (eq (char-after (1- (point))) ? ) | ||
| 396 | (forward-char -1) | ||
| 397 | (delete-char 1)) | ||
| 398 | |||
| 399 | (insert "Xref: " sysname " " group ":") | ||
| 400 | (princ article (current-buffer)) | ||
| 401 | (insert " ") | ||
| 402 | |||
| 403 | ;; If there were existing xref lines, clean them up to have the correct | ||
| 404 | ;; component server prefix. | ||
| 405 | (save-restriction | ||
| 406 | (narrow-to-region (point) | ||
| 407 | (or (search-forward "\t" (point-at-eol) t) | ||
| 408 | (point-at-eol))) | ||
| 409 | (goto-char (point-min)) | ||
| 410 | (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t) | ||
| 411 | (replace-match "" t t)) | ||
| 412 | (goto-char (point-min)) | ||
| 413 | (when (re-search-forward | ||
| 414 | (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+") | ||
| 415 | nil t) | ||
| 416 | (replace-match "" t t)) | ||
| 417 | (unless (eobp) | ||
| 418 | (insert " ") | ||
| 419 | (when (not (string= "" prefix)) | ||
| 420 | (while (re-search-forward "[^ ]+:[0-9]+" nil t) | ||
| 421 | (save-excursion | ||
| 422 | (goto-char (match-beginning 0)) | ||
| 423 | (insert prefix)))))) | ||
| 424 | |||
| 425 | ;; Ensure a trailing \t. | ||
| 426 | (end-of-line) | ||
| 427 | (or (eq (char-after (1- (point))) ?\t) | ||
| 428 | (insert ?\t))) | ||
| 429 | |||
| 430 | 350 | ||
| 431 | (defun nnvirtual-possibly-change-server (server) | 351 | (defun nnvirtual-possibly-change-server (server) |
| 432 | (or (not server) | 352 | (or (not server) |
diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 8ce936ad164..879653057d0 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el | |||
| @@ -1655,6 +1655,9 @@ in `describe-keymap'. See also `Searching the Active Keymaps'." | |||
| 1655 | (get-char-property (point) 'local-map) | 1655 | (get-char-property (point) 'local-map) |
| 1656 | (current-local-map))))) | 1656 | (current-local-map))))) |
| 1657 | 1657 | ||
| 1658 | (defvar keymap-name-history nil | ||
| 1659 | "History for input to `describe-keymap'.") | ||
| 1660 | |||
| 1658 | ;;;###autoload | 1661 | ;;;###autoload |
| 1659 | (defun describe-keymap (keymap) | 1662 | (defun describe-keymap (keymap) |
| 1660 | "Describe key bindings in KEYMAP. | 1663 | "Describe key bindings in KEYMAP. |
diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 73870f9579e..82952e934b6 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el | |||
| @@ -45,11 +45,7 @@ | |||
| 45 | ;; An overlay is used. In the non-sticky cases, this overlay is | 45 | ;; An overlay is used. In the non-sticky cases, this overlay is |
| 46 | ;; active only on the selected window. A hook is added to | 46 | ;; active only on the selected window. A hook is added to |
| 47 | ;; `post-command-hook' to activate the overlay and move it to the line | 47 | ;; `post-command-hook' to activate the overlay and move it to the line |
| 48 | ;; about point. To get the non-sticky behavior, `hl-line-unhighlight' | 48 | ;; about point. |
| 49 | ;; is added to `pre-command-hook' as well. This function deactivates | ||
| 50 | ;; the overlay unconditionally in case the command changes the | ||
| 51 | ;; selected window. (It does so rather than keeping track of changes | ||
| 52 | ;; in the selected window). | ||
| 53 | 49 | ||
| 54 | ;; You could make variable `global-hl-line-mode' buffer-local and set | 50 | ;; You could make variable `global-hl-line-mode' buffer-local and set |
| 55 | ;; it to nil to avoid highlighting specific buffers, when the global | 51 | ;; it to nil to avoid highlighting specific buffers, when the global |
| @@ -91,9 +87,9 @@ when `global-hl-line-sticky-flag' is non-nil.") | |||
| 91 | (set symbol value) | 87 | (set symbol value) |
| 92 | (dolist (buffer (buffer-list)) | 88 | (dolist (buffer (buffer-list)) |
| 93 | (with-current-buffer buffer | 89 | (with-current-buffer buffer |
| 94 | (when hl-line-overlay | 90 | (when (overlayp hl-line-overlay) |
| 95 | (overlay-put hl-line-overlay 'face hl-line-face)))) | 91 | (overlay-put hl-line-overlay 'face hl-line-face)))) |
| 96 | (when global-hl-line-overlay | 92 | (when (overlayp global-hl-line-overlay) |
| 97 | (overlay-put global-hl-line-overlay 'face hl-line-face)))) | 93 | (overlay-put global-hl-line-overlay 'face hl-line-face)))) |
| 98 | 94 | ||
| 99 | (defcustom hl-line-sticky-flag t | 95 | (defcustom hl-line-sticky-flag t |
| @@ -141,9 +137,7 @@ non-selected window. Hl-Line mode uses the function | |||
| 141 | `hl-line-highlight' on `post-command-hook' in this case. | 137 | `hl-line-highlight' on `post-command-hook' in this case. |
| 142 | 138 | ||
| 143 | When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the | 139 | When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the |
| 144 | line about point in the selected window only. In this case, it | 140 | line about point in the selected window only." |
| 145 | uses the function `hl-line-maybe-unhighlight' in | ||
| 146 | addition to `hl-line-highlight' on `post-command-hook'." | ||
| 147 | :group 'hl-line | 141 | :group 'hl-line |
| 148 | (if hl-line-mode | 142 | (if hl-line-mode |
| 149 | (progn | 143 | (progn |
| @@ -151,12 +145,10 @@ addition to `hl-line-highlight' on `post-command-hook'." | |||
| 151 | (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) | 145 | (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) |
| 152 | (hl-line-highlight) | 146 | (hl-line-highlight) |
| 153 | (setq hl-line-overlay-buffer (current-buffer)) | 147 | (setq hl-line-overlay-buffer (current-buffer)) |
| 154 | (add-hook 'post-command-hook #'hl-line-highlight nil t) | 148 | (add-hook 'post-command-hook #'hl-line-highlight nil t)) |
| 155 | (add-hook 'post-command-hook #'hl-line-maybe-unhighlight nil t)) | ||
| 156 | (remove-hook 'post-command-hook #'hl-line-highlight t) | 149 | (remove-hook 'post-command-hook #'hl-line-highlight t) |
| 157 | (hl-line-unhighlight) | 150 | (hl-line-unhighlight) |
| 158 | (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t) | 151 | (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t))) |
| 159 | (remove-hook 'post-command-hook #'hl-line-maybe-unhighlight t))) | ||
| 160 | 152 | ||
| 161 | (defun hl-line-make-overlay () | 153 | (defun hl-line-make-overlay () |
| 162 | (let ((ol (make-overlay (point) (point)))) | 154 | (let ((ol (make-overlay (point) (point)))) |
| @@ -168,17 +160,19 @@ addition to `hl-line-highlight' on `post-command-hook'." | |||
| 168 | "Activate the Hl-Line overlay on the current line." | 160 | "Activate the Hl-Line overlay on the current line." |
| 169 | (if hl-line-mode ; Might be changed outside the mode function. | 161 | (if hl-line-mode ; Might be changed outside the mode function. |
| 170 | (progn | 162 | (progn |
| 171 | (unless hl-line-overlay | 163 | (unless (overlayp hl-line-overlay) |
| 172 | (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved. | 164 | (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved. |
| 173 | (overlay-put hl-line-overlay | 165 | (overlay-put hl-line-overlay |
| 174 | 'window (unless hl-line-sticky-flag (selected-window))) | 166 | 'window (unless hl-line-sticky-flag (selected-window))) |
| 175 | (hl-line-move hl-line-overlay)) | 167 | (hl-line-move hl-line-overlay) |
| 168 | (hl-line-maybe-unhighlight)) | ||
| 176 | (hl-line-unhighlight))) | 169 | (hl-line-unhighlight))) |
| 177 | 170 | ||
| 178 | (defun hl-line-unhighlight () | 171 | (defun hl-line-unhighlight () |
| 179 | "Deactivate the Hl-Line overlay on the current line." | 172 | "Deactivate the Hl-Line overlay on the current line." |
| 180 | (when hl-line-overlay | 173 | (when (overlayp hl-line-overlay) |
| 181 | (delete-overlay hl-line-overlay))) | 174 | (delete-overlay hl-line-overlay) |
| 175 | (setq hl-line-overlay nil))) | ||
| 182 | 176 | ||
| 183 | (defun hl-line-maybe-unhighlight () | 177 | (defun hl-line-maybe-unhighlight () |
| 184 | "Maybe deactivate the Hl-Line overlay on the current line. | 178 | "Maybe deactivate the Hl-Line overlay on the current line. |
| @@ -191,8 +185,7 @@ such overlays in all buffers except the current one." | |||
| 191 | (not (eq curbuf hlob)) | 185 | (not (eq curbuf hlob)) |
| 192 | (not (minibufferp))) | 186 | (not (minibufferp))) |
| 193 | (with-current-buffer hlob | 187 | (with-current-buffer hlob |
| 194 | (when (overlayp hl-line-overlay) | 188 | (hl-line-unhighlight))) |
| 195 | (delete-overlay hl-line-overlay)))) | ||
| 196 | (when (and (overlayp hl-line-overlay) | 189 | (when (and (overlayp hl-line-overlay) |
| 197 | (eq (overlay-buffer hl-line-overlay) curbuf)) | 190 | (eq (overlay-buffer hl-line-overlay) curbuf)) |
| 198 | (setq hl-line-overlay-buffer curbuf)))) | 191 | (setq hl-line-overlay-buffer curbuf)))) |
| @@ -205,8 +198,8 @@ If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode | |||
| 205 | highlights the line about the current buffer's point in all live | 198 | highlights the line about the current buffer's point in all live |
| 206 | windows. | 199 | windows. |
| 207 | 200 | ||
| 208 | Global-Hl-Line mode uses the functions `global-hl-line-highlight' | 201 | Global-Hl-Line mode uses the function `global-hl-line-highlight' |
| 209 | and `global-hl-line-maybe-unhighlight' on `post-command-hook'." | 202 | on `post-command-hook'." |
| 210 | :global t | 203 | :global t |
| 211 | :group 'hl-line | 204 | :group 'hl-line |
| 212 | (if global-hl-line-mode | 205 | (if global-hl-line-mode |
| @@ -214,25 +207,24 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'." | |||
| 214 | ;; In case `kill-all-local-variables' is called. | 207 | ;; In case `kill-all-local-variables' is called. |
| 215 | (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight) | 208 | (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight) |
| 216 | (global-hl-line-highlight-all) | 209 | (global-hl-line-highlight-all) |
| 217 | (add-hook 'post-command-hook #'global-hl-line-highlight) | 210 | (add-hook 'post-command-hook #'global-hl-line-highlight)) |
| 218 | (add-hook 'post-command-hook #'global-hl-line-maybe-unhighlight)) | ||
| 219 | (global-hl-line-unhighlight-all) | 211 | (global-hl-line-unhighlight-all) |
| 220 | (remove-hook 'post-command-hook #'global-hl-line-highlight) | 212 | (remove-hook 'post-command-hook #'global-hl-line-highlight) |
| 221 | (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight) | 213 | (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight))) |
| 222 | (remove-hook 'post-command-hook #'global-hl-line-maybe-unhighlight))) | ||
| 223 | 214 | ||
| 224 | (defun global-hl-line-highlight () | 215 | (defun global-hl-line-highlight () |
| 225 | "Highlight the current line in the current window." | 216 | "Highlight the current line in the current window." |
| 226 | (when global-hl-line-mode ; Might be changed outside the mode function. | 217 | (when global-hl-line-mode ; Might be changed outside the mode function. |
| 227 | (unless (window-minibuffer-p) | 218 | (unless (window-minibuffer-p) |
| 228 | (unless global-hl-line-overlay | 219 | (unless (overlayp global-hl-line-overlay) |
| 229 | (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved. | 220 | (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved. |
| 230 | (unless (member global-hl-line-overlay global-hl-line-overlays) | 221 | (unless (member global-hl-line-overlay global-hl-line-overlays) |
| 231 | (push global-hl-line-overlay global-hl-line-overlays)) | 222 | (push global-hl-line-overlay global-hl-line-overlays)) |
| 232 | (overlay-put global-hl-line-overlay 'window | 223 | (overlay-put global-hl-line-overlay 'window |
| 233 | (unless global-hl-line-sticky-flag | 224 | (unless global-hl-line-sticky-flag |
| 234 | (selected-window))) | 225 | (selected-window))) |
| 235 | (hl-line-move global-hl-line-overlay)))) | 226 | (hl-line-move global-hl-line-overlay) |
| 227 | (global-hl-line-maybe-unhighlight)))) | ||
| 236 | 228 | ||
| 237 | (defun global-hl-line-highlight-all () | 229 | (defun global-hl-line-highlight-all () |
| 238 | "Highlight the current line in all live windows." | 230 | "Highlight the current line in all live windows." |
| @@ -243,8 +235,9 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'." | |||
| 243 | 235 | ||
| 244 | (defun global-hl-line-unhighlight () | 236 | (defun global-hl-line-unhighlight () |
| 245 | "Deactivate the Global-Hl-Line overlay on the current line." | 237 | "Deactivate the Global-Hl-Line overlay on the current line." |
| 246 | (when global-hl-line-overlay | 238 | (when (overlayp global-hl-line-overlay) |
| 247 | (delete-overlay global-hl-line-overlay))) | 239 | (delete-overlay global-hl-line-overlay) |
| 240 | (setq global-hl-line-overlay nil))) | ||
| 248 | 241 | ||
| 249 | (defun global-hl-line-maybe-unhighlight () | 242 | (defun global-hl-line-maybe-unhighlight () |
| 250 | "Maybe deactivate the Global-Hl-Line overlay on the current line. | 243 | "Maybe deactivate the Global-Hl-Line overlay on the current line. |
| @@ -256,9 +249,8 @@ all such overlays in all buffers except the current one." | |||
| 256 | (bufferp ovb) | 249 | (bufferp ovb) |
| 257 | (not (eq ovb (current-buffer))) | 250 | (not (eq ovb (current-buffer))) |
| 258 | (not (minibufferp))) | 251 | (not (minibufferp))) |
| 259 | (with-current-buffer ovb | 252 | (with-current-buffer ovb |
| 260 | (when (overlayp global-hl-line-overlay) | 253 | (global-hl-line-unhighlight))))) |
| 261 | (delete-overlay global-hl-line-overlay)))))) | ||
| 262 | global-hl-line-overlays)) | 254 | global-hl-line-overlays)) |
| 263 | 255 | ||
| 264 | (defun global-hl-line-unhighlight-all () | 256 | (defun global-hl-line-unhighlight-all () |
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 7be1b3d16c9..44574abd46a 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el | |||
| @@ -1497,10 +1497,10 @@ Ordering is lexicographic." | |||
| 1497 | (string-lessp | 1497 | (string-lessp |
| 1498 | ;; FIXME: For now just compare the file name and the process name | 1498 | ;; FIXME: For now just compare the file name and the process name |
| 1499 | ;; (if it exists). Is there a better way to do this? | 1499 | ;; (if it exists). Is there a better way to do this? |
| 1500 | (or (buffer-file-name (car a)) | 1500 | (or (with-current-buffer (car a) (ibuffer-buffer-file-name)) |
| 1501 | (let ((pr-a (get-buffer-process (car a)))) | 1501 | (let ((pr-a (get-buffer-process (car a)))) |
| 1502 | (and (processp pr-a) (process-name pr-a)))) | 1502 | (and (processp pr-a) (process-name pr-a)))) |
| 1503 | (or (buffer-file-name (car b)) | 1503 | (or (with-current-buffer (car b) (ibuffer-buffer-file-name)) |
| 1504 | (let ((pr-b (get-buffer-process (car b)))) | 1504 | (let ((pr-b (get-buffer-process (car b)))) |
| 1505 | (and (processp pr-b) (process-name pr-b)))))) | 1505 | (and (processp pr-b) (process-name pr-b)))))) |
| 1506 | 1506 | ||
| @@ -1823,18 +1823,12 @@ When BUF nil, default to the buffer at current line." | |||
| 1823 | ;;;###autoload | 1823 | ;;;###autoload |
| 1824 | (defun ibuffer-mark-by-file-name-regexp (regexp) | 1824 | (defun ibuffer-mark-by-file-name-regexp (regexp) |
| 1825 | "Mark all buffers whose file name matches REGEXP." | 1825 | "Mark all buffers whose file name matches REGEXP." |
| 1826 | (interactive "sMark by file name (regexp): ") | 1826 | (interactive (list (read-regexp "Mark by file name (regexp)"))) |
| 1827 | (ibuffer-mark-on-buffer | 1827 | (ibuffer-mark-on-buffer |
| 1828 | #'(lambda (buf) | 1828 | (lambda (buf) |
| 1829 | (let ((name (or (buffer-file-name buf) | 1829 | (when-let ((name (with-current-buffer buf (ibuffer-buffer-file-name)))) |
| 1830 | (with-current-buffer buf | 1830 | ;; Match on the displayed file name (which is abbreviated). |
| 1831 | (and | 1831 | (string-match-p regexp (ibuffer--abbreviate-file-name name)))))) |
| 1832 | (boundp 'dired-directory) | ||
| 1833 | (stringp dired-directory) | ||
| 1834 | dired-directory))))) | ||
| 1835 | (when name | ||
| 1836 | ;; Match on the displayed file name (which is abbreviated). | ||
| 1837 | (string-match regexp (abbreviate-file-name name))))))) | ||
| 1838 | 1832 | ||
| 1839 | ;;;###autoload | 1833 | ;;;###autoload |
| 1840 | (defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers) | 1834 | (defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers) |
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 4800e0243d7..84c53b16acf 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el | |||
| @@ -1308,6 +1308,11 @@ a new window in the current frame, splitting vertically." | |||
| 1308 | (car dired-directory))))) | 1308 | (car dired-directory))))) |
| 1309 | (and dirname (expand-file-name dirname)))))) | 1309 | (and dirname (expand-file-name dirname)))))) |
| 1310 | 1310 | ||
| 1311 | (defun ibuffer--abbreviate-file-name (filename) | ||
| 1312 | "Abbreviate FILENAME using `ibuffer-directory-abbrev-alist'." | ||
| 1313 | (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist)) | ||
| 1314 | (abbreviate-file-name filename))) | ||
| 1315 | |||
| 1311 | (define-ibuffer-op ibuffer-do-save () | 1316 | (define-ibuffer-op ibuffer-do-save () |
| 1312 | "Save marked buffers as with `save-buffer'." | 1317 | "Save marked buffers as with `save-buffer'." |
| 1313 | (:complex t | 1318 | (:complex t |
| @@ -1885,9 +1890,7 @@ If point is on a group name, this function operates on that group." | |||
| 1885 | (cond ((zerop total) "No files") | 1890 | (cond ((zerop total) "No files") |
| 1886 | ((= 1 total) "1 file") | 1891 | ((= 1 total) "1 file") |
| 1887 | (t (format "%d files" total)))))) | 1892 | (t (format "%d files" total)))))) |
| 1888 | (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist)) | 1893 | (ibuffer--abbreviate-file-name (or (ibuffer-buffer-file-name) ""))) |
| 1889 | (abbreviate-file-name | ||
| 1890 | (or (ibuffer-buffer-file-name) "")))) | ||
| 1891 | 1894 | ||
| 1892 | (define-ibuffer-column filename-and-process | 1895 | (define-ibuffer-column filename-and-process |
| 1893 | (:name "Filename/Process" | 1896 | (:name "Filename/Process" |
diff --git a/lisp/image.el b/lisp/image.el index 814035594b6..6955a90de77 100644 --- a/lisp/image.el +++ b/lisp/image.el | |||
| @@ -264,9 +264,9 @@ compatibility with versions of Emacs that lack the variable | |||
| 264 | ;; Used to be in image-type-header-regexps, but now not used anywhere | 264 | ;; Used to be in image-type-header-regexps, but now not used anywhere |
| 265 | ;; (since 2009-08-28). | 265 | ;; (since 2009-08-28). |
| 266 | (defun image-jpeg-p (data) | 266 | (defun image-jpeg-p (data) |
| 267 | (declare (obsolete "It is unused inside Emacs and will be removed." "27.1")) | ||
| 268 | "Value is non-nil if DATA, a string, consists of JFIF image data. | 267 | "Value is non-nil if DATA, a string, consists of JFIF image data. |
| 269 | We accept the tag Exif because that is the same format." | 268 | We accept the tag Exif because that is the same format." |
| 269 | (declare (obsolete "It is unused inside Emacs and will be removed." "27.1")) | ||
| 270 | (setq data (ignore-errors (string-to-unibyte data))) | 270 | (setq data (ignore-errors (string-to-unibyte data))) |
| 271 | (when (and data (string-match-p "\\`\xff\xd8" data)) | 271 | (when (and data (string-match-p "\\`\xff\xd8" data)) |
| 272 | (catch 'jfif | 272 | (catch 'jfif |
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 14e7b89dd1f..8f0f263dcce 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el | |||
| @@ -719,6 +719,7 @@ | |||
| 719 | georgian | 719 | georgian |
| 720 | cherokee | 720 | cherokee |
| 721 | canadian-aboriginal | 721 | canadian-aboriginal |
| 722 | cham | ||
| 722 | ogham | 723 | ogham |
| 723 | runic | 724 | runic |
| 724 | symbol | 725 | symbol |
diff --git a/lisp/isearch.el b/lisp/isearch.el index c6f7fe7bd4a..a86678572c4 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el | |||
| @@ -3757,23 +3757,27 @@ since they have special meaning in a regexp." | |||
| 3757 | (overlay-put isearch-overlay 'priority 1001) | 3757 | (overlay-put isearch-overlay 'priority 1001) |
| 3758 | (overlay-put isearch-overlay 'face isearch-face))) | 3758 | (overlay-put isearch-overlay 'face isearch-face))) |
| 3759 | 3759 | ||
| 3760 | (when (and search-highlight-submatches | 3760 | (when (and search-highlight-submatches isearch-regexp) |
| 3761 | isearch-regexp) | ||
| 3762 | (mapc 'delete-overlay isearch-submatches-overlays) | 3761 | (mapc 'delete-overlay isearch-submatches-overlays) |
| 3763 | (setq isearch-submatches-overlays nil) | 3762 | (setq isearch-submatches-overlays nil) |
| 3764 | (let ((submatch-data (cddr (butlast match-data))) | 3763 | ;; 'cddr' removes whole expression match from match-data |
| 3764 | (let ((submatch-data (cddr match-data)) | ||
| 3765 | (group 0) | 3765 | (group 0) |
| 3766 | ov face) | 3766 | b e ov face) |
| 3767 | (while submatch-data | 3767 | (while submatch-data |
| 3768 | (setq group (1+ group)) | 3768 | (setq b (pop submatch-data) |
| 3769 | (setq ov (make-overlay (pop submatch-data) (pop submatch-data)) | 3769 | e (pop submatch-data)) |
| 3770 | face (intern-soft (format "isearch-group-%d" group))) | 3770 | (when (and (integer-or-marker-p b) |
| 3771 | ;; Recycle faces from beginning. | 3771 | (integer-or-marker-p e)) |
| 3772 | (unless (facep face) | 3772 | (setq ov (make-overlay b e) |
| 3773 | (setq group 1 face 'isearch-group-1)) | 3773 | group (1+ group) |
| 3774 | (overlay-put ov 'face face) | 3774 | face (intern-soft (format "isearch-group-%d" group))) |
| 3775 | (overlay-put ov 'priority 1002) | 3775 | ;; Recycle faces from beginning |
| 3776 | (push ov isearch-submatches-overlays))))) | 3776 | (unless (facep face) |
| 3777 | (setq group 1 face 'isearch-group-1)) | ||
| 3778 | (overlay-put ov 'face face) | ||
| 3779 | (overlay-put ov 'priority 1002) | ||
| 3780 | (push ov isearch-submatches-overlays)))))) | ||
| 3777 | 3781 | ||
| 3778 | (defun isearch-dehighlight () | 3782 | (defun isearch-dehighlight () |
| 3779 | (when isearch-overlay | 3783 | (when isearch-overlay |
diff --git a/lisp/language/cham.el b/lisp/language/cham.el index eef6d6f8f9f..089988da918 100644 --- a/lisp/language/cham.el +++ b/lisp/language/cham.el | |||
| @@ -34,6 +34,12 @@ | |||
| 34 | (set-language-info-alist | 34 | (set-language-info-alist |
| 35 | "Cham" '((charset unicode) | 35 | "Cham" '((charset unicode) |
| 36 | (coding-system utf-8) | 36 | (coding-system utf-8) |
| 37 | (coding-priority utf-8))) | 37 | (coding-priority utf-8) |
| 38 | (input-method . "cham") | ||
| 39 | (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨁꨰ") | ||
| 40 | (documentation . "\ | ||
| 41 | The Cham script is a Brahmic script used to write Cham, | ||
| 42 | an Austronesian language spoken by some 245,000 Chams | ||
| 43 | in Vietnam and Cambodia."))) | ||
| 38 | 44 | ||
| 39 | (provide 'cham) | 45 | (provide 'cham) |
diff --git a/lisp/leim/quail/cham.el b/lisp/leim/quail/cham.el new file mode 100644 index 00000000000..d12ae6cddf0 --- /dev/null +++ b/lisp/leim/quail/cham.el | |||
| @@ -0,0 +1,116 @@ | |||
| 1 | ;;; cham.el --- Quail package for inputting Cham characters -*- coding: utf-8; lexical-binding:t -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 2021 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Eli Zaretskii <eliz@gnu.org> | ||
| 6 | ;; Keywords: i18n | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | |||
| 25 | ;; This file defines the following Cham keyboards: | ||
| 26 | ;; | ||
| 27 | ;; - QWERTY-based Cham. | ||
| 28 | |||
| 29 | ;;; Code: | ||
| 30 | |||
| 31 | (require 'quail) | ||
| 32 | |||
| 33 | (quail-define-package | ||
| 34 | "cham" "Cham" "ꨌꩌ" t | ||
| 35 | "A QWERTY-based Cham input method." | ||
| 36 | nil t nil nil t nil nil nil nil nil t) | ||
| 37 | |||
| 38 | (quail-define-rules | ||
| 39 | ("a" ?ꨀ) | ||
| 40 | ("A" ?ꨄ) | ||
| 41 | ("i" ?ꨁ) | ||
| 42 | ("u" ?ꨂ) | ||
| 43 | ("e" ?ꨃ) | ||
| 44 | ("o" ?ꨅ) | ||
| 45 | ("k" ?ꨆ) | ||
| 46 | ("K" ?ꨇ) | ||
| 47 | ("g" ?ꨈ) | ||
| 48 | ("G" ?ꨉ) | ||
| 49 | ("q" ?ꨊ) | ||
| 50 | ("Q" ?ꨋ) | ||
| 51 | ("c" ?ꨌ) | ||
| 52 | ("C" ?ꨍ) | ||
| 53 | ("j" ?ꨎ) | ||
| 54 | ("J" ?ꨏ) | ||
| 55 | ("z" ?ꨐ) | ||
| 56 | ("Z" ?ꨑ) | ||
| 57 | ("zz" ?ꨒ) | ||
| 58 | ("t" ?ꨓ) | ||
| 59 | ("T" ?ꨔ) | ||
| 60 | ("d" ?ꨕ) | ||
| 61 | ("D" ?ꨖ) | ||
| 62 | ("n" ?ꨗ) | ||
| 63 | ("N" ?ꨘ) | ||
| 64 | ("p" ?ꨚ) | ||
| 65 | ("P" ?ꨛ) | ||
| 66 | ("f" ?ꨜ) | ||
| 67 | ("b" ?ꨝ) | ||
| 68 | ("B" ?ꨞ) | ||
| 69 | ("m" ?ꨟ) | ||
| 70 | ("M" ?ꨠ) | ||
| 71 | ("mm" ?ꨡ) | ||
| 72 | ("y" ?ꨢ) | ||
| 73 | ("r" ?ꨣ) | ||
| 74 | ("l" ?ꨤ) | ||
| 75 | ("w" ?ꨥ) | ||
| 76 | ("v" ?ꨥ) | ||
| 77 | ("x" ?ꨦ) | ||
| 78 | ("s" ?ꨧ) | ||
| 79 | ("h" ?ꨨ) | ||
| 80 | ("kk" ?ꩀ) | ||
| 81 | ("ww" ?ꩁ) | ||
| 82 | ("vv" ?ꩁ) | ||
| 83 | ("qq" ?ꩂ) | ||
| 84 | ("cc" ?ꩄ) | ||
| 85 | ("tt" ?ꩅ) | ||
| 86 | ("nn" ?ꩆ) | ||
| 87 | ("pp" ?ꩇ) | ||
| 88 | ("yy" ?ꩈ) | ||
| 89 | ("rr" ?ꩉ) | ||
| 90 | ("ll" ?ꩊ) | ||
| 91 | ("gg" ?ꩊ) | ||
| 92 | ("xx" ?ꩋ) | ||
| 93 | ("." ?ꩌ) | ||
| 94 | ("H" ?ꩍ) | ||
| 95 | ("0" ?꩐) | ||
| 96 | ("1" ?꩑) | ||
| 97 | ("2" ?꩒) | ||
| 98 | ("3" ?꩓) | ||
| 99 | ("4" ?꩔) | ||
| 100 | ("5" ?꩕) | ||
| 101 | ("6" ?꩖) | ||
| 102 | ("7" ?꩗) | ||
| 103 | ("8" ?꩘) | ||
| 104 | ("9" ?꩙) | ||
| 105 | ("!" ?ꨩ) | ||
| 106 | ("#" ?ꨪ) | ||
| 107 | ("$" ?ꨫ) | ||
| 108 | ("^" ?ꨬ) | ||
| 109 | ("&" ?ꨮ) | ||
| 110 | ("`" ?꩜) | ||
| 111 | ("=" ?ꨱ) | ||
| 112 | ("-" ?ꩃ) | ||
| 113 | ("~" ?꩟) | ||
| 114 | ) | ||
| 115 | |||
| 116 | ;;; cham.el ends here | ||
diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index e93ba547a89..0fab1b21b47 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el | |||
| @@ -174,8 +174,8 @@ lines." | |||
| 174 | (defvar fill-flowed-encode-tests) | 174 | (defvar fill-flowed-encode-tests) |
| 175 | 175 | ||
| 176 | (defun fill-flowed-test () | 176 | (defun fill-flowed-test () |
| 177 | (interactive "") | ||
| 178 | (declare (obsolete nil "27.1")) | 177 | (declare (obsolete nil "27.1")) |
| 178 | (interactive "") | ||
| 179 | (user-error (concat "This function is obsolete. Please see " | 179 | (user-error (concat "This function is obsolete. Please see " |
| 180 | "test/lisp/mail/flow-fill-tests.el " | 180 | "test/lisp/mail/flow-fill-tests.el " |
| 181 | "in the Emacs source tree"))) | 181 | "in the Emacs source tree"))) |
diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index ea109eec12a..995ae5f9160 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el | |||
| @@ -910,7 +910,31 @@ play around with the following keys: | |||
| 910 | (unless (assoc bullet-regexp filladapt-token-table) | 910 | (unless (assoc bullet-regexp filladapt-token-table) |
| 911 | (setq filladapt-token-table | 911 | (setq filladapt-token-table |
| 912 | (append filladapt-token-table | 912 | (append filladapt-token-table |
| 913 | (list (list bullet-regexp 'bullet))))))))) | 913 | (list (list bullet-regexp 'bullet))))))) |
| 914 | (footnote--regenerate-alist))) | ||
| 915 | |||
| 916 | (defun footnote--regenerate-alist () | ||
| 917 | (save-excursion | ||
| 918 | (goto-char (point-min)) | ||
| 919 | (when (re-search-forward footnote-section-tag-regexp nil t) | ||
| 920 | (setq footnote--markers-alist | ||
| 921 | (cl-loop | ||
| 922 | with start-of-footnotes = (match-beginning 0) | ||
| 923 | with regexp = (footnote--current-regexp) | ||
| 924 | for (note text) in | ||
| 925 | (cl-loop for pos = (re-search-forward regexp nil t) | ||
| 926 | while pos | ||
| 927 | collect (list (match-string 1) | ||
| 928 | (copy-marker (match-beginning 0) t))) | ||
| 929 | do (goto-char (point-min)) | ||
| 930 | collect (cl-list* | ||
| 931 | (string-to-number note) | ||
| 932 | text | ||
| 933 | (cl-loop | ||
| 934 | for pos = (re-search-forward regexp start-of-footnotes t) | ||
| 935 | while pos | ||
| 936 | when (equal note (match-string 1)) | ||
| 937 | collect (copy-marker (match-beginning 0) t)))))))) | ||
| 914 | 938 | ||
| 915 | (provide 'footnote) | 939 | (provide 'footnote) |
| 916 | 940 | ||
diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el index 2680ed7f3a3..c3b351d7bc8 100644 --- a/lisp/mail/rmailedit.el +++ b/lisp/mail/rmailedit.el | |||
| @@ -145,8 +145,9 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'. | |||
| 145 | (declare-function rmail-summary-enable "rmailsum" ()) | 145 | (declare-function rmail-summary-enable "rmailsum" ()) |
| 146 | (declare-function rmail-summary-update-line "rmailsum" (n)) | 146 | (declare-function rmail-summary-update-line "rmailsum" (n)) |
| 147 | 147 | ||
| 148 | (defun rmail-cease-edit () | 148 | (defun rmail-cease-edit (&optional abort) |
| 149 | "Finish editing message; switch back to Rmail proper." | 149 | "Finish editing message; switch back to Rmail proper. |
| 150 | If ABORT, this is the result of aborting an edit." | ||
| 150 | (interactive) | 151 | (interactive) |
| 151 | (if (rmail-summary-exists) | 152 | (if (rmail-summary-exists) |
| 152 | (with-current-buffer rmail-summary-buffer | 153 | (with-current-buffer rmail-summary-buffer |
| @@ -271,6 +272,8 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'. | |||
| 271 | ;; No match for rmail-mime-charset-pattern, but there was some | 272 | ;; No match for rmail-mime-charset-pattern, but there was some |
| 272 | ;; other Content-Type. We should not insert another. (Bug#4624) | 273 | ;; other Content-Type. We should not insert another. (Bug#4624) |
| 273 | (content-type) | 274 | (content-type) |
| 275 | ;; Don't insert anything if aborting. | ||
| 276 | (abort) | ||
| 274 | ((null old-coding) | 277 | ((null old-coding) |
| 275 | ;; If there was no charset= spec, insert one. | 278 | ;; If there was no charset= spec, insert one. |
| 276 | (backward-char 1) | 279 | (backward-char 1) |
| @@ -352,7 +355,7 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'. | |||
| 352 | (widen) | 355 | (widen) |
| 353 | (delete-region (point-min) (point-max)) | 356 | (delete-region (point-min) (point-max)) |
| 354 | (insert rmail-old-text) | 357 | (insert rmail-old-text) |
| 355 | (rmail-cease-edit) | 358 | (rmail-cease-edit t) |
| 356 | (rmail-highlight-headers)) | 359 | (rmail-highlight-headers)) |
| 357 | 360 | ||
| 358 | (defun rmail-edit-headers-alist (&optional widen markers) | 361 | (defun rmail-edit-headers-alist (&optional widen markers) |
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 60b67edf85a..d29115a9570 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el | |||
| @@ -51,10 +51,10 @@ Setting this option to nil might speed up the generation of summaries." | |||
| 51 | :group 'rmail-summary) | 51 | :group 'rmail-summary) |
| 52 | 52 | ||
| 53 | (defvar rmail-summary-font-lock-keywords | 53 | (defvar rmail-summary-font-lock-keywords |
| 54 | '(("^.....D.*" . font-lock-string-face) ; Deleted. | 54 | '(("^ *[0-9]+D.*" . font-lock-string-face) ; Deleted. |
| 55 | ("^.....-.*" . font-lock-type-face) ; Unread. | 55 | ("^ *[0-9]+-.*" . font-lock-type-face) ; Unread. |
| 56 | ;; Neither of the below will be highlighted if either of the above are: | 56 | ;; Neither of the below will be highlighted if either of the above are: |
| 57 | ("^.....[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date. | 57 | ("^ *[0-9]+[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date. |
| 58 | ("{ \\([^\n}]+\\) }" 1 font-lock-comment-face)) ; Labels. | 58 | ("{ \\([^\n}]+\\) }" 1 font-lock-comment-face)) ; Labels. |
| 59 | "Additional expressions to highlight in Rmail Summary mode.") | 59 | "Additional expressions to highlight in Rmail Summary mode.") |
| 60 | 60 | ||
diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 35d5884b16c..7cbd42c8ea2 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el | |||
| @@ -125,11 +125,10 @@ With non-nil FORCE, the update is always carried out." | |||
| 125 | ;; Otherwise on to your regular programming | 125 | ;; Otherwise on to your regular programming |
| 126 | (t t))) | 126 | (t t))) |
| 127 | 127 | ||
| 128 | (defun mh-speed-toggle (&rest ignored) | 128 | (defun mh-speed-toggle (&rest _ignored) |
| 129 | "Toggle the display of child folders in the speedbar. | 129 | "Toggle the display of child folders in the speedbar. |
| 130 | The optional arguments from speedbar are IGNORED." | 130 | The optional arguments from speedbar are IGNORED." |
| 131 | (interactive) | 131 | (interactive) |
| 132 | (declare (ignore args)) | ||
| 133 | (beginning-of-line) | 132 | (beginning-of-line) |
| 134 | (let ((parent (get-text-property (point) 'mh-folder)) | 133 | (let ((parent (get-text-property (point) 'mh-folder)) |
| 135 | (kids-p (get-text-property (point) 'mh-children-p)) | 134 | (kids-p (get-text-property (point) 'mh-children-p)) |
| @@ -164,11 +163,10 @@ The optional arguments from speedbar are IGNORED." | |||
| 164 | (mh-line-beginning-position) (1+ (line-beginning-position)) | 163 | (mh-line-beginning-position) (1+ (line-beginning-position)) |
| 165 | '(mh-expanded t))))))) | 164 | '(mh-expanded t))))))) |
| 166 | 165 | ||
| 167 | (defun mh-speed-view (&rest ignored) | 166 | (defun mh-speed-view (&rest _ignored) |
| 168 | "Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder]. | 167 | "Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder]. |
| 169 | The optional arguments from speedbar are IGNORED." | 168 | The optional arguments from speedbar are IGNORED." |
| 170 | (interactive) | 169 | (interactive) |
| 171 | (declare (ignore args)) | ||
| 172 | (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) | 170 | (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) |
| 173 | (range (and (stringp folder) | 171 | (range (and (stringp folder) |
| 174 | (mh-read-range "Scan" folder t nil nil | 172 | (mh-read-range "Scan" folder t nil nil |
diff --git a/lisp/net/eww.el b/lisp/net/eww.el index d131b2bf8c9..e39a4c33b20 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el | |||
| @@ -1050,9 +1050,16 @@ the like." | |||
| 1050 | ;; multi-page isearch support | 1050 | ;; multi-page isearch support |
| 1051 | (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer) | 1051 | (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer) |
| 1052 | (setq truncate-lines t) | 1052 | (setq truncate-lines t) |
| 1053 | (setq-local thing-at-point-provider-alist | ||
| 1054 | (append thing-at-point-provider-alist | ||
| 1055 | '((url . eww--url-at-point)))) | ||
| 1053 | (buffer-disable-undo) | 1056 | (buffer-disable-undo) |
| 1054 | (setq buffer-read-only t)) | 1057 | (setq buffer-read-only t)) |
| 1055 | 1058 | ||
| 1059 | (defun eww--url-at-point () | ||
| 1060 | "`thing-at-point' provider function." | ||
| 1061 | (get-text-property (point) 'shr-url)) | ||
| 1062 | |||
| 1056 | ;;;###autoload | 1063 | ;;;###autoload |
| 1057 | (defun eww-browse-url (url &optional new-window) | 1064 | (defun eww-browse-url (url &optional new-window) |
| 1058 | "Ask the EWW browser to load URL. | 1065 | "Ask the EWW browser to load URL. |
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index e8ee372cb25..ed3d15377c3 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el | |||
| @@ -181,10 +181,9 @@ The string is used in `tramp-methods'.") | |||
| 181 | `("scpx" | 181 | `("scpx" |
| 182 | (tramp-login-program "ssh") | 182 | (tramp-login-program "ssh") |
| 183 | (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") | 183 | (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") |
| 184 | ("-e" "none") ("-t" "-t") ("%h") | 184 | ("-e" "none") ("-t" "-t") |
| 185 | ("%l"))) | 185 | ("-o" "RemoteCommand='%l'") ("%h"))) |
| 186 | (tramp-async-args (("-q"))) | 186 | (tramp-async-args (("-q"))) |
| 187 | (tramp-direct-async t) | ||
| 188 | (tramp-remote-shell ,tramp-default-remote-shell) | 187 | (tramp-remote-shell ,tramp-default-remote-shell) |
| 189 | (tramp-remote-shell-login ("-l")) | 188 | (tramp-remote-shell-login ("-l")) |
| 190 | (tramp-remote-shell-args ("-c")) | 189 | (tramp-remote-shell-args ("-c")) |
| @@ -238,10 +237,9 @@ The string is used in `tramp-methods'.") | |||
| 238 | `("sshx" | 237 | `("sshx" |
| 239 | (tramp-login-program "ssh") | 238 | (tramp-login-program "ssh") |
| 240 | (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") | 239 | (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") |
| 241 | ("-e" "none") ("-t" "-t") ("%h") | 240 | ("-e" "none") ("-t" "-t") |
| 242 | ("%l"))) | 241 | ("-o" "RemoteCommand='%l'") ("%h"))) |
| 243 | (tramp-async-args (("-q"))) | 242 | (tramp-async-args (("-q"))) |
| 244 | (tramp-direct-async t) | ||
| 245 | (tramp-remote-shell ,tramp-default-remote-shell) | 243 | (tramp-remote-shell ,tramp-default-remote-shell) |
| 246 | (tramp-remote-shell-login ("-l")) | 244 | (tramp-remote-shell-login ("-l")) |
| 247 | (tramp-remote-shell-args ("-c")))) | 245 | (tramp-remote-shell-args ("-c")))) |
| @@ -2608,23 +2606,19 @@ The method used must be an out-of-band method." | |||
| 2608 | (defun tramp-sh-handle-insert-directory | 2606 | (defun tramp-sh-handle-insert-directory |
| 2609 | (filename switches &optional wildcard full-directory-p) | 2607 | (filename switches &optional wildcard full-directory-p) |
| 2610 | "Like `insert-directory' for Tramp files." | 2608 | "Like `insert-directory' for Tramp files." |
| 2611 | (setq filename (expand-file-name filename)) | ||
| 2612 | (unless switches (setq switches "")) | 2609 | (unless switches (setq switches "")) |
| 2613 | ;; Check, whether directory is accessible. | 2610 | ;; Check, whether directory is accessible. |
| 2614 | (unless wildcard | 2611 | (unless wildcard |
| 2615 | (access-file filename "Reading directory")) | 2612 | (access-file filename "Reading directory")) |
| 2616 | (with-parsed-tramp-file-name filename nil | 2613 | (with-parsed-tramp-file-name (expand-file-name filename) nil |
| 2617 | (if (and (featurep 'ls-lisp) | 2614 | (if (and (featurep 'ls-lisp) |
| 2618 | (not (symbol-value 'ls-lisp-use-insert-directory-program))) | 2615 | (not (symbol-value 'ls-lisp-use-insert-directory-program))) |
| 2619 | (tramp-handle-insert-directory | 2616 | (tramp-handle-insert-directory |
| 2620 | filename switches wildcard full-directory-p) | 2617 | filename switches wildcard full-directory-p) |
| 2621 | (when (stringp switches) | 2618 | (when (stringp switches) |
| 2622 | (setq switches (split-string switches))) | 2619 | (setq switches (split-string switches))) |
| 2623 | (when (tramp-get-ls-command-with ;FIXME: tramp-sh--quoting-style-options? | 2620 | (setq switches |
| 2624 | v "--quoting-style=literal --show-control-chars") | 2621 | (append switches (split-string (tramp-sh--quoting-style-options v)))) |
| 2625 | (setq switches | ||
| 2626 | (append | ||
| 2627 | switches '("--quoting-style=literal" "--show-control-chars")))) | ||
| 2628 | (unless (tramp-get-ls-command-with v "--dired") | 2622 | (unless (tramp-get-ls-command-with v "--dired") |
| 2629 | (setq switches (delete "--dired" switches))) | 2623 | (setq switches (delete "--dired" switches))) |
| 2630 | (when wildcard | 2624 | (when wildcard |
| @@ -4306,11 +4300,14 @@ file exists and nonzero exit status otherwise." | |||
| 4306 | ;; ensure they have the correct values when the shell starts, not | 4300 | ;; ensure they have the correct values when the shell starts, not |
| 4307 | ;; just processes run within the shell. (Which processes include | 4301 | ;; just processes run within the shell. (Which processes include |
| 4308 | ;; our initial probes to ensure the remote shell is usable.) | 4302 | ;; our initial probes to ensure the remote shell is usable.) |
| 4303 | ;; For the time being, we assume that all shells interpret -i as | ||
| 4304 | ;; interactive shell. Must be the last argument, because (for | ||
| 4305 | ;; example) bash expects long options first. | ||
| 4309 | (tramp-send-command | 4306 | (tramp-send-command |
| 4310 | vec (format | 4307 | vec (format |
| 4311 | (concat | 4308 | (concat |
| 4312 | "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " | 4309 | "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " |
| 4313 | "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") | 4310 | "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i") |
| 4314 | tramp-terminal-type | 4311 | tramp-terminal-type |
| 4315 | (or (getenv "INSIDE_EMACS") emacs-version) tramp-version | 4312 | (or (getenv "INSIDE_EMACS") emacs-version) tramp-version |
| 4316 | (or (getenv-internal "ENV" tramp-remote-process-environment) "") | 4313 | (or (getenv-internal "ENV" tramp-remote-process-environment) "") |
| @@ -5122,7 +5119,7 @@ connection if a previous connection has died for some reason." | |||
| 5122 | options (format-spec options spec) | 5119 | options (format-spec options spec) |
| 5123 | spec (format-spec-make | 5120 | spec (format-spec-make |
| 5124 | ?h l-host ?u l-user ?p l-port ?c options | 5121 | ?h l-host ?u l-user ?p l-port ?c options |
| 5125 | ?l (concat remote-shell " " extra-args)) | 5122 | ?l (concat remote-shell " " extra-args " -i")) |
| 5126 | command | 5123 | command |
| 5127 | (concat | 5124 | (concat |
| 5128 | ;; We do not want to see the trailing local | 5125 | ;; We do not want to see the trailing local |
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 1604e8962c0..c5a74a5c653 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el | |||
| @@ -156,6 +156,7 @@ this variable (\"client min protocol=NT1\") ." | |||
| 156 | "NT_STATUS_NO_SUCH_FILE" | 156 | "NT_STATUS_NO_SUCH_FILE" |
| 157 | "NT_STATUS_NO_SUCH_USER" | 157 | "NT_STATUS_NO_SUCH_USER" |
| 158 | "NT_STATUS_NOT_A_DIRECTORY" | 158 | "NT_STATUS_NOT_A_DIRECTORY" |
| 159 | "NT_STATUS_NOT_SUPPORTED" | ||
| 159 | "NT_STATUS_OBJECT_NAME_COLLISION" | 160 | "NT_STATUS_OBJECT_NAME_COLLISION" |
| 160 | "NT_STATUS_OBJECT_NAME_INVALID" | 161 | "NT_STATUS_OBJECT_NAME_INVALID" |
| 161 | "NT_STATUS_OBJECT_NAME_NOT_FOUND" | 162 | "NT_STATUS_OBJECT_NAME_NOT_FOUND" |
| @@ -371,17 +372,17 @@ pass to the OPERATION." | |||
| 371 | (tramp-error | 372 | (tramp-error |
| 372 | v2 'file-error | 373 | v2 'file-error |
| 373 | "add-name-to-file: %s must not be a directory" filename)) | 374 | "add-name-to-file: %s must not be a directory" filename)) |
| 374 | ;; Do the 'confirm if exists' thing. | 375 | ;; Do the 'confirm if exists' thing. |
| 375 | (when (file-exists-p newname) | 376 | (when (file-exists-p newname) |
| 376 | ;; What to do? | 377 | ;; What to do? |
| 377 | (if (or (null ok-if-already-exists) ; not allowed to exist | 378 | (if (or (null ok-if-already-exists) ; not allowed to exist |
| 378 | (and (numberp ok-if-already-exists) | 379 | (and (numberp ok-if-already-exists) |
| 379 | (not (yes-or-no-p | 380 | (not (yes-or-no-p |
| 380 | (format | 381 | (format |
| 381 | "File %s already exists; make it a link anyway? " | 382 | "File %s already exists; make it a link anyway? " |
| 382 | v2-localname))))) | 383 | v2-localname))))) |
| 383 | (tramp-error v2 'file-already-exists newname) | 384 | (tramp-error v2 'file-already-exists newname) |
| 384 | (delete-file newname))) | 385 | (delete-file newname))) |
| 385 | ;; We must also flush the cache of the directory, because | 386 | ;; We must also flush the cache of the directory, because |
| 386 | ;; `file-attributes' reads the values from there. | 387 | ;; `file-attributes' reads the values from there. |
| 387 | (tramp-flush-file-properties v2 v2-localname) | 388 | (tramp-flush-file-properties v2 v2-localname) |
| @@ -1166,7 +1167,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." | |||
| 1166 | (insert " -> " (tramp-compat-file-attribute-type attr)))) | 1167 | (insert " -> " (tramp-compat-file-attribute-type attr)))) |
| 1167 | 1168 | ||
| 1168 | (insert "\n") | 1169 | (insert "\n") |
| 1169 | (forward-line) | ||
| 1170 | (beginning-of-line))) | 1170 | (beginning-of-line))) |
| 1171 | entries)))))) | 1171 | entries)))))) |
| 1172 | 1172 | ||
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 2816c58fe7f..7b34a748822 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el | |||
| @@ -1990,6 +1990,8 @@ the resulting error message." | |||
| 1990 | (tramp-dissect-file-name default-directory) 0 fmt-string arguments) | 1990 | (tramp-dissect-file-name default-directory) 0 fmt-string arguments) |
| 1991 | (apply #'message fmt-string arguments))) | 1991 | (apply #'message fmt-string arguments))) |
| 1992 | 1992 | ||
| 1993 | (put #'tramp-test-message 'tramp-suppress-trace t) | ||
| 1994 | |||
| 1993 | ;; This function provides traces in case of errors not triggered by | 1995 | ;; This function provides traces in case of errors not triggered by |
| 1994 | ;; Tramp functions. | 1996 | ;; Tramp functions. |
| 1995 | (defun tramp-signal-hook-function (error-symbol data) | 1997 | (defun tramp-signal-hook-function (error-symbol data) |
| @@ -3801,15 +3803,20 @@ It does not support `:stderr'." | |||
| 3801 | (get-buffer-create buffer) | 3803 | (get-buffer-create buffer) |
| 3802 | ;; BUFFER can be nil. We use a temporary buffer. | 3804 | ;; BUFFER can be nil. We use a temporary buffer. |
| 3803 | (generate-new-buffer tramp-temp-buffer-name))) | 3805 | (generate-new-buffer tramp-temp-buffer-name))) |
| 3804 | ;; We use as environment the difference to toplevel | ||
| 3805 | ;; `process-environment'. | ||
| 3806 | (env (mapcar | 3806 | (env (mapcar |
| 3807 | (lambda (elt) | 3807 | (lambda (elt) |
| 3808 | (unless | 3808 | (when (string-match-p "=" elt) elt)) |
| 3809 | (member | 3809 | tramp-remote-process-environment)) |
| 3810 | elt (default-toplevel-value 'process-environment)) | 3810 | ;; We use as environment the difference to toplevel |
| 3811 | (when (string-match-p "=" elt) elt))) | 3811 | ;; `process-environment'. |
| 3812 | process-environment)) | 3812 | (env (dolist (elt process-environment env) |
| 3813 | (when | ||
| 3814 | (and | ||
| 3815 | (string-match-p "=" elt) | ||
| 3816 | (not | ||
| 3817 | (member | ||
| 3818 | elt (default-toplevel-value 'process-environment)))) | ||
| 3819 | (setq env (cons elt env))))) | ||
| 3813 | (env (setenv-internal | 3820 | (env (setenv-internal |
| 3814 | env "INSIDE_EMACS" | 3821 | env "INSIDE_EMACS" |
| 3815 | (concat (or (getenv "INSIDE_EMACS") emacs-version) | 3822 | (concat (or (getenv "INSIDE_EMACS") emacs-version) |
diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 9bcf1d37345..e5941ae652e 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el | |||
| @@ -2,9 +2,10 @@ | |||
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Neil W. Van Dyke <nwv@acm.org> | 5 | ;; Author: Neil W. Van Dyke <nwv@acm.org> |
| 6 | ;; Created: 09-Aug-1996 | 6 | ;; Maintainer: emacs-devel@gnu.org |
| 7 | ;; Keywords: comm www | 7 | ;; Created: 09-Aug-1996 |
| 8 | ;; Keywords: comm www | ||
| 8 | 9 | ||
| 9 | ;; This file is part of GNU Emacs. | 10 | ;; This file is part of GNU Emacs. |
| 10 | 11 | ||
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el index 5bc3049d90f..0602943db20 100644 --- a/lisp/nxml/nxml-mode.el +++ b/lisp/nxml/nxml-mode.el | |||
| @@ -54,26 +54,30 @@ | |||
| 54 | "Non-nil means display glyph following character reference. | 54 | "Non-nil means display glyph following character reference. |
| 55 | The glyph is displayed in face `nxml-glyph'." | 55 | The glyph is displayed in face `nxml-glyph'." |
| 56 | :group 'nxml | 56 | :group 'nxml |
| 57 | :type 'boolean) | 57 | :type 'boolean |
| 58 | :safe #'booleanp) | ||
| 58 | 59 | ||
| 59 | (defcustom nxml-sexp-element-flag t | 60 | (defcustom nxml-sexp-element-flag t |
| 60 | "Non-nil means sexp commands treat an element as a single expression." | 61 | "Non-nil means sexp commands treat an element as a single expression." |
| 61 | :version "27.1" ; nil -> t | 62 | :version "27.1" ; nil -> t |
| 62 | :group 'nxml | 63 | :group 'nxml |
| 63 | :type 'boolean) | 64 | :type 'boolean |
| 65 | :safe #'booleanp) | ||
| 64 | 66 | ||
| 65 | (defcustom nxml-slash-auto-complete-flag nil | 67 | (defcustom nxml-slash-auto-complete-flag nil |
| 66 | "Non-nil means typing a slash automatically completes the end-tag. | 68 | "Non-nil means typing a slash automatically completes the end-tag. |
| 67 | This is used by `nxml-electric-slash'." | 69 | This is used by `nxml-electric-slash'." |
| 68 | :group 'nxml | 70 | :group 'nxml |
| 69 | :type 'boolean) | 71 | :type 'boolean |
| 72 | :safe #'booleanp) | ||
| 70 | 73 | ||
| 71 | (defcustom nxml-child-indent 2 | 74 | (defcustom nxml-child-indent 2 |
| 72 | "Indentation for the children of an element relative to the start-tag. | 75 | "Indentation for the children of an element relative to the start-tag. |
| 73 | This only applies when the line or lines containing the start-tag contains | 76 | This only applies when the line or lines containing the start-tag contains |
| 74 | nothing else other than that start-tag." | 77 | nothing else other than that start-tag." |
| 75 | :group 'nxml | 78 | :group 'nxml |
| 76 | :type 'integer) | 79 | :type 'integer |
| 80 | :safe #'integerp) | ||
| 77 | 81 | ||
| 78 | (defcustom nxml-attribute-indent 4 | 82 | (defcustom nxml-attribute-indent 4 |
| 79 | "Indentation for the attributes of an element relative to the start-tag. | 83 | "Indentation for the attributes of an element relative to the start-tag. |
| @@ -81,12 +85,14 @@ This only applies when the first attribute of a tag starts a line. | |||
| 81 | In other cases, the first attribute on one line is indented the same | 85 | In other cases, the first attribute on one line is indented the same |
| 82 | as the first attribute on the previous line." | 86 | as the first attribute on the previous line." |
| 83 | :group 'nxml | 87 | :group 'nxml |
| 84 | :type 'integer) | 88 | :type 'integer |
| 89 | :safe #'integerp) | ||
| 85 | 90 | ||
| 86 | (defcustom nxml-bind-meta-tab-to-complete-flag t | 91 | (defcustom nxml-bind-meta-tab-to-complete-flag t |
| 87 | "Non-nil means to use nXML completion in \\[completion-at-point]." | 92 | "Non-nil means to use nXML completion in \\[completion-at-point]." |
| 88 | :group 'nxml | 93 | :group 'nxml |
| 89 | :type 'boolean) | 94 | :type 'boolean |
| 95 | :safe #'booleanp) | ||
| 90 | 96 | ||
| 91 | (defcustom nxml-prefer-utf-16-to-utf-8-flag nil | 97 | (defcustom nxml-prefer-utf-16-to-utf-8-flag nil |
| 92 | "Non-nil means prefer UTF-16 to UTF-8 when saving a buffer. | 98 | "Non-nil means prefer UTF-16 to UTF-8 when saving a buffer. |
| @@ -94,7 +100,8 @@ This is used only when a buffer does not contain an encoding declaration | |||
| 94 | and when its current `buffer-file-coding-system' specifies neither UTF-16 | 100 | and when its current `buffer-file-coding-system' specifies neither UTF-16 |
| 95 | nor UTF-8." | 101 | nor UTF-8." |
| 96 | :group 'nxml | 102 | :group 'nxml |
| 97 | :type 'boolean) | 103 | :type 'boolean |
| 104 | :safe #'booleanp) | ||
| 98 | 105 | ||
| 99 | (defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type | 106 | (defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type |
| 100 | 'windows-nt) | 107 | 'windows-nt) |
| @@ -103,7 +110,8 @@ This is used only for saving a buffer; when reading the byte-order is | |||
| 103 | auto-detected. It may be relevant both when there is no encoding declaration | 110 | auto-detected. It may be relevant both when there is no encoding declaration |
| 104 | and when the encoding declaration specifies `UTF-16'." | 111 | and when the encoding declaration specifies `UTF-16'." |
| 105 | :group 'nxml | 112 | :group 'nxml |
| 106 | :type 'boolean) | 113 | :type 'boolean |
| 114 | :safe #'booleanp) | ||
| 107 | 115 | ||
| 108 | (defcustom nxml-default-buffer-file-coding-system nil | 116 | (defcustom nxml-default-buffer-file-coding-system nil |
| 109 | "Default value for `buffer-file-coding-system' for a buffer for a new file. | 117 | "Default value for `buffer-file-coding-system' for a buffer for a new file. |
| @@ -112,13 +120,15 @@ A value of nil means use the default value of | |||
| 112 | A buffer's `buffer-file-coding-system' affects what | 120 | A buffer's `buffer-file-coding-system' affects what |
| 113 | \\[nxml-insert-xml-declaration] inserts." | 121 | \\[nxml-insert-xml-declaration] inserts." |
| 114 | :group 'nxml | 122 | :group 'nxml |
| 115 | :type 'coding-system) | 123 | :type 'coding-system |
| 124 | :safe #'coding-system-p) | ||
| 116 | 125 | ||
| 117 | (defcustom nxml-auto-insert-xml-declaration-flag nil | 126 | (defcustom nxml-auto-insert-xml-declaration-flag nil |
| 118 | "Non-nil means automatically insert an XML declaration in a new file. | 127 | "Non-nil means automatically insert an XML declaration in a new file. |
| 119 | The XML declaration is inserted using `nxml-insert-xml-declaration'." | 128 | The XML declaration is inserted using `nxml-insert-xml-declaration'." |
| 120 | :group 'nxml | 129 | :group 'nxml |
| 121 | :type 'boolean) | 130 | :type 'boolean |
| 131 | :safe #'booleanp) | ||
| 122 | 132 | ||
| 123 | (defface nxml-delimited-data | 133 | (defface nxml-delimited-data |
| 124 | '((t (:inherit font-lock-doc-face))) | 134 | '((t (:inherit font-lock-doc-face))) |
diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el index 147efed0057..0b7d1e454c3 100644 --- a/lisp/obsolete/nnir.el +++ b/lisp/obsolete/nnir.el | |||
| @@ -504,7 +504,6 @@ Add an entry here when adding a new search engine.") | |||
| 504 | ,@(mapcar (lambda (elem) (list 'const (car elem))) | 504 | ,@(mapcar (lambda (elem) (list 'const (car elem))) |
| 505 | nnir-engines))))) | 505 | nnir-engines))))) |
| 506 | 506 | ||
| 507 | |||
| 508 | (defmacro nnir-add-result (dirnam artno score prefix server artlist) | 507 | (defmacro nnir-add-result (dirnam artno score prefix server artlist) |
| 509 | "Construct a result vector and add it to ARTLIST. | 508 | "Construct a result vector and add it to ARTLIST. |
| 510 | DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to | 509 | DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to |
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 2a2a4978c62..d047dd543c2 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el | |||
| @@ -95,6 +95,12 @@ | |||
| 95 | :prefix "perl-" | 95 | :prefix "perl-" |
| 96 | :group 'languages) | 96 | :group 'languages) |
| 97 | 97 | ||
| 98 | (defface perl-non-scalar-variable | ||
| 99 | '((t :inherit font-lock-variable-name-face :underline t)) | ||
| 100 | "Face used for non-scalar variables." | ||
| 101 | :version "28.1" | ||
| 102 | :group 'perl) | ||
| 103 | |||
| 98 | (defvar perl-mode-abbrev-table nil | 104 | (defvar perl-mode-abbrev-table nil |
| 99 | "Abbrev table in use in perl-mode buffers.") | 105 | "Abbrev table in use in perl-mode buffers.") |
| 100 | (define-abbrev-table 'perl-mode-abbrev-table ()) | 106 | (define-abbrev-table 'perl-mode-abbrev-table ()) |
| @@ -187,11 +193,12 @@ | |||
| 187 | ;; | 193 | ;; |
| 188 | ;; Fontify function, variable and file name references. | 194 | ;; Fontify function, variable and file name references. |
| 189 | ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face) | 195 | ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face) |
| 190 | ;; Additionally underline non-scalar variables. Maybe this is a bad idea. | 196 | ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable' |
| 197 | ;; will underline them by default. | ||
| 191 | ;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face) | 198 | ;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face) |
| 192 | ("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face) | 199 | ("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face) |
| 193 | ("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)" | 200 | ("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)" |
| 194 | (2 (cons font-lock-variable-name-face '(underline)))) | 201 | (2 'perl-non-scalar-variable)) |
| 195 | ("<\\(\\sw+\\)>" 1 font-lock-constant-face) | 202 | ("<\\(\\sw+\\)>" 1 font-lock-constant-face) |
| 196 | ;; | 203 | ;; |
| 197 | ;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'. | 204 | ;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'. |
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 06966f33b72..768cd58ae44 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el | |||
| @@ -928,6 +928,7 @@ if one already exists." | |||
| 928 | ;;;###autoload | 928 | ;;;###autoload |
| 929 | (defun project-async-shell-command () | 929 | (defun project-async-shell-command () |
| 930 | "Run `async-shell-command' in the current project's root directory." | 930 | "Run `async-shell-command' in the current project's root directory." |
| 931 | (declare (interactive-only async-shell-command)) | ||
| 931 | (interactive) | 932 | (interactive) |
| 932 | (let ((default-directory (project-root (project-current t)))) | 933 | (let ((default-directory (project-root (project-current t)))) |
| 933 | (call-interactively #'async-shell-command))) | 934 | (call-interactively #'async-shell-command))) |
| @@ -935,6 +936,7 @@ if one already exists." | |||
| 935 | ;;;###autoload | 936 | ;;;###autoload |
| 936 | (defun project-shell-command () | 937 | (defun project-shell-command () |
| 937 | "Run `shell-command' in the current project's root directory." | 938 | "Run `shell-command' in the current project's root directory." |
| 939 | (declare (interactive-only shell-command)) | ||
| 938 | (interactive) | 940 | (interactive) |
| 939 | (let ((default-directory (project-root (project-current t)))) | 941 | (let ((default-directory (project-root (project-current t)))) |
| 940 | (call-interactively #'shell-command))) | 942 | (call-interactively #'shell-command))) |
| @@ -972,6 +974,7 @@ loop using the command \\[fileloop-continue]." | |||
| 972 | ;;;###autoload | 974 | ;;;###autoload |
| 973 | (defun project-compile () | 975 | (defun project-compile () |
| 974 | "Run `compile' in the project root." | 976 | "Run `compile' in the project root." |
| 977 | (declare (interactive-only compile)) | ||
| 975 | (interactive) | 978 | (interactive) |
| 976 | (let ((default-directory (project-root (project-current t)))) | 979 | (let ((default-directory (project-root (project-current t)))) |
| 977 | (call-interactively #'compile))) | 980 | (call-interactively #'compile))) |
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index a417de32640..cc045a1b2d1 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el | |||
| @@ -1556,7 +1556,7 @@ with your script for an edit-interpret-debug cycle." | |||
| 1556 | (sh-set-shell | 1556 | (sh-set-shell |
| 1557 | (cond ((save-excursion | 1557 | (cond ((save-excursion |
| 1558 | (goto-char (point-min)) | 1558 | (goto-char (point-min)) |
| 1559 | (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^ \t\n]+\\)")) | 1559 | (looking-at auto-mode-interpreter-regexp)) |
| 1560 | (match-string 2)) | 1560 | (match-string 2)) |
| 1561 | ((not buffer-file-name) sh-shell-file) | 1561 | ((not buffer-file-name) sh-shell-file) |
| 1562 | ;; Checks that use `buffer-file-name' follow. | 1562 | ;; Checks that use `buffer-file-name' follow. |
| @@ -2927,8 +2927,8 @@ option followed by a colon `:' if the option accepts an argument." | |||
| 2927 | (put 'sh-assignment 'delete-selection t) | 2927 | (put 'sh-assignment 'delete-selection t) |
| 2928 | (defun sh-assignment (arg) | 2928 | (defun sh-assignment (arg) |
| 2929 | "Remember preceding identifier for future completion and do self-insert." | 2929 | "Remember preceding identifier for future completion and do self-insert." |
| 2930 | (interactive "p") | ||
| 2931 | (declare (obsolete nil "27.1")) | 2930 | (declare (obsolete nil "27.1")) |
| 2931 | (interactive "p") | ||
| 2932 | (self-insert-command arg) | 2932 | (self-insert-command arg) |
| 2933 | (sh--assignment-collect)) | 2933 | (sh--assignment-collect)) |
| 2934 | 2934 | ||
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index b6778de807d..898cb4fb4c1 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el | |||
| @@ -967,16 +967,15 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." | |||
| 967 | (let ((inhibit-read-only t) | 967 | (let ((inhibit-read-only t) |
| 968 | (buffer-undo-list t)) | 968 | (buffer-undo-list t)) |
| 969 | (save-excursion | 969 | (save-excursion |
| 970 | (erase-buffer) | ||
| 971 | (condition-case err | 970 | (condition-case err |
| 972 | (xref--insert-xrefs | 971 | (let ((alist (xref--analyze (funcall xref--fetcher)))) |
| 973 | (xref--analyze (funcall xref--fetcher))) | 972 | (erase-buffer) |
| 973 | (xref--insert-xrefs alist)) | ||
| 974 | (user-error | 974 | (user-error |
| 975 | (insert | 975 | (insert |
| 976 | (propertize | 976 | (propertize |
| 977 | (error-message-string err) | 977 | (error-message-string err) |
| 978 | 'face 'error)))) | 978 | 'face 'error))))))) |
| 979 | (goto-char (point-min))))) | ||
| 980 | 979 | ||
| 981 | (defun xref-show-definitions-buffer (fetcher alist) | 980 | (defun xref-show-definitions-buffer (fetcher alist) |
| 982 | "Show the definitions list in a regular window. | 981 | "Show the definitions list in a regular window. |
| @@ -1001,8 +1000,12 @@ When only one definition found, jump to it right away instead." | |||
| 1001 | When there is more than one definition, split the selected window | 1000 | When there is more than one definition, split the selected window |
| 1002 | and show the list in a small window at the bottom. And use a | 1001 | and show the list in a small window at the bottom. And use a |
| 1003 | local keymap that binds `RET' to `xref-quit-and-goto-xref'." | 1002 | local keymap that binds `RET' to `xref-quit-and-goto-xref'." |
| 1004 | (let ((xrefs (funcall fetcher)) | 1003 | (let* ((xrefs (funcall fetcher)) |
| 1005 | (dd default-directory)) | 1004 | (dd default-directory) |
| 1005 | ;; XXX: Make percentage customizable maybe? | ||
| 1006 | (max-height (/ (window-height) 2)) | ||
| 1007 | (size-fun (lambda (window) | ||
| 1008 | (fit-window-to-buffer window max-height)))) | ||
| 1006 | (cond | 1009 | (cond |
| 1007 | ((not (cdr xrefs)) | 1010 | ((not (cdr xrefs)) |
| 1008 | (xref-pop-to-location (car xrefs) | 1011 | (xref-pop-to-location (car xrefs) |
| @@ -1013,7 +1016,8 @@ local keymap that binds `RET' to `xref-quit-and-goto-xref'." | |||
| 1013 | (xref--transient-buffer-mode) | 1016 | (xref--transient-buffer-mode) |
| 1014 | (xref--show-common-initialize (xref--analyze xrefs) fetcher alist) | 1017 | (xref--show-common-initialize (xref--analyze xrefs) fetcher alist) |
| 1015 | (pop-to-buffer (current-buffer) | 1018 | (pop-to-buffer (current-buffer) |
| 1016 | '(display-buffer-in-direction . ((direction . below)))) | 1019 | `(display-buffer-in-direction . ((direction . below) |
| 1020 | (window-height . ,size-fun)))) | ||
| 1017 | (current-buffer)))))) | 1021 | (current-buffer)))))) |
| 1018 | 1022 | ||
| 1019 | (define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom | 1023 | (define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom |
diff --git a/lisp/replace.el b/lisp/replace.el index d41dc98a0d9..db5b340631a 100644 --- a/lisp/replace.el +++ b/lisp/replace.el | |||
| @@ -866,13 +866,10 @@ If nil, uses `regexp-history'." | |||
| 866 | ;; Do not automatically add default to the history for empty input. | 866 | ;; Do not automatically add default to the history for empty input. |
| 867 | (history-add-new-input nil) | 867 | (history-add-new-input nil) |
| 868 | (input (read-from-minibuffer | 868 | (input (read-from-minibuffer |
| 869 | (cond ((string-match-p ":[ \t]*\\'" prompt) | 869 | (if (string-match-p ":[ \t]*\\'" prompt) |
| 870 | prompt) | 870 | prompt |
| 871 | ((and default (> (length default) 0)) | 871 | (format-prompt prompt (and (length> default 0) |
| 872 | (format "%s (default %s): " prompt | 872 | (query-replace-descr default)))) |
| 873 | (query-replace-descr default))) | ||
| 874 | (t | ||
| 875 | (format "%s: " prompt))) | ||
| 876 | nil nil nil (or history 'regexp-history) suggestions t))) | 873 | nil nil nil (or history 'regexp-history) suggestions t))) |
| 877 | (if (equal input "") | 874 | (if (equal input "") |
| 878 | ;; Return the default value when the user enters empty input. | 875 | ;; Return the default value when the user enters empty input. |
| @@ -2428,23 +2425,27 @@ It is called with three arguments, as if it were | |||
| 2428 | (overlay-put replace-overlay 'priority 1001) ;higher than lazy overlays | 2425 | (overlay-put replace-overlay 'priority 1001) ;higher than lazy overlays |
| 2429 | (overlay-put replace-overlay 'face 'query-replace))) | 2426 | (overlay-put replace-overlay 'face 'query-replace))) |
| 2430 | 2427 | ||
| 2431 | (when (and query-replace-highlight-submatches | 2428 | (when (and query-replace-highlight-submatches regexp-flag) |
| 2432 | regexp-flag) | ||
| 2433 | (mapc 'delete-overlay replace-submatches-overlays) | 2429 | (mapc 'delete-overlay replace-submatches-overlays) |
| 2434 | (setq replace-submatches-overlays nil) | 2430 | (setq replace-submatches-overlays nil) |
| 2435 | (let ((submatch-data (cddr (butlast (match-data t)))) | 2431 | ;; 'cddr' removes whole expression match from match-data |
| 2432 | (let ((submatch-data (cddr (match-data t))) | ||
| 2436 | (group 0) | 2433 | (group 0) |
| 2437 | ov face) | 2434 | b e ov face) |
| 2438 | (while submatch-data | 2435 | (while submatch-data |
| 2439 | (setq group (1+ group)) | 2436 | (setq b (pop submatch-data) |
| 2440 | (setq ov (make-overlay (pop submatch-data) (pop submatch-data)) | 2437 | e (pop submatch-data)) |
| 2441 | face (intern-soft (format "isearch-group-%d" group))) | 2438 | (when (and (integer-or-marker-p b) |
| 2442 | ;; Recycle faces from beginning. | 2439 | (integer-or-marker-p e)) |
| 2443 | (unless (facep face) | 2440 | (setq ov (make-overlay b e) |
| 2444 | (setq group 1 face 'isearch-group-1)) | 2441 | group (1+ group) |
| 2445 | (overlay-put ov 'face face) | 2442 | face (intern-soft (format "isearch-group-%d" group))) |
| 2446 | (overlay-put ov 'priority 1002) | 2443 | ;; Recycle faces from beginning |
| 2447 | (push ov replace-submatches-overlays)))) | 2444 | (unless (facep face) |
| 2445 | (setq group 1 face 'isearch-group-1)) | ||
| 2446 | (overlay-put ov 'face face) | ||
| 2447 | (overlay-put ov 'priority 1002) | ||
| 2448 | (push ov replace-submatches-overlays))))) | ||
| 2448 | 2449 | ||
| 2449 | (if query-replace-lazy-highlight | 2450 | (if query-replace-lazy-highlight |
| 2450 | (let ((isearch-string search-string) | 2451 | (let ((isearch-string search-string) |
diff --git a/lisp/simple.el b/lisp/simple.el index 37c0885dcc5..8d4e4a7a6bb 100644 --- a/lisp/simple.el +++ b/lisp/simple.el | |||
| @@ -820,9 +820,10 @@ With ARG, perform this action that many times." | |||
| 820 | (delete-horizontal-space t) | 820 | (delete-horizontal-space t) |
| 821 | (unless arg | 821 | (unless arg |
| 822 | (setq arg 1)) | 822 | (setq arg 1)) |
| 823 | (dotimes (_ arg) | 823 | (let ((electric-indent-mode nil)) |
| 824 | (newline nil t) | 824 | (dotimes (_ arg) |
| 825 | (indent-according-to-mode))) | 825 | (newline nil t) |
| 826 | (indent-according-to-mode)))) | ||
| 826 | 827 | ||
| 827 | (defun reindent-then-newline-and-indent () | 828 | (defun reindent-then-newline-and-indent () |
| 828 | "Reindent current line, insert newline, then indent the new line. | 829 | "Reindent current line, insert newline, then indent the new line. |
| @@ -832,7 +833,8 @@ In programming language modes, this is the same as TAB. | |||
| 832 | In some text modes, where TAB inserts a tab, this indents to the | 833 | In some text modes, where TAB inserts a tab, this indents to the |
| 833 | column specified by the function `current-left-margin'." | 834 | column specified by the function `current-left-margin'." |
| 834 | (interactive "*") | 835 | (interactive "*") |
| 835 | (let ((pos (point))) | 836 | (let ((pos (point)) |
| 837 | (electric-indent-mode nil)) | ||
| 836 | ;; Be careful to insert the newline before indenting the line. | 838 | ;; Be careful to insert the newline before indenting the line. |
| 837 | ;; Otherwise, the indentation might be wrong. | 839 | ;; Otherwise, the indentation might be wrong. |
| 838 | (newline) | 840 | (newline) |
| @@ -7338,10 +7340,7 @@ even beep.)" | |||
| 7338 | ;; of the kill before killing. | 7340 | ;; of the kill before killing. |
| 7339 | (let ((opoint (point)) | 7341 | (let ((opoint (point)) |
| 7340 | (kill-whole-line (and kill-whole-line (bolp))) | 7342 | (kill-whole-line (and kill-whole-line (bolp))) |
| 7341 | (orig-y (cdr (nth 2 (posn-at-point)))) | 7343 | (orig-vlnum (cdr (nth 6 (posn-at-point))))) |
| 7342 | ;; FIXME: This tolerance should be zero! It isn't due to a | ||
| 7343 | ;; bug in posn-at-point, see bug#45837. | ||
| 7344 | (tol (/ (line-pixel-height) 2))) | ||
| 7345 | (if arg | 7344 | (if arg |
| 7346 | (vertical-motion (prefix-numeric-value arg)) | 7345 | (vertical-motion (prefix-numeric-value arg)) |
| 7347 | (end-of-visual-line 1) | 7346 | (end-of-visual-line 1) |
| @@ -7352,8 +7351,8 @@ even beep.)" | |||
| 7352 | ;; end-of-visual-line didn't overshoot due to complications | 7351 | ;; end-of-visual-line didn't overshoot due to complications |
| 7353 | ;; like display or overlay strings, intangible text, etc.: | 7352 | ;; like display or overlay strings, intangible text, etc.: |
| 7354 | ;; otherwise, we don't want to kill a character that's | 7353 | ;; otherwise, we don't want to kill a character that's |
| 7355 | ;; unrelated to the place where the visual line wrapped. | 7354 | ;; unrelated to the place where the visual line wraps. |
| 7356 | (and (< (abs (- (cdr (nth 2 (posn-at-point))) orig-y)) tol) | 7355 | (and (= (cdr (nth 6 (posn-at-point))) orig-vlnum) |
| 7357 | ;; Make sure we delete the character where the line wraps | 7356 | ;; Make sure we delete the character where the line wraps |
| 7358 | ;; under visual-line-mode, be it whitespace or a | 7357 | ;; under visual-line-mode, be it whitespace or a |
| 7359 | ;; character whose category set allows to wrap at it. | 7358 | ;; character whose category set allows to wrap at it. |
diff --git a/lisp/startup.el b/lisp/startup.el index 9325ab5acff..09635b12990 100644 --- a/lisp/startup.el +++ b/lisp/startup.el | |||
| @@ -1180,6 +1180,7 @@ please check its value") | |||
| 1180 | ;; are dependencies between them. | 1180 | ;; are dependencies between them. |
| 1181 | (nreverse custom-delayed-init-variables)) | 1181 | (nreverse custom-delayed-init-variables)) |
| 1182 | (mapc #'custom-reevaluate-setting custom-delayed-init-variables) | 1182 | (mapc #'custom-reevaluate-setting custom-delayed-init-variables) |
| 1183 | (setq custom-delayed-init-variables nil) | ||
| 1183 | 1184 | ||
| 1184 | ;; Warn for invalid user name. | 1185 | ;; Warn for invalid user name. |
| 1185 | (when init-file-user | 1186 | (when init-file-user |
| @@ -1309,12 +1310,6 @@ please check its value") | |||
| 1309 | (startup--setup-quote-display) | 1310 | (startup--setup-quote-display) |
| 1310 | (setq internal--text-quoting-flag t)) | 1311 | (setq internal--text-quoting-flag t)) |
| 1311 | 1312 | ||
| 1312 | ;; Re-evaluate again the predefined variables whose initial value | ||
| 1313 | ;; depends on the runtime context, in case some of them depend on | ||
| 1314 | ;; the window-system features. Example: blink-cursor-mode. | ||
| 1315 | (mapc #'custom-reevaluate-setting custom-delayed-init-variables) | ||
| 1316 | (setq custom-delayed-init-variables nil) | ||
| 1317 | |||
| 1318 | (normal-erase-is-backspace-setup-frame) | 1313 | (normal-erase-is-backspace-setup-frame) |
| 1319 | 1314 | ||
| 1320 | ;; Register default TTY colors for the case the terminal hasn't a | 1315 | ;; Register default TTY colors for the case the terminal hasn't a |
| @@ -1495,13 +1490,13 @@ to reading the init file), or afterwards when the user first | |||
| 1495 | opens a graphical frame. | 1490 | opens a graphical frame. |
| 1496 | 1491 | ||
| 1497 | This can set the values of `menu-bar-mode', `tool-bar-mode', | 1492 | This can set the values of `menu-bar-mode', `tool-bar-mode', |
| 1498 | `tab-bar-mode', and `no-blinking-cursor', as well as the `cursor' face. | 1493 | `tab-bar-mode', and `blink-cursor-mode', as well as the `cursor' face. |
| 1499 | Changed settings will be marked as \"CHANGED outside of Customize\"." | 1494 | Changed settings will be marked as \"CHANGED outside of Customize\"." |
| 1500 | (let ((no-vals '("no" "off" "false" "0")) | 1495 | (let ((no-vals '("no" "off" "false" "0")) |
| 1501 | (settings '(("menuBar" "MenuBar" menu-bar-mode nil) | 1496 | (settings '(("menuBar" "MenuBar" menu-bar-mode nil) |
| 1502 | ("toolBar" "ToolBar" tool-bar-mode nil) | 1497 | ("toolBar" "ToolBar" tool-bar-mode nil) |
| 1503 | ("scrollBar" "ScrollBar" scroll-bar-mode nil) | 1498 | ("scrollBar" "ScrollBar" scroll-bar-mode nil) |
| 1504 | ("cursorBlink" "CursorBlink" no-blinking-cursor t)))) | 1499 | ("cursorBlink" "CursorBlink" blink-cursor-mode nil)))) |
| 1505 | (dolist (x settings) | 1500 | (dolist (x settings) |
| 1506 | (if (member (x-get-resource (nth 0 x) (nth 1 x)) no-vals) | 1501 | (if (member (x-get-resource (nth 0 x) (nth 1 x)) no-vals) |
| 1507 | (set (nth 2 x) (nth 3 x))))) | 1502 | (set (nth 2 x) (nth 3 x))))) |
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 5f4dd9ef587..94e9d5c5828 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el | |||
| @@ -120,6 +120,15 @@ The properties returned may include `top', `left', `height', and `width'." | |||
| 120 | (define-key global-map [?\s-d] 'isearch-repeat-backward) | 120 | (define-key global-map [?\s-d] 'isearch-repeat-backward) |
| 121 | (define-key global-map [?\s-e] 'isearch-yank-kill) | 121 | (define-key global-map [?\s-e] 'isearch-yank-kill) |
| 122 | (define-key global-map [?\s-f] 'isearch-forward) | 122 | (define-key global-map [?\s-f] 'isearch-forward) |
| 123 | (define-key esc-map [?\s-f] 'isearch-forward-regexp) | ||
| 124 | (define-key minibuffer-local-isearch-map [?\s-f] | ||
| 125 | 'isearch-forward-exit-minibuffer) | ||
| 126 | (define-key isearch-mode-map [?\s-f] 'isearch-repeat-forward) | ||
| 127 | (define-key global-map [?\s-F] 'isearch-backward) | ||
| 128 | (define-key esc-map [?\s-F] 'isearch-backward-regexp) | ||
| 129 | (define-key minibuffer-local-isearch-map [?\s-F] | ||
| 130 | 'isearch-reverse-exit-minibuffer) | ||
| 131 | (define-key isearch-mode-map [?\s-F] 'isearch-repeat-backward) | ||
| 123 | (define-key global-map [?\s-g] 'isearch-repeat-forward) | 132 | (define-key global-map [?\s-g] 'isearch-repeat-forward) |
| 124 | (define-key global-map [?\s-h] 'ns-do-hide-emacs) | 133 | (define-key global-map [?\s-h] 'ns-do-hide-emacs) |
| 125 | (define-key global-map [?\s-H] 'ns-do-hide-others) | 134 | (define-key global-map [?\s-H] 'ns-do-hide-others) |
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 98d3a3856ea..820ee38d101 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el | |||
| @@ -159,7 +159,8 @@ | |||
| 159 | ;; ;; This should be before other entries that may return t | 159 | ;; ;; This should be before other entries that may return t |
| 160 | ;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries) | 160 | ;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries) |
| 161 | ;; | 161 | ;; |
| 162 | ;; This module recognizes entries of the form | 162 | ;; This module recognizes entries of the form (defined by |
| 163 | ;; `remember-diary-regexp') | ||
| 163 | ;; | 164 | ;; |
| 164 | ;; DIARY: .... | 165 | ;; DIARY: .... |
| 165 | ;; | 166 | ;; |
| @@ -410,13 +411,24 @@ The default emulates `current-time-string' for backward compatibility." | |||
| 410 | :group 'remember | 411 | :group 'remember |
| 411 | :version "27.1") | 412 | :version "27.1") |
| 412 | 413 | ||
| 414 | (defcustom remember-text-format-function nil | ||
| 415 | "The function to format the remembered text. | ||
| 416 | The function receives the remembered text as argument and should | ||
| 417 | return the text to be remembered." | ||
| 418 | :type '(choice (const nil) function) | ||
| 419 | :group 'remember | ||
| 420 | :version "28.1") | ||
| 421 | |||
| 413 | (defun remember-append-to-file () | 422 | (defun remember-append-to-file () |
| 414 | "Remember, with description DESC, the given TEXT." | 423 | "Remember, with description DESC, the given TEXT." |
| 415 | (let* ((text (buffer-string)) | 424 | (let* ((text (buffer-string)) |
| 416 | (desc (remember-buffer-desc)) | 425 | (desc (remember-buffer-desc)) |
| 417 | (remember-text (concat "\n" remember-leader-text | 426 | (remember-text (concat "\n" |
| 418 | (format-time-string remember-time-format) | 427 | (if remember-text-format-function |
| 419 | " (" desc ")\n\n" text | 428 | (funcall remember-text-format-function text) |
| 429 | (concat remember-leader-text | ||
| 430 | (format-time-string remember-time-format) | ||
| 431 | " (" desc ")\n\n" text)) | ||
| 420 | (save-excursion (goto-char (point-max)) | 432 | (save-excursion (goto-char (point-max)) |
| 421 | (if (bolp) nil "\n")))) | 433 | (if (bolp) nil "\n")))) |
| 422 | (buf (find-buffer-visiting remember-data-file))) | 434 | (buf (find-buffer-visiting remember-data-file))) |
| @@ -532,17 +544,28 @@ If this is nil, then `diary-file' will be used instead." | |||
| 532 | 544 | ||
| 533 | (autoload 'diary-make-entry "diary-lib") | 545 | (autoload 'diary-make-entry "diary-lib") |
| 534 | 546 | ||
| 547 | (defcustom remember-diary-regexp "^DIARY:\\s-*\\(.+\\)" | ||
| 548 | "Regexp to extract diary entries." | ||
| 549 | :type 'regexp | ||
| 550 | :version "28.1") | ||
| 551 | |||
| 552 | (defvar diary-file) | ||
| 553 | |||
| 535 | ;;;###autoload | 554 | ;;;###autoload |
| 536 | (defun remember-diary-extract-entries () | 555 | (defun remember-diary-extract-entries () |
| 537 | "Extract diary entries from the region." | 556 | "Extract diary entries from the region based on `remember-diary-regexp'." |
| 538 | (save-excursion | 557 | (save-excursion |
| 539 | (goto-char (point-min)) | 558 | (goto-char (point-min)) |
| 540 | (let (list) | 559 | (let (list) |
| 541 | (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t) | 560 | (while (re-search-forward remember-diary-regexp nil t) |
| 542 | (push (remember-diary-convert-entry (match-string 1)) list)) | 561 | (push (remember-diary-convert-entry (match-string 1)) list)) |
| 543 | (when list | 562 | (when list |
| 544 | (diary-make-entry (mapconcat 'identity list "\n") | 563 | (diary-make-entry (mapconcat 'identity list "\n") |
| 545 | nil remember-diary-file)) | 564 | nil remember-diary-file) |
| 565 | (when remember-save-after-remembering | ||
| 566 | (with-current-buffer (find-buffer-visiting (or remember-diary-file | ||
| 567 | diary-file)) | ||
| 568 | (save-buffer)))) | ||
| 546 | nil))) ;; Continue processing | 569 | nil))) ;; Continue processing |
| 547 | 570 | ||
| 548 | ;;; Internal Functions: | 571 | ;;; Internal Functions: |
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index d3ba941fcc2..c52fcfcc051 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el | |||
| @@ -52,8 +52,30 @@ | |||
| 52 | 52 | ||
| 53 | ;;; Code: | 53 | ;;; Code: |
| 54 | 54 | ||
| 55 | (require 'cl-lib) | ||
| 55 | (provide 'thingatpt) | 56 | (provide 'thingatpt) |
| 56 | 57 | ||
| 58 | (defvar thing-at-point-provider-alist nil | ||
| 59 | "Alist of providers for returning a \"thing\" at point. | ||
| 60 | This variable can be set globally, or appended to buffer-locally | ||
| 61 | by modes, to provide functions that will return a \"thing\" at | ||
| 62 | point. The first provider for the \"thing\" that returns a | ||
| 63 | non-nil value wins. | ||
| 64 | |||
| 65 | For instance, a major mode could say: | ||
| 66 | |||
| 67 | \(setq-local thing-at-point-provider-alist | ||
| 68 | (append thing-at-point-provider-alist | ||
| 69 | \\='((url . my-mode--url-at-point)))) | ||
| 70 | |||
| 71 | to provide a way to get an `url' at point in that mode. The | ||
| 72 | provider functions are called with no parameters at the point in | ||
| 73 | question. | ||
| 74 | |||
| 75 | \"things\" include `symbol', `list', `sexp', `defun', `filename', | ||
| 76 | `url', `email', `uuid', `word', `sentence', `whitespace', `line', | ||
| 77 | and `page'.") | ||
| 78 | |||
| 57 | ;; Basic movement | 79 | ;; Basic movement |
| 58 | 80 | ||
| 59 | ;;;###autoload | 81 | ;;;###autoload |
| @@ -143,11 +165,18 @@ strip text properties from the return value. | |||
| 143 | See the file `thingatpt.el' for documentation on how to define | 165 | See the file `thingatpt.el' for documentation on how to define |
| 144 | a symbol as a valid THING." | 166 | a symbol as a valid THING." |
| 145 | (let ((text | 167 | (let ((text |
| 146 | (if (get thing 'thing-at-point) | 168 | (cond |
| 147 | (funcall (get thing 'thing-at-point)) | 169 | ((cl-loop for (pthing . function) in thing-at-point-provider-alist |
| 170 | when (eq pthing thing) | ||
| 171 | for result = (funcall function) | ||
| 172 | when result | ||
| 173 | return result)) | ||
| 174 | ((get thing 'thing-at-point) | ||
| 175 | (funcall (get thing 'thing-at-point))) | ||
| 176 | (t | ||
| 148 | (let ((bounds (bounds-of-thing-at-point thing))) | 177 | (let ((bounds (bounds-of-thing-at-point thing))) |
| 149 | (when bounds | 178 | (when bounds |
| 150 | (buffer-substring (car bounds) (cdr bounds))))))) | 179 | (buffer-substring (car bounds) (cdr bounds)))))))) |
| 151 | (when (and text no-properties (sequencep text)) | 180 | (when (and text no-properties (sequencep text)) |
| 152 | (set-text-properties 0 (length text) nil text)) | 181 | (set-text-properties 0 (length text) nil text)) |
| 153 | text)) | 182 | text)) |
| @@ -218,6 +247,15 @@ The bounds of THING are determined by `bounds-of-thing-at-point'." | |||
| 218 | 247 | ||
| 219 | (put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp) | 248 | (put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp) |
| 220 | 249 | ||
| 250 | ;; Symbols | ||
| 251 | |||
| 252 | (put 'symbol 'beginning-op 'thing-at-point--beginning-of-symbol) | ||
| 253 | |||
| 254 | (defun thing-at-point--beginning-of-symbol () | ||
| 255 | "Move point to the beginning of the current symbol." | ||
| 256 | (and (re-search-backward "\\(\\sw\\|\\s_\\)+") | ||
| 257 | (skip-syntax-backward "w_"))) | ||
| 258 | |||
| 221 | ;; Lists | 259 | ;; Lists |
| 222 | 260 | ||
| 223 | (put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point) | 261 | (put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point) |
diff --git a/lisp/type-break.el b/lisp/type-break.el index 84c240c9f8c..a6d5cd01702 100644 --- a/lisp/type-break.el +++ b/lisp/type-break.el | |||
| @@ -487,7 +487,7 @@ Return nil if the file is missing or if the time is not a Lisp time value." | |||
| 487 | (goto-char (point-min)) | 487 | (goto-char (point-min)) |
| 488 | (read (current-buffer))) | 488 | (read (current-buffer))) |
| 489 | (end-of-file | 489 | (end-of-file |
| 490 | (error "End of file in `%s'" file)))))))) | 490 | (warn "End of file in `%s'" file)))))))) |
| 491 | 491 | ||
| 492 | (defun type-break-get-previous-count () | 492 | (defun type-break-get-previous-count () |
| 493 | "Get previous keystroke count from `type-break-file-name'. | 493 | "Get previous keystroke count from `type-break-file-name'. |
| @@ -505,7 +505,7 @@ integer." | |||
| 505 | (forward-line 1) | 505 | (forward-line 1) |
| 506 | (read (current-buffer))) | 506 | (read (current-buffer))) |
| 507 | (end-of-file | 507 | (end-of-file |
| 508 | (error "End of file in `%s'" file))))))) | 508 | (warn "End of file in `%s'" file))))))) |
| 509 | file | 509 | file |
| 510 | 0))) | 510 | 0))) |
| 511 | 511 | ||
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 6c96d8ca7c4..bc9f11202b1 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el | |||
| @@ -2392,6 +2392,7 @@ If it contains `file', show short logs for files. | |||
| 2392 | Not all VC backends support short logs!") | 2392 | Not all VC backends support short logs!") |
| 2393 | 2393 | ||
| 2394 | (defvar log-view-vc-fileset) | 2394 | (defvar log-view-vc-fileset) |
| 2395 | (defvar log-view-message-re) | ||
| 2395 | 2396 | ||
| 2396 | (defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return) | 2397 | (defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return) |
| 2397 | "Insert at the end of the current buffer buttons to show more log entries. | 2398 | "Insert at the end of the current buffer buttons to show more log entries. |
| @@ -2401,21 +2402,32 @@ Does nothing if IS-START-REVISION is non-nil, or if LIMIT is nil, | |||
| 2401 | or if PL-RETURN is `limit-unsupported'." | 2402 | or if PL-RETURN is `limit-unsupported'." |
| 2402 | (when (and limit (not (eq 'limit-unsupported pl-return)) | 2403 | (when (and limit (not (eq 'limit-unsupported pl-return)) |
| 2403 | (not is-start-revision)) | 2404 | (not is-start-revision)) |
| 2404 | (goto-char (point-max)) | 2405 | (let ((entries 0)) |
| 2405 | (insert "\n") | 2406 | (goto-char (point-min)) |
| 2406 | (insert-text-button "Show 2X entries" | 2407 | (while (re-search-forward log-view-message-re nil t) |
| 2407 | 'action (lambda (&rest _ignore) | 2408 | (cl-incf entries)) |
| 2408 | (vc-print-log-internal | 2409 | ;; If we got fewer entries than we asked for, then displaying |
| 2409 | log-view-vc-backend log-view-vc-fileset | 2410 | ;; the "more" buttons isn't useful. |
| 2410 | working-revision nil (* 2 limit))) | 2411 | (when (>= entries limit) |
| 2411 | 'help-echo "Show the log again, and double the number of log entries shown") | 2412 | (goto-char (point-max)) |
| 2412 | (insert " ") | 2413 | (insert "\n") |
| 2413 | (insert-text-button "Show unlimited entries" | 2414 | (insert-text-button |
| 2414 | 'action (lambda (&rest _ignore) | 2415 | "Show 2X entries" |
| 2415 | (vc-print-log-internal | 2416 | 'action (lambda (&rest _ignore) |
| 2416 | log-view-vc-backend log-view-vc-fileset | 2417 | (vc-print-log-internal |
| 2417 | working-revision nil nil)) | 2418 | log-view-vc-backend log-view-vc-fileset |
| 2418 | 'help-echo "Show the log again, including all entries"))) | 2419 | working-revision nil (* 2 limit))) |
| 2420 | 'help-echo | ||
| 2421 | "Show the log again, and double the number of log entries shown") | ||
| 2422 | (insert " ") | ||
| 2423 | (insert-text-button | ||
| 2424 | "Show unlimited entries" | ||
| 2425 | 'action (lambda (&rest _ignore) | ||
| 2426 | (vc-print-log-internal | ||
| 2427 | log-view-vc-backend log-view-vc-fileset | ||
| 2428 | working-revision nil nil)) | ||
| 2429 | 'help-echo "Show the log again, including all entries") | ||
| 2430 | (insert "\n"))))) | ||
| 2419 | 2431 | ||
| 2420 | (defun vc-print-log-internal (backend files working-revision | 2432 | (defun vc-print-log-internal (backend files working-revision |
| 2421 | &optional is-start-revision limit type) | 2433 | &optional is-start-revision limit type) |
diff --git a/lisp/version.el b/lisp/version.el index fcfc2f8b806..3a3093fdd4a 100644 --- a/lisp/version.el +++ b/lisp/version.el | |||
| @@ -29,14 +29,12 @@ | |||
| 29 | (defconst emacs-major-version | 29 | (defconst emacs-major-version |
| 30 | (progn (string-match "^[0-9]+" emacs-version) | 30 | (progn (string-match "^[0-9]+" emacs-version) |
| 31 | (string-to-number (match-string 0 emacs-version))) | 31 | (string-to-number (match-string 0 emacs-version))) |
| 32 | "Major version number of this version of Emacs. | 32 | "Major version number of this version of Emacs.") |
| 33 | This variable first existed in version 19.23.") | ||
| 34 | 33 | ||
| 35 | (defconst emacs-minor-version | 34 | (defconst emacs-minor-version |
| 36 | (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) | 35 | (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) |
| 37 | (string-to-number (match-string 1 emacs-version))) | 36 | (string-to-number (match-string 1 emacs-version))) |
| 38 | "Minor version number of this version of Emacs. | 37 | "Minor version number of this version of Emacs.") |
| 39 | This variable first existed in version 19.23.") | ||
| 40 | 38 | ||
| 41 | (defconst emacs-build-system (system-name) | 39 | (defconst emacs-build-system (system-name) |
| 42 | "Name of the system on which Emacs was built, or nil if not available.") | 40 | "Name of the system on which Emacs was built, or nil if not available.") |
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 7dda04eda21..68a0d3d2356 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el | |||
| @@ -4026,17 +4026,19 @@ is inline." | |||
| 4026 | 4026 | ||
| 4027 | ;;; The `color' Widget. | 4027 | ;;; The `color' Widget. |
| 4028 | 4028 | ||
| 4029 | ;; Fixme: match | ||
| 4030 | (define-widget 'color 'editable-field | 4029 | (define-widget 'color 'editable-field |
| 4031 | "Choose a color name (with sample)." | 4030 | "Choose a color name (with sample)." |
| 4032 | :format "%{%t%}: %v (%{sample%})\n" | 4031 | :format "%{%t%}: %v (%{sample%})\n" |
| 4033 | :value-create 'widget-color-value-create | 4032 | :value-create 'widget-color-value-create |
| 4034 | :size 10 | 4033 | :size (1+ (apply #'max 13 ; Longest RGB hex string. |
| 4034 | (mapcar #'length (defined-colors)))) | ||
| 4035 | :tag "Color" | 4035 | :tag "Color" |
| 4036 | :value "black" | 4036 | :value "black" |
| 4037 | :completions (or facemenu-color-alist (defined-colors)) | 4037 | :completions (or facemenu-color-alist (defined-colors)) |
| 4038 | :sample-face-get 'widget-color-sample-face-get | 4038 | :sample-face-get 'widget-color-sample-face-get |
| 4039 | :notify 'widget-color-notify | 4039 | :notify 'widget-color-notify |
| 4040 | :match #'widget-color-match | ||
| 4041 | :validate #'widget-color-validate | ||
| 4040 | :action 'widget-color-action) | 4042 | :action 'widget-color-action) |
| 4041 | 4043 | ||
| 4042 | (defun widget-color-value-create (widget) | 4044 | (defun widget-color-value-create (widget) |
| @@ -4085,6 +4087,19 @@ is inline." | |||
| 4085 | (overlay-put (widget-get widget :sample-overlay) | 4087 | (overlay-put (widget-get widget :sample-overlay) |
| 4086 | 'face (widget-apply widget :sample-face-get)) | 4088 | 'face (widget-apply widget :sample-face-get)) |
| 4087 | (widget-default-notify widget child event)) | 4089 | (widget-default-notify widget child event)) |
| 4090 | |||
| 4091 | (defun widget-color-match (_widget value) | ||
| 4092 | "Non-nil if VALUE is a defined color or a RGB hex string." | ||
| 4093 | (and (stringp value) | ||
| 4094 | (or (color-defined-p value) | ||
| 4095 | (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value)))) | ||
| 4096 | |||
| 4097 | (defun widget-color-validate (widget) | ||
| 4098 | "Check that WIDGET's value is a valid color." | ||
| 4099 | (let ((value (widget-value widget))) | ||
| 4100 | (unless (widget-color-match widget value) | ||
| 4101 | (widget-put widget :error (format "Invalid color: %S" value)) | ||
| 4102 | widget))) | ||
| 4088 | 4103 | ||
| 4089 | ;;; The Help Echo | 4104 | ;;; The Help Echo |
| 4090 | 4105 | ||
diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4 index 475fa15d6bd..0dfb2da9a6a 100644 --- a/m4/canonicalize.m4 +++ b/m4/canonicalize.m4 | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | # canonicalize.m4 serial 35 | 1 | # canonicalize.m4 serial 37 |
| 2 | 2 | ||
| 3 | dnl Copyright (C) 2003-2007, 2009-2021 Free Software Foundation, Inc. | 3 | dnl Copyright (C) 2003-2007, 2009-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -78,68 +78,106 @@ AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE], | |||
| 78 | # so is the latter. | 78 | # so is the latter. |
| 79 | AC_DEFUN([gl_FUNC_REALPATH_WORKS], | 79 | AC_DEFUN([gl_FUNC_REALPATH_WORKS], |
| 80 | [ | 80 | [ |
| 81 | AC_CHECK_FUNCS_ONCE([realpath]) | 81 | AC_CHECK_FUNCS_ONCE([realpath lstat]) |
| 82 | AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles | 82 | AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles |
| 83 | AC_CACHE_CHECK([whether realpath works], [gl_cv_func_realpath_works], [ | 83 | AC_CACHE_CHECK([whether realpath works], [gl_cv_func_realpath_works], [ |
| 84 | rm -rf conftest.a conftest.d | 84 | rm -rf conftest.a conftest.d |
| 85 | touch conftest.a | 85 | touch conftest.a |
| 86 | # Assume that if we have lstat, we can also check symlinks. | ||
| 87 | if test $ac_cv_func_lstat = yes; then | ||
| 88 | ln -s conftest.a conftest.l | ||
| 89 | fi | ||
| 86 | mkdir conftest.d | 90 | mkdir conftest.d |
| 87 | AC_RUN_IFELSE([ | 91 | AC_RUN_IFELSE([ |
| 88 | AC_LANG_PROGRAM([[ | 92 | AC_LANG_PROGRAM([[ |
| 89 | ]GL_NOCRASH[ | 93 | ]GL_NOCRASH[ |
| 94 | #include <errno.h> | ||
| 90 | #include <stdlib.h> | 95 | #include <stdlib.h> |
| 91 | #include <string.h> | 96 | #include <string.h> |
| 92 | ]], [[ | 97 | ]], [[ |
| 93 | int result = 0; | 98 | int result = 0; |
| 99 | /* This test fails on Solaris 10. */ | ||
| 94 | { | 100 | { |
| 95 | char *name = realpath ("conftest.a", NULL); | 101 | char *name = realpath ("conftest.a", NULL); |
| 96 | if (!(name && *name == '/')) | 102 | if (!(name && *name == '/')) |
| 97 | result |= 1; | 103 | result |= 1; |
| 98 | free (name); | 104 | free (name); |
| 99 | } | 105 | } |
| 106 | /* This test fails on older versions of Cygwin. */ | ||
| 100 | { | 107 | { |
| 101 | char *name = realpath ("conftest.b/../conftest.a", NULL); | 108 | char *name = realpath ("conftest.b/../conftest.a", NULL); |
| 102 | if (name != NULL) | 109 | if (name != NULL) |
| 103 | result |= 2; | 110 | result |= 2; |
| 104 | free (name); | 111 | free (name); |
| 105 | } | 112 | } |
| 113 | /* This test fails on Cygwin 2.9. */ | ||
| 114 | #if HAVE_LSTAT | ||
| 115 | { | ||
| 116 | char *name = realpath ("conftest.l/../conftest.a", NULL); | ||
| 117 | if (name != NULL || errno != ENOTDIR) | ||
| 118 | result |= 4; | ||
| 119 | free (name); | ||
| 120 | } | ||
| 121 | #endif | ||
| 122 | /* This test fails on Mac OS X 10.13, OpenBSD 6.0. */ | ||
| 106 | { | 123 | { |
| 107 | char *name = realpath ("conftest.a/", NULL); | 124 | char *name = realpath ("conftest.a/", NULL); |
| 108 | if (name != NULL) | 125 | if (name != NULL) |
| 109 | result |= 4; | 126 | result |= 8; |
| 110 | free (name); | 127 | free (name); |
| 111 | } | 128 | } |
| 129 | /* This test fails on AIX 7, Solaris 10. */ | ||
| 112 | { | 130 | { |
| 113 | char *name1 = realpath (".", NULL); | 131 | char *name1 = realpath (".", NULL); |
| 114 | char *name2 = realpath ("conftest.d//./..", NULL); | 132 | char *name2 = realpath ("conftest.d//./..", NULL); |
| 115 | if (! name1 || ! name2 || strcmp (name1, name2)) | 133 | if (! name1 || ! name2 || strcmp (name1, name2)) |
| 116 | result |= 8; | 134 | result |= 16; |
| 117 | free (name1); | 135 | free (name1); |
| 118 | free (name2); | 136 | free (name2); |
| 119 | } | 137 | } |
| 138 | #ifdef __linux__ | ||
| 139 | /* On Linux, // is the same as /. See also double-slash-root.m4. | ||
| 140 | realpath() should respect this. | ||
| 141 | This test fails on musl libc 1.2.2. */ | ||
| 142 | { | ||
| 143 | char *name = realpath ("//", NULL); | ||
| 144 | if (! name || strcmp (name, "/")) | ||
| 145 | result |= 32; | ||
| 146 | free (name); | ||
| 147 | } | ||
| 148 | #endif | ||
| 120 | return result; | 149 | return result; |
| 121 | ]]) | 150 | ]]) |
| 122 | ], | 151 | ], |
| 123 | [gl_cv_func_realpath_works=yes], | 152 | [gl_cv_func_realpath_works=yes], |
| 124 | [gl_cv_func_realpath_works=no], | 153 | [case $? in |
| 154 | 32) gl_cv_func_realpath_works=nearly ;; | ||
| 155 | *) gl_cv_func_realpath_works=no ;; | ||
| 156 | esac | ||
| 157 | ], | ||
| 125 | [case "$host_os" in | 158 | [case "$host_os" in |
| 126 | # Guess yes on glibc systems. | 159 | # Guess yes on glibc systems. |
| 127 | *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;; | 160 | *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;; |
| 128 | # Guess yes on musl systems. | 161 | # Guess 'nearly' on musl systems. |
| 129 | *-musl*) gl_cv_func_realpath_works="guessing yes" ;; | 162 | *-musl*) gl_cv_func_realpath_works="guessing nearly" ;; |
| 163 | # Guess no on Cygwin. | ||
| 164 | cygwin*) gl_cv_func_realpath_works="guessing no" ;; | ||
| 130 | # Guess no on native Windows. | 165 | # Guess no on native Windows. |
| 131 | mingw*) gl_cv_func_realpath_works="guessing no" ;; | 166 | mingw*) gl_cv_func_realpath_works="guessing no" ;; |
| 132 | # If we don't know, obey --enable-cross-guesses. | 167 | # If we don't know, obey --enable-cross-guesses. |
| 133 | *) gl_cv_func_realpath_works="$gl_cross_guess_normal" ;; | 168 | *) gl_cv_func_realpath_works="$gl_cross_guess_normal" ;; |
| 134 | esac | 169 | esac |
| 135 | ]) | 170 | ]) |
| 136 | rm -rf conftest.a conftest.d | 171 | rm -rf conftest.a conftest.l conftest.d |
| 137 | ]) | 172 | ]) |
| 138 | case "$gl_cv_func_realpath_works" in | 173 | case "$gl_cv_func_realpath_works" in |
| 139 | *yes) | 174 | *yes) |
| 140 | AC_DEFINE([FUNC_REALPATH_WORKS], [1], [Define to 1 if realpath() | 175 | AC_DEFINE([FUNC_REALPATH_WORKS], [1], |
| 141 | can malloc memory, always gives an absolute path, and handles | 176 | [Define to 1 if realpath() can malloc memory, always gives an absolute path, and handles leading slashes and a trailing slash correctly.]) |
| 142 | trailing slash correctly.]) | 177 | ;; |
| 178 | *nearly) | ||
| 179 | AC_DEFINE([FUNC_REALPATH_NEARLY_WORKS], [1], | ||
| 180 | [Define to 1 if realpath() can malloc memory, always gives an absolute path, and handles a trailing slash correctly.]) | ||
| 143 | ;; | 181 | ;; |
| 144 | esac | 182 | esac |
| 145 | ]) | 183 | ]) |
diff --git a/m4/extensions.m4 b/m4/extensions.m4 index f7333acbd4f..5792a9557a8 100644 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | # serial 21 -*- Autoconf -*- | 1 | # serial 22 -*- Autoconf -*- |
| 2 | # Enable extensions on systems that normally disable them. | 2 | # Enable extensions on systems that normally disable them. |
| 3 | 3 | ||
| 4 | # Copyright (C) 2003, 2006-2021 Free Software Foundation, Inc. | 4 | # Copyright (C) 2003, 2006-2021 Free Software Foundation, Inc. |
| @@ -212,4 +212,16 @@ dnl it should only be defined when necessary. | |||
| 212 | AC_DEFUN_ONCE([gl_USE_SYSTEM_EXTENSIONS], | 212 | AC_DEFUN_ONCE([gl_USE_SYSTEM_EXTENSIONS], |
| 213 | [ | 213 | [ |
| 214 | AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) | 214 | AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) |
| 215 | |||
| 216 | dnl On OpenBSD 6.8 with GCC, the include files contain a couple of | ||
| 217 | dnl definitions that are only activated with an explicit -D_ISOC11_SOURCE. | ||
| 218 | dnl That's because this version of GCC (4.2.1) supports the option | ||
| 219 | dnl '-std=gnu99' but not the option '-std=gnu11'. | ||
| 220 | AC_REQUIRE([AC_CANONICAL_HOST]) | ||
| 221 | case "$host_os" in | ||
| 222 | openbsd*) | ||
| 223 | AC_DEFINE([_ISOC11_SOURCE], [1], | ||
| 224 | [Define to enable the declarations of ISO C 11 types and functions.]) | ||
| 225 | ;; | ||
| 226 | esac | ||
| 215 | ]) | 227 | ]) |
diff --git a/m4/fchmodat.m4 b/m4/fchmodat.m4 index 09380327799..66c0e308fcc 100644 --- a/m4/fchmodat.m4 +++ b/m4/fchmodat.m4 | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | # fchmodat.m4 serial 5 | 1 | # fchmodat.m4 serial 6 |
| 2 | dnl Copyright (C) 2004-2021 Free Software Foundation, Inc. | 2 | dnl Copyright (C) 2004-2021 Free Software Foundation, Inc. |
| 3 | dnl This file is free software; the Free Software Foundation | 3 | dnl This file is free software; the Free Software Foundation |
| 4 | dnl gives unlimited permission to copy and/or distribute it, | 4 | dnl gives unlimited permission to copy and/or distribute it, |
| @@ -16,11 +16,9 @@ AC_DEFUN([gl_FUNC_FCHMODAT], | |||
| 16 | HAVE_FCHMODAT=0 | 16 | HAVE_FCHMODAT=0 |
| 17 | else | 17 | else |
| 18 | AC_CACHE_CHECK( | 18 | AC_CACHE_CHECK( |
| 19 | [whether fchmodat+AT_SYMLINK_NOFOLLOW works on non-symlinks], | 19 | [whether fchmodat works], |
| 20 | [gl_cv_func_fchmodat_works], | 20 | [gl_cv_func_fchmodat_works], |
| 21 | [dnl This test fails on GNU/Linux with glibc 2.31 (but not on | 21 | [AC_RUN_IFELSE( |
| 22 | dnl GNU/kFreeBSD nor GNU/Hurd) and Cygwin 2.9. | ||
| 23 | AC_RUN_IFELSE( | ||
| 24 | [AC_LANG_PROGRAM( | 22 | [AC_LANG_PROGRAM( |
| 25 | [ | 23 | [ |
| 26 | AC_INCLUDES_DEFAULT[ | 24 | AC_INCLUDES_DEFAULT[ |
| @@ -44,27 +42,49 @@ AC_DEFUN([gl_FUNC_FCHMODAT], | |||
| 44 | [[ | 42 | [[ |
| 45 | int permissive = S_IRWXU | S_IRWXG | S_IRWXO; | 43 | int permissive = S_IRWXU | S_IRWXG | S_IRWXO; |
| 46 | int desired = S_IRUSR | S_IWUSR; | 44 | int desired = S_IRUSR | S_IWUSR; |
| 47 | static char const f[] = "conftest.fchmodat"; | 45 | int result = 0; |
| 46 | #define file "conftest.fchmodat" | ||
| 48 | struct stat st; | 47 | struct stat st; |
| 49 | if (creat (f, permissive) < 0) | 48 | if (creat (file, permissive) < 0) |
| 50 | return 1; | 49 | return 1; |
| 51 | if (fchmodat (AT_FDCWD, f, desired, AT_SYMLINK_NOFOLLOW) != 0) | 50 | /* Test whether fchmodat rejects a trailing slash on a non-directory. |
| 51 | This test fails on AIX 7.2. */ | ||
| 52 | if (fchmodat (AT_FDCWD, file "/", desired, 0) == 0) | ||
| 53 | result |= 2; | ||
| 54 | /* Test whether fchmodat+AT_SYMLINK_NOFOLLOW works on non-symlinks. | ||
| 55 | This test fails on GNU/Linux with glibc 2.31 (but not on | ||
| 56 | GNU/kFreeBSD nor GNU/Hurd) and Cygwin 2.9. */ | ||
| 57 | if (fchmodat (AT_FDCWD, file, desired, AT_SYMLINK_NOFOLLOW) != 0) | ||
| 58 | result |= 4; | ||
| 59 | if (stat (file, &st) != 0) | ||
| 52 | return 1; | 60 | return 1; |
| 53 | if (stat (f, &st) != 0) | 61 | if ((st.st_mode & permissive) != desired) |
| 54 | return 1; | 62 | result |= 4; |
| 55 | return ! ((st.st_mode & permissive) == desired); | 63 | return result; |
| 56 | ]])], | 64 | ]])], |
| 57 | [gl_cv_func_fchmodat_works=yes], | 65 | [gl_cv_func_fchmodat_works=yes], |
| 58 | [gl_cv_func_fchmodat_works=no], | 66 | [case $? in |
| 67 | 2) gl_cv_func_fchmodat_works='nearly' ;; | ||
| 68 | *) gl_cv_func_fchmodat_works=no ;; | ||
| 69 | esac | ||
| 70 | ], | ||
| 59 | [case "$host_os" in | 71 | [case "$host_os" in |
| 60 | dnl Guess no on Linux with glibc and Cygwin, yes otherwise. | 72 | # Guess no on Linux with glibc and Cygwin. |
| 61 | linux-gnu* | cygwin*) gl_cv_func_fchmodat_works="guessing no" ;; | 73 | linux-gnu* | cygwin*) gl_cv_func_fchmodat_works="guessing no" ;; |
| 74 | # Guess 'nearly' on AIX. | ||
| 75 | aix*) gl_cv_func_fchmodat_works="guessing nearly" ;; | ||
| 76 | # If we don't know, obey --enable-cross-guesses. | ||
| 62 | *) gl_cv_func_fchmodat_works="$gl_cross_guess_normal" ;; | 77 | *) gl_cv_func_fchmodat_works="$gl_cross_guess_normal" ;; |
| 63 | esac | 78 | esac |
| 64 | ]) | 79 | ]) |
| 65 | rm -f conftest.fchmodat]) | 80 | rm -f conftest.fchmodat]) |
| 66 | case $gl_cv_func_fchmodat_works in | 81 | case "$gl_cv_func_fchmodat_works" in |
| 67 | *yes) ;; | 82 | *yes) ;; |
| 83 | *nearly) | ||
| 84 | AC_DEFINE([HAVE_NEARLY_WORKING_FCHMODAT], [1], | ||
| 85 | [Define to 1 if fchmodat works, except for the trailing slash handling.]) | ||
| 86 | REPLACE_FCHMODAT=1 | ||
| 87 | ;; | ||
| 68 | *) | 88 | *) |
| 69 | AC_DEFINE([NEED_FCHMODAT_NONSYMLINK_FIX], [1], | 89 | AC_DEFINE([NEED_FCHMODAT_NONSYMLINK_FIX], [1], |
| 70 | [Define to 1 if fchmodat+AT_SYMLINK_NOFOLLOW does not work right on non-symlinks.]) | 90 | [Define to 1 if fchmodat+AT_SYMLINK_NOFOLLOW does not work right on non-symlinks.]) |
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 535359b2cf6..f2eff10de6d 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 | |||
| @@ -39,11 +39,12 @@ AC_DEFUN([gl_COMMON_BODY], [ | |||
| 39 | this syntax with 'extern'. */ | 39 | this syntax with 'extern'. */ |
| 40 | # define _Noreturn [[noreturn]] | 40 | # define _Noreturn [[noreturn]] |
| 41 | # elif ((!defined __cplusplus || defined __clang__) \ | 41 | # elif ((!defined __cplusplus || defined __clang__) \ |
| 42 | && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ | 42 | && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ |
| 43 | || _GL_GNUC_PREREQ (4, 7) \ | 43 | || (!defined __STRICT_ANSI__ \ |
| 44 | || (defined __apple_build_version__ \ | 44 | && (_GL_GNUC_PREREQ (4, 7) \ |
| 45 | ? 6000000 <= __apple_build_version__ \ | 45 | || (defined __apple_build_version__ \ |
| 46 | : 3 < __clang_major__ + (5 <= __clang_minor__)))) | 46 | ? 6000000 <= __apple_build_version__ \ |
| 47 | : 3 < __clang_major__ + (5 <= __clang_minor__)))))) | ||
| 47 | /* _Noreturn works as-is. */ | 48 | /* _Noreturn works as-is. */ |
| 48 | # elif _GL_GNUC_PREREQ (2, 8) || defined __clang__ || 0x5110 <= __SUNPRO_C | 49 | # elif _GL_GNUC_PREREQ (2, 8) || defined __clang__ || 0x5110 <= __SUNPRO_C |
| 49 | # define _Noreturn __attribute__ ((__noreturn__)) | 50 | # define _Noreturn __attribute__ ((__noreturn__)) |
| @@ -66,7 +67,9 @@ AC_DEFUN([gl_COMMON_BODY], [ | |||
| 66 | #endif]) | 67 | #endif]) |
| 67 | AH_VERBATIM([attribute], | 68 | AH_VERBATIM([attribute], |
| 68 | [/* Attributes. */ | 69 | [/* Attributes. */ |
| 69 | #ifdef __has_attribute | 70 | #if (defined __has_attribute \ |
| 71 | && (!defined __clang_minor__ \ | ||
| 72 | || 3 < __clang_major__ + (5 <= __clang_minor__))) | ||
| 70 | # define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__) | 73 | # define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__) |
| 71 | #else | 74 | #else |
| 72 | # define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr | 75 | # define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr |
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index ad109520dd1..cd6f7b4bbdf 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 | |||
| @@ -75,6 +75,7 @@ AC_DEFUN([gl_EARLY], | |||
| 75 | # Code from module dtoastr: | 75 | # Code from module dtoastr: |
| 76 | # Code from module dtotimespec: | 76 | # Code from module dtotimespec: |
| 77 | # Code from module dup2: | 77 | # Code from module dup2: |
| 78 | # Code from module dynarray: | ||
| 78 | # Code from module eloop-threshold: | 79 | # Code from module eloop-threshold: |
| 79 | # Code from module environ: | 80 | # Code from module environ: |
| 80 | # Code from module errno: | 81 | # Code from module errno: |
| @@ -517,6 +518,7 @@ AC_DEFUN([gl_INIT], | |||
| 517 | gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=false | 518 | gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=false |
| 518 | gl_gnulib_enabled_cloexec=false | 519 | gl_gnulib_enabled_cloexec=false |
| 519 | gl_gnulib_enabled_dirfd=false | 520 | gl_gnulib_enabled_dirfd=false |
| 521 | gl_gnulib_enabled_dynarray=false | ||
| 520 | gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c=false | 522 | gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c=false |
| 521 | gl_gnulib_enabled_euidaccess=false | 523 | gl_gnulib_enabled_euidaccess=false |
| 522 | gl_gnulib_enabled_getdtablesize=false | 524 | gl_gnulib_enabled_getdtablesize=false |
| @@ -564,6 +566,12 @@ AC_DEFUN([gl_INIT], | |||
| 564 | gl_gnulib_enabled_dirfd=true | 566 | gl_gnulib_enabled_dirfd=true |
| 565 | fi | 567 | fi |
| 566 | } | 568 | } |
| 569 | func_gl_gnulib_m4code_dynarray () | ||
| 570 | { | ||
| 571 | if ! $gl_gnulib_enabled_dynarray; then | ||
| 572 | gl_gnulib_enabled_dynarray=true | ||
| 573 | fi | ||
| 574 | } | ||
| 567 | func_gl_gnulib_m4code_925677f0343de64b89a9f0c790b4104c () | 575 | func_gl_gnulib_m4code_925677f0343de64b89a9f0c790b4104c () |
| 568 | { | 576 | { |
| 569 | if ! $gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c; then | 577 | if ! $gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c; then |
| @@ -797,6 +805,9 @@ AC_DEFUN([gl_INIT], | |||
| 797 | if test $HAVE_READLINKAT = 0 || test $REPLACE_READLINKAT = 1; then | 805 | if test $HAVE_READLINKAT = 0 || test $REPLACE_READLINKAT = 1; then |
| 798 | func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 | 806 | func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 |
| 799 | fi | 807 | fi |
| 808 | if test $ac_use_included_regex = yes; then | ||
| 809 | func_gl_gnulib_m4code_dynarray | ||
| 810 | fi | ||
| 800 | if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then | 811 | if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then |
| 801 | func_gl_gnulib_m4code_strtoll | 812 | func_gl_gnulib_m4code_strtoll |
| 802 | fi | 813 | fi |
| @@ -819,6 +830,7 @@ AC_DEFUN([gl_INIT], | |||
| 819 | AM_CONDITIONAL([gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b], [$gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b]) | 830 | AM_CONDITIONAL([gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b], [$gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b]) |
| 820 | AM_CONDITIONAL([gl_GNULIB_ENABLED_cloexec], [$gl_gnulib_enabled_cloexec]) | 831 | AM_CONDITIONAL([gl_GNULIB_ENABLED_cloexec], [$gl_gnulib_enabled_cloexec]) |
| 821 | AM_CONDITIONAL([gl_GNULIB_ENABLED_dirfd], [$gl_gnulib_enabled_dirfd]) | 832 | AM_CONDITIONAL([gl_GNULIB_ENABLED_dirfd], [$gl_gnulib_enabled_dirfd]) |
| 833 | AM_CONDITIONAL([gl_GNULIB_ENABLED_dynarray], [$gl_gnulib_enabled_dynarray]) | ||
| 822 | AM_CONDITIONAL([gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c], [$gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c]) | 834 | AM_CONDITIONAL([gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c], [$gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c]) |
| 823 | AM_CONDITIONAL([gl_GNULIB_ENABLED_euidaccess], [$gl_gnulib_enabled_euidaccess]) | 835 | AM_CONDITIONAL([gl_GNULIB_ENABLED_euidaccess], [$gl_gnulib_enabled_euidaccess]) |
| 824 | AM_CONDITIONAL([gl_GNULIB_ENABLED_getdtablesize], [$gl_gnulib_enabled_getdtablesize]) | 836 | AM_CONDITIONAL([gl_GNULIB_ENABLED_getdtablesize], [$gl_gnulib_enabled_getdtablesize]) |
| @@ -1021,6 +1033,7 @@ AC_DEFUN([gl_FILE_LIST], [ | |||
| 1021 | lib/dtoastr.c | 1033 | lib/dtoastr.c |
| 1022 | lib/dtotimespec.c | 1034 | lib/dtotimespec.c |
| 1023 | lib/dup2.c | 1035 | lib/dup2.c |
| 1036 | lib/dynarray.h | ||
| 1024 | lib/eloop-threshold.h | 1037 | lib/eloop-threshold.h |
| 1025 | lib/errno.in.h | 1038 | lib/errno.in.h |
| 1026 | lib/euidaccess.c | 1039 | lib/euidaccess.c |
| @@ -1076,6 +1089,13 @@ AC_DEFUN([gl_FILE_LIST], [ | |||
| 1076 | lib/libc-config.h | 1089 | lib/libc-config.h |
| 1077 | lib/limits.in.h | 1090 | lib/limits.in.h |
| 1078 | lib/lstat.c | 1091 | lib/lstat.c |
| 1092 | lib/malloc/dynarray-skeleton.c | ||
| 1093 | lib/malloc/dynarray.h | ||
| 1094 | lib/malloc/dynarray_at_failure.c | ||
| 1095 | lib/malloc/dynarray_emplace_enlarge.c | ||
| 1096 | lib/malloc/dynarray_finalize.c | ||
| 1097 | lib/malloc/dynarray_resize.c | ||
| 1098 | lib/malloc/dynarray_resize_clear.c | ||
| 1079 | lib/malloc/scratch_buffer.h | 1099 | lib/malloc/scratch_buffer.h |
| 1080 | lib/malloc/scratch_buffer_dupfree.c | 1100 | lib/malloc/scratch_buffer_dupfree.c |
| 1081 | lib/malloc/scratch_buffer_grow.c | 1101 | lib/malloc/scratch_buffer_grow.c |
diff --git a/m4/nstrftime.m4 b/m4/nstrftime.m4 index 4674442810b..b510554b947 100644 --- a/m4/nstrftime.m4 +++ b/m4/nstrftime.m4 | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | # serial 36 | 1 | # serial 37 |
| 2 | 2 | ||
| 3 | # Copyright (C) 1996-1997, 1999-2007, 2009-2021 Free Software Foundation, Inc. | 3 | # Copyright (C) 1996-1997, 1999-2007, 2009-2021 Free Software Foundation, Inc. |
| 4 | # | 4 | # |
| @@ -12,7 +12,7 @@ AC_DEFUN([gl_FUNC_GNU_STRFTIME], | |||
| 12 | [ | 12 | [ |
| 13 | AC_REQUIRE([AC_C_RESTRICT]) | 13 | AC_REQUIRE([AC_C_RESTRICT]) |
| 14 | 14 | ||
| 15 | # This defines (or not) HAVE_TZNAME and HAVE_TM_ZONE. | 15 | # This defines (or not) HAVE_TZNAME and HAVE_STRUCT_TM_TM_ZONE. |
| 16 | AC_REQUIRE([AC_STRUCT_TIMEZONE]) | 16 | AC_REQUIRE([AC_STRUCT_TIMEZONE]) |
| 17 | 17 | ||
| 18 | AC_REQUIRE([gl_TM_GMTOFF]) | 18 | AC_REQUIRE([gl_TM_GMTOFF]) |
diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4 index 18e872f483e..cd666c4a58c 100644 --- a/m4/stddef_h.m4 +++ b/m4/stddef_h.m4 | |||
| @@ -1,14 +1,19 @@ | |||
| 1 | dnl A placeholder for <stddef.h>, for platforms that have issues. | 1 | # stddef_h.m4 serial 9 |
| 2 | # stddef_h.m4 serial 7 | ||
| 3 | dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. | 2 | dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. |
| 4 | dnl This file is free software; the Free Software Foundation | 3 | dnl This file is free software; the Free Software Foundation |
| 5 | dnl gives unlimited permission to copy and/or distribute it, | 4 | dnl gives unlimited permission to copy and/or distribute it, |
| 6 | dnl with or without modifications, as long as this notice is preserved. | 5 | dnl with or without modifications, as long as this notice is preserved. |
| 7 | 6 | ||
| 7 | dnl A placeholder for <stddef.h>, for platforms that have issues. | ||
| 8 | |||
| 8 | AC_DEFUN([gl_STDDEF_H], | 9 | AC_DEFUN([gl_STDDEF_H], |
| 9 | [ | 10 | [ |
| 10 | AC_REQUIRE([gl_STDDEF_H_DEFAULTS]) | 11 | AC_REQUIRE([gl_STDDEF_H_DEFAULTS]) |
| 11 | AC_REQUIRE([gt_TYPE_WCHAR_T]) | 12 | AC_REQUIRE([gt_TYPE_WCHAR_T]) |
| 13 | |||
| 14 | dnl Persuade OpenBSD <stddef.h> to declare max_align_t. | ||
| 15 | AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) | ||
| 16 | |||
| 12 | STDDEF_H= | 17 | STDDEF_H= |
| 13 | 18 | ||
| 14 | dnl Test whether the type max_align_t exists and whether its alignment | 19 | dnl Test whether the type max_align_t exists and whether its alignment |
| @@ -23,6 +28,13 @@ AC_DEFUN([gl_STDDEF_H], | |||
| 23 | int check1[2 * (__alignof__ (double) <= __alignof__ (max_align_t)) - 1]; | 28 | int check1[2 * (__alignof__ (double) <= __alignof__ (max_align_t)) - 1]; |
| 24 | int check2[2 * (__alignof__ (long double) <= __alignof__ (max_align_t)) - 1]; | 29 | int check2[2 * (__alignof__ (long double) <= __alignof__ (max_align_t)) - 1]; |
| 25 | #endif | 30 | #endif |
| 31 | typedef struct { char a; max_align_t b; } max_helper; | ||
| 32 | typedef struct { char a; long b; } long_helper; | ||
| 33 | typedef struct { char a; double b; } double_helper; | ||
| 34 | typedef struct { char a; long double b; } long_double_helper; | ||
| 35 | int check3[2 * (offsetof (long_helper, b) <= offsetof (max_helper, b)) - 1]; | ||
| 36 | int check4[2 * (offsetof (double_helper, b) <= offsetof (max_helper, b)) - 1]; | ||
| 37 | int check5[2 * (offsetof (long_double_helper, b) <= offsetof (max_helper, b)) - 1]; | ||
| 26 | ]])], | 38 | ]])], |
| 27 | [gl_cv_type_max_align_t=yes], | 39 | [gl_cv_type_max_align_t=yes], |
| 28 | [gl_cv_type_max_align_t=no]) | 40 | [gl_cv_type_max_align_t=no]) |
diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 3e65355735c..a4cc5b43783 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 | |||
| @@ -5,7 +5,7 @@ | |||
| 5 | # gives unlimited permission to copy and/or distribute it, | 5 | # gives unlimited permission to copy and/or distribute it, |
| 6 | # with or without modifications, as long as this notice is preserved. | 6 | # with or without modifications, as long as this notice is preserved. |
| 7 | 7 | ||
| 8 | # serial 28 | 8 | # serial 29 |
| 9 | 9 | ||
| 10 | # Written by Paul Eggert. | 10 | # Written by Paul Eggert. |
| 11 | 11 | ||
| @@ -113,6 +113,7 @@ AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS], | |||
| 113 | HAVE_SIGDESCR_NP=1; AC_SUBST([HAVE_SIGDESCR_NP]) | 113 | HAVE_SIGDESCR_NP=1; AC_SUBST([HAVE_SIGDESCR_NP]) |
| 114 | HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL]) | 114 | HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL]) |
| 115 | HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP]) | 115 | HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP]) |
| 116 | REPLACE_FFSLL=0; AC_SUBST([REPLACE_FFSLL]) | ||
| 116 | REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR]) | 117 | REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR]) |
| 117 | REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM]) | 118 | REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM]) |
| 118 | REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY]) | 119 | REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY]) |
diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4 index e8eac71b466..23cbdd28eb2 100644 --- a/m4/sys_stat_h.m4 +++ b/m4/sys_stat_h.m4 | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | # sys_stat_h.m4 serial 36 -*- Autoconf -*- | 1 | # sys_stat_h.m4 serial 38 -*- Autoconf -*- |
| 2 | dnl Copyright (C) 2006-2021 Free Software Foundation, Inc. | 2 | dnl Copyright (C) 2006-2021 Free Software Foundation, Inc. |
| 3 | dnl This file is free software; the Free Software Foundation | 3 | dnl This file is free software; the Free Software Foundation |
| 4 | dnl gives unlimited permission to copy and/or distribute it, | 4 | dnl gives unlimited permission to copy and/or distribute it, |
| @@ -104,7 +104,9 @@ AC_DEFUN([gl_SYS_STAT_H_DEFAULTS], | |||
| 104 | REPLACE_LSTAT=0; AC_SUBST([REPLACE_LSTAT]) | 104 | REPLACE_LSTAT=0; AC_SUBST([REPLACE_LSTAT]) |
| 105 | REPLACE_MKDIR=0; AC_SUBST([REPLACE_MKDIR]) | 105 | REPLACE_MKDIR=0; AC_SUBST([REPLACE_MKDIR]) |
| 106 | REPLACE_MKFIFO=0; AC_SUBST([REPLACE_MKFIFO]) | 106 | REPLACE_MKFIFO=0; AC_SUBST([REPLACE_MKFIFO]) |
| 107 | REPLACE_MKFIFOAT=0; AC_SUBST([REPLACE_MKFIFOAT]) | ||
| 107 | REPLACE_MKNOD=0; AC_SUBST([REPLACE_MKNOD]) | 108 | REPLACE_MKNOD=0; AC_SUBST([REPLACE_MKNOD]) |
| 109 | REPLACE_MKNODAT=0; AC_SUBST([REPLACE_MKNODAT]) | ||
| 108 | REPLACE_STAT=0; AC_SUBST([REPLACE_STAT]) | 110 | REPLACE_STAT=0; AC_SUBST([REPLACE_STAT]) |
| 109 | REPLACE_UTIMENSAT=0; AC_SUBST([REPLACE_UTIMENSAT]) | 111 | REPLACE_UTIMENSAT=0; AC_SUBST([REPLACE_UTIMENSAT]) |
| 110 | ]) | 112 | ]) |
diff --git a/m4/time_h.m4 b/m4/time_h.m4 index 07e6967e45b..b6a1aa3bc0f 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 | |||
| @@ -2,7 +2,7 @@ | |||
| 2 | 2 | ||
| 3 | # Copyright (C) 2000-2001, 2003-2007, 2009-2021 Free Software Foundation, Inc. | 3 | # Copyright (C) 2000-2001, 2003-2007, 2009-2021 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | # serial 13 | 5 | # serial 15 |
| 6 | 6 | ||
| 7 | # This file is free software; the Free Software Foundation | 7 | # This file is free software; the Free Software Foundation |
| 8 | # gives unlimited permission to copy and/or distribute it, | 8 | # gives unlimited permission to copy and/or distribute it, |
| @@ -25,6 +25,22 @@ AC_DEFUN([gl_HEADER_TIME_H_BODY], | |||
| 25 | AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC]) | 25 | AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC]) |
| 26 | 26 | ||
| 27 | AC_REQUIRE([AC_C_RESTRICT]) | 27 | AC_REQUIRE([AC_C_RESTRICT]) |
| 28 | |||
| 29 | AC_CACHE_CHECK([for TIME_UTC in <time.h>], | ||
| 30 | [gl_cv_time_h_has_TIME_UTC], | ||
| 31 | [AC_COMPILE_IFELSE( | ||
| 32 | [AC_LANG_PROGRAM( | ||
| 33 | [[#include <time.h> | ||
| 34 | ]], | ||
| 35 | [[static int x = TIME_UTC; x++;]])], | ||
| 36 | [gl_cv_time_h_has_TIME_UTC=yes], | ||
| 37 | [gl_cv_time_h_has_TIME_UTC=no])]) | ||
| 38 | if test $gl_cv_time_h_has_TIME_UTC = yes; then | ||
| 39 | TIME_H_DEFINES_TIME_UTC=1 | ||
| 40 | else | ||
| 41 | TIME_H_DEFINES_TIME_UTC=0 | ||
| 42 | fi | ||
| 43 | AC_SUBST([TIME_H_DEFINES_TIME_UTC]) | ||
| 28 | ]) | 44 | ]) |
| 29 | 45 | ||
| 30 | dnl Check whether 'struct timespec' is declared | 46 | dnl Check whether 'struct timespec' is declared |
| @@ -113,6 +129,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS], | |||
| 113 | GNULIB_STRFTIME=0; AC_SUBST([GNULIB_STRFTIME]) | 129 | GNULIB_STRFTIME=0; AC_SUBST([GNULIB_STRFTIME]) |
| 114 | GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME]) | 130 | GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME]) |
| 115 | GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM]) | 131 | GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM]) |
| 132 | GNULIB_TIMESPEC_GET=0; AC_SUBST([GNULIB_TIMESPEC_GET]) | ||
| 116 | GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R]) | 133 | GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R]) |
| 117 | GNULIB_TIME_RZ=0; AC_SUBST([GNULIB_TIME_RZ]) | 134 | GNULIB_TIME_RZ=0; AC_SUBST([GNULIB_TIME_RZ]) |
| 118 | GNULIB_TZSET=0; AC_SUBST([GNULIB_TZSET]) | 135 | GNULIB_TZSET=0; AC_SUBST([GNULIB_TZSET]) |
| @@ -123,6 +140,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS], | |||
| 123 | HAVE_NANOSLEEP=1; AC_SUBST([HAVE_NANOSLEEP]) | 140 | HAVE_NANOSLEEP=1; AC_SUBST([HAVE_NANOSLEEP]) |
| 124 | HAVE_STRPTIME=1; AC_SUBST([HAVE_STRPTIME]) | 141 | HAVE_STRPTIME=1; AC_SUBST([HAVE_STRPTIME]) |
| 125 | HAVE_TIMEGM=1; AC_SUBST([HAVE_TIMEGM]) | 142 | HAVE_TIMEGM=1; AC_SUBST([HAVE_TIMEGM]) |
| 143 | HAVE_TIMESPEC_GET=1; AC_SUBST([HAVE_TIMESPEC_GET]) | ||
| 126 | dnl Even GNU libc does not have timezone_t yet. | 144 | dnl Even GNU libc does not have timezone_t yet. |
| 127 | HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T]) | 145 | HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T]) |
| 128 | dnl If another module says to replace or to not replace, do that. | 146 | dnl If another module says to replace or to not replace, do that. |
diff --git a/m4/utimensat.m4 b/m4/utimensat.m4 index bdabe24c568..b5bff1651f3 100644 --- a/m4/utimensat.m4 +++ b/m4/utimensat.m4 | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | # serial 7 | 1 | # serial 9 |
| 2 | # See if we need to provide utimensat replacement. | 2 | # See if we need to provide utimensat replacement. |
| 3 | 3 | ||
| 4 | dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. | 4 | dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. |
| @@ -12,6 +12,7 @@ AC_DEFUN([gl_FUNC_UTIMENSAT], | |||
| 12 | [ | 12 | [ |
| 13 | AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) | 13 | AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) |
| 14 | AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) | 14 | AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) |
| 15 | AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles | ||
| 15 | AC_CHECK_FUNCS_ONCE([utimensat]) | 16 | AC_CHECK_FUNCS_ONCE([utimensat]) |
| 16 | if test $ac_cv_func_utimensat = no; then | 17 | if test $ac_cv_func_utimensat = no; then |
| 17 | HAVE_UTIMENSAT=0 | 18 | HAVE_UTIMENSAT=0 |
| @@ -28,10 +29,19 @@ AC_DEFUN([gl_FUNC_UTIMENSAT], | |||
| 28 | const char *f = "conftest.file"; | 29 | const char *f = "conftest.file"; |
| 29 | if (close (creat (f, 0600))) | 30 | if (close (creat (f, 0600))) |
| 30 | return 1; | 31 | return 1; |
| 32 | /* Test whether a trailing slash is handled correctly. | ||
| 33 | This fails on AIX 7.2. */ | ||
| 34 | { | ||
| 35 | struct timespec ts[2]; | ||
| 36 | ts[0].tv_sec = 345183300; ts[0].tv_nsec = 0; | ||
| 37 | ts[1] = ts[0]; | ||
| 38 | if (utimensat (AT_FDCWD, "conftest.file/", ts, 0) == 0) | ||
| 39 | result |= 2; | ||
| 40 | } | ||
| 31 | /* Test whether the AT_SYMLINK_NOFOLLOW flag is supported. */ | 41 | /* Test whether the AT_SYMLINK_NOFOLLOW flag is supported. */ |
| 32 | { | 42 | { |
| 33 | if (utimensat (AT_FDCWD, f, NULL, AT_SYMLINK_NOFOLLOW)) | 43 | if (utimensat (AT_FDCWD, f, NULL, AT_SYMLINK_NOFOLLOW)) |
| 34 | result |= 2; | 44 | result |= 4; |
| 35 | } | 45 | } |
| 36 | /* Test whether UTIME_NOW and UTIME_OMIT work. */ | 46 | /* Test whether UTIME_NOW and UTIME_OMIT work. */ |
| 37 | { | 47 | { |
| @@ -41,7 +51,7 @@ AC_DEFUN([gl_FUNC_UTIMENSAT], | |||
| 41 | ts[1].tv_sec = 1; | 51 | ts[1].tv_sec = 1; |
| 42 | ts[1].tv_nsec = UTIME_NOW; | 52 | ts[1].tv_nsec = UTIME_NOW; |
| 43 | if (utimensat (AT_FDCWD, f, ts, 0)) | 53 | if (utimensat (AT_FDCWD, f, ts, 0)) |
| 44 | result |= 4; | 54 | result |= 8; |
| 45 | } | 55 | } |
| 46 | sleep (1); | 56 | sleep (1); |
| 47 | { | 57 | { |
| @@ -52,19 +62,44 @@ AC_DEFUN([gl_FUNC_UTIMENSAT], | |||
| 52 | ts[1].tv_sec = 1; | 62 | ts[1].tv_sec = 1; |
| 53 | ts[1].tv_nsec = UTIME_OMIT; | 63 | ts[1].tv_nsec = UTIME_OMIT; |
| 54 | if (utimensat (AT_FDCWD, f, ts, 0)) | 64 | if (utimensat (AT_FDCWD, f, ts, 0)) |
| 55 | result |= 8; | ||
| 56 | if (stat (f, &st)) | ||
| 57 | result |= 16; | 65 | result |= 16; |
| 58 | else if (st.st_ctime < st.st_atime) | 66 | if (stat (f, &st)) |
| 59 | result |= 32; | 67 | result |= 32; |
| 68 | else if (st.st_ctime < st.st_atime) | ||
| 69 | result |= 64; | ||
| 60 | } | 70 | } |
| 61 | return result; | 71 | return result; |
| 62 | ]])], | 72 | ]])], |
| 63 | [gl_cv_func_utimensat_works=yes], | 73 | [gl_cv_func_utimensat_works=yes], |
| 64 | [gl_cv_func_utimensat_works=no], | 74 | [case $? in |
| 65 | [gl_cv_func_utimensat_works="guessing yes"])]) | 75 | 2) gl_cv_func_utimensat_works='nearly' ;; |
| 66 | if test "$gl_cv_func_utimensat_works" = no; then | 76 | *) gl_cv_func_utimensat_works=no ;; |
| 67 | REPLACE_UTIMENSAT=1 | 77 | esac |
| 68 | fi | 78 | ], |
| 79 | [case "$host_os" in | ||
| 80 | # Guess yes on Linux or glibc systems. | ||
| 81 | linux-* | linux | *-gnu* | gnu*) | ||
| 82 | gl_cv_func_utimensat_works="guessing yes" ;; | ||
| 83 | # Guess 'nearly' on AIX. | ||
| 84 | aix*) | ||
| 85 | gl_cv_func_utimensat_works="guessing nearly" ;; | ||
| 86 | # If we don't know, obey --enable-cross-guesses. | ||
| 87 | *) | ||
| 88 | gl_cv_func_utimensat_works="$gl_cross_guess_normal" ;; | ||
| 89 | esac | ||
| 90 | ]) | ||
| 91 | ]) | ||
| 92 | case "$gl_cv_func_utimensat_works" in | ||
| 93 | *yes) | ||
| 94 | ;; | ||
| 95 | *nearly) | ||
| 96 | AC_DEFINE([HAVE_NEARLY_WORKING_UTIMENSAT], [1], | ||
| 97 | [Define to 1 if utimensat works, except for the trailing slash handling.]) | ||
| 98 | REPLACE_UTIMENSAT=1 | ||
| 99 | ;; | ||
| 100 | *) | ||
| 101 | REPLACE_UTIMENSAT=1 | ||
| 102 | ;; | ||
| 103 | esac | ||
| 69 | fi | 104 | fi |
| 70 | ]) | 105 | ]) |
diff --git a/src/alloc.c b/src/alloc.c index 350fec25a02..0ed5b9346f6 100644 --- a/src/alloc.c +++ b/src/alloc.c | |||
| @@ -6122,11 +6122,13 @@ garbage_collect (void) | |||
| 6122 | 6122 | ||
| 6123 | gc_in_progress = 0; | 6123 | gc_in_progress = 0; |
| 6124 | 6124 | ||
| 6125 | unblock_input (); | ||
| 6126 | |||
| 6127 | consing_until_gc = gc_threshold | 6125 | consing_until_gc = gc_threshold |
| 6128 | = consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0); | 6126 | = consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0); |
| 6129 | 6127 | ||
| 6128 | /* Unblock *after* re-setting `consing_until_gc` in case `unblock_input` | ||
| 6129 | signals an error (see bug#43389). */ | ||
| 6130 | unblock_input (); | ||
| 6131 | |||
| 6130 | if (garbage_collection_messages && NILP (Vmemory_full)) | 6132 | if (garbage_collection_messages && NILP (Vmemory_full)) |
| 6131 | { | 6133 | { |
| 6132 | if (message_p || minibuf_level > 0) | 6134 | if (message_p || minibuf_level > 0) |
diff --git a/src/conf_post.h b/src/conf_post.h index bd56f29e287..176ab28b21a 100644 --- a/src/conf_post.h +++ b/src/conf_post.h | |||
| @@ -71,7 +71,9 @@ typedef bool bool_bf; | |||
| 71 | It is used only on arguments like cleanup that are handled here. | 71 | It is used only on arguments like cleanup that are handled here. |
| 72 | This macro should be used only in #if expressions, as Oracle | 72 | This macro should be used only in #if expressions, as Oracle |
| 73 | Studio 12.5's __has_attribute does not work in plain code. */ | 73 | Studio 12.5's __has_attribute does not work in plain code. */ |
| 74 | #ifdef __has_attribute | 74 | #if (defined __has_attribute \ |
| 75 | && (!defined __clang_minor__ \ | ||
| 76 | || 3 < __clang_major__ + (5 <= __clang_minor__))) | ||
| 75 | # define HAS_ATTRIBUTE(a) __has_attribute (__##a##__) | 77 | # define HAS_ATTRIBUTE(a) __has_attribute (__##a##__) |
| 76 | #else | 78 | #else |
| 77 | # define HAS_ATTRIBUTE(a) HAS_ATTR_##a | 79 | # define HAS_ATTRIBUTE(a) HAS_ATTR_##a |
diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in index 2989b439109..fe52587c1a5 100644 --- a/src/emacs-module.h.in +++ b/src/emacs-module.h.in | |||
| @@ -51,7 +51,9 @@ information how to write modules and use this header file. | |||
| 51 | #if 3 < __GNUC__ + (3 <= __GNUC_MINOR__) | 51 | #if 3 < __GNUC__ + (3 <= __GNUC_MINOR__) |
| 52 | # define EMACS_ATTRIBUTE_NONNULL(...) \ | 52 | # define EMACS_ATTRIBUTE_NONNULL(...) \ |
| 53 | __attribute__ ((__nonnull__ (__VA_ARGS__))) | 53 | __attribute__ ((__nonnull__ (__VA_ARGS__))) |
| 54 | #elif defined __has_attribute | 54 | #elif (defined __has_attribute \ |
| 55 | && (!defined __clang_minor__ \ | ||
| 56 | || 3 < __clang_major__ + (5 <= __clang_minor__))) | ||
| 55 | # if __has_attribute (__nonnull__) | 57 | # if __has_attribute (__nonnull__) |
| 56 | # define EMACS_ATTRIBUTE_NONNULL(...) \ | 58 | # define EMACS_ATTRIBUTE_NONNULL(...) \ |
| 57 | __attribute__ ((__nonnull__ (__VA_ARGS__))) | 59 | __attribute__ ((__nonnull__ (__VA_ARGS__))) |
diff --git a/src/frame.c b/src/frame.c index 45ee96e9620..599c4075f88 100644 --- a/src/frame.c +++ b/src/frame.c | |||
| @@ -2572,23 +2572,30 @@ before calling this function on it, like this. | |||
| 2572 | int yval = check_integer_range (y, INT_MIN, INT_MAX); | 2572 | int yval = check_integer_range (y, INT_MIN, INT_MAX); |
| 2573 | 2573 | ||
| 2574 | /* I think this should be done with a hook. */ | 2574 | /* I think this should be done with a hook. */ |
| 2575 | #ifdef HAVE_WINDOW_SYSTEM | ||
| 2576 | if (FRAME_WINDOW_P (XFRAME (frame))) | 2575 | if (FRAME_WINDOW_P (XFRAME (frame))) |
| 2577 | /* Warping the mouse will cause enternotify and focus events. */ | 2576 | { |
| 2578 | frame_set_mouse_position (XFRAME (frame), xval, yval); | 2577 | #ifdef HAVE_WINDOW_SYSTEM |
| 2579 | #elif defined MSDOS | 2578 | /* Warping the mouse will cause enternotify and focus events. */ |
| 2580 | if (FRAME_MSDOS_P (XFRAME (frame))) | 2579 | frame_set_mouse_position (XFRAME (frame), xval, yval); |
| 2580 | #endif /* HAVE_WINDOW_SYSTEM */ | ||
| 2581 | } | ||
| 2582 | #ifdef MSDOS | ||
| 2583 | else if (FRAME_MSDOS_P (XFRAME (frame))) | ||
| 2581 | { | 2584 | { |
| 2582 | Fselect_frame (frame, Qnil); | 2585 | Fselect_frame (frame, Qnil); |
| 2583 | mouse_moveto (xval, yval); | 2586 | mouse_moveto (xval, yval); |
| 2584 | } | 2587 | } |
| 2585 | #elif defined HAVE_GPM | 2588 | #endif /* MSDOS */ |
| 2586 | Fselect_frame (frame, Qnil); | 2589 | else |
| 2587 | term_mouse_moveto (xval, yval); | 2590 | { |
| 2591 | Fselect_frame (frame, Qnil); | ||
| 2592 | #ifdef HAVE_GPM | ||
| 2593 | term_mouse_moveto (xval, yval); | ||
| 2588 | #else | 2594 | #else |
| 2589 | (void) xval; | 2595 | (void) xval; |
| 2590 | (void) yval; | 2596 | (void) yval; |
| 2591 | #endif | 2597 | #endif /* HAVE_GPM */ |
| 2598 | } | ||
| 2592 | 2599 | ||
| 2593 | return Qnil; | 2600 | return Qnil; |
| 2594 | } | 2601 | } |
| @@ -2610,23 +2617,31 @@ before calling this function on it, like this. | |||
| 2610 | int yval = check_integer_range (y, INT_MIN, INT_MAX); | 2617 | int yval = check_integer_range (y, INT_MIN, INT_MAX); |
| 2611 | 2618 | ||
| 2612 | /* I think this should be done with a hook. */ | 2619 | /* I think this should be done with a hook. */ |
| 2613 | #ifdef HAVE_WINDOW_SYSTEM | ||
| 2614 | if (FRAME_WINDOW_P (XFRAME (frame))) | 2620 | if (FRAME_WINDOW_P (XFRAME (frame))) |
| 2615 | /* Warping the mouse will cause enternotify and focus events. */ | 2621 | { |
| 2616 | frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); | 2622 | /* Warping the mouse will cause enternotify and focus events. */ |
| 2617 | #elif defined MSDOS | 2623 | #ifdef HAVE_WINDOW_SYSTEM |
| 2618 | if (FRAME_MSDOS_P (XFRAME (frame))) | 2624 | frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); |
| 2625 | #endif /* HAVE_WINDOW_SYSTEM */ | ||
| 2626 | } | ||
| 2627 | #ifdef MSDOS | ||
| 2628 | else if (FRAME_MSDOS_P (XFRAME (frame))) | ||
| 2619 | { | 2629 | { |
| 2620 | Fselect_frame (frame, Qnil); | 2630 | Fselect_frame (frame, Qnil); |
| 2621 | mouse_moveto (xval, yval); | 2631 | mouse_moveto (xval, yval); |
| 2622 | } | 2632 | } |
| 2623 | #elif defined HAVE_GPM | 2633 | #endif /* MSDOS */ |
| 2624 | Fselect_frame (frame, Qnil); | 2634 | else |
| 2625 | term_mouse_moveto (xval, yval); | 2635 | { |
| 2636 | Fselect_frame (frame, Qnil); | ||
| 2637 | #ifdef HAVE_GPM | ||
| 2638 | term_mouse_moveto (xval, yval); | ||
| 2626 | #else | 2639 | #else |
| 2627 | (void) xval; | 2640 | (void) xval; |
| 2628 | (void) yval; | 2641 | (void) yval; |
| 2629 | #endif | 2642 | #endif /* HAVE_GPM */ |
| 2643 | |||
| 2644 | } | ||
| 2630 | 2645 | ||
| 2631 | return Qnil; | 2646 | return Qnil; |
| 2632 | } | 2647 | } |
diff --git a/src/nsfns.m b/src/nsfns.m index ae114f83e4d..24ea7d7f63b 100644 --- a/src/nsfns.m +++ b/src/nsfns.m | |||
| @@ -1487,7 +1487,6 @@ Some window managers may refuse to restack windows. */) | |||
| 1487 | { | 1487 | { |
| 1488 | EmacsWindow *window = (EmacsWindow *)[FRAME_NS_VIEW (f1) window]; | 1488 | EmacsWindow *window = (EmacsWindow *)[FRAME_NS_VIEW (f1) window]; |
| 1489 | NSWindow *window2 = [FRAME_NS_VIEW (f2) window]; | 1489 | NSWindow *window2 = [FRAME_NS_VIEW (f2) window]; |
| 1490 | BOOL flag = !NILP (above); | ||
| 1491 | 1490 | ||
| 1492 | if ([window restackWindow:window2 above:!NILP (above)]) | 1491 | if ([window restackWindow:window2 above:!NILP (above)]) |
| 1493 | return Qt; | 1492 | return Qt; |
diff --git a/src/nsmenu.m b/src/nsmenu.m index 8086f56854e..f8219d27026 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m | |||
| @@ -101,7 +101,6 @@ popup_activated (void) | |||
| 101 | static void | 101 | static void |
| 102 | ns_update_menubar (struct frame *f, bool deep_p) | 102 | ns_update_menubar (struct frame *f, bool deep_p) |
| 103 | { | 103 | { |
| 104 | NSAutoreleasePool *pool; | ||
| 105 | BOOL needsSet = NO; | 104 | BOOL needsSet = NO; |
| 106 | id menu = [NSApp mainMenu]; | 105 | id menu = [NSApp mainMenu]; |
| 107 | bool owfi; | 106 | bool owfi; |
diff --git a/src/nsselect.m b/src/nsselect.m index 27db9248e46..5ab3ef77fec 100644 --- a/src/nsselect.m +++ b/src/nsselect.m | |||
| @@ -78,7 +78,13 @@ ns_string_to_symbol (NSString *t) | |||
| 78 | return QSECONDARY; | 78 | return QSECONDARY; |
| 79 | if ([t isEqualToString: NSPasteboardTypeString]) | 79 | if ([t isEqualToString: NSPasteboardTypeString]) |
| 80 | return QTEXT; | 80 | return QTEXT; |
| 81 | if ([t isEqualToString: NSFilenamesPboardType]) | 81 | if ([t isEqualToString: |
| 82 | #if NS_USE_NSPasteboardTypeFileURL != 0 | ||
| 83 | NSPasteboardTypeFileURL | ||
| 84 | #else | ||
| 85 | NSFilenamesPboardType | ||
| 86 | #endif | ||
| 87 | ]) | ||
| 82 | return QFILE_NAME; | 88 | return QFILE_NAME; |
| 83 | if ([t isEqualToString: NSPasteboardTypeTabularText]) | 89 | if ([t isEqualToString: NSPasteboardTypeTabularText]) |
| 84 | return QTEXT; | 90 | return QTEXT; |
| @@ -467,7 +473,12 @@ nxatoms_of_nsselect (void) | |||
| 467 | [NSNumber numberWithLong:0], NXPrimaryPboard, | 473 | [NSNumber numberWithLong:0], NXPrimaryPboard, |
| 468 | [NSNumber numberWithLong:0], NXSecondaryPboard, | 474 | [NSNumber numberWithLong:0], NXSecondaryPboard, |
| 469 | [NSNumber numberWithLong:0], NSPasteboardTypeString, | 475 | [NSNumber numberWithLong:0], NSPasteboardTypeString, |
| 470 | [NSNumber numberWithLong:0], NSFilenamesPboardType, | 476 | [NSNumber numberWithLong:0], |
| 477 | #if NS_USE_NSPasteboardTypeFileURL != 0 | ||
| 478 | NSPasteboardTypeFileURL, | ||
| 479 | #else | ||
| 480 | NSFilenamesPboardType, | ||
| 481 | #endif | ||
| 471 | [NSNumber numberWithLong:0], NSPasteboardTypeTabularText, | 482 | [NSNumber numberWithLong:0], NSPasteboardTypeTabularText, |
| 472 | nil] retain]; | 483 | nil] retain]; |
| 473 | } | 484 | } |
diff --git a/src/nsterm.h b/src/nsterm.h index 2c9d8e85ba9..eae1d0725ea 100644 --- a/src/nsterm.h +++ b/src/nsterm.h | |||
| @@ -39,6 +39,15 @@ typedef CGFloat EmacsCGFloat; | |||
| 39 | typedef float EmacsCGFloat; | 39 | typedef float EmacsCGFloat; |
| 40 | #endif | 40 | #endif |
| 41 | 41 | ||
| 42 | /* NSFilenamesPboardType is deprecated in macOS 10.14, but | ||
| 43 | NSPasteboardTypeFileURL is only available in 10.13 (and GNUstep | ||
| 44 | probably lacks it too). */ | ||
| 45 | #if defined NS_IMPL_COCOA && MAC_OS_X_VERSION_MIN_REQUIRED >= 101300 | ||
| 46 | #define NS_USE_NSPasteboardTypeFileURL 1 | ||
| 47 | #else | ||
| 48 | #define NS_USE_NSPasteboardTypeFileURL 0 | ||
| 49 | #endif | ||
| 50 | |||
| 42 | /* ========================================================================== | 51 | /* ========================================================================== |
| 43 | 52 | ||
| 44 | Trace support | 53 | Trace support |
diff --git a/src/nsterm.m b/src/nsterm.m index 2defb9e2eec..df3934c5c34 100644 --- a/src/nsterm.m +++ b/src/nsterm.m | |||
| @@ -272,7 +272,9 @@ long context_menu_value = 0; | |||
| 272 | 272 | ||
| 273 | /* display update */ | 273 | /* display update */ |
| 274 | static struct frame *ns_updating_frame; | 274 | static struct frame *ns_updating_frame; |
| 275 | #if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 | ||
| 275 | static NSView *focus_view = NULL; | 276 | static NSView *focus_view = NULL; |
| 277 | #endif | ||
| 276 | static int ns_window_num = 0; | 278 | static int ns_window_num = 0; |
| 277 | static BOOL gsaved = NO; | 279 | static BOOL gsaved = NO; |
| 278 | static BOOL ns_fake_keydown = NO; | 280 | static BOOL ns_fake_keydown = NO; |
| @@ -1139,7 +1141,9 @@ ns_update_end (struct frame *f) | |||
| 1139 | external (RIF) call; for whole frame, called after gui_update_window_end | 1141 | external (RIF) call; for whole frame, called after gui_update_window_end |
| 1140 | -------------------------------------------------------------------------- */ | 1142 | -------------------------------------------------------------------------- */ |
| 1141 | { | 1143 | { |
| 1144 | #if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 | ||
| 1142 | EmacsView *view = FRAME_NS_VIEW (f); | 1145 | EmacsView *view = FRAME_NS_VIEW (f); |
| 1146 | #endif | ||
| 1143 | 1147 | ||
| 1144 | NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_end"); | 1148 | NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_end"); |
| 1145 | 1149 | ||
| @@ -1449,7 +1453,7 @@ ns_ring_bell (struct frame *f) | |||
| 1449 | } | 1453 | } |
| 1450 | } | 1454 | } |
| 1451 | 1455 | ||
| 1452 | 1456 | #if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 | |
| 1453 | static void | 1457 | static void |
| 1454 | hide_bell (void) | 1458 | hide_bell (void) |
| 1455 | /* -------------------------------------------------------------------------- | 1459 | /* -------------------------------------------------------------------------- |
| @@ -1463,6 +1467,7 @@ hide_bell (void) | |||
| 1463 | [bell_view remove]; | 1467 | [bell_view remove]; |
| 1464 | } | 1468 | } |
| 1465 | } | 1469 | } |
| 1470 | #endif | ||
| 1466 | 1471 | ||
| 1467 | 1472 | ||
| 1468 | /* ========================================================================== | 1473 | /* ========================================================================== |
| @@ -2876,6 +2881,8 @@ ns_get_shifted_character (NSEvent *event) | |||
| 2876 | ========================================================================== */ | 2881 | ========================================================================== */ |
| 2877 | 2882 | ||
| 2878 | 2883 | ||
| 2884 | #if 0 | ||
| 2885 | /* FIXME: Remove this function. */ | ||
| 2879 | static void | 2886 | static void |
| 2880 | ns_redraw_scroll_bars (struct frame *f) | 2887 | ns_redraw_scroll_bars (struct frame *f) |
| 2881 | { | 2888 | { |
| @@ -2890,6 +2897,7 @@ ns_redraw_scroll_bars (struct frame *f) | |||
| 2890 | [view display]; | 2897 | [view display]; |
| 2891 | } | 2898 | } |
| 2892 | } | 2899 | } |
| 2900 | #endif | ||
| 2893 | 2901 | ||
| 2894 | 2902 | ||
| 2895 | void | 2903 | void |
| @@ -5602,7 +5610,11 @@ ns_term_init (Lisp_Object display_name) | |||
| 5602 | ns_drag_types = [[NSArray arrayWithObjects: | 5610 | ns_drag_types = [[NSArray arrayWithObjects: |
| 5603 | NSPasteboardTypeString, | 5611 | NSPasteboardTypeString, |
| 5604 | NSPasteboardTypeTabularText, | 5612 | NSPasteboardTypeTabularText, |
| 5613 | #if NS_USE_NSPasteboardTypeFileURL != 0 | ||
| 5614 | NSPasteboardTypeFileURL, | ||
| 5615 | #else | ||
| 5605 | NSFilenamesPboardType, | 5616 | NSFilenamesPboardType, |
| 5617 | #endif | ||
| 5606 | NSPasteboardTypeURL, nil] retain]; | 5618 | NSPasteboardTypeURL, nil] retain]; |
| 5607 | 5619 | ||
| 5608 | /* If fullscreen is in init/default-frame-alist, focus isn't set | 5620 | /* If fullscreen is in init/default-frame-alist, focus isn't set |
| @@ -8395,21 +8407,23 @@ not_in_argv (NSString *arg) | |||
| 8395 | void *pixels = CGBitmapContextGetData (context); | 8407 | void *pixels = CGBitmapContextGetData (context); |
| 8396 | int rowSize = CGBitmapContextGetBytesPerRow (context); | 8408 | int rowSize = CGBitmapContextGetBytesPerRow (context); |
| 8397 | int srcRowSize = NSWidth (srcRect) * scale * bpp; | 8409 | int srcRowSize = NSWidth (srcRect) * scale * bpp; |
| 8398 | void *srcPixels = pixels + (int)(NSMinY (srcRect) * scale * rowSize | 8410 | void *srcPixels = (char *) pixels |
| 8399 | + NSMinX (srcRect) * scale * bpp); | 8411 | + (int) (NSMinY (srcRect) * scale * rowSize |
| 8400 | void *dstPixels = pixels + (int)(NSMinY (dstRect) * scale * rowSize | 8412 | + NSMinX (srcRect) * scale * bpp); |
| 8401 | + NSMinX (dstRect) * scale * bpp); | 8413 | void *dstPixels = (char *) pixels |
| 8414 | + (int) (NSMinY (dstRect) * scale * rowSize | ||
| 8415 | + NSMinX (dstRect) * scale * bpp); | ||
| 8402 | 8416 | ||
| 8403 | if (NSIntersectsRect (srcRect, dstRect) | 8417 | if (NSIntersectsRect (srcRect, dstRect) |
| 8404 | && NSMinY (srcRect) < NSMinY (dstRect)) | 8418 | && NSMinY (srcRect) < NSMinY (dstRect)) |
| 8405 | for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--) | 8419 | for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--) |
| 8406 | memmove (dstPixels + y * rowSize, | 8420 | memmove ((char *) dstPixels + y * rowSize, |
| 8407 | srcPixels + y * rowSize, | 8421 | (char *) srcPixels + y * rowSize, |
| 8408 | srcRowSize); | 8422 | srcRowSize); |
| 8409 | else | 8423 | else |
| 8410 | for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++) | 8424 | for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++) |
| 8411 | memmove (dstPixels + y * rowSize, | 8425 | memmove ((char *) dstPixels + y * rowSize, |
| 8412 | srcPixels + y * rowSize, | 8426 | (char *) srcPixels + y * rowSize, |
| 8413 | srcRowSize); | 8427 | srcRowSize); |
| 8414 | 8428 | ||
| 8415 | #if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 | 8429 | #if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 |
| @@ -8533,9 +8547,19 @@ not_in_argv (NSString *arg) | |||
| 8533 | { | 8547 | { |
| 8534 | return NO; | 8548 | return NO; |
| 8535 | } | 8549 | } |
| 8536 | /* FIXME: NSFilenamesPboardType is deprecated in 10.14, but the | 8550 | #if NS_USE_NSPasteboardTypeFileURL != 0 |
| 8537 | NSURL method can only handle one file at a time. Stick with the | 8551 | else if ([type isEqualToString: NSPasteboardTypeFileURL]) |
| 8538 | existing code at the moment. */ | 8552 | { |
| 8553 | type_sym = Qfile; | ||
| 8554 | |||
| 8555 | NSArray *urls = [pb readObjectsForClasses: @[[NSURL self]] | ||
| 8556 | options: nil]; | ||
| 8557 | NSEnumerator *uenum = [urls objectEnumerator]; | ||
| 8558 | NSURL *url; | ||
| 8559 | while ((url = [uenum nextObject])) | ||
| 8560 | strings = Fcons ([[url path] lispString], strings); | ||
| 8561 | } | ||
| 8562 | #else // !NS_USE_NSPasteboardTypeFileURL | ||
| 8539 | else if ([type isEqualToString: NSFilenamesPboardType]) | 8563 | else if ([type isEqualToString: NSFilenamesPboardType]) |
| 8540 | { | 8564 | { |
| 8541 | NSArray *files; | 8565 | NSArray *files; |
| @@ -8551,6 +8575,7 @@ not_in_argv (NSString *arg) | |||
| 8551 | while ( (file = [fenum nextObject]) ) | 8575 | while ( (file = [fenum nextObject]) ) |
| 8552 | strings = Fcons ([file lispString], strings); | 8576 | strings = Fcons ([file lispString], strings); |
| 8553 | } | 8577 | } |
| 8578 | #endif // !NS_USE_NSPasteboardTypeFileURL | ||
| 8554 | else if ([type isEqualToString: NSPasteboardTypeURL]) | 8579 | else if ([type isEqualToString: NSPasteboardTypeURL]) |
| 8555 | { | 8580 | { |
| 8556 | NSURL *url = [NSURL URLFromPasteboard: pb]; | 8581 | NSURL *url = [NSURL URLFromPasteboard: pb]; |
| @@ -8727,7 +8752,8 @@ not_in_argv (NSString *arg) | |||
| 8727 | /* The array returned by [NSWindow parentWindow] may already be | 8752 | /* The array returned by [NSWindow parentWindow] may already be |
| 8728 | sorted, but the documentation doesn't tell us whether or not it is, | 8753 | sorted, but the documentation doesn't tell us whether or not it is, |
| 8729 | so to be safe we'll sort it. */ | 8754 | so to be safe we'll sort it. */ |
| 8730 | NSInteger nswindow_orderedIndex_sort (id w1, id w2, void *c) | 8755 | static NSInteger |
| 8756 | nswindow_orderedIndex_sort (id w1, id w2, void *c) | ||
| 8731 | { | 8757 | { |
| 8732 | NSInteger i1 = [w1 orderedIndex]; | 8758 | NSInteger i1 = [w1 orderedIndex]; |
| 8733 | NSInteger i2 = [w2 orderedIndex]; | 8759 | NSInteger i2 = [w2 orderedIndex]; |
diff --git a/src/process.c b/src/process.c index dac7d0440fa..1df4ed9ce03 100644 --- a/src/process.c +++ b/src/process.c | |||
| @@ -283,6 +283,18 @@ static int max_desc; | |||
| 283 | the file descriptor of a socket that is already bound. */ | 283 | the file descriptor of a socket that is already bound. */ |
| 284 | static int external_sock_fd; | 284 | static int external_sock_fd; |
| 285 | 285 | ||
| 286 | /* File descriptor that becomes readable when we receive SIGCHLD. */ | ||
| 287 | static int child_signal_read_fd = -1; | ||
| 288 | /* The write end thereof. The SIGCHLD handler writes to this file | ||
| 289 | descriptor to notify `wait_reading_process_output' of process | ||
| 290 | status changes. */ | ||
| 291 | static int child_signal_write_fd = -1; | ||
| 292 | static void child_signal_init (void); | ||
| 293 | #ifndef WINDOWSNT | ||
| 294 | static void child_signal_read (int, void *); | ||
| 295 | #endif | ||
| 296 | static void child_signal_notify (void); | ||
| 297 | |||
| 286 | /* Indexed by descriptor, gives the process (if any) for that descriptor. */ | 298 | /* Indexed by descriptor, gives the process (if any) for that descriptor. */ |
| 287 | static Lisp_Object chan_process[FD_SETSIZE]; | 299 | static Lisp_Object chan_process[FD_SETSIZE]; |
| 288 | static void wait_for_socket_fds (Lisp_Object, char const *); | 300 | static void wait_for_socket_fds (Lisp_Object, char const *); |
| @@ -2060,6 +2072,10 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) | |||
| 2060 | Lisp_Object lisp_pty_name = Qnil; | 2072 | Lisp_Object lisp_pty_name = Qnil; |
| 2061 | sigset_t oldset; | 2073 | sigset_t oldset; |
| 2062 | 2074 | ||
| 2075 | /* Ensure that the SIGCHLD handler can notify | ||
| 2076 | `wait_reading_process_output'. */ | ||
| 2077 | child_signal_init (); | ||
| 2078 | |||
| 2063 | inchannel = outchannel = -1; | 2079 | inchannel = outchannel = -1; |
| 2064 | 2080 | ||
| 2065 | if (p->pty_flag) | 2081 | if (p->pty_flag) |
| @@ -5309,6 +5325,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, | |||
| 5309 | compute_input_wait_mask (&Atemp); | 5325 | compute_input_wait_mask (&Atemp); |
| 5310 | compute_write_mask (&Ctemp); | 5326 | compute_write_mask (&Ctemp); |
| 5311 | 5327 | ||
| 5328 | /* If a process status has changed, the child signal pipe | ||
| 5329 | will likely be readable. We want to ignore it for now, | ||
| 5330 | because otherwise we wouldn't run into a timeout | ||
| 5331 | below. */ | ||
| 5332 | int fd = child_signal_read_fd; | ||
| 5333 | eassert (fd < FD_SETSIZE); | ||
| 5334 | if (0 <= fd) | ||
| 5335 | FD_CLR (fd, &Atemp); | ||
| 5336 | |||
| 5312 | timeout = make_timespec (0, 0); | 5337 | timeout = make_timespec (0, 0); |
| 5313 | if ((thread_select (pselect, max_desc + 1, | 5338 | if ((thread_select (pselect, max_desc + 1, |
| 5314 | &Atemp, | 5339 | &Atemp, |
| @@ -5395,6 +5420,14 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, | |||
| 5395 | check_write = true; | 5420 | check_write = true; |
| 5396 | } | 5421 | } |
| 5397 | 5422 | ||
| 5423 | /* We have to be informed when we receive a SIGCHLD signal for | ||
| 5424 | an asynchronous process. Otherwise this might deadlock if we | ||
| 5425 | receive a SIGCHLD during `pselect'. */ | ||
| 5426 | int child_fd = child_signal_read_fd; | ||
| 5427 | eassert (child_fd < FD_SETSIZE); | ||
| 5428 | if (0 <= child_fd) | ||
| 5429 | FD_SET (child_fd, &Available); | ||
| 5430 | |||
| 5398 | /* If frame size has changed or the window is newly mapped, | 5431 | /* If frame size has changed or the window is newly mapped, |
| 5399 | redisplay now, before we start to wait. There is a race | 5432 | redisplay now, before we start to wait. There is a race |
| 5400 | condition here; if a SIGIO arrives between now and the select | 5433 | condition here; if a SIGIO arrives between now and the select |
| @@ -7114,7 +7147,95 @@ process has been transmitted to the serial port. */) | |||
| 7114 | subprocesses which the main thread should not reap. For example, | 7147 | subprocesses which the main thread should not reap. For example, |
| 7115 | if the main thread attempted to reap an already-reaped child, it | 7148 | if the main thread attempted to reap an already-reaped child, it |
| 7116 | might inadvertently reap a GTK-created process that happened to | 7149 | might inadvertently reap a GTK-created process that happened to |
| 7117 | have the same process ID. */ | 7150 | have the same process ID. |
| 7151 | |||
| 7152 | To avoid a deadlock when receiving SIGCHLD while | ||
| 7153 | 'wait_reading_process_output' is in 'pselect', the SIGCHLD handler | ||
| 7154 | will notify the `pselect' using a self-pipe. The deadlock could | ||
| 7155 | occur if SIGCHLD is delivered outside of the 'pselect' call, in | ||
| 7156 | which case 'pselect' will not be interrupted by the signal, and | ||
| 7157 | will therefore wait on the process's output descriptor for the | ||
| 7158 | output that will never come. | ||
| 7159 | |||
| 7160 | WINDOWSNT doesn't need this facility because its 'pselect' | ||
| 7161 | emulation (see 'sys_select' in w32proc.c) waits on a subprocess | ||
| 7162 | handle, which becomes signaled when the process exits, and also | ||
| 7163 | because that emulation delays the delivery of the simulated SIGCHLD | ||
| 7164 | until all the output from the subprocess has been consumed. */ | ||
| 7165 | |||
| 7166 | /* FIXME: On Unix-like systems that have a proper 'pselect' | ||
| 7167 | (HAVE_PSELECT), we should block SIGCHLD in | ||
| 7168 | 'wait_reading_process_output' and pass a non-NULL signal mask to | ||
| 7169 | 'pselect' to avoid the need for the self-pipe. */ | ||
| 7170 | |||
| 7171 | /* Set up `child_signal_read_fd' and `child_signal_write_fd'. */ | ||
| 7172 | |||
| 7173 | static void | ||
| 7174 | child_signal_init (void) | ||
| 7175 | { | ||
| 7176 | /* Either both are initialized, or both are uninitialized. */ | ||
| 7177 | eassert ((child_signal_read_fd < 0) == (child_signal_write_fd < 0)); | ||
| 7178 | |||
| 7179 | #ifndef WINDOWSNT | ||
| 7180 | if (0 <= child_signal_read_fd) | ||
| 7181 | return; /* already done */ | ||
| 7182 | |||
| 7183 | int fds[2]; | ||
| 7184 | if (emacs_pipe (fds) < 0) | ||
| 7185 | report_file_error ("Creating pipe for child signal", Qnil); | ||
| 7186 | if (FD_SETSIZE <= fds[0]) | ||
| 7187 | { | ||
| 7188 | /* Since we need to `pselect' on the read end, it has to fit | ||
| 7189 | into an `fd_set'. */ | ||
| 7190 | emacs_close (fds[0]); | ||
| 7191 | emacs_close (fds[1]); | ||
| 7192 | report_file_errno ("Creating pipe for child signal", Qnil, | ||
| 7193 | EMFILE); | ||
| 7194 | } | ||
| 7195 | |||
| 7196 | /* We leave the file descriptors open until the Emacs process | ||
| 7197 | exits. */ | ||
| 7198 | eassert (0 <= fds[0]); | ||
| 7199 | eassert (0 <= fds[1]); | ||
| 7200 | if (fcntl (fds[0], F_SETFL, O_NONBLOCK) != 0) | ||
| 7201 | emacs_perror ("fcntl"); | ||
| 7202 | if (fcntl (fds[1], F_SETFL, O_NONBLOCK) != 0) | ||
| 7203 | emacs_perror ("fcntl"); | ||
| 7204 | add_read_fd (fds[0], child_signal_read, NULL); | ||
| 7205 | fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD; | ||
| 7206 | child_signal_read_fd = fds[0]; | ||
| 7207 | child_signal_write_fd = fds[1]; | ||
| 7208 | #endif /* !WINDOWSNT */ | ||
| 7209 | } | ||
| 7210 | |||
| 7211 | #ifndef WINDOWSNT | ||
| 7212 | /* Consume a process status change. */ | ||
| 7213 | |||
| 7214 | static void | ||
| 7215 | child_signal_read (int fd, void *data) | ||
| 7216 | { | ||
| 7217 | eassert (0 <= fd); | ||
| 7218 | eassert (fd == child_signal_read_fd); | ||
| 7219 | char dummy; | ||
| 7220 | if (emacs_read (fd, &dummy, 1) < 0) | ||
| 7221 | emacs_perror ("reading from child signal FD"); | ||
| 7222 | } | ||
| 7223 | #endif /* !WINDOWSNT */ | ||
| 7224 | |||
| 7225 | /* Notify `wait_reading_process_output' of a process status | ||
| 7226 | change. */ | ||
| 7227 | |||
| 7228 | static void | ||
| 7229 | child_signal_notify (void) | ||
| 7230 | { | ||
| 7231 | #ifndef WINDOWSNT | ||
| 7232 | int fd = child_signal_write_fd; | ||
| 7233 | eassert (0 <= fd); | ||
| 7234 | char dummy = 0; | ||
| 7235 | if (emacs_write (fd, &dummy, 1) != 1) | ||
| 7236 | emacs_perror ("writing to child signal FD"); | ||
| 7237 | #endif | ||
| 7238 | } | ||
| 7118 | 7239 | ||
| 7119 | /* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing | 7240 | /* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing |
| 7120 | its own SIGCHLD handling. On POSIXish systems, glib needs this to | 7241 | its own SIGCHLD handling. On POSIXish systems, glib needs this to |
| @@ -7152,6 +7273,7 @@ static void | |||
| 7152 | handle_child_signal (int sig) | 7273 | handle_child_signal (int sig) |
| 7153 | { | 7274 | { |
| 7154 | Lisp_Object tail, proc; | 7275 | Lisp_Object tail, proc; |
| 7276 | bool changed = false; | ||
| 7155 | 7277 | ||
| 7156 | /* Find the process that signaled us, and record its status. */ | 7278 | /* Find the process that signaled us, and record its status. */ |
| 7157 | 7279 | ||
| @@ -7174,6 +7296,7 @@ handle_child_signal (int sig) | |||
| 7174 | eassert (ok); | 7296 | eassert (ok); |
| 7175 | if (child_status_changed (deleted_pid, 0, 0)) | 7297 | if (child_status_changed (deleted_pid, 0, 0)) |
| 7176 | { | 7298 | { |
| 7299 | changed = true; | ||
| 7177 | if (STRINGP (XCDR (head))) | 7300 | if (STRINGP (XCDR (head))) |
| 7178 | unlink (SSDATA (XCDR (head))); | 7301 | unlink (SSDATA (XCDR (head))); |
| 7179 | XSETCAR (tail, Qnil); | 7302 | XSETCAR (tail, Qnil); |
| @@ -7191,6 +7314,7 @@ handle_child_signal (int sig) | |||
| 7191 | && child_status_changed (p->pid, &status, WUNTRACED | WCONTINUED)) | 7314 | && child_status_changed (p->pid, &status, WUNTRACED | WCONTINUED)) |
| 7192 | { | 7315 | { |
| 7193 | /* Change the status of the process that was found. */ | 7316 | /* Change the status of the process that was found. */ |
| 7317 | changed = true; | ||
| 7194 | p->tick = ++process_tick; | 7318 | p->tick = ++process_tick; |
| 7195 | p->raw_status = status; | 7319 | p->raw_status = status; |
| 7196 | p->raw_status_new = 1; | 7320 | p->raw_status_new = 1; |
| @@ -7210,6 +7334,10 @@ handle_child_signal (int sig) | |||
| 7210 | } | 7334 | } |
| 7211 | } | 7335 | } |
| 7212 | 7336 | ||
| 7337 | if (changed) | ||
| 7338 | /* Wake up `wait_reading_process_output'. */ | ||
| 7339 | child_signal_notify (); | ||
| 7340 | |||
| 7213 | lib_child_handler (sig); | 7341 | lib_child_handler (sig); |
| 7214 | #ifdef NS_IMPL_GNUSTEP | 7342 | #ifdef NS_IMPL_GNUSTEP |
| 7215 | /* NSTask in GNUstep sets its child handler each time it is called. | 7343 | /* NSTask in GNUstep sets its child handler each time it is called. |
diff --git a/src/term.c b/src/term.c index a87f9c745ce..1059b0669a7 100644 --- a/src/term.c +++ b/src/term.c | |||
| @@ -790,7 +790,7 @@ tty_write_glyphs (struct frame *f, struct glyph *string, int len) | |||
| 790 | cmcheckmagic (tty); | 790 | cmcheckmagic (tty); |
| 791 | } | 791 | } |
| 792 | 792 | ||
| 793 | #ifdef HAVE_GPM /* Only used by GPM code. */ | 793 | #ifndef DOS_NT |
| 794 | 794 | ||
| 795 | static void | 795 | static void |
| 796 | tty_write_glyphs_with_face (register struct frame *f, register struct glyph *string, | 796 | tty_write_glyphs_with_face (register struct frame *f, register struct glyph *string, |
| @@ -847,6 +847,7 @@ tty_write_glyphs_with_face (register struct frame *f, register struct glyph *str | |||
| 847 | 847 | ||
| 848 | cmcheckmagic (tty); | 848 | cmcheckmagic (tty); |
| 849 | } | 849 | } |
| 850 | |||
| 850 | #endif | 851 | #endif |
| 851 | 852 | ||
| 852 | /* An implementation of insert_glyphs for termcap frames. */ | 853 | /* An implementation of insert_glyphs for termcap frames. */ |
| @@ -2380,25 +2381,9 @@ frame's terminal). */) | |||
| 2380 | Mouse | 2381 | Mouse |
| 2381 | ***********************************************************************/ | 2382 | ***********************************************************************/ |
| 2382 | 2383 | ||
| 2383 | #ifdef HAVE_GPM | 2384 | #ifndef DOS_NT |
| 2384 | |||
| 2385 | #ifndef HAVE_WINDOW_SYSTEM | ||
| 2386 | void | ||
| 2387 | term_mouse_moveto (int x, int y) | ||
| 2388 | { | ||
| 2389 | /* TODO: how to set mouse position? | ||
| 2390 | const char *name; | ||
| 2391 | int fd; | ||
| 2392 | name = (const char *) ttyname (0); | ||
| 2393 | fd = emacs_open (name, O_WRONLY, 0); | ||
| 2394 | SOME_FUNCTION (x, y, fd); | ||
| 2395 | emacs_close (fd); | ||
| 2396 | last_mouse_x = x; | ||
| 2397 | last_mouse_y = y; */ | ||
| 2398 | } | ||
| 2399 | #endif /* HAVE_WINDOW_SYSTEM */ | ||
| 2400 | 2385 | ||
| 2401 | /* Implementation of draw_row_with_mouse_face for TTY/GPM. */ | 2386 | /* Implementation of draw_row_with_mouse_face for TTY/GPM and macOS. */ |
| 2402 | void | 2387 | void |
| 2403 | tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, | 2388 | tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, |
| 2404 | int start_hpos, int end_hpos, | 2389 | int start_hpos, int end_hpos, |
| @@ -2430,6 +2415,24 @@ tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, | |||
| 2430 | cursor_to (f, save_y, save_x); | 2415 | cursor_to (f, save_y, save_x); |
| 2431 | } | 2416 | } |
| 2432 | 2417 | ||
| 2418 | #endif | ||
| 2419 | |||
| 2420 | #ifdef HAVE_GPM | ||
| 2421 | |||
| 2422 | void | ||
| 2423 | term_mouse_moveto (int x, int y) | ||
| 2424 | { | ||
| 2425 | /* TODO: how to set mouse position? | ||
| 2426 | const char *name; | ||
| 2427 | int fd; | ||
| 2428 | name = (const char *) ttyname (0); | ||
| 2429 | fd = emacs_open (name, O_WRONLY, 0); | ||
| 2430 | SOME_FUNCTION (x, y, fd); | ||
| 2431 | emacs_close (fd); | ||
| 2432 | last_mouse_x = x; | ||
| 2433 | last_mouse_y = y; */ | ||
| 2434 | } | ||
| 2435 | |||
| 2433 | /* Return the current time, as a Time value. Wrap around on overflow. */ | 2436 | /* Return the current time, as a Time value. Wrap around on overflow. */ |
| 2434 | static Time | 2437 | static Time |
| 2435 | current_Time (void) | 2438 | current_Time (void) |
| @@ -4246,8 +4249,8 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ | |||
| 4246 | 4249 | ||
| 4247 | #ifdef HAVE_GPM | 4250 | #ifdef HAVE_GPM |
| 4248 | terminal->mouse_position_hook = term_mouse_position; | 4251 | terminal->mouse_position_hook = term_mouse_position; |
| 4249 | tty->mouse_highlight.mouse_face_window = Qnil; | ||
| 4250 | #endif | 4252 | #endif |
| 4253 | tty->mouse_highlight.mouse_face_window = Qnil; | ||
| 4251 | 4254 | ||
| 4252 | terminal->kboard = allocate_kboard (Qnil); | 4255 | terminal->kboard = allocate_kboard (Qnil); |
| 4253 | terminal->kboard->reference_count++; | 4256 | terminal->kboard->reference_count++; |
diff --git a/src/termhooks.h b/src/termhooks.h index 85a47c071b6..3800679e803 100644 --- a/src/termhooks.h +++ b/src/termhooks.h | |||
| @@ -366,9 +366,7 @@ enum { | |||
| 366 | #ifdef HAVE_GPM | 366 | #ifdef HAVE_GPM |
| 367 | #include <gpm.h> | 367 | #include <gpm.h> |
| 368 | extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *); | 368 | extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *); |
| 369 | #ifndef HAVE_WINDOW_SYSTEM | ||
| 370 | extern void term_mouse_moveto (int, int); | 369 | extern void term_mouse_moveto (int, int); |
| 371 | #endif | ||
| 372 | 370 | ||
| 373 | /* The device for which we have enabled gpm support. */ | 371 | /* The device for which we have enabled gpm support. */ |
| 374 | extern struct tty_display_info *gpm_tty; | 372 | extern struct tty_display_info *gpm_tty; |
diff --git a/src/window.c b/src/window.c index e025e0b0821..eb16e2a4338 100644 --- a/src/window.c +++ b/src/window.c | |||
| @@ -2260,7 +2260,7 @@ return value is a list of elements of the form (PARAMETER . VALUE). */) | |||
| 2260 | Lisp_Object | 2260 | Lisp_Object |
| 2261 | window_parameter (struct window *w, Lisp_Object parameter) | 2261 | window_parameter (struct window *w, Lisp_Object parameter) |
| 2262 | { | 2262 | { |
| 2263 | Lisp_Object result = Fassq (parameter, w->window_parameters); | 2263 | Lisp_Object result = assq_no_quit (parameter, w->window_parameters); |
| 2264 | 2264 | ||
| 2265 | return CDR_SAFE (result); | 2265 | return CDR_SAFE (result); |
| 2266 | } | 2266 | } |
diff --git a/src/xdisp.c b/src/xdisp.c index ea67329cff1..e1e4ff41365 100644 --- a/src/xdisp.c +++ b/src/xdisp.c | |||
| @@ -20822,9 +20822,8 @@ try_window_id (struct window *w) | |||
| 20822 | + window_wants_header_line (w) | 20822 | + window_wants_header_line (w) |
| 20823 | + window_internal_height (w)); | 20823 | + window_internal_height (w)); |
| 20824 | 20824 | ||
| 20825 | #if defined (HAVE_GPM) || defined (MSDOS) | ||
| 20826 | gui_clear_window_mouse_face (w); | 20825 | gui_clear_window_mouse_face (w); |
| 20827 | #endif | 20826 | |
| 20828 | /* Perform the operation on the screen. */ | 20827 | /* Perform the operation on the screen. */ |
| 20829 | if (dvpos > 0) | 20828 | if (dvpos > 0) |
| 20830 | { | 20829 | { |
| @@ -31928,9 +31927,8 @@ draw_row_with_mouse_face (struct window *w, int start_x, struct glyph_row *row, | |||
| 31928 | return; | 31927 | return; |
| 31929 | } | 31928 | } |
| 31930 | #endif | 31929 | #endif |
| 31931 | #if defined (HAVE_GPM) || defined (MSDOS) || defined (WINDOWSNT) | 31930 | |
| 31932 | tty_draw_row_with_mouse_face (w, row, start_hpos, end_hpos, draw); | 31931 | tty_draw_row_with_mouse_face (w, row, start_hpos, end_hpos, draw); |
| 31933 | #endif | ||
| 31934 | } | 31932 | } |
| 31935 | 31933 | ||
| 31936 | /* Display the active region described by mouse_face_* according to DRAW. */ | 31934 | /* Display the active region described by mouse_face_* according to DRAW. */ |
diff --git a/test/Makefile.in b/test/Makefile.in index 849fbbf474e..bfab95b9381 100644 --- a/test/Makefile.in +++ b/test/Makefile.in | |||
| @@ -253,11 +253,17 @@ endef | |||
| 253 | 253 | ||
| 254 | $(foreach test,${TESTS},$(eval $(call test_template,${test}))) | 254 | $(foreach test,${TESTS},$(eval $(call test_template,${test}))) |
| 255 | 255 | ||
| 256 | # Get the tests for only a specific directory | 256 | ## Get the tests for only a specific directory. |
| 257 | NET_TESTS := $(patsubst %.el,%,$(wildcard lisp/net/*.el)) | 257 | SUBDIRS = $(sort $(shell find lib-src lisp src -type d ! -path "*resources*" -print)) |
| 258 | LISP_TESTS := $(patsubst %.el,%,$(wildcard lisp/*.el)) | 258 | |
| 259 | check-net: ${NET_TESTS} | 259 | define subdir_template |
| 260 | check-lisp: ${LISP_TESTS} | 260 | .PHONY: check-$(subst /,-,$(1)) |
| 261 | check-$(subst /,-,$(1)): | ||
| 262 | @${MAKE} check LOGFILES="$(patsubst %.el,%.log, \ | ||
| 263 | $(patsubst $(srcdir)/%,%,$(wildcard $(1)/*.el)))" | ||
| 264 | endef | ||
| 265 | |||
| 266 | $(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) | ||
| 261 | 267 | ||
| 262 | ifeq (@HAVE_MODULES@, yes) | 268 | ifeq (@HAVE_MODULES@, yes) |
| 263 | # -fPIC is a no-op on Windows, but causes a compiler warning | 269 | # -fPIC is a no-op on Windows, but causes a compiler warning |
| @@ -325,10 +331,10 @@ check-doit: | |||
| 325 | ifeq ($(TEST_INTERACTIVE), yes) | 331 | ifeq ($(TEST_INTERACTIVE), yes) |
| 326 | HOME=$(TEST_HOME) $(emacs) \ | 332 | HOME=$(TEST_HOME) $(emacs) \ |
| 327 | -l ert ${ert_opts} \ | 333 | -l ert ${ert_opts} \ |
| 328 | $(patsubst %,-l %,$(if $(findstring $(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \ | 334 | $(patsubst %,-l %,$(if $(findstring $(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \ |
| 329 | $(TEST_RUN_ERT) | 335 | $(TEST_RUN_ERT) |
| 330 | else | 336 | else |
| 331 | -@${MAKE} -k ${LOGFILES} | 337 | -@${MAKE} -k ${LOGFILES} |
| 332 | @$(emacs) --batch -l ert --eval \ | 338 | @$(emacs) --batch -l ert --eval \ |
| 333 | "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES} | 339 | "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES} |
| 334 | endif | 340 | endif |
diff --git a/test/README b/test/README index 38f4a109701..5f3c10adbe1 100644 --- a/test/README +++ b/test/README | |||
| @@ -39,11 +39,10 @@ The Makefile in this directory supports the following targets: | |||
| 39 | * make check-all | 39 | * make check-all |
| 40 | Like "make check", but run all tests. | 40 | Like "make check", but run all tests. |
| 41 | 41 | ||
| 42 | * make check-lisp | 42 | * make check-<dirname> |
| 43 | Like "make check", but run only the tests in test/lisp/*.el | 43 | Like "make check", but run only the tests in test/<dirname>/*.el. |
| 44 | 44 | <dirname> is a relative directory path, which has replaced "/" by "-", | |
| 45 | * make check-net | 45 | like in "check-src" or "check-lisp-net". |
| 46 | Like "make check", but run only the tests in test/lisp/net/*.el | ||
| 47 | 46 | ||
| 48 | * make <filename> -or- make <filename>.log | 47 | * make <filename> -or- make <filename>.log |
| 49 | Run all tests declared in <filename>.el. This includes expensive | 48 | Run all tests declared in <filename>.el. This includes expensive |
| @@ -61,7 +60,9 @@ https://www.gnu.org/software/emacs/manual/html_node/ert/Test-Selectors.html | |||
| 61 | 60 | ||
| 62 | You could use predefined selectors of the Makefile. "make <filename> | 61 | You could use predefined selectors of the Makefile. "make <filename> |
| 63 | SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for <filename>.el | 62 | SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for <filename>.el |
| 64 | except the tests tagged as expensive or unstable. | 63 | except the tests tagged as expensive or unstable. Other predefined |
| 64 | selectors are $(SELECTOR_EXPENSIVE) (run all tests except unstable | ||
| 65 | ones) and $(SELECTOR_ALL) (run all tests). | ||
| 65 | 66 | ||
| 66 | If your test file contains the tests "test-foo", "test2-foo" and | 67 | If your test file contains the tests "test-foo", "test2-foo" and |
| 67 | "test-foo-remote", and you want to run only the former two tests, you | 68 | "test-foo-remote", and you want to run only the former two tests, you |
diff --git a/test/file-organization.org b/test/file-organization.org index efc354529c5..7cf5b88d6d0 100644 --- a/test/file-organization.org +++ b/test/file-organization.org | |||
| @@ -17,13 +17,15 @@ Sub-directories are in many cases themed after packages (~gnus~, ~org~, | |||
| 17 | ~calc~), related functionality (~net~, ~emacs-lisp~, ~progmodes~) or status | 17 | ~calc~), related functionality (~net~, ~emacs-lisp~, ~progmodes~) or status |
| 18 | (~obsolete~). | 18 | (~obsolete~). |
| 19 | 19 | ||
| 20 | C source is stored in the ~src~ directory, which is flat. | 20 | C source is stored in the ~src~ directory, which is flat. Source for |
| 21 | utility programs is stored in the ~lib-src~ directory. | ||
| 21 | 22 | ||
| 22 | ** Test Files | 23 | ** Test Files |
| 23 | 24 | ||
| 24 | Automated tests should be stored in the ~test/lisp~ directory for | 25 | Automated tests should be stored in the ~test/lisp~ directory for |
| 25 | tests of functionality implemented in Lisp, and in the ~test/src~ | 26 | tests of functionality implemented in Lisp, in the ~test/src~ |
| 26 | directory for functionality implemented in C. Tests should reflect | 27 | directory for functionality implemented in C, and in the |
| 28 | ~test/lib-src~ directory for utility programs. Tests should reflect | ||
| 27 | the directory structure of the source tree; so tests for files in the | 29 | the directory structure of the source tree; so tests for files in the |
| 28 | ~lisp/emacs-lisp~ source directory should reside in the | 30 | ~lisp/emacs-lisp~ source directory should reside in the |
| 29 | ~test/lisp/emacs-lisp~ directory. | 31 | ~test/lisp/emacs-lisp~ directory. |
| @@ -36,10 +38,10 @@ files of any name which are themselves placed in a directory named | |||
| 36 | after the feature with ~-tests~ appended, such as | 38 | after the feature with ~-tests~ appended, such as |
| 37 | ~/test/lisp/emacs-lisp/eieio-tests~ | 39 | ~/test/lisp/emacs-lisp/eieio-tests~ |
| 38 | 40 | ||
| 39 | Similarly, features implemented in C should reside in ~/test/src~ and | 41 | Similarly, tests of features implemented in C should reside in |
| 40 | be named after the C file with ~-tests.el~ added to the base-name of | 42 | ~/test/src~ or in ~test/lib-src~ and be named after the C file with |
| 41 | the tested source file. Thus, tests for ~src/fileio.c~ should be in | 43 | ~-tests.el~ added to the base-name of the tested source file. Thus, |
| 42 | ~test/src/fileio-tests.el~. | 44 | tests for ~src/fileio.c~ should be in ~test/src/fileio-tests.el~. |
| 43 | 45 | ||
| 44 | There are also some test materials that cannot be run automatically | 46 | There are also some test materials that cannot be run automatically |
| 45 | (i.e. via ert). These should be placed in ~/test/manual~; they are | 47 | (i.e. via ert). These should be placed in ~/test/manual~; they are |
diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba index dd41982ad59..421264db9c9 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba | |||
| @@ -41,7 +41,7 @@ COPY . /checkout | |||
| 41 | WORKDIR /checkout | 41 | WORKDIR /checkout |
| 42 | RUN ./autogen.sh autoconf | 42 | RUN ./autogen.sh autoconf |
| 43 | RUN ./configure --without-makeinfo | 43 | RUN ./configure --without-makeinfo |
| 44 | RUN make bootstrap | 44 | RUN make -j4 bootstrap |
| 45 | RUN make -j4 | 45 | RUN make -j4 |
| 46 | 46 | ||
| 47 | FROM emacs-base as emacs-filenotify-gio | 47 | FROM emacs-base as emacs-filenotify-gio |
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml new file mode 100644 index 00000000000..5a0ab54e4b9 --- /dev/null +++ b/test/infra/gitlab-ci.yml | |||
| @@ -0,0 +1,245 @@ | |||
| 1 | # Copyright (C) 2017-2021 Free Software Foundation, Inc. | ||
| 2 | # | ||
| 3 | # This file is part of GNU Emacs. | ||
| 4 | # | ||
| 5 | # GNU Emacs is free software: you can redistribute it and/or modify | ||
| 6 | # it under the terms of the GNU General Public License as published by | ||
| 7 | # the Free Software Foundation, either version 3 of the License, or | ||
| 8 | # (at your option) any later version. | ||
| 9 | # | ||
| 10 | # GNU Emacs is distributed in the hope that it will be useful, | ||
| 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 13 | # GNU General Public License for more details. | ||
| 14 | # | ||
| 15 | # You should have received a copy of the GNU General Public License | ||
| 16 | # along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
| 17 | |||
| 18 | # GNU Emacs support for the GitLab protocol for CI | ||
| 19 | |||
| 20 | # The presence of this file does not imply any FSF/GNU endorsement of | ||
| 21 | # any particular service that uses that protocol. Also, it is intended for | ||
| 22 | # evaluation purposes, thus possibly temporary. | ||
| 23 | |||
| 24 | # Maintainer: Ted Zlatanov <tzz@lifelogs.com> | ||
| 25 | # URL: https://emba.gnu.org/emacs/emacs | ||
| 26 | |||
| 27 | # Never run merge request pipelines, they usually duplicate push pipelines | ||
| 28 | # see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules | ||
| 29 | |||
| 30 | # Rules: always run tags and branches named master*, emacs*, feature*, fix* | ||
| 31 | # Test that it triggers by pushing a tag: `git tag mytag; git push origin mytag` | ||
| 32 | # Test that it triggers by pushing to: feature/emba, feature1, master, master-2, fix/emba, emacs-299, fix-2 | ||
| 33 | # Test that it doesn't trigger by pushing to: scratch-2, scratch/emba, oldbranch, dev | ||
| 34 | workflow: | ||
| 35 | rules: | ||
| 36 | - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' | ||
| 37 | when: never | ||
| 38 | - if: '$CI_COMMIT_TAG' | ||
| 39 | when: always | ||
| 40 | - if: '$CI_COMMIT_BRANCH !~ /^(master|emacs|feature|fix)/' | ||
| 41 | when: never | ||
| 42 | - when: always | ||
| 43 | |||
| 44 | variables: | ||
| 45 | GIT_STRATEGY: fetch | ||
| 46 | EMACS_EMBA_CI: 1 | ||
| 47 | # # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled | ||
| 48 | # DOCKER_HOST: tcp://docker:2376 | ||
| 49 | # DOCKER_TLS_CERTDIR: "/certs" | ||
| 50 | # Put the configuration for each run in a separate directory to avoid conflicts | ||
| 51 | DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" | ||
| 52 | # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap across multiple builds | ||
| 53 | BUILD_TAG: ${CI_COMMIT_REF_SLUG} | ||
| 54 | |||
| 55 | default: | ||
| 56 | image: docker:19.03.12 | ||
| 57 | timeout: 3 hours | ||
| 58 | before_script: | ||
| 59 | - docker info | ||
| 60 | - echo "docker registry is ${CI_REGISTRY}" | ||
| 61 | - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} | ||
| 62 | |||
| 63 | .job-template: | ||
| 64 | rules: | ||
| 65 | - changes: | ||
| 66 | - "**/Makefile.in" | ||
| 67 | - .gitlab-ci.yml | ||
| 68 | - aclocal.m4 | ||
| 69 | - autogen.sh | ||
| 70 | - configure.ac | ||
| 71 | - lib/*.{h,c} | ||
| 72 | - lisp/**/*.el | ||
| 73 | - src/*.{h,c} | ||
| 74 | - test/infra/* | ||
| 75 | - test/lib-src/*.el | ||
| 76 | - test/lisp/**/*.el | ||
| 77 | - test/src/*.el | ||
| 78 | - changes: | ||
| 79 | # gfilemonitor, kqueue | ||
| 80 | - src/gfilenotify.c | ||
| 81 | - src/kqueue.c | ||
| 82 | # MS Windows | ||
| 83 | - "**/w32*" | ||
| 84 | # GNUstep | ||
| 85 | - lisp/term/ns-win.el | ||
| 86 | - src/ns*.{h,m} | ||
| 87 | - src/macfont.{h,m} | ||
| 88 | when: never | ||
| 89 | # these will be cached across builds | ||
| 90 | cache: | ||
| 91 | key: ${CI_COMMIT_SHA} | ||
| 92 | paths: [] | ||
| 93 | policy: pull-push | ||
| 94 | # these will be saved for followup builds | ||
| 95 | artifacts: | ||
| 96 | expire_in: 24 hrs | ||
| 97 | paths: [] | ||
| 98 | # - "test/**/*.log" | ||
| 99 | # - "**/*.log" | ||
| 100 | # using the variables for each job | ||
| 101 | script: | ||
| 102 | - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} | ||
| 103 | # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it | ||
| 104 | - 'export PWD=$(pwd)' | ||
| 105 | - 'docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' | ||
| 106 | |||
| 107 | .build-template: | ||
| 108 | rules: | ||
| 109 | - if: '$CI_PIPELINE_SOURCE == "web"' | ||
| 110 | when: always | ||
| 111 | - changes: | ||
| 112 | - "**/Makefile.in" | ||
| 113 | - .gitlab-ci.yml | ||
| 114 | - aclocal.m4 | ||
| 115 | - autogen.sh | ||
| 116 | - configure.ac | ||
| 117 | - lib/*.{h,c} | ||
| 118 | - lisp/emacs-lisp/*.el | ||
| 119 | - src/*.{h,c} | ||
| 120 | - test/infra/* | ||
| 121 | - changes: | ||
| 122 | # gfilemonitor, kqueue | ||
| 123 | - src/gfilenotify.c | ||
| 124 | - src/kqueue.c | ||
| 125 | # MS Windows | ||
| 126 | - "**/w32*" | ||
| 127 | # GNUstep | ||
| 128 | - lisp/term/ns-win.el | ||
| 129 | - src/ns*.{h,m} | ||
| 130 | - src/macfont.{h,m} | ||
| 131 | when: never | ||
| 132 | script: | ||
| 133 | - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . | ||
| 134 | - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} | ||
| 135 | |||
| 136 | .gnustep-template: | ||
| 137 | rules: | ||
| 138 | - if: '$CI_PIPELINE_SOURCE == "web"' | ||
| 139 | - if: '$CI_PIPELINE_SOURCE == "schedule"' | ||
| 140 | changes: | ||
| 141 | - "**/Makefile.in" | ||
| 142 | - .gitlab-ci.yml | ||
| 143 | - configure.ac | ||
| 144 | - src/ns*.{h,m} | ||
| 145 | - src/macfont.{h,m} | ||
| 146 | - lisp/term/ns-win.el | ||
| 147 | - nextstep/**/* | ||
| 148 | - test/infra/* | ||
| 149 | |||
| 150 | .filenotify-gio-template: | ||
| 151 | rules: | ||
| 152 | - if: '$CI_PIPELINE_SOURCE == "web"' | ||
| 153 | - if: '$CI_PIPELINE_SOURCE == "schedule"' | ||
| 154 | changes: | ||
| 155 | - "**/Makefile.in" | ||
| 156 | - .gitlab-ci.yml | ||
| 157 | - lisp/autorevert.el | ||
| 158 | - lisp/filenotify.el | ||
| 159 | - lisp/net/tramp-sh.el | ||
| 160 | - src/gfilenotify.c | ||
| 161 | - test/infra/* | ||
| 162 | - test/lisp/autorevert-tests.el | ||
| 163 | - test/lisp/filenotify-tests.el | ||
| 164 | |||
| 165 | stages: | ||
| 166 | - prep-images | ||
| 167 | - build-images | ||
| 168 | - fast | ||
| 169 | - normal | ||
| 170 | - platform-images | ||
| 171 | - platforms | ||
| 172 | - slow | ||
| 173 | |||
| 174 | prep-image-base: | ||
| 175 | stage: prep-images | ||
| 176 | extends: [.job-template, .build-template] | ||
| 177 | variables: | ||
| 178 | target: emacs-base | ||
| 179 | |||
| 180 | build-image-inotify: | ||
| 181 | stage: build-images | ||
| 182 | extends: [.job-template, .build-template] | ||
| 183 | variables: | ||
| 184 | target: emacs-inotify | ||
| 185 | |||
| 186 | test-fast-inotify: | ||
| 187 | stage: fast | ||
| 188 | extends: [.job-template] | ||
| 189 | variables: | ||
| 190 | target: emacs-inotify | ||
| 191 | make_params: "-C test check" | ||
| 192 | |||
| 193 | build-image-filenotify-gio: | ||
| 194 | stage: platform-images | ||
| 195 | extends: [.job-template, .build-template, .filenotify-gio-template] | ||
| 196 | variables: | ||
| 197 | target: emacs-filenotify-gio | ||
| 198 | |||
| 199 | build-image-gnustep: | ||
| 200 | stage: platform-images | ||
| 201 | extends: [.job-template, .build-template, .gnustep-template] | ||
| 202 | variables: | ||
| 203 | target: emacs-gnustep | ||
| 204 | |||
| 205 | test-lisp-inotify: | ||
| 206 | stage: normal | ||
| 207 | extends: [.job-template] | ||
| 208 | variables: | ||
| 209 | target: emacs-inotify | ||
| 210 | make_params: "-C test check-lisp" | ||
| 211 | |||
| 212 | test-lisp-net-inotify: | ||
| 213 | stage: normal | ||
| 214 | extends: [.job-template] | ||
| 215 | variables: | ||
| 216 | target: emacs-inotify | ||
| 217 | make_params: "-C test check-lisp-net" | ||
| 218 | |||
| 219 | test-filenotify-gio: | ||
| 220 | # This tests file monitor libraries gfilemonitor and gio. | ||
| 221 | stage: platforms | ||
| 222 | extends: [.job-template, .filenotify-gio-template] | ||
| 223 | variables: | ||
| 224 | target: emacs-filenotify-gio | ||
| 225 | make_params: "-k -C test autorevert-tests filenotify-tests" | ||
| 226 | |||
| 227 | test-gnustep: | ||
| 228 | # This tests the GNUstep build process | ||
| 229 | stage: platforms | ||
| 230 | extends: [.job-template, .gnustep-template] | ||
| 231 | variables: | ||
| 232 | target: emacs-gnustep | ||
| 233 | make_params: install | ||
| 234 | |||
| 235 | test-all-inotify: | ||
| 236 | # This tests also file monitor libraries inotify and inotifywatch. | ||
| 237 | stage: slow | ||
| 238 | extends: [.job-template] | ||
| 239 | rules: | ||
| 240 | # note there's no "changes" section, so this always runs on a schedule | ||
| 241 | - if: '$CI_PIPELINE_SOURCE == "web"' | ||
| 242 | - if: '$CI_PIPELINE_SOURCE == "schedule"' | ||
| 243 | variables: | ||
| 244 | target: emacs-inotify | ||
| 245 | make_params: check-expensive | ||
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 6da515bb2c8..45cf6353960 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el | |||
| @@ -524,8 +524,10 @@ This expects `auto-revert--messages' to be bound by | |||
| 524 | (auto-revert-test--write-file "1-b" file-1) | 524 | (auto-revert-test--write-file "1-b" file-1) |
| 525 | (auto-revert-test--wait-for-buffer-text | 525 | (auto-revert-test--wait-for-buffer-text |
| 526 | buf-1 "1-b" (auto-revert--timeout)) | 526 | buf-1 "1-b" (auto-revert--timeout)) |
| 527 | (should (buffer-local-value | 527 | ;; On emba, `buf-1' is a killed buffer. |
| 528 | 'auto-revert-notify-watch-descriptor buf-1)) | 528 | (when (buffer-live-p buf-1) |
| 529 | (should (buffer-local-value | ||
| 530 | 'auto-revert-notify-watch-descriptor buf-1))) | ||
| 529 | 531 | ||
| 530 | ;; Write a buffer to a new file, then modify the new file on disk. | 532 | ;; Write a buffer to a new file, then modify the new file on disk. |
| 531 | (with-current-buffer buf-2 | 533 | (with-current-buffer buf-2 |
| @@ -607,11 +609,12 @@ This expects `auto-revert--messages' to be bound by | |||
| 607 | (should auto-revert-mode)) | 609 | (should auto-revert-mode)) |
| 608 | 610 | ||
| 609 | (dotimes (i num-buffers) | 611 | (dotimes (i num-buffers) |
| 610 | (add-to-list | 612 | (push (make-indirect-buffer |
| 611 | 'buffers | 613 | (car buffers) |
| 612 | (make-indirect-buffer | 614 | (format "%s-%d" (buffer-file-name (car buffers)) i) |
| 613 | (car buffers) (format "%s-%d" (buffer-file-name (car buffers)) i) 'clone) | 615 | 'clone) |
| 614 | 'append)) | 616 | buffers)) |
| 617 | (setq buffers (nreverse buffers)) | ||
| 615 | (dolist (buf buffers) | 618 | (dolist (buf buffers) |
| 616 | (with-current-buffer buf | 619 | (with-current-buffer buf |
| 617 | (should (string-equal (buffer-string) "any text")) | 620 | (should (string-equal (buffer-string) "any text")) |
| @@ -638,10 +641,10 @@ This expects `auto-revert--messages' to be bound by | |||
| 638 | (auto-revert-tests--write-file "any text" tmpfile (pop times)) | 641 | (auto-revert-tests--write-file "any text" tmpfile (pop times)) |
| 639 | 642 | ||
| 640 | (dotimes (i num-buffers) | 643 | (dotimes (i num-buffers) |
| 641 | (add-to-list | 644 | (push (generate-new-buffer |
| 642 | 'buffers | 645 | (format "%s-%d" (file-name-nondirectory tmpfile) i)) |
| 643 | (generate-new-buffer (format "%s-%d" (file-name-nondirectory tmpfile) i)) | 646 | buffers)) |
| 644 | 'append)) | 647 | (setq buffers (nreverse buffers)) |
| 645 | (dolist (buf buffers) | 648 | (dolist (buf buffers) |
| 646 | (with-current-buffer buf | 649 | (with-current-buffer buf |
| 647 | (insert-file-contents tmpfile 'visit) | 650 | (insert-file-contents tmpfile 'visit) |
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el new file mode 100644 index 00000000000..47481574ea8 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el | |||
| @@ -0,0 +1,6 @@ | |||
| 1 | ;; -*- lexical-binding: t; -*- | ||
| 2 | |||
| 3 | (defsubst foo-inlineable (foo-var) | ||
| 4 | (+ foo-var 2)) | ||
| 5 | |||
| 6 | (provide 'foo-inlinable) | ||
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el new file mode 100644 index 00000000000..5582b2ab0ea --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el | |||
| @@ -0,0 +1,17 @@ | |||
| 1 | ;; -*- lexical-binding: t; -*- | ||
| 2 | |||
| 3 | ;; In this test, we try and make sure that inlined functions's code isn't | ||
| 4 | ;; mistakenly re-interpreted in the caller's context: we import an | ||
| 5 | ;; inlinable function from another file where `foo-var' is a normal | ||
| 6 | ;; lexical variable, and then call(inline) it in a function where | ||
| 7 | ;; `foo-var' is a dynamically-scoped variable. | ||
| 8 | |||
| 9 | (require 'foo-inlinable | ||
| 10 | (expand-file-name "foo-inlinable.el" | ||
| 11 | (file-name-directory | ||
| 12 | (or byte-compile-current-file load-file-name)))) | ||
| 13 | |||
| 14 | (defvar foo-var) | ||
| 15 | |||
| 16 | (defun foo-fun () | ||
| 17 | (+ (foo-inlineable 5) 1)) | ||
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a07af188fac..980b402ca2d 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el | |||
| @@ -617,13 +617,13 @@ Subtests signal errors if something goes wrong." | |||
| 617 | (make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") | 617 | (make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") |
| 618 | 618 | ||
| 619 | (bytecomp--define-warning-file-test "warn-obsolete-hook.el" | 619 | (bytecomp--define-warning-file-test "warn-obsolete-hook.el" |
| 620 | "bytecomp--tests-obs.*obsolete.*99.99") | 620 | "bytecomp--tests-obs.*obsolete[^z-a]*99.99") |
| 621 | 621 | ||
| 622 | (bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" | 622 | (bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" |
| 623 | "foo-obs.*obsolete.*99.99" t) | 623 | "foo-obs.*obsolete.*99.99" t) |
| 624 | 624 | ||
| 625 | (bytecomp--define-warning-file-test "warn-obsolete-variable.el" | 625 | (bytecomp--define-warning-file-test "warn-obsolete-variable.el" |
| 626 | "bytecomp--tests-obs.*obsolete.*99.99") | 626 | "bytecomp--tests-obs.*obsolete[^z-a]*99.99") |
| 627 | 627 | ||
| 628 | (bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" | 628 | (bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" |
| 629 | "bytecomp--tests-obs.*obsolete.*99.99" t) | 629 | "bytecomp--tests-obs.*obsolete.*99.99" t) |
| @@ -713,6 +713,10 @@ Subtests signal errors if something goes wrong." | |||
| 713 | "warn-wide-docstring-multiline.el" | 713 | "warn-wide-docstring-multiline.el" |
| 714 | "defvar.*foo.*wider than.*characters") | 714 | "defvar.*foo.*wider than.*characters") |
| 715 | 715 | ||
| 716 | (bytecomp--define-warning-file-test | ||
| 717 | "nowarn-inline-after-defvar.el" | ||
| 718 | "Lexical argument shadows" 'reverse) | ||
| 719 | |||
| 716 | 720 | ||
| 717 | ;;;; Macro expansion. | 721 | ;;;; Macro expansion. |
| 718 | 722 | ||
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 97a44c43ef7..065ca4fa651 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el | |||
| @@ -543,15 +543,7 @@ | |||
| 543 | (apply (lambda (x) (+ x 1)) (list 8))))) | 543 | (apply (lambda (x) (+ x 1)) (list 8))))) |
| 544 | '(5 (6 5) (6 6) 9)))) | 544 | '(5 (6 5) (6 6) 9)))) |
| 545 | 545 | ||
| 546 | (defun cl-lib-tests--dummy-function () | ||
| 547 | ;; Dummy function to see if the file is compiled. | ||
| 548 | t) | ||
| 549 | |||
| 550 | (ert-deftest cl-lib-defstruct-record () | 546 | (ert-deftest cl-lib-defstruct-record () |
| 551 | ;; This test fails when compiled, see Bug#24402/27718. | ||
| 552 | :expected-result (if (byte-code-function-p | ||
| 553 | (symbol-function 'cl-lib-tests--dummy-function)) | ||
| 554 | :failed :passed) | ||
| 555 | (cl-defstruct foo x) | 547 | (cl-defstruct foo x) |
| 556 | (let ((x (make-foo :x 42))) | 548 | (let ((x (make-foo :x 42))) |
| 557 | (should (recordp x)) | 549 | (should (recordp x)) |
| @@ -566,6 +558,7 @@ | |||
| 566 | (should (eq (type-of x) 'vector)) | 558 | (should (eq (type-of x) 'vector)) |
| 567 | 559 | ||
| 568 | (cl-old-struct-compat-mode 1) | 560 | (cl-old-struct-compat-mode 1) |
| 561 | (defvar cl-struct-foo) | ||
| 569 | (let ((cl-struct-foo (cl--struct-get-class 'foo))) | 562 | (let ((cl-struct-foo (cl--struct-get-class 'foo))) |
| 570 | (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) | 563 | (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) |
| 571 | (should (eq (type-of x) 'foo)) | 564 | (should (eq (type-of x) 'foo)) |
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 1b06c6e7543..e6f4c097504 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el | |||
| @@ -32,6 +32,10 @@ | |||
| 32 | (should (equal (pcase '(2 . 3) ;bug#18554 | 32 | (should (equal (pcase '(2 . 3) ;bug#18554 |
| 33 | (`(,hd . ,(and (pred atom) tl)) (list hd tl)) | 33 | (`(,hd . ,(and (pred atom) tl)) (list hd tl)) |
| 34 | ((pred consp) nil)) | 34 | ((pred consp) nil)) |
| 35 | '(2 3))) | ||
| 36 | (should (equal (pcase '(2 . 3) | ||
| 37 | (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl)) | ||
| 38 | ((pred consp) nil)) | ||
| 35 | '(2 3)))) | 39 | '(2 3)))) |
| 36 | 40 | ||
| 37 | (pcase-defmacro pcase-tests-plus (pat n) | 41 | (pcase-defmacro pcase-tests-plus (pat n) |
diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 670398354a6..05c7fbe781e 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el | |||
| @@ -29,6 +29,9 @@ | |||
| 29 | (require 'ert) | 29 | (require 'ert) |
| 30 | (require 'seq) | 30 | (require 'seq) |
| 31 | 31 | ||
| 32 | (eval-when-compile | ||
| 33 | (require 'cl-lib)) | ||
| 34 | |||
| 32 | (defmacro with-test-sequences (spec &rest body) | 35 | (defmacro with-test-sequences (spec &rest body) |
| 33 | "Successively bind VAR to a list, vector, and string built from SEQ. | 36 | "Successively bind VAR to a list, vector, and string built from SEQ. |
| 34 | Evaluate BODY for each created sequence. | 37 | Evaluate BODY for each created sequence. |
| @@ -108,16 +111,12 @@ Evaluate BODY for each created sequence. | |||
| 108 | '((a 0) (b 1) (c 2) (d 3))))) | 111 | '((a 0) (b 1) (c 2) (d 3))))) |
| 109 | 112 | ||
| 110 | (ert-deftest test-seq-do-indexed () | 113 | (ert-deftest test-seq-do-indexed () |
| 111 | (let ((result nil)) | 114 | (let (result) |
| 112 | (seq-do-indexed (lambda (elt i) | 115 | (seq-do-indexed (lambda (elt i) (push (list elt i) result)) ()) |
| 113 | (add-to-list 'result (list elt i))) | 116 | (should-not result)) |
| 114 | nil) | ||
| 115 | (should (equal result nil))) | ||
| 116 | (with-test-sequences (seq '(4 5 6)) | 117 | (with-test-sequences (seq '(4 5 6)) |
| 117 | (let ((result nil)) | 118 | (let (result) |
| 118 | (seq-do-indexed (lambda (elt i) | 119 | (seq-do-indexed (lambda (elt i) (push (list elt i) result)) seq) |
| 119 | (add-to-list 'result (list elt i))) | ||
| 120 | seq) | ||
| 121 | (should (equal (seq-elt result 0) '(6 2))) | 120 | (should (equal (seq-elt result 0) '(6 2))) |
| 122 | (should (equal (seq-elt result 1) '(5 1))) | 121 | (should (equal (seq-elt result 1) '(5 1))) |
| 123 | (should (equal (seq-elt result 2) '(4 0)))))) | 122 | (should (equal (seq-elt result 2) '(4 0)))))) |
| @@ -410,12 +409,10 @@ Evaluate BODY for each created sequence. | |||
| 410 | 409 | ||
| 411 | (ert-deftest test-seq-random-elt-take-all () | 410 | (ert-deftest test-seq-random-elt-take-all () |
| 412 | (let ((seq '(a b c d e)) | 411 | (let ((seq '(a b c d e)) |
| 413 | (elts '())) | 412 | elts) |
| 414 | (should (= 0 (length elts))) | ||
| 415 | (dotimes (_ 1000) | 413 | (dotimes (_ 1000) |
| 416 | (let ((random-elt (seq-random-elt seq))) | 414 | (let ((random-elt (seq-random-elt seq))) |
| 417 | (add-to-list 'elts | 415 | (cl-pushnew random-elt elts))) |
| 418 | random-elt))) | ||
| 419 | (should (= 5 (length elts))))) | 416 | (should (= 5 (length elts))))) |
| 420 | 417 | ||
| 421 | (ert-deftest test-seq-random-elt-signal-on-empty () | 418 | (ert-deftest test-seq-random-elt-signal-on-empty () |
diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el index 6e77259fe1b..c0db9c9de17 100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el | |||
| @@ -217,5 +217,13 @@ | |||
| 217 | )) | 217 | )) |
| 218 | ) | 218 | ) |
| 219 | 219 | ||
| 220 | (ert-deftest test-tty-find-type () | ||
| 221 | (let ((pred (lambda (string) | ||
| 222 | (locate-library (concat "term/" string ".el"))))) | ||
| 223 | (should (tty-find-type pred "cygwin")) | ||
| 224 | (should (tty-find-type pred "cygwin-foo")) | ||
| 225 | (should (equal (tty-find-type pred "xterm") "xterm")) | ||
| 226 | (should (equal (tty-find-type pred "screen.xterm") "screen")))) | ||
| 227 | |||
| 220 | (provide 'faces-tests) | 228 | (provide 'faces-tests) |
| 221 | ;;; faces-tests.el ends here | 229 | ;;; faces-tests.el ends here |
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index ef0968a3385..7757c55c16b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el | |||
| @@ -2272,8 +2272,8 @@ This checks also `file-name-as-directory', `file-name-directory', | |||
| 2272 | (delete-file tmp-name) | 2272 | (delete-file tmp-name) |
| 2273 | (should-not (file-exists-p tmp-name)) | 2273 | (should-not (file-exists-p tmp-name)) |
| 2274 | 2274 | ||
| 2275 | ;; Trashing files doesn't work for crypted remote files. | 2275 | ;; Trashing files doesn't work on MS Windows, and for crypted remote files. |
| 2276 | (unless (tramp--test-crypt-p) | 2276 | (unless (or (tramp--test-windows-nt-p) (tramp--test-crypt-p)) |
| 2277 | (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) | 2277 | (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) |
| 2278 | (delete-by-moving-to-trash t)) | 2278 | (delete-by-moving-to-trash t)) |
| 2279 | (make-directory trash-directory) | 2279 | (make-directory trash-directory) |
| @@ -2786,9 +2786,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." | |||
| 2786 | (should-not (file-directory-p tmp-name1)) | 2786 | (should-not (file-directory-p tmp-name1)) |
| 2787 | 2787 | ||
| 2788 | ;; Trashing directories works only since Emacs 27.1. It doesn't | 2788 | ;; Trashing directories works only since Emacs 27.1. It doesn't |
| 2789 | ;; work for crypted remote directories and for ange-ftp. | 2789 | ;; work on MS Windows, for crypted remote directories and for ange-ftp. |
| 2790 | (when (and (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) | 2790 | (when (and (not (tramp--test-windows-nt-p)) (not (tramp--test-crypt-p)) |
| 2791 | (tramp--test-emacs27-p)) | 2791 | (not (tramp--test-ftp-p)) (tramp--test-emacs27-p)) |
| 2792 | (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) | 2792 | (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) |
| 2793 | (delete-by-moving-to-trash t)) | 2793 | (delete-by-moving-to-trash t)) |
| 2794 | (make-directory trash-directory) | 2794 | (make-directory trash-directory) |
| @@ -5247,7 +5247,7 @@ Use direct async.") | |||
| 5247 | ;; order to avoid a question. `explicit-sh-args' echoes the | 5247 | ;; order to avoid a question. `explicit-sh-args' echoes the |
| 5248 | ;; test data. | 5248 | ;; test data. |
| 5249 | (with-current-buffer (get-buffer-create "*shell*") | 5249 | (with-current-buffer (get-buffer-create "*shell*") |
| 5250 | (ignore-errors (kill-process (current-buffer))) | 5250 | (ignore-errors (kill-process (get-buffer-process (current-buffer)))) |
| 5251 | (should-not explicit-shell-file-name) | 5251 | (should-not explicit-shell-file-name) |
| 5252 | (call-interactively #'shell) | 5252 | (call-interactively #'shell) |
| 5253 | (with-timeout (10) | 5253 | (with-timeout (10) |
| @@ -5720,16 +5720,16 @@ This requires restrictions of file name syntax." | |||
| 5720 | (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) | 5720 | (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) |
| 5721 | 'tramp-ftp-file-name-handler)) | 5721 | 'tramp-ftp-file-name-handler)) |
| 5722 | 5722 | ||
| 5723 | (defun tramp--test-crypt-p () | ||
| 5724 | "Check, whether the remote directory is crypted" | ||
| 5725 | (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) | ||
| 5726 | |||
| 5723 | (defun tramp--test-docker-p () | 5727 | (defun tramp--test-docker-p () |
| 5724 | "Check, whether the docker method is used. | 5728 | "Check, whether the docker method is used. |
| 5725 | This does not support some special file names." | 5729 | This does not support some special file names." |
| 5726 | (string-equal | 5730 | (string-equal |
| 5727 | "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) | 5731 | "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) |
| 5728 | 5732 | ||
| 5729 | (defun tramp--test-crypt-p () | ||
| 5730 | "Check, whether the remote directory is crypted" | ||
| 5731 | (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) | ||
| 5732 | |||
| 5733 | (defun tramp--test-ftp-p () | 5733 | (defun tramp--test-ftp-p () |
| 5734 | "Check, whether an FTP-like method is used. | 5734 | "Check, whether an FTP-like method is used. |
| 5735 | This does not support globbing characters in file names (yet)." | 5735 | This does not support globbing characters in file names (yet)." |
| @@ -5748,7 +5748,7 @@ If optional METHOD is given, it is checked first." | |||
| 5748 | "Check, whether the remote host runs HP-UX. | 5748 | "Check, whether the remote host runs HP-UX. |
| 5749 | Several special characters do not work properly there." | 5749 | Several special characters do not work properly there." |
| 5750 | ;; We must refill the cache. `file-truename' does it. | 5750 | ;; We must refill the cache. `file-truename' does it. |
| 5751 | (file-truename tramp-test-temporary-file-directory) nil | 5751 | (file-truename tramp-test-temporary-file-directory) |
| 5752 | (string-match-p | 5752 | (string-match-p |
| 5753 | "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" ""))) | 5753 | "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" ""))) |
| 5754 | 5754 | ||
| @@ -5757,7 +5757,7 @@ Several special characters do not work properly there." | |||
| 5757 | ksh93 makes some strange conversions of non-latin characters into | 5757 | ksh93 makes some strange conversions of non-latin characters into |
| 5758 | a $'' syntax." | 5758 | a $'' syntax." |
| 5759 | ;; We must refill the cache. `file-truename' does it. | 5759 | ;; We must refill the cache. `file-truename' does it. |
| 5760 | (file-truename tramp-test-temporary-file-directory) nil | 5760 | (file-truename tramp-test-temporary-file-directory) |
| 5761 | (string-match-p | 5761 | (string-match-p |
| 5762 | "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" ""))) | 5762 | "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" ""))) |
| 5763 | 5763 | ||
| @@ -5787,6 +5787,15 @@ This does not support special file names." | |||
| 5787 | "Check, whether the remote host runs a based method from tramp-sh.el." | 5787 | "Check, whether the remote host runs a based method from tramp-sh.el." |
| 5788 | (tramp-sh-file-name-handler-p tramp-test-vec)) | 5788 | (tramp-sh-file-name-handler-p tramp-test-vec)) |
| 5789 | 5789 | ||
| 5790 | (defun tramp--test-sh-no-ls--dired-p () | ||
| 5791 | "Check, whether the remote host runs a based method from tramp-sh.el. | ||
| 5792 | Additionally, ls does not support \"--dired\"." | ||
| 5793 | (and (tramp--test-sh-p) | ||
| 5794 | (with-temp-buffer | ||
| 5795 | ;; We must refill the cache. `insert-directory' does it. | ||
| 5796 | (insert-directory tramp-test-temporary-file-directory "-al") | ||
| 5797 | (not (tramp-get-connection-property tramp-test-vec "ls--dired" nil))))) | ||
| 5798 | |||
| 5790 | (defun tramp--test-share-p () | 5799 | (defun tramp--test-share-p () |
| 5791 | "Check, whether the method needs a share." | 5800 | "Check, whether the method needs a share." |
| 5792 | (and (tramp--test-gvfs-p) | 5801 | (and (tramp--test-gvfs-p) |
| @@ -6023,17 +6032,20 @@ This requires restrictions of file name syntax." | |||
| 6023 | ;; expanded to <TAB>. | 6032 | ;; expanded to <TAB>. |
| 6024 | (let ((files | 6033 | (let ((files |
| 6025 | (list | 6034 | (list |
| 6026 | (if (or (tramp--test-ange-ftp-p) | 6035 | (cond ((or (tramp--test-ange-ftp-p) |
| 6027 | (tramp--test-gvfs-p) | 6036 | (tramp--test-gvfs-p) |
| 6028 | (tramp--test-rclone-p) | 6037 | (tramp--test-rclone-p) |
| 6029 | (tramp--test-sudoedit-p) | 6038 | (tramp--test-sudoedit-p) |
| 6030 | (tramp--test-windows-nt-or-smb-p)) | 6039 | (tramp--test-windows-nt-or-smb-p)) |
| 6031 | "foo bar baz" | 6040 | "foo bar baz") |
| 6032 | (if (or (tramp--test-adb-p) | 6041 | ((or (tramp--test-adb-p) |
| 6033 | (tramp--test-docker-p) | 6042 | (tramp--test-docker-p) |
| 6034 | (eq system-type 'cygwin)) | 6043 | (eq system-type 'cygwin)) |
| 6035 | " foo bar baz " | 6044 | " foo bar baz ") |
| 6036 | " foo\tbar baz\t")) | 6045 | ((tramp--test-sh-no-ls--dired-p) |
| 6046 | "\tfoo bar baz\t") | ||
| 6047 | (t " foo\tbar baz\t")) | ||
| 6048 | "@foo@bar@baz@" | ||
| 6037 | "$foo$bar$$baz$" | 6049 | "$foo$bar$$baz$" |
| 6038 | "-foo-bar-baz-" | 6050 | "-foo-bar-baz-" |
| 6039 | "%foo%bar%baz%" | 6051 | "%foo%bar%baz%" |
| @@ -6349,6 +6361,7 @@ process sentinels. They shall not disturb each other." | |||
| 6349 | (tramp--test-sh-p))) | 6361 | (tramp--test-sh-p))) |
| 6350 | (skip-unless (not (tramp--test-crypt-p))) | 6362 | (skip-unless (not (tramp--test-crypt-p))) |
| 6351 | (skip-unless (not (tramp--test-docker-p))) | 6363 | (skip-unless (not (tramp--test-docker-p))) |
| 6364 | (skip-unless (not (tramp--test-windows-nt-p))) | ||
| 6352 | 6365 | ||
| 6353 | (with-timeout | 6366 | (with-timeout |
| 6354 | (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler)) | 6367 | (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler)) |
| @@ -6358,12 +6371,11 @@ process sentinels. They shall not disturb each other." | |||
| 6358 | (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) | 6371 | (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) |
| 6359 | ;; It doesn't work on w32 systems. | 6372 | ;; It doesn't work on w32 systems. |
| 6360 | (watchdog | 6373 | (watchdog |
| 6361 | (unless (tramp--test-windows-nt-p) | 6374 | (start-process-shell-command |
| 6362 | (start-process-shell-command | 6375 | "*watchdog*" nil |
| 6363 | "*watchdog*" nil | 6376 | (format |
| 6364 | (format | 6377 | "sleep %d; kill -USR1 %d" |
| 6365 | "sleep %d; kill -USR1 %d" | 6378 | tramp--test-asynchronous-requests-timeout (emacs-pid)))) |
| 6366 | tramp--test-asynchronous-requests-timeout (emacs-pid))))) | ||
| 6367 | (tmp-name (tramp--test-make-temp-name)) | 6379 | (tmp-name (tramp--test-make-temp-name)) |
| 6368 | (default-directory tmp-name) | 6380 | (default-directory tmp-name) |
| 6369 | ;; Do not cache Tramp properties. | 6381 | ;; Do not cache Tramp properties. |
diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index a10d5dab906..0da0e393535 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el | |||
| @@ -314,7 +314,19 @@ | |||
| 314 | (let* ((xref (pop xrefs)) | 314 | (let* ((xref (pop xrefs)) |
| 315 | (expected (pop expected-xrefs)) | 315 | (expected (pop expected-xrefs)) |
| 316 | (expected-xref (or (when (consp expected) (car expected)) expected)) | 316 | (expected-xref (or (when (consp expected) (car expected)) expected)) |
| 317 | (expected-source (when (consp expected) (cdr expected)))) | 317 | (expected-source (when (consp expected) (cdr expected))) |
| 318 | (xref-file (xref-elisp-location-file (oref xref location))) | ||
| 319 | (expected-file (xref-elisp-location-file | ||
| 320 | (oref expected-xref location)))) | ||
| 321 | |||
| 322 | ;; Make sure file names compare as strings. | ||
| 323 | (when (file-name-absolute-p xref-file) | ||
| 324 | (setf (xref-elisp-location-file (oref xref location)) | ||
| 325 | (file-truename (xref-elisp-location-file (oref xref location))))) | ||
| 326 | (when (file-name-absolute-p expected-file) | ||
| 327 | (setf (xref-elisp-location-file (oref expected-xref location)) | ||
| 328 | (file-truename (xref-elisp-location-file | ||
| 329 | (oref expected-xref location))))) | ||
| 318 | 330 | ||
| 319 | ;; Downcase the filenames for case-insensitive file systems. | 331 | ;; Downcase the filenames for case-insensitive file systems. |
| 320 | (when xref--case-insensitive | 332 | (when xref--case-insensitive |
| @@ -822,5 +834,56 @@ to (xref-elisp-test-descr-to-target xref)." | |||
| 822 | (indent-region (point-min) (point-max)) | 834 | (indent-region (point-min) (point-max)) |
| 823 | (should (equal (buffer-string) orig))))) | 835 | (should (equal (buffer-string) orig))))) |
| 824 | 836 | ||
| 837 | (defun test--font (form search) | ||
| 838 | (with-temp-buffer | ||
| 839 | (emacs-lisp-mode) | ||
| 840 | (if (stringp form) | ||
| 841 | (insert form) | ||
| 842 | (pp form (current-buffer))) | ||
| 843 | (font-lock-debug-fontify) | ||
| 844 | (goto-char (point-min)) | ||
| 845 | (and (re-search-forward search nil t) | ||
| 846 | (get-text-property (match-beginning 1) 'face)))) | ||
| 847 | |||
| 848 | (ert-deftest test-elisp-font-keywords-1 () | ||
| 849 | ;; Special form. | ||
| 850 | (should (eq (test--font '(if foo bar) "(\\(if\\)") | ||
| 851 | 'font-lock-keyword-face)) | ||
| 852 | ;; Macro. | ||
| 853 | (should (eq (test--font '(when foo bar) "(\\(when\\)") | ||
| 854 | 'font-lock-keyword-face)) | ||
| 855 | (should (eq (test--font '(condition-case nil | ||
| 856 | (foo) | ||
| 857 | (error (if a b))) | ||
| 858 | "(\\(if\\)") | ||
| 859 | 'font-lock-keyword-face)) | ||
| 860 | (should (eq (test--font '(condition-case nil | ||
| 861 | (foo) | ||
| 862 | (when (if a b))) | ||
| 863 | "(\\(when\\)") | ||
| 864 | 'nil))) | ||
| 865 | |||
| 866 | (ert-deftest test-elisp-font-keywords-2 () | ||
| 867 | :expected-result :failed ; FIXME bug#43265 | ||
| 868 | (should (eq (test--font '(condition-case nil | ||
| 869 | (foo) | ||
| 870 | (error (when a b))) | ||
| 871 | "(\\(when\\)") | ||
| 872 | 'font-lock-keyword-face))) | ||
| 873 | |||
| 874 | (ert-deftest test-elisp-font-keywords-3 () | ||
| 875 | :expected-result :failed ; FIXME bug#43265 | ||
| 876 | (should (eq (test--font '(setq a '(if when zot)) | ||
| 877 | "(\\(if\\)") | ||
| 878 | nil))) | ||
| 879 | |||
| 880 | (ert-deftest test-elisp-font-keywords-if () | ||
| 881 | :expected-result :failed ; FIXME bug#43265 | ||
| 882 | (should (eq (test--font '(condition-case nil | ||
| 883 | (foo) | ||
| 884 | ((if foo) (when a b))) | ||
| 885 | "(\\(if\\)") | ||
| 886 | nil))) | ||
| 887 | |||
| 825 | (provide 'elisp-mode-tests) | 888 | (provide 'elisp-mode-tests) |
| 826 | ;;; elisp-mode-tests.el ends here | 889 | ;;; elisp-mode-tests.el ends here |
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 8c2682a1f13..2db570c97dd 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el | |||
| @@ -587,5 +587,18 @@ bound to HIGHLIGHT-LOCUS." | |||
| 587 | (get-text-property (point) 'occur-target)) | 587 | (get-text-property (point) 'occur-target)) |
| 588 | (should (funcall check-overlays has-overlay))))))) | 588 | (should (funcall check-overlays has-overlay))))))) |
| 589 | 589 | ||
| 590 | (ert-deftest replace-regexp-bug45973 () | ||
| 591 | "Test for https://debbugs.gnu.org/45973 ." | ||
| 592 | (let ((before "1RB 1LC 1RC 1RB 1RD 0LE 1LA 1LD 1RH 0LA") | ||
| 593 | (after "1LB 1RC 1LC 1LB 1LD 0RE 1RA 1RD 1LH 0RA")) | ||
| 594 | (with-temp-buffer | ||
| 595 | (insert before) | ||
| 596 | (goto-char (point-min)) | ||
| 597 | (replace-regexp | ||
| 598 | "\\(\\(L\\)\\|\\(R\\)\\)" | ||
| 599 | '(replace-eval-replacement | ||
| 600 | replace-quote | ||
| 601 | (if (match-string 2) "R" "L"))) | ||
| 602 | (should (equal (buffer-string) after))))) | ||
| 590 | 603 | ||
| 591 | ;;; replace-tests.el ends here | 604 | ;;; replace-tests.el ends here |
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index c43c81af9fd..62a27f09cbd 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el | |||
| @@ -146,4 +146,48 @@ position to retrieve THING.") | |||
| 146 | (should (thing-at-point-looking-at "2abcd")) | 146 | (should (thing-at-point-looking-at "2abcd")) |
| 147 | (should (equal (match-data) m2))))) | 147 | (should (equal (match-data) m2))))) |
| 148 | 148 | ||
| 149 | (ert-deftest test-symbol-thing-1 () | ||
| 150 | (with-temp-buffer | ||
| 151 | (insert "foo bar zot") | ||
| 152 | (goto-char 4) | ||
| 153 | (should (eq (symbol-at-point) 'foo)) | ||
| 154 | (forward-char 1) | ||
| 155 | (should (eq (symbol-at-point) 'bar)) | ||
| 156 | (forward-char 1) | ||
| 157 | (should (eq (symbol-at-point) 'bar)) | ||
| 158 | (forward-char 1) | ||
| 159 | (should (eq (symbol-at-point) 'bar)) | ||
| 160 | (forward-char 1) | ||
| 161 | (should (eq (symbol-at-point) 'bar)) | ||
| 162 | (forward-char 1) | ||
| 163 | (should (eq (symbol-at-point) 'zot)))) | ||
| 164 | |||
| 165 | (ert-deftest test-symbol-thing-2 () | ||
| 166 | (with-temp-buffer | ||
| 167 | (insert " bar ") | ||
| 168 | (goto-char (point-max)) | ||
| 169 | (should (eq (symbol-at-point) nil)) | ||
| 170 | (forward-char -1) | ||
| 171 | (should (eq (symbol-at-point) 'bar)))) | ||
| 172 | |||
| 173 | (ert-deftest test-symbol-thing-2 () | ||
| 174 | (with-temp-buffer | ||
| 175 | (insert " bar ") | ||
| 176 | (goto-char (point-max)) | ||
| 177 | (should (eq (symbol-at-point) nil)) | ||
| 178 | (forward-char -1) | ||
| 179 | (should (eq (symbol-at-point) 'bar)))) | ||
| 180 | |||
| 181 | (ert-deftest test-symbol-thing-3 () | ||
| 182 | (with-temp-buffer | ||
| 183 | (insert "bar") | ||
| 184 | (goto-char 2) | ||
| 185 | (should (eq (symbol-at-point) 'bar)))) | ||
| 186 | |||
| 187 | (ert-deftest test-symbol-thing-3 () | ||
| 188 | (with-temp-buffer | ||
| 189 | (insert "`[[`(") | ||
| 190 | (goto-char 2) | ||
| 191 | (should (eq (symbol-at-point) nil)))) | ||
| 192 | |||
| 149 | ;;; thingatpt.el ends here | 193 | ;;; thingatpt.el ends here |
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index 81488c3df19..4ae3c1917dd 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el | |||
| @@ -262,40 +262,48 @@ | |||
| 262 | (ert-deftest time-stamp-format-day-of-week () | 262 | (ert-deftest time-stamp-format-day-of-week () |
| 263 | "Test time-stamp formats for named day of week." | 263 | "Test time-stamp formats for named day of week." |
| 264 | (with-time-stamp-test-env | 264 | (with-time-stamp-test-env |
| 265 | ;; implemented and documented since 1997 | 265 | (let ((Mon (format-time-string "%a" ref-time1 t)) |
| 266 | (should (equal (time-stamp-string "%3a" ref-time1) "Mon")) | 266 | (MON (format-time-string "%^a" ref-time1 t)) |
| 267 | (should (equal (time-stamp-string "%#A" ref-time1) "MONDAY")) | 267 | (Monday (format-time-string "%A" ref-time1 t)) |
| 268 | ;; documented 1997-2019 | 268 | (MONDAY (format-time-string "%^A" ref-time1 t))) |
| 269 | (should (equal (time-stamp-string "%3A" ref-time1) "MON")) | 269 | ;; implemented and documented since 1997 |
| 270 | (should (equal (time-stamp-string "%:a" ref-time1) "Monday")) | 270 | (should (equal (time-stamp-string "%3a" ref-time1) Mon)) |
| 271 | ;; implemented since 2001, documented since 2019 | 271 | (should (equal (time-stamp-string "%#A" ref-time1) MONDAY)) |
| 272 | (should (equal (time-stamp-string "%#a" ref-time1) "MON")) | 272 | ;; documented 1997-2019 |
| 273 | (should (equal (time-stamp-string "%:A" ref-time1) "Monday")) | 273 | (should (equal (time-stamp-string "%3A" ref-time1) MON)) |
| 274 | ;; allowed but undocumented since 2019 (warned 1997-2019) | 274 | (should (equal (time-stamp-string "%:a" ref-time1) Monday)) |
| 275 | (should (equal (time-stamp-string "%^A" ref-time1) "MONDAY")) | 275 | ;; implemented since 2001, documented since 2019 |
| 276 | ;; warned 1997-2019, changed in 2019 | 276 | (should (equal (time-stamp-string "%#a" ref-time1) MON)) |
| 277 | (should (equal (time-stamp-string "%a" ref-time1) "Mon")) | 277 | (should (equal (time-stamp-string "%:A" ref-time1) Monday)) |
| 278 | (should (equal (time-stamp-string "%^a" ref-time1) "MON")) | 278 | ;; allowed but undocumented since 2019 (warned 1997-2019) |
| 279 | (should (equal (time-stamp-string "%A" ref-time1) "Monday")))) | 279 | (should (equal (time-stamp-string "%^A" ref-time1) MONDAY)) |
| 280 | ;; warned 1997-2019, changed in 2019 | ||
| 281 | (should (equal (time-stamp-string "%a" ref-time1) Mon)) | ||
| 282 | (should (equal (time-stamp-string "%^a" ref-time1) MON)) | ||
| 283 | (should (equal (time-stamp-string "%A" ref-time1) Monday))))) | ||
| 280 | 284 | ||
| 281 | (ert-deftest time-stamp-format-month-name () | 285 | (ert-deftest time-stamp-format-month-name () |
| 282 | "Test time-stamp formats for month name." | 286 | "Test time-stamp formats for month name." |
| 283 | (with-time-stamp-test-env | 287 | (with-time-stamp-test-env |
| 284 | ;; implemented and documented since 1997 | 288 | (let ((Jan (format-time-string "%b" ref-time1 t)) |
| 285 | (should (equal (time-stamp-string "%3b" ref-time1) "Jan")) | 289 | (JAN (format-time-string "%^b" ref-time1 t)) |
| 286 | (should (equal (time-stamp-string "%#B" ref-time1) "JANUARY")) | 290 | (January (format-time-string "%B" ref-time1 t)) |
| 287 | ;; documented 1997-2019 | 291 | (JANUARY (format-time-string "%^B" ref-time1 t))) |
| 288 | (should (equal (time-stamp-string "%3B" ref-time1) "JAN")) | 292 | ;; implemented and documented since 1997 |
| 289 | (should (equal (time-stamp-string "%:b" ref-time1) "January")) | 293 | (should (equal (time-stamp-string "%3b" ref-time1) Jan)) |
| 290 | ;; implemented since 2001, documented since 2019 | 294 | (should (equal (time-stamp-string "%#B" ref-time1) JANUARY)) |
| 291 | (should (equal (time-stamp-string "%#b" ref-time1) "JAN")) | 295 | ;; documented 1997-2019 |
| 292 | (should (equal (time-stamp-string "%:B" ref-time1) "January")) | 296 | (should (equal (time-stamp-string "%3B" ref-time1) JAN)) |
| 293 | ;; allowed but undocumented since 2019 (warned 1997-2019) | 297 | (should (equal (time-stamp-string "%:b" ref-time1) January)) |
| 294 | (should (equal (time-stamp-string "%^B" ref-time1) "JANUARY")) | 298 | ;; implemented since 2001, documented since 2019 |
| 295 | ;; warned 1997-2019, changed in 2019 | 299 | (should (equal (time-stamp-string "%#b" ref-time1) JAN)) |
| 296 | (should (equal (time-stamp-string "%b" ref-time1) "Jan")) | 300 | (should (equal (time-stamp-string "%:B" ref-time1) January)) |
| 297 | (should (equal (time-stamp-string "%^b" ref-time1) "JAN")) | 301 | ;; allowed but undocumented since 2019 (warned 1997-2019) |
| 298 | (should (equal (time-stamp-string "%B" ref-time1) "January")))) | 302 | (should (equal (time-stamp-string "%^B" ref-time1) JANUARY)) |
| 303 | ;; warned 1997-2019, changed in 2019 | ||
| 304 | (should (equal (time-stamp-string "%b" ref-time1) Jan)) | ||
| 305 | (should (equal (time-stamp-string "%^b" ref-time1) JAN)) | ||
| 306 | (should (equal (time-stamp-string "%B" ref-time1) January))))) | ||
| 299 | 307 | ||
| 300 | (ert-deftest time-stamp-format-day-of-month () | 308 | (ert-deftest time-stamp-format-day-of-month () |
| 301 | "Test time-stamp formats for day of month." | 309 | "Test time-stamp formats for day of month." |
| @@ -483,14 +491,18 @@ | |||
| 483 | (ert-deftest time-stamp-format-am-pm () | 491 | (ert-deftest time-stamp-format-am-pm () |
| 484 | "Test time-stamp formats for AM and PM strings." | 492 | "Test time-stamp formats for AM and PM strings." |
| 485 | (with-time-stamp-test-env | 493 | (with-time-stamp-test-env |
| 486 | ;; implemented and documented since 1997 | 494 | (let ((pm (format-time-string "%#p" ref-time1 t)) |
| 487 | (should (equal (time-stamp-string "%#p" ref-time1) "pm")) | 495 | (am (format-time-string "%#p" ref-time3 t)) |
| 488 | (should (equal (time-stamp-string "%#p" ref-time3) "am")) | 496 | (PM (format-time-string "%p" ref-time1 t)) |
| 489 | (should (equal (time-stamp-string "%P" ref-time1) "PM")) | 497 | (AM (format-time-string "%p" ref-time3 t))) |
| 490 | (should (equal (time-stamp-string "%P" ref-time3) "AM")) | 498 | ;; implemented and documented since 1997 |
| 491 | ;; warned 1997-2019, changed in 2019 | 499 | (should (equal (time-stamp-string "%#p" ref-time1) pm)) |
| 492 | (should (equal (time-stamp-string "%p" ref-time1) "PM")) | 500 | (should (equal (time-stamp-string "%#p" ref-time3) am)) |
| 493 | (should (equal (time-stamp-string "%p" ref-time3) "AM")))) | 501 | (should (equal (time-stamp-string "%P" ref-time1) PM)) |
| 502 | (should (equal (time-stamp-string "%P" ref-time3) AM)) | ||
| 503 | ;; warned 1997-2019, changed in 2019 | ||
| 504 | (should (equal (time-stamp-string "%p" ref-time1) PM)) | ||
| 505 | (should (equal (time-stamp-string "%p" ref-time3) AM))))) | ||
| 494 | 506 | ||
| 495 | (ert-deftest time-stamp-format-day-number-in-week () | 507 | (ert-deftest time-stamp-format-day-number-in-week () |
| 496 | "Test time-stamp formats for day number in week." | 508 | "Test time-stamp formats for day number in week." |
| @@ -567,10 +579,15 @@ | |||
| 567 | (ert-deftest time-stamp-format-ignored-modifiers () | 579 | (ert-deftest time-stamp-format-ignored-modifiers () |
| 568 | "Test additional args allowed (but ignored) to allow for future expansion." | 580 | "Test additional args allowed (but ignored) to allow for future expansion." |
| 569 | (with-time-stamp-test-env | 581 | (with-time-stamp-test-env |
| 570 | ;; allowed modifiers | 582 | (let ((May (format-time-string "%B" ref-time3 t))) |
| 571 | (should (equal (time-stamp-string "%.,@-+_ ^(stuff)P" ref-time3) "AM")) | 583 | ;; allowed modifiers |
| 572 | ;; not all punctuation is allowed | 584 | (should (equal (time-stamp-string "%.,@+ (stuff)B" ref-time3) May)) |
| 573 | (should-not (equal (time-stamp-string "%&P" ref-time3) "AM")))) | 585 | ;; parens nest |
| 586 | (should (equal (time-stamp-string "%(st(u)ff)B" ref-time3) May)) | ||
| 587 | ;; escaped parens do not change the nesting level | ||
| 588 | (should (equal (time-stamp-string "%(st\\)u\\(ff)B" ref-time3) May)) | ||
| 589 | ;; not all punctuation is allowed | ||
| 590 | (should-not (equal (time-stamp-string "%&B" ref-time3) May))))) | ||
| 574 | 591 | ||
| 575 | (ert-deftest time-stamp-format-non-conversions () | 592 | (ert-deftest time-stamp-format-non-conversions () |
| 576 | "Test that without a %, the text is copied literally." | 593 | "Test that without a %, the text is copied literally." |
| @@ -580,16 +597,22 @@ | |||
| 580 | (ert-deftest time-stamp-format-string-width () | 597 | (ert-deftest time-stamp-format-string-width () |
| 581 | "Test time-stamp string width modifiers." | 598 | "Test time-stamp string width modifiers." |
| 582 | (with-time-stamp-test-env | 599 | (with-time-stamp-test-env |
| 583 | ;; strings truncate on the right or are blank-padded on the left | 600 | (let ((May (format-time-string "%b" ref-time3 t)) |
| 584 | (should (equal (time-stamp-string "%0P" ref-time3) "")) | 601 | (SUN (format-time-string "%^a" ref-time3 t)) |
| 585 | (should (equal (time-stamp-string "%1P" ref-time3) "A")) | 602 | (NOV (format-time-string "%^b" ref-time2 t))) |
| 586 | (should (equal (time-stamp-string "%2P" ref-time3) "AM")) | 603 | ;; strings truncate on the right or are blank-padded on the left |
| 587 | (should (equal (time-stamp-string "%3P" ref-time3) " AM")) | 604 | (should (equal (time-stamp-string "%0b" ref-time3) "")) |
| 588 | (should (equal (time-stamp-string "%0%" ref-time3) "")) | 605 | (should (equal (time-stamp-string "%1b" ref-time3) (substring May 0 1))) |
| 589 | (should (equal (time-stamp-string "%1%" ref-time3) "%")) | 606 | (should (equal (time-stamp-string "%2b" ref-time3) (substring May 0 2))) |
| 590 | (should (equal (time-stamp-string "%2%" ref-time3) " %")) | 607 | (should (equal (time-stamp-string "%3b" ref-time3) May)) |
| 591 | (should (equal (time-stamp-string "%#3a" ref-time3) "SUN")) | 608 | (should (equal (time-stamp-string "%4b" ref-time3) (concat " " May))) |
| 592 | (should (equal (time-stamp-string "%#3b" ref-time2) "NOV")))) | 609 | (should (equal (time-stamp-string "%0%" ref-time3) "")) |
| 610 | (should (equal (time-stamp-string "%1%" ref-time3) "%")) | ||
| 611 | (should (equal (time-stamp-string "%2%" ref-time3) " %")) | ||
| 612 | (should (equal (time-stamp-string "%9%" ref-time3) " %")) | ||
| 613 | (should (equal (time-stamp-string "%10%" ref-time3) " %")) | ||
| 614 | (should (equal (time-stamp-string "%#3a" ref-time3) SUN)) | ||
| 615 | (should (equal (time-stamp-string "%#3b" ref-time2) NOV))))) | ||
| 593 | 616 | ||
| 594 | ;;; Tests of helper functions | 617 | ;;; Tests of helper functions |
| 595 | 618 | ||
diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el index 17fdfefce84..f843649784a 100644 --- a/test/lisp/wid-edit-tests.el +++ b/test/lisp/wid-edit-tests.el | |||
| @@ -322,4 +322,15 @@ return nil, even with a non-nil bubblep argument." | |||
| 322 | (widget-backward 1) | 322 | (widget-backward 1) |
| 323 | (should (string= "Second" (widget-value (widget-at)))))) | 323 | (should (string= "Second" (widget-value (widget-at)))))) |
| 324 | 324 | ||
| 325 | (ert-deftest widget-test-color-match () | ||
| 326 | "Test that the :match function for the color widget works." | ||
| 327 | (let ((widget (widget-convert 'color))) | ||
| 328 | (should (widget-apply widget :match "red")) | ||
| 329 | (should (widget-apply widget :match "#fa3")) | ||
| 330 | (should (widget-apply widget :match "#ff0000")) | ||
| 331 | (should (widget-apply widget :match "#111222333")) | ||
| 332 | (should (widget-apply widget :match "#111122223333")) | ||
| 333 | (should-not (widget-apply widget :match "someundefinedcolorihope")) | ||
| 334 | (should-not (widget-apply widget :match "#11223")))) | ||
| 335 | |||
| 325 | ;;; wid-edit-tests.el ends here | 336 | ;;; wid-edit-tests.el ends here |
diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 57097cfa052..a3fba8d328b 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el | |||
| @@ -576,11 +576,6 @@ FD_SETSIZE file descriptors (Bug#24325)." | |||
| 576 | (should (memq (process-status process) '(run exit))) | 576 | (should (memq (process-status process) '(run exit))) |
| 577 | (when (process-live-p process) | 577 | (when (process-live-p process) |
| 578 | (process-send-eof process)) | 578 | (process-send-eof process)) |
| 579 | ;; FIXME: This `sleep-for' shouldn't be needed. It | ||
| 580 | ;; indicates a bug in Emacs; perhaps SIGCHLD is | ||
| 581 | ;; received in parallel with `accept-process-output', | ||
| 582 | ;; causing the latter to hang. | ||
| 583 | (sleep-for 0.1) | ||
| 584 | (while (accept-process-output process)) | 579 | (while (accept-process-output process)) |
| 585 | (should (eq (process-status process) 'exit)) | 580 | (should (eq (process-status process) 'exit)) |
| 586 | ;; If there's an error between fork and exec, Emacs | 581 | ;; If there's an error between fork and exec, Emacs |
| @@ -739,5 +734,150 @@ Return nil if that can't be determined." | |||
| 739 | (match-string-no-properties 1)))))) | 734 | (match-string-no-properties 1)))))) |
| 740 | process-tests--EMFILE-message) | 735 | process-tests--EMFILE-message) |
| 741 | 736 | ||
| 737 | (ert-deftest process-tests/sentinel-called () | ||
| 738 | "Check that sentinels are called after processes finish" | ||
| 739 | (let ((command (process-tests--emacs-command))) | ||
| 740 | (skip-unless command) | ||
| 741 | (dolist (conn-type '(pipe pty)) | ||
| 742 | (ert-info ((format "Connection type: %s" conn-type)) | ||
| 743 | (process-tests--with-processes processes | ||
| 744 | (let* ((calls ()) | ||
| 745 | (process (make-process | ||
| 746 | :name "echo" | ||
| 747 | :command (process-tests--eval | ||
| 748 | command '(print "first")) | ||
| 749 | :noquery t | ||
| 750 | :connection-type conn-type | ||
| 751 | :coding 'utf-8-unix | ||
| 752 | :sentinel (lambda (process message) | ||
| 753 | (push (list process message) | ||
| 754 | calls))))) | ||
| 755 | (push process processes) | ||
| 756 | (while (accept-process-output process)) | ||
| 757 | (should (equal calls | ||
| 758 | (list (list process "finished\n")))))))))) | ||
| 759 | |||
| 760 | (ert-deftest process-tests/sentinel-with-multiple-processes () | ||
| 761 | "Check that sentinels are called in time even when other processes | ||
| 762 | have written output." | ||
| 763 | (let ((command (process-tests--emacs-command))) | ||
| 764 | (skip-unless command) | ||
| 765 | (dolist (conn-type '(pipe pty)) | ||
| 766 | (ert-info ((format "Connection type: %s" conn-type)) | ||
| 767 | (process-tests--with-processes processes | ||
| 768 | (let* ((calls ()) | ||
| 769 | (process (make-process | ||
| 770 | :name "echo" | ||
| 771 | :command (process-tests--eval | ||
| 772 | command '(print "first")) | ||
| 773 | :noquery t | ||
| 774 | :connection-type conn-type | ||
| 775 | :coding 'utf-8-unix | ||
| 776 | :sentinel (lambda (process message) | ||
| 777 | (push (list process message) | ||
| 778 | calls))))) | ||
| 779 | (push process processes) | ||
| 780 | (push (make-process | ||
| 781 | :name "bash" | ||
| 782 | :command (process-tests--eval | ||
| 783 | command | ||
| 784 | '(progn (sleep-for 10) (print "second"))) | ||
| 785 | :noquery t | ||
| 786 | :connection-type conn-type) | ||
| 787 | processes) | ||
| 788 | (while (accept-process-output process)) | ||
| 789 | (should (equal calls | ||
| 790 | (list (list process "finished\n")))))))))) | ||
| 791 | |||
| 792 | (ert-deftest process-tests/multiple-threads-waiting () | ||
| 793 | (skip-unless (fboundp 'make-thread)) | ||
| 794 | (with-timeout (60 (ert-fail "Test timed out")) | ||
| 795 | (process-tests--with-processes processes | ||
| 796 | (let ((threads ()) | ||
| 797 | (cat (executable-find "cat"))) | ||
| 798 | (skip-unless cat) | ||
| 799 | (dotimes (i 10) | ||
| 800 | (let* ((name (format "test %d" i)) | ||
| 801 | (process (make-process :name name | ||
| 802 | :command (list cat) | ||
| 803 | :coding 'no-conversion | ||
| 804 | :noquery t | ||
| 805 | :connection-type 'pipe))) | ||
| 806 | (push process processes) | ||
| 807 | (set-process-thread process nil) | ||
| 808 | (push (make-thread | ||
| 809 | (lambda () | ||
| 810 | (while (accept-process-output process))) | ||
| 811 | name) | ||
| 812 | threads))) | ||
| 813 | (mapc #'process-send-eof processes) | ||
| 814 | (cl-loop for process in processes | ||
| 815 | and thread in threads | ||
| 816 | do | ||
| 817 | (should-not (thread-join thread)) | ||
| 818 | (should-not (thread-last-error)) | ||
| 819 | (should (eq (process-status process) 'exit)) | ||
| 820 | (should (eql (process-exit-status process) 0))))))) | ||
| 821 | |||
| 822 | (defun process-tests--eval (command form) | ||
| 823 | "Return a command that evaluates FORM in an Emacs subprocess. | ||
| 824 | COMMAND must be a list returned by | ||
| 825 | `process-tests--emacs-command'." | ||
| 826 | (let ((print-gensym t) | ||
| 827 | (print-circle t) | ||
| 828 | (print-length nil) | ||
| 829 | (print-level nil) | ||
| 830 | (print-escape-control-characters t) | ||
| 831 | (print-escape-newlines t) | ||
| 832 | (print-escape-multibyte t) | ||
| 833 | (print-escape-nonascii t)) | ||
| 834 | `(,@command "--quick" "--batch" ,(format "--eval=%S" form)))) | ||
| 835 | |||
| 836 | (defun process-tests--emacs-command () | ||
| 837 | "Return a command to reinvoke the current Emacs instance. | ||
| 838 | Return nil if that doesn't appear to be possible." | ||
| 839 | (when-let ((binary (process-tests--emacs-binary)) | ||
| 840 | (dump (process-tests--dump-file))) | ||
| 841 | (cons binary | ||
| 842 | (unless (eq dump :not-needed) | ||
| 843 | (list (concat "--dump-file=" | ||
| 844 | (file-name-unquote dump))))))) | ||
| 845 | |||
| 846 | (defun process-tests--emacs-binary () | ||
| 847 | "Return the filename of the currently running Emacs binary. | ||
| 848 | Return nil if that can't be determined." | ||
| 849 | (and (stringp invocation-name) | ||
| 850 | (not (file-remote-p invocation-name)) | ||
| 851 | (not (file-name-absolute-p invocation-name)) | ||
| 852 | (stringp invocation-directory) | ||
| 853 | (not (file-remote-p invocation-directory)) | ||
| 854 | (file-name-absolute-p invocation-directory) | ||
| 855 | (when-let ((file (process-tests--usable-file-for-reinvoke | ||
| 856 | (expand-file-name invocation-name | ||
| 857 | invocation-directory)))) | ||
| 858 | (and (file-executable-p file) file)))) | ||
| 859 | |||
| 860 | (defun process-tests--dump-file () | ||
| 861 | "Return the filename of the dump file used to start Emacs. | ||
| 862 | Return nil if that can't be determined. Return `:not-needed' if | ||
| 863 | Emacs wasn't started with a dump file." | ||
| 864 | (if-let ((stats (and (fboundp 'pdumper-stats) (pdumper-stats)))) | ||
| 865 | (when-let ((file (process-tests--usable-file-for-reinvoke | ||
| 866 | (cdr (assq 'dump-file-name stats))))) | ||
| 867 | (and (file-readable-p file) file)) | ||
| 868 | :not-needed)) | ||
| 869 | |||
| 870 | (defun process-tests--usable-file-for-reinvoke (filename) | ||
| 871 | "Return a version of FILENAME that can be used to reinvoke Emacs. | ||
| 872 | Return nil if FILENAME doesn't exist." | ||
| 873 | (when (and (stringp filename) | ||
| 874 | (not (file-remote-p filename))) | ||
| 875 | (cl-callf file-truename filename) | ||
| 876 | (and (stringp filename) | ||
| 877 | (not (file-remote-p filename)) | ||
| 878 | (file-name-absolute-p filename) | ||
| 879 | (file-regular-p filename) | ||
| 880 | filename))) | ||
| 881 | |||
| 742 | (provide 'process-tests) | 882 | (provide 'process-tests) |
| 743 | ;;; process-tests.el ends here | 883 | ;;; process-tests.el ends here |
diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el index ec96d777ffb..4e7d2ad8ab2 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el | |||
| @@ -75,31 +75,28 @@ | |||
| 75 | (ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748 | 75 | (ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748 |
| 76 | (with-temp-buffer | 76 | (with-temp-buffer |
| 77 | (insert "xxx") | 77 | (insert "xxx") |
| 78 | (let* ((window | 78 | (switch-to-buffer (current-buffer)) |
| 79 | (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) | 79 | (let* ((char-width (frame-char-width)) |
| 80 | (char-width (frame-char-width)) | 80 | (size (window-text-pixel-size nil t t)) |
| 81 | (size (window-text-pixel-size nil t t))) | 81 | (width-in-chars (/ (car size) char-width))) |
| 82 | (delete-frame (window-frame window)) | 82 | (should (equal width-in-chars 3))))) |
| 83 | (should (equal (/ (car size) char-width) 3))))) | ||
| 84 | 83 | ||
| 85 | (ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748 | 84 | (ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748 |
| 86 | (with-temp-buffer | 85 | (with-temp-buffer |
| 87 | (insert " xx") | 86 | (insert " xx") |
| 88 | (let* ((window | 87 | (switch-to-buffer (current-buffer)) |
| 89 | (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) | 88 | (let* ((char-width (frame-char-width)) |
| 90 | (char-width (frame-char-width)) | 89 | (size (window-text-pixel-size nil t t)) |
| 91 | (size (window-text-pixel-size nil t t))) | 90 | (width-in-chars (/ (car size) char-width))) |
| 92 | (delete-frame (window-frame window)) | 91 | (should (equal width-in-chars 3))))) |
| 93 | (should (equal (/ (car size) char-width) 3))))) | ||
| 94 | 92 | ||
| 95 | (ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748 | 93 | (ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748 |
| 96 | (with-temp-buffer | 94 | (with-temp-buffer |
| 97 | (insert "xx ") | 95 | (insert "xx ") |
| 98 | (let* ((window | 96 | (switch-to-buffer (current-buffer)) |
| 99 | (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) | 97 | (let* ((char-width (frame-char-width)) |
| 100 | (char-width (frame-char-width)) | 98 | (size (window-text-pixel-size nil t t)) |
| 101 | (size (window-text-pixel-size nil t t))) | 99 | (width-in-chars (/ (car size) char-width))) |
| 102 | (delete-frame (window-frame window)) | 100 | (should (equal width-in-chars 3))))) |
| 103 | (should (equal (/ (car size) char-width) 3))))) | ||
| 104 | 101 | ||
| 105 | ;;; xdisp-tests.el ends here | 102 | ;;; xdisp-tests.el ends here |