[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/pgtk 7d5e94b: Merge branch 'master' of git.sv.gnu.org:/srv/git/e
|
From: |
Yuuki Harano |
|
Subject: |
feature/pgtk 7d5e94b: Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs into feature/pgtk |
|
Date: |
Sun, 13 Jun 2021 04:48:19 -0400 (EDT) |
branch: feature/pgtk
commit 7d5e94bada09e642a8bfc4f66804f7948bad40bc
Merge: 7673b6b dc471fe
Author: Yuuki Harano <masm+github@masm11.me>
Commit: Yuuki Harano <masm+github@masm11.me>
Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs into feature/pgtk
---
configure.ac | 31 +-
doc/emacs/display.texi | 40 +-
doc/emacs/docstyle.texi | 1 +
doc/emacs/fixit.texi | 2 +-
doc/emacs/killing.texi | 56 +-
doc/emacs/misc.texi | 6 +
doc/emacs/windows.texi | 3 +
doc/lispref/help.texi | 18 +-
doc/lispref/internals.texi | 2 +-
doc/lispref/macros.texi | 2 -
doc/lispref/modes.texi | 3 +-
doc/lispref/os.texi | 22 +-
doc/lispref/searching.texi | 9 +-
doc/lispref/syntax.texi | 14 +-
doc/lispref/variables.texi | 6 +
doc/lispref/windows.texi | 65 +-
doc/man/emacs.1.in | 4 +-
doc/man/etags.1 | 23 +-
doc/misc/eieio.texi | 88 +-
doc/misc/emacs-mime.texi | 5 +
doc/misc/erc.texi | 4 +-
doc/misc/gnus.texi | 39 +-
etc/NEWS | 130 +-
lib-src/etags.c | 505 ++++-
lib/Makefile.in | 2 +-
lisp/Makefile.in | 4 +-
lisp/auth-source.el | 4 +-
lisp/cedet/ede/base.el | 46 +-
lisp/cedet/ede/config.el | 2 +-
lisp/cedet/ede/generic.el | 2 +-
lisp/cedet/ede/proj-obj.el | 4 +-
lisp/cedet/ede/proj.el | 12 +-
lisp/cedet/semantic/db-ebrowse.el | 4 +-
lisp/cedet/semantic/db-el.el | 4 +-
lisp/cedet/semantic/db-javascript.el | 4 +-
lisp/cedet/semantic/db.el | 4 +-
lisp/cedet/semantic/ede-grammar.el | 12 +-
lisp/cedet/semantic/symref/grep.el | 2 +-
lisp/cedet/srecode/compile.el | 7 +-
lisp/cedet/srecode/insert.el | 17 +-
lisp/custom.el | 2 +-
lisp/dired-aux.el | 15 +-
lisp/dired.el | 68 +-
lisp/electric.el | 5 +-
lisp/emacs-lisp/benchmark.el | 3 +-
lisp/emacs-lisp/byte-opt.el | 10 +-
lisp/emacs-lisp/bytecomp.el | 4 +-
lisp/emacs-lisp/chart.el | 2 +-
lisp/emacs-lisp/comp.el | 33 +-
lisp/emacs-lisp/eieio-base.el | 2 +-
lisp/emacs-lisp/eieio-core.el | 127 +-
lisp/emacs-lisp/eieio-custom.el | 2 +-
lisp/emacs-lisp/eieio-speedbar.el | 10 +-
lisp/emacs-lisp/eieio.el | 57 +-
lisp/emacs-lisp/elp.el | 18 +-
lisp/emacs-lisp/shortdoc.el | 48 +
lisp/emacs-lisp/syntax.el | 4 +
lisp/epa-ks.el | 40 +-
lisp/erc/erc.el | 4 +-
lisp/eshell/em-hist.el | 2 +-
lisp/fileloop.el | 3 +-
lisp/files.el | 7 +-
lisp/format.el | 2 +-
lisp/fringe.el | 11 +-
lisp/gnus/gnus-art.el | 144 +-
lisp/gnus/gnus-group.el | 42 +-
lisp/gnus/gnus-sum.el | 22 +-
lisp/gnus/gnus-topic.el | 15 +-
lisp/gnus/gnus.el | 8 +
lisp/gnus/nnimap.el | 5 +-
lisp/help-fns.el | 56 +-
lisp/hl-line.el | 5 +-
lisp/ibuffer.el | 7 +-
lisp/icomplete.el | 424 +++--
lisp/indent.el | 4 +-
lisp/isearch.el | 8 +-
lisp/kmacro.el | 2 +-
lisp/ldefs-boot.el | 259 ++-
lisp/leim/quail/latin-ltx.el | 52 +
lisp/menu-bar.el | 1 +
lisp/mh-e/mh-e.el | 7 +-
lisp/minibuffer.el | 37 +-
lisp/mpc.el | 33 +-
lisp/msb.el | 9 +-
lisp/net/browse-url.el | 36 +-
lisp/net/mailcap.el | 23 +
lisp/net/rcirc.el | 3 +-
lisp/net/tramp.el | 2 +-
lisp/progmodes/etags.el | 4 +-
lisp/progmodes/fortran.el | 143 +-
lisp/progmodes/grep.el | 39 +-
lisp/progmodes/hideif.el | 1217 +++++++++---
lisp/progmodes/octave.el | 2 +-
lisp/progmodes/perl-mode.el | 2 +-
lisp/progmodes/xref.el | 2 +-
lisp/server.el | 15 +-
lisp/shell.el | 17 +-
lisp/simple.el | 39 +-
lisp/so-long.el | 8 +-
lisp/subr.el | 14 +-
lisp/term/x-win.el | 2 +-
lisp/textmodes/flyspell.el | 27 +-
lisp/textmodes/tex-mode.el | 12 +-
lisp/time-stamp.el | 376 ++--
lisp/transient.el | 8 +-
lisp/vc/ediff-diff.el | 5 +-
lisp/vc/vc-git.el | 18 +-
lisp/wdired.el | 33 +-
lisp/whitespace.el | 3 +
lisp/wid-edit.el | 5 +-
lisp/windmove.el | 175 +-
lisp/window.el | 160 +-
lisp/xdg.el | 2 +-
src/character.c | 16 +-
src/character.h | 2 +-
src/composite.c | 76 +-
src/composite.h | 23 +-
src/data.c | 4 +-
src/editfns.c | 2 +-
src/frame.c | 12 +-
src/frame.h | 5 +
src/image.c | 23 +-
src/keyboard.c | 122 +-
src/minibuf.c | 2 +-
src/nsfns.m | 16 +-
src/nsimage.m | 9 +-
src/nsterm.h | 6 +-
src/nsterm.m | 158 +-
src/window.c | 35 +-
src/xdisp.c | 33 +-
.../cperl-mode-resources/cperl-bug-22355.pl | 14 +
.../cperl-mode-resources/cperl-bug-23992.pl | 10 +
.../cperl-mode-resources/cperl-bug-25098.pl | 21 +
test/lisp/progmodes/cperl-mode-tests.el | 59 +-
test/lisp/progmodes/octave-tests.el | 49 +
test/lisp/progmodes/xref-tests.el | 40 +-
test/lisp/subr-tests.el | 10 +
test/lisp/time-stamp-tests.el | 38 +-
test/manual/etags/CTAGS.good | 114 ++
test/manual/etags/ETAGS.good_1 | 116 ++
test/manual/etags/ETAGS.good_2 | 174 ++
test/manual/etags/ETAGS.good_3 | 116 ++
test/manual/etags/ETAGS.good_4 | 116 ++
test/manual/etags/ETAGS.good_5 | 174 ++
test/manual/etags/ETAGS.good_6 | 174 ++
test/manual/etags/Makefile | 3 +-
test/manual/etags/merc-src/accumulator.m | 1954 ++++++++++++++++++++
test/src/comp-tests.el | 2 +-
148 files changed, 7254 insertions(+), 1693 deletions(-)
diff --git a/configure.ac b/configure.ac
index 39f9ada..88d5cc1 100644
--- a/configure.ac
+++ b/configure.ac
@@ -3847,27 +3847,28 @@ AC_DEFUN([libgccjit_smoke_test], [
}]])])
AC_DEFUN([libgccjit_not_found], [
- AC_MSG_ERROR([elisp native compiler requested but libgccjit not found.
-Please try installing libgccjit or similar package.
-If you are sure you want Emacs compiled without elisp native compiler, pass
- --without-native-compilation
-to configure.])])
+ AC_MSG_ERROR([ELisp native compiler was requested, but libgccjit was not
found.
+Please try installing libgccjit or a similar package.
+If you are sure you want Emacs be compiled without ELisp native compiler,
+pass the --without-native-compilation option to configure.])])
AC_DEFUN([libgccjit_dev_not_found], [
- AC_MSG_ERROR([elisp native compiler requested but libgccjit header files were
+ AC_MSG_ERROR([ELisp native compiler was requested, but libgccjit header
files were
not found.
-Please try installing libgccjit-dev or similar package.
-If you are sure you want Emacs compiled without elisp native compiler, pass
---without-nativecomp
-to configure.])])
+Please try installing libgccjit-dev or a similar package.
+If you are sure you want Emacs be compiled without ELisp native compiler,
+pass the --without-nativecomp option to configure.])])
AC_DEFUN([libgccjit_broken], [
- AC_MSG_ERROR([Installed libgccjit has failed passing the smoke test.
-You can verify it yourself compiling:
+ AC_MSG_ERROR([The installed libgccjit failed to compile and run a test
program using
+the libgccjit library; see config.log for the details of the failure.
+The test program can be found here:
<https://gcc.gnu.org/onlinedocs/jit/intro/tutorial01.html>.
-Please report the issue to your distribution if libgccjit was installed through
-that.
-Here instructions on how to compile and install libgccjit from source:
+You can try compiling it yourself to investigate the issues.
+Please report the issue to your distribution if libgccjit was installed
+through that.
+You can find the instructions on how to compile and install libgccjit from
+source on this site:
<https://gcc.gnu.org/wiki/JIT>.])])
HAVE_NATIVE_COMP=no
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index 5fccdaa..f6c422a 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -1189,8 +1189,8 @@ that has some special meaning for formatting the source
code of a
program.
To activate the fill-column indication display, use the minor modes
-@w{@kbd{M-x display-fill-column-indicator-mode}} and
-@w{@kbd{M-x global-display-fill-column-indicator-mode}}, which enable
+@kbd{M-x display-fill-@-column-indicator-mode} and
+@kbd{M-x global-display-fill-column-indicator-mode}, which enable
the indicator locally or globally, respectively.
Alternatively, you can set the two buffer-local variables
@@ -1220,8 +1220,8 @@ The value @code{nil} disables the indicator. When the
mode is enabled
through the functions @code{display-fill-column-indicator-mode} or
@code{global-display-fill-column-indicator-mode}, they will use the
character specified by this variable, if it is non-@code{nil};
-otherwise Emacs will use the character @samp{U+2502 VERTICAL LINE},
-falling back to @samp{|} if @code{U+2502} cannot be displayed.
+otherwise Emacs will use the character U+2502 @sc{box drawings light vertical},
+falling back to @samp{|} if U+2502 cannot be displayed.
@item fill-column-indicator
@vindex fill-column-indicator
@@ -1577,8 +1577,8 @@ characters, as well as many non-@acronym{ASCII}
characters.
@cindex control characters on display
The @acronym{ASCII} character set contains non-printing @dfn{control
characters}. Two of these are displayed specially: the newline
-character (Unicode code point @code{U+000A}) is displayed by starting
-a new line, while the tab character (@code{U+0009}) is displayed as a
+character (Unicode code point U+000A) is displayed by starting
+a new line, while the tab character (U+0009) is displayed as a
space that extends to the next tab stop column (normally every 8
columns). The number of spaces per tab is controlled by the
buffer-local variable @code{tab-width}, which must have an integer
@@ -1587,17 +1587,17 @@ character in the buffer is displayed has nothing to do
with the
definition of @key{TAB} as a command.
Other @acronym{ASCII} control characters, whose codes are below
-@code{U+0020} (octal 40, decimal 32), are displayed as a caret
+U+0020 (octal 40, decimal 32), are displayed as a caret
(@samp{^}) followed by the non-control version of the character, with
the @code{escape-glyph} face. For instance, the @samp{control-A}
-character, @code{U+0001}, is displayed as @samp{^A}.
+character, U+0001, is displayed as @samp{^A}.
@cindex octal escapes
@vindex ctl-arrow
- The raw bytes with codes @code{U+0080} (octal 200) through
-@code{U+009F} (octal 237) are displayed as @dfn{octal escape
+ The raw bytes with codes U+0080 (octal 200) through
+U+009F (octal 237) are displayed as @dfn{octal escape
sequences}, with the @code{escape-glyph} face. For instance,
-character code @code{U+0098} (octal 230) is displayed as @samp{\230}.
+character code U+0098 (octal 230) is displayed as @samp{\230}.
If you change the buffer-local variable @code{ctl-arrow} to
@code{nil}, the @acronym{ASCII} control characters are also displayed
as octal escape sequences instead of caret escape sequences. (You can
@@ -1616,11 +1616,11 @@ can cause problems if they are entered into a buffer
without your
realization, e.g., by yanking; for instance, source code compilers
typically do not treat non-@acronym{ASCII} spaces as whitespace
characters. To deal with this problem, Emacs displays such characters
-specially: it displays @code{U+00A0} (no-break space) and other
+specially: it displays U+00A0 @sc{no-break space} and other
characters from the Unicode horizontal space class with the
-@code{nobreak-space} face, and it displays @code{U+00AD} (soft
-hyphen), @code{U+2010} (hyphen), and @code{U+2011} (non-breaking
-hyphen) with the @code{nobreak-hyphen} face. To disable this, change
+@code{nobreak-space} face, and it displays U+00AD @sc{soft
+hyphen}, U+2010 @sc{hyphen}, and U+2011 @sc{non-breaking
+hyphen} with the @code{nobreak-hyphen} face. To disable this, change
the variable @code{nobreak-char-display} to @code{nil}. If you give
this variable a non-@code{nil} and non-@code{t} value, Emacs instead
displays such characters as a highlighted backslash followed by a
@@ -1829,15 +1829,15 @@ variable @code{visual-line-fringe-indicators}.
That produces incorrect results when CJK and Latin text are mixed
together (because CJK characters don't use whitespace to separate
words). You can customize the option @code{word-wrap-by-category} to
-allow Emacs to break lines after any character with ``|'' category
+allow Emacs to break lines after any character with @samp{|} category
(@pxref{Categories,,, elisp, the Emacs Lisp Reference Manual}), which
provides better support for CJK characters. Also, if this variable is
set using Customize, Emacs automatically loads @file{kinsoku.el}.
When @file{kinsoku.el} is loaded, Emacs respects kinsoku rules when
-breaking lines. That means characters with the ``>'' category don't
-appear at the beginning of a line (e.g., U+FF0C FULLWIDTH COMMA), and
-characters with the ``<'' category don't appear at the end of a line
-(e.g., U+300A LEFT DOUBLE ANGLE BRACKET). You can view the category
+breaking lines. That means characters with the @samp{>} category don't
+appear at the beginning of a line (e.g., U+FF0C @sc{fullwidth comma}), and
+characters with the @samp{<} category don't appear at the end of a line
+(e.g., U+300A @sc{left double angle bracket}). You can view the category
set of a character using the commands @code{char-category-set} and
@code{category-set-mnemonics}, or by typing @kbd{C-u C-x =} with point
on the character and looking at the ``category'' section in the
diff --git a/doc/emacs/docstyle.texi b/doc/emacs/docstyle.texi
index 5bdcd07..e740439 100644
--- a/doc/emacs/docstyle.texi
+++ b/doc/emacs/docstyle.texi
@@ -15,4 +15,5 @@
@hyphenation{work-a-round}
@hyphenation{work-a-rounds}
@hyphenation{un-marked}
+@hyphenation{dic-tion-ary}
@end iftex
diff --git a/doc/emacs/fixit.texi b/doc/emacs/fixit.texi
index 6b41849..acc0381 100644
--- a/doc/emacs/fixit.texi
+++ b/doc/emacs/fixit.texi
@@ -365,7 +365,7 @@ Like @kbd{i}, but you can also specify dictionary completion
information.
@item u
-Insert the lower-case version of this word in your private dic@-tion@-ary
+Insert the lower-case version of this word in your private dictionary
file.
@item l @var{word} @key{RET}
diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi
index 89de9af..56763b2 100644
--- a/doc/emacs/killing.texi
+++ b/doc/emacs/killing.texi
@@ -311,13 +311,13 @@ the end. Using any other prefix argument specifies an
earlier kill;
e.g., @kbd{C-u 4 C-y} reinserts the fourth most recent kill.
@xref{Earlier Kills}.
- On graphical displays, @kbd{C-y} first checks if another application
-has placed any text in the system clipboard more recently than the
-last Emacs kill. If so, it inserts the clipboard's text instead.
-Thus, Emacs effectively treats ``cut'' or ``copy'' clipboard
-operations performed in other applications like Emacs kills, except
-that they are not recorded in the kill ring. @xref{Cut and Paste},
-for details.
+ On graphical displays and on capable text-mode displays, @kbd{C-y}
+first checks if another application has placed any text in the system
+clipboard more recently than the last Emacs kill. If so, it inserts
+the clipboard's text instead. Thus, Emacs effectively treats ``cut''
+or ``copy'' clipboard operations performed in other applications like
+Emacs kills, except that they are not recorded in the kill ring.
+@xref{Cut and Paste}, for details.
@menu
* Kill Ring:: Where killed text is stored.
@@ -371,12 +371,12 @@ command, it works differently, see below.)
last-yank pointer which points at an entry in the kill ring. Each
time you kill, the last-yank pointer moves to the newly made entry at
the front of the ring. @kbd{C-y} yanks the entry which the last-yank
-pointer points to. @kbd{M-y} moves the last-yank pointer to a
-different entry, and the text in the buffer changes to match. Enough
-@kbd{M-y} commands can move the pointer to any entry in the ring, so
-you can get any entry into the buffer. Eventually the pointer reaches
-the end of the ring; the next @kbd{M-y} loops back around to the first
-entry again.
+pointer points to. @kbd{M-y} after a @kbd{C-y} or another @kbd{M-y}
+moves the last-yank pointer to the previous entry, and the text in the
+buffer changes to match. Enough @kbd{M-y} commands one after another
+can move the pointer to any entry in the ring, so you can get any
+entry into the buffer. Eventually the pointer reaches the end of the
+ring; the next @kbd{M-y} loops back around to the first entry again.
@kbd{M-y} moves the last-yank pointer around the ring, but it does
not change the order of the entries in the ring, which always runs from
@@ -388,12 +388,13 @@ pointer by. A negative argument moves the pointer toward
the front of
the ring; from the front of the ring, it moves around to the last
entry and continues forward from there.
- Once the text you are looking for is brought into the buffer, you can
-stop doing @kbd{M-y} commands and it will stay there. It's just a copy
-of the kill ring entry, so editing it in the buffer does not change
-what's in the ring. As long as no new killing is done, the last-yank
-pointer remains at the same place in the kill ring, so repeating
-@kbd{C-y} will yank another copy of the same previous kill.
+ Once the text you are looking for is brought into the buffer, you
+can stop doing @kbd{M-y} commands and the last yanked text will stay
+there. It's just a copy of the kill ring entry, so editing it in the
+buffer does not change what's in the ring. As long as no new killing
+is done, the last-yank pointer remains at the same place in the kill
+ring, so repeating @kbd{C-y} will yank another copy of the same
+previous kill.
When you call @kbd{C-y} with a numeric argument, that also sets the
last-yank pointer to the entry that it yanks.
@@ -404,11 +405,18 @@ one of the previous kills. You can use the minibuffer
history
commands (@pxref{Minibuffer History}) to navigate or search through
the entries in the kill ring until you find the one you want to
reinsert. Or you can use completion commands (@pxref{Completion
-Commands}) to complete on the list of entries in the kill ring or pop
-up the @file{*Completions*} buffer with the candidate entries from
-which you can choose. After selecting the kill-ring entry, you can
-optionally edit it in the minibuffer. Finally, type @kbd{RET} to exit
-the minibuffer and insert the selected text.
+Commands}) to complete on an entry from the list of entries in the
+kill ring or pop up the @file{*Completions*} buffer with the candidate
+entries from which you can choose. After selecting the kill-ring
+entry, you can optionally edit it in the minibuffer. Finally, type
+@kbd{RET} to exit the minibuffer and insert the text of the selected
+kill-ring entry. Like in case of @kbd{M-y} after another yank
+command, the last-yank pointer is left pointing at the text you just
+yanked, whether it is one of the previous kills or an entry from the
+kill-ring that you edited before inserting it. (In the latter case,
+the edited entry is added to the front of the kill-ring.) So here,
+too, typing @kbd{C-y} will yank another copy of the text just
+inserted.
When invoked with a plain prefix argument (@kbd{C-u M-y}) after a
command that is not a yank command, @kbd{M-y} leaves the cursor in
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index c802779..027133c 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -1864,6 +1864,12 @@ it to exit. Programs that use @env{EDITOR} usually wait
for the
editor---in this case @command{emacsclient}---to exit before doing
something else.
+@findex server-edit-abort
+ If you want to abandon the edit instead, use the @w{@kbd{M-x
+server-edit-abort}} command. This sends a message back to the
+@command{emacsclient} program, telling it to exit with abnormal exit
+status, and doesn't save any buffers.
+
You can also call @command{emacsclient} with multiple file name
arguments: @samp{emacsclient @var{file1} @var{file2} ...} tells the
Emacs server to visit @var{file1}, @var{file2}, and so forth. Emacs
diff --git a/doc/emacs/windows.texi b/doc/emacs/windows.texi
index c66deb7..facbc7f 100644
--- a/doc/emacs/windows.texi
+++ b/doc/emacs/windows.texi
@@ -310,6 +310,9 @@ the space that it occupied is given to an adjacent window
(but not the
minibuffer window, even if that is active at the time). Deleting the
window has no effect on the buffer it used to display; the buffer
continues to exist, and you can still switch to it with @kbd{C-x b}.
+The option @code{delete-window-choose-selected} allows to choose which
+window becomes the new selected window instead (@pxref{Deleting
+Windows,,, elisp, The Emacs Lisp Reference Manual}).
@findex kill-buffer-and-window
@kindex C-x 4 0
diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi
index 298bec5..dbbc34f 100644
--- a/doc/lispref/help.texi
+++ b/doc/lispref/help.texi
@@ -839,7 +839,7 @@ evaluated, and the result used. For instance:
@end example
@noindent
-will be printed as
+will result in:
@example
(concat "foo" "bar" "zot")
@@ -866,13 +866,14 @@ should be included.
@end example
@item :no-eval*
-Like @code{:no-eval}, but alaways inserts @samp{[it depends]} as the
-result.
+Like @code{:no-eval}, but always inserts @samp{[it depends]} as the
+result. For instance:
@example
:no-eval* (buffer-string)
@end example
+@noindent
will result in:
@example
@@ -894,12 +895,21 @@ Used to output the result from non-evaluating example
forms.
@item :eg-result
Used to output an example result from non-evaluating example forms.
+For instance:
@example
:no-eval (looking-at "f[0-9]")
:eg-result t
@end example
+@noindent
+will result in:
+
+@example
+(looking-at "f[0-9]")
+eg. @click{} t
+@end example
+
@item :result-string
@itemx :eg-result-string
These two are the same as @code{:result} and @code{:eg-result},
@@ -951,7 +961,7 @@ sections.
@defun shortdoc-add-function shortdoc-add-function group section elem
Lisp packages can add functions to groups with this command. Each
-@var{elem} should be a function descriptions, as described above.
+@var{elem} should be a function description, as described above.
@var{group} is the function group, and @var{section} is what section
in the function group to insert the function into.
diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi
index 4150a2b..0e250d0 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -1429,7 +1429,7 @@ other words, if a module function wants to call Lisp
functions or
Emacs primitives, convert @code{emacs_value} objects to and from C
datatypes (@pxref{Module Values}), or interact with Emacs in any other
way, some call from Emacs to @code{emacs_module_init} or to a module
-function must be in the call stack. Module function may not interact
+function must be in the call stack. Module functions may not interact
with Emacs while garbage collection is running; @pxref{Garbage
Collection}. They may only interact with Emacs from Lisp interpreter
threads (including the main thread) created by Emacs; @pxref{Threads}.
diff --git a/doc/lispref/macros.texi b/doc/lispref/macros.texi
index b8df363..cf23ecb 100644
--- a/doc/lispref/macros.texi
+++ b/doc/lispref/macros.texi
@@ -241,7 +241,6 @@ of constants and nonconstant parts. To make this easier,
use the
@samp{`} syntax (@pxref{Backquote}). For example:
@example
-@example
@group
(defmacro t-becomes-nil (variable)
`(if (eq ,variable t)
@@ -253,7 +252,6 @@ of constants and nonconstant parts. To make this easier,
use the
@equiv{} (if (eq foo t) (setq foo nil))
@end group
@end example
-@end example
@node Problems with Macros
@section Common Problems Using Macros
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index 88f2f14..02064e7 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -3004,7 +3004,8 @@ name.
However, @var{facespec} can also evaluate to a list of this form:
@example
-(face @var{face} @var{prop1} @var{val1} @var{prop2} @var{val2}@dots{})
+(@var{subexp}
+(face @var{face} @var{prop1} @var{val1} @var{prop2} @var{val2}@dots{}))
@end example
@noindent
diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi
index 37fde0a..242c5ed 100644
--- a/doc/lispref/os.texi
+++ b/doc/lispref/os.texi
@@ -2369,11 +2369,17 @@ has no effect except in @sc{cbreak} mode.
The argument @var{meta} controls support for input character codes
above 127. If @var{meta} is @code{t}, Emacs converts characters with
-the 8th bit set into Meta characters. If @var{meta} is @code{nil},
+the 8th bit set into Meta characters, before it decodes them as needed
+(@pxref{Terminal I/O Encoding}). If @var{meta} is @code{nil},
Emacs disregards the 8th bit; this is necessary when the terminal uses
-it as a parity bit. If @var{meta} is neither @code{t} nor @code{nil},
-Emacs uses all 8 bits of input unchanged. This is good for terminals
-that use 8-bit character sets.
+it as a parity bit. If @var{meta} is the symbol @code{encoded}, Emacs
+first decodes the characters using all the 8 bits of each byte, and
+then converts the decoded single-byte characters into Meta characters
+if they have their eighth bit set. Finally, if @var{meta} is neither
+@code{t} nor @code{nil} nor @code{encoded}, Emacs uses all 8 bits of
+input unchanged, both before and after decoding them. This is good
+for terminals that use 8-bit character sets and don't encode the Meta
+modifier as the eighth bit.
If @var{quit-char} is non-@code{nil}, it specifies the character to
use for quitting. Normally this character is @kbd{C-g}.
@@ -2398,9 +2404,11 @@ flow control for output to the terminal. This value is
meaningful only
when @var{interrupt} is @code{nil}.
@item meta
is @code{t} if Emacs treats the eighth bit of input characters as
-the meta bit; @code{nil} means Emacs clears the eighth bit of every
-input character; any other value means Emacs uses all eight bits as the
-basic character code.
+the Meta bit before decoding input; @code{encoded} if Emacs treats the
+eighth bit of the decoded single-byte characters as the Meta bit;
+@code{nil} if Emacs clears the eighth bit of every input character;
+any other value means Emacs uses all eight bits as the basic character
+code.
@item quit
is the character Emacs currently uses for quitting, usually @kbd{C-g}.
@end table
diff --git a/doc/lispref/searching.texi b/doc/lispref/searching.texi
index b38ee99..1d3e2d9 100644
--- a/doc/lispref/searching.texi
+++ b/doc/lispref/searching.texi
@@ -368,7 +368,7 @@ preceding expression either once or not at all. For
example,
@anchor{Non-greedy repetition}
@item @samp{*?}, @samp{+?}, @samp{??}
@cindex non-greedy repetition characters in regexp
-These are @dfn{non-greedy} variants of the operators @samp{*}, @samp{+}
+are @dfn{non-greedy} variants of the operators @samp{*}, @samp{+}
and @samp{?}. Where those operators match the largest possible
substring (consistent with matching the entire containing expression),
the non-greedy variants match the smallest possible substring
@@ -443,6 +443,13 @@ including newline. However, a reversed range should
always be from
the letter @samp{z} to the letter @samp{a} to make it clear that it is
not a typo; for example, @samp{[+-*/]} should be avoided, because it
matches only @samp{/} rather than the likely-intended four characters.
+
+@item
+If the end points of a range are raw 8-bit bytes (@pxref{Text
+Representations}), or if the range start is ASCII and the end is a raw
+byte (as in @samp{[a-\377]}), the range will match only ASCII
+characters and raw 8-bit bytes, but not non-ASCII characters. This
+feature is intended for searching text in unibyte buffers and strings.
@end enumerate
Some kinds of character alternatives are not the best style even
diff --git a/doc/lispref/syntax.texi b/doc/lispref/syntax.texi
index 2df6c15..bde7075 100644
--- a/doc/lispref/syntax.texi
+++ b/doc/lispref/syntax.texi
@@ -572,12 +572,14 @@ The function is called by @code{syntax-ppss}
(@pxref{Position Parse}),
and by Font Lock mode during syntactic fontification (@pxref{Syntactic
Font Lock}). It is called with two arguments, @var{start} and
@var{end}, which are the starting and ending positions of the text on
-which it should act. It is allowed to call @code{syntax-ppss} on any
-position before @var{end}, but if a Lisp program calls
-@code{syntax-ppss} on some position and later modifies the buffer at
-some earlier position, then it is that program's responsibility to
-call @code{syntax-ppss-flush-cache} to flush the now obsolete info
-from the cache.
+which it should act. It is allowed to arbitrarily move point within
+the region delimited by @var{start} and @var{end}; such motions don't
+need to use @code{save-excursion} (@pxref{Excursions}). It is also
+allowed to call @code{syntax-ppss} on any position before @var{end},
+but if a Lisp program calls @code{syntax-ppss} on some position and
+later modifies the buffer at some earlier position, then it is that
+program's responsibility to call @code{syntax-ppss-flush-cache} to
+flush the now obsolete info from the cache.
@strong{Caution:} When this variable is non-@code{nil}, Emacs removes
@code{syntax-table} text properties arbitrarily and relies on
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index 36abc31..62c76f0 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -1582,6 +1582,12 @@ buffer-local binding in buffer @var{buffer}, it returns
the default
value (@pxref{Default Value}) of @var{variable} instead.
@end defun
+@defun buffer-local-boundp variable buffer
+This returns non-@code{nil} if there's either a buffer-local binding
+of @var{variable} (a symbol) in buffer @var{buffer}, or @var{variable}
+has a global binding.
+@end defun
+
@defun buffer-local-variables &optional buffer
This function returns a list describing the buffer-local variables in
buffer @var{buffer}. (If @var{buffer} is omitted, the current buffer
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index 82d2ce4..3b6f74b 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -1318,6 +1318,33 @@ lieu of the usual action of @code{delete-window}.
@xref{Window
Parameters}.
@end deffn
+When @code{delete-window} deletes the selected window of its frame, it
+has to make another window the new selected window of that frame. The
+following option allows configuring which window is chosen.
+
+@defopt delete-window-choose-selected
+This option allows specifying which window should become a frame's
+selected window after @code{delete-window} has deleted the previously
+selected one. Possible choices are
+
+@itemize
+@item @code{mru}
+(the default) choose the most recently used window on that frame.
+
+@item @code{pos}
+choose the window comprising the frame coordinates of point of the
+previously selected window on that frame.
+
+@item @code{nil}
+choose the first window (the window returned by
+@code{frame-first-window}) on that frame.
+@end itemize
+
+A window with a non-@code{nil} @code{no-other-window} parameter is
+chosen only if all other windows on that frame have that parameter set
+to a non-@code{nil} value too.
+@end defopt
+
@deffn Command delete-other-windows &optional window
This function makes @var{window} fill its frame, deleting other
windows as necessary. If @var{window} is omitted or @code{nil}, it
@@ -1838,6 +1865,14 @@ with @var{window} as the selected window without
needlessly running
@code{buffer-list-update-hook}.
@end defmac
+@defmac with-selected-frame frame forms@dots{}
+This macro executes @var{forms} with @var{frame} as the selected
+frame. The value returned is the value of the last form in
+@var{forms}. This macro saves and restores the selected frame, and
+changes the order of neither the recently selected windows nor the
+buffers in the buffer list.
+@end defmac
+
@defun frame-selected-window &optional frame
This function returns the window on @var{frame} that is selected
within that frame. @var{frame} should be a live frame; if omitted or
@@ -1999,7 +2034,7 @@ meaning as for @code{next-window}.
criterion, without selecting it:
@cindex least recently used window
-@defun get-lru-window &optional all-frames dedicated not-selected
+@defun get-lru-window &optional all-frames dedicated not-selected no-other
This function returns a live window which is heuristically the least
recently used. The optional argument @var{all-frames} has
the same meaning as in @code{next-window}.
@@ -2010,33 +2045,25 @@ window (@pxref{Dedicated Windows}) is never a candidate
unless the
optional argument @var{dedicated} is non-@code{nil}. The selected
window is never returned, unless it is the only candidate. However, if
the optional argument @var{not-selected} is non-@code{nil}, this
-function returns @code{nil} in that case.
+function returns @code{nil} in that case. The optional argument
+@var{no-other}, if non-@code{nil}, means to never return a window whose
+@code{no-other-window} parameter is non-@code{nil}.
@end defun
@cindex most recently used window
-@defun get-mru-window &optional all-frames dedicated not-selected
+@defun get-mru-window &optional all-frames dedicated not-selected no-other
This function is like @code{get-lru-window}, but it returns the most
recently used window instead. The meaning of the arguments is the
-same as described for @code{get-lru-window}.
+same as for @code{get-lru-window}.
@end defun
@cindex largest window
-@defun get-largest-window &optional all-frames dedicated not-selected
+@defun get-largest-window &optional all-frames dedicated not-selected no-other
This function returns the window with the largest area (height times
-width). The optional argument @var{all-frames} specifies the windows to
-search, and has the same meaning as in @code{next-window}.
-
-A minibuffer window is never a candidate. A dedicated window
-(@pxref{Dedicated Windows}) is never a candidate unless the optional
-argument @var{dedicated} is non-@code{nil}. The selected window is not
-a candidate if the optional argument @var{not-selected} is
-non-@code{nil}. If the optional argument @var{not-selected} is
-non-@code{nil} and the selected window is the only candidate, this
-function returns @code{nil}.
-
-If there are two candidate windows of the same size, this function
-prefers the one that comes first in the cyclic ordering of windows,
-starting from the selected window.
+width). If there are two candidate windows of the same size, it prefers
+the one that comes first in the cyclic ordering of windows, starting
+from the selected window. The meaning of the arguments is the same as
+for @code{get-lru-window}.
@end defun
@cindex window that satisfies a predicate
diff --git a/doc/man/emacs.1.in b/doc/man/emacs.1.in
index da912bd..290be60 100644
--- a/doc/man/emacs.1.in
+++ b/doc/man/emacs.1.in
@@ -197,7 +197,7 @@ searches for Lisp files.
.\" START DELETING HERE IF YOU'RE NOT USING X
.SS Using Emacs with X
.I Emacs
-has been tailored to work well with the X window system.
+has been tailored to work well with the X Window System.
If you run
.I Emacs
from under X windows, it will create its own X window to
@@ -566,7 +566,7 @@ distribution.
/usr/local/share/info \(em files for the Info documentation browser.
The complete text of the Emacs reference manual is included in a
convenient tree structured form.
-Also includes the Emacs Lisp Reference Manual, useful to anyone
+This includes the Emacs Lisp Reference Manual, useful to anyone
wishing to write programs in the Emacs Lisp extension language,
and the Introduction to Programming in Emacs Lisp.
diff --git a/doc/man/etags.1 b/doc/man/etags.1
index 354f6ca..cbd3c1a 100644
--- a/doc/man/etags.1
+++ b/doc/man/etags.1
@@ -1,5 +1,5 @@
.\" See section COPYING for copyright and redistribution information.
-.TH ETAGS 1 "2019-06-24" "GNU Tools" "GNU"
+.TH ETAGS 1 "2021-03-30" "GNU Tools" "GNU"
.de BP
.sp
.ti -.2i
@@ -50,9 +50,9 @@ format understood by
.BR vi ( 1 )\c
\&. Both forms of the program understand
the syntax of C, Objective C, C++, Java, Fortran, Ada, Cobol, Erlang,
-Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Pascal, Perl,
-Ruby, Rust, PHP, PostScript, Python, Prolog, Scheme and
-most assembler\-like syntaxes.
+Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Mercury, Pascal,
+Perl, Ruby, Rust, PHP, PostScript, Python, Prolog, Scheme and most
+assembler\-like syntaxes.
Both forms read the files specified on the command line, and write a tag
table (defaults: \fBTAGS\fP for \fBetags\fP, \fBtags\fP for
\fBctags\fP) in the current working directory.
@@ -91,6 +91,9 @@ Only \fBctags\fP accepts this option.
In C and derived languages, create tags for function declarations,
and create tags for extern variables unless \-\-no\-globals is used.
In Lisp, create tags for (defvar foo) declarations.
+In Mercury, declarations start a line with "\|\fB:-\fP\|" and are always
+tagged. In addition, this option tags predicates or functions in first
+rules of clauses, as in Prolog.
.TP
.B \-D, \-\-no\-defines
Do not create tag entries for C preprocessor constant definitions
@@ -125,10 +128,14 @@ final brace of a function or structure definition in C
and C++.
Parse the following files according to the given language. More than
one such options may be intermixed with filenames. Use \fB\-\-help\fP
to get a list of the available languages and their default filename
-extensions. The "auto" language can be used to restore automatic
-detection of language based on the file name. The "none"
-language may be used to disable language parsing altogether; only
-regexp matching is done in this case (see the \fB\-\-regex\fP option).
+extensions. For example, as Mercury and Objective-C have same
+filename extension \fI.m\fP, a test based on contents tries to detect
+the language. If this test fails, \fB\-\-language=\fP\fImercury\fP or
+\fB\-\-language=\fP\fIobjc\fP should be used.
+The "auto" language can be used to restore automatic detection of language
+based on the file name. The "none" language may be used to disable language
+parsing altogether; only regexp matching is done in this case (see the
+\fB\-\-regex\fP option).
.TP
.B \-\-members
Create tag entries for variables that are members of structure-like
diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi
index 4952e90..63b4282 100644
--- a/doc/misc/eieio.texi
+++ b/doc/misc/eieio.texi
@@ -115,10 +115,10 @@ Each class can have methods, which are defined like this:
(cl-defmethod call-person ((pers person) &optional scriptname)
"Dial the phone for the person PERS.
Execute the program SCRIPTNAME to dial the phone."
- (message "Dialing the phone for %s" (oref pers name))
+ (message "Dialing the phone for %s" (slot-value pers 'name))
(shell-command (concat (or scriptname "dialphone.sh")
" "
- (oref pers phone))))
+ (slot-value pers 'phone))))
@end example
@noindent
@@ -693,16 +693,43 @@ for each slot. For example:
@node Accessing Slots
@chapter Accessing Slots
-There are several ways to access slot values in an object. The naming
-and argument-order conventions are similar to those used for
-referencing vectors (@pxref{Vectors,,,elisp,GNU Emacs Lisp Reference
-Manual}).
+There are several ways to access slot values in an object.
+The following accessors are defined by CLOS to reference or modify
+slot values, and use the previously mentioned set/ref routines.
+
+@defun slot-value object slot
+@anchor{slot-value}
+This function retrieves the value of @var{slot} from @var{object}.
+
+This is a generalized variable that can be used with @code{setf} to
+modify the value stored in @var{slot}. @xref{Generalized
+Variables,,,elisp,GNU Emacs Lisp Reference Manual}.
+@end defun
+
+@defun set-slot-value object slot value
+@anchor{set-slot-value}
+This function sets the value of @var{slot} from @var{object}.
+
+This is not a CLOS function, but is the obsolete setter for
+@code{slot-value} used by the @code{setf} macro. It is therefore
+recommended to use @w{@code{(setf (slot-value @var{object} @var{slot})
+@var{value})}} instead.
+@end defun
+
+@defun slot-makeunbound object slot
+This function unbinds @var{slot} in @var{object}. Referencing an
+unbound slot can signal an error.
+@end defun
+
+The following accessors follow a naming and argument-order conventions
+are similar to those used for referencing vectors
+(@pxref{Vectors,,,elisp,GNU Emacs Lisp Reference Manual}).
@defmac oref obj slot
@anchor{oref}
This macro retrieves the value stored in @var{obj} in the named
-@var{slot}. Slot names are determined by @code{defclass} which
-creates the slot.
+@var{slot}. Unlike @code{slot-value}, the symbol for @var{slot} must
+not be quoted.
This is a generalized variable that can be used with @code{setf} to
modify the value stored in @var{slot}. @xref{Generalized
@@ -737,35 +764,6 @@ changed, this can be arranged by simply executing this bit
of code:
@end example
@end defmac
-The following accessors are defined by CLOS to reference or modify
-slot values, and use the previously mentioned set/ref routines.
-
-@defun slot-value object slot
-@anchor{slot-value}
-This function retrieves the value of @var{slot} from @var{object}.
-Unlike @code{oref}, the symbol for @var{slot} must be quoted.
-
-This is a generalized variable that can be used with @code{setf} to
-modify the value stored in @var{slot}. @xref{Generalized
-Variables,,,elisp,GNU Emacs Lisp Reference Manual}.
-@end defun
-
-@defun set-slot-value object slot value
-@anchor{set-slot-value}
-This function sets the value of @var{slot} from @var{object}. Unlike
-@code{oset}, the symbol for @var{slot} must be quoted.
-
-This is not a CLOS function, but is the obsolete setter for
-@code{slot-value} used by the @code{setf} macro. It is therefore
-recommended to use @w{@code{(setf (slot-value @var{object} @var{slot})
-@var{value})}} instead.
-@end defun
-
-@defun slot-makeunbound object slot
-This function unbinds @var{slot} in @var{object}. Referencing an
-unbound slot can signal an error.
-@end defun
-
@defun object-add-to-list object slot item &optional append
@anchor{object-add-to-list}
In OBJECT's @var{slot}, add @var{item} to the list of elements.
@@ -807,7 +805,7 @@ Where each @var{var} is the local variable given to the
associated
variable name of the same name as the slot.
@example
-(defclass myclass () (x :initform 1))
+(defclass myclass () ((x :initform 1)))
(setq mc (make-instance 'myclass))
(with-slots (x) mc x) => 1
(with-slots ((something x)) mc something) => 1
@@ -981,8 +979,8 @@ the @code{subclass} specializer with @code{cl-defmethod}:
new))
@end example
-The first argument of a static method will be a class rather than an
-object. Use the functions @code{oref-default} or @code{oset-default} which
+The argument of a static method will be a class rather than an object.
+Use the functions @code{oref-default} or @code{oset-default} which
will work on a class.
A class's @code{make-instance} method is defined as a static
@@ -1238,12 +1236,6 @@ of CLOS.
Return the list of public slots for @var{obj}.
@end defun
-@defun class-slot-initarg class slot
-For the given @var{class} return an :initarg associated with
-@var{slot}. Not all slots have initargs, so the return value can be
-@code{nil}.
-@end defun
-
@node Base Classes
@chapter Base Classes
@@ -1656,8 +1648,8 @@ Method invoked when an attempt to access a slot in
@var{object} fails.
that was requested, and optional @var{new-value} is the value that was desired
to be set.
-This method is called from @code{oref}, @code{oset}, and other functions which
-directly reference slots in EIEIO objects.
+This method is called from @code{slot-value}, @code{set-slot-value},
+and other functions which directly reference slots in EIEIO objects.
The default method signals an error of type @code{invalid-slot-name}.
@xref{Signals}.
diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi
index 0cf5ba9..7cd3e5f 100644
--- a/doc/misc/emacs-mime.texi
+++ b/doc/misc/emacs-mime.texi
@@ -1870,6 +1870,11 @@ A customizable list of viewers that take preference over
Interface functions:
@table @code
+@item mailcap-view-file
+@findex mailcap-view-file
+Prompt for a file name, and start a viewer applicable for the file
+type in question.
+
@item mailcap-parse-mailcaps
@findex mailcap-parse-mailcaps
@vindex mailcap-prefer-mailcap-viewers
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index 213b69e..77a19a4 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -518,7 +518,7 @@ That is, if called with the following arguments,
@var{server} and
for the values of the other parameters.
@example
-(erc :server "chat.freenode.net" :full-name "Harry S Truman")
+(erc :server "chat.freenode.net" :full-name "J. Random Hacker")
@end example
@end defun
@@ -545,7 +545,7 @@ for the values of the other parameters, and
@code{client-certificate}
will be @code{nil}.
@example
-(erc-tls :server "chat.freenode.net" :full-name "Harry S Truman")
+(erc-tls :server "chat.freenode.net" :full-name "J. Random Hacker")
@end example
To use a certificate with @code{erc-tls}, specify the optional
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 7d6fa4c..b63947c 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -2583,25 +2583,28 @@ with the process mark and then execute the command.
@itemx M m
@kindex M m @r{(Group)}
@findex gnus-group-mark-group
-Set the mark on the current group (@code{gnus-group-mark-group}).
+Toggle the process mark for the current group
+(@code{gnus-group-mark-group}).@*
+If @code{gnus-process-mark-toggle} is @code{nil}, set the process mark
+for the current group.
@item M-#
@kindex M-# @r{(Group)}
@itemx M u
@kindex M u @r{(Group)}
@findex gnus-group-unmark-group
-Remove the mark from the current group
+Remove the process mark, if any, from the current group
(@code{gnus-group-unmark-group}).
@item M U
@kindex M U @r{(Group)}
@findex gnus-group-unmark-all-groups
-Remove the mark from all groups (@code{gnus-group-unmark-all-groups}).
+Remove the process mark from all groups (@code{gnus-group-unmark-all-groups}).
@item M w
@kindex M w @r{(Group)}
@findex gnus-group-mark-region
-Mark all groups between point and mark (@code{gnus-group-mark-region}).
+Mark groups in region (@code{gnus-group-mark-region}).
@item M b
@kindex M b @r{(Group)}
@@ -4041,9 +4044,11 @@ Toggle hiding empty topics
@item T #
@kindex T # @r{(Topic)}
@findex gnus-topic-mark-topic
-Mark all groups in the current topic with the process mark
+Toggle the process mark for all groups in the current topic
(@code{gnus-topic-mark-topic}). This command works recursively on
-sub-topics unless given a prefix.
+sub-topics unless given a prefix.@*
+If @code{gnus-process-mark-toggle} is @code{nil}, set the process mark
+for the current topic.
@item T M-#
@kindex T M-# @r{(Topic)}
@@ -5241,6 +5246,12 @@ have to disable fetching headers with @samp{XOVER}:
Be aware, though, that this will make entering an @acronym{NNTP} group
much, much slower, so this is not recommended.
+One particular scenario in which it can be desirable to not use
+@samp{XOVER} is for @code{nnvirtual} groups in order to support
+limiting by extra headers (e.g., by the newsgroup of its component
+groups). Because group parameters are not inherited, a separate
+select method for the component groups with the appropriate
+@code{nov-is-evil} set as a method variable is required.
@node Summary Buffer Mode Line
@subsection Summary Buffer Mode Line
@@ -6617,14 +6628,16 @@ articles into the cache. For more information,
@kindex # @r{(Summary)}
@kindex M P p @r{(Summary)}
@findex gnus-summary-mark-as-processable
-Mark the current article with the process mark
-(@code{gnus-summary-mark-as-processable}).
-@findex gnus-summary-unmark-as-processable
+Toggle the process mark for the current article
+(@code{gnus-summary-mark-as-processable}).@*
+If @code{gnus-process-mark-toggle} is @code{nil}, set the process mark
+for the current article.
@item M P u
@itemx M-#
@kindex M P u @r{(Summary)}
@kindex M-# @r{(Summary)}
+@findex gnus-summary-unmark-as-processable
Remove the process mark, if any, from the current article
(@code{gnus-summary-unmark-as-processable}).
@@ -10562,13 +10575,15 @@ Here are the available keystrokes when using pick
mode:
@item .
@kindex . @r{(Pick)}
@findex gnus-pick-article-or-thread
-Pick the article or thread on the current line
-(@code{gnus-pick-article-or-thread}). If the variable
+Pick the article or thread on the current line or unpick it if is
+already picked (@code{gnus-pick-article-or-thread}). If the variable
@code{gnus-thread-hide-subtree} is true, then this key selects the
entire thread when used at the first article of the thread. Otherwise,
it selects just the article. If given a numerical prefix, go to that
thread or article and pick it. (The line number is normally displayed
-at the beginning of the summary pick lines.)
+at the beginning of the summary pick lines.) If
+@code{gnus-process-mark-toggle} is @code{nil}, this key will pick an
+article or thread.
@item @key{SPC}
@kindex SPC @r{(Pick)}
diff --git a/etc/NEWS b/etc/NEWS
index 49bde94..1693342 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -112,6 +112,17 @@ filters.
* Changes in Emacs 28.1
+++
+** Etags now supports the Mercury programming language.
+See https://mercurylang.org.
+
++++
+** Etags command line option '--declarations' now has Mercury-specific
behavior.
+All Mercury declarations are tagged by default. However, for
+compatibility with 'etags' support for Prolog, predicates and
+functions appearing first in clauses will also be tagged if 'etags' is
+invoked with the '--declarations' command-line option.
+
++++
** New command 'font-lock-update', bound to 'C-x x f'.
This command updates the syntax highlighting in this buffer.
@@ -295,6 +306,17 @@ default, 9.5 MiB). Press '?' or 'C-h' in that prompt to
read more
about the different options to visit a file, how you can disable the
prompt, and how you can tweak the file size threshold.
++++
+** Improved support for terminal emulators that encode the Meta flag.
+Some terminal emulators set the 8th bit of Meta characters, and then
+encode the resulting character code as if it were non-ASCII character
+above codepoint 127. Previously, the only way of using these in Emacs
+was to set up the terminal emulator to use the 'ESC' characters to send
+Meta characters to Emacs, e.g., send "ESC x" when the user types
+'M-x'. You can now avoid the need for this setup of such terminal
+emulators by using the new input-meta-mode with the special value
+'encoded' with these terminal emulators.
+
* Editing Changes in Emacs 28.1
@@ -510,6 +532,13 @@ When emacsclient connects, Emacs will (by default) output
a message
about how to exit the client frame. If 'server-client-instructions'
is set to nil, this message is inhibited.
++++
+*** New command 'server-edit-abort'.
+This command (not bound to any key by default) can be used to abort
+an edit instead of marking it as "Done" (which the 'C-x #' command
+does). The 'emacsclient' program exits with an abnormal status as
+result of this command.
+
** Perl mode
---
@@ -534,9 +563,23 @@ indentation is done using SMIE or with the old ad-hoc code.
** Icomplete
+++
-*** New minor mode 'icomplete-vertical-mode'.
-This mode is intended to be used with Icomplete or Fido, to display the
-list of completions candidates vertically instead of horizontally.
+*** New minor mode 'icomplete-vertical-mode', alias 'fido-vertical-mode'.
+This mode is intended to be used with Icomplete ('M-x icomplete-mode')
+or Fido ('M-x fido-mode'), to display the list of completions
+candidates vertically instead of horizontally. When used with
+Icomplete, completions are rotated and selection kept at the top.
+When used with Fido, completions scroll like a typical dropdown
+widget.
+
+*** Default value of 'icomplete-compute-delay' has been changed to 0.15 s.
+
+*** Default value of 'icomplete-max-delay-chars' has been changed to 2.
+
+*** Reduced blinking while completing the next completions set.
+Icomplete doesn't hide the hint with the previously computed
+completions anymore when compute delay is in effect, or the previous
+computation has been aborted by input. Instead it shows the previous
+completions until the new ones are ready.
---
** Specific warnings can now be disabled from the warning buffer.
@@ -551,9 +594,28 @@ disabled entirely.
---
*** Autoload the main entry point 'mspool-show'.
+** Windmove
+
+*** New user options to customize windmove keybindings.
+These options include 'windmove-default-keybindings',
+'windmove-display-default-keybindings',
+'windmove-delete-default-keybindings',
+'windmove-swap-states-default-keybindings'.
+
** Windows
+++
+*** New option 'delete-window-choose-selected'.
+This allows to choose a frame's selected window after deleting the
+previously selected one.
+
++++
+*** New argument NO-OTHER for some window functions.
+'get-lru-window', ‘get-mru-window’ and 'get-largest-window' now accept a
+new optional argument NO-OTHER which, if non-nil, avoids returning a
+window whose 'no-other-window' parameter is non-nil.
+
++++
*** New 'display-buffer' function 'display-buffer-use-least-recent-window'.
This is like 'display-buffer-use-some-window', but won't reuse the
current window, and when called repeatedly will try not to reuse a
@@ -829,9 +891,23 @@ If non-nil, only branches and remotes are considered when
doing
completion over Git branch names. The default is nil, which causes
tags to be considered as well.
+---
+*** New user option 'vc-git-log-switches'.
+String or list of strings specifying switches for Git log under VC.
+
** Gnus
+++
+*** The '#' command in the Group and Summary buffer now toggles,
+instead of sets, the process mark.
+
++++
+*** New user option 'gnus-process-mark-toggle'.
+If non-nil (the default), the '#' command in the Group and Summary
+buffers will toggle, instead of set, the process mark.
+
+
++++
*** New user option 'gnus-registry-register-all'.
If non-nil (the default), create registry entries for all messages.
If nil, don't automatically create entries, they must be created
@@ -1037,6 +1113,15 @@ grep-like tools.
On systems where the grep command supports it, directories will be
skipped.
+*** Commands that use 'grep-find' now follow symlinks for command-line args.
+This is because the default value of 'grep-find-template' now includes
+the 'find' option '-H'. Commands that use that variable, including
+indirectly via a call to 'xref-matches-in-directory', might be
+affected. In particular, there should be no need anymore to ensure
+any directory names on the 'find' command lines end in a slash.
+This change is for better compatibility with old versions of non-GNU
+'find', such as the one used on macOS.
+
** Help
---
@@ -1057,14 +1142,14 @@ GTK toolkit, this is only true if
'x-gtk-use-system-tooltips' is t.
+++
*** New command 'describe-command' shows help for a command.
This can be used instead of 'describe-function' for interactive
-commands and is globally bound to `C-h x'.
+commands and is globally bound to 'C-h x'.
+++
*** New command 'describe-keymap' describes keybindings in a keymap.
---
*** New user option 'describe-bindings-outline'.
-It enables outlines in the output buffer of `describe-bindings' that
+It enables outlines in the output buffer of 'describe-bindings' that
can provide a better overview in a long list of available bindings.
---
@@ -1252,6 +1337,12 @@ it when producing a doc string.
This is bound to 'C-x n d' in 'shell-mode' buffers, and narrows to the
command line under point (and any following output).
+---
+*** New user option 'shell-has-auto-cd'.
+If non-nil, 'shell-mode' handles implicit "cd" commands, changing the
+directory if the command is a directory. Useful for shells like "zsh"
+that has this feature.
+
** Eshell
---
@@ -1541,6 +1632,11 @@ symbol property to the browsing commands. With a new
command
'browse-url-with-browser-kind', an URL can explicitly be browsed with
either an internal or external browser.
+---
+*** Support for browsing of remote files.
+If a remote file is taken, a local temporary copy of that file is
+passed to the browser.
+
*** Support for the conkeror browser is now obsolete.
*** Support for the Mosaic browser has been removed.
@@ -1991,6 +2087,15 @@ Shift while typing 'C-a', i.e. 'C-S-a', will now
highlight the text.
** Miscellaneous
+---
+*** New variable 'hl-line-overlay-priority'.
+This can be used to change the priority of the hl-line overlays.
+
++++
+*** New command 'mailcap-view-file'.
+This command will open a viewer based on the file type, as determined
+by "~/.mailcap" and related files and variables.
+
+++
*** New command 'C-x C-k Q' to force redisplay in keyboard macros.
@@ -2451,6 +2556,13 @@ similar to prefix arguments, but are more flexible and
discoverable.
* Incompatible Editing Changes in Emacs 28.1
+** 'electric-indent-mode' now also indents inside strings and comments,
+(unless the indentation function doesn't, of course).
+To recover the previous behavior you can use:
+
+ (add-hook 'electric-indent-functions
+ (lambda (_) (if (nth 8 (syntax-ppss)) 'no-indent)))
+
** The 'M-o' ('facemenu-keymap') global binding has been removed.
To restore the old binding, say something like:
@@ -2502,7 +2614,7 @@ In previous versions of Emacs, numbers with a trailing
dot and an exponent
were read as integers and the exponent ignored: 2.e6 was interpreted as the
integer 2. Such numerals are now read as floats with the exponent included:
2.e6 is now read as the floating-point value 2000000.0.
-That is, (read-from-string "1.e3") => (1000.0 . 4) now.
+That is, '(read-from-string "1.e3")' => '(1000.0 . 4)' now.
+++
** The 'lexical-binding' local variable is always enabled.
@@ -2711,7 +2823,7 @@ form should be exceedingly rare. See the Info node
"(elisp) Backtracking" in
the Emacs Lisp reference manual for background.
---
-** 'sql-*-statement-starters' are no longer defcustoms.
+** 'sql-*-statement-starters' are no longer user options.
These variables describe facts about the SQL standard and
product-specific additions. There should be no need for users to
customize them.
@@ -2719,6 +2831,10 @@ customize them.
* Lisp Changes in Emacs 28.1
++++
+** New function 'buffer-local-boundp'.
+This predicate says whether a symbol is bound in a specific buffer.
+
---
** Emacs now attempts to test for high-rate subprocess output more fairly.
When several subprocesses produce output simultaneously at high rate,
diff --git a/lib-src/etags.c b/lib-src/etags.c
index d703183..9f20e44c 100644
--- a/lib-src/etags.c
+++ b/lib-src/etags.c
@@ -142,7 +142,14 @@ University of California, as described above. */
# define CTAGS false
#endif
-/* Copy to DEST from SRC (containing LEN bytes), and append a NUL byte. */
+/* Define MERCURY_HEURISTICS_RATIO as it was necessary to disambiguate
+ Mercury from Objective C, which have same file extensions .m
+ See comments before function test_objc_is_mercury for details. */
+#ifndef MERCURY_HEURISTICS_RATIO
+# define MERCURY_HEURISTICS_RATIO 0.5
+#endif
+
+/* COPY to DEST from SRC (containing LEN bytes), and append a NUL byte. */
static void
memcpyz (void *dest, void const *src, ptrdiff_t len)
{
@@ -359,6 +366,7 @@ static void HTML_labels (FILE *);
static void Lisp_functions (FILE *);
static void Lua_functions (FILE *);
static void Makefile_targets (FILE *);
+static void Mercury_functions (FILE *);
static void Pascal_functions (FILE *);
static void Perl_functions (FILE *);
static void PHP_functions (FILE *);
@@ -379,6 +387,7 @@ static ptrdiff_t readline_internal (linebuffer *, FILE *,
char const *);
static bool nocase_tail (const char *);
static void get_tag (char *, char **);
static void get_lispy_tag (char *);
+static void test_objc_is_mercury (char *, language **);
static void analyze_regex (char *);
static void free_regexps (void);
@@ -684,10 +693,22 @@ static const char Makefile_help [] =
"In makefiles, targets are tags; additionally, variables are tags\n\
unless you specify '--no-globals'.";
+/* Mercury and Objective C share the same .m file extensions. */
+static const char *Mercury_suffixes [] =
+ {"m",
+ NULL};
+static const char Mercury_help [] =
+ "In Mercury code, tags are all declarations beginning a line with ':-'\n\
+and optionally Prolog-like definitions (first rule for a predicate or \
+function).\n\
+To enable this behavior, run etags using --declarations.";
+static bool with_mercury_definitions = false;
+float mercury_heuristics_ratio = MERCURY_HEURISTICS_RATIO;
+
static const char *Objc_suffixes [] =
- { "lm", /* Objective lex file */
- "m", /* Objective C file */
- NULL };
+ { "lm", /* Objective lex file */
+ "m", /* By default, Objective C file will be
assumed. */
+ NULL};
static const char Objc_help [] =
"In Objective C code, tags include Objective C definitions for classes,\n\
class categories, methods and protocols. Tags for variables and\n\
@@ -831,7 +852,9 @@ static language lang_names [] =
{ "lisp", Lisp_help, Lisp_functions, Lisp_suffixes },
{ "lua", Lua_help,Lua_functions,Lua_suffixes,NULL,Lua_interpreters},
{ "makefile", Makefile_help,Makefile_targets,NULL,Makefile_filenames},
+ /* objc listed before mercury as it is a better default for .m extensions.
*/
{ "objc", Objc_help, plain_C_entries, Objc_suffixes },
+ { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes },
{ "pascal", Pascal_help, Pascal_functions, Pascal_suffixes },
{ "perl",Perl_help,Perl_functions,Perl_suffixes,NULL,Perl_interpreters},
{ "php", PHP_help, PHP_functions, PHP_suffixes },
@@ -958,6 +981,9 @@ Relative ones are stored relative to the output file's
directory.\n");
puts
("\tand create tags for extern variables unless --no-globals is used.");
+ puts ("In Mercury, tag both declarations starting a line with ':-' and
first\n\
+ predicates or functions in clauses.");
+
if (CTAGS)
puts ("-d, --defines\n\
Create tag entries for C #define constants and enum constants, too.");
@@ -1783,6 +1809,11 @@ find_entries (FILE *inf)
if (parser == NULL)
{
lang = get_language_from_filename (curfdp->infname, true);
+
+ /* Disambiguate file names between Objc and Mercury. */
+ if (lang != NULL && strcmp (lang->name, "objc") == 0)
+ test_objc_is_mercury (curfdp->infname, &lang);
+
if (lang != NULL && lang->function != NULL)
{
curfdp->lang = lang;
@@ -6072,6 +6103,472 @@ prolog_atom (char *s, size_t pos)
/*
+ * Support for Mercury
+ *
+ * Assumes that the declarations start at column 0.
+ * Original code by Sunichirou Sugou (1989) for Prolog.
+ * Rewritten by Anders Lindgren (1996) for Prolog.
+ * Adapted by Fabrice Nicol (2021) for Mercury.
+ * Note: Prolog-support behavior is preserved if
+ * --declarations is used, corresponding to
+ * with_mercury_definitions=true.
+ */
+
+static ptrdiff_t mercury_pr (char *, char *, ptrdiff_t);
+static void mercury_skip_comment (linebuffer *, FILE *);
+static bool is_mercury_type = false;
+static bool is_mercury_quantifier = false;
+static bool is_mercury_declaration = false;
+
+/*
+ * Objective-C and Mercury have identical file extension .m.
+ * To disambiguate between Objective C and Mercury, parse file
+ * with the following heuristics hook:
+ * - if line starts with :-, choose Mercury unconditionally;
+ * - if line starts with #, @, choose Objective-C;
+ * - otherwise compute the following ratio:
+ *
+ * r = (number of lines with :-
+ * or % in non-commented parts or . at trimmed EOL)
+ * / (number of lines - number of lines starting by any amount
+ * of whitespace, optionally followed by comment(s))
+ *
+ * Note: strings are neglected in counts.
+ *
+ * If r > mercury_heuristics_ratio, choose Mercury.
+ * Experimental tests show that a possibly optimal default value for
+ * this floor value is around 0.5. This is the default value for
+ * MERCURY_HEURISTICS_RATIO, defined in the first lines of this file.
+ * The closer r is to 0.5, the closer the source code to pure Prolog.
+ * Idiomatic Mercury is scored either with r = 1.0 or higher.
+ * Objective-C is scored with r = 0.0. When this fails, the r-score
+ * never rose above 0.1 in Objective-C tests.
+ */
+
+static void
+test_objc_is_mercury (char *this_file, language **lang)
+{
+ if (this_file == NULL) return;
+ FILE* fp = fopen (this_file, "r");
+ if (fp == NULL)
+ pfatal (this_file);
+
+ bool blank_line = false; /* Line starting with any amount of white space
+ followed by optional comment(s). */
+ bool commented_line = false;
+ bool found_dot = false;
+ bool only_space_before = true;
+ bool start_of_line = true;
+ int c;
+ intmax_t lines = 1;
+ intmax_t mercury_dots = 0;
+ intmax_t percentage_signs = 0;
+ intmax_t rule_signs = 0;
+ float ratio = 0;
+
+ while ((c = fgetc (fp)) != EOF)
+ {
+ switch (c)
+ {
+ case '\n':
+ if (! blank_line) ++lines;
+ blank_line = true;
+ commented_line = false;
+ start_of_line = true;
+ if (found_dot) ++mercury_dots;
+ found_dot = false;
+ only_space_before = true;
+ break;
+ case '.':
+ found_dot = ! commented_line;
+ only_space_before = false;
+ break;
+ case '%': /* More frequent in Mercury. May be modulo in Obj.-C. */
+ if (! commented_line)
+ {
+ ++percentage_signs;
+ /* Cannot tell if it is a comment or modulo yet for sure.
+ Yet works for heuristic purposes. */
+ commented_line = true;
+ }
+ found_dot = false;
+ start_of_line = false;
+ only_space_before = false;
+ break;
+ case '/':
+ {
+ int d = fgetc (fp);
+ found_dot = false;
+ only_space_before = false;
+ if (! commented_line)
+ {
+ if (d == '*')
+ commented_line = true;
+ else
+ /* If d == '/', cannot tell if it is an Obj.-C comment:
+ may be Mercury integ. division. */
+ blank_line = false;
+ }
+ }
+ FALLTHROUGH;
+ case ' ':
+ case '\t':
+ start_of_line = false;
+ break;
+ case ':':
+ c = fgetc (fp);
+ if (start_of_line)
+ {
+ if (c == '-')
+ {
+ ratio = 1.0; /* Failsafe, not an operator in Obj.-C. */
+ goto out;
+ }
+ start_of_line = false;
+ }
+ else
+ {
+ /* p :- q. Frequent in Mercury.
+ Rare or in quoted exprs in Obj.-C. */
+ if (c == '-' && ! commented_line)
+ ++rule_signs;
+ }
+ blank_line = false;
+ found_dot = false;
+ only_space_before = false;
+ break;
+ case '@':
+ case '#':
+ if (start_of_line || only_space_before)
+ {
+ ratio = 0.0;
+ goto out;
+ }
+ FALLTHROUGH;
+ default:
+ start_of_line = false;
+ blank_line = false;
+ found_dot = false;
+ only_space_before = false;
+ }
+ }
+
+ /* Fallback heuristic test. Not failsafe but errless in pratice. */
+ ratio = ((float) rule_signs + percentage_signs + mercury_dots) / lines;
+
+ out:
+ if (fclose (fp) == EOF)
+ pfatal (this_file);
+
+ if (ratio > mercury_heuristics_ratio)
+ {
+ /* Change the language from Objective-C to Mercury. */
+ static language lang0 = { "mercury", Mercury_help, Mercury_functions,
+ Mercury_suffixes };
+ *lang = &lang0;
+ }
+}
+
+static void
+Mercury_functions (FILE *inf)
+{
+ char *cp, *last = NULL;
+ ptrdiff_t lastlen = 0, allocated = 0;
+ if (declarations) with_mercury_definitions = true;
+
+ LOOP_ON_INPUT_LINES (inf, lb, cp)
+ {
+ if (cp[0] == '\0') /* Empty line. */
+ continue;
+ else if (c_isspace (cp[0]) || cp[0] == '%')
+ /* A Prolog-type comment or anything other than a declaration. */
+ continue;
+ else if (cp[0] == '/' && cp[1] == '*') /* Mercury C-type comment. */
+ mercury_skip_comment (&lb, inf);
+ else
+ {
+ is_mercury_declaration = (cp[0] == ':' && cp[1] == '-');
+
+ if (is_mercury_declaration
+ || with_mercury_definitions)
+ {
+ ptrdiff_t len = mercury_pr (cp, last, lastlen);
+ if (0 < len)
+ {
+ /* Store the declaration to avoid generating duplicate
+ tags later. */
+ if (allocated <= len)
+ {
+ xrnew (last, len + 1, 1);
+ allocated = len + 1;
+ }
+ memcpyz (last, cp, len);
+ lastlen = len;
+ }
+ }
+ }
+ }
+ free (last);
+}
+
+static void
+mercury_skip_comment (linebuffer *plb, FILE *inf)
+{
+ char *cp;
+
+ do
+ {
+ for (cp = plb->buffer; *cp != '\0'; ++cp)
+ if (cp[0] == '*' && cp[1] == '/')
+ return;
+ readline (plb, inf);
+ }
+ while (perhaps_more_input (inf));
+}
+
+/*
+ * A declaration is added if it matches:
+ * <beginning of line>:-<whitespace><Mercury Term><whitespace>(
+ * If with_mercury_definitions == true, we also add:
+ * <beginning of line><Mercury item><whitespace>(
+ * or <beginning of line><Mercury item><whitespace>:-
+ * As for Prolog support, different arities and types are not taken into
+ * consideration.
+ * Item is added to the tags database if it doesn't match the
+ * name of the previous declaration.
+ *
+ * Consume a Mercury declaration.
+ * Return the number of bytes consumed, or 0 if there was an error.
+ *
+ * A Mercury declaration must be one of:
+ * :- type
+ * :- solver type
+ * :- pred
+ * :- func
+ * :- inst
+ * :- mode
+ * :- typeclass
+ * :- instance
+ * :- pragma
+ * :- promise
+ * :- initialise
+ * :- finalise
+ * :- mutable
+ * :- module
+ * :- interface
+ * :- implementation
+ * :- import_module
+ * :- use_module
+ * :- include_module
+ * :- end_module
+ * followed on the same line by an alphanumeric sequence, starting with a lower
+ * case letter or by a single-quoted arbitrary string.
+ * Single quotes can escape themselves. Backslash quotes everything.
+ *
+ * Return the size of the name of the declaration or 0 if no header was found.
+ * As quantifiers may precede functions or predicates, we must list them too.
+ */
+
+static const char *Mercury_decl_tags[] = {"type", "solver type", "pred",
+ "func", "inst", "mode", "typeclass", "instance", "pragma", "promise",
+ "initialise", "finalise", "mutable", "module", "interface", "implementation",
+ "import_module", "use_module", "include_module", "end_module", "some",
"all"};
+
+static size_t
+mercury_decl (char *s, size_t pos)
+{
+ if (s == NULL) return 0;
+
+ size_t origpos;
+ origpos = pos;
+
+ while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) ++pos;
+
+ unsigned char decl_type_length = pos - origpos;
+ char buf[decl_type_length + 1];
+ memset (buf, 0, decl_type_length + 1);
+
+ /* Mercury declaration tags. Consume them, then check the declaration item
+ following :- is legitimate, then go on as in the prolog case. */
+
+ memcpy (buf, &s[origpos], decl_type_length);
+
+ bool found_decl_tag = false;
+
+ if (is_mercury_quantifier)
+ {
+ if (strcmp (buf, "pred") != 0 && strcmp (buf, "func") != 0) /* Bad
syntax. */
+ return 0;
+ is_mercury_quantifier = false; /* Reset to base value. */
+ found_decl_tag = true;
+ }
+ else
+ {
+ for (int j = 0; j < sizeof (Mercury_decl_tags) / sizeof (char*); ++j)
+ {
+ if (strcmp (buf, Mercury_decl_tags[j]) == 0)
+ {
+ found_decl_tag = true;
+ if (strcmp (buf, "type") == 0)
+ is_mercury_type = true;
+
+ if (strcmp (buf, "some") == 0
+ || strcmp (buf, "all") == 0)
+ {
+ is_mercury_quantifier = true;
+ }
+
+ break; /* Found declaration tag of rank j. */
+ }
+ else
+ /* 'solver type' has a blank in the middle,
+ so this is the hard case. */
+ if (strcmp (buf, "solver") == 0)
+ {
+ ++pos;
+ while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_'))
+ ++pos;
+
+ decl_type_length = pos - origpos;
+ char buf2[decl_type_length + 1];
+ memset (buf2, 0, decl_type_length + 1);
+ memcpy (buf2, &s[origpos], decl_type_length);
+
+ if (strcmp (buf2, "solver type") == 0)
+ {
+ found_decl_tag = false;
+ break; /* Found declaration tag of rank j. */
+ }
+ }
+ }
+ }
+
+ /* If with_mercury_definitions == false
+ * this is a Mercury syntax error, ignoring... */
+
+ if (with_mercury_definitions)
+ {
+ if (found_decl_tag)
+ pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */
+ else
+ /* Prolog-like behavior
+ * we have parsed the predicate once, yet inappropriately
+ * so restarting again the parsing step. */
+ pos = 0;
+ }
+ else
+ {
+ if (found_decl_tag)
+ pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */
+ else
+ return 0;
+ }
+
+ /* From now on it is the same as for Prolog except for module dots. */
+
+ if (c_islower (s[pos]) || s[pos] == '_' )
+ {
+ /* The name is unquoted.
+ Do not confuse module dots with end-of-declaration dots. */
+
+ while (c_isalnum (s[pos])
+ || s[pos] == '_'
+ || (s[pos] == '.' /* A module dot. */
+ && s + pos + 1 != NULL
+ && (c_isalnum (s[pos + 1]) || s[pos + 1] == '_')))
+ ++pos;
+
+ return pos - origpos;
+ }
+ else if (s[pos] == '\'')
+ {
+ ++pos;
+ for (;;)
+ {
+ if (s[pos] == '\'')
+ {
+ ++pos;
+ if (s[pos] != '\'')
+ break;
+ ++pos; /* A double quote. */
+ }
+ else if (s[pos] == '\0') /* Multiline quoted atoms are ignored. */
+ return 0;
+ else if (s[pos] == '\\')
+ {
+ if (s[pos+1] == '\0')
+ return 0;
+ pos += 2;
+ }
+ else
+ ++pos;
+ }
+ return pos - origpos;
+ }
+ else if (is_mercury_quantifier && s[pos] == '[') /* :- some [T] pred/func.
*/
+ {
+ for (++pos; s + pos != NULL && s[pos] != ']'; ++pos) {}
+ if (s + pos == NULL) return 0;
+ ++pos;
+ pos = skip_spaces (s + pos) - s;
+ return mercury_decl (s, pos) + pos - origpos;
+ }
+ else
+ return 0;
+}
+
+static ptrdiff_t
+mercury_pr (char *s, char *last, ptrdiff_t lastlen)
+{
+ size_t len0 = 0;
+ is_mercury_type = false;
+ is_mercury_quantifier = false;
+
+ if (is_mercury_declaration)
+ {
+ /* Skip len0 blanks only for declarations. */
+ len0 = skip_spaces (s + 2) - s;
+ }
+
+ size_t len = mercury_decl (s, len0);
+ if (len == 0) return 0;
+ len += len0;
+
+ if (( (s[len] == '.' /* This is a statement dot, not a module dot. */
+ || (s[len] == '(' && (len += 1))
+ || (s[len] == ':' /* Stopping in case of a rule. */
+ && s[len + 1] == '-'
+ && (len += 2)))
+ && (lastlen != len || memcmp (s, last, len) != 0)
+ )
+ /* Types are often declared on several lines so keeping just
+ the first line. */
+ || is_mercury_type)
+ {
+ char *name = skip_non_spaces (s + len0);
+ size_t namelen;
+ if (name >= s + len)
+ {
+ name = s;
+ namelen = len;
+ }
+ else
+ {
+ name = skip_spaces (name);
+ namelen = len - (name - s);
+ }
+ /* Remove trailing non-name characters. */
+ while (namelen > 0 && notinname (name[namelen - 1]))
+ namelen--;
+ make_tag (name, namelen, true, s, len, lineno, linecharno);
+ return len;
+ }
+
+ return 0;
+}
+
+
+/*
* Support for Erlang
*
* Generates tags for functions, defines, and records.
diff --git a/lib/Makefile.in b/lib/Makefile.in
index ec92f92..ccb90c3 100644
--- a/lib/Makefile.in
+++ b/lib/Makefile.in
@@ -64,7 +64,7 @@ endif
../config.status: $(top_srcdir)/configure.ac $(top_srcdir)/m4/*.m4
$(MAKE) -C .. $(notdir $@)
Makefile: ../config.status $(srcdir)/Makefile.in
- $(MAKE) -C .. src/$@
+ $(MAKE) -C .. lib/$@
# Object modules that need not be built for Emacs.
# Emacs does not need e-regex.o (it has its own regex-emacs.c),
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 8e0d9c4..431217a 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -274,7 +274,7 @@ $(THEFILE)c:
ifeq ($(HAVE_NATIVE_COMP),yes)
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l comp -f byte-compile-refresh-preloaded \
- -f batch-byte-native-compile-for-bootstrap $(THEFILE)
+ -f batch-byte+native-compile $(THEFILE)
else
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l bytecomp -f byte-compile-refresh-preloaded \
@@ -295,7 +295,7 @@ endif
ifeq ($(HAVE_NATIVE_COMP),yes)
.el.elc:
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
- -l comp -f batch-byte-native-compile-for-bootstrap $<
+ -l comp -f batch-byte+native-compile $<
else
.el.elc:
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index 2516b4b..9ca28eb 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -121,12 +121,12 @@ let-binding."
:initform nil
:documentation "Internal backend data.")
(create-function :initarg :create-function
- :initform ignore
+ :initform #'ignore
:type function
:custom function
:documentation "The create function.")
(search-function :initarg :search-function
- :initform ignore
+ :initform #'ignore
:type function
:custom function
:documentation "The search function.")))
diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el
index 3fcc023..103a370 100644
--- a/lisp/cedet/ede/base.el
+++ b/lisp/cedet/ede/base.el
@@ -47,7 +47,7 @@
;; and features of those files.
(defclass ede-target (eieio-speedbar-directory-button eieio-named)
- ((buttonface :initform speedbar-file-face) ;override for superclass
+ ((buttonface :initform 'speedbar-file-face) ;override for superclass
(name :initarg :name
:type string
:custom string
@@ -91,16 +91,16 @@ This is used to match target objects with the compilers
they can use, and
which files this object is interested in."
:accessor ede-object-sourcecode)
(keybindings :allocation :class
- :initform (("D" . ede-debug-target))
+ :initform '(("D" . ede-debug-target))
:documentation
"Keybindings specialized to this type of target."
:accessor ede-object-keybindings)
(menu :allocation :class
- :initform ( [ "Debug target" ede-debug-target
- (ede-buffer-belongs-to-target-p) ]
- [ "Run target" ede-run-target
- (ede-buffer-belongs-to-target-p) ]
- )
+ :initform '( [ "Debug target" ede-debug-target
+ (ede-buffer-belongs-to-target-p) ]
+ [ "Run target" ede-run-target
+ (ede-buffer-belongs-to-target-p) ]
+ )
:documentation "Menu specialized to this type of target."
:accessor ede-object-menu)
)
@@ -236,7 +236,7 @@ also be of a form used by TRAMP for use with scp, or rcp.")
This FTP site should be in Emacs form as needed by `ange-ftp'.
If this slot is nil, then use `ftp-site' instead.")
(configurations :initarg :configurations
- :initform ("debug" "release")
+ :initform '("debug" "release")
:type list
:custom (repeat string)
:label "Configuration Options"
@@ -258,25 +258,25 @@ and target specific elements such as build variables.")
:group (settings)
:documentation "Project local variables")
(keybindings :allocation :class
- :initform (("D" . ede-debug-target)
- ("R" . ede-run-target))
+ :initform '(("D" . ede-debug-target)
+ ("R" . ede-run-target))
:documentation "Keybindings specialized to this type of target."
:accessor ede-object-keybindings)
(menu :allocation :class
:initform
- (
- [ "Update Version" ede-update-version ede-object ]
- [ "Version Control Status" ede-vc-project-directory ede-object ]
- [ "Edit Project Homepage" ede-edit-web-page
- (and ede-object (oref (ede-toplevel) web-site-file)) ]
- [ "Browse Project URL" ede-web-browse-home
- (and ede-object
- (not (string= "" (oref (ede-toplevel) web-site-url)))) ]
- "--"
- [ "Rescan Project Files" ede-rescan-toplevel t ]
- [ "Edit Projectfile" ede-edit-file-target
- (ede-buffer-belongs-to-project-p) ]
- )
+ '(
+ [ "Update Version" ede-update-version ede-object ]
+ [ "Version Control Status" ede-vc-project-directory ede-object ]
+ [ "Edit Project Homepage" ede-edit-web-page
+ (and ede-object (oref (ede-toplevel) web-site-file)) ]
+ [ "Browse Project URL" ede-web-browse-home
+ (and ede-object
+ (not (string= "" (oref (ede-toplevel) web-site-url)))) ]
+ "--"
+ [ "Rescan Project Files" ede-rescan-toplevel t ]
+ [ "Edit Projectfile" ede-edit-file-target
+ (ede-buffer-belongs-to-project-p) ]
+ )
:documentation "Menu specialized to this type of target."
:accessor ede-object-menu)
)
diff --git a/lisp/cedet/ede/config.el b/lisp/cedet/ede/config.el
index bc1810a..98a0419 100644
--- a/lisp/cedet/ede/config.el
+++ b/lisp/cedet/ede/config.el
@@ -96,7 +96,7 @@ and also want to save some extra level of configuration.")
This filename excludes the directory name and is used to
initialize the :file slot of the persistent baseclass.")
(config-class
- :initform ede-extra-config
+ :initform 'ede-extra-config
:allocation :class
:type class
:documentation
diff --git a/lisp/cedet/ede/generic.el b/lisp/cedet/ede/generic.el
index b3b59b5..4537f59 100644
--- a/lisp/cedet/ede/generic.el
+++ b/lisp/cedet/ede/generic.el
@@ -137,7 +137,7 @@ subclasses of this base target will override the default
value.")
ede-project-with-config-program
ede-project-with-config-c
ede-project-with-config-java)
- ((config-class :initform ede-generic-config)
+ ((config-class :initform 'ede-generic-config)
(config-file-basename :initform "EDEConfig.el")
(buildfile :initform ""
:type string
diff --git a/lisp/cedet/ede/proj-obj.el b/lisp/cedet/ede/proj-obj.el
index 2ae62f4..1b96376 100644
--- a/lisp/cedet/ede/proj-obj.el
+++ b/lisp/cedet/ede/proj-obj.el
@@ -34,8 +34,8 @@
;;; Code:
(defclass ede-proj-target-makefile-objectcode (ede-proj-target-makefile)
(;; Give this a new default
- (configuration-variables :initform ("debug" . (("CFLAGS" . "-g")
- ("LDFLAGS" . "-g"))))
+ (configuration-variables :initform '("debug" . (("CFLAGS" . "-g")
+ ("LDFLAGS" . "-g"))))
;; @TODO - add an include path.
(availablecompilers :initform '(ede-gcc-compiler
ede-g++-compiler
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el
index 6ff7630..c8c34d0 100644
--- a/lisp/cedet/ede/proj.el
+++ b/lisp/cedet/ede/proj.el
@@ -220,7 +220,7 @@ This enables the creation of your target type."
((extension :initform ".ede")
(file-header-line :initform ";; EDE Project Files are auto generated: Do
Not Edit")
(makefile-type :initarg :makefile-type
- :initform Makefile
+ :initform 'Makefile
:type symbol
:custom (choice (const Makefile)
;(const Makefile.in)
@@ -240,7 +240,7 @@ in targets.")
:documentation "Variables to set in this Makefile.")
(configuration-variables
:initarg :configuration-variables
- :initform ("debug" (("DEBUG" . "1")))
+ :initform '("debug" (("DEBUG" . "1")))
:type list
:custom (repeat (cons (string :tag "Configuration")
(repeat
@@ -269,10 +269,10 @@ These files can contain additional rules, variables, and
customizations.")
:documentation
"Non-nil to do implement automatic dependencies in the Makefile.")
(menu :initform
- (
- [ "Regenerate Makefiles" ede-proj-regenerate t ]
- [ "Upload Distribution" ede-upload-distribution t ]
- )
+ '(
+ [ "Regenerate Makefiles" ede-proj-regenerate t ]
+ [ "Upload Distribution" ede-upload-distribution t ]
+ )
)
(metasubproject
:initarg :metasubproject
diff --git a/lisp/cedet/semantic/db-ebrowse.el
b/lisp/cedet/semantic/db-ebrowse.el
index 682a4cc..8bc3b81 100644
--- a/lisp/cedet/semantic/db-ebrowse.el
+++ b/lisp/cedet/semantic/db-ebrowse.el
@@ -79,7 +79,7 @@ be searched."
;;; SEMANTIC Database related Code
;;; Classes:
(defclass semanticdb-table-ebrowse (semanticdb-table)
- ((major-mode :initform c++-mode)
+ ((major-mode :initform #'c++-mode)
(ebrowse-tree :initform nil
:initarg :ebrowse-tree
:documentation
@@ -95,7 +95,7 @@ This table is composited from the ebrowse *Globals* section.")
(defclass semanticdb-project-database-ebrowse
(semanticdb-project-database)
- ((new-table-class :initform semanticdb-table-ebrowse
+ ((new-table-class :initform 'semanticdb-table-ebrowse
:type class
:documentation
"New tables created for this database are of this class.")
diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el
index 78339c3..41e48b0 100644
--- a/lisp/cedet/semantic/db-el.el
+++ b/lisp/cedet/semantic/db-el.el
@@ -40,7 +40,7 @@
;;; Classes:
(defclass semanticdb-table-emacs-lisp (semanticdb-abstract-table)
- ((major-mode :initform emacs-lisp-mode)
+ ((major-mode :initform #'emacs-lisp-mode)
)
"A table for returning search results from Emacs.")
@@ -63,7 +63,7 @@ It does not need refreshing."
(defclass semanticdb-project-database-emacs-lisp
(semanticdb-project-database eieio-singleton)
- ((new-table-class :initform semanticdb-table-emacs-lisp
+ ((new-table-class :initform 'semanticdb-table-emacs-lisp
:type class
:documentation
"New tables created for this database are of this class.")
diff --git a/lisp/cedet/semantic/db-javascript.el
b/lisp/cedet/semantic/db-javascript.el
index cad561e..bf3d612 100644
--- a/lisp/cedet/semantic/db-javascript.el
+++ b/lisp/cedet/semantic/db-javascript.el
@@ -80,7 +80,7 @@ See bottom of this file for instructions on managing this
list.")
;;; Classes:
(defclass semanticdb-table-javascript (semanticdb-search-results-table)
- ((major-mode :initform javascript-mode)
+ ((major-mode :initform #'javascript-mode)
)
"A table for returning search results from javascript.")
@@ -88,7 +88,7 @@ See bottom of this file for instructions on managing this
list.")
(semanticdb-project-database
eieio-singleton ;this db is for js globals, so singleton is appropriate
)
- ((new-table-class :initform semanticdb-table-javascript
+ ((new-table-class :initform 'semanticdb-table-javascript
:type class
:documentation
"New tables created for this database are of this class.")
diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el
index 8f9ecee..38e2b34 100644
--- a/lisp/cedet/semantic/db.el
+++ b/lisp/cedet/semantic/db.el
@@ -321,12 +321,12 @@ Adds the number of tags in this file to the object print
name."
'(list-of semanticdb-abstract-table))
(defclass semanticdb-project-database (eieio-instance-tracker)
- ((tracking-symbol :initform semanticdb-database-list)
+ ((tracking-symbol :initform 'semanticdb-database-list)
(reference-directory :type string
:documentation "Directory this database refers to.
When a cache directory is specified, then this refers to the directory
this database contains symbols for.")
- (new-table-class :initform semanticdb-table
+ (new-table-class :initform 'semanticdb-table
:type class
:documentation
"New tables created for this database are of this class.")
diff --git a/lisp/cedet/semantic/ede-grammar.el
b/lisp/cedet/semantic/ede-grammar.el
index 6bb8352..19d4184 100644
--- a/lisp/cedet/semantic/ede-grammar.el
+++ b/lisp/cedet/semantic/ede-grammar.el
@@ -38,13 +38,13 @@
(keybindings :initform nil)
(phony :initform t)
(sourcetype :initform
- (semantic-ede-source-grammar-wisent
- semantic-ede-source-grammar-bovine
- ))
+ '(semantic-ede-source-grammar-wisent
+ semantic-ede-source-grammar-bovine
+ ))
(availablecompilers :initform
- (semantic-ede-grammar-compiler-wisent
- semantic-ede-grammar-compiler-bovine
- ))
+ '(semantic-ede-grammar-compiler-wisent
+ semantic-ede-grammar-compiler-bovine
+ ))
(aux-packages :initform '("semantic" "cedet-compat"))
(pre-load-packages :initform '("cedet-compat" "semantic/grammar"
"semantic/bovine/grammar" "semantic/wisent/grammar"))
)
diff --git a/lisp/cedet/semantic/symref/grep.el
b/lisp/cedet/semantic/symref/grep.el
index 46027f1..180d779 100644
--- a/lisp/cedet/semantic/symref/grep.el
+++ b/lisp/cedet/semantic/symref/grep.el
@@ -168,7 +168,7 @@ This shell should support pipe redirect syntax."
(erase-buffer)
(setq default-directory rootdir)
(let ((cmd (semantic-symref-grep-use-template
- (file-name-as-directory (file-local-name rootdir))
+ (directory-file-name (file-local-name rootdir))
filepattern grepflags greppat)))
(process-file semantic-symref-grep-shell nil b nil
shell-command-switch cmd)))
diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el
index 36df1da..15107ef 100644
--- a/lisp/cedet/srecode/compile.el
+++ b/lisp/cedet/srecode/compile.el
@@ -110,7 +110,12 @@ stack is broken."
:type (or null string)
:documentation
"If there is a colon in the inserter's name, it represents
-additional static argument data."))
+additional static argument data.")
+ (key :initform nil :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.
+All children of this class should specify `key' slot with appropriate
+:initform value."))
"This represents an item to be inserted via a template macro.
Plain text strings are not handled via this baseclass."
:abstract t)
diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el
index ab0503c..f20842b 100644
--- a/lisp/cedet/srecode/insert.el
+++ b/lisp/cedet/srecode/insert.el
@@ -89,6 +89,8 @@ DICT-ENTRIES are additional dictionary values to add."
;; for this insertion step.
))
+(eieio-declare-slots (point :allocation :class))
+
(defun srecode-insert-fcn (template dictionary &optional stream skipresolver)
"Insert TEMPLATE using DICTIONARY into STREAM.
Optional SKIPRESOLVER means to avoid refreshing the tag list,
@@ -134,13 +136,13 @@ has set everything up already."
)
(srecode-insert-method template dictionary))
;; Handle specialization of the POINT inserter.
- (when (and (bufferp standard-output)
- (slot-boundp 'srecode-template-inserter-point 'point)
- )
- (set-buffer standard-output)
- (setq end-mark (point-marker))
- (goto-char (oref-default 'srecode-template-inserter-point point)))
- (oset-default 'srecode-template-inserter-point point eieio-unbound)
+ (when (bufferp standard-output)
+ (let ((point (oref-default 'srecode-template-inserter-point point)))
+ (when point
+ (set-buffer standard-output)
+ (setq end-mark (point-marker))
+ (goto-char point))))
+ (oset-default 'srecode-template-inserter-point point nil)
;; Return the end-mark.
(or end-mark (point)))
@@ -733,6 +735,7 @@ DEPTH.")
"The character code used to identify inserters of this style.")
(point :type (or null marker)
:allocation :class
+ :initform nil
:documentation
"Record the value of (point) in this class slot.
It is the responsibility of the inserter algorithm to clear this
diff --git a/lisp/custom.el b/lisp/custom.el
index 078e3a8..1db3f4f 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -1528,7 +1528,7 @@ See `custom-enabled-themes' for a list of enabled themes."
(let* ((prop (car s))
(symbol (cadr s))
(val (assq-delete-all theme (get symbol prop))))
- (custom-push-theme prop symbol theme 'reset)
+ (put symbol prop val)
(cond
((eq prop 'theme-value)
(custom-theme-recalc-variable symbol)
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index a1dda3f..54cfbba 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1859,7 +1859,7 @@ unless OK-IF-ALREADY-EXISTS is non-nil."
(while blist
(with-current-buffer (car blist)
(if (and buffer-file-name
- (dired-in-this-tree-p buffer-file-name expanded-from-dir))
+ (file-in-directory-p buffer-file-name expanded-from-dir))
(let ((modflag (buffer-modified-p))
(to-file (replace-regexp-in-string
(concat "^" (regexp-quote from-dir))
@@ -1878,7 +1878,7 @@ unless OK-IF-ALREADY-EXISTS is non-nil."
(while alist
(setq elt (car alist)
alist (cdr alist))
- (if (dired-in-this-tree-p (car elt) expanded-dir)
+ (if (file-in-directory-p (car elt) expanded-dir)
;; ELT's subdir is affected by the rename
(dired-rename-subdir-2 elt dir to)))
(if (equal dir default-directory)
@@ -1963,6 +1963,9 @@ or with the current marker character if MARKER-CHAR is t."
(let (to overwrite-query
overwrite-backup-query) ; for dired-handle-overwrite
(dolist (from fn-list)
+ ;; Position point on the current file -- this is useful if
+ ;; handling a number of files to show where we're working at.
+ (dired-goto-file from)
(setq to (funcall name-constructor from))
(if (equal to from)
(progn
@@ -2704,7 +2707,7 @@ This function takes some pains to conform to `ls -lR'
output."
(setq switches (string-replace "R" "" switches))
(dolist (cur-ass dired-subdir-alist)
(let ((cur-dir (car cur-ass)))
- (and (dired-in-this-tree-p cur-dir dirname)
+ (and (file-in-directory-p cur-dir dirname)
(let ((cur-cons (assoc-string cur-dir dired-switches-alist)))
(if cur-cons
(setcdr cur-cons switches)
@@ -2716,7 +2719,7 @@ This function takes some pains to conform to `ls -lR'
output."
(defun dired-insert-subdir-validate (dirname &optional switches)
;; Check that it is valid to insert DIRNAME with SWITCHES.
;; Signal an error if invalid (e.g. user typed `i' on `..').
- (or (dired-in-this-tree-p dirname (expand-file-name default-directory))
+ (or (file-in-directory-p dirname (expand-file-name default-directory))
(error "%s: not in this directory tree" dirname))
(let ((real-switches (or switches dired-subdir-switches)))
(when real-switches
@@ -2757,7 +2760,7 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME
as well."
(setq dir (car (car s-alist))
s-alist (cdr s-alist))
(and (or kill-root (not (string-equal dir dirname)))
- (dired-in-this-tree-p dir dirname)
+ (file-in-directory-p dir dirname)
(dired-goto-subdir dir)
(setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist))))
m-alist))
@@ -2989,7 +2992,7 @@ Lower levels are unaffected."
(while rest
(setq elt (car rest)
rest (cdr rest))
- (if (dired-in-this-tree-p (directory-file-name (car elt)) dir)
+ (if (file-in-directory-p (directory-file-name (car elt)) dir)
(setq rest nil
pos (dired-goto-subdir (car elt))))))
(if pos
diff --git a/lisp/dired.el b/lisp/dired.el
index 8527634..bb428e2 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -2820,10 +2820,12 @@ You can then feed the file name(s) to other commands
with \\[yank]."
;; Keeping Dired buffers in sync with the filesystem and with each other
-(defun dired-buffers-for-dir (dir &optional file)
+(defun dired-buffers-for-dir (dir &optional file subdirs)
"Return a list of buffers for DIR (top level or in-situ subdir).
If FILE is non-nil, include only those whose wildcard pattern (if any)
matches FILE.
+If SUBDIRS is non-nil, also include the dired buffers of
+directories below DIR.
The list is in reverse order of buffer creation, most recent last.
As a side effect, killed dired buffers for DIR are removed from
dired-buffers."
@@ -2835,19 +2837,20 @@ dired-buffers."
((null (buffer-name buf))
;; Buffer is killed - clean up:
(setq dired-buffers (delq elt dired-buffers)))
- ((dired-in-this-tree-p dir (car elt))
+ ((file-in-directory-p (car elt) dir)
(with-current-buffer buf
- (and (assoc dir dired-subdir-alist)
- (or (null file)
- (if (stringp dired-directory)
- (let ((wildcards (file-name-nondirectory
- dired-directory)))
- (or (zerop (length wildcards))
- (string-match-p (dired-glob-regexp wildcards)
- file)))
- (member (expand-file-name file dir)
- (cdr dired-directory))))
- (setq result (cons buf result)))))))
+ (when (and (or subdirs
+ (assoc dir dired-subdir-alist))
+ (or (null file)
+ (if (stringp dired-directory)
+ (let ((wildcards (file-name-nondirectory
+ dired-directory)))
+ (or (zerop (length wildcards))
+ (string-match-p (dired-glob-regexp wildcards)
+ file)))
+ (member (expand-file-name file dir)
+ (cdr dired-directory)))))
+ (setq result (cons buf result)))))))
result))
(defun dired-glob-regexp (pattern)
@@ -2912,6 +2915,7 @@ dired-buffers."
;;"Is FILE part of the directory tree starting at DIR?"
(let (case-fold-search)
(string-match-p (concat "^" (regexp-quote dir)) file)))
+(make-obsolete 'dired-in-this-tree-p 'file-in-directory-p "28.1")
(define-obsolete-function-alias 'dired-in-this-tree
'dired-in-this-tree-p "27.1")
@@ -3280,15 +3284,19 @@ non-empty directories is allowed."
(interactive)
(let* ((dired-marker-char dired-del-marker)
(regexp (dired-marker-regexp))
- case-fold-search)
+ case-fold-search markers)
(if (save-excursion (goto-char (point-min))
(re-search-forward regexp nil t))
(dired-internal-do-deletions
(nreverse
;; this can't move point since ARG is nil
- (dired-map-over-marks (cons (dired-get-filename) (point))
+ (dired-map-over-marks (cons (dired-get-filename)
+ (let ((m (point-marker)))
+ (push m markers)
+ m))
nil))
nil t)
+ (dolist (m markers) (set-marker m nil))
(or nomessage
(message "(No deletions requested)")))))
@@ -3299,12 +3307,17 @@ non-empty directories is allowed."
;; This is more consistent with the file marking feature than
;; dired-do-flagged-delete.
(interactive "P")
- (dired-internal-do-deletions
- (nreverse
- ;; this may move point if ARG is an integer
- (dired-map-over-marks (cons (dired-get-filename) (point))
- arg))
- arg t))
+ (let (markers)
+ (dired-internal-do-deletions
+ (nreverse
+ ;; this may move point if ARG is an integer
+ (dired-map-over-marks (cons (dired-get-filename)
+ (let ((m (point-marker)))
+ (push m markers)
+ m))
+ arg))
+ arg t)
+ (dolist (m markers) (set-marker m nil))))
(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p?
@@ -3312,11 +3325,6 @@ non-empty directories is allowed."
;; L is an alist of files to delete, with their buffer positions.
;; ARG is the prefix arg.
;; Filenames are absolute.
- ;; (car L) *must* be the *last* (bottommost) file in the dired buffer.
- ;; That way as changes are made in the buffer they do not shift the
- ;; lines still to be changed, so the (point) values in L stay valid.
- ;; Also, for subdirs in natural order, a subdir's files are deleted
- ;; before the subdir itself - the other way around would not work.
(let* ((files (mapcar #'car l))
(count (length l))
(succ 0)
@@ -3337,9 +3345,10 @@ non-empty directories is allowed."
(make-progress-reporter
(if trashing "Trashing..." "Deleting...")
succ count))
- failures) ;; files better be in reverse order for this loop!
+ failures)
(while l
- (goto-char (cdr (car l)))
+ (goto-char (marker-position (cdr (car l))))
+ (dired-move-to-filename)
(let ((inhibit-read-only t))
(condition-case err
(let ((fn (car (car l))))
@@ -3422,7 +3431,8 @@ confirmation. To disable the confirmation, see
(file-name-nondirectory fn))))
(not dired-clean-confirm-killing-deleted-buffers))
(kill-buffer buf)))
- (let ((buf-list (dired-buffers-for-dir (expand-file-name fn))))
+ (let ((buf-list (dired-buffers-for-dir (expand-file-name fn)
+ nil 'subdirs)))
(and buf-list
(or (and dired-clean-confirm-killing-deleted-buffers
(y-or-n-p
diff --git a/lisp/electric.el b/lisp/electric.el
index 6701a36..4394fae 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -245,10 +245,7 @@ or comment."
'electric-indent-functions
last-command-event)
(memq last-command-event electric-indent-chars))))
- (not
- (or (memq act '(nil no-indent))
- ;; In a string or comment.
- (unless (eq act 'do-indent) (nth 8 (syntax-ppss))))))))
+ (not (memq act '(nil no-indent))))))
;; If we error during indent, silently give up since this is an
;; automatic action that the user didn't explicitly request.
;; But we don't want to suppress errors from elsewhere in *this*
diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index 439d3bd..64c6288 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -37,8 +37,7 @@
"Return the time in seconds elapsed for execution of FORMS."
(declare (indent 0) (debug t))
(let ((t1 (make-symbol "t1")))
- `(let (,t1)
- (setq ,t1 (current-time))
+ `(let ((,t1 (current-time)))
,@forms
(float-time (time-since ,t1)))))
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 10a50da..2fff0bd 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -343,7 +343,7 @@ Same format as `byte-optimize--lexvars', with shared
structure and contents.")
(numberp expr)
(stringp expr)
(and (consp expr)
- (eq (car expr) 'quote)
+ (memq (car expr) '(quote function))
(symbolp (cadr expr)))
(keywordp expr)))
@@ -1269,6 +1269,14 @@ See Info node `(elisp) Integer Basics'."
form)
form))
+(put 'cons 'byte-optimizer #'byte-optimize-cons)
+(defun byte-optimize-cons (form)
+ ;; (cons X nil) => (list X)
+ (if (and (= (safe-length form) 3)
+ (null (nth 2 form)))
+ `(list ,(nth 1 form))
+ form))
+
;; Fixme: delete-char -> delete-region (byte-coded)
;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte,
;; string-make-multibyte for constant args.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 86c5d32..96a0da9 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -606,7 +606,7 @@ Each element is (INDEX . VALUE)")
"Non nil while native compiling.")
(defvar byte-native-qualities nil
"To spill default qualities from the compiled file.")
-(defvar byte-native-for-bootstrap nil
+(defvar byte+native-compile nil
"Non nil while compiling for bootstrap."
;; During bootstrap we produce both the .eln and the .elc together.
;; Because the make target is the later this has to be produced as
@@ -2109,7 +2109,7 @@ See also `emacs-lisp-byte-compile-and-load'."
;; recompiled). Previously this was accomplished by
;; deleting target-file before writing it.
(if byte-native-compiling
- (if byte-native-for-bootstrap
+ (if byte+native-compile
;; Defer elc final renaming.
(setf byte-to-native-output-file
(cons tempfile target-file))
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index 5afc6d3..0494497 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -203,7 +203,7 @@ Make sure the width/height is correct."
(defclass chart-bar (chart)
((direction :initarg :direction
- :initform vertical))
+ :initform 'vertical))
"Subclass for bar charts (vertical or horizontal).")
(cl-defmethod chart-draw ((c chart) &optional buff)
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index b09739c..638d4b2 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -200,6 +200,9 @@ Emacs Lisp file:
\;; Local Variables:\n;; no-native-compile: t\n;; End:")
;;;###autoload(put 'no-native-compile 'safe-local-variable 'booleanp)
+(defvar native-compile-target-directory nil
+ "When non-nil force the target directory for the eln files being compiled.")
+
(defvar comp-log-time-report nil
"If non-nil, log a time report for each pass.")
@@ -1337,8 +1340,9 @@ clashes."
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename
filename
- (when byte-native-for-bootstrap
- (car (last
native-comp-eln-load-path))))))
+ (or native-compile-target-directory
+ (when byte+native-compile
+ (car (last
native-comp-eln-load-path)))))))
(setf (comp-ctxt-speed comp-ctxt) (alist-get 'native-comp-speed
byte-native-qualities)
(comp-ctxt-debug comp-ctxt) (alist-get 'native-comp-debug
@@ -3643,7 +3647,7 @@ Prepare every function for final compilation and drive
the C back-end."
;; unless during bootstrap or async compilation (bug#45056). GCC
;; leaks memory but also interfere with the ability of Emacs to
;; detect when a sub-process completes (TODO understand why).
- (if (or byte-native-for-bootstrap comp-async-compilation)
+ (if (or byte+native-compile comp-async-compilation)
(comp-final1)
;; Call comp-final1 in a child process.
(let* ((output (comp-ctxt-output comp-ctxt))
@@ -3941,7 +3945,11 @@ display a message."
(load1 load)
(process (make-process
:name (concat "Compiling: " source-file)
- :buffer (get-buffer-create comp-async-buffer-name)
+ :buffer (with-current-buffer
+ (get-buffer-create
+ comp-async-buffer-name)
+ (setf buffer-read-only t)
+ (current-buffer))
:command (list
(expand-file-name invocation-name
invocation-directory)
@@ -3970,8 +3978,9 @@ display a message."
(run-hooks 'native-comp-async-all-done-hook)
(with-current-buffer (get-buffer-create comp-async-buffer-name)
(save-excursion
- (goto-char (point-max))
- (insert "Compilation finished.\n")))
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (insert "Compilation finished.\n"))))
;; `comp-deferred-pending-h' should be empty at this stage.
;; Reset it anyway.
(clrhash comp-deferred-pending-h)))
@@ -4166,7 +4175,7 @@ it won’t work in an interactive Emacs.
Native compilation equivalent to `batch-byte-compile'."
(comp-ensure-native-compiler)
(cl-loop for file in command-line-args-left
- if (or (null byte-native-for-bootstrap)
+ if (or (null byte+native-compile)
(cl-notany (lambda (re) (string-match re file))
native-comp-bootstrap-deny-list))
do (comp--native-compile file)
@@ -4174,18 +4183,18 @@ Native compilation equivalent to `batch-byte-compile'."
do (byte-compile-file file)))
;;;###autoload
-(defun batch-byte-native-compile-for-bootstrap ()
+(defun batch-byte+native-compile ()
"Like `batch-native-compile', but used for bootstrap.
Generate .elc files in addition to the .eln files.
Force the produced .eln to be outputted in the eln system
-directory (the last entry in `native-comp-eln-load-path').
-If the environment variable 'NATIVE_DISABLED' is set, only byte
-compile."
+directory (the last entry in `native-comp-eln-load-path') unless
+`native-compile-target-directory' is non-nil. If the environment
+variable 'NATIVE_DISABLED' is set, only byte compile."
(comp-ensure-native-compiler)
(if (equal (getenv "NATIVE_DISABLED") "1")
(batch-byte-compile)
(cl-assert (length= command-line-args-left 1))
- (let ((byte-native-for-bootstrap t)
+ (let ((byte+native-compile t)
(byte-to-native-output-file nil))
(batch-native-compile)
(pcase byte-to-native-output-file
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 641882c..ec7c899 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -156,7 +156,7 @@ only one object ever exists."
;; NOTE TO SELF: In next version, make `slot-boundp' support classes
;; with class allocated slots or default values.
(let ((old (oref-default class singleton)))
- (if (eq old eieio-unbound)
+ (if (eq old eieio--unbound)
(oset-default class singleton (cl-call-next-method))
old)))
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 34b4575..8f1e38b 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -71,11 +71,10 @@ Currently under control of this var:
- Define <class>-child-p and <class>-list-p predicates.
- Allow object names in constructors.")
-(defconst eieio-unbound
- (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound))
- eieio-unbound
- (make-symbol "unbound"))
+(define-obsolete-variable-alias 'eieio-unbound 'eieio--unbound "28.1")
+(defvar eieio--unbound (make-symbol "eieio--unbound")
"Uninterned symbol representing an unbound slot in an object.")
+(defvar eieio--unbound-form (macroexp-quote eieio--unbound))
;; This is a bootstrap for eieio-default-superclass so it has a value
;; while it is being built itself.
@@ -264,6 +263,7 @@ use \\='%s or turn off `eieio-backward-compatibility'
instead" cname)
(object-of-class-p obj class))))
(defvar eieio--known-slot-names nil)
+(defvar eieio--known-class-slot-names nil)
(defun eieio-defclass-internal (cname superclasses slots options)
"Define CNAME as a new subclass of SUPERCLASSES.
@@ -381,7 +381,7 @@ See `defclass' for more information."
(pcase-dolist (`(,name . ,slot) slots)
(let* ((init (or (plist-get slot :initform)
(if (member :initform slot) nil
- eieio-unbound)))
+ eieio--unbound-form)))
(initarg (plist-get slot :initarg))
(docstr (plist-get slot :documentation))
(prot (plist-get slot :protection))
@@ -395,6 +395,14 @@ See `defclass' for more information."
(skip-nil (eieio--class-option-assoc options :allow-nil-initform))
)
+ (unless (or (macroexp-const-p init)
+ (eieio--eval-default-p init))
+ ;; FIXME: We duplicate this test here and in `defclass' because
+ ;; if we move this part to `defclass' we may break some existing
+ ;; code (because the `fboundp' test in `eieio--eval-default-p'
+ ;; returns a different result at compile time).
+ (setq init (macroexp-quote init)))
+
;; Clean up the meaning of protection.
(setq prot
(pcase prot
@@ -457,8 +465,9 @@ See `defclass' for more information."
(n (length slots))
(v (make-vector n nil)))
(dotimes (i n)
- (setf (aref v i) (eieio-default-eval-maybe
- (cl--slot-descriptor-initform (aref slots i)))))
+ (setf (aref v i) (eval
+ (cl--slot-descriptor-initform (aref slots i))
+ t)))
(setf (eieio--class-class-allocation-values newc) v))
;; Attach slot symbols into a hash table, and store the index of
@@ -513,7 +522,7 @@ See `defclass' for more information."
cname
))
-(defsubst eieio-eval-default-p (val)
+(defun eieio--eval-default-p (val)
"Whether the default value VAL should be evaluated for use."
(and (consp val) (symbolp (car val)) (fboundp (car val))))
@@ -522,10 +531,10 @@ See `defclass' for more information."
If SKIPNIL is non-nil, then if default value is nil return t instead."
(let ((value (cl--slot-descriptor-initform slot))
(spec (cl--slot-descriptor-type slot)))
- (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
+ (if (not (or (not (macroexp-const-p value))
eieio-skip-typecheck
(and skipnil (null value))
- (eieio--perform-slot-validation spec value)))
+ (eieio--perform-slot-validation spec (eval value t))))
(signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec
value)))))
(defun eieio--slot-override (old new skipnil)
@@ -546,7 +555,7 @@ If SKIPNIL is non-nil, then if default value is nil return
t instead."
type tp a))
(setf (cl--slot-descriptor-type new) tp))
;; If we have a repeat, only update the initarg...
- (unless (eq d eieio-unbound)
+ (unless (eq d eieio--unbound-form)
(eieio--perform-slot-validation-for-default new skipnil)
(setf (cl--slot-descriptor-initform old) d))
@@ -604,6 +613,8 @@ if default value is nil."
(cold (car (cl-member a (eieio--class-class-slots newc)
:key #'cl--slot-descriptor-name))))
(cl-pushnew a eieio--known-slot-names)
+ (when (eq alloc :class)
+ (cl-pushnew a eieio--known-class-slot-names))
(condition-case nil
(if (sequencep d) (setq d (copy-sequence d)))
;; This copy can fail on a cons cell with a non-cons in the cdr. Let's
@@ -679,7 +690,7 @@ the new child class."
(defun eieio--perform-slot-validation (spec value)
"Return non-nil if SPEC does not match VALUE."
(or (eq spec t) ; t always passes
- (eq value eieio-unbound) ; unbound always passes
+ (eq value eieio--unbound) ; unbound always passes
(cl-typep value spec)))
(defun eieio--validate-slot-value (class slot-idx value slot)
@@ -715,7 +726,7 @@ an error."
INSTANCE is the object being referenced. SLOTNAME is the offending
slot. If the slot is ok, return VALUE.
Argument FN is the function calling this verifier."
- (if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
+ (if (and (eq value eieio--unbound) (not eieio-skip-typecheck))
(slot-unbound instance (eieio--object-class instance) slotname fn)
value))
@@ -755,15 +766,29 @@ Argument FN is the function calling this verifier."
(eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
-(defun eieio-oref-default (obj slot)
+(defun eieio-oref-default (class slot)
"Do the work for the macro `oref-default' with similar parameters.
-Fills in OBJ's SLOT with its default value."
- (declare (gv-setter eieio-oset-default))
- (cl-check-type obj (or eieio-object class))
+Fills in CLASS's SLOT with its default value."
+ (declare (gv-setter eieio-oset-default)
+ (compiler-macro
+ (lambda (exp)
+ (ignore class)
+ (pcase slot
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Unknown slot `%S'" name) exp 'compile-only))
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-class-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Slot `%S' is not class-allocated" name)
+ exp 'compile-only))
+ (_ exp)))))
+ (cl-check-type class (or eieio-object class))
(cl-check-type slot symbol)
- (let* ((cl (cond ((symbolp obj) (cl--find-class obj))
- ((eieio-object-p obj) (eieio--object-class obj))
- (t obj)))
+ (let* ((cl (cond ((symbolp class) (cl--find-class class))
+ ((eieio-object-p class) (eieio--object-class class))
+ (t class)))
(c (eieio--slot-name-index cl slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
@@ -773,27 +798,13 @@ Fills in OBJ's SLOT with its default value."
;; Oref that slot.
(aref (eieio--class-class-allocation-values cl)
c)
- (slot-missing obj slot 'oref-default))
+ (slot-missing class slot 'oref-default))
(eieio-barf-if-slot-unbound
(let ((val (cl--slot-descriptor-initform
(aref (eieio--class-slots cl)
(- c (eval-when-compile eieio--object-num-slots))))))
- (eieio-default-eval-maybe val))
- obj (eieio--class-name cl) 'oref-default))))
-
-(defun eieio-default-eval-maybe (val)
- "Check VAL, and return what `oref-default' would provide."
- ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate
- ;; variables as well? Why not just always call `eval'?
- (cond
- ;; Is it a function call? If so, evaluate it.
- ((eieio-eval-default-p val)
- (eval val t))
- ;;;; check for quoted things, and unquote them
- ;;((and (consp val) (eq (car val) 'quote))
- ;; (car (cdr val)))
- ;; return it verbatim
- (t val)))
+ (eval val t))
+ class (eieio--class-name cl) 'oref-default))))
(defun eieio-oset (obj slot value)
"Do the work for the macro `oset'.
@@ -820,6 +831,20 @@ Fills in OBJ's SLOT with VALUE."
(defun eieio-oset-default (class slot value)
"Do the work for the macro `oset-default'.
Fills in the default value in CLASS' in SLOT with VALUE."
+ (declare (compiler-macro
+ (lambda (exp)
+ (ignore class value)
+ (pcase slot
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Unknown slot `%S'" name) exp 'compile-only))
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-class-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Slot `%S' is not class-allocated" name)
+ exp 'compile-only))
+ (_ exp)))))
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
(cl-check-type slot symbol)
@@ -836,22 +861,18 @@ Fills in the default value in CLASS' in SLOT with VALUE."
(signal 'invalid-slot-name (list (eieio--class-name class) slot)))
;; `oset-default' on an instance-allocated slot is allowed by EIEIO but
;; not by CLOS and is mildly inconsistent with the :initform thingy, so
- ;; it'd be nice to get of it. This said, it is/was used at one place by
- ;; gnus/registry.el, so it might be used elsewhere as well, so let's
- ;; keep it for now.
+ ;; it'd be nice to get rid of it.
+ ;; This said, it is/was used at one place by gnus/registry.el, so it
+ ;; might be used elsewhere as well, so let's keep it for now.
;; FIXME: Generate a compile-time warning for it!
;; (error "Can't `oset-default' an instance-allocated slot: %S of %S"
;; slot class)
(eieio--validate-slot-value class c value slot)
;; Set this into the storage for defaults.
- (if (eieio-eval-default-p value)
- (error "Can't set default to a sexp that gets evaluated again"))
(setf (cl--slot-descriptor-initform
- ;; FIXME: Apparently we set it both in `slots' and in
- ;; `object-cache', which seems redundant.
(aref (eieio--class-slots class)
(- c (eval-when-compile eieio--object-num-slots))))
- value)
+ (macroexp-quote value))
;; Take the value, and put it into our cache object.
(eieio-oset (eieio--class-default-object-cache class)
slot value)
@@ -1093,8 +1114,20 @@ These match if the argument is the name of a subclass of
CLASS."
(defmacro eieio-declare-slots (&rest slots)
"Declare that SLOTS are known eieio object slot names."
- `(eval-when-compile
- (setq eieio--known-slot-names (append ',slots eieio--known-slot-names))))
+ (let ((slotnames (mapcar (lambda (s) (if (consp s) (car s) s)) slots))
+ (classslots (delq nil
+ (mapcar (lambda (s)
+ (when (and (consp s)
+ (eq :class (plist-get (cdr s)
+
:allocation)))
+ (car s)))
+ slots))))
+ `(eval-when-compile
+ ,@(when classslots
+ (mapcar (lambda (s) `(add-to-list 'eieio--known-class-slot-names
',s))
+ classslots))
+ ,@(mapcar (lambda (s) `(add-to-list 'eieio--known-slot-names ',s))
+ slotnames))))
(provide 'eieio-core)
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 8257f7a..d7d078b 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -46,7 +46,7 @@
:documentation "A string for testing custom.
This is the next line of documentation.")
(listostuff :initarg :listostuff
- :initform ("1" "2" "3")
+ :initform '("1" "2" "3")
:type list
:custom (repeat (string :tag "Stuff"))
:label "List of Strings"
diff --git a/lisp/emacs-lisp/eieio-speedbar.el
b/lisp/emacs-lisp/eieio-speedbar.el
index c25ea8a..3f2a653 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -248,7 +248,7 @@ and take the appropriate action."
Possible values are those symbols supported by the `exp-button-type' argument
to `speedbar-make-tag-line'."
:allocation :class)
- (buttonface :initform speedbar-tag-face
+ (buttonface :initform 'speedbar-tag-face
:type (or symbol face)
:documentation
"The face used on the textual part of the button for this class.
@@ -265,15 +265,15 @@ Add one of the child classes to this class to the parent
list of a class."
:abstract t)
(defclass eieio-speedbar-directory-button (eieio-speedbar)
- ((buttontype :initform angle)
- (buttonface :initform speedbar-directory-face))
+ ((buttontype :initform 'angle)
+ (buttonface :initform 'speedbar-directory-face))
"Class providing support for objects which behave like a directory."
:method-invocation-order :depth-first
:abstract t)
(defclass eieio-speedbar-file-button (eieio-speedbar)
- ((buttontype :initform bracket)
- (buttonface :initform speedbar-file-face))
+ ((buttontype :initform 'bracket)
+ (buttonface :initform 'speedbar-file-face))
"Class providing support for objects which behave like a file."
:method-invocation-order :depth-first
:abstract t)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 31b6b09..1c8c372 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -131,6 +131,7 @@ and reference them using the function `class-option'."
(let ((testsym1 (intern (concat (symbol-name name) "-p")))
(testsym2 (intern (format "%s--eieio-childp" name)))
+ (warnings '())
(accessors ()))
;; Collect the accessors we need to define.
@@ -145,6 +146,8 @@ and reference them using the function `class-option'."
;; Update eieio--known-slot-names already in case we compile code which
;; uses this before the class is loaded.
(cl-pushnew sname eieio--known-slot-names)
+ (when (eq alloc :class)
+ (cl-pushnew sname eieio--known-class-slot-names))
(if eieio-error-unsupported-class-tags
(let ((tmp soptions))
@@ -176,8 +179,22 @@ and reference them using the function `class-option'."
(signal 'invalid-slot-type (list :label label)))
;; Is there an initarg, but allocation of class?
- (if (and initarg (eq alloc :class))
- (message "Class allocated slots do not need :initarg"))
+ (when (and initarg (eq alloc :class))
+ (push (format "Meaningless :initarg for class allocated slot '%S'"
+ sname)
+ warnings))
+
+ (let ((init (plist-get soptions :initform)))
+ (unless (or (macroexp-const-p init)
+ (eieio--eval-default-p init))
+ ;; FIXME: Historically, EIEIO used a heuristic to try and guess
+ ;; whether the initform is a form to be evaluated or just
+ ;; a constant. We use `eieio--eval-default-p' to see what the
+ ;; heuristic says and if it disagrees with normal evaluation
+ ;; then tweak the initform to make it fit and emit
+ ;; a warning accordingly.
+ (push (format "Ambiguous initform needs quoting: %S" init)
+ warnings)))
;; Anyone can have an accessor function. This creates a function
;; of the specified name, and also performs a `defsetf' if applicable
@@ -223,6 +240,8 @@ This method is obsolete."
))
`(progn
+ ,@(mapcar (lambda (w) (macroexp-warn-and-return w `(progn ',w)
'compile-only))
+ warnings)
;; This test must be created right away so we can have self-
;; referencing classes. ei, a class whose slot can contain only
;; pointers to itself.
@@ -282,9 +301,7 @@ This method is obsolete."
;;; Get/Set slots in an object.
;;
(defmacro oref (obj slot)
- "Retrieve the value stored in OBJ in the slot named by SLOT.
-Slot is the name of the slot when created by `defclass' or the label
-created by the :initarg tag."
+ "Retrieve the value stored in OBJ in the slot named by SLOT."
(declare (debug (form symbolp)))
`(eieio-oref ,obj (quote ,slot)))
@@ -292,13 +309,11 @@ created by the :initarg tag."
(defalias 'set-slot-value #'eieio-oset)
(make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1")
-(defmacro oref-default (obj slot)
- "Get the default value of OBJ (maybe a class) for SLOT.
-The default value is the value installed in a class with the :initform
-tag. SLOT can be the slot name, or the tag specified by the :initarg
-tag in the `defclass' call."
+(defmacro oref-default (class slot)
+ "Get the value of class allocated slot SLOT.
+CLASS can also be an object, in which case we use the object's class."
(declare (debug (form symbolp)))
- `(eieio-oref-default ,obj (quote ,slot)))
+ `(eieio-oref-default ,class (quote ,slot)))
;;; Handy CLOS macros
;;
@@ -538,11 +553,11 @@ OBJECT can be an instance or a class."
((eieio-object-p object) (eieio-oref object slot))
((symbolp object) (eieio-oref-default object slot))
(t (signal 'wrong-type-argument (list 'eieio-object-p object))))
- eieio-unbound))))
+ eieio--unbound))))
(defun slot-makeunbound (object slot)
"In OBJECT, make SLOT unbound."
- (eieio-oset object slot eieio-unbound))
+ (eieio-oset object slot eieio--unbound))
(defun slot-exists-p (object-or-class slot)
"Return non-nil if OBJECT-OR-CLASS has SLOT."
@@ -740,18 +755,14 @@ dynamically set from SLOTS."
(slots (eieio--class-slots this-class)))
(dotimes (i (length slots))
;; For each slot, see if we need to evaluate it.
- ;;
- ;; Paul Landes said in an email:
- ;; > CL evaluates it if it can, and otherwise, leaves it as
- ;; > the quoted thing as you already have. This is by the
- ;; > Sonya E. Keene book and other things I've look at on the
- ;; > web.
(let* ((slot (aref slots i))
- (initform (cl--slot-descriptor-initform slot))
- (dflt (eieio-default-eval-maybe initform)))
- (when (not (eq dflt initform))
+ (initform (cl--slot-descriptor-initform slot)))
+ ;; Those slots whose initform is constant already have the right
+ ;; value set in the default-object.
+ (unless (macroexp-const-p initform)
;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)!
- (eieio-oset this (cl--slot-descriptor-name slot) dflt)))))
+ (eieio-oset this (cl--slot-descriptor-name slot)
+ (eval initform t))))))
;; Shared initialize will parse our slots for us.
(shared-initialize this slots))
diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el
index 2ee19a3..c2b026d 100644
--- a/lisp/emacs-lisp/elp.el
+++ b/lisp/emacs-lisp/elp.el
@@ -483,6 +483,10 @@ original definition, use \\[elp-restore-function] or
\\[elp-restore-all]."
'face 'link
'help-echo "mouse-2 or RET jumps to definition")))
+(define-derived-mode elp-results-mode special-mode "ELP"
+ "Mode for ELP results."
+ :interactive nil)
+
;;;###autoload
(defun elp-results ()
"Display current profiling results.
@@ -490,11 +494,12 @@ If `elp-reset-after-results' is non-nil, then current
profiling
information for all instrumented functions is reset after results are
displayed."
(interactive)
- (let ((curbuf (current-buffer))
- (resultsbuf (if elp-recycle-buffers-p
- (get-buffer-create elp-results-buffer)
- (generate-new-buffer elp-results-buffer))))
- (set-buffer resultsbuf)
+ (pop-to-buffer
+ (if elp-recycle-buffers-p
+ (get-buffer-create elp-results-buffer)
+ (generate-new-buffer elp-results-buffer)))
+ (elp-results-mode)
+ (let ((inhibit-read-only t))
(erase-buffer)
;; get the length of the longest function name being profiled
(let* ((longest 0)
@@ -565,9 +570,6 @@ displayed."
(if elp-sort-by-function
(setq resvec (sort resvec elp-sort-by-function)))
(mapc 'elp-output-result resvec))
- ;; now pop up results buffer
- (set-buffer curbuf)
- (pop-to-buffer resultsbuf)
;; copy results to standard-output?
(if (or elp-use-standard-output noninteractive)
(princ (buffer-substring (point-min) (point-max)))
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 38d8ad6..16e8307 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -60,8 +60,10 @@ FUNCTIONS is a list of elements on the form:
:args ARGS
:eval EXAMPLE-FORM
:no-eval EXAMPLE-FORM
+ :no-eval* EXAMPLE-FORM
:no-value EXAMPLE-FORM
:result RESULT-FORM
+ :result-string RESULT-FORM
:eg-result RESULT-FORM
:eg-result-string RESULT-FORM)
@@ -887,6 +889,52 @@ There can be any number of :example/:result elements."
(unlock-buffer
:no-value (lock-buffer)))
+(define-short-documentation-group overlay
+ "Predicates"
+ (overlayp
+ :no-eval (overlayp some-overlay)
+ :eg-result t)
+ "Creation and Deletion"
+ (make-overlay
+ :args (beg end &optional buffer)
+ :no-eval (make-overlay 1 10)
+ :eg-result-string "#<overlay from 1 to 10 in *foo*>")
+ (delete-overlay
+ :no-eval (delete-overlay foo)
+ :eg-result t)
+ "Searching Overlays"
+ (overlays-at
+ :no-eval (overlays-at 15)
+ :eg-result-string "(#<overlay from 1 to 10 in *foo*>)")
+ (overlays-in
+ :no-eval (overlays-in 1 30)
+ :eg-result-string "(#<overlay from 1 to 10 in *foo*>)")
+ (next-overlay-change
+ :no-eval (next-overlay-change 1)
+ :eg-result 20)
+ (previous-overlay-change
+ :no-eval (previous-overlay-change 30)
+ :eg-result 20)
+ "Overlay Properties"
+ (overlay-start
+ :no-eval (overlay-start foo)
+ :eg-result 1)
+ (overlay-end
+ :no-eval (overlay-end foo)
+ :eg-result 10)
+ (overlay-put
+ :no-eval (overlay-put foo 'happy t)
+ :eg-result t)
+ (overlay-get
+ :no-eval (overlay-get foo 'happy)
+ :eg-result t)
+ (overlay-buffer
+ :no-eval (overlay-buffer foo))
+ "Moving Overlays"
+ (move-overlay
+ :no-eval (move-overlay foo 5 20)
+ :eg-result-string "#<overlay from 5 to 20 in *foo*>"))
+
(define-short-documentation-group process
(make-process
:no-eval (make-process :name "foo" :command '("cat" "/tmp/foo"))
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index 6d5b04b..0bb1b89 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -125,6 +125,10 @@ otherwise nil. That construct can be a two character
comment
delimiter or an Escaped or Char-quoted character."))
(defun syntax-propertize-wholelines (start end)
+ "Extend the region delimited by START and END to whole lines.
+This function is useful for
+`syntax-propertize-extend-region-functions';
+see Info node `(elisp) Syntax Properties'."
(goto-char start)
(cons (line-beginning-position)
(progn (goto-char end)
diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el
index a33025b..ebdb127 100644
--- a/lisp/epa-ks.el
+++ b/lisp/epa-ks.el
@@ -43,7 +43,8 @@
This is used by `epa-ks-lookup-key', for looking up public keys."
:type '(choice :tag "Keyserver"
- (const random)
+ (repeat :tag "Random pool"
+ (string :tag "Keyserver address"))
(const "keyring.debian.org")
(const "keys.gnupg.net")
(const "keyserver.ubuntu.com")
@@ -141,20 +142,33 @@ Keys are marked using `epa-ks-mark-key-to-fetch'."
(epa-ks--fetch-key id))))
(tabulated-list-clear-all-tags))
+(defun epa-ks--query-url (query exact)
+ "Return URL for QUERY.
+If EXACT is non-nil, don't accept approximate matches."
+ (format "https://%s/pks/lookup?%s";
+ (cond ((null epa-keyserver)
+ (user-error "Empty keyserver pool"))
+ ((listp epa-keyserver)
+ (nth (random (length epa-keyserver))
+ epa-keyserver))
+ ((stringp epa-keyserver)
+ epa-keyserver)
+ ((error "Invalid type for `epa-keyserver'")))
+ (url-build-query-string
+ (append `(("search" ,query)
+ ("options" "mr")
+ ("op" "index"))
+ (and exact '(("exact" "on")))))))
+
(defun epa-ks--fetch-key (id)
"Send request to import key with specified ID."
(url-retrieve
- (format "https://%s/pks/lookup?%s";
- epa-keyserver
- (url-build-query-string
- `(("search" ,(concat "0x" (url-hexify-string id)))
- ("options" "mr")
- ("op" "get"))))
+ (epa-ks--query-url (concat "0x" (url-hexify-string id)) t)
(lambda (status)
(when (plist-get status :error)
(error "Request failed: %s"
- (caddr (assq (caddr (plist-get status :error))
- url-http-codes))))
+ (caddr (assq (caddr (plist-get status :error))
+ url-http-codes))))
(forward-paragraph)
(save-excursion
(goto-char (point-max))
@@ -224,13 +238,7 @@ enough, since keyservers have strict timeout settings."
(erase-buffer))
(epa-ks-search-mode))
(url-retrieve
- (format "https://%s/pks/lookup?%s";
- epa-keyserver
- (url-build-query-string
- (append `(("search" ,query)
- ("options" "mr")
- ("op" "index"))
- (and exact '(("exact" "on"))))))
+ (epa-ks--query-url query exact)
(lambda (status)
(when (plist-get status :error)
(when buf
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 5470563..5245204 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2225,7 +2225,7 @@ Non-interactively, it takes the keyword arguments
That is, if called with
- (erc :server \"chat.freenode.net\" :full-name \"Harry S Truman\")
+ (erc :server \"chat.freenode.net\" :full-name \"J. Random Hacker\")
then the server and full-name will be set to those values,
whereas `erc-compute-port' and `erc-compute-nick' will be invoked
@@ -2260,7 +2260,7 @@ Non-interactively, it takes the keyword arguments
That is, if called with
- (erc-tls :server \"chat.freenode.net\" :full-name \"Harry S Truman\")
+ (erc-tls :server \"chat.freenode.net\" :full-name \"J. Random Hacker\")
then the server and full-name will be set to those values,
whereas `erc-compute-port' and `erc-compute-nick' will be invoked
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index e559f5b..18e19a9 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -379,7 +379,7 @@ input."
(if (eq eshell-hist-ignoredups 'erase)
;; Remove any old occurrences of the input, and put
;; the new one at the end.
- (progn
+ (unless (ring-empty-p eshell-history-ring)
(ring-remove eshell-history-ring
(ring-member eshell-history-ring input))
t)
diff --git a/lisp/fileloop.el b/lisp/fileloop.el
index cb9fe8f..8a2755d 100644
--- a/lisp/fileloop.el
+++ b/lisp/fileloop.el
@@ -171,7 +171,8 @@ operating on the next file and nil otherwise."
(goto-char pos))
(push-mark original-point t))
- (switch-to-buffer (current-buffer))
+ (let (switch-to-buffer-preserve-window-point)
+ (switch-to-buffer (current-buffer)))
;; Now operate on the file.
;; If value is non-nil, continue to scan the next file.
diff --git a/lisp/files.el b/lisp/files.el
index c694507..2450daf 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -6248,8 +6248,11 @@ Non-file buffers need a custom function."
(dolist (regexp revert-without-query)
(when (string-match regexp file-name)
(throw 'found t)))))
- (yes-or-no-p (format "Revert buffer from file %s? "
- file-name)))
+ (yes-or-no-p
+ (format (if (buffer-modified-p)
+ "Discard edits and reread from %s? "
+ "Revert buffer from file %s? ")
+ file-name)))
(run-hooks 'before-revert-hook)
;; If file was backed up but has changed since,
;; we should make another backup.
diff --git a/lisp/format.el b/lisp/format.el
index 3e2d92f..1e87d25 100644
--- a/lisp/format.el
+++ b/lisp/format.el
@@ -181,7 +181,7 @@ it should be a Lisp function. BUFFER is currently ignored."
;; We should perhaps go via a temporary buffer and copy it
;; back, in case of errors.
(if (and (zerop (save-window-excursion
- (shell-command-on-region from to method t t
+ (shell-command-on-region from to method t 'no-mark
error-buff)))
;; gzip gives zero exit status with bad args, for instance.
(zerop (with-current-buffer error-buff
diff --git a/lisp/fringe.el b/lisp/fringe.el
index e2d7968..d73aae0 100644
--- a/lisp/fringe.el
+++ b/lisp/fringe.el
@@ -181,7 +181,11 @@ When setting this variable in a Lisp program, call
`set-fringe-mode' afterward to make it take real effect.
To modify the appearance of the fringe in a specific frame, use
-the interactive function `set-fringe-style'."
+the interactive function `set-fringe-style'.
+
+Note that, despite the name, this is not a variable that controls
+a (major or minor) Emacs mode, but controls the appearance of the
+fringes."
:type `(choice
,@ (mapcar (lambda (style)
(let ((name
@@ -248,7 +252,10 @@ Fringe widths set by `set-window-fringes' override the
default
fringe widths set by this command. This command applies to all
frames that exist and frames to be created in the future. If you
want to set the default appearance of fringes on the selected
-frame only, see the command `set-fringe-style'."
+frame only, see the command `set-fringe-style'.
+
+Note that, despite the name, this is not a (major or minor) Emacs
+mode, but a command that controls the appearance of the fringes."
(interactive (list (fringe-query-style 'all-frames)))
(set-fringe-mode mode))
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 5ce03db..f2ec946 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -170,12 +170,17 @@ If `gnus-visible-headers' is non-nil, this variable will
be ignored."
"All headers that do not match this regexp will be hidden.
This variable can also be a list of regexp of headers to remain visible.
If this variable is non-nil, `gnus-ignored-headers' will be ignored."
- :type '(choice
- (repeat :value-to-internal (lambda (widget value)
- (custom-split-regexp-maybe value))
- :match (lambda (widget value)
- (or (stringp value)
- (widget-editable-list-match widget value)))
+ :type `(choice
+ (repeat :value-to-internal
+ ,(lambda (_widget value)
+ ;; FIXME: Are we sure this can't be used without
+ ;; loading cus-edit?
+ (declare-function custom-split-regexp-maybe
+ "cus-edit" (regexp))
+ (custom-split-regexp-maybe value))
+ :match ,(lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
regexp)
(const :tag "Use gnus-ignored-headers" nil)
regexp)
@@ -402,14 +407,14 @@ the entire emphasized word. The third is a number that
says what
regexp grouping should be displayed and highlighted. The fourth
is the face used for highlighting."
:type
- '(repeat
+ `(repeat
(menu-choice
:format "%[Customizing Style%]\n%v"
:indent 2
(group :tag "Default"
:value ("" 0 0 default)
:value-create
- (lambda (widget)
+ ,(lambda (widget)
(let ((value (widget-get
(cadr (widget-get (widget-get widget :parent)
:args))
@@ -3738,7 +3743,7 @@ is to run."
(setq n 1))
(gnus-stop-date-timer)
(setq article-lapsed-timer
- (run-at-time 1 n 'article-update-date-lapsed)))
+ (run-at-time 1 n #'article-update-date-lapsed)))
(defun gnus-stop-date-timer ()
"Stop the Date timer."
@@ -4405,7 +4410,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is
"\M-g" gnus-article-read-summary-keys)
(substitute-key-definition
- 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
+ #'undefined #'gnus-article-read-summary-keys gnus-article-mode-map)
(defvar gnus-article-send-map)
(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map)
@@ -4483,12 +4488,12 @@ commands:
(make-local-variable 'gnus-article-image-alist)
(make-local-variable 'gnus-article-charset)
(make-local-variable 'gnus-article-ignored-charsets)
- (setq-local bookmark-make-record-function 'gnus-summary-bookmark-make-record)
+ (setq-local bookmark-make-record-function
#'gnus-summary-bookmark-make-record)
;; Prevent Emacs from displaying non-break space with
;; `nobreak-space' face.
(setq-local nobreak-char-display nil)
;; Enable `gnus-article-remove-images' to delete images shr.el renders.
- (setq-local shr-put-image-function 'gnus-shr-put-image)
+ (setq-local shr-put-image-function #'gnus-shr-put-image)
(unless gnus-article-show-cursor
(setq cursor-in-non-selected-windows nil))
(gnus-set-default-directory)
@@ -4723,16 +4728,17 @@ If ALL-HEADERS is non-nil, no headers are hidden."
(define-derived-mode gnus-sticky-article-mode gnus-article-mode "StickyArticle"
"Mode for sticky articles."
;; Release bindings that won't work.
- (substitute-key-definition 'gnus-article-read-summary-keys 'undefined
+ (substitute-key-definition #'gnus-article-read-summary-keys #'undefined
gnus-sticky-article-mode-map)
- (substitute-key-definition 'gnus-article-refer-article 'undefined
+ (substitute-key-definition #'gnus-article-refer-article #'undefined
gnus-sticky-article-mode-map)
(dolist (k '("e" "h" "s" "F" "R"))
(define-key gnus-sticky-article-mode-map k nil))
- (define-key gnus-sticky-article-mode-map "k"
'gnus-kill-sticky-article-buffer)
- (define-key gnus-sticky-article-mode-map "q" 'bury-buffer)
- (define-key gnus-sticky-article-mode-map "\C-hc" 'describe-key-briefly)
- (define-key gnus-sticky-article-mode-map "\C-hk" 'describe-key))
+ (define-key gnus-sticky-article-mode-map "k"
+ #'gnus-kill-sticky-article-buffer)
+ (define-key gnus-sticky-article-mode-map "q" #'bury-buffer)
+ (define-key gnus-sticky-article-mode-map "\C-hc" #'describe-key-briefly)
+ (define-key gnus-sticky-article-mode-map "\C-hk" #'describe-key))
(defun gnus-sticky-article (arg)
"Make the current article sticky.
@@ -4863,9 +4869,9 @@ General format specifiers can also be used. See Info node
(defvar gnus-mime-button-map
(let ((map (make-sparse-keymap)))
- (define-key map "\r" 'gnus-article-push-button)
- (define-key map [mouse-2] 'gnus-article-push-button)
- (define-key map [down-mouse-3] 'gnus-mime-button-menu)
+ (define-key map "\r" #'gnus-article-push-button)
+ (define-key map [mouse-2] #'gnus-article-push-button)
+ (define-key map [down-mouse-3] #'gnus-mime-button-menu)
(dolist (c gnus-mime-button-commands)
(define-key map (cadr c) (car c)))
map))
@@ -6138,7 +6144,7 @@ If nil, don't show those extra buttons."
(let* ((preferred (or preferred (mm-preferred-alternative handles)))
(ihandles handles)
(point (point))
- handle (inhibit-read-only t) begend not-pref) ;; from
+ (inhibit-read-only t) begend not-pref) ;; from
(save-window-excursion
(save-restriction
(when ibegend
@@ -6152,8 +6158,8 @@ If nil, don't show those extra buttons."
(mm-remove-parts handles))
(setq begend (list (point-marker)))
;; Do the toggle.
- (unless (setq not-pref (cadr (member preferred ihandles)))
- (setq not-pref (car ihandles)))
+ (setq not-pref (or (cadr (member preferred ihandles))
+ (car ihandles)))
(when (or ibegend
(not preferred)
(not (gnus-unbuttonized-mime-type-p
@@ -6164,22 +6170,22 @@ If nil, don't show those extra buttons."
(progn
(insert (format "%d. " id))
(point))
- `(gnus-callback
- (lambda (handles)
- (unless ,(not ibegend)
- (setq gnus-article-mime-handle-alist
- ',gnus-article-mime-handle-alist))
- (gnus-mime-display-alternative
- ',ihandles ',not-pref ',begend ,id))
- keymap ,gnus-mime-button-map
- mouse-face ,gnus-article-mouse-face
- face ,gnus-article-button-face
- follow-link t
- gnus-part ,id
- article-type multipart
- rear-nonsticky t))
+ (let ((gamha gnus-article-mime-handle-alist))
+ `(gnus-callback
+ ,(lambda (_handles)
+ (unless (not ibegend)
+ (setq gnus-article-mime-handle-alist gamha))
+ (gnus-mime-display-alternative
+ ihandles not-pref begend id))
+ keymap ,gnus-mime-button-map
+ mouse-face ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ follow-link t
+ gnus-part ,id
+ article-type multipart
+ rear-nonsticky t)))
;; Do the handles
- (while (setq handle (pop handles))
+ (dolist (handle handles)
(add-text-properties
;; (setq from
(point) ;; )
@@ -6188,22 +6194,22 @@ If nil, don't show those extra buttons."
(if (equal handle preferred) ?* ? )
(mm-handle-media-type handle)))
(point))
- `(gnus-callback
- (lambda (handles)
- (unless ,(not ibegend)
- (setq gnus-article-mime-handle-alist
- ',gnus-article-mime-handle-alist))
- (gnus-mime-display-alternative
- ',ihandles ',handle ',begend ,id))
- keymap ,gnus-mime-button-map
- mouse-face ,gnus-article-mouse-face
- face ,gnus-article-button-face
- follow-link t
- gnus-part ,id
- button t
- category t
- gnus-data ,handle
- rear-nonsticky t))
+ (let ((gamha gnus-article-mime-handle-alist))
+ `(gnus-callback
+ ,(lambda (_handles)
+ (unless (not ibegend)
+ (setq gnus-article-mime-handle-alist gamha))
+ (gnus-mime-display-alternative
+ ihandles handle begend id))
+ keymap ,gnus-mime-button-map
+ mouse-face ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ follow-link t
+ gnus-part ,id
+ button t
+ category t
+ gnus-data ,handle
+ rear-nonsticky t)))
(insert " "))
(insert "\n\n"))
(when preferred
@@ -6308,7 +6314,8 @@ is the string to use when it is inactive.")
(setq gnus-article-image-alist (delq entry gnus-article-image-alist))
(gnus-delete-wash-type category)))
-(defalias 'gnus-article-hide-headers-if-wanted
'gnus-article-maybe-hide-headers)
+(defalias 'gnus-article-hide-headers-if-wanted
+ #'gnus-article-maybe-hide-headers)
(defun gnus-article-maybe-hide-headers ()
"Hide unwanted headers if `gnus-have-all-headers' is nil.
@@ -6874,7 +6881,7 @@ then we display only bindings that start with that
prefix."
parent agent draft)
(define-key keymap "S" map)
(define-key map [t] nil)
- (define-key summap [t] 'undefined)
+ (define-key summap [t] #'undefined)
(with-current-buffer gnus-article-current-summary
(dolist (key sumkeys)
(define-key summap key (key-binding key (current-local-map))))
@@ -6910,10 +6917,11 @@ then we display only bindings that start with that
prefix."
(setq-local gnus-agent-summary-mode agent)
(setq-local gnus-draft-mode draft)
(describe-bindings prefix))
- (let ((item `((lambda (prefix)
- (with-current-buffer ,(current-buffer)
- (gnus-article-describe-bindings prefix)))
- ,prefix)))
+ (let* ((cb (current-buffer))
+ (item `(,(lambda (prefix)
+ (with-current-buffer cb
+ (gnus-article-describe-bindings prefix)))
+ ,prefix)))
;; Loading `help-mode' here is necessary if `describe-bindings'
;; is replaced with something, e.g. `helm-descbinds'.
(require 'help-mode)
@@ -8394,14 +8402,14 @@ url is put as the `gnus-button-url' overlay property on
the button."
(defvar gnus-prev-page-map
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-2] 'gnus-button-prev-page)
- (define-key map "\r" 'gnus-button-prev-page)
+ (define-key map [mouse-2] #'gnus-button-prev-page)
+ (define-key map "\r" #'gnus-button-prev-page)
map))
(defvar gnus-next-page-map
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-2] 'gnus-button-next-page)
- (define-key map "\r" 'gnus-button-next-page)
+ (define-key map [mouse-2] #'gnus-button-next-page)
+ (define-key map "\r" #'gnus-button-next-page)
map))
(defun gnus-insert-prev-page-button ()
@@ -8705,9 +8713,9 @@ For example:
(defvar gnus-mime-security-button-map
(let ((map (make-sparse-keymap)))
- (define-key map "\r" 'gnus-article-push-button)
- (define-key map [mouse-2] 'gnus-article-push-button)
- (define-key map [down-mouse-3] 'gnus-mime-security-button-menu)
+ (define-key map "\r" #'gnus-article-push-button)
+ (define-key map [mouse-2] #'gnus-article-push-button)
+ (define-key map [down-mouse-3] #'gnus-mime-security-button-menu)
(dolist (c gnus-mime-security-button-commands)
(define-key map (cadr c) (car c)))
map))
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 8c62c94..c8b95d9 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -894,14 +894,14 @@ simple manner."
["Sort by real name" gnus-group-sort-selected-groups-by-real-name
(not (gnus-topic-mode-p))])
("Mark"
- ["Mark group" gnus-group-mark-group
+ ["Toggle/Set mark" gnus-group-mark-group
(and (gnus-group-group-name)
(not (memq (gnus-group-group-name) gnus-group-marked)))]
- ["Unmark group" gnus-group-unmark-group
+ ["Remove mark" gnus-group-unmark-group
(and (gnus-group-group-name)
(memq (gnus-group-group-name) gnus-group-marked))]
- ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked]
- ["Mark regexp..." gnus-group-mark-regexp t]
+ ["Remove all marks" gnus-group-unmark-all-groups gnus-group-marked]
+ ["Mark by regexp..." gnus-group-mark-regexp t]
["Mark region" gnus-group-mark-region :active mark-active]
["Mark buffer" gnus-group-mark-buffer t]
["Execute command" gnus-group-universal-argument
@@ -1865,7 +1865,7 @@ If FIRST-TOO, the current line is also eligible as a
target."
(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
(eq (char-after) gnus-process-mark)))
-(defun gnus-group-mark-group (n &optional unmark no-advance)
+(defun gnus-group-mark-group (n &optional unmark no-advance no-toggle)
"Mark the current group."
(interactive "p" gnus-group-mode)
(let ((buffer-read-only nil)
@@ -1877,23 +1877,33 @@ If FIRST-TOO, the current line is also eligible as a
target."
(beginning-of-line)
(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
(delete-char 1)
- (if unmark
- (progn
- (setq gnus-group-marked (delete group gnus-group-marked))
- (insert-char ?\s 1 t))
- (setq gnus-group-marked
- (cons group (delete group gnus-group-marked)))
- (insert-char gnus-process-mark 1 t)))
+ (if (and gnus-process-mark-toggle (not no-toggle))
+ (if (memq group gnus-group-marked)
+ (gnus-group-mark-update group t)
+ (gnus-group-mark-update group))
+ (gnus-group-mark-update group unmark)))
(unless no-advance
(gnus-group-next-group 1))
(cl-decf n))
(gnus-group-position-point)
n))
+(defun gnus-group-mark-update (n &optional unmark)
+ "Set the process mark on current group and update the group line."
+ (if unmark
+ (progn
+ (setq gnus-group-marked
+ (delete n gnus-group-marked))
+ (insert-char ?\s 1 t))
+ (progn
+ (setq gnus-group-marked
+ (cons n (delete n gnus-group-marked)))
+ (insert-char gnus-process-mark 1 t))))
+
(defun gnus-group-unmark-group (n)
"Remove the mark from the current group."
(interactive "p" gnus-group-mode)
- (gnus-group-mark-group n 'unmark)
+ (gnus-group-mark-group n 'unmark nil t)
(gnus-group-position-point))
(defun gnus-group-unmark-all-groups ()
@@ -1910,7 +1920,7 @@ If UNMARK, remove the mark instead."
(let ((num (count-lines beg end)))
(save-excursion
(goto-char beg)
- (- num (gnus-group-mark-group num unmark)))))
+ (- num (gnus-group-mark-group num unmark nil t)))))
(defun gnus-group-mark-buffer (&optional unmark)
"Mark all groups in the buffer.
@@ -1935,7 +1945,7 @@ If UNMARK, remove the mark instead."
Return nil if the group isn't displayed."
(if (gnus-group-goto-group group nil test-marked)
(save-excursion
- (gnus-group-mark-group 1 'unmark t)
+ (gnus-group-mark-group 1 'unmark t t)
t)
(setq gnus-group-marked
(delete group gnus-group-marked))
@@ -1945,7 +1955,7 @@ Return nil if the group isn't displayed."
"Set the process mark on GROUP."
(if (gnus-group-goto-group group)
(save-excursion
- (gnus-group-mark-group 1 nil t))
+ (gnus-group-mark-group 1 nil t t))
(setq gnus-group-marked (cons group (delete group gnus-group-marked)))))
(defun gnus-group-universal-argument (arg &optional _groups func)
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index aa4c753..bcd76dd 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -2774,7 +2774,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Hide marked" gnus-summary-limit-exclude-marks t]
["Show expunged" gnus-summary-limit-include-expunged t])
("Process Mark"
- ["Set mark" gnus-summary-mark-as-processable t]
+ ["Toggle/Set mark" gnus-summary-mark-as-processable t]
["Remove mark" gnus-summary-unmark-as-processable t]
["Remove all marks" gnus-summary-unmark-all-processable t]
["Invert marks" gnus-uu-invert-processable t]
@@ -8247,7 +8247,7 @@ If NOT-MATCHING, excluding articles that have subjects
that match a regexp."
(let ((articles (gnus-summary-find-matching
(or header "subject") subject 'all nil nil
not-matching)))
- (unless articles
+ (unless (or articles not-matching)
(error "Found no matches for \"%s\"" subject))
(gnus-summary-limit articles))
(gnus-summary-position-point))))
@@ -8318,7 +8318,7 @@ To and Cc headers are checked. You need to include them
in
(and (memq a to) a))
cc)
(nconc to cc))))
- (unless articles
+ (unless (or articles not-matching)
(error "Found no matches for \"%s\"" recipient))
(gnus-summary-limit articles))
(gnus-summary-position-point))))
@@ -8374,7 +8374,7 @@ in `nnmail-extra-headers'."
(nconc (if (eq to t) nil to)
(if (eq cc t) nil cc)
from))))
- (unless articles
+ (unless (or articles not-matching)
(error "Found no matches for \"%s\"" address))
(gnus-summary-limit articles))
(gnus-summary-position-point))))
@@ -8465,7 +8465,7 @@ articles that are younger than AGE days."
(let ((articles (gnus-summary-find-matching
(cons 'extra header) regexp 'all nil nil
not-matching)))
- (unless articles
+ (unless (or articles not-matching)
(error "Found no matches for \"%s\"" regexp))
(gnus-summary-limit articles))
(gnus-summary-position-point))))
@@ -10951,10 +10951,14 @@ number of articles marked is returned."
(n (abs n)))
(while (and
(> n 0)
- (if unmark
- (gnus-summary-remove-process-mark
- (gnus-summary-article-number))
- (gnus-summary-set-process-mark (gnus-summary-article-number)))
+ (let ((article (gnus-summary-article-number)))
+ (if unmark
+ (gnus-summary-remove-process-mark article)
+ (if gnus-process-mark-toggle
+ (if (memq article gnus-newsgroup-processable)
+ (gnus-summary-remove-process-mark article)
+ (gnus-summary-set-process-mark article))
+ (gnus-summary-set-process-mark article))))
(zerop (gnus-summary-next-subject (if backward -1 1) nil t)))
(setq n (1- n)))
(when (/= 0 n)
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index b3d17bc..b974dff 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -1112,7 +1112,7 @@ articles in the topic and its subtopics."
["Delete" gnus-topic-delete t]
["Rename..." gnus-topic-rename t]
["Create..." gnus-topic-create-topic t]
- ["Mark" gnus-topic-mark-topic t]
+ ["Toggle/Set mark" gnus-topic-mark-topic t]
["Indent" gnus-topic-indent t]
["Sort" gnus-topic-sort-topics t]
["Previous topic" gnus-topic-goto-previous-topic t]
@@ -1436,7 +1436,7 @@ If PERMANENT, make it stay shown in subsequent sessions
as well."
(setcar (cdr (cadr topic)) 'visible)
(gnus-group-list-groups)))))
-(defun gnus-topic-mark-topic (topic &optional unmark non-recursive)
+(defun gnus-topic-mark-topic (topic &optional unmark non-recursive no-toggle)
"Mark all groups in the TOPIC with the process mark.
If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics."
(interactive
@@ -1450,8 +1450,13 @@ If NON-RECURSIVE (which is the prefix) is t, don't mark
its subtopics."
(let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil
(not non-recursive))))
(while groups
- (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
- (gnus-info-group (nth 1 (pop groups)))))))))
+ (let ((group (gnus-info-group (nth 1 (pop groups)))))
+ (if (and gnus-process-mark-toggle (not no-toggle))
+ (if (memq group gnus-group-marked)
+ (gnus-group-remove-mark group )
+ (gnus-group-set-mark group))
+ (if unmark (gnus-group-remove-mark group)
+ (gnus-group-set-mark group)))))))))
(defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive)
"Remove the process mark from all groups in the TOPIC.
@@ -1462,7 +1467,7 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark
its subtopics."
gnus-topic-mode)
(if (not topic)
(call-interactively 'gnus-group-unmark-group)
- (gnus-topic-mark-topic topic t non-recursive)))
+ (gnus-topic-mark-topic topic t non-recursive t)))
(defun gnus-topic-get-new-news-this-topic (&optional n)
"Check for new news in the current topic."
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 7de1cd1..7dde799 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1183,6 +1183,14 @@ newsgroups."
:group 'gnus-summary-marks
:type 'character)
+(defcustom gnus-process-mark-toggle t
+ "If nil the process mark command only sets the process mark."
+ :version "28.1"
+ :group 'gnus-summary
+ :group 'gnus-group-various
+ :group 'gnus-group-topic
+ :type 'boolean)
+
(defcustom gnus-large-newsgroup 200
"The number of articles which indicates a large newsgroup.
If the number of articles in a newsgroup is greater than this value,
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index f869f58..3e2a202 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -428,8 +428,9 @@ during splitting, which may be slow."
(time-subtract
now
(nnimap-last-command-time nnimap-object))))
- (ignore-errors ;E.g. "buffer foo has no process".
- (nnimap-send-command "NOOP"))))))))
+ (with-local-quit
+ (ignore-errors ;E.g. "buffer foo has no process".
+ (nnimap-send-command "NOOP")))))))))
(defun nnimap-open-connection (buffer)
;; Be backwards-compatible -- the earlier value of nnimap-stream was
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 0b0ae43..133763a 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -126,29 +126,35 @@ with the current prefix. The files are chosen according
to
:group 'help
:version "26.3")
+(defun help--symbol-class (s)
+ "Return symbol class characters for symbol S."
+ (when (stringp s)
+ (setq s (intern-soft s)))
+ (cond ((commandp s)
+ "c") ; command
+ ((eq (car-safe (symbol-function s)) 'macro)
+ "m") ; macro
+ ((fboundp s)
+ "f") ; function
+ ((custom-variable-p s)
+ "u") ; user option
+ ((boundp s)
+ "v") ; variable
+ ((facep s)
+ "a") ; fAce
+ ((and (fboundp 'cl-find-class)
+ (cl-find-class s))
+ "t") ; CL type
+ (" ") ; something else
+ ))
+
(defun help--symbol-completion-table-affixation (completions)
(mapcar (lambda (c)
(let* ((s (intern c))
(doc (condition-case nil (documentation s) (error nil)))
(doc (and doc (substring doc 0 (string-match "\n" doc)))))
(list c (propertize
- (concat (cond ((commandp s)
- "c") ; command
- ((eq (car-safe (symbol-function s))
'macro)
- "m") ; macro
- ((fboundp s)
- "f") ; function
- ((custom-variable-p s)
- "u") ; user option
- ((boundp s)
- "v") ; variable
- ((facep s)
- "a") ; fAce
- ((and (fboundp 'cl-find-class)
- (cl-find-class s))
- "t") ; CL type
- (" ")) ; something else
- " ") ; prefix separator
+ (concat (help--symbol-class s) " ") ; prefix separator
'face 'completions-annotations)
(if doc (propertize (format " -- %s" doc)
'face 'completions-annotations)
@@ -268,7 +274,9 @@ If we can't find the file name, nil is returned."
(let ((docbuf (get-buffer-create " *DOC*"))
(name (if (eq 'var kind)
(concat "V" (symbol-name subr-or-var))
- (concat "F" (subr-name (advice--cd*r subr-or-var))))))
+ (concat "F" (if (symbolp subr-or-var)
+ (symbol-name subr-or-var)
+ (subr-name (advice--cd*r subr-or-var)))))))
(with-current-buffer docbuf
(goto-char (point-min))
(if (eobp)
@@ -1022,12 +1030,12 @@ it is displayed along with the global value."
(format-prompt "Describe variable" (and (symbolp v) v))
#'help--symbol-completion-table
(lambda (vv)
- ;; In case the variable only exists in the buffer
- ;; the command we switch back to that buffer before
- ;; we examine the variable.
- (with-current-buffer orig-buffer
- (or (get vv 'variable-documentation)
- (and (boundp vv) (not (keywordp vv))))))
+ (or (get vv 'variable-documentation)
+ (and (not (keywordp vv))
+ ;; Since the variable may only exist in the
+ ;; original buffer, we have to look for it
+ ;; there.
+ (buffer-local-boundp vv orig-buffer))))
t nil nil
(if (symbolp v) (symbol-name v))))
(list (if (equal val "")
diff --git a/lisp/hl-line.el b/lisp/hl-line.el
index 82952e9..26cfcc3 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -125,6 +125,9 @@ This variable is expected to be made buffer-local by
modes.")
(defvar hl-line-overlay-buffer nil
"Most recently visited buffer in which Hl-Line mode is enabled.")
+(defvar hl-line-overlay-priority -50
+ "Priority used on the overlay used by hl-line.")
+
;;;###autoload
(define-minor-mode hl-line-mode
"Toggle highlighting of the current line (Hl-Line mode).
@@ -152,7 +155,7 @@ line about point in the selected window only."
(defun hl-line-make-overlay ()
(let ((ol (make-overlay (point) (point))))
- (overlay-put ol 'priority -50) ;(bug#16192)
+ (overlay-put ol 'priority hl-line-overlay-priority) ;(bug#16192)
(overlay-put ol 'face hl-line-face)
ol))
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index c80222e..9088f31 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1079,8 +1079,11 @@ a new window in the current frame, splitting vertically."
;; Make sure that redisplay is performed, otherwise there can be a
;; bad interaction with code in the window-scroll-functions hook
(redisplay t)
- (fit-window-to-buffer nil (when owin (/ (frame-height)
- (length (window-list
(selected-frame)))))))
+ (when (buffer-local-value 'ibuffer-auto-mode (window-buffer))
+ (fit-window-to-buffer
+ nil (and owin
+ (/ (frame-height)
+ (length (window-list (selected-frame))))))))
(defun ibuffer-confirm-operation-on (operation names)
"Display a buffer asking whether to perform OPERATION on NAMES."
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index 91bbb60..08b4ef2 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -50,6 +50,8 @@
;;; Code:
(require 'rfn-eshadow) ; rfn-eshadow-overlay
+(require 'simple) ; max-mini-window-lines
+(require 'cl-lib)
(defgroup icomplete nil
"Show completions dynamically in minibuffer."
@@ -99,6 +101,10 @@ Otherwise this should be a list of the completion tables
(e.g.,
"Face used by Icomplete for highlighting first match."
:version "24.4")
+(defface icomplete-selected-match '((t :inherit highlight))
+ "Face used by `icomplete-vertical-mode' for the selected candidate."
+ :version "24.4")
+
;;;_* User Customization variables
(defcustom icomplete-prospects-height 2
;; We used to compute how many lines 100 characters would take in
@@ -109,7 +115,7 @@ Otherwise this should be a list of the completion tables
(e.g.,
:type 'integer
:version "26.1")
-(defcustom icomplete-compute-delay .3
+(defcustom icomplete-compute-delay .15
"Completions-computation stall, used only with large-number completions.
See `icomplete-delay-completions-threshold'."
:type 'number)
@@ -118,7 +124,7 @@ See `icomplete-delay-completions-threshold'."
"Pending-completions number over which to apply `icomplete-compute-delay'."
:type 'integer)
-(defcustom icomplete-max-delay-chars 3
+(defcustom icomplete-max-delay-chars 2
"Maximum number of initial chars to apply `icomplete-compute-delay'."
:type 'integer)
@@ -152,10 +158,6 @@ icompletion is occurring."
"Initial input in the minibuffer when icomplete-mode was activated.
Used to implement the option `icomplete-show-matches-on-no-input'.")
-(defun icomplete-pre-command-hook ()
- (let ((non-essential t))
- (icomplete-tidy)))
-
(defun icomplete-post-command-hook ()
(let ((non-essential t)) ;E.g. don't prompt for password!
(icomplete-exhibit)))
@@ -215,6 +217,29 @@ the default otherwise."
;; We're not at all interested in cycling here (bug#34077).
(minibuffer-force-complete nil nil 'dont-cycle))
+;; Apropos `icomplete-scroll', we implement "scrolling icomplete"
+;; within classic icomplete, which is "rotating", by contrast.
+;;
+;; The two variables supporing this are
+;; `icomplete--scrolled-completions' and `icomplete--scrolled-past'.
+;; They come into play when:
+;;
+;; - The user invokes commands `icomplete-forward-completions' and
+;; `icomplete-backward-completions', thus "manually" scrolling to a
+;; given position;
+;;
+;; - The user re-filters a selection that had already been manually
+;; scrolled. The system attempts to keep the previous selection
+;; stable in the face of the new filtering. This is mostly done in
+;; `icomplete--render-vertical'.
+;;
+(defvar icomplete-scroll nil
+ "If non-nil, scroll candidates list instead of rotating it.")
+(defvar icomplete--scrolled-completions nil
+ "If non-nil, tail of completions list manually scrolled to.")
+(defvar icomplete--scrolled-past nil
+ "If non-nil, reverse tail of completions scrolled past.")
+
(defun icomplete-forward-completions ()
"Step forward completions by one entry.
Second entry becomes the first and can be selected with
@@ -223,10 +248,14 @@ Second entry becomes the first and can be selected with
(let* ((beg (icomplete--field-beg))
(end (icomplete--field-end))
(comps (completion-all-sorted-completions beg end))
- (last (last comps)))
- (when comps
- (setcdr last (cons (car comps) (cdr last)))
- (completion--cache-all-sorted-completions beg end (cdr comps)))))
+ (last (last comps)))
+ (when (consp (cdr comps))
+ (cond (icomplete-scroll
+ (push (pop comps) icomplete--scrolled-past)
+ (setq icomplete--scrolled-completions comps))
+ (t
+ (setcdr (last comps) (cons (pop comps) (cdr last)))))
+ (completion--cache-all-sorted-completions beg end comps))))
(defun icomplete-backward-completions ()
"Step backward completions by one entry.
@@ -236,12 +265,16 @@ Last entry becomes the first and can be selected with
(let* ((beg (icomplete--field-beg))
(end (icomplete--field-end))
(comps (completion-all-sorted-completions beg end))
- (last-but-one (last comps 2))
- (last (cdr last-but-one)))
- (when (consp last) ; At least two elements in comps
- (setcdr last-but-one (cdr last))
- (push (car last) comps)
- (completion--cache-all-sorted-completions beg end comps))))
+ last-but-one)
+ (cond ((and icomplete-scroll icomplete--scrolled-past)
+ (push (pop icomplete--scrolled-past) comps)
+ (setq icomplete--scrolled-completions comps))
+ ((and (not icomplete-scroll)
+ (consp (cdr (setq last-but-one (last comps 2)))))
+ ;; At least two elements in comps
+ (push (car (cdr last-but-one)) comps)
+ (setcdr last-but-one (cdr (cdr last-but-one)))))
+ (completion--cache-all-sorted-completions beg end comps)))
;;; Helpers for `fido-mode' (or `ido-mode' emulation)
;;;
@@ -298,7 +331,8 @@ require user confirmation."
(file-name-directory (icomplete--field-string))))
(current (car completion-all-sorted-completions))
(probe (and dir current
- (expand-file-name (directory-file-name current) dir))))
+ (expand-file-name (directory-file-name current)
+ (substitute-env-vars dir)))))
(cond ((and probe (file-directory-p probe) (not (string= current "./")))
(icomplete-force-complete))
(t
@@ -351,6 +385,7 @@ if that doesn't produce a completion match."
(setq-local icomplete-tidy-shadowed-file-names t
icomplete-show-matches-on-no-input t
icomplete-hide-common-prefix nil
+ icomplete-scroll (not (null icomplete-vertical-mode))
completion-styles '(flex)
completion-flex-nospace nil
completion-category-defaults nil
@@ -449,9 +484,9 @@ Usually run by inclusion in `minibuffer-setup-hook'."
(when (and icomplete-mode (icomplete-simple-completing-p))
(setq-local icomplete--initial-input (icomplete--field-string))
(setq-local completion-show-inline-help nil)
+ (setq icomplete--scrolled-completions nil)
(use-local-map (make-composed-keymap icomplete-minibuffer-map
(current-local-map)))
- (add-hook 'pre-command-hook #'icomplete-pre-command-hook nil t)
(add-hook 'post-command-hook #'icomplete-post-command-hook nil t)
(run-hooks 'icomplete-minibuffer-setup-hook)))
@@ -465,7 +500,6 @@ Usually run by inclusion in `minibuffer-setup-hook'."
(setq icomplete--in-region-buffer nil)
(delete-overlay icomplete-overlay)
(kill-local-variable 'completion-show-inline-help)
- (remove-hook 'pre-command-hook 'icomplete-pre-command-hook t)
(remove-hook 'post-command-hook 'icomplete-post-command-hook t)
(message nil)))
(when (and completion-in-region-mode
@@ -477,12 +511,12 @@ Usually run by inclusion in `minibuffer-setup-hook'."
(unless (memq icomplete-minibuffer-map (cdr tem))
(setcdr tem (make-composed-keymap icomplete-minibuffer-map
(cdr tem)))))
- (add-hook 'pre-command-hook 'icomplete-pre-command-hook nil t)
(add-hook 'post-command-hook 'icomplete-post-command-hook nil t)))
(defun icomplete--sorted-completions ()
(or completion-all-sorted-completions
(cl-loop
+ initially (setq icomplete--scrolled-past nil) ; Invalidate scrolled
state
with beg = (icomplete--field-beg)
with end = (icomplete--field-end)
with all = (completion-all-sorted-completions beg end)
@@ -593,18 +627,13 @@ resized depends on `resize-mini-windows'."
(add-hook 'icomplete-minibuffer-setup-hook
#'icomplete--vertical-minibuffer-setup)))
+(defalias 'fido-vertical-mode 'icomplete-vertical-mode)
+
;;;_* Completion
-;;;_ > icomplete-tidy ()
-(defun icomplete-tidy ()
- "Remove completions display (if any) prior to new user input.
-Should be run in on the minibuffer `pre-command-hook'.
-See `icomplete-mode' and `minibuffer-setup-hook'."
- (delete-overlay icomplete-overlay))
-
;;;_ > icomplete-exhibit ()
(defun icomplete-exhibit ()
"Insert Icomplete completions display.
@@ -659,13 +688,126 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
deactivate-mark)
;; Do nothing if while-no-input was aborted.
(when (stringp text)
- (move-overlay icomplete-overlay (point) (point) (current-buffer))
+ (move-overlay icomplete-overlay (point-min) (point)
(current-buffer))
;; The current C cursor code doesn't know to use the overlay's
;; marker's stickiness to figure out whether to place the cursor
;; before or after the string, so let's spoon-feed it the pos.
(put-text-property 0 1 'cursor t text)
+ (overlay-put
+ icomplete-overlay 'before-string
+ (and icomplete-scroll
+ (let ((past (length icomplete--scrolled-past)))
+ (format
+ "%s/%s "
+ (1+ past)
+ (+ past
+ (safe-length completion-all-sorted-completions))))))
(overlay-put icomplete-overlay 'after-string text))))))))
+(defun icomplete--affixate (md prospects)
+ "Affixate PROSPECTS given completion metadata MD.
+Return a list of (COMP PREFIX SUFFIX)."
+ (let ((aff-fun (or (completion-metadata-get md 'affixation-function)
+ (plist-get completion-extra-properties
:affixation-function)))
+ (ann-fun (or (completion-metadata-get md 'annotation-function)
+ (plist-get completion-extra-properties
:annotation-function))))
+ (cond (aff-fun
+ (funcall aff-fun prospects))
+ (ann-fun
+ (mapcar
+ (lambda (comp)
+ (let ((suffix (or (funcall ann-fun comp) "")))
+ (list comp ""
+ ;; The default completion UI adds the
+ ;; `completions-annotations' face if no
+ ;; other faces are present.
+ (if (text-property-not-all 0 (length suffix) 'face nil
suffix)
+ suffix
+ (propertize suffix 'face 'completions-annotations)))))
+ prospects))
+ (prospects))))
+
+(cl-defun icomplete--render-vertical (comps md &aux scroll-above scroll-below)
+ ;; Welcome to loopapalooza!
+ ;;
+ ;; First, be mindful of `icomplete-scroll' and manual scrolls. If
+ ;; `icomplete--scrolled-completions' and `icomplete--scrolled-past'
+ ;; are:
+ ;;
+ ;; - both nil, there is no manual scroll;
+ ;; - both non-nil, there is a healthy manual scroll the doesn't need
+ ;; to be readjusted (user just moved around the minibuffer, for
+ ;; example)l
+ ;; - non-nil and nil, respectively, a refiltering took place and we
+ ;; need attempt to readjust them to the new filtered `comps'.
+ (when (and icomplete-scroll
+ icomplete--scrolled-completions
+ (null icomplete--scrolled-past))
+ (cl-loop with preds
+ for (comp . rest) on comps
+ when (equal comp (car icomplete--scrolled-completions))
+ do
+ (setq icomplete--scrolled-past preds
+ comps (cons comp rest))
+ (completion--cache-all-sorted-completions
+ (icomplete--field-beg)
+ (icomplete--field-end)
+ comps)
+ and return nil
+ do (push comp preds)
+ finally (setq icomplete--scrolled-completions nil)))
+ ;; Then, in this pretty ugly loop, collect completions to display
+ ;; above and below the selected one, considering scrolling
+ ;; positions.
+ (cl-loop with preds = icomplete--scrolled-past
+ with succs = (cdr comps)
+ with max-lines = (1- (min
+ icomplete-prospects-height
+ (truncate (max-mini-window-lines) 1)))
+ with max-above = (- max-lines
+ 1
+ (cl-loop for (_ . r) on comps
+ repeat (truncate max-lines 2)
+ while (listp r)
+ count 1))
+ repeat max-lines
+ for neighbour = nil
+ if (and preds (> max-above 0)) do
+ (push (setq neighbour (pop preds)) scroll-above)
+ (cl-decf max-above)
+ else if (consp succs) collect
+ (setq neighbour (pop succs)) into scroll-below-aux
+ while neighbour
+ finally (setq scroll-below scroll-below-aux))
+ ;; Now figure out spacing and layout
+ ;;
+ (cl-loop
+ with selected = (substring (car comps))
+ initially (add-face-text-property 0 (length selected)
+ 'icomplete-selected-match 'append
selected)
+ with torender = (nconc scroll-above (list selected) scroll-below)
+ with triplets = (icomplete--affixate md torender)
+ initially (when (eq triplets torender)
+ (cl-return-from icomplete--render-vertical
+ (concat
+ " \n"
+ (mapconcat #'identity torender icomplete-separator))))
+ for (comp prefix) in triplets
+ maximizing (length prefix) into max-prefix-len
+ maximizing (length comp) into max-comp-len
+ finally return
+ ;; Finally, render
+ ;;
+ (concat
+ " \n"
+ (cl-loop for (comp prefix suffix) in triplets
+ concat prefix
+ concat (make-string (- max-prefix-len (length prefix)) ? )
+ concat comp
+ concat (make-string (- max-comp-len (length comp)) ? )
+ concat suffix
+ concat icomplete-separator))))
+
;;;_ > icomplete-completions (name candidates predicate require-match)
(defun icomplete-completions (name candidates predicate require-match)
"Identify prospective candidates for minibuffer completion.
@@ -703,126 +845,126 @@ matches exist."
predicate))
(md (completion--field-metadata (icomplete--field-beg)))
(comps (icomplete--sorted-completions))
- (last (if (consp comps) (last comps)))
- (base-size (cdr last))
(open-bracket (if require-match "(" "["))
(close-bracket (if require-match ")" "]")))
;; `concat'/`mapconcat' is the slow part.
(if (not (consp comps))
(progn ;;(debug (format "Candidates=%S field=%S" candidates name))
(format " %sNo matches%s" open-bracket close-bracket))
- (if last (setcdr last nil))
- (let* ((most-try
- (if (and base-size (> base-size 0))
+ (if icomplete-vertical-mode
+ (icomplete--render-vertical comps md)
+ (let* ((last (if (consp comps) (last comps)))
+ ;; Save the "base size" encoded in `comps' then
+ ;; removing making `comps' a proper list.
+ (base-size (prog1 (cdr last)
+ (if last (setcdr last nil))))
+ (most-try
+ (if (and base-size (> base-size 0))
+ (completion-try-completion
+ name candidates predicate (length name) md)
+ ;; If the `comps' are 0-based, the result should be
+ ;; the same with `comps'.
(completion-try-completion
- name candidates predicate (length name) md)
- ;; If the `comps' are 0-based, the result should be
- ;; the same with `comps'.
- (completion-try-completion
- name comps nil (length name) md)))
- (most (if (consp most-try) (car most-try)
- (if most-try (car comps) "")))
- ;; Compare name and most, so we can determine if name is
- ;; a prefix of most, or something else.
- (compare (compare-strings name nil nil
- most nil nil completion-ignore-case))
- (ellipsis (if (char-displayable-p ?…) "…" "..."))
- (determ (unless (or (eq t compare) (eq t most-try)
- (= (setq compare (1- (abs compare)))
- (length most)))
- (concat open-bracket
- (cond
- ((= compare (length name))
- ;; Typical case: name is a prefix.
- (substring most compare))
- ;; Don't bother truncating if it doesn't gain
- ;; us at least 2 columns.
- ((< compare (+ 2 (string-width ellipsis))) most)
- (t (concat ellipsis (substring most compare))))
- close-bracket)))
- ;;"-prospects" - more than one candidate
- (prospects-len (+ (string-width
- (or determ (concat open-bracket close-bracket)))
- (string-width icomplete-separator)
- (+ 2 (string-width ellipsis)) ;; take {…} into
account
- (string-width (buffer-string))))
- (prospects-max
- ;; Max total length to use, including the minibuffer content.
- (* (+ icomplete-prospects-height
- ;; If the minibuffer content already uses up more than
- ;; one line, increase the allowable space accordingly.
- (/ prospects-len (window-width)))
- (window-width)))
- ;; Find the common prefix among `comps'.
- ;; We can't use the optimization below because its assumptions
- ;; aren't always true, e.g. when completion-cycling (bug#10850):
- ;; (if (eq t (compare-strings (car comps) nil (length most)
- ;; most nil nil completion-ignore-case))
- ;; ;; Common case.
- ;; (length most)
- ;; Else, use try-completion.
- (prefix (when icomplete-hide-common-prefix
- (try-completion "" comps)))
- (prefix-len
- (and (stringp prefix)
- ;; Only hide the prefix if the corresponding info
- ;; is already displayed via `most'.
- (string-prefix-p prefix most t)
- (length prefix))) ;;)
- prospects comp limit)
- (if (or (eq most-try t) (not (consp (cdr comps))))
- (setq prospects nil)
- (when (member name comps)
- ;; NAME is complete but not unique. This scenario poses
- ;; following UI issues:
- ;;
- ;; - When `icomplete-hide-common-prefix' is non-nil, NAME
- ;; is stripped empty. This would make the entry
- ;; inconspicuous.
- ;;
- ;; - Due to sorting of completions, NAME may not be the
- ;; first of the prospects and could be hidden deep in
- ;; the displayed string.
- ;;
- ;; - Because of `icomplete-prospects-height' , NAME may
- ;; not even be displayed to the user.
- ;;
- ;; To circumvent all the above problems, provide a visual
- ;; cue to the user via an "empty string" in the try
- ;; completion field.
- (setq determ (concat open-bracket "" close-bracket)))
- ;; Compute prospects for display.
- (while (and comps (not limit))
- (setq comp
- (if prefix-len (substring (car comps) prefix-len) (car comps))
- comps (cdr comps))
- (setq prospects-len
- (+ (string-width comp)
- (string-width icomplete-separator)
- prospects-len))
- (if (< prospects-len prospects-max)
- (push comp prospects)
- (setq limit t))))
- (setq prospects (nreverse prospects))
- ;; Decorate first of the prospects.
- (when prospects
- (let ((first (copy-sequence (pop prospects))))
- (put-text-property 0 (length first)
- 'face 'icomplete-first-match first)
- (push first prospects)))
- ;; Restore the base-size info, since completion-all-sorted-completions
- ;; is cached.
- (if last (setcdr last base-size))
- (if prospects
- (concat determ
- (if icomplete-vertical-mode " \n" "{")
- (mapconcat 'identity prospects (if icomplete-vertical-mode
- "\n"
- icomplete-separator))
- (unless icomplete-vertical-mode
- (concat (and limit (concat icomplete-separator ellipsis))
- "}")))
- (concat determ " [Matched]"))))))
+ name comps nil (length name) md)))
+ (most (if (consp most-try) (car most-try)
+ (if most-try (car comps) "")))
+ ;; Compare name and most, so we can determine if name is
+ ;; a prefix of most, or something else.
+ (compare (compare-strings name nil nil
+ most nil nil completion-ignore-case))
+ (ellipsis (if (char-displayable-p ?…) "…" "..."))
+ (determ (unless (or (eq t compare) (eq t most-try)
+ (= (setq compare (1- (abs compare)))
+ (length most)))
+ (concat open-bracket
+ (cond
+ ((= compare (length name))
+ ;; Typical case: name is a prefix.
+ (substring most compare))
+ ;; Don't bother truncating if it doesn't gain
+ ;; us at least 2 columns.
+ ((< compare (+ 2 (string-width ellipsis)))
most)
+ (t (concat ellipsis (substring most
compare))))
+ close-bracket)))
+ ;;"-prospects" - more than one candidate
+ (prospects-len (+ (string-width
+ (or determ (concat open-bracket
close-bracket)))
+ (string-width icomplete-separator)
+ (+ 2 (string-width ellipsis)) ;; take {…}
into account
+ (string-width (buffer-string))))
+ (prospects-max
+ ;; Max total length to use, including the minibuffer content.
+ (* (+ icomplete-prospects-height
+ ;; If the minibuffer content already uses up more than
+ ;; one line, increase the allowable space accordingly.
+ (/ prospects-len (window-width)))
+ (window-width)))
+ ;; Find the common prefix among `comps'.
+ ;; We can't use the optimization below because its assumptions
+ ;; aren't always true, e.g. when completion-cycling (bug#10850):
+ ;; (if (eq t (compare-strings (car comps) nil (length most)
+ ;; most nil nil completion-ignore-case))
+ ;; ;; Common case.
+ ;; (length most)
+ ;; Else, use try-completion.
+ (prefix (when icomplete-hide-common-prefix
+ (try-completion "" comps)))
+ (prefix-len
+ (and (stringp prefix)
+ ;; Only hide the prefix if the corresponding info
+ ;; is already displayed via `most'.
+ (string-prefix-p prefix most t)
+ (length prefix))) ;;)
+ prospects comp limit)
+ (prog1
+ (if (or (eq most-try t) (and (not icomplete-scroll)
+ (not (consp (cdr comps)))))
+ (concat determ " [Matched]")
+ (when (member name comps)
+ ;; NAME is complete but not unique. This scenario poses
+ ;; following UI issues:
+ ;;
+ ;; - When `icomplete-hide-common-prefix' is non-nil, NAME
+ ;; is stripped empty. This would make the entry
+ ;; inconspicuous.
+ ;;
+ ;; - Due to sorting of completions, NAME may not be the
+ ;; first of the prospects and could be hidden deep in
+ ;; the displayed string.
+ ;;
+ ;; - Because of `icomplete-prospects-height' , NAME may
+ ;; not even be displayed to the user.
+ ;;
+ ;; To circumvent all the above problems, provide a visual
+ ;; cue to the user via an "empty string" in the try
+ ;; completion field.
+ (setq determ (concat open-bracket "" close-bracket)))
+ (while (and comps (not limit))
+ (setq comp
+ (if prefix-len (substring (car comps) prefix-len) (car
comps))
+ comps (cdr comps))
+ (setq prospects-len
+ (+ (string-width comp)
+ (string-width icomplete-separator)
+ prospects-len))
+ (if (< prospects-len prospects-max)
+ (push comp prospects)
+ (setq limit t)))
+ (setq prospects (nreverse prospects))
+ ;; Decorate first of the prospects.
+ (when prospects
+ (let ((first (copy-sequence (pop prospects))))
+ (put-text-property 0 (length first)
+ 'face 'icomplete-first-match first)
+ (push first prospects)))
+ (concat determ
+ "{"
+ (mapconcat 'identity prospects icomplete-separator)
+ (concat (and limit (concat icomplete-separator
ellipsis))
+ "}")))
+ ;; Restore the base-size info, since
completion-all-sorted-completions
+ ;; is cached.
+ (if last (setcdr last base-size))))))))
;;; Iswitchb compatibility
diff --git a/lisp/indent.el b/lisp/indent.el
index 285b8e2..a33d962 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -39,8 +39,8 @@
(defvar indent-line-function 'indent-relative
"Function to indent the current line.
This function will be called with no arguments.
-If it is called somewhere where auto-indentation cannot be done
-\(e.g. inside a string), the function should simply return `noindent'.
+If it is called somewhere where it cannot auto-indent, the function
+should return `noindent' to signal that it didn't.
Setting this function is all you need to make TAB indent appropriately.
Don't rebind TAB unless you really need to.")
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 232a994..c8bd628 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -404,7 +404,7 @@ A value of nil means highlight all matches shown on the
screen."
(integer :tag "Some"))
:group 'lazy-highlight)
-(defcustom lazy-highlight-buffer-max-at-a-time 20
+(defcustom lazy-highlight-buffer-max-at-a-time 200 ; 20 (bug#48581)
"Maximum matches to highlight at a time (for `lazy-highlight-buffer').
Larger values may reduce Isearch's responsiveness to user input;
smaller values make matches highlight slowly.
@@ -412,7 +412,7 @@ A value of nil means highlight all matches in the buffer."
:type '(choice (const :tag "All" nil)
(integer :tag "Some"))
:group 'lazy-highlight
- :version "27.1")
+ :version "28.1")
(defcustom lazy-highlight-buffer nil
"Controls the lazy-highlighting of the full buffer.
@@ -3462,10 +3462,6 @@ Can be changed via `isearch-search-fun-function' for
special needs."
(if isearch-forward #'re-search-forward #'re-search-backward)
regexp bound noerror count))))
-;; This is for when we compile this file during bootstrap, with
-;; loaddefs.el still not loaded.
-(declare-function multi-isearch-switch-buffer "misearch" ())
-
(defun isearch-search-string (string bound noerror)
"Search for the first occurrence of STRING or its translation.
STRING's characters are translated using `translation-table-for-input'
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index afc486f..8821e35 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -482,7 +482,7 @@ without repeating the prefix."
(defun kmacro-view-ring-2nd ()
- "Display the current head of the keyboard macro ring."
+ "Display the second macro in the keyboard macro ring."
(interactive)
(unless (kmacro-ring-empty-p)
(kmacro-display (car (car kmacro-ring)) nil "2nd macro")))
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 613223b3..f490bfb 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -1063,7 +1063,7 @@ or a non-nil `apropos-do-all' argument.
\(fn PATTERN)" t nil)
-(defalias 'command-apropos 'apropos-command)
+(defalias 'command-apropos #'apropos-command)
(autoload 'apropos-command "apropos" "\
Show commands (interactively callable functions) that match PATTERN.
@@ -5339,14 +5339,14 @@ clashes.
\(fn NAME PREFIX &optional FIRST)" nil nil)
(autoload 'comp-clean-up-stale-eln "comp" "\
-Given FILE remove all its *.eln files in `comp-eln-load-path'
+Given FILE remove all its *.eln files in `native-comp-eln-load-path'
sharing the original source filename (including FILE).
\(fn FILE)" nil nil)
(autoload 'comp-lookup-eln "comp" "\
Given a Lisp source FILENAME return the corresponding .eln file if found.
-Search happens in `comp-eln-load-path'.
+Search happens in `native-comp-eln-load-path'.
\(fn FILENAME)" nil nil)
@@ -5374,7 +5374,7 @@ Native compilation equivalent to `batch-byte-compile'."
nil nil)
Like `batch-native-compile', but used for bootstrap.
Generate .elc files in addition to the .eln files.
Force the produced .eln to be outputted in the eln system
-directory (the last entry in `comp-eln-load-path').
+directory (the last entry in `native-comp-eln-load-path').
If the environment variable 'NATIVE_DISABLED' is set, only byte
compile." nil nil)
@@ -5394,7 +5394,7 @@ nil -- Select all files.
a string -- A regular expression selecting files with matching names.
a function -- A function selecting files with matching names.
-The variable `comp-async-jobs-number' specifies the number
+The variable `native-comp-async-jobs-number' specifies the number
of (commands) to run simultaneously.
\(fn FILES &optional RECURSIVELY LOAD SELECTOR)" nil nil)
@@ -7209,6 +7209,12 @@ information on adapting behavior of commands in Delete
Selection mode.
\(fn &optional ARG)" t nil)
+(autoload 'delete-active-region "delsel" "\
+Delete the active region.
+If KILLP in not-nil, the active region is killed instead of deleted.
+
+\(fn &optional KILLP)" t nil)
+
(register-definition-prefixes "delsel" '("del" "minibuffer-keyboard-quit"))
;;;***
@@ -9389,6 +9395,26 @@ an EDE controlled project.
;;;### (autoloads nil "edebug" "emacs-lisp/edebug.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/edebug.el
+(defvar edebug-all-defs nil "\
+If non-nil, evaluating defining forms instruments for Edebug.
+This applies to `eval-defun', `eval-region', `eval-buffer', and
+`eval-current-buffer'. `eval-region' is also called by
+`eval-last-sexp', and `eval-print-last-sexp'.
+
+You can use the command `edebug-all-defs' to toggle the value of this
+variable. You may wish to make it local to each buffer with
+\(make-local-variable \\='edebug-all-defs) in your
+`emacs-lisp-mode-hook'.")
+
+(custom-autoload 'edebug-all-defs "edebug" t)
+
+(defvar edebug-all-forms nil "\
+Non-nil means evaluation of all forms will instrument for Edebug.
+This doesn't apply to loading or evaluations in the minibuffer.
+Use the command `edebug-all-forms' to toggle the value of this option.")
+
+(custom-autoload 'edebug-all-forms "edebug" t)
+
(autoload 'edebug-basic-spec "edebug" "\
Return t if SPEC uses only extant spec symbols.
An extant spec symbol is a symbol that is not a function and has a
@@ -10545,6 +10571,26 @@ Encrypt marked files." t nil)
;;;***
+;;;### (autoloads nil "epa-ks" "epa-ks.el" (0 0 0 0))
+;;; Generated autoloads from epa-ks.el
+
+(autoload 'epa-search-keys "epa-ks" "\
+Ask a keyserver for all keys matching QUERY.
+
+The keyserver to be used is specified by `epa-keyserver'.
+
+If EXACT is non-nil (interactively, prefix argument), require
+exact matches.
+
+Note that the request may fail if the query is not specific
+enough, since keyservers have strict timeout settings.
+
+\(fn QUERY EXACT)" t nil)
+
+(register-definition-prefixes "epa-ks" '("epa-k"))
+
+;;;***
+
;;;### (autoloads nil "epa-mail" "epa-mail.el" (0 0 0 0))
;;; Generated autoloads from epa-mail.el
@@ -10758,8 +10804,8 @@ Example usage:
(erc-tls :server \"chat.freenode.net\" :port 6697
:client-certificate
- '(\"/data/bandali/my-cert.key\"
- \"/data/bandali/my-cert.crt\"))
+ '(\"/home/bandali/my-cert.key\"
+ \"/home/bandali/my-cert.crt\"))
\(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK
(erc-compute-nick)) PASSWORD (FULL-NAME (erc-compute-full-name))
CLIENT-CERTIFICATE)" t nil)
@@ -12603,6 +12649,10 @@ Being on a `#include' line pulls in that file.
If optional IN-OTHER-WINDOW is non-nil, find the file in the other window.
If optional IGNORE-INCLUDE is non-nil, ignore being on `#include' lines.
+If optional EVENT is non-nil (default `last-nonmenu-event', move
+point to the end position of that event before calling the
+various ff-* hooks.
+
Variables of interest include:
- `ff-case-fold-search'
@@ -15762,6 +15812,12 @@ When called from lisp, FUNCTION may also be a function
object.
\(fn FUNCTION)" t nil)
+(autoload 'describe-command "help-fns" "\
+Display the full documentation of COMMAND (a symbol).
+When called from lisp, COMMAND may also be a function object.
+
+\(fn COMMAND)" t nil)
+
(autoload 'help-C-file-name "help-fns" "\
Return the name of the C file where SUBR-OR-VAR is defined.
KIND should be `var' for a variable or `subr' for a subroutine.
@@ -16076,22 +16132,30 @@ also supported.
There are several ways to change text in hexl mode:
-ASCII characters (character between space (0x20) and tilde (0x7E)) are
-bound to self-insert so you can simply type the character and it will
-insert itself (actually overstrike) into the buffer.
+Self-inserting characters are bound to `hexl-self-insert' so you
+can simply type the character and it will insert itself (actually
+overstrike) into the buffer. However, inserting non-ASCII characters
+requires caution: the buffer's coding-system should correspond to
+the encoding on disk, and multibyte characters should be inserted
+with cursor on the first byte of a multibyte sequence whose length
+is identical to the length of the multibyte sequence to be inserted,
+otherwise this could produce invalid multibyte sequences. Non-ASCII
+characters in ISO-2022 encodings should preferably inserted byte by
+byte, to avoid problems caused by the designation sequences before
+the actual characters.
\\[hexl-quoted-insert] followed by another keystroke allows you to insert the
key even if
it isn't bound to self-insert. An octal number can be supplied in place
of another key to insert the octal number's ASCII representation.
-\\[hexl-insert-hex-char] will insert a given hexadecimal value (if it is
between 0 and 0xFF)
-into the buffer at the current point.
+\\[hexl-insert-hex-char] will insert a given hexadecimal value
+into the buffer at the current address.
-\\[hexl-insert-octal-char] will insert a given octal value (if it is between 0
and 0377)
-into the buffer at the current point.
+\\[hexl-insert-octal-char] will insert a given octal value
+into the buffer at the current address.
-\\[hexl-insert-decimal-char] will insert a given decimal value (if it is
between 0 and 255)
-into the buffer at the current point.
+\\[hexl-insert-decimal-char] will insert a given decimal value
+into the buffer at the current address..
\\[hexl-mode-exit] will exit `hexl-mode'.
@@ -16107,7 +16171,8 @@ You can use \\[hexl-find-file] to visit a file in Hexl
mode.
(autoload 'hexl-find-file "hexl" "\
Edit file FILENAME as a binary file in hex dump format.
Switch to a buffer visiting file FILENAME, creating one if none exists,
-and edit the file in `hexl-mode'.
+and edit the file in `hexl-mode'. The buffer's coding-system will be
+no-conversion, unlike if you visit it normally and then invoke `hexl-mode'.
\(fn FILENAME)" t nil)
@@ -17195,7 +17260,7 @@ resized depends on `resize-mini-windows'.
(make-obsolete 'iswitchb-mode
"use `icomplete-mode' or `ido-mode' instead." "24.4"))
-(register-definition-prefixes "icomplete" '("icomplete-"))
+(register-definition-prefixes "icomplete" '("fido-vertical-mode" "icomplete-"))
;;;***
@@ -19272,7 +19337,7 @@ It is not recommended to set this variable permanently
to anything but nil.")
Uninstall jka-compr.
This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
and `inhibit-local-variables-suffixes' that were added
-by `jka-compr-installed'." nil nil)
+by `jka-compr-install'." nil nil)
(register-definition-prefixes "jka-compr" '("compression-error" "jka-compr-"))
@@ -19437,12 +19502,12 @@ and the return value is the length of the conversion.
;;;### (autoloads nil "kmacro" "kmacro.el" (0 0 0 0))
;;; Generated autoloads from kmacro.el
- (global-set-key "\C-x(" 'kmacro-start-macro)
- (global-set-key "\C-x)" 'kmacro-end-macro)
- (global-set-key "\C-xe" 'kmacro-end-and-call-macro)
- (global-set-key [f3] 'kmacro-start-macro-or-insert-counter)
- (global-set-key [f4] 'kmacro-end-or-call-macro)
- (global-set-key "\C-x\C-k" 'kmacro-keymap)
+ (global-set-key "\C-x(" #'kmacro-start-macro)
+ (global-set-key "\C-x)" #'kmacro-end-macro)
+ (global-set-key "\C-xe" #'kmacro-end-and-call-macro)
+ (global-set-key [f3] #'kmacro-start-macro-or-insert-counter)
+ (global-set-key [f4] #'kmacro-end-or-call-macro)
+ (global-set-key "\C-x\C-k" #'kmacro-keymap)
(autoload 'kmacro-keymap "kmacro" "Keymap for keyboard macro commands." t
'keymap)
(autoload 'kmacro-exec-ring-item "kmacro" "\
@@ -19950,28 +20015,28 @@ except that FILTER is not optional.
;;; Generated autoloads from vc/log-edit.el
(autoload 'log-edit "log-edit" "\
-Setup a buffer to enter a log message.
-The buffer is put in mode MODE or `log-edit-mode' if MODE is nil.
+Setup a buffer to enter a VC commit log message.
+The buffer is put in mode MODE, or `log-edit-mode' if MODE is nil.
\\<log-edit-mode-map>
If SETUP is non-nil, erase the buffer and run `log-edit-hook'.
Set mark and point around the entire contents of the buffer, so
that it is easy to kill the contents of the buffer with
-\\[kill-region]. Once the user is done editing the message,
-invoking the command \\[log-edit-done] (`log-edit-done') will
-call CALLBACK to do the actual commit.
+\\[kill-region]. Once the user is done editing the message, he
+or she is expected to invoke the command \\[log-edit-done] (`log-edit-done'),
+which will call CALLBACK, a function to do the actual commit.
-PARAMS if non-nil is an alist of variables and buffer-local
-values to give them in the Log Edit buffer. Possible keys and
-associated values:
+PARAMS, if non-nil, is an alist of variables and buffer-local
+values to give to those variables in the Log Edit buffer. Possible
+keys and associated values are:
`log-edit-listfun' -- function taking no arguments that returns the list of
- files that are concerned by the current operation (using relative names);
+ files that are concerned by the current operation (using relative names);
`log-edit-diff-function' -- function taking no arguments that
- displays a diff of the files concerned by the current operation.
+ displays a diff of the files concerned by the current operation.
`vc-log-fileset' -- the VC fileset to be committed (if any).
-If BUFFER is non-nil `log-edit' will jump to that buffer, use it
+If BUFFER is non-nil, `log-edit' will switch to that buffer, use it
to edit the log message and go back to the current buffer when
-done. Otherwise, it uses the current buffer.
+done. Otherwise, this function will use the current buffer.
\(fn CALLBACK &optional SETUP PARAMS BUFFER MODE &rest IGNORE)" nil nil)
@@ -20511,6 +20576,50 @@ The mail client is taken to be the handler of mailto
URLs." nil nil)
;;;### (autoloads nil "mairix" "net/mairix.el" (0 0 0 0))
;;; Generated autoloads from net/mairix.el
+(autoload 'mairix-search "mairix" "\
+Call Mairix with SEARCH.
+If THREADS is non-nil, also display whole threads of found
+messages. Results will be put into the default search file.
+
+\(fn SEARCH THREADS)" t nil)
+
+(autoload 'mairix-use-saved-search "mairix" "\
+Use a saved search for querying Mairix." t nil)
+
+(autoload 'mairix-edit-saved-searches-customize "mairix" "\
+Edit the list of saved searches in a customization buffer." t nil)
+
+(autoload 'mairix-search-from-this-article "mairix" "\
+Search messages from sender of the current article.
+This is effectively a shortcut for calling `mairix-search' with
+f:current_from. If prefix THREADS is non-nil, include whole
+threads.
+
+\(fn THREADS)" t nil)
+
+(autoload 'mairix-search-thread-this-article "mairix" "\
+Search thread for the current article.
+This is effectively a shortcut for calling `mairix-search'
+with m:msgid of the current article and enabled threads." t nil)
+
+(autoload 'mairix-widget-search-based-on-article "mairix" "\
+Create mairix query based on current article using widgets." t nil)
+
+(autoload 'mairix-edit-saved-searches "mairix" "\
+Edit current mairix searches." t nil)
+
+(autoload 'mairix-widget-search "mairix" "\
+Create mairix query interactively using graphical widgets.
+MVALUES may contain values from current article.
+
+\(fn &optional MVALUES)" t nil)
+
+(autoload 'mairix-update-database "mairix" "\
+Call mairix for updating the database for SERVERS.
+Mairix will be called asynchronously unless
+`mairix-synchronous-update' is t. Mairix will be called with
+`mairix-update-options'." t nil)
+
(register-definition-prefixes "mairix" '("mairix-"))
;;;***
@@ -21518,6 +21627,9 @@ Sequence of files visited by multiple file buffers
Isearch.")
Set up isearch to search multiple buffers.
Intended to be added to `isearch-mode-hook'." nil nil)
+(autoload 'multi-isearch-switch-buffer "misearch" "\
+Switch to the next buffer in multi-buffer search." nil nil)
+
(autoload 'multi-isearch-buffers "misearch" "\
Start multi-buffer Isearch on a list of BUFFERS.
This list can contain live buffers or their names.
@@ -24243,7 +24355,7 @@ Turning on outline mode calls the value of
`text-mode-hook' and then of
\(fn)" t nil)
(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp)
-(put 'outline-minor-mode-highlight 'safe-local-variable 'booleanp)
+(put 'outline-minor-mode-highlight 'safe-local-variable 'symbolp)
(autoload 'outline-minor-mode "outline" "\
Toggle Outline minor mode.
@@ -25312,14 +25424,14 @@ Macroexpand EXPRESSION and pretty-print its value.
(autoload 'pp-eval-last-sexp "pp" "\
Run `pp-eval-expression' on sexp before point.
-With argument, pretty-print output into current buffer.
+With ARG, pretty-print output into current buffer.
Ignores leading comment characters.
\(fn ARG)" t nil)
(autoload 'pp-macroexpand-last-sexp "pp" "\
Run `pp-macroexpand-expression' on sexp before point.
-With argument, pretty-print output into current buffer.
+With ARG, pretty-print output into current buffer.
Ignores leading comment characters.
\(fn ARG)" t nil)
@@ -26996,7 +27108,12 @@ the regexp builder. It displays a buffer named
\"*RE-Builder*\"
in another window, initially containing an empty regexp.
As you edit the regexp in the \"*RE-Builder*\" buffer, the
-matching parts of the target buffer will be highlighted." t nil)
+matching parts of the target buffer will be highlighted.
+
+Case-sensitivity can be toggled with \\[reb-toggle-case]. The
+regexp builder supports three different forms of input which can
+be set with \\[reb-change-syntax]. More options and details are
+provided in the Commentary section of this library." t nil)
(register-definition-prefixes "re-builder" '("re-builder-unload-function"
"reb-"))
@@ -28016,28 +28133,37 @@ than appending to it. Deletes the message after
writing if
;;; Generated autoloads from emacs-lisp/rmc.el
(autoload 'read-multiple-choice "rmc" "\
-Ask user a multiple choice question.
-PROMPT should be a string that will be displayed as the prompt.
-
-CHOICES is a list of (KEY NAME [DESCRIPTION]). KEY is a
-character to be entered. NAME is a short name for the entry to
-be displayed while prompting (if there's room, it might be
-shortened). DESCRIPTION is an optional longer explanation that
-will be displayed in a help buffer if the user requests more
-help.
+Ask user to select an entry from CHOICES, promting with PROMPT.
+This function allows to ask the user a multiple-choice question.
+
+CHOICES should be a list of the form (KEY NAME [DESCRIPTION]).
+KEY is a character the user should type to select the entry.
+NAME is a short name for the entry to be displayed while prompting
+\(if there's no room, it might be shortened).
+DESCRIPTION is an optional longer description of the entry; it will
+be displayed in a help buffer if the user requests more help. This
+help description has a fixed format in columns. For greater
+flexibility, instead of passing a DESCRIPTION, the caller can pass
+the optional argument HELP-STRING. This argument is a string that
+should contain a more detailed description of all of the possible
+choices. `read-multiple-choice' will display that description in a
+help buffer if the user requests that.
This function translates user input into responses by consulting
the bindings in `query-replace-map'; see the documentation of
-that variable for more information. In this case, the useful
-bindings are `recenter', `scroll-up', and `scroll-down'. If the
-user enters `recenter', `scroll-up', or `scroll-down' responses,
-perform the requested window recentering or scrolling and ask
-again.
-
-When `use-dialog-box' is t (the default), this function can pop
-up a dialog window to collect the user input. That functionality
-requires `display-popup-menus-p' to return t. Otherwise, a
-text dialog will be used.
+that variable for more information. The relevant bindings for the
+purposes of this function are `recenter', `scroll-up', `scroll-down',
+and `edit'.
+If the user types the `recenter', `scroll-up', or `scroll-down'
+responses, the function performs the requested window recentering or
+scrolling, and then asks the question again. If the user enters `edit',
+the function starts a recursive edit. When the user exit the recursive
+edit, the multiple-choice prompt gains focus again.
+
+When `use-dialog-box' is t (the default), and the command using this
+function was invoked via the mouse, this function pops up a GUI dialog
+to collect the user input, but only if Emacs is capable of using GUI
+dialogs. Otherwise, the function will always use text-mode dialogs.
The return value is the matching entry from the CHOICES list.
@@ -28048,7 +28174,7 @@ Usage example:
(?s \"session only\")
(?n \"no\")))
-\(fn PROMPT CHOICES)" nil nil)
+\(fn PROMPT CHOICES &optional HELP-STRING)" nil nil)
;;;***
@@ -28559,7 +28685,7 @@ For more details, see Info node `(elisp) Extending Rx'.
(function-put 'rx-define 'lisp-indent-function 'defun)
-(eval-and-compile (defun rx--pcase-macroexpander (&rest regexps) "A pattern
that matches strings against `rx' REGEXPS in sexp form.\nREGEXPS are
interpreted as in `rx'. The pattern matches any\nstring that is a match for
REGEXPS, as if by `string-match'.\n\nIn addition to the usual `rx' syntax,
REGEXPS can contain the\nfollowing constructs:\n\n (let REF RX...) binds the
symbol REF to a submatch that matches\n the regular
expressions RX. REF is bound in\n [...]
+(eval-and-compile (defun rx--pcase-macroexpander (&rest regexps) "A pattern
that matches strings against `rx' REGEXPS in sexp form.\nREGEXPS are
interpreted as in `rx'. The pattern matches any\nstring that is a match for
REGEXPS, as if by `string-match'.\n\nIn addition to the usual `rx' syntax,
REGEXPS can contain the\nfollowing constructs:\n\n (let REF RX...) binds the
symbol REF to a submatch that matches\n the regular
expressions RX. REF is bound in\n [...]
(define-symbol-prop 'rx--pcase-macroexpander 'edebug-form-spec 'nil)
@@ -29934,7 +30060,7 @@ Pop to a buffer with short documentation summary for
functions in GROUP.
\(fn GROUP)" t nil)
-(register-definition-prefixes "shortdoc" '("alist" "buffer"
"define-short-documentation-group" "file" "hash-table" "list" "number"
"process" "regexp" "sequence" "shortdoc-" "string" "vector"))
+(register-definition-prefixes "shortdoc" '("alist" "buffer"
"define-short-documentation-group" "file" "hash-table" "list" "number"
"overlay" "process" "regexp" "sequence" "shortdoc-" "string" "vector"))
;;;***
@@ -34136,10 +34262,10 @@ match file names at root of the underlying local file
system,
like \"/sys\" or \"/C:\".")
(defun tramp-autoload-file-name-handler (operation &rest args) "\
-Load Tramp file name handler, and perform OPERATION."
(tramp-unload-file-name-handlers) (when tramp-mode (let ((default-directory
temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply
operation args))
+Load Tramp file name handler, and perform OPERATION."
(tramp-unload-file-name-handlers) (when tramp-mode (let ((default-directory
temporary-file-directory)) (when (bound-and-true-p tramp-archive-autoload)
(load "tramp-archive" 'noerror 'nomessage)) (load "tramp" 'noerror
'nomessage))) (apply operation args))
(defun tramp-register-autoload-file-name-handlers nil "\
-Add Tramp file name handlers to `file-name-handler-alist' during autoload."
(add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp
'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler
'safe-magic t))
+Add Tramp file name handlers to `file-name-handler-alist' during autoload."
(add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp
#'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler
'safe-magic t))
(tramp-register-autoload-file-name-handlers)
(defun tramp-unload-file-name-handlers nil "\
@@ -34177,7 +34303,8 @@ It must be supported by libarchive(3).")
(defmacro tramp-archive-autoload-file-name-regexp nil "\
Regular expression matching archive file names." '(concat "\\`" "\\(" ".+"
"\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt
tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'"))
-(defalias 'tramp-archive-autoload-file-name-handler
#'tramp-autoload-file-name-handler)
+(defun tramp-archive-autoload-file-name-handler (operation &rest args) "\
+Load Tramp archive file name handler, and perform OPERATION." (when
tramp-archive-enabled (let ((default-directory temporary-file-directory)
(tramp-archive-autoload t)) tramp-archive-autoload (apply
#'tramp-autoload-file-name-handler operation args))))
(defun tramp-register-archive-file-name-handler nil "\
Add archive file name handler to `file-name-handler-alist'." (when
tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons
(tramp-archive-autoload-file-name-regexp)
#'tramp-archive-autoload-file-name-handler)) (put
#'tramp-archive-autoload-file-name-handler 'safe-magic t)))
diff --git a/lisp/leim/quail/latin-ltx.el b/lisp/leim/quail/latin-ltx.el
index 8b1e520..2146304 100644
--- a/lisp/leim/quail/latin-ltx.el
+++ b/lisp/leim/quail/latin-ltx.el
@@ -279,13 +279,17 @@ system, including many technical ones. Examples:
("\\Vdash" ?⊩)
("\\Vert" ?‖)
("\\Vvdash" ?⊪)
+ ("\\above" ?┴)
("\\aleph" ?ℵ)
("\\amalg" ?∐)
("\\angle" ?∠)
+ ("\\aoint" ?∳)
("\\approx" ?≈)
("\\approxeq" ?≊)
+ ("\\asmash" ?⬆)
("\\ast" ?∗)
("\\asymp" ?≍)
+ ("\\atop" ?¦)
("\\backcong" ?≌)
("\\backepsilon" ?∍)
("\\backprime" ?‵)
@@ -294,11 +298,18 @@ system, including many technical ones. Examples:
("\\backslash" ?\\)
("\\barwedge" ?⊼)
("\\because" ?∵)
+ ("\\begin" ?\〖)
+ ("\\below" ?┬)
("\\beth" ?ℶ)
("\\between" ?≬)
("\\bigcap" ?⋂)
("\\bigcirc" ?◯)
("\\bigcup" ?⋃)
+ ("\\bigodot" ?⨀)
+ ("\\bigoplus" ?⨁)
+ ("\\bigotimes" ?⨂)
+ ("\\bigsqcup" ?⨆)
+ ("\\biguplus" ?⨄)
("\\bigstar" ?★)
("\\bigtriangledown" ?▽)
("\\bigtriangleup" ?△)
@@ -315,6 +326,7 @@ system, including many technical ones. Examples:
("\\boxminus" ?⊟)
("\\boxplus" ?⊞)
("\\boxtimes" ?⊠)
+ ("\\bra" ?\⟨)
("\\bullet" ?•)
("\\bumpeq" ?≏)
("\\cap" ?∩)
@@ -331,7 +343,9 @@ system, including many technical ones. Examples:
("\\circledast" ?⊛)
("\\circledcirc" ?⊚)
("\\circleddash" ?⊝)
+ ("\\close" ?┤)
("\\clubsuit" ?♣)
+ ("\\coint" ?∲)
("\\coloneq" ?≔)
("\\complement" ?∁)
("\\cong" ?≅)
@@ -349,8 +363,12 @@ system, including many technical ones. Examples:
("\\dagger" ?†)
("\\daleth" ?ℸ)
("\\dashv" ?⊣)
+ ("\\Dd" ?ⅅ)
+ ("\\dd" ?ⅆ)
("\\ddag" ?‡)
("\\ddagger" ?‡)
+ ("\\ddddot" ?⃜)
+ ("\\dddot" ?⃛)
("\\ddots" ?⋱)
("\\diamond" ?⋄)
("\\diamondsuit" ?♢)
@@ -363,8 +381,12 @@ system, including many technical ones. Examples:
("\\downdownarrows" ?⇊)
("\\downleftharpoon" ?⇃)
("\\downrightharpoon" ?⇂)
+ ("\\dsmash" ?⬇)
+ ("\\ee" ?ⅇ)
("\\ell" ?ℓ)
("\\emptyset" ?∅)
+ ("\\end" ?\〗)
+ ("\\eqarray" ?█)
("\\eqcirc" ?≖)
("\\eqcolon" ?≕)
("\\eqslantgtr" ?⋝)
@@ -414,16 +436,25 @@ system, including many technical ones. Examples:
("\\heartsuit" ?♥)
("\\hookleftarrow" ?↩)
("\\hookrightarrow" ?↪)
+ ("\\hphantom" ?⬄)
+ ("\\hsmash" ?⬌)
("\\iff" ?⇔)
+ ("\\ii" ?ⅈ)
+ ("\\iiiint" ?⨌)
+ ("\\iiint" ?∭)
+ ("\\iint" ?∬)
("\\imath" ?ı)
("\\in" ?∈)
("\\infty" ?∞)
("\\int" ?∫)
("\\intercal" ?⊺)
+ ("\\jj" ?ⅉ)
+ ("\\jmath" ?ȷ)
("\\langle" ?⟨) ;; Was ?〈, see bug#12948.
("\\lbrace" ?{)
("\\lbrack" ?\[)
("\\lceil" ?⌈)
+ ("\\ldiv" ?∕)
("\\ldots" ?…)
("\\le" ?≤)
("\\leadsto" ?↝)
@@ -529,16 +560,25 @@ system, including many technical ones. Examples:
("\\nvdash" ?⊬)
("\\nwarrow" ?↖)
("\\odot" ?⊙)
+ ("\\oiiint" ?∰)
+ ("\\oiint" ?∯)
("\\oint" ?∮)
("\\ominus" ?⊖)
("\\oplus" ?⊕)
("\\oslash" ?⊘)
("\\otimes" ?⊗)
+ ("\\overbrace" ?⏞)
+ ("\\overparen" ?⏜)
("\\par" ?
)
("\\parallel" ?∥)
("\\partial" ?∂)
("\\perp" ?⊥)
+ ("\\phantom" ?⟡)
("\\pitchfork" ?⋔)
+ ("\\pppprime" ?⁗)
+ ("\\ppprime" ?‴)
+ ("\\pprime" ?″)
+ ("\\prcue" ?≼)
("\\prec" ?≺)
("\\precapprox" ?≾)
("\\preceq" ?≼)
@@ -548,12 +588,16 @@ system, including many technical ones. Examples:
("\\prime" ?′)
("\\prod" ?∏)
("\\propto" ?∝)
+ ("\\qdrt" ?∜)
("\\qed" ?∎)
("\\quad" ? )
("\\rangle" ?\⟩) ;; Was ?〉, see bug#12948.
+ ("\\ratio" ?∶)
("\\rbrace" ?})
("\\rbrack" ?\])
("\\rceil" ?⌉)
+ ("\\rddots" ?⋰)
+ ("\\rect" ?▭)
("\\rfloor" ?⌋)
("\\rightarrow" ?→)
("\\rightarrowtail" ?↣)
@@ -565,6 +609,8 @@ system, including many technical ones. Examples:
("\\rightrightarrows" ?⇉)
("\\rightthreetimes" ?⋌)
("\\risingdotseq" ?≓)
+ ("\\rrect" ?▢)
+ ("\\sdiv" ?⁄)
("\\rtimes" ?⋊)
("\\sbs" ?﹨)
("\\searrow" ?↘)
@@ -577,6 +623,7 @@ system, including many technical ones. Examples:
("\\smallamalg" ?∐)
("\\smallsetminus" ?∖)
("\\smallsmile" ?⌣)
+ ("\\smash" ?⬍)
("\\smile" ?⌣)
("\\spadesuit" ?♠)
("\\sphericalangle" ?∢)
@@ -627,12 +674,16 @@ system, including many technical ones. Examples:
("\\ulcorner" ?⌜)
("\\uparrow" ?↑)
("\\updownarrow" ?↕)
+ ("\\underbar" ?▁)
+ ("\\underbrace" ?⏟)
+ ("\\underparen" ?⏝)
("\\upleftharpoon" ?↿)
("\\uplus" ?⊎)
("\\uprightharpoon" ?↾)
("\\upuparrows" ?⇈)
("\\urcorner" ?⌝)
("\\u{i}" ?ĭ)
+ ("\\vbar" ?│)
("\\vDash" ?⊨)
((lambda (name char)
@@ -655,6 +706,7 @@ system, including many technical ones. Examples:
("\\vee" ?∨)
("\\veebar" ?⊻)
("\\vert" ?|)
+ ("\\vphantom" ?⇳)
("\\wedge" ?∧)
("\\wp" ?℘)
("\\wr" ?≀)
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index f812267..9cd2c62 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -2241,6 +2241,7 @@ Buffers menu is regenerated."
"String to display in buffer listings for buffers not visiting a file.")
(defun menu-bar-select-buffer ()
+ (declare (obsolete nil "28.1"))
(interactive)
(switch-to-buffer last-command-event))
diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el
index 1aac337..e935cfd 100644
--- a/lisp/mh-e/mh-e.el
+++ b/lisp/mh-e/mh-e.el
@@ -738,8 +738,11 @@ is described by the variable `mh-variants'."
;; Make a unique list of directories, keeping the given order.
;; We don't want the same MH variant to be listed multiple times.
(cl-loop for dir in (append mh-path mh-sys-path exec-path) do
- (setq dir (file-chase-links (directory-file-name dir)))
- (cl-pushnew dir list-unique :test #'equal))
+ ;; skip relative dirs, typically "."
+ (if (file-name-absolute-p dir)
+ (progn
+ (setq dir (file-chase-links (directory-file-name dir)))
+ (cl-pushnew dir list-unique :test #'equal))))
(cl-loop for dir in (nreverse list-unique) do
(when (and dir (file-accessible-directory-p dir))
(let ((variant (mh-variant-info dir)))
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index ec21b7b..d09a348 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -741,14 +741,16 @@ If ARGS are provided, then pass MESSAGE through
`format-message'."
;; Don't overwrite the face properties the caller has set
(text-properties-at 0 message))
(setq message (apply #'propertize message
minibuffer-message-properties)))
- (let ((ol (make-overlay (point-max) (point-max) nil t t))
- ;; A quit during sit-for normally only interrupts the sit-for,
- ;; but since minibuffer-message is used at the end of a command,
- ;; at a time when the command has virtually finished already, a C-g
- ;; should really cause an abort-recursive-edit instead (i.e. as if
- ;; the C-g had been typed at top-level). Binding inhibit-quit here
- ;; is an attempt to get that behavior.
- (inhibit-quit t))
+ ;; Put overlay either on `minibuffer-message' property, or at EOB.
+ (let* ((ovpos (minibuffer--message-overlay-pos))
+ (ol (make-overlay ovpos ovpos nil t t))
+ ;; A quit during sit-for normally only interrupts the sit-for,
+ ;; but since minibuffer-message is used at the end of a command,
+ ;; at a time when the command has virtually finished already, a C-g
+ ;; should really cause an abort-recursive-edit instead (i.e. as if
+ ;; the C-g had been typed at top-level). Binding inhibit-quit here
+ ;; is an attempt to get that behavior.
+ (inhibit-quit t))
(unwind-protect
(progn
(unless (zerop (length message))
@@ -757,6 +759,12 @@ If ARGS are provided, then pass MESSAGE through
`format-message'."
;; before or after the string, so let's spoon-feed it the pos.
(put-text-property 0 1 'cursor t message))
(overlay-put ol 'after-string message)
+ ;; Make sure the overlay with the message is displayed before
+ ;; any other overlays in that position, in case they have
+ ;; resize-mini-windows set to nil and the other overlay strings
+ ;; are too long for the mini-window width. This makes sure the
+ ;; temporary message will always be visible.
+ (overlay-put ol 'priority 1100)
(sit-for (or minibuffer-message-timeout 1000000)))
(delete-overlay ol)))))
@@ -778,8 +786,10 @@ and `clear-minibuffer-message' called automatically via
(defvar minibuffer-message-overlay nil)
(defun minibuffer--message-overlay-pos ()
- "Return position where `set-minibuffer-message' shall put message overlay."
- ;; Starting from point, look for non-nil 'minibuffer-message'
+ "Return position where minibuffer message functions shall put message
overlay.
+The minibuffer message functions include `minibuffer-message' and
+`set-minibuffer-message'."
+ ;; Starting from point, look for non-nil `minibuffer-message'
;; property, and return its position. If none found, return the EOB
;; position.
(let* ((pt (point))
@@ -824,7 +834,7 @@ via `set-message-function'."
;; The current C cursor code doesn't know to use the overlay's
;; marker's stickiness to figure out whether to place the cursor
;; before or after the string, so let's spoon-feed it the pos.
- (put-text-property 0 1 'cursor 1 message))
+ (put-text-property 0 1 'cursor t message))
(overlay-put minibuffer-message-overlay 'after-string message)
;; Make sure the overlay with the message is displayed before
;; any other overlays in that position, in case they have
@@ -3484,7 +3494,8 @@ between 0 and 1, and with faces `completions-common-part',
(when completions
(let* ((re (completion-pcm--pattern->regex pattern 'group))
(point-idx (completion-pcm--pattern-point-idx pattern))
- (case-fold-search completion-ignore-case))
+ (case-fold-search completion-ignore-case)
+ last-md)
(mapcar
(lambda (str)
;; Don't modify the string itself.
@@ -3493,7 +3504,7 @@ between 0 and 1, and with faces `completions-common-part',
(error "Internal error: %s does not match %s" re str))
(let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
(match-end (match-end 0))
- (md (cddr (match-data)))
+ (md (cddr (setq last-md (match-data t last-md))))
(from 0)
(end (length str))
;; To understand how this works, consider these simple
diff --git a/lisp/mpc.el b/lisp/mpc.el
index f730275..ab572aa 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -125,14 +125,13 @@
(unless (member elem seen) (push elem res)))))
(nreverse res)))
-(defun mpc-intersection (l1 l2 &optional selectfun)
+(defun mpc-intersection (l1 l2 selectfun)
"Return L1 after removing all elements not found in L2.
-If SELECTFUN is non-nil, elements aren't compared directly, but instead
+Elements aren't compared directly, but instead
they are passed through SELECTFUN before comparison."
- (when selectfun
- (setq l1 (mapcar selectfun l1))
- (setq l2 (mapcar selectfun l2)))
- (seq-intersection l1 l2))
+ (seq-intersection l1 l2 (lambda (x y)
+ (equal (funcall selectfun x)
+ (funcall selectfun y)))))
(defun mpc-event-set-point (event)
(condition-case nil (posn-set-point (event-end event))
@@ -1027,10 +1026,14 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
(let ((dir (file-name-directory (cdr (assq 'file info)))))
;; (debug)
(setq pred
- (lambda (info)
- (and (funcall pred info)
- (equal dir (file-name-directory
- (cdr (assq 'file info)))))))
+ ;; We want the closure to capture the current
+ ;; value of `pred' and not a reference to the
+ ;; variable itself.
+ (let ((oldpred pred))
+ (lambda (info)
+ (and (funcall oldpred info)
+ (equal dir (file-name-directory
+ (cdr (assq 'file info))))))))
(if-let* ((covers '(".folder.png" "cover.jpg"
"folder.jpg"))
(cover (cl-loop for file in (directory-files
(mpc-file-local-copy dir))
if (member (downcase file)
covers)
@@ -1057,9 +1060,13 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
(when (and (null val) (eq tag 'Title))
(setq val (cdr (assq 'file info))))
(setq pred
- (lambda (info)
- (and (funcall pred info)
- (equal val (cdr (assq ',tag info))))))
+ ;; We want the closure to capture the current
+ ;; value of `pred' and not a reference to the
+ ;; variable itself.
+ (let ((oldpred pred))
+ (lambda (info)
+ (and (funcall oldpred info)
+ (equal val (cdr (assq tag info)))))))
(cond
((not (and (eq tag 'Date) (stringp val))) val)
;; For "date", only keep the year!
diff --git a/lisp/msb.el b/lisp/msb.el
index 1064f94..1f05e9d 100644
--- a/lisp/msb.el
+++ b/lisp/msb.el
@@ -1052,9 +1052,12 @@ variable `msb-menu-cond'."
(msb--split-menus-2 list 0 nil)
list))
+(defun msb--select-buffer ()
+ (interactive)
+ (switch-to-buffer last-command-event))
+
(defun msb--make-keymap-menu (raw-menu)
- (let ((end 'menu-bar-select-buffer)
- (mcount 0))
+ (let ((mcount 0))
(mapcar
(lambda (sub-menu)
(cond
@@ -1063,7 +1066,7 @@ variable `msb-menu-cond'."
(t
(let ((buffers (mapcar (lambda (item)
(cons (buffer-name (cdr item))
- (cons (car item) end)))
+ (cons (car item) 'msb--select-buffer)))
(cdr sub-menu))))
(nconc (list (cl-incf mcount) (car sub-menu)
'keymap (car sub-menu))
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 8621491..96da0c5 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -47,6 +47,7 @@
;; browse-url-xdg-open freedesktop.org xdg-open
;; browse-url-kde KDE konqueror (kfm)
;; browse-url-elinks Elinks Don't know (tried with
0.12.GIT)
+;; eww-browse-url Emacs Web Wowser
;; Browsers can cache Web pages so it may be necessary to tell them to
;; reload the current page if it has changed (e.g., if you have edited
@@ -758,7 +759,7 @@ for use in `interactive'."
;;;###autoload
(defun browse-url-of-file (&optional file)
- "Ask a WWW browser to display FILE.
+ "Use a web browser to display FILE.
Display the current buffer's file if FILE is nil or if called
interactively. Turn the filename into a URL with function
`browse-url-file-url'. Pass the URL to a browser using the
@@ -773,6 +774,8 @@ interactively. Turn the filename into a URL with function
(cond ((not (buffer-modified-p)))
(browse-url-save-file (save-buffer))
(t (message "%s modified since last save" file))))))
+ (when (file-remote-p file)
+ (setq file (file-local-copy file)))
(browse-url (browse-url-file-url file))
(run-hooks 'browse-url-of-file-hook))
@@ -793,7 +796,9 @@ Use variable `browse-url-filename-alist' to map filenames
to URLs."
;;;###autoload
(defun browse-url-of-buffer (&optional buffer)
- "Ask a WWW browser to display BUFFER.
+ "Use a web browser to display BUFFER.
+See `browse-url' for details.
+
Display the current buffer if BUFFER is nil. Display only the
currently visible part of BUFFER (from a temporary file) if buffer is
narrowed."
@@ -842,7 +847,8 @@ If optional arg TEMP-FILE-NAME is non-nil, delete it
instead."
;;;###autoload
(defun browse-url-of-region (min max)
- "Ask a WWW browser to display the current region."
+ "Use a web browser to display the current region.
+See `browse-url' for details."
(interactive "r")
(save-excursion
(save-restriction
@@ -856,14 +862,18 @@ If optional arg TEMP-FILE-NAME is non-nil, delete it
instead."
;;;###autoload
(defun browse-url (url &rest args)
- "Ask a WWW browser to load URL.
-Prompt for a URL, defaulting to the URL at or before point.
-Invokes a suitable browser function which does the actual job.
+ "Open URL using a configurable method.
+This will typically (by default) open URL with an external web
+browser, but a wide variety of different methods can be used,
+depending on the URL type.
The variables `browse-url-browser-function',
`browse-url-handlers', and `browse-url-default-handlers'
determine which browser function to use.
+This command prompts for a URL, defaulting to the URL at or
+before point.
+
The additional ARGS are passed to the browser function. See the
doc strings of the actual functions, starting with
`browse-url-browser-function', for information about the
@@ -904,8 +914,8 @@ If ARGS are omitted, the default is to pass
;;;###autoload
(defun browse-url-at-point (&optional arg)
- "Ask a WWW browser to load the URL at or before point.
-Variable `browse-url-browser-function' says which browser to use.
+ "Open URL at point using a configurable method.
+See `browse-url' for details.
Optional prefix argument ARG non-nil inverts the value of the option
`browse-url-new-window-flag'."
(interactive "P")
@@ -946,10 +956,11 @@ opposite of the browser kind of
`browse-url-browser-function'."
;;;###autoload
(defun browse-url-at-mouse (event)
- "Ask a WWW browser to load a URL clicked with the mouse.
-The URL is the one around or before the position of the mouse click
-but point is not changed. Variable `browse-url-browser-function'
-says which browser to use."
+ "Use a web browser to load a URL clicked with the mouse.
+See `browse-url' for details.
+
+The URL is the one around or before the position of the mouse
+click but point is not changed."
(interactive "e")
(save-excursion
(mouse-set-point event)
@@ -1791,6 +1802,7 @@ external browser instead of the default one."
(funcall browse-url-secondary-browser-function url)
(browse-url url))))
+;;;###autoload
(defun browse-url-button-open-url (url)
"Open URL using `browse-url'.
If `current-prefix-arg' is non-nil, use
diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el
index 3097c9a..54f7f41 100644
--- a/lisp/net/mailcap.el
+++ b/lisp/net/mailcap.el
@@ -1156,6 +1156,29 @@ current buffer after passing its contents to the shell
command."
(mailcap--async-shell method file))
(funcall method))))
+(defun mailcap-view-file (file)
+ "View FILE according to rules given by the mailcap system.
+This normally involves executing some external program to display
+the file.
+
+See \"~/.mailcap\", `mailcap-mime-data' and related files and variables."
+ (interactive "fOpen file with mailcap: ")
+ (setq file (expand-file-name file))
+ (mailcap-parse-mailcaps)
+ (let ((command (mailcap-mime-info
+ (mailcap-extension-to-mime (file-name-extension file)))))
+ (unless command
+ (error "No viewer for %s" (file-name-extension file)))
+ ;; Remove quotes around the file name - we'll use shell-quote-argument.
+ (while (string-match "['\"]%s['\"]" command)
+ (setq command (replace-match "%s" t t command)))
+ (setq command (replace-regexp-in-string
+ "%s"
+ (shell-quote-argument (convert-standard-filename file))
+ command
+ nil t))
+ (start-process-shell-command command nil command)))
+
(provide 'mailcap)
;;; mailcap.el ends here
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index 7251640..4fdb63e 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -2502,7 +2502,8 @@ If ARG is given, opens the URL in a new browser window."
'follow-link t
'rcirc-url url
'action (lambda (button)
- (browse-url (button-get button 'rcirc-url))))
+ (browse-url-button-open-url
+ (button-get button 'rcirc-url))))
;; Record the URL if it is not already the latest stored URL.
(unless (string= url (caar rcirc-urls))
(push (cons url start) rcirc-urls)))))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 4fd7a322..838464e 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -2048,7 +2048,7 @@ function is meant for debugging purposes."
(put #'tramp-backtrace 'tramp-suppress-trace t)
-(defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments)
+(defun tramp-error (vec-or-proc signal fmt-string &rest arguments)
"Emit an error.
VEC-OR-PROC identifies the connection to use, SIGNAL is the
signal identifier to be raised, remaining arguments passed to
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index 13717b1..f0180ce 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -1808,7 +1808,7 @@ argument is passed to `next-file', which see)."
(defun tags-search (regexp &optional files)
"Search through all files listed in tags table for match for REGEXP.
Stops when a match is found.
-To continue searching for next match, use command \\[tags-loop-continue].
+To continue searching for next match, use the command \\[fileloop-continue].
If FILES if non-nil should be a list or an iterator returning the
files to search. The search will be restricted to these files.
@@ -1834,7 +1834,7 @@ Also see the documentation of the `tags-file-name'
variable."
"Do `query-replace-regexp' of FROM with TO on all files listed in tags table.
Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
-with the command \\[tags-loop-continue].
+with the command \\[fileloop-continue].
For non-interactive use, superseded by `fileloop-initialize-replace'."
(declare (advertised-calling-convention (from to &optional delimited)
"27.1"))
(interactive (query-replace-read-args "Tags query replace (regexp)" t t))
diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el
index 3bef398..707226f 100644
--- a/lisp/progmodes/fortran.el
+++ b/lisp/progmodes/fortran.el
@@ -650,74 +650,6 @@ Used in the Fortran entry in `hs-special-modes-alist'.")
(define-key map "7" 'fortran-electric-line-number)
(define-key map "8" 'fortran-electric-line-number)
(define-key map "9" 'fortran-electric-line-number)
-
- (easy-menu-define fortran-menu map "Menu for Fortran mode."
- `("Fortran"
- ["Manual" (info "(emacs)Fortran") :active t
- :help "Read the Emacs manual chapter on Fortran mode"]
- ("Customization"
- ,(custom-menu-create 'fortran)
- ;; FIXME useless?
- ["Set" Custom-set :active t
- :help "Set current value of all edited settings in the buffer"]
- ["Save" Custom-save :active t
- :help "Set and save all edited settings"]
- ["Reset to Current" Custom-reset-current :active t
- :help "Reset all edited settings to current"]
- ["Reset to Saved" Custom-reset-saved :active t
- :help "Reset all edited or set settings to saved"]
- ["Reset to Standard Settings" Custom-reset-standard :active t
- :help "Erase all customizations in buffer"]
- )
- "--"
- ["Comment Region" fortran-comment-region mark-active]
- ["Uncomment Region"
- (fortran-comment-region (region-beginning) (region-end) 1)
- mark-active]
- ["Indent Region" indent-region mark-active]
- ["Indent Subprogram" fortran-indent-subprogram t]
- "--"
- ["Beginning of Subprogram" fortran-beginning-of-subprogram :active t
- :help "Move point to the start of the current subprogram"]
- ["End of Subprogram" fortran-end-of-subprogram :active t
- :help "Move point to the end of the current subprogram"]
- ("Mark"
- :help "Mark a region of code"
- ["Subprogram" mark-defun t]
- ["IF Block" fortran-mark-if t]
- ["DO Block" fortran-mark-do t]
- )
- ["Narrow to Subprogram" narrow-to-defun t]
- ["Widen" widen t]
- "--"
- ["Temporary Column Ruler" fortran-column-ruler :active t
- :help "Briefly display Fortran column numbers"]
- ;; May not be '72', depending on fortran-line-length, but this
- ;; seems ok for a menu item.
- ["72-column Window" fortran-window-create :active t
- :help "Set window width to Fortran line length"]
- ["Full Width Window"
- (enlarge-window-horizontally (- (frame-width) (window-width)))
- :active (not (window-full-width-p))
- :help "Make window full width"]
- ["Momentary 72-Column Window" fortran-window-create-momentarily
- :active t :help "Briefly set window width to Fortran line length"]
- "--"
- ["Break Line at Point" fortran-split-line :active t
- :help "Break the current line at point"]
- ["Join Line" fortran-join-line :active t
- :help "Join the current line to the previous one"]
- ["Fill Statement/Comment" fill-paragraph t]
- "--"
- ["Toggle Auto Fill" auto-fill-mode :selected auto-fill-function
- :style toggle
- :help "Automatically fill text while typing in this buffer"]
- ["Toggle Abbrev Mode" abbrev-mode :selected abbrev-mode
- :style toggle :help "Expand abbreviations while typing in this
buffer"]
- ["Add Imenu Menu" imenu-add-menubar-index
- :active (not (lookup-key (current-local-map) [menu-bar index]))
- :included (fboundp 'imenu-add-to-menubar)
- :help "Add an index menu to the menu-bar"]))
map)
"Keymap used in Fortran mode.")
@@ -2209,6 +2141,81 @@ arg DO-SPACE prevents stripping the whitespace."
(point)))))
"main"))))
+;; The menu is defined at the end because `custom-menu-create' is
+;; called at load time and will result in (recursively) loading this
+;; file otherwise.
+(easy-menu-define fortran-menu fortran-mode-map "Menu for Fortran mode."
+ `("Fortran"
+ ["Manual" (info "(emacs)Fortran") :active t
+ :help "Read the Emacs manual chapter on Fortran mode"]
+ ("Customization"
+ ,(progn
+ ;; Tell the byte compiler that `features' is lexical.
+ (with-no-warnings (defvar features))
+ (let ((features (cons 'fortran features)))
+ (custom-menu-create 'fortran)))
+ ;; FIXME useless?
+ ["Set" Custom-set :active t
+ :help "Set current value of all edited settings in the buffer"]
+ ["Save" Custom-save :active t
+ :help "Set and save all edited settings"]
+ ["Reset to Current" Custom-reset-current :active t
+ :help "Reset all edited settings to current"]
+ ["Reset to Saved" Custom-reset-saved :active t
+ :help "Reset all edited or set settings to saved"]
+ ["Reset to Standard Settings" Custom-reset-standard :active t
+ :help "Erase all customizations in buffer"]
+ )
+ "--"
+ ["Comment Region" fortran-comment-region mark-active]
+ ["Uncomment Region"
+ (fortran-comment-region (region-beginning) (region-end) 1)
+ mark-active]
+ ["Indent Region" indent-region mark-active]
+ ["Indent Subprogram" fortran-indent-subprogram t]
+ "--"
+ ["Beginning of Subprogram" fortran-beginning-of-subprogram :active t
+ :help "Move point to the start of the current subprogram"]
+ ["End of Subprogram" fortran-end-of-subprogram :active t
+ :help "Move point to the end of the current subprogram"]
+ ("Mark"
+ :help "Mark a region of code"
+ ["Subprogram" mark-defun t]
+ ["IF Block" fortran-mark-if t]
+ ["DO Block" fortran-mark-do t]
+ )
+ ["Narrow to Subprogram" narrow-to-defun t]
+ ["Widen" widen t]
+ "--"
+ ["Temporary Column Ruler" fortran-column-ruler :active t
+ :help "Briefly display Fortran column numbers"]
+ ;; May not be '72', depending on fortran-line-length, but this
+ ;; seems ok for a menu item.
+ ["72-column Window" fortran-window-create :active t
+ :help "Set window width to Fortran line length"]
+ ["Full Width Window"
+ (enlarge-window-horizontally (- (frame-width) (window-width)))
+ :active (not (window-full-width-p))
+ :help "Make window full width"]
+ ["Momentary 72-Column Window" fortran-window-create-momentarily
+ :active t :help "Briefly set window width to Fortran line length"]
+ "--"
+ ["Break Line at Point" fortran-split-line :active t
+ :help "Break the current line at point"]
+ ["Join Line" fortran-join-line :active t
+ :help "Join the current line to the previous one"]
+ ["Fill Statement/Comment" fill-paragraph t]
+ "--"
+ ["Toggle Auto Fill" auto-fill-mode :selected auto-fill-function
+ :style toggle
+ :help "Automatically fill text while typing in this buffer"]
+ ["Toggle Abbrev Mode" abbrev-mode :selected abbrev-mode
+ :style toggle :help "Expand abbreviations while typing in this buffer"]
+ ["Add Imenu Menu" imenu-add-menubar-index
+ :active (not (lookup-key (current-local-map) [menu-bar index]))
+ :included (fboundp 'imenu-add-to-menubar)
+ :help "Add an index menu to the menu-bar"]))
+
(provide 'fortran)
;;; fortran.el ends here
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index 80c3e78..462ea51 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -473,7 +473,7 @@ buffer `default-directory'."
(1 (if (eq (char-after (match-beginning 1)) ?\0)
`(face nil display ,(match-string 2)))))
;; Hide excessive part of rgrep command
- ("^find \\(\\. -type d .*\\(?:\\\\)\\|\")\"\\)\\)"
+ ("^find \\(\\(?:-H \\)?\\. -type d .*\\(?:\\\\)\\|\")\"\\)\\)"
(1 (if grep-find-abbreviate grep-find-abbreviate-properties
'(face nil abbreviated-command t))))
;; Hide excessive part of lgrep command
@@ -774,25 +774,24 @@ The value depends on `grep-command', `grep-template',
(let ((gcmd (format "%s <C> %s <R>"
grep-program grep-options))
(null (if grep-use-null-device
- (format "%s " (null-device))
- "")))
- (cond ((eq grep-find-use-xargs 'gnu)
- (format "%s <D> <X> -type f <F> -print0 | \"%s\" -0 %s"
- find-program xargs-program gcmd))
- ((eq grep-find-use-xargs 'gnu-sort)
- (format "%s <D> <X> -type f <F> -print0 | sort -z |
\"%s\" -0 %s"
- find-program xargs-program gcmd))
- ((eq grep-find-use-xargs 'exec)
- (format "%s <D> <X> -type f <F> -exec %s %s %s%s"
- find-program gcmd quot-braces null
quot-scolon))
- ((eq grep-find-use-xargs 'exec-plus)
- (format "%s <D> <X> -type f <F> -exec %s %s%s +"
- find-program gcmd null quot-braces))
- (t
- (format "%s <D> <X> -type f <F> -print | \"%s\" %s"
- find-program xargs-program gcmd))))))))
-
- ;; Save defaults for this host.
+ (format "%s " (null-device))
+ "")))
+ (cond ((eq grep-find-use-xargs 'gnu)
+ (format "%s -H <D> <X> -type f <F> -print0 | \"%s\"
-0 %s"
+ find-program xargs-program gcmd))
+ ((eq grep-find-use-xargs 'gnu-sort)
+ (format "%s -H <D> <X> -type f <F> -print0 | sort -z
| \"%s\" -0 %s"
+ find-program xargs-program gcmd))
+ ((eq grep-find-use-xargs 'exec)
+ (format "%s -H <D> <X> -type f <F> -exec %s %s %s%s"
+ find-program gcmd quot-braces null
quot-scolon))
+ ((eq grep-find-use-xargs 'exec-plus)
+ (format "%s -H <D> <X> -type f <F> -exec %s %s%s +"
+ find-program gcmd null quot-braces))
+ (t
+ (format "%s -H <D> <X> -type f <F> -print | \"%s\" %s"
+ find-program xargs-program gcmd))))))))
+ ;; Save defaults for this host.
(setq grep-host-defaults-alist
(delete (assq host-id grep-host-defaults-alist)
grep-host-defaults-alist))
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index 0d9b4b7..d127575 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -55,10 +55,10 @@
;; Use M-x hide-ifdef-undef (C-c @ u) to undefine a symbol.
;;
;; If you define or undefine a symbol while hide-ifdef-mode is in effect,
-;; the display will be updated. Only the define list for the current
-;; buffer will be affected. You can save changes to the local define
-;; list with hide-ifdef-set-define-alist. This adds entries
-;; to hide-ifdef-define-alist.
+;; the display will be updated. The global define list hide-ifdef-env
+;; is affected accordingly. You can save changes to this globally define
+;; list with hide-ifdef-set-define-alist. This adds entries to
+;; hide-ifdef-define-alist.
;;
;; If you have defined a hide-ifdef-mode-hook, you can set
;; up a list of symbols that may be used by hide-ifdefs as in the
@@ -68,10 +68,19 @@
;; (lambda ()
;; (unless hide-ifdef-define-alist
;; (setq hide-ifdef-define-alist
-;; '((list1 ONE TWO)
-;; (list2 TWO THREE))))
+;; '((list1 (ONE . 1) (TWO . 2))
+;; (list2 (TWO . 2) (THREE . 3)))))
;; (hide-ifdef-use-define-alist 'list2))) ; use list2 by default
;;
+;; Currently recursive #include is not yet supported, a quick and reliable
+;; way is to let the compiler generates all the #include-d defined macros
+;; into a file, then open it in Emacs with hide-ifdefs (C-c @ h).
+;; Take gcc and hello.c for example, hello.c #include-s <stdio.h>:
+;;
+;; $ gcc -dM -E hello.c -o hello.hh
+;;
+;; Then, open hello.hh and perform hide-ifdefs.
+;;
;; You can call hide-ifdef-use-define-alist (C-c @ U) at any time to specify
;; another list to use.
;;
@@ -99,7 +108,11 @@
;; Extensively modified by Daniel LaLiberte (while at Gould).
;;
;; Extensively modified by Luke Lee in 2013 to support complete C expression
-;; evaluation and argumented macro expansion.
+;; evaluation and argumented macro expansion; C++11, C++14, C++17, GCC
+;; extension literals and gcc/clang matching behaviours are supported in 2021.
+;; Various floating point types and operations are also supported but the
+;; actual precision is limited by the Emacs internal floating representation,
+;; which is the C data type "double" or IEEE binary64 format.
;;; Code:
@@ -136,7 +149,10 @@
:type '(choice (const nil) string)
:version "25.1")
-(defcustom hide-ifdef-expand-reinclusion-protection t
+(define-obsolete-variable-alias 'hide-ifdef-expand-reinclusion-protection
+ 'hide-ifdef-expand-reinclusion-guard "28.1")
+
+(defcustom hide-ifdef-expand-reinclusion-guard t
"Non-nil means don't hide an entire header file enclosed by #ifndef...#endif.
Most C/C++ headers are usually wrapped with ifdefs to prevent re-inclusion:
@@ -161,7 +177,7 @@ outermost #if is always visible."
(defcustom hide-ifdef-header-regexp
"\\.h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\'"
"C/C++ header file name patterns to determine if current buffer is a header.
-Effective only if `hide-ifdef-expand-reinclusion-protection' is t."
+Effective only if `hide-ifdef-expand-reinclusion-guard' is t."
:type 'regexp
:version "25.1")
@@ -195,6 +211,21 @@ Effective only if
`hide-ifdef-expand-reinclusion-protection' is t."
:type 'key-sequence
:version "27.1")
+(defcustom hide-ifdef-verbose nil
+ "Show some defining symbols on hiding for a visible feedback."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom hide-ifdef-evalulate-enter-hook nil
+ "Hook function to be called when entering `hif-evaluate-macro'."
+ :type 'hook
+ :version "28.1")
+
+(defcustom hide-ifdef-evalulate-leave-hook nil
+ "Hook function to be called when leaving `hif-evaluate-macro'."
+ :type 'hook
+ :version "28.1")
+
(defvar hide-ifdef-mode-map
;; Set up the mode's main map, which leads via the prefix key to the submap.
(let ((map (make-sparse-keymap)))
@@ -306,9 +337,9 @@ Several variables affect how the hiding is done:
;; (default-value 'hide-ifdef-env))
(setq hide-ifdef-env (default-value 'hide-ifdef-env))
;; Some C/C++ headers might have other ways to prevent reinclusion and
- ;; thus would like `hide-ifdef-expand-reinclusion-protection' to be
nil.
- (setq-local hide-ifdef-expand-reinclusion-protection
- (default-value 'hide-ifdef-expand-reinclusion-protection))
+ ;; thus would like `hide-ifdef-expand-reinclusion-guard' to be nil.
+ (setq-local hide-ifdef-expand-reinclusion-guard
+ (default-value 'hide-ifdef-expand-reinclusion-guard))
(setq-local hide-ifdef-hiding
(default-value 'hide-ifdef-hiding))
(setq-local hif-outside-read-only buffer-read-only)
@@ -330,23 +361,42 @@ Several variables affect how the hiding is done:
(defun hif-clear-all-ifdef-defined ()
"Clears all symbols defined in `hide-ifdef-env'.
It will backup this variable to `hide-ifdef-env-backup' before clearing to
-prevent accidental clearance."
+prevent accidental clearance.
+When prefixed, it swaps current symbols with the backup ones."
(interactive)
- (when (y-or-n-p "Clear all #defined symbols? ")
- (setq hide-ifdef-env-backup hide-ifdef-env)
- (setq hide-ifdef-env nil)))
-
-(defun hif-show-all ()
- "Show all of the text in the current buffer."
- (interactive)
- (hif-show-ifdef-region (point-min) (point-max)))
+ (if current-prefix-arg
+ (if hide-ifdef-env-backup
+ (when (y-or-n-p (format
+ "Restore all %d #defined symbols just cleared? "
+ (length hide-ifdef-env-backup)))
+ (let ((tmp hide-ifdef-env-backup))
+ (setq hide-ifdef-env hide-ifdef-env-backup)
+ (setq hide-ifdef-env-backup tmp))
+ (message "Backup symbols restored."))
+ (message "No backup symbol to restore."))
+ (when (y-or-n-p (format "Clear all %d #defined symbols? "
+ (length hide-ifdef-env)))
+ (if hide-ifdef-env ;; backup only if not empty
+ (setq hide-ifdef-env-backup hide-ifdef-env))
+ (setq hide-ifdef-env nil)
+ (message "All defined symbols cleared." ))))
+
+(defun hif-show-all (&optional start end)
+ "Show all of the text in the current buffer.
+If there is a marked region from START to END it only shows the symbols
within."
+ (interactive
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+ (hif-show-ifdef-region
+ (or start (point-min)) (or end (point-max))))
;; By putting this on after-revert-hook, we arrange that it only
;; does anything when revert-buffer avoids turning off the mode.
;; (That can happen in VC.)
(defun hif-after-revert-function ()
(and hide-ifdef-mode hide-ifdef-hiding
- (hide-ifdefs t)))
+ (hide-ifdefs nil nil t)))
(add-hook 'after-revert-hook 'hif-after-revert-function)
(defun hif-end-of-line ()
@@ -427,9 +477,17 @@ Everything including these lines is made invisible."
;;===%%SF%% evaluation (Start) ===
+(defun hif-eval (form)
+ "Evaluate hideif internal representation."
+ (let ((val (eval form)))
+ (if (stringp val)
+ (or (get-text-property 0 'hif-value val)
+ val)
+ val)))
+
;; It is not useful to set this to anything but `eval'.
;; In fact, the variable might as well be eliminated.
-(defvar hide-ifdef-evaluator 'eval
+(defvar hide-ifdef-evaluator #'hif-eval
"The function to use to evaluate a form.
The evaluator is given a canonical form and returns t if text under
that form should be displayed.")
@@ -442,23 +500,42 @@ that form should be displayed.")
"Prepend (VAR VALUE) pair to `hide-ifdef-env'."
(setq hide-ifdef-env (cons (cons var value) hide-ifdef-env)))
+(defconst hif-predefine-alist
+ '((__LINE__ . hif-__LINE__)
+ (__FILE__ . hif-__FILE__)
+ (__COUNTER__ . hif-__COUNTER__)
+ (__cplusplus . hif-__cplusplus)
+ (__DATE__ . hif-__DATE__)
+ (__TIME__ . hif-__TIME__)
+ (__STDC__ . hif-__STDC__)
+ (__STDC_VERSION__ . hif-__STDC_VERSION__)
+ (__STDC_HOST__ . hif-__STDC_HOST__)
+ (__BASE_FILE__ . hif-__FILE__)))
+
(declare-function semantic-c-hideif-lookup "semantic/bovine/c" (var))
(declare-function semantic-c-hideif-defined "semantic/bovine/c" (var))
(defun hif-lookup (var)
(or (when (bound-and-true-p semantic-c-takeover-hideif)
(semantic-c-hideif-lookup var))
- (let ((val (assoc var hide-ifdef-env)))
+ (let ((val (assq var hide-ifdef-env)))
(if val
(cdr val)
- hif-undefined-symbol))))
+ (if (setq val (assq var hif-predefine-alist))
+ (funcall (cdr val))
+ hif-undefined-symbol)))))
(defun hif-defined (var)
- (cond
- ((bound-and-true-p semantic-c-takeover-hideif)
- (semantic-c-hideif-defined var))
- ((assoc var hide-ifdef-env) 1)
- (t 0)))
+ (let (def)
+ (cond
+ ((bound-and-true-p semantic-c-takeover-hideif)
+ (semantic-c-hideif-defined var))
+ ;; Here we can't use hif-lookup as an empty definition like `#define
EMPTY'
+ ;; is considered defined but is evaluated as `nil'.
+ ((assq var hide-ifdef-env) 1)
+ ((and (setq def (assq var hif-predefine-alist))
+ (funcall (cdr def))) 1)
+ (t 0))))
;;===%%SF%% evaluation (End) ===
@@ -484,7 +561,7 @@ that form should be displayed.")
(defconst hif-define-regexp (concat hif-cpp-prefix "\\(define\\|undef\\)"))
(defconst hif-id-regexp (concat "[[:alpha:]_][[:alnum:]_]*"))
(defconst hif-macroref-regexp
- (concat hif-white-regexp "\\(" hif-id-regexp "\\)" hif-white-regexp
+ (concat hif-white-regexp "\\(" hif-id-regexp "\\)"
"\\("
"(" hif-white-regexp
"\\(" hif-id-regexp "\\)?" hif-white-regexp
@@ -493,6 +570,75 @@ that form should be displayed.")
")"
"\\)?" ))
+;; The point here is *NOT* to do "syntax error checking" for C(++) compiler,
but
+;; to parse and recognize *already valid* numeric literals. Therefore we don't
+;; need to worry if number like "0x12'" is invalid, leave it to the compiler.
+;; Otherwise, the runtime performance of hideif would be poor.
+;;
+;; GCC fixed-point literal extension:
+;;
+;; ‘ullk’ or ‘ULLK’ for unsigned long long _Accum and _Sat unsigned long long
_Accum
+;; ‘ullr’ or ‘ULLR’ for unsigned long long _Fract and _Sat unsigned long long
_Fract
+;;
+;; ‘llk’ or ‘LLK’ for long long _Accum and _Sat long long _Accum
+;; ‘llr’ or ‘LLR’ for long long _Fract and _Sat long long _Fract
+;; ‘uhk’ or ‘UHK’ for unsigned short _Accum and _Sat unsigned short _Accum
+;; ‘ulk’ or ‘ULK’ for unsigned long _Accum and _Sat unsigned long _Accum
+;; ‘uhr’ or ‘UHR’ for unsigned short _Fract and _Sat unsigned short _Fract
+;; ‘ulr’ or ‘ULR’ for unsigned long _Fract and _Sat unsigned long _Fract
+;;
+;; ‘lk’ or ‘LK’ for long _Accum and _Sat long _Accum
+;; ‘lr’ or ‘LR’ for long _Fract and _Sat long _Fract
+;; ‘uk’ or ‘UK’ for unsigned _Accum and _Sat unsigned _Accum
+;; ‘ur’ or ‘UR’ for unsigned _Fract and _Sat unsigned _Fract
+;; ‘hk’ or ‘HK’ for short _Accum and _Sat short _Accum
+;; ‘hr’ or ‘HR’ for short _Fract and _Sat short _Fract
+;;
+;; ‘r’ or ‘R’ for _Fract and _Sat _Fract
+;; ‘k’ or ‘K’ for _Accum and _Sat _Accum
+
+;; C++14 also include '0b' for binary and "'" as separator
+(defconst hif-numtype-suffix-regexp
+ ;;
"\\(ll[uU]\\|LL[uU]\\|[uU]?ll\\|[uU]?LL\\|[lL][uU]\\|[uU][lL]\\|[uUlLfF]\\)"
+ (concat
+ "\\(\\(ll[uU]\\|LL[uU]\\|[uU]?ll\\|[uU]?LL\\|[lL][uU]\\|[uU][lL]\\|"
+ "[uU][hH]\\)[kKrR]?\\|" ; GCC fixed-point extension
+ "[dD][dDfFlL]\\|" ; GCC floating-point extension
+ "[uUlLfF]\\)"))
+(defconst hif-bin-regexp
+ (concat "[+-]?0[bB]\\([01']+\\)"
+ hif-numtype-suffix-regexp "?"))
+(defconst hif-hex-regexp
+ (concat "[+-]?0[xX]\\([[:xdigit:]']+\\)"
+ hif-numtype-suffix-regexp "?"))
+(defconst hif-oct-regexp
+ (concat "[+-]?0[0-7']+"
+ hif-numtype-suffix-regexp "?"))
+(defconst hif-dec-regexp
+ (concat "[+-]?\\(0\\|[1-9][0-9']*\\)"
+ hif-numtype-suffix-regexp "?"))
+
+(defconst hif-decfloat-regexp
+ ;; `hif-string-to-decfloat' relies on the number and ordering of parentheses
+ (concat
+ "\\(?:"
+ "\\([+-]?[0-9]+\\)\\([eE][+-]?[0-9]+\\)?[dD]?[fFlL]?"
+ "\\|\\([+-]?[0-9]+\\)\\.\\([eE][+-]?[0-9]+\\)?[dD]?[dDfFlL]?"
+ "\\|\\([+-]?[0-9]*\\.[0-9]+\\)\\([eE][+-]?[0-9]+\\)?[dD]?[dDfFlL]?"
+ "\\)"))
+
+;; C++17 hexadecimal floating point literal
+(defconst hif-hexfloat-regexp
+ ;; `hif-string-to-hexfloat' relies on the ordering of regexp groupings
+ (concat
+ "[+-]?\\(?:"
+ "0[xX]\\([[:xdigit:]']+\\)[pP]\\([+-]?[0-9']+\\)[fFlL]?"
+ "\\|"
+ "0[xX]\\([[:xdigit:]']+\\)\\.[pP]\\([+-]?[0-9']+\\)[fFlL]?"
+ "\\|"
+
"0[xX]\\([[:xdigit:]']*\\)\\.\\([[:xdigit:]']+\\)[pP]\\([+-]?[0-9']+\\)[fFlL]?"
+ "\\)"))
+
;; Store the current token and the whole token list during parsing.
;; Bound dynamically.
(defvar hif-token)
@@ -530,29 +676,113 @@ that form should be displayed.")
(":" . hif-colon)
("," . hif-comma)
("#" . hif-stringify)
- ("..." . hif-etc)))
+ ("..." . hif-etc)
+ ("defined" . hif-defined)))
(defconst hif-valid-token-list (mapcar 'cdr hif-token-alist))
(defconst hif-token-regexp
- (concat (regexp-opt (mapcar 'car hif-token-alist))
- "\\|0x[[:xdigit:]]+\\.?[[:xdigit:]]*"
- "\\|[0-9]+\\.?[0-9]*" ;; decimal/octal
- "\\|\\w+"))
-
-(defconst hif-string-literal-regexp "\\(\"\\(?:[^\"\\]\\|\\\\.\\)*\"\\)")
+ ;; The ordering of regexp grouping is crutial to `hif-strtok'
+ (concat
+ ;; hex/binary:
+
"\\([+-]?0[xXbB]\\([[:xdigit:]']+\\)?\\.?\\([[:xdigit:]']+\\)?\\([pP]\\([+-]?[0-9]+\\)\\)?"
+ hif-numtype-suffix-regexp "?\\)"
+ ;; decimal/octal:
+ "\\|\\(\\([+-]?[0-9']+\\(\\.[0-9']*\\)?\\)\\([eE][+-]?[0-9]+\\)?"
+ hif-numtype-suffix-regexp "?\\)"
+ "\\|" (regexp-opt (mapcar 'car hif-token-alist) t)
+ "\\|\\(\\w+\\)"))
+
+;; C++11 Unicode string literals (L"" u8"" u"" U"" R"" LR"" u8R"" uR"")
+(defconst hif-unicode-prefix-regexp "\\(?:u8R?\\|[uUL]R?\\\|R\\)")
+(defconst hif-string-literal-regexp
+ (concat hif-unicode-prefix-regexp "?"
+ "\\(\"\\(?:[^\"\\]\\|\\\\.\\)*\"\\)"))
+
+;; matching and conversion
+
+(defun hif-full-match (regexp string)
+ "A full REGEXP match of STRING instead of partially match."
+ (string-match (concat "\\`" regexp "\\'") string))
+
+(defun hif-is-number (string)
+ "Check if STRING is a valid C(++) numeric literal."
+ (or (hif-full-match hif-dec-regexp string)
+ (hif-full-match hif-hex-regexp string)
+ (hif-full-match hif-oct-regexp string)
+ (hif-full-match hif-bin-regexp string)))
+
+(defun hif-is-float (string)
+ "Check if STRING is a valid C(++) floating point literal."
+ (or (hif-full-match hif-decfloat-regexp string)
+ (hif-full-match hif-hexfloat-regexp string)))
+
+(defun hif-delete-char-in-string (char string)
+ "Delete CHAR in STRING inplace."
+ (let ((i (length string))
+ (s nil))
+ (while (> i 0)
+ (setq i (1- i))
+ (unless (eq (aref string i) char)
+ (setq s (cons (aref string i) s))))
+ (concat s)))
+
+(defun hif-string-to-decfloat (string &optional fix exp)
+ "Convert a C(++) decimal floating formatted string into float.
+Assuming we've just regexp-matched with `hif-decfloat-regexp' and it matched.
+if REMATCH is t, do a rematch."
+ ;; In elisp `(string-to-number "01.e2")' will return 1 instead of the
expected
+ ;; 100.0; therefore we need to write our own.
+ ;; This function relies on the regexp groups of `hif-dexfloat-regexp'
+ (if (or fix exp)
+ (setq fix (hif-delete-char-in-string ?' fix)
+ exp (hif-delete-char-in-string ?' exp))
+ ;; rematch
+ (setq string (hif-delete-char-in-string ?' string))
+ (hif-full-match hif-decfloat-regexp string)
+ (setq fix (or (match-string 1 string)
+ (match-string 3 string)
+ (match-string 5 string))
+ exp (or (match-string 2 string)
+ (match-string 4 string)
+ (match-string 6 string))))
+ (setq fix (string-to-number fix)
+ exp (if (zerop (length exp)) ;; nil or ""
+ 0 (string-to-number (substring-no-properties exp 1))))
+ (* fix (expt 10 exp)))
+
+(defun hif-string-to-hexfloat (string &optional int fra exp)
+ "Convert a C++17 hex float formatted string into float.
+Assuming we've just regexp-matched with `hif-hexfloat-regexp' and it matched.
+if REMATCH is t, do a rematch."
+ ;; This function relies on the regexp groups of `hif-hexfloat-regexp'
+ (let ((negate (if (eq ?- (aref string 0)) -1.0 1.0)))
+ (if (or int fra exp)
+ (setq int (hif-delete-char-in-string ?' int)
+ fra (hif-delete-char-in-string ?' fra)
+ exp (hif-delete-char-in-string ?' exp))
+ (setq string (hif-delete-char-in-string ?' string))
+ (hif-full-match hif-hexfloat-regexp string)
+ (setq int (or (match-string 1 string)
+ (match-string 3 string)
+ (match-string 5 string))
+ fra (or (match-string 2 string)
+ (match-string 4 string)
+ (match-string 6 string))
+ exp (match-string 7 string)))
+ (setq int (if (zerop (length int)) ;; nil or ""
+ 0 (string-to-number int 16))
+ fra (if (zerop (length fra))
+ 0 (/ (string-to-number fra 16)
+ (expt 16.0 (length fra))))
+ exp (if (zerop (length exp))
+ 0 (string-to-number exp)))
+ (* negate (+ int fra) (expt 2.0 exp))))
(defun hif-string-to-number (string &optional base)
- "Like `string-to-number', but it understands non-decimal floats."
- (if (or (not base) (= base 10))
- (string-to-number string base)
- (let* ((parts (split-string string "\\." t "[ \t]+"))
- (frac (cadr parts))
- (fraclen (length frac))
- (quot (expt (if (zerop fraclen)
- base
- (* base 1.0)) fraclen)))
- (/ (string-to-number (concat (car parts) frac) base) quot))))
+ "Like `string-to-number', but it understands C(++) literals."
+ (setq string (hif-delete-char-in-string ?' string))
+ (string-to-number string base))
;; The dynamic binding variable `hif-simple-token-only' is shared only by
;; `hif-tokenize' and `hif-find-define'. The purpose is to prevent
`hif-tokenize'
@@ -562,52 +792,204 @@ that form should be displayed.")
;; Check the long comments before `hif-find-define' for more details. [lukelee]
(defvar hif-simple-token-only)
+(defsubst hif-is-white (c)
+ (memq c '(? ?\t ?\n ?\r)))
+
+(defun hif-strtok (string &optional rematch)
+ "Convert STRING into a hideif mode internal token.
+Assuming we've just performed a `hif-token-regexp' lookup."
+ ;; This function relies on the regexp groups of `hif-token-regexp'
+ ;; New hideif internal number representation: a text string with `hif-value'
+ ;; property to keep its value. Strings without `hif-value' property is a
+ ;; normal C(++) string. This is mainly for stringification. The original
+ ;; implementation only keep the value thus a C++ number like octal 01234
+ ;; will become "668" after being stringified instead of the expected "01234".
+ (let (bufstr m1 m3 m5 m6 m8 neg ch val dec)
+ (when rematch
+ (string-match hif-token-regexp string)
+ (setq bufstr string))
+
+ (cond
+
+ ;; decimal/octal
+ ((match-string 8 bufstr)
+ (setq m6 (match-string 9 bufstr))
+ (setq val
+ (if (or (setq m8 (match-string 11 bufstr))
+ (match-string 10 bufstr)) ;; floating
+ ;; TODO: do we need to add 'hif-type property for
+ ;; type-checking, but this will slow things down
+ (hif-string-to-decfloat string m6 m8)
+ (setq ch (aref string 0))
+ (hif-string-to-number
+ string
+ ;; octal begin with `0'
+ (if (and (> (length string) 1)
+ (or (eq ch ?0)
+ ;; -0... or +0...
+ (and (memq ch '(?- ?+))
+ (eq (aref string 1) ?0))))
+ 8 (setq dec 10)))))
+ ;; Decimal integer without sign and extension is identical to its
+ ;; string form, make it as simple as possible
+ (if (and dec
+ (null (match-string 12 bufstr)) ;; no extension like 'UL'
+ (not (memq ch '(?- ?+))))
+ val
+ (add-text-properties 0 1 (list 'hif-value val) string)
+ string))
+
+ ;; hex/binary
+ ((match-string 1 bufstr)
+ (setq m3 (match-string 3 bufstr))
+ (add-text-properties
+ 0 1
+ (list 'hif-value
+ (if (or (setq m5 (match-string 5 bufstr))
+ m3)
+ (hif-string-to-hexfloat
+ string
+ (match-string 2 bufstr) m3 m5) ;; hexfloat
+ (setq neg (if (eq (aref string 0) ?-) -1 1))
+ (* neg
+ (hif-string-to-number
+ ;; (5-(-1))/2=3; (5-1)/2=2
+ (substring-no-properties string (ash (- 5 neg) -1))
+ ;; (3-(-1))/2=2; (3-1)/2=1
+ (if (or (eq (setq ch (aref string (ash (- 3 neg) -1))) ?x)
+ (eq ch ?X)) ;; hex
+ 16 2)))))
+ string) string)
+
+ ;; operator
+ ((setq m1 (match-string 14 bufstr))
+ (cdr (assoc m1 hif-token-alist #'string-equal)))
+
+ (t
+ (setq hif-simple-token-only nil)
+ (intern-safe string)))))
+
+(defun hif-backward-comment (&optional start end)
+ "If we're currently within a C(++) comment, skip them backwards."
+ ;; Ignore trailing white spaces after comment
+ (setq end (or end (point)))
+ (while (and (> (1- end) 1)
+ (hif-is-white (char-after (1- end))))
+ (cl-decf end))
+ (let ((p0 end)
+ p cmt ce ws we ;; ce:comment start, ws:white start, we whilte end
+ cmtlist) ;; pair of (start.end) of comments
+ (setq start (or start (progn (beginning-of-line) (point)))
+ p start)
+ (while (< (1+ p) end)
+ (if (char-equal ?/ (char-after p)) ; /
+ (if (char-equal ?/ (char-after (1+ p))) ; //
+ (progn
+ ;; merge whites immediately ahead
+ (setq ce (if (and we (= (1- p) we)) ws p))
+ ;; scan for end of line
+ (while (and (< (cl-incf p) end)
+ (not (char-equal ?\n (char-after p)))
+ (not (char-equal ?\r (char-after p)))))
+ ;; Merge with previous comment if immediately followed
+ (push (cons (if (and cmtlist
+ (= (cdr (car cmtlist)) ce))
+ (car (pop cmtlist)) ;; extend previous comment
+ ce)
+ p)
+ cmtlist))
+ (when (char-equal ?* (char-after (1+ p))) ; /*
+ ;; merge whites immediately ahead
+ (setq ce (if (and we (= (1- p) we)) ws p))
+ ;; Check if it immediately follows previous /*...*/ comment;
+ ;; if yes, extend and merge into previous comment
+ (setq cmt (if (and cmtlist
+ (= (cdr (car cmtlist)) ce))
+ (car (pop cmtlist)) ;; extend previous comment
+ ce))
+ (setq p (+ 2 p))
+ ;; Scanning for `*/'
+ (catch 'break
+ (while (< (1+ p) end)
+ (if (not (and (char-equal ?* (char-after p))
+ (char-equal ?/ (char-after (1+ p)))))
+ (cl-incf p)
+ ;; found `*/', mark end pos
+ (push (cons cmt (1+ (setq p (1+ p)))) cmtlist)
+ (throw 'break nil)))
+ ;; (1+ p) >= end
+ (push (cons cmt end) cmtlist))))
+ ;; Trace most recent continuous white spaces before a comment
+ (if (char-equal ? (char-after p))
+ (if (and ws (= we (1- p))) ;; continued
+ (setq we p)
+ (setq ws p
+ we p))
+ (setq ws nil
+ we nil)))
+ (cl-incf p))
+ ;; Goto beginning of the last comment, if we're within
+ (setq cmt (car cmtlist)) ;; last cmt
+ (setq cmt (if (and cmt
+ (>= p0 (car cmt))
+ (<= p0 (cdr cmt)))
+ (car cmt) ;; beginning of the last comment
+ p0))
+ ;; Ignore leading whites ahead of comment
+ (while (and (> (1- cmt) 1)
+ (hif-is-white (char-after (1- cmt))))
+ (cl-decf cmt))
+ (goto-char cmt)))
+
(defun hif-tokenize (start end)
"Separate string between START and END into a list of tokens."
- (let ((token-list nil))
+ (let ((token-list nil)
+ (white-regexp "[ \t]+")
+ token)
(setq hif-simple-token-only t)
(with-syntax-table hide-ifdef-syntax-table
(save-excursion
- (goto-char start)
- (while (progn (forward-comment (point-max)) (< (point) end))
- ;; (message "expr-start = %d" expr-start) (sit-for 1)
- (cond
- ((looking-at "\\\\\n")
- (forward-char 2))
-
- ((looking-at hif-string-literal-regexp)
- (push (substring-no-properties (match-string 1)) token-list)
- (goto-char (match-end 0)))
-
- ((looking-at hif-token-regexp)
- (let ((token (buffer-substring-no-properties
- (point) (match-end 0))))
+ (save-restriction
+ ;; Narrow down to the focusing region so that the ending white spaces
+ ;; of that line will not be treated as a white, as `looking-at' won't
+ ;; look outside the restriction; otherwise it will note the last
token
+ ;; or string as one with an `hif-space' property.
+ (setq end (hif-backward-comment start end))
+ (narrow-to-region start end)
+ (goto-char start)
+ (while (progn (forward-comment (point-max)) (< (point) end))
+ ;; (message "expr-start = %d" expr-start) (sit-for 1)
+ (cond
+ ((looking-at "\\\\\n")
+ (forward-char 2))
+
+ ((looking-at hif-string-literal-regexp)
+ (setq token (substring-no-properties (match-string 1)))
+ (goto-char (match-end 0))
+ (when (looking-at white-regexp)
+ (add-text-properties 0 1 '(hif-space t) token)
+ (goto-char (match-end 0)))
+ (push token token-list))
+
+ ((looking-at hif-token-regexp)
(goto-char (match-end 0))
- ;; (message "token: %s" token) (sit-for 1)
- (push
- (or (cdr (assoc token hif-token-alist))
- (if (string-equal token "defined") 'hif-defined)
- ;; TODO:
- ;; 1. postfix 'l', 'll', 'ul' and 'ull'
- ;; 2. floating number formats (like 1.23e4)
- ;; 3. 098 is interpreted as octal conversion error
- (if (string-match "0x\\([[:xdigit:]]+\\.?[[:xdigit:]]*\\)"
- token)
- (hif-string-to-number (match-string 1 token) 16)) ;; hex
- (if (string-match "\\`0[0-9]+\\(\\.[0-9]+\\)?\\'" token)
- (hif-string-to-number token 8)) ;; octal
- (if (string-match "\\`[1-9][0-9]*\\(\\.[0-9]+\\)?\\'"
- token)
- (string-to-number token)) ;; decimal
- (prog1 (intern token)
- (setq hif-simple-token-only nil)))
- token-list)))
-
- ((looking-at "\r") ; Sometimes MS-Windows user will leave CR in
- (forward-char 1)) ; the source code. Let's not get stuck here.
- (t (error "Bad #if expression: %s" (buffer-string)))))))
-
- (nreverse token-list)))
+ (setq token (hif-strtok
+ (substring-no-properties (match-string 0))))
+ (push token token-list)
+ (when (looking-at white-regexp)
+ ;; We can't just append a space to the token string, otherwise
+ ;; `0xf0 ' ## `01' will become `0xf0 01' instead of the
expected
+ ;; `0xf001', hence a standalone `hif-space' is placed instead.
+ (push 'hif-space token-list)
+ (goto-char (match-end 0))))
+
+ ((looking-at "\r") ; Sometimes MS-Windows user will leave CR in
+ (forward-char 1)) ; the source code. Let's not get stuck here.
+
+ (t (error "Bad #if expression: %s" (buffer-string)))))))
+ (if (eq 'hif-space (car token-list))
+ (setq token-list (cdr token-list))) ;; remove trailing white space
+ (nreverse token-list))))
;;------------------------------------------------------------------------
;; Translate C preprocessor #if expressions using recursive descent.
@@ -637,50 +1019,96 @@ that form should be displayed.")
;; | | ^= = | |
;; | Comma | , | left-to-right |
-(defsubst hif-nexttoken ()
+(defun hif-nexttoken (&optional keep-space)
"Pop the next token from token-list into the let variable `hif-token'."
- (setq hif-token (pop hif-token-list)))
+ (let ((prevtoken hif-token))
+ (while (progn
+ (setq hif-token (pop hif-token-list))
+ (if keep-space ; keep only one space
+ (and (eq prevtoken 'hif-space)
+ (eq hif-token 'hif-space))
+ (eq hif-token 'hif-space)))))
+ hif-token)
+
+(defun hif-split-signed-token ()
+ "Split current numeric token into two (hif-plus/minus num)."
+ (let* (val ch0 head)
+ (when (and (stringp hif-token)
+ (setq val (get-text-property 0 'hif-value hif-token))
+ ;; explicitly signed?
+ (memq (setq ch0 (aref hif-token 0)) '(?+ ?-)))
+ (if (eq ch0 ?+)
+ (setq head 'hif-plus)
+ (setq head 'hif-minus
+ val (- val)))
+ (setq hif-token (substring hif-token 1))
+ (add-text-properties 0 1 (list 'hif-value val) hif-token)
+ (push hif-token hif-token-list)
+ (setq hif-token head))))
(defsubst hif-if-valid-identifier-p (id)
(not (or (numberp id)
- (stringp id))))
+ (stringp id)
+ (and (atom id)
+ (eq 'defined id)))))
(defun hif-define-operator (tokens)
"\"Upgrade\" hif-define XXX to `(hif-define XXX)' so it won't be
substituted."
- (let ((result nil)
- (tok nil))
- (while (setq tok (pop tokens))
- (push
- (if (eq tok 'hif-defined)
- (progn
- (setq tok (cadr tokens))
- (if (eq (car tokens) 'hif-lparen)
- (if (and (hif-if-valid-identifier-p tok)
- (eq (nth 2 tokens) 'hif-rparen))
- (setq tokens (cl-cdddr tokens))
- (error "#define followed by non-identifier: %S" tok))
- (setq tok (car tokens)
- tokens (cdr tokens))
- (unless (hif-if-valid-identifier-p tok)
- (error "#define followed by non-identifier: %S" tok)))
- (list 'hif-defined 'hif-lparen tok 'hif-rparen))
- tok)
- result))
- (nreverse result)))
+ (if (memq 'hif-defined tokens)
+ (let* ((hif-token-list tokens)
+ hif-token
+ target
+ paren)
+ (setq tokens nil) ;; now it becomes the result
+ (while (hif-nexttoken t) ;; keep `hif-space'
+ (when (eq hif-token 'hif-defined)
+ ;; defined XXX, start ignoring `hif-space'
+ (hif-nexttoken)
+ (if (setq paren (eq hif-token 'hif-lparen))
+ (hif-nexttoken))
+ (if (not (hif-if-valid-identifier-p
+ (setq target hif-token)))
+ (error "`defined' followed by non-identifier: %S" target))
+ (if (and paren
+ (not (eq (hif-nexttoken) 'hif-rparen)))
+ (error "missing right parenthesis for `defined'"))
+ (setq hif-token
+ (list 'hif-defined 'hif-lparen target 'hif-rparen)))
+ (push hif-token tokens))
+ (nreverse tokens))
+ tokens))
(define-obsolete-function-alias 'hif-flatten #'flatten-tree "27.1")
-(defun hif-expand-token-list (tokens &optional macroname expand_list)
+(defun hif-keep-single (l e)
+ "Prevent two or more consecutive E in list L."
+ (if (memq e l)
+ (let (prev curr result)
+ (while (progn
+ (setq prev curr
+ curr (car l)
+ l (cdr l))
+ curr)
+ (unless (and (eq prev e)
+ (eq curr e))
+ (push curr result)))
+ (nreverse result))
+ l))
+
+(defun hif-expand-token-list (tokens &optional macroname expand_list level)
"Perform expansion on TOKENS till everything expanded.
Self-reference (directly or indirectly) tokens are not expanded.
EXPAND_LIST is the list of macro names currently being expanded, used for
-detecting self-reference."
+detecting self-reference.
+Function-like macros with calling depth LEVEL 0 does not expand arguments,
+this is to emulate the stringification behavior of C++ preprocessor."
(catch 'self-referencing
(let ((expanded nil)
(remains (hif-define-operator
(hif-token-concatenation
(hif-token-stringification tokens))))
tok rep)
+ (setq level (if level level 0))
(if macroname
(setq expand_list (cons macroname expand_list)))
;; Expanding all tokens till list exhausted
@@ -699,21 +1127,31 @@ detecting self-reference."
(if (and (listp rep)
(eq (car rep) 'hif-define-macro)) ; A defined macro
;; Recursively expand it
+ ;; only in defined macro do we increase the nesting LEVEL
(if (cadr rep) ; Argument list is not nil
- (if (not (eq (car remains) 'hif-lparen))
+ (if (not (or (eq (car remains) 'hif-lparen)
+ ;; hif-space hif-lparen
+ (and (eq (car remains) 'hif-space)
+ (eq (cadr remains) 'hif-lparen)
+ (setq remains (cdr remains)))))
;; No argument, no invocation
tok
;; Argumented macro, get arguments and invoke it.
- ;; Dynamically bind hif-token-list and hif-token
- ;; for hif-macro-supply-arguments
+ ;; Dynamically bind `hif-token-list' and `hif-token'
+ ;; for `hif-macro-supply-arguments'
(let* ((hif-token-list (cdr remains))
(hif-token nil)
- (parmlist (mapcar #'hif-expand-token-list
- (hif-get-argument-list)))
+ (parmlist
+ (if (zerop level)
+ (hif-get-argument-list t)
+ (mapcar (lambda (a)
+ (hif-expand-token-list
+ a nil nil (1+ level)))
+ (hif-get-argument-list t))))
(result
(hif-expand-token-list
(hif-macro-supply-arguments tok parmlist)
- tok expand_list)))
+ tok expand_list (1+ level))))
(setq remains (cons hif-token hif-token-list))
result))
;; Argument list is nil, direct expansion
@@ -745,16 +1183,20 @@ detecting self-reference."
"Parse the TOKEN-LIST.
Return translated list in prefix form. MACRONAME is applied when invoking
macros to prevent self-reference."
- (let ((hif-token-list (hif-expand-token-list token-list macroname)))
+ (let ((hif-token-list (hif-expand-token-list token-list macroname nil))
+ (hif-token nil))
(hif-nexttoken)
(prog1
(and hif-token
(hif-exprlist))
(if hif-token ; is there still a token?
- (error "Error: unexpected token: %s" hif-token)))))
+ (error "Error: unexpected token at line %d: `%s'"
+ (line-number-at-pos)
+ (or (car (rassq hif-token hif-token-alist))
+ hif-token))))))
(defun hif-exprlist ()
- "Parse an exprlist: expr { `,' expr}."
+ "Parse an exprlist: expr { `,' expr }."
(let ((result (hif-expr)))
(if (eq hif-token 'hif-comma)
(let ((temp (list result)))
@@ -824,7 +1266,7 @@ expr : or-expr | or-expr `?' expr `:' expr."
(defun hif-eq-expr ()
"Parse an eq-expr : comp | eq-expr `=='|`!=' comp."
(let ((result (hif-comp-expr))
- (eq-token nil))
+ (eq-token nil))
(while (memq hif-token '(hif-equal hif-notequal))
(setq eq-token hif-token)
(hif-nexttoken)
@@ -857,7 +1299,9 @@ expr : or-expr | or-expr `?' expr `:' expr."
math : muldiv | math `+'|`-' muldiv."
(let ((result (hif-muldiv-expr))
(math-op nil))
- (while (memq hif-token '(hif-plus hif-minus))
+ (while (or (memq hif-token '(hif-plus hif-minus))
+ ;; One token lookahead
+ (hif-split-signed-token))
(setq math-op hif-token)
(hif-nexttoken)
(setq result (list math-op result (hif-muldiv-expr))))
@@ -876,7 +1320,7 @@ expr : or-expr | or-expr `?' expr `:' expr."
(defun hif-factor ()
"Parse a factor.
-factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' |
+factor : `!' factor | `~' factor | `(' exprlist `)' | `defined(' id `)' |
id `(' parmlist `)' | strings | id."
(cond
((eq hif-token 'hif-not)
@@ -908,10 +1352,14 @@ factor : `!' factor | `~' factor | `(' expr `)' |
`defined(' id `)' |
(hif-nexttoken)
`(hif-defined (quote ,ident))))
+ ((stringp hif-token)
+ (if (get-text-property 0 'hif-value hif-token)
+ ;; new hideif internal number format for string concatenation
+ (prog1 hif-token (hif-nexttoken))
+ (hif-string-concatenation)))
+
((numberp hif-token)
(prog1 hif-token (hif-nexttoken)))
- ((stringp hif-token)
- (hif-string-concatenation))
;; Unary plus/minus.
((memq hif-token '(hif-minus hif-plus))
@@ -924,12 +1372,12 @@ factor : `!' factor | `~' factor | `(' expr `)' |
`defined(' id `)' |
(hif-place-macro-invocation ident)
`(hif-lookup (quote ,ident)))))))
-(defun hif-get-argument-list ()
+(defun hif-get-argument-list (&optional keep-space)
(let ((nest 0)
(parmlist nil) ; A "token" list of parameters, will later be parsed
(parm nil))
- (while (or (not (eq (hif-nexttoken) 'hif-rparen))
+ (while (or (not (eq (hif-nexttoken keep-space) 'hif-rparen))
(/= nest 0))
(if (eq (car (last parm)) 'hif-comma)
(setq parm nil))
@@ -945,7 +1393,7 @@ factor : `!' factor | `~' factor | `(' expr `)' |
`defined(' id `)' |
(push hif-token parm))
(push (nreverse parm) parmlist) ; Okay even if PARM is nil
- (hif-nexttoken) ; Drop the `hif-rparen', get next token
+ (hif-nexttoken keep-space) ; Drop the `hif-rparen', get next token
(nreverse parmlist)))
(defun hif-place-macro-invocation (ident)
@@ -973,10 +1421,21 @@ This macro cannot be evaluated alone without parameters
input."
(cond
((numberp a)
(number-to-string a))
- ((atom a)
- (symbol-name a))
((stringp a)
- (concat "\"" a "\""))
+ ;; Remove properties here otherwise a string like "0x12 + 0x34" will be
+ ;; later evaluated as (0x12 + 0x34) and become 0x70.
+ ;; See also `hif-eval' and `hif-mathify'.
+ (concat (substring-no-properties a)
+ (if (get-text-property 0 'hif-space a) " ")))
+ ((atom a)
+ (if (memq a hif-valid-token-list)
+ (car (rassq a hif-token-alist))
+ (if (eq a 'hif-space)
+ " "
+ (symbol-name a))))
+ ((listp a) ;; stringify each element then concat
+ (cl-loop for e in a
+ concat (hif-stringify e)))
(t
(error "Invalid token to stringify"))))
@@ -984,32 +1443,34 @@ This macro cannot be evaluated alone without parameters
input."
(if (stringp str)
(intern str)))
-(defun hif-token-concat (a b)
- "Concatenate two tokens into a longer token.
-Currently support only simple token concatenation. Also support weird (but
-valid) token concatenation like `>' ## `>' becomes `>>'. Here we take care
only
-those that can be evaluated during preprocessing time and ignore all those that
-can only be evaluated at C(++) runtime (like `++', `--' and `+='...)."
- (if (or (memq a hif-valid-token-list)
- (memq b hif-valid-token-list))
- (let* ((ra (car (rassq a hif-token-alist)))
- (rb (car (rassq b hif-token-alist)))
- (result (and ra rb
- (cdr (assoc (concat ra rb) hif-token-alist)))))
- (or result
- ;;(error "Invalid token to concatenate")
- (error "Concatenating \"%s\" and \"%s\" does not give a valid \
-preprocessing token"
- (or ra (symbol-name a))
- (or rb (symbol-name b)))))
- (intern-safe (concat (hif-stringify a)
- (hif-stringify b)))))
+(defun hif-token-concat (l)
+ "Concatenate a list of tokens into a longer token.
+Also support weird (but valid) token concatenation like `>' ## `>' becomes
`>>'.
+Here we take care only those that can be evaluated during preprocessing time
and
+ignore all those that can only be evaluated at C(++) runtime (like `++', `--'
+and `+='...)."
+ (let ((str nil))
+ (dolist (i l)
+ ;;(assert (not (eq i 'hif-space)) nil ;; debug
+ ;; "Internal error: should not be concatenating `hif-space'")
+ (setq str
+ (concat str
+ (if (memq i hif-valid-token-list)
+ (car (rassq i hif-token-alist))
+ (hif-stringify i)))))
+ ;; Check if it's a number, if yes, return the number instead of a symbol.
+ ;; 'hif-value and 'hif-space properties are trimmed off by `hif-stringify'
+ (hif-strtok str t)))
(defun hif-mathify (val)
- "Treat VAL as a number: if it's t or nil, use 1 or 0."
- (cond ((eq val t) 1)
- ((null val) 0)
- (t val)))
+ "Treat VAL as a hideif number: if it's t or nil, use 1 or 0."
+ (cond
+ ((stringp val)
+ (or (get-text-property 0 'hif-value val)
+ val))
+ ((eq val t) 1)
+ ((null val) 0)
+ (t val)))
(defun hif-conditional (a b c)
(if (not (zerop (hif-mathify a))) (hif-mathify b) (hif-mathify c)))
@@ -1053,49 +1514,108 @@ preprocessing token"
(defalias 'hif-logxor (hif-mathify-binop logxor))
(defalias 'hif-logand (hif-mathify-binop logand))
+(defun hif-__LINE__ ()
+ (line-number-at-pos))
+
+(defun hif-__FILE__ ()
+ (file-name-nondirectory (buffer-file-name)))
+
+(defvar hif-__COUNTER__ 0)
+(defun hif-__COUNTER__ ()
+ (prog1 hif-__COUNTER__ (cl-incf hif-__COUNTER__)))
+
+(defun hif-__cplusplus ()
+ (and (string-match
+ "\\.c\\(c\\|xx\\|pp\\|\\+\\+\\)\\'"
+ (buffer-file-name))
+ (memq major-mode '(c++-mode cc-mode cpp-mode))
+ 201710))
+
+(defun hif-__DATE__ ()
+ (format-time-string "%Y/%m/%d"))
+
+(defun hif-__TIME__ ()
+ (format-time-string "%H:%M:%S"))
+
+(defun hif-__STDC__ () 1)
+(defun hif-__STDC_VERSION__ () 201710)
+(defun hif-__STDC_HOST__ () 1)
(defun hif-comma (&rest expr)
"Evaluate a list of EXPR, return the result of the last item."
(let ((result nil))
- (dolist (e expr)
+ (dolist (e expr result)
(ignore-errors
- (setq result (funcall hide-ifdef-evaluator e))))
- result))
+ (setq result (funcall hide-ifdef-evaluator e))))))
(defun hif-token-stringification (l)
- "Scan token list for `hif-stringify' ('#') token and stringify the next
token."
- (let (result)
- (while l
- (push (if (eq (car l) 'hif-stringify)
- (prog1
- (if (cadr l)
- (hif-stringify (cadr l))
- (error "No token to stringify"))
- (setq l (cdr l)))
- (car l))
- result)
- (setq l (cdr l)))
- (nreverse result)))
+ "Scan token list for `hif-stringify' (`#') token and stringify the next
token."
+ (if (memq 'hif-stringify l)
+ (let (result)
+ (while l
+ (push (if (eq (car l) 'hif-stringify)
+ (prog1
+ (if (cadr l)
+ (hif-stringify (cadr l))
+ (error "No token to stringify"))
+ (setq l (cdr l)))
+ (car l))
+ result)
+ (setq l (cdr l)))
+ (nreverse result))
+ ;; no `#' presents
+ l))
(defun hif-token-concatenation (l)
- "Scan token list for `hif-token-concat' ('##') token and concatenate two
tokens."
- (let ((prev nil)
- result)
- (while l
- (while (eq (car l) 'hif-token-concat)
- (unless prev
- (error "No token before ## to concatenate"))
- (unless (cdr l)
- (error "No token after ## to concatenate"))
- (setq prev (hif-token-concat prev (cadr l)))
- (setq l (cddr l)))
- (if prev
- (setq result (append result (list prev))))
- (setq prev (car l)
- l (cdr l)))
- (if prev
- (append result (list prev))
- result)))
+ "Scan token list for `hif-token-concat' ('##') token and concatenate tokens."
+ (if (memq 'hif-token-concat l)
+ ;; Notice that after some substitutions, there could be more than
+ ;; one `hif-space' in a list.
+ (let ((items nil)
+ (tk nil)
+ (count 0) ; count of `##'
+ result)
+ (setq l (hif-keep-single l 'hif-space))
+ (while (setq tk (car l))
+ (if (not (eq tk 'hif-token-concat))
+ ;; In reverse order so that we don't have to use `last' or
+ ;; `butlast'
+ (progn
+ (push tk result)
+ (setq l (cdr l)))
+ ;; First `##' met, start `##' sequence
+ ;; We only drop `hif-space' when doing token concatenation
+ (setq items nil
+ count 0)
+ (setq tk (pop result))
+ (if (or (null tk)
+ (and (eq tk 'hif-space)
+ (null (setq tk (pop result)))))
+ (error "No token before `##' to concatenate")
+ (push tk items) ; first item, in reverse order
+ (setq tk 'hif-token-concat))
+ (while (eq tk 'hif-token-concat)
+ (cl-incf count)
+ ;; 2+ item
+ (setq l (cdr l)
+ tk (car l))
+ ;; only one 'hif-space could appear here
+ (if (eq tk 'hif-space) ; ignore it
+ (setq l (cdr l)
+ tk (car l)))
+ (if (or (null tk)
+ (eq tk 'hif-token-concat))
+ (error
+ "No token after the %d-th `##' to concatenate at line %d"
+ count (line-number-at-pos))
+ (push tk items)
+ (setq l (cdr l)
+ tk (car l))))
+ ;; `##' sequence ended, concat them, then push into result
+ (push (hif-token-concat (nreverse items)) result)))
+ (nreverse result))
+ ;; no need to reassemble the list if no `##' presents
+ l))
(defun hif-delimit (lis atom)
(nconc (mapcan (lambda (l) (list l atom))
@@ -1105,7 +1625,7 @@ preprocessing token"
;; Perform token replacement:
(defun hif-macro-supply-arguments (macro-name actual-parms)
"Expand a macro call, replace ACTUAL-PARMS in the macro body."
- (let* ((SA (assoc macro-name hide-ifdef-env))
+ (let* ((SA (assq macro-name hide-ifdef-env))
(macro (and SA
(cdr SA)
(eq (cadr SA) 'hif-define-macro)
@@ -1156,11 +1676,14 @@ preprocessing token"
formal macro-body))
(setq actual-parms (cdr actual-parms)))
- ;; Replacement completed, flatten the whole token list
- (setq macro-body (flatten-tree macro-body))
+ ;; Replacement completed, stringifiy and concatenate the token list.
+ ;; Stringification happens must take place before flattening, otherwise
+ ;; only the first token will be stringified.
+ (setq macro-body
+ (flatten-tree (hif-token-stringification macro-body)))
- ;; Stringification and token concatenation happens here
- (hif-token-concatenation (hif-token-stringification macro-body)))))
+ ;; Token concatenation happens here, keep single 'hif-space
+ (hif-keep-single (hif-token-concatenation macro-body) 'hif-space))))
(defun hif-invoke (macro-name actual-parms)
"Invoke a macro by expanding it, reparse macro-body and finally invoke it."
@@ -1432,7 +1955,7 @@ Point is left unchanged."
;; A bit slimy.
(defun hif-hide-line (point)
- "Hide the line containing point.
+ "Hide the line containing POINT.
Does nothing if `hide-ifdef-lines' is nil."
(when hide-ifdef-lines
(save-excursion
@@ -1441,7 +1964,7 @@ Does nothing if `hide-ifdef-lines' is nil."
(line-beginning-position) (progn (hif-end-of-line) (point))))))
-;; Hif-Possibly-Hide
+;; hif-Possibly-Hide
;; There are four cases. The #ifX expression is "taken" if it
;; the hide-ifdef-evaluator returns T. Presumably, this means the code
;; inside the #ifdef would be included when the program was
@@ -1484,7 +2007,7 @@ Does nothing if `hide-ifdef-lines' is nil."
"Called at #ifX expression, this hides those parts that should be hidden.
It uses the judgment of `hide-ifdef-evaluator'. EXPAND-REINCLUSION is a flag
indicating that we should expand the #ifdef even if it should be hidden.
-Refer to `hide-ifdef-expand-reinclusion-protection' for more details."
+Refer to `hide-ifdef-expand-reinclusion-guard' for more details."
;; (message "hif-possibly-hide") (sit-for 1)
(let* ((case-fold-search nil)
(test (hif-canonicalize hif-ifx-regexp))
@@ -1564,23 +2087,83 @@ Refer to `hide-ifdef-expand-reinclusion-protection' for
more details."
(result (funcall hide-ifdef-evaluator expr)))
result))
+(defun hif-display-macro (name def &optional result)
+ (if (and def
+ (listp def)
+ (eq (car def) 'hif-define-macro))
+ (let ((cdef (concat "#define " name))
+ (parmlist (cadr def))
+ s)
+ (setq def (caddr def))
+ ;; parmlist
+ (when parmlist
+ (setq cdef (concat cdef "("))
+ (while (car parmlist)
+ (setq cdef (concat cdef (symbol-name (car parmlist))
+ (if (cdr parmlist) ","))
+ parmlist (cdr parmlist)))
+ (setq cdef (concat cdef ")")))
+ (setq cdef (concat cdef " "))
+ ;; body
+ (while def
+ (if (listp def)
+ (setq s (car def)
+ def (cdr def))
+ (setq s def
+ def nil))
+ (setq cdef
+ (concat cdef
+ (cond
+ ;;((setq tok (car (rassoc s hif-token-alist)))
+ ;; (concat tok (if (eq s 'hif-comma) " ")))
+ ((symbolp s)
+ (concat (hif-stringify s)
+ (if (eq s 'hif-comma) " ")))
+ ((stringp s)
+ (hif-stringify s))
+ (t ;; (numberp s)
+ (format "%S" s))))))
+ (if (and result
+ ;; eg: "#define RECURSIVE_SYMBOL RECURSIVE_SYMBOL"
+ (not (and (listp result)
+ (eq (car result) 'hif-define-macro))))
+ (setq cdef (concat cdef
+ (if (integerp result)
+ (format "\n=> %S (%#x)" result result)
+ (format "\n=> %S" result)))))
+ (message "%s" cdef))
+ (message "%S <= `%s'" def name)))
+
(defun hif-evaluate-macro (rstart rend)
"Evaluate the macro expansion result for the active region.
-If no region active, find the current #ifdefs and evaluate the result.
+If no region is currently active, find the current #ifdef/#define and evaluate
+the result; otherwise it looks for current word at point.
Currently it supports only math calculations, strings or argumented macros can
-not be expanded."
+not be expanded.
+This function by default ignores parsing error and return `false' on evaluating
+runtime C(++) statements or tokens that normal C(++) preprocessor can't
perform;
+however, when this command is prefixed, it will display the error instead."
(interactive
- (if (use-region-p)
- (list (region-beginning) (region-end))
- '(nil nil)))
- (let ((case-fold-search nil))
+ (if (not (use-region-p))
+ '(nil nil)
+ (list (region-beginning) (region-end))))
+ (run-hooks 'hide-ifdef-evalulate-enter-hook)
+ (let ((case-fold-search nil)
+ (currpnt (point))
+ bounds)
(save-excursion
(unless (use-region-p)
(setq rstart nil rend nil)
(beginning-of-line)
- (when (and (re-search-forward hif-macro-expr-prefix-regexp nil t)
- (string= "define" (match-string 2)))
- (re-search-forward hif-macroref-regexp nil t)))
+ (if (and (re-search-forward hif-macro-expr-prefix-regexp nil t)
+ (= (line-number-at-pos currpnt) (line-number-at-pos)))
+ (if (string= "define" (match-string 2))
+ (re-search-forward hif-macroref-regexp nil t))
+ (goto-char currpnt)
+ (setq bounds (bounds-of-thing-at-point 'word)
+ ;; TODO: BOUNDS need a C++ syntax word boundary finder
+ rstart (car bounds)
+ rend (cdr bounds))))
(let* ((start (or rstart (point)))
(end (or rend (progn (hif-end-of-line) (point))))
(defined nil)
@@ -1588,34 +2171,61 @@ not be expanded."
(tokens (ignore-errors ; Prevent C statement things like
; 'do { ... } while (0)'
(hif-tokenize start end)))
+ ;; Note that on evaluating we can't simply define the symbol
+ ;; even if we are currently at a #define line, as this #define
+ ;; might actually be wrapped up in a #if 0 block. We can only
+ ;; define that explicitly with `hide-ifdef-define'.
(expr (or (and (<= (length tokens) 1) ; Simple token
- (setq defined (assoc (car tokens) hide-ifdef-env))
+ (setq defined
+ (or (assq (car tokens) hide-ifdef-env)
+ (assq (car tokens) hif-predefine-alist)))
(setq simple (atom (hif-lookup (car tokens))))
(hif-lookup (car tokens)))
(and tokens
- (condition-case nil
+ (condition-case err
(hif-parse-exp tokens)
(error
- nil)))))
- (result (funcall hide-ifdef-evaluator expr))
- (exprstring (replace-regexp-in-string
- ;; Trim off leading/trailing whites
- "^[ \t]*\\|[ \t]*$" ""
- (replace-regexp-in-string
- "\\(//.*\\)" "" ; Trim off end-of-line comments
- (buffer-substring-no-properties start end)))))
- (cond
- ((and (<= (length tokens) 1) simple) ; Simple token
- (if defined
- (message "%S <= `%s'" result exprstring)
- (message "`%s' is not defined" exprstring)))
- ((integerp result)
- (if (or (= 0 result) (= 1 result))
- (message "%S <= `%s'" result exprstring)
- (message "%S (%#x) <= `%s'" result result exprstring)))
- ((null result) (message "%S <= `%s'" 'false exprstring))
- ((eq t result) (message "%S <= `%s'" 'true exprstring))
- (t (message "%S <= `%s'" result exprstring)))
+ ;; when prefixed, pass the error on for later
+ ;; `hide-ifdef-evaluator'
+ (if current-prefix-arg err))))))
+ (exprstring (hif-stringify tokens))
+ (result (condition-case err
+ (funcall hide-ifdef-evaluator expr)
+ ;; in case of arithmetic error or others
+ (error (error "Error: line %d %S when evaluating `%s'"
+ (line-number-at-pos) err exprstring)))))
+ (setq
+ result
+ (cond
+ ((= (length tokens) 0)
+ (message "`%s'" exprstring))
+ ((= (length tokens) 1) ; Simple token
+ (if simple
+ (if defined
+ (hif-display-macro exprstring result)
+ (if (and (hif-is-number exprstring)
+ result (numberp result))
+ (message "%S (%#x)" result result)
+ (if (and (hif-is-float exprstring)
+ result (numberp result))
+ (message "%S (%s)" result exprstring)
+ (if (string-match hif-string-literal-regexp exprstring)
+ (message "%s" exprstring)
+ (message "`%s' is not defined" exprstring)))))
+ (if defined
+ (hif-display-macro exprstring (cdr defined) result)
+ (message "`%s' is not defined" exprstring))))
+ ((integerp result)
+ (if (or (= 0 result) (= 1 result))
+ (message "%S <= `%s'" result exprstring)
+ (message "%S (%#x) <= `%s'" result result exprstring)))
+ ((null result)
+ (message "%S <= `%s'" 'false exprstring))
+ ((eq t result)
+ (message "%S <= `%s'" 'true exprstring))
+ (t
+ (message "%S <= `%s'" result exprstring))))
+ (run-hooks 'hide-ifdef-evalulate-leave-hook)
result))))
(defun hif-parse-macro-arglist (str)
@@ -1667,6 +2277,8 @@ first arg will be `hif-etc'."
;; the performance I use this `hif-simple-token-only' to notify my code and
;; save the final [value] into symbol database. [lukelee]
+(defvar hif-verbose-define-count 0)
+
(defun hif-find-define (&optional min max)
"Parse texts and retrieve all defines within the region MIN and MAX."
(interactive)
@@ -1676,8 +2288,11 @@ first arg will be `hif-etc'."
(let* ((defining (string= "define" (match-string 2)))
(name (and (re-search-forward hif-macroref-regexp max t)
(match-string 1)))
- (parmlist (and (match-string 3) ; First arg id found
- (hif-parse-macro-arglist (match-string 2)))))
+ (parmlist (or (and (match-string 3) ; First arg id found
+ (delq 'hif-space
+ (hif-parse-macro-arglist (match-string 2))))
+ (and (match-string 2) ; empty arglist
+ (list nil)))))
(if defining
;; Ignore name (still need to return 't), or define the name
(or (and hide-ifdef-exclude-define-regexp
@@ -1689,6 +2304,14 @@ first arg will be `hif-etc'."
(hif-simple-token-only nil) ; Dynamic binding
(tokens
(and name
+ (prog1 t
+ (cl-incf hif-verbose-define-count)
+ ;; only show 1/50 to not slow down to much
+ (if (and hide-ifdef-verbose
+ (= (% hif-verbose-define-count 50)
1))
+ (message "[Line %d] defining %S"
+ (line-number-at-pos (point))
+ (substring-no-properties name))))
;; `hif-simple-token-only' is set/clear
;; only in this block
(condition-case nil
@@ -1700,8 +2323,10 @@ first arg will be `hif-etc'."
;; this will stop hideif from searching
;; for more #defines.
(setq hif-simple-token-only t)
- (buffer-substring-no-properties
- start end)))))
+ (replace-regexp-in-string
+ "^[ \t]*\\|[ \t]*$" ""
+ (buffer-substring-no-properties
+ start end))))))
;; For simple tokens we save only the parsed result;
;; otherwise we save the tokens and parse it after
;; parameter replacement
@@ -1715,17 +2340,19 @@ first arg will be `hif-etc'."
`(hif-define-macro ,parmlist
,tokens))))
(SA (and name
- (assoc (intern name) hide-ifdef-env))))
+ (assq (intern name) hide-ifdef-env))))
(and name
(if SA
(or (setcdr SA expr) t)
- ;; Lazy evaluation, eval only if hif-lookup find it.
+ ;; Lazy evaluation, eval only if `hif-lookup' find
it.
;; Define it anyway, even if nil it's still in list
;; and therefore considered defined.
(push (cons (intern name) expr) hide-ifdef-env)))))
;; #undef
(and name
- (hif-undefine-symbol (intern name))))))
+ (intern-soft name)
+ (hif-undefine-symbol (intern name)))
+ t)))
t))
@@ -1735,7 +2362,10 @@ first arg will be `hif-etc'."
(save-excursion
(save-restriction
;; (mark-region min max) ;; for debugging
+ (setq hif-verbose-define-count 0)
+ (forward-comment (point-max))
(while (hif-find-define min max)
+ (forward-comment (point-max))
(setf min (point)))
(if max (goto-char max)
(goto-char (point-max))))))
@@ -1745,22 +2375,31 @@ first arg will be `hif-etc'."
It does not do the work that's pointless to redo on a recursive entry."
(save-excursion
(let* ((case-fold-search t) ; Ignore case for `hide-ifdef-header-regexp'
- (expand-header (and hide-ifdef-expand-reinclusion-protection
+ (expand-header (and hide-ifdef-expand-reinclusion-guard
(buffer-file-name)
(string-match hide-ifdef-header-regexp
(buffer-file-name))
(zerop hif-recurse-level)))
(case-fold-search nil)
min max)
+ (setq hif-__COUNTER__ 0)
(goto-char (point-min))
(setf min (point))
- (cl-loop do
- (setf max (hif-find-any-ifX))
- (hif-add-new-defines min max)
- (if max
- (hif-possibly-hide expand-header))
- (setf min (point))
- while max))))
+ ;; Without this `condition-case' it would be easier to see which
+ ;; operation went wrong thru the backtrace `iff' user realize
+ ;; the underlying meaning of all hif-* operation; for example,
+ ;; `hif-shiftleft' refers to C(++) '<<' operator and floating
+ ;; operation arguments would be invalid.
+ (condition-case err
+ (cl-loop do
+ (setf max (hif-find-any-ifX))
+ (hif-add-new-defines min max)
+ (if max
+ (hif-possibly-hide expand-header))
+ (setf min (point))
+ while max)
+ (error (error "Error: failed at line %d %S"
+ (line-number-at-pos) err))))))
;;===%%SF%% hide-ifdef-hiding (End) ===
@@ -1821,13 +2460,17 @@ This allows #ifdef VAR to be hidden."
nil nil t nil "1")))
(list var val)))
(hif-set-var var (or val 1))
- (message "%s set to %s" var (or val 1))
- (sleep-for 1)
- (if hide-ifdef-hiding (hide-ifdefs)))
+ (if hide-ifdef-hiding (hide-ifdefs))
+ (message "%s set to %s" var (or val 1)))
(defun hif-undefine-symbol (var)
- (setq hide-ifdef-env
- (delete (assoc var hide-ifdef-env) hide-ifdef-env)))
+ (when (assq var hide-ifdef-env)
+ (setq hide-ifdef-env
+ (delete (assq var hide-ifdef-env) hide-ifdef-env))
+ ;; We can override things in `hif-predefine-alist' so keep them
+ (unless (assq var hif-predefine-alist)
+ (unintern (symbol-name var) nil))
+ t))
(defun hide-ifdef-undef (start end)
"Undefine a VAR so that #ifdef VAR would not be included."
@@ -1848,35 +2491,54 @@ This allows #ifdef VAR to be hidden."
(if hide-ifdef-hiding (hide-ifdefs))
(message "`%S' undefined" sym))))
-(defun hide-ifdefs (&optional nomsg)
+(defun hide-ifdefs (&optional start end nomsg)
"Hide the contents of some #ifdefs.
Assume that defined symbols have been added to `hide-ifdef-env'.
The text hidden is the text that would not be included by the C
preprocessor if it were given the file with those symbols defined.
With prefix command presents it will also hide the #ifdefs themselves.
+Hiding will only be performed within the marked region if there is one.
+
Turn off hiding by calling `show-ifdefs'."
- (interactive)
- (let ((hide-ifdef-lines current-prefix-arg))
- (or nomsg
- (message "Hiding..."))
- (setq hif-outside-read-only buffer-read-only)
- (unless hide-ifdef-mode (hide-ifdef-mode 1)) ; Turn on hide-ifdef-mode
- (if hide-ifdef-hiding
- (show-ifdefs)) ; Otherwise, deep confusion.
- (setq hide-ifdef-hiding t)
- (hide-ifdef-guts)
- (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only))
- (or nomsg
- (message "Hiding done"))))
-
-
-(defun show-ifdefs ()
+ (interactive
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+
+ (setq current-prefix-arg (or hide-ifdef-lines current-prefix-arg))
+ (save-restriction
+ (let* ((hide-ifdef-lines current-prefix-arg)
+ (outer-hide-ifdef-verbose hide-ifdef-verbose)
+ (hide-ifdef-verbose (and outer-hide-ifdef-verbose
+ (not (or nomsg (use-region-p)))))
+ (hide-start-time (current-time)))
+ (and hide-ifdef-verbose
+ (message "Hiding..."))
+ (setq hif-outside-read-only buffer-read-only)
+ (unless hide-ifdef-mode (hide-ifdef-mode 1)) ; Turn on hide-ifdef-mode
+ (if hide-ifdef-hiding
+ (show-ifdefs)) ; Otherwise, deep confusion.
+ (setq hide-ifdef-hiding t)
+ (narrow-to-region (or start (point-min)) (or end (point-max)))
+ (hide-ifdef-guts)
+ (setq buffer-read-only
+ (or hide-ifdef-read-only hif-outside-read-only))
+ (and hide-ifdef-verbose
+ (message "Hiding done, %.1f seconds elapsed"
+ (float-time (time-subtract (current-time)
+ hide-start-time)))))))
+
+
+(defun show-ifdefs (&optional start end)
"Cancel the effects of `hide-ifdef': show the contents of all #ifdefs."
- (interactive)
+ (interactive
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
(setq buffer-read-only hif-outside-read-only)
- (hif-show-all)
+ (hif-show-all (or start (point-min)) (or end (point-max)))
(setq hide-ifdef-hiding nil))
@@ -1960,21 +2622,17 @@ With optional prefix argument ARG, also hide the
#ifdefs themselves."
;;; definition alist support
+;; The old implementation that match symbol only to 't is now considered
+;; obsolete.
(defvar hide-ifdef-define-alist nil
"A global assoc list of pre-defined symbol lists.")
-(defun hif-compress-define-list (env)
- "Compress the define list ENV into a list of defined symbols only."
- (let ((new-defs nil))
- (dolist (def env new-defs)
- (if (hif-lookup (car def)) (push (car def) new-defs)))))
-
(defun hide-ifdef-set-define-alist (name)
"Set the association for NAME to `hide-ifdef-env'."
(interactive "SSet define list: ")
- (push (cons name (hif-compress-define-list hide-ifdef-env))
- hide-ifdef-define-alist))
+ (push (cons name hide-ifdef-env)
+ hide-ifdef-define-alist))
(defun hide-ifdef-use-define-alist (name)
"Set `hide-ifdef-env' to the define list specified by NAME."
@@ -1986,9 +2644,8 @@ With optional prefix argument ARG, also hide the #ifdefs
themselves."
(if (stringp name) (setq name (intern name)))
(let ((define-list (assoc name hide-ifdef-define-alist)))
(if define-list
- (setq hide-ifdef-env
- (mapcar (lambda (arg) (cons arg t))
- (cdr define-list)))
+ (setq hide-ifdef-env
+ (cdr define-list))
(error "No define list for %s" name))
(if hide-ifdef-hiding (hide-ifdefs))))
diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el
index 5d877fc..aff3066 100644
--- a/lisp/progmodes/octave.el
+++ b/lisp/progmodes/octave.el
@@ -461,7 +461,7 @@ Non-nil means always go to the next Octave code line after
sending."
;; For (invalid) code between switch and case.
;; (if (smie-rule-parent-p "switch") 4)
nil))
- ('(:after . "=") octave-block-offset)))
+ ('(:after . "=") (smie-rule-parent octave-block-offset))))
(defun octave-indent-comment ()
"A function for `smie-indent-functions' (which see)."
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index fd23683..f49ee4c 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -285,7 +285,7 @@
(put-text-property (match-beginning 2) (match-end 2)
'syntax-table (string-to-syntax "\""))
(perl-syntax-propertize-special-constructs end)))))
- ("\\(^\\|[?:.,;=!~({[
\t]\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\(?:\\([^])}>=
\n\t]\\)\\|\\(?3:=\\)[^>]\\)"
+ ("\\(^\\|[?:.,;=|&!~({[
\t]\\|=>\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\(?:\\s-\\|\n\\)*\\(?:\\([^])}>=
\n\t]\\)\\|\\(?3:=\\)[^>]\\)"
;; Nasty cases:
;; /foo/m $a->m $#m $m @m %m
;; \s (appears often in regexps).
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index d307c31..b7a926f 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1464,7 +1464,7 @@ IGNORES is a list of glob patterns for files to ignore."
;; do that reliably enough, without creating false negatives?
(command (xref--rgrep-command (xref--regexp-to-extended regexp)
files
- (file-name-as-directory
+ (directory-file-name
(file-name-unquote
(file-local-name (expand-file-name
dir))))
ignores))
diff --git a/lisp/server.el b/lisp/server.el
index 55af278..5cb5452 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -1608,7 +1608,9 @@ prevent a backup for it.) The variable
`server-temp-file-regexp' controls
which filenames are considered temporary.
If invoked with a prefix argument, or if there is no server process running,
-starts server process and that is all. Invoked by \\[server-edit]."
+starts server process and that is all. Invoked by \\[server-edit].
+
+To abort an edit instead of saying \"Done\", use \\[server-edit-abort]."
(interactive "P")
(cond
((or arg
@@ -1618,6 +1620,17 @@ starts server process and that is all. Invoked by
\\[server-edit]."
(server-clients (apply #'server-switch-buffer (server-done)))
(t (message "No server editing buffers exist"))))
+(defun server-edit-abort ()
+ "Abort editing the current client buffer."
+ (interactive)
+ (if server-clients
+ (mapc (lambda (proc)
+ (server-send-string
+ proc (concat "-error "
+ (server-quote-arg "Aborted by the user"))))
+ server-clients)
+ (message "This buffer has no clients")))
+
(defun server-switch-buffer (&optional next-buffer killed-one filepos
this-frame-only)
"Switch to another buffer, preferably one that has a client.
diff --git a/lisp/shell.el b/lisp/shell.el
index 3098d3a..62de5be 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -321,6 +321,15 @@ Thus, this does not include the shell's current
directory.")
(defvar shell-dirstack-query nil
"Command used by `shell-resync-dirs' to query the shell.")
+(defcustom shell-has-auto-cd nil
+ "If non-nil, `shell-mode' handles implicit \"cd\" commands.
+Implicit \"cd\" is changing the directory if the command is a directory.
+You can make this variable buffer-local to change it, per shell-mode instance.
+Useful for shells like zsh that has this feature."
+ :type 'boolean
+ :group 'shell-directories
+ :version "28.1")
+
(defvar shell-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-f" 'shell-forward-command)
@@ -836,13 +845,15 @@ Environment variables are expanded, see function
`substitute-in-file-name'."
str) ; skip whitespace
(match-end 0)))
(case-fold-search)
- end cmd arg1)
+ end cmd arg1 cmd-subst-fn)
(while (string-match shell-command-regexp str start)
(setq end (match-end 0)
cmd (comint-arguments (substring str start end) 0 0)
arg1 (comint-arguments (substring str start end) 1 1))
(if arg1
(setq arg1 (shell-unquote-argument arg1)))
+ (if shell-has-auto-cd
+ (setq cmd-subst-fn (comint-substitute-in-file-name cmd)))
(cond ((string-match (concat "\\`\\(" shell-popd-regexp
"\\)\\($\\|[ \t]\\)")
cmd)
@@ -859,7 +870,9 @@ Environment variables are expanded, see function
`substitute-in-file-name'."
(string-match (concat "\\`\\(" shell-chdrive-regexp
"\\)\\($\\|[ \t]\\)")
cmd))
- (shell-process-cd (comint-substitute-in-file-name cmd))))
+ (shell-process-cd (comint-substitute-in-file-name cmd)))
+ ((and shell-has-auto-cd (file-directory-p cmd-subst-fn))
+ (shell-process-cd cmd-subst-fn)))
(setq start (progn (string-match shell-command-separator-regexp
str end)
;; skip again
diff --git a/lisp/simple.el b/lisp/simple.el
index 4695a6a..b00918e 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -4217,12 +4217,22 @@ impose the use of a shell (with its need to quote
arguments)."
(shell-command-on-region (point) (point) command
output-buffer nil error-buffer)))))))
+(defun max-mini-window-lines (&optional frame)
+ "Compute maximum number of lines for echo area in FRAME.
+As defined by `max-mini-window-height'. FRAME defaults to the
+selected frame. Result may be a floating-point number,
+i.e. include a fractional number of lines."
+ (cond ((floatp max-mini-window-height) (* (frame-height frame)
+ max-mini-window-height))
+ ((integerp max-mini-window-height) max-mini-window-height)
+ (t 1)))
+
(defun display-message-or-buffer (message &optional buffer-name action frame)
"Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer.
MESSAGE may be either a string or a buffer.
A pop-up buffer is displayed using `display-buffer' if MESSAGE is too long
-for maximum height of the echo area, as defined by `max-mini-window-height'
+for maximum height of the echo area, as defined by `max-mini-window-lines'
if `resize-mini-windows' is non-nil.
Returns either the string shown in the echo area, or when a pop-up
@@ -4261,14 +4271,7 @@ and are used only if a pop-up buffer is displayed."
(cond ((= lines 0))
((and (or (<= lines 1)
(<= lines
- (if resize-mini-windows
- (cond ((floatp max-mini-window-height)
- (* (frame-height)
- max-mini-window-height))
- ((integerp max-mini-window-height)
- max-mini-window-height)
- (t
- 1))
+ (if resize-mini-windows (max-mini-window-lines)
1)))
;; Don't use the echo area if the output buffer is
;; already displayed in the selected frame.
@@ -4334,7 +4337,7 @@ current buffer after START.
Optional fifth arg REPLACE, if non-nil, means to insert the
output in place of text from START to END, putting point and mark
-around it.
+around it. If REPLACE is the symbol `no-mark', don't set the mark.
Optional sixth arg ERROR-BUFFER, if non-nil, specifies a buffer
or buffer name to which to direct the command's standard error
@@ -4409,7 +4412,9 @@ characters."
(let ((swap (and replace (< start end))))
;; Don't muck with mark unless REPLACE says we should.
(goto-char start)
- (and replace (push-mark (point) 'nomsg))
+ (when (and replace
+ (not (eq replace 'no-mark)))
+ (push-mark (point) 'nomsg))
(setq exit-status
(call-shell-region start end command replace
(if error-file
@@ -4420,7 +4425,9 @@ characters."
;; (and shell-buffer (not (eq shell-buffer (current-buffer)))
;; (kill-buffer shell-buffer)))
;; Don't muck with mark unless REPLACE says we should.
- (and replace swap (exchange-point-and-mark)))
+ (when (and replace swap
+ (not (eq replace 'no-mark)))
+ (exchange-point-and-mark)))
;; No prefix argument: put the output in a temp buffer,
;; replacing its entire contents.
(let ((buffer (get-buffer-create
@@ -5735,7 +5742,8 @@ PROMPT is a string to prompt with."
(complete-with-action action completions string pred)))
nil nil nil
(if history-pos
- (cons 'read-from-kill-ring-history (1+ history-pos))
+ (cons 'read-from-kill-ring-history
+ (if (zerop history-pos) history-pos (1+ history-pos)))
'read-from-kill-ring-history)))))
(defcustom yank-from-kill-ring-rotate t
@@ -5773,8 +5781,9 @@ When called from Lisp, insert STRING like
`insert-for-yank' does."
(insert-for-yank string)
(when yank-from-kill-ring-rotate
(let ((pos (seq-position kill-ring string)))
- (when pos
- (setq kill-ring-yank-pointer (nthcdr pos kill-ring)))))
+ (if pos
+ (setq kill-ring-yank-pointer (nthcdr pos kill-ring))
+ (kill-new string))))
(if (consp arg)
;; Swap point and mark like in `yank' and `yank-pop'.
(goto-char (prog1 (mark t)
diff --git a/lisp/so-long.el b/lisp/so-long.el
index f916b61..d765d34 100644
--- a/lisp/so-long.el
+++ b/lisp/so-long.el
@@ -1648,7 +1648,8 @@ invoking the new action."
(when so-long--active
(so-long-revert))
;; Invoke the new action.
- (let ((so-long--calling t))
+ (let ((so-long--calling t)
+ (view-mode-active view-mode))
(so-long--ensure-enabled)
;; ACTION takes precedence if supplied.
(when action
@@ -1677,7 +1678,10 @@ invoking the new action."
;; functions need to modify the buffer. We use `inhibit-read-only' to
;; side-step the issue (and likewise in `so-long-revert').
(let ((inhibit-read-only t))
- (run-hooks 'so-long-hook)))))
+ (run-hooks 'so-long-hook))
+ ;; Restore `view-mode'.
+ (when view-mode-active
+ (view-mode)))))
(defun so-long-revert ()
"Revert the active `so-long-action' and run `so-long-revert-hook'.
diff --git a/lisp/subr.el b/lisp/subr.el
index 78507a5..e49c277 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -195,6 +195,14 @@ buffer-local wherever it is set."
(list 'progn (list 'defvar var val docstring)
(list 'make-variable-buffer-local (list 'quote var))))
+(defun buffer-local-boundp (symbol buffer)
+ "Return non-nil if SYMBOL is bound in BUFFER.
+Also see `local-variable-p'."
+ (condition-case nil
+ (buffer-local-value symbol buffer)
+ (:success t)
+ (void-variable nil)))
+
(defmacro push (newelt place)
"Add NEWELT to the list stored in the generalized variable PLACE.
This is morally equivalent to (setf PLACE (cons NEWELT PLACE)),
@@ -2476,7 +2484,11 @@ file name without extension.
If TYPE is nil, then any kind of definition is acceptable. If
TYPE is `defun', `defvar', or `defface', that specifies function
definition, variable definition, or face definition only.
-Otherwise TYPE is assumed to be a symbol property."
+Otherwise TYPE is assumed to be a symbol property.
+
+This function only works for symbols defined in Lisp files. For
+symbols that are defined in C files, use `help-C-file-name'
+instead."
(if (and (or (null type) (eq type 'defun))
(symbolp symbol)
(autoloadp (symbol-function symbol)))
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index e4521ff..8c6c75e 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -1355,7 +1355,7 @@ This returns an error if any Emacs frames are X frames."
(declare-function x-get-selection-internal "xselect.c"
(selection-symbol target-type &optional time-stamp terminal))
-(add-to-list 'display-format-alist '("\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" . x))
+(add-to-list 'display-format-alist '("\\`.*:[0-9]+\\(\\.[0-9]+\\)?\\'" . x))
(cl-defmethod handle-args-function (args &context (window-system x))
(x-handle-args args))
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index 8d2715f..ba48e5d 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -1263,14 +1263,27 @@ spell-check."
(t
(setq flyspell-word-cache-result nil)
;; Highlight the location as incorrect,
- ;; including offset specified in POSS.
+ ;; including offset specified in POSS
+ ;; and only for the length of the
+ ;; misspelled word specified by POSS.
(if flyspell-highlight-flag
- (flyspell-highlight-incorrect-region
- (if (and (consp poss)
- (integerp (nth 1 poss)))
- (+ start (nth 1 poss) -1)
- start)
- end poss)
+ (let ((hstart start)
+ (hend end)
+ offset misspelled)
+ (when (consp poss)
+ (setq misspelled (car poss)
+ offset (nth 1 poss))
+ (if (integerp offset)
+ (setq hstart (+ start offset -1)))
+ ;; POSS includes the misspelled
+ ;; word; use that to figure out
+ ;; how many characters to highlight.
+ (if (stringp misspelled)
+ (setq hend
+ (+ hstart
+ (length misspelled)))))
+ (flyspell-highlight-incorrect-region
+ hstart hend poss))
(flyspell-notify-misspell word poss))
nil))))
;; return to original location
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 8d7f459..a805c89 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -599,11 +599,13 @@ An alternative value is \" . \", if you use a font with a
narrow period."
;; Citation args.
(list (concat slash citations opt arg) 3 'font-lock-constant-face)
;;
- ;; Text between `` quotes ''.
- (cons (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t)
- "[^'\">{]+" ;a bit pessimistic
- (regexp-opt '("''" "\">" "\"'" ">>" "»") t))
- 'font-lock-string-face)
+ ;; Text between `` quotes ''.
+ (list (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t)
+ "\\(\\(.\\|\n\\)+?\\)"
+ (regexp-opt `("''" "\">" "\"'" ">>" "»") t))
+ '(1 font-lock-keyword-face)
+ '(2 font-lock-string-face)
+ '(4 font-lock-keyword-face))
;;
;; Command names, special and general.
(cons (concat slash specials-1) 'font-lock-warning-face)
diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el
index b9eab95..0cc566f 100644
--- a/lisp/time-stamp.el
+++ b/lisp/time-stamp.el
@@ -462,195 +462,203 @@ and all `time-stamp-format' compatibility."
(let ((fmt-len (length format))
(ind 0)
cur-char
- (prev-char nil)
- (result "")
- field-width
- field-result
- alt-form change-case upcase
- (paren-level 0))
+ (result ""))
(while (< ind fmt-len)
(setq cur-char (aref format ind))
(setq
result
- (concat result
- (cond
- ((eq cur-char ?%)
- ;; eat any additional args to allow for future expansion
- (setq alt-form 0 change-case nil upcase nil field-width "")
- (while (progn
- (setq ind (1+ ind))
- (setq cur-char (if (< ind fmt-len)
- (aref format ind)
- ?\0))
- (or (eq ?. cur-char)
- (eq ?, cur-char) (eq ?: cur-char) (eq ?@ cur-char)
- (eq ?- cur-char) (eq ?+ cur-char) (eq ?_ cur-char)
- (eq ?\s cur-char) (eq ?# cur-char) (eq ?^ cur-char)
- (and (eq ?\( cur-char)
- (not (eq prev-char ?\\))
- (setq paren-level (1+ paren-level)))
- (if (and (eq ?\) cur-char)
+ (concat
+ result
+ (cond
+ ((eq cur-char ?%)
+ (let ((prev-char nil)
+ (field-width "")
+ field-result
+ (alt-form 0)
+ (change-case nil)
+ (upcase nil)
+ (paren-level 0))
+ ;; eat any additional args to allow for future expansion
+ (while (progn
+ (setq ind (1+ ind))
+ (setq cur-char (if (< ind fmt-len)
+ (aref format ind)
+ ?\0))
+ (or (eq ?. cur-char)
+ (eq ?, cur-char) (eq ?: cur-char) (eq ?@ cur-char)
+ (eq ?- cur-char) (eq ?+ cur-char) (eq ?_ cur-char)
+ (eq ?\s cur-char) (eq ?# cur-char) (eq ?^ cur-char)
+ (and (eq ?\( cur-char)
(not (eq prev-char ?\\))
- (> paren-level 0))
- (setq paren-level (1- paren-level))
- (and (> paren-level 0)
- (< ind fmt-len)))
- (if (and (<= ?0 cur-char) (>= ?9 cur-char))
- ;; get format width
- (let ((field-index ind))
- (while (progn
- (setq ind (1+ ind))
- (setq cur-char (if (< ind fmt-len)
- (aref format ind)
- ?\0))
- (and (<= ?0 cur-char) (>= ?9 cur-char))))
- (setq field-width (substring format field-index ind))
- (setq ind (1- ind))
- t))))
- (setq prev-char cur-char)
- ;; some characters we actually use
- (cond ((eq cur-char ?:)
- (setq alt-form (1+ alt-form)))
- ((eq cur-char ?#)
- (setq change-case t))
- ((eq cur-char ?^)
- (setq upcase t))
- ((eq cur-char ?-)
- (setq field-width "1"))
- ((eq cur-char ?_)
- (setq field-width "2"))))
- (setq field-result
- (cond
- ((eq cur-char ?%)
- "%")
- ((eq cur-char ?a) ;day of week
- (if (> alt-form 0)
- (if (string-equal field-width "")
- (time-stamp--format "%A" time)
- "") ;discourage "%:3a"
- (if (or change-case upcase)
- (time-stamp--format "%#a" time)
- (time-stamp--format "%a" time))))
- ((eq cur-char ?A)
- (if (or change-case upcase (not (string-equal field-width "")))
- (time-stamp--format "%#A" time)
- (time-stamp--format "%A" time)))
- ((eq cur-char ?b) ;month name
- (if (> alt-form 0)
- (if (string-equal field-width "")
- (time-stamp--format "%B" time)
- "") ;discourage "%:3b"
- (if (or change-case upcase)
- (time-stamp--format "%#b" time)
- (time-stamp--format "%b" time))))
- ((eq cur-char ?B)
- (if (or change-case upcase (not (string-equal field-width "")))
- (time-stamp--format "%#B" time)
- (time-stamp--format "%B" time)))
- ((eq cur-char ?d) ;day of month, 1-31
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?H) ;hour, 0-23
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?I) ;hour, 1-12
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?m) ;month number, 1-12
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?M) ;minute, 0-59
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?p) ;am or pm
- (if change-case
- (time-stamp--format "%#p" time)
- (time-stamp--format "%p" time)))
- ((eq cur-char ?P) ;AM or PM
- (time-stamp--format "%p" time))
- ((eq cur-char ?S) ;seconds, 00-60
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?w) ;weekday number, Sunday is 0
- (time-stamp--format "%w" time))
- ((eq cur-char ?y) ;year
- (if (> alt-form 0)
- (string-to-number (time-stamp--format "%Y" time))
- (if (or (string-equal field-width "")
- (<= (string-to-number field-width) 2))
- (string-to-number (time-stamp--format "%y" time))
- (time-stamp-conv-warn (format "%%%sy" field-width) "%Y")
- (string-to-number (time-stamp--format "%Y" time)))))
- ((eq cur-char ?Y) ;4-digit year
- (string-to-number (time-stamp--format "%Y" time)))
- ((eq cur-char ?z) ;time zone offset
- (if change-case
- "" ;discourage %z variations
- (cond ((= alt-form 0)
- (if (string-equal field-width "")
- (progn
- (time-stamp-conv-warn "%z" "%#Z")
- (time-stamp--format "%#Z" time))
- (cond ((string-equal field-width "1")
- (setq field-width "3")) ;%-z -> "+00"
- ((string-equal field-width "2")
- (setq field-width "5")) ;%_z -> "+0000"
- ((string-equal field-width "4")
- (setq field-width "0"))) ;discourage %4z
- (time-stamp--format "%z" time)))
- ((= alt-form 1)
- (time-stamp--format "%:z" time))
- ((= alt-form 2)
- (time-stamp--format "%::z" time))
- ((= alt-form 3)
- (time-stamp--format "%:::z" time)))))
- ((eq cur-char ?Z) ;time zone name
- (if change-case
- (time-stamp--format "%#Z" time)
- (time-stamp--format "%Z" time)))
- ((eq cur-char ?f) ;buffer-file-name, base name only
- (if buffer-file-name
- (file-name-nondirectory buffer-file-name)
- time-stamp-no-file))
- ((eq cur-char ?F) ;buffer-file-name, full path
- (or buffer-file-name
- time-stamp-no-file))
- ((eq cur-char ?s) ;system name, legacy
- (system-name))
- ((eq cur-char ?u) ;user name, legacy
- (user-login-name))
- ((eq cur-char ?U) ;user full name, legacy
- (user-full-name))
- ((eq cur-char ?l) ;login name
- (user-login-name))
- ((eq cur-char ?L) ;full name of logged-in user
- (user-full-name))
- ((eq cur-char ?h) ;mail host name
- (or mail-host-address (system-name)))
- ((eq cur-char ?q) ;unqualified host name
- (let ((qualname (system-name)))
- (if (string-match "\\." qualname)
- (substring qualname 0 (match-beginning 0))
- qualname)))
- ((eq cur-char ?Q) ;fully-qualified host name
- (system-name))
- ))
- (and (numberp field-result)
- (= alt-form 0)
- (string-equal field-width "")
- ;; no width provided; set width for default
- (setq field-width "02"))
- (let ((padded-result
- (format (format "%%%s%c"
- field-width
- (if (numberp field-result) ?d ?s))
- (or field-result ""))))
- (let* ((initial-length (length padded-result))
- (desired-length (if (string-equal field-width "")
- initial-length
- (string-to-number field-width))))
- (if (> initial-length desired-length)
- ;; truncate strings on right
- (if (stringp field-result)
- (substring padded-result 0 desired-length)
- padded-result) ;numbers don't truncate
- padded-result))))
- (t
- (char-to-string cur-char)))))
+ (setq paren-level (1+ paren-level)))
+ (if (and (eq ?\) cur-char)
+ (not (eq prev-char ?\\))
+ (> paren-level 0))
+ (setq paren-level (1- paren-level))
+ (and (> paren-level 0)
+ (< ind fmt-len)))
+ (if (and (<= ?0 cur-char) (>= ?9 cur-char))
+ ;; get format width
+ (let ((field-index ind)
+ (first-digit cur-char))
+ (while (progn
+ (setq ind (1+ ind))
+ (setq cur-char (if (< ind fmt-len)
+ (aref format ind)
+ ?\0))
+ (and (<= ?0 cur-char)
+ (>= ?9 cur-char))))
+ (setq field-width
+ (substring format field-index ind))
+ (setq ind (1- ind))
+ (setq cur-char first-digit)
+ t))))
+ (setq prev-char cur-char)
+ ;; some characters we actually use
+ (cond ((eq cur-char ?:)
+ (setq alt-form (1+ alt-form)))
+ ((eq cur-char ?#)
+ (setq change-case t))
+ ((eq cur-char ?^)
+ (setq upcase t))
+ ((eq cur-char ?-)
+ (setq field-width "1"))
+ ((eq cur-char ?_)
+ (setq field-width "2"))))
+ (setq field-result
+ (cond
+ ((eq cur-char ?%)
+ "%")
+ ((eq cur-char ?a) ;day of week
+ (if (> alt-form 0)
+ (if (string-equal field-width "")
+ (time-stamp--format "%A" time)
+ "") ;discourage "%:3a"
+ (if (or change-case upcase)
+ (time-stamp--format "%#a" time)
+ (time-stamp--format "%a" time))))
+ ((eq cur-char ?A)
+ (if (or change-case upcase (not (string-equal field-width
+ "")))
+ (time-stamp--format "%#A" time)
+ (time-stamp--format "%A" time)))
+ ((eq cur-char ?b) ;month name
+ (if (> alt-form 0)
+ (if (string-equal field-width "")
+ (time-stamp--format "%B" time)
+ "") ;discourage "%:3b"
+ (if (or change-case upcase)
+ (time-stamp--format "%#b" time)
+ (time-stamp--format "%b" time))))
+ ((eq cur-char ?B)
+ (if (or change-case upcase (not (string-equal field-width
+ "")))
+ (time-stamp--format "%#B" time)
+ (time-stamp--format "%B" time)))
+ ((eq cur-char ?d) ;day of month, 1-31
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?H) ;hour, 0-23
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?I) ;hour, 1-12
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?m) ;month number, 1-12
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?M) ;minute, 0-59
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?p) ;am or pm
+ (if change-case
+ (time-stamp--format "%#p" time)
+ (time-stamp--format "%p" time)))
+ ((eq cur-char ?P) ;AM or PM
+ (time-stamp--format "%p" time))
+ ((eq cur-char ?S) ;seconds, 00-60
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?w) ;weekday number, Sunday is 0
+ (time-stamp--format "%w" time))
+ ((eq cur-char ?y) ;year
+ (if (> alt-form 0)
+ (string-to-number (time-stamp--format "%Y" time))
+ (if (or (string-equal field-width "")
+ (<= (string-to-number field-width) 2))
+ (string-to-number (time-stamp--format "%y" time))
+ (time-stamp-conv-warn (format "%%%sy" field-width)
"%Y")
+ (string-to-number (time-stamp--format "%Y" time)))))
+ ((eq cur-char ?Y) ;4-digit year
+ (string-to-number (time-stamp--format "%Y" time)))
+ ((eq cur-char ?z) ;time zone offset
+ (if change-case
+ "" ;discourage %z variations
+ (cond ((= alt-form 0)
+ (if (string-equal field-width "")
+ (progn
+ (time-stamp-conv-warn "%z" "%#Z")
+ (time-stamp--format "%#Z" time))
+ (cond ((string-equal field-width "1")
+ (setq field-width "3")) ;%-z -> "+00"
+ ((string-equal field-width "2")
+ (setq field-width "5")) ;%_z -> "+0000"
+ ((string-equal field-width "4")
+ (setq field-width "0"))) ;discourage %4z
+ (time-stamp--format "%z" time)))
+ ((= alt-form 1)
+ (time-stamp--format "%:z" time))
+ ((= alt-form 2)
+ (time-stamp--format "%::z" time))
+ ((= alt-form 3)
+ (time-stamp--format "%:::z" time)))))
+ ((eq cur-char ?Z) ;time zone name
+ (if change-case
+ (time-stamp--format "%#Z" time)
+ (time-stamp--format "%Z" time)))
+ ((eq cur-char ?f) ;buffer-file-name, base name only
+ (if buffer-file-name
+ (file-name-nondirectory buffer-file-name)
+ time-stamp-no-file))
+ ((eq cur-char ?F) ;buffer-file-name, full path
+ (or buffer-file-name
+ time-stamp-no-file))
+ ((eq cur-char ?s) ;system name, legacy
+ (system-name))
+ ((eq cur-char ?u) ;user name, legacy
+ (user-login-name))
+ ((eq cur-char ?U) ;user full name, legacy
+ (user-full-name))
+ ((eq cur-char ?l) ;login name
+ (user-login-name))
+ ((eq cur-char ?L) ;full name of logged-in user
+ (user-full-name))
+ ((eq cur-char ?h) ;mail host name
+ (or mail-host-address (system-name)))
+ ((eq cur-char ?q) ;unqualified host name
+ (let ((qualname (system-name)))
+ (if (string-match "\\." qualname)
+ (substring qualname 0 (match-beginning 0))
+ qualname)))
+ ((eq cur-char ?Q) ;fully-qualified host name
+ (system-name))
+ ))
+ (and (numberp field-result)
+ (= alt-form 0)
+ (string-equal field-width "")
+ ;; no width provided; set width for default
+ (setq field-width "02"))
+ (let ((padded-result
+ (format (format "%%%s%c"
+ field-width
+ (if (numberp field-result) ?d ?s))
+ (or field-result ""))))
+ (let* ((initial-length (length padded-result))
+ (desired-length (if (string-equal field-width "")
+ initial-length
+ (string-to-number field-width))))
+ (if (> initial-length desired-length)
+ ;; truncate strings on right
+ (if (stringp field-result)
+ (substring padded-result 0 desired-length)
+ padded-result) ;numbers don't truncate
+ padded-result)))))
+ (t
+ (char-to-string cur-char)))))
(setq ind (1+ ind)))
result))
diff --git a/lisp/transient.el b/lisp/transient.el
index 93a643c..6153b50 100644
--- a/lisp/transient.el
+++ b/lisp/transient.el
@@ -932,7 +932,7 @@ example, sets a variable use `transient-define-infix'
instead.
(if (eq k :class)
(setq class pop)
(setq args (plist-put args k pop)))))
- (vector (or level (oref-default 'transient-child level))
+ (vector (or level 1)
(or class
(if (vectorp car)
'transient-columns
@@ -1003,7 +1003,7 @@ example, sets a variable use `transient-define-infix'
instead.
(unless (plist-get args :key)
(when-let ((shortarg (plist-get args :shortarg)))
(setq args (plist-put args :key shortarg))))
- (list (or level (oref-default 'transient-child level))
+ (list (or level 1)
(or class 'transient-suffix)
args)))
@@ -3583,9 +3583,9 @@ we stop there."
;;;; `transient-lisp-variable'
(defclass transient-lisp-variable (transient-variable)
- ((reader :initform transient-lisp-variable--reader)
+ ((reader :initform #'transient-lisp-variable--reader)
(always-read :initform t)
- (set-value :initarg :set-value :initform set))
+ (set-value :initarg :set-value :initform #'set))
"[Experimental] Class used for Lisp variables.")
(cl-defmethod transient-init-value ((obj transient-lisp-variable))
diff --git a/lisp/vc/ediff-diff.el b/lisp/vc/ediff-diff.el
index 270c99e..0965e88 100644
--- a/lisp/vc/ediff-diff.el
+++ b/lisp/vc/ediff-diff.el
@@ -231,10 +231,7 @@ one optional arguments, diff-number to refine.")
(sit-for 2)
;; 1 is an error exit code
1)
- (t (message "Computing differences between %s and %s ..."
- (file-name-nondirectory file1)
- (file-name-nondirectory file2))
- ;; this erases the diff buffer automatically
+ (t ;; this erases the diff buffer automatically
(ediff-exec-process ediff-diff-program
diff-buffer
'synchronize
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index e37c09d..89f9800 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -127,6 +127,13 @@ If nil, use the value of `vc-annotate-switches'. If t,
use no switches."
(repeat :tag "Argument List" :value ("") string))
:version "25.1")
+(defcustom vc-git-log-switches nil
+ "String or list of strings specifying switches for Git log under VC."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "28.1")
+
(defcustom vc-git-resolve-conflicts t
"When non-nil, mark conflicted file as resolved upon saving.
That is performed after all conflict markers in it have been
@@ -1131,6 +1138,8 @@ This prompts for a branch to merge from."
:type 'boolean
:version "26.1")
+(autoload 'vc-switches "vc")
+
(defun vc-git-print-log (files buffer &optional shortlog start-revision limit)
"Print commit log associated with FILES into specified BUFFER.
If SHORTLOG is non-nil, use a short format based on `vc-git-root-log-format'.
@@ -1162,9 +1171,10 @@ If LIMIT is a revision string, use it as an
end-revision."
(when shortlog
`("--graph" "--decorate" "--date=short"
,(format "--pretty=tformat:%s"
- (car vc-git-root-log-format))
- "--abbrev-commit"))
- (when (numberp limit)
+ (car vc-git-root-log-format))
+ "--abbrev-commit"))
+ vc-git-log-switches
+ (when (numberp limit)
(list "-n" (format "%s" limit)))
(when start-revision
(if (and limit (not (numberp limit)))
@@ -1385,8 +1395,6 @@ This requires git 1.8.4 or later, for the \"-L\" option
of \"git log\"."
samp coding-system-for-read t)))
(setq coding-system-for-read 'undecided)))
-(autoload 'vc-switches "vc")
-
(defun vc-git-diff (files &optional rev1 rev2 buffer _async)
"Get a difference report using Git between two revisions of FILES."
(let (process-file-side-effects
diff --git a/lisp/wdired.el b/lisp/wdired.el
index 35211bc..22c1ceb 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -351,13 +351,32 @@ or \\[wdired-abort-changes] to abort changes")))
;; This code is a copy of some dired-get-filename lines.
(defsubst wdired-normalize-filename (file unquotep)
(when unquotep
- (setq file
- ;; FIXME: shouldn't we check for a `b' argument or somesuch before
- ;; doing such unquoting? --Stef
- (read (concat
- "\"" (replace-regexp-in-string
- "\\([^\\]\\|\\`\\)\"" "\\1\\\\\"" file)
- "\""))))
+ ;; Unquote names quoted by ls or by dired-insert-directory.
+ ;; This code was written using `read' to unquote, because
+ ;; it's faster than substituting \007 (4 chars) -> ^G (1
+ ;; char) etc. in a lisp loop. Unfortunately, this decision
+ ;; has necessitated hacks such as dealing with filenames
+ ;; with quotation marks in their names.
+ (while (string-match "\\(?:[^\\]\\|\\`\\)\\(\"\\)" file)
+ (setq file (replace-match "\\\"" nil t file 1)))
+ ;; Unescape any spaces escaped by ls -b (bug#10469).
+ ;; Other -b quotes, eg \t, \n, work transparently.
+ (if (dired-switches-escape-p dired-actual-switches)
+ (let ((start 0)
+ (rep "")
+ (shift -1))
+ (while (string-match "\\(\\\\\\) " file start)
+ (setq file (replace-match rep nil t file 1)
+ start (+ shift (match-end 0))))))
+ (when (eq system-type 'windows-nt)
+ (save-match-data
+ (let ((start 0))
+ (while (string-match "\\\\" file start)
+ (aset file (match-beginning 0) ?/)
+ (setq start (match-end 0))))))
+
+ ;; Hence we don't need to worry about converting `\\' back to `\'.
+ (setq file (read (concat "\"" file "\""))))
(and file buffer-file-coding-system
(not file-name-coding-system)
(not default-file-name-coding-system)
diff --git a/lisp/whitespace.el b/lisp/whitespace.el
index 22bfae0..aaa5683 100644
--- a/lisp/whitespace.el
+++ b/lisp/whitespace.el
@@ -1039,6 +1039,9 @@ See also `whitespace-newline' and
`whitespace-display-mappings'."
1 -1))
;; sync states (running a batch job)
(setq global-whitespace-newline-mode global-whitespace-mode)))
+(make-obsolete 'global-whitespace-newline-mode
+ "use `global-whitespace-mode' with `whitespace-style' set to
`(newline-mark newline)' instead."
+ "28.1")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 49baab6..9a34dc8 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -4011,7 +4011,10 @@ is inline."
(defun widget-boolean-prompt-value (_widget prompt _value _unbound)
;; Toggle a boolean.
- (y-or-n-p prompt))
+ ;; Say what "y" means. A la
+ ;; "Set customized value for bar to true: (y or n)"
+ (y-or-n-p (concat (replace-regexp-in-string ": ?\\'" "" prompt)
+ " true: ")))
;;; The `color' Widget.
diff --git a/lisp/windmove.el b/lisp/windmove.el
index e4ea8e0..f558903 100644
--- a/lisp/windmove.el
+++ b/lisp/windmove.el
@@ -426,19 +426,53 @@ unless `windmove-create-window' is non-nil and a new
window is created."
;; I don't think these bindings will work on non-X terminals; you
;; probably want to use different bindings in that case.
+(defvar windmove-mode-map (make-sparse-keymap)
+ "Map used by `windmove-install-defaults'.")
+
+(define-minor-mode windmove-mode
+ "Global minor mode for default windmove commands."
+ :keymap windmove-mode-map
+ :init-value t
+ :global t)
+
+(defun windmove-install-defaults (prefix modifiers alist &optional uninstall)
+ "Install keys as specified by ALIST.
+Every element of ALIST has the form (FN KEY), where KEY is
+appended to MODIFIERS, adding PREFIX to the beginning, before
+installing the key. Previous bindings of FN are unbound.
+If UNINSTALL is non-nil, just remove the keys from ALIST."
+ (dolist (bind alist)
+ (dolist (old (where-is-internal (car bind) windmove-mode-map))
+ (define-key windmove-mode-map old nil))
+ (unless uninstall
+ (let ((key (vconcat (if (or (equal prefix [ignore])
+ (eq prefix 'none))
+ nil prefix)
+ (list (append modifiers (cdr bind))))))
+ (when (eq (key-binding key) #'self-insert-command)
+ (warn "Command %S is shadowing self-insert-key" (car bind)))
+ (let ((old-fn (lookup-key windmove-mode-map key)))
+ (when (functionp old-fn)
+ (warn "Overriding %S with %S" old-fn (car bind))))
+ (define-key windmove-mode-map key (car bind))))))
+
;;;###autoload
(defun windmove-default-keybindings (&optional modifiers)
"Set up keybindings for `windmove'.
Keybindings are of the form MODIFIERS-{left,right,up,down},
where MODIFIERS is either a list of modifiers or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to
+the arrow keys.
Default value of MODIFIERS is `shift'."
(interactive)
(unless modifiers (setq modifiers 'shift))
+ (when (eq modifiers 'none) (setq modifiers nil))
(unless (listp modifiers) (setq modifiers (list modifiers)))
- (global-set-key (vector (append modifiers '(left))) 'windmove-left)
- (global-set-key (vector (append modifiers '(right))) 'windmove-right)
- (global-set-key (vector (append modifiers '(up))) 'windmove-up)
- (global-set-key (vector (append modifiers '(down))) 'windmove-down))
+ (windmove-install-defaults nil modifiers
+ '((windmove-left left)
+ (windmove-right right)
+ (windmove-up up)
+ (windmove-down down))))
;;; Directional window display and selection
@@ -546,17 +580,21 @@ See the logic of the prefix ARG in
`windmove-display-in-direction'."
Keys are bound to commands that display the next buffer in the specified
direction. Keybindings are of the form MODIFIERS-{left,right,up,down},
where MODIFIERS is either a list of modifiers or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to
+the arrow keys.
Default value of MODIFIERS is `shift-meta'."
(interactive)
(unless modifiers (setq modifiers '(shift meta)))
+ (when (eq modifiers 'none) (setq modifiers nil))
(unless (listp modifiers) (setq modifiers (list modifiers)))
- (global-set-key (vector (append modifiers '(left))) 'windmove-display-left)
- (global-set-key (vector (append modifiers '(right))) 'windmove-display-right)
- (global-set-key (vector (append modifiers '(up))) 'windmove-display-up)
- (global-set-key (vector (append modifiers '(down))) 'windmove-display-down)
- (global-set-key (vector (append modifiers '(?0)))
'windmove-display-same-window)
- (global-set-key (vector (append modifiers '(?f)))
'windmove-display-new-frame)
- (global-set-key (vector (append modifiers '(?t)))
'windmove-display-new-tab))
+ (windmove-install-defaults nil modifiers
+ '((windmove-display-left left)
+ (windmove-display-right right)
+ (windmove-display-up up)
+ (windmove-display-down down)
+ (windmove-display-same-window ?0)
+ (windmove-display-new-frame ?f)
+ (windmove-display-new-tab ?t))))
;;; Directional window deletion
@@ -618,16 +656,22 @@ select the window that was below the current one."
Keys are bound to commands that delete windows in the specified
direction. Keybindings are of the form PREFIX MODIFIERS-{left,right,up,down},
where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or
-a single modifier. Default value of PREFIX is `C-x' and MODIFIERS is `shift'."
+a single modifier.
+If PREFIX is `none', no prefix is used. If MODIFIERS is `none', the keybindings
+are directly bound to the arrow keys.
+Default value of PREFIX is `C-x' and MODIFIERS is `shift'."
(interactive)
(unless prefix (setq prefix '(?\C-x)))
+ (when (eq prefix 'none) (setq prefix nil))
(unless (listp prefix) (setq prefix (list prefix)))
(unless modifiers (setq modifiers '(shift)))
+ (when (eq modifiers 'none) (setq modifiers nil))
(unless (listp modifiers) (setq modifiers (list modifiers)))
- (global-set-key (vector prefix (append modifiers '(left)))
'windmove-delete-left)
- (global-set-key (vector prefix (append modifiers '(right)))
'windmove-delete-right)
- (global-set-key (vector prefix (append modifiers '(up)))
'windmove-delete-up)
- (global-set-key (vector prefix (append modifiers '(down)))
'windmove-delete-down))
+ (windmove-install-defaults prefix modifiers
+ '((windmove-delete-left left)
+ (windmove-delete-right right)
+ (windmove-delete-up up)
+ (windmove-delete-down down))))
;;; Directional window swap states
@@ -673,14 +717,103 @@ from the opposite side of the frame."
Keys are bound to commands that swap the states of the selected window
with the window in the specified direction. Keybindings are of the form
MODIFIERS-{left,right,up,down}, where MODIFIERS is either a list of modifiers
-or a single modifier. Default value of MODIFIERS is `shift-super'."
+or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to the
+arrow keys.
+Default value of MODIFIERS is `shift-super'."
(interactive)
(unless modifiers (setq modifiers '(shift super)))
+ (when (eq modifiers 'none) (setq modifiers nil))
(unless (listp modifiers) (setq modifiers (list modifiers)))
- (global-set-key (vector (append modifiers '(left)))
'windmove-swap-states-left)
- (global-set-key (vector (append modifiers '(right)))
'windmove-swap-states-right)
- (global-set-key (vector (append modifiers '(up)))
'windmove-swap-states-up)
- (global-set-key (vector (append modifiers '(down)))
'windmove-swap-states-down))
+ (windmove-install-defaults nil modifiers
+ '((windmove-swap-states-left left)
+ (windmove-swap-states-right right)
+ (windmove-swap-states-up up)
+ (windmove-swap-states-down down))))
+
+
+
+(defconst windmove--default-keybindings-type
+ `(choice (const :tag "Don't bind" nil)
+ (cons :tag "Bind using"
+ (key-sequence :tag "Prefix")
+ (set :tag "Modifier"
+ :greedy t
+ ;; See `(elisp) Keyboard Events'
+ (const :tag "Meta" meta)
+ (const :tag "Control" control)
+ (const :tag "Shift" shift)
+ (const :tag "Hyper" hyper)
+ (const :tag "Super" super)
+ (const :tag "Alt" alt))))
+ "Customisation type for windmove modifiers.")
+
+(defcustom windmove-default-keybindings nil
+ "Default keybindings for regular windmove commands.
+See `windmove-default-keybindings' for more detail."
+ :set (lambda (sym val)
+ (windmove-install-defaults
+ (car val) (cdr val)
+ '((windmove-left left)
+ (windmove-right right)
+ (windmove-up up)
+ (windmove-down down))
+ (null val))
+ (set-default sym val))
+ :type windmove--default-keybindings-type
+ :version "28.1"
+ :group 'windmove)
+
+(defcustom windmove-display-default-keybindings nil
+ "Default keybindings for windmove directional buffer display commands.
+See `windmove-display-default-keybindings' for more detail."
+ :set (lambda (sym val)
+ (windmove-install-defaults
+ (car val) (cdr val)
+ '((windmove-display-left left)
+ (windmove-display-right right)
+ (windmove-display-up up)
+ (windmove-display-down down)
+ (windmove-display-same-window ?0)
+ (windmove-display-new-frame ?f)
+ (windmove-display-new-tab ?t))
+ (null val))
+ (set-default sym val))
+ :type windmove--default-keybindings-type
+ :version "28.1"
+ :group 'windmove)
+
+(defcustom windmove-delete-default-keybindings nil
+ "Default keybindings for windmove directional window deletion commands.
+See `windmove-delete-default-keybindings' for more detail."
+ :set (lambda (sym val)
+ (windmove-install-defaults
+ (car val) (cdr val)
+ '((windmove-delete-left left)
+ (windmove-delete-right right)
+ (windmove-delete-up up)
+ (windmove-delete-down down))
+ (null val))
+ (set-default sym val))
+ :type windmove--default-keybindings-type
+ :version "28.1"
+ :group 'windmove)
+
+(defcustom windmove-swap-states-default-keybindings nil
+ "Default keybindings for windmove's directional window swap-state commands.
+See `windmove-swap-states-default-keybindings' for more detail."
+ :set (lambda (sym val)
+ (windmove-install-defaults
+ (car val) (cdr val)
+ '((windmove-swap-states-left left)
+ (windmove-swap-states-right right)
+ (windmove-swap-states-up up)
+ (windmove-swap-states-down down))
+ (null val))
+ (set-default sym val))
+ :type windmove--default-keybindings-type
+ :version "28.1"
+ :group 'windmove)
(provide 'windmove)
diff --git a/lisp/window.el b/lisp/window.el
index fd1c617..ff4a39a 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -2499,14 +2499,16 @@ and no others."
(defalias 'some-window 'get-window-with-predicate)
-(defun get-lru-window (&optional all-frames dedicated not-selected)
+(defun get-lru-window (&optional all-frames dedicated not-selected no-other)
"Return the least recently used window on frames specified by ALL-FRAMES.
Return a full-width window if possible. A minibuffer window is
never a candidate. A dedicated window is never a candidate
unless DEDICATED is non-nil, so if all windows are dedicated, the
value is nil. Avoid returning the selected window if possible.
Optional argument NOT-SELECTED non-nil means never return the
-selected window.
+selected window. Optional argument NO-OTHER non-nil means to
+never return a window whose 'no-other-window' parameter is
+non-nil.
The following non-nil values of the optional argument ALL-FRAMES
have special meanings:
@@ -2526,7 +2528,9 @@ selected frame and no others."
(let (best-window best-time second-best-window second-best-time time)
(dolist (window (window-list-1 nil 'nomini all-frames))
(when (and (or dedicated (not (window-dedicated-p window)))
- (or (not not-selected) (not (eq window (selected-window)))))
+ (or (not not-selected) (not (eq window (selected-window))))
+ (or (not no-other)
+ (not (window-parameter window 'no-other-window))))
(setq time (window-use-time window))
(if (or (eq window (selected-window))
(not (window-full-width-p window)))
@@ -2538,12 +2542,14 @@ selected frame and no others."
(setq best-window window)))))
(or best-window second-best-window)))
-(defun get-mru-window (&optional all-frames dedicated not-selected)
+(defun get-mru-window (&optional all-frames dedicated not-selected no-other)
"Return the most recently used window on frames specified by ALL-FRAMES.
A minibuffer window is never a candidate. A dedicated window is
never a candidate unless DEDICATED is non-nil, so if all windows
are dedicated, the value is nil. Optional argument NOT-SELECTED
-non-nil means never return the selected window.
+non-nil means never return the selected window. Optional
+argument NO-OTHER non-nil means to never return a window whose
+'no-other-window' parameter is non-nil.
The following non-nil values of the optional argument ALL-FRAMES
have special meanings:
@@ -2565,17 +2571,21 @@ selected frame and no others."
(setq time (window-use-time window))
(when (and (or dedicated (not (window-dedicated-p window)))
(or (not not-selected) (not (eq window (selected-window))))
- (or (not best-time) (> time best-time)))
+ (or (not no-other)
+ (not (window-parameter window 'no-other-window)))
+ (or (not best-time) (> time best-time)))
(setq best-time time)
(setq best-window window)))
best-window))
-(defun get-largest-window (&optional all-frames dedicated not-selected)
+(defun get-largest-window (&optional all-frames dedicated not-selected
no-other)
"Return the largest window on frames specified by ALL-FRAMES.
A minibuffer window is never a candidate. A dedicated window is
never a candidate unless DEDICATED is non-nil, so if all windows
are dedicated, the value is nil. Optional argument NOT-SELECTED
-non-nil means never return the selected window.
+non-nil means never return the selected window. Optional
+argument NO-OTHER non-nil means to never return a window whose
+'no-other-window' parameter is non-nil.
The following non-nil values of the optional argument ALL-FRAMES
have special meanings:
@@ -2596,7 +2606,9 @@ selected frame and no others."
best-window size)
(dolist (window (window-list-1 nil 'nomini all-frames))
(when (and (or dedicated (not (window-dedicated-p window)))
- (or (not not-selected) (not (eq window (selected-window)))))
+ (or (not not-selected) (not (eq window (selected-window))))
+ (or (not no-other)
+ (not (window-parameter window 'no-other-window))))
(setq size (* (window-pixel-height window)
(window-pixel-width window)))
(when (> size best-size)
@@ -4130,18 +4142,56 @@ frame can be safely deleted."
;; of its frame.
t))))
-(defun window--in-subtree-p (window root)
- "Return t if WINDOW is either ROOT or a member of ROOT's subtree."
- (or (eq window root)
- (let ((parent (window-parent window)))
- (catch 'done
- (while parent
- (if (eq parent root)
- (throw 'done t)
- (setq parent (window-parent parent))))))))
+(defun window-at-x-y (x y &optional frame no-other)
+ "Return live window at coordinates X, Y on specified FRAME.
+X and Y are FRAME-relative pixel coordinates. A coordinate on an
+edge shared by two windows is attributed to the window on the
+right (or below). Return nil if no such window can be found.
+
+Optional argument FRAME must specify a live frame and defaults to
+the selected one. Optional argument NO-OTHER non-nil means to
+return nil if the window located at the specified coordinates has
+a non-nil `no-other-window' parameter."
+ (setq frame (window-normalize-frame frame))
+ (let* ((root-edges (window-edges (frame-root-window frame) nil nil t))
+ (root-left (nth 2 root-edges))
+ (root-bottom (nth 3 root-edges)))
+ (catch 'window
+ (walk-window-tree
+ (lambda (window)
+ (let ((edges (window-edges window nil nil t)))
+ (when (and (>= x (nth 0 edges))
+ (or (< x (nth 2 edges)) (= x root-left))
+ (>= y (nth 1 edges))
+ (or (< y (nth 3 edges)) (= y root-bottom)))
+ (if (and no-other (window-parameter window 'no-other-window))
+ (throw 'window nil)
+ (throw 'window window)))))
+ frame))))
+
+(defcustom delete-window-choose-selected 'mru
+ "How to choose a frame's selected window after window deletion.
+When a frame's selected window gets deleted, Emacs has to choose
+another live window on that frame to serve as its selected
+window. This option allows to control which window gets selected
+instead.
+
+The possible choices are 'mru' (the default) to select the most
+recently used window on that frame, and 'pos' to choose the
+window at the frame coordinates of point of the previously
+selected window. If this is nil, choose the frame's first window
+instead. A window with a non-nil `no-other-window' parameter is
+chosen only if all windows on that frame have that parameter set
+to a non-nil value."
+ :type '(choice (const :tag "Most recently used" mru)
+ (const :tag "At position of deleted" pos)
+ (const :tag "Frame's first " nil))
+ :group 'windows
+ :group 'frames
+ :version "28.1")
(defun delete-window (&optional window)
- "Delete WINDOW.
+ "Delete specified WINDOW.
WINDOW must be a valid window and defaults to the selected one.
Return nil.
@@ -4156,7 +4206,11 @@ Otherwise, if WINDOW is part of an atomic window, call
`delete-window' with the root of the atomic window as its
argument. Signal an error if WINDOW is either the only window on
its frame, the last non-side window, or part of an atomic window
-that is its frame's root window."
+that is its frame's root window.
+
+If WINDOW is the selected window on its frame, choose some other
+window as that frame's selected window according to the value of
+the option `delete-window-choose-selected'."
(interactive)
(setq window (window-normalize-window window))
(let* ((frame (window-frame window))
@@ -4191,11 +4245,11 @@ that is its frame's root window."
(window-combination-resize
(or window-combination-resize
(window-parameter parent 'window-side)))
- (frame-selected
- (window--in-subtree-p (frame-selected-window frame) window))
+ (frame-selected-window (frame-selected-window frame))
;; Emacs 23 preferably gives WINDOW's space to its left
;; sibling.
- (sibling (or (window-left window) (window-right window))))
+ (sibling (or (window-left window) (window-right window)))
+ frame-selected-window-edges frame-selected-window-pos)
(window--resize-reset frame horizontal)
(cond
((and (not (eq window-combination-resize t))
@@ -4211,15 +4265,63 @@ that is its frame's root window."
(t
;; Can't do without resizing fixed-size windows.
(window--resize-siblings window (- size) horizontal t)))
+
+ (when (eq delete-window-choose-selected 'pos)
+ ;; Remember edges and position of point of the selected window
+ ;; of WINDOW'S frame.
+ (setq frame-selected-window-edges
+ (window-edges frame-selected-window nil nil t))
+ (setq frame-selected-window-pos
+ (nth 2 (posn-at-point nil frame-selected-window))))
+
;; Actually delete WINDOW.
(delete-window-internal window)
(window--pixel-to-total frame horizontal)
- (when (and frame-selected
- (window-parameter
- (frame-selected-window frame) 'no-other-window))
- ;; `delete-window-internal' has selected a window that should
- ;; not be selected, fix this here.
- (other-window -1 frame))
+
+ ;; If we deleted the selected window of WINDOW's frame, choose
+ ;; another one based on `delete-window-choose-selected'. Note
+ ;; that both `window-at-x-y' and `get-mru-window' may fail to
+ ;; produce a suitable window in which case we will fall back on
+ ;; its frame's first window, chosen by `delete-window-internal'.
+ (cond
+ ((window-live-p frame-selected-window))
+ ((and frame-selected-window-pos
+ ;; We have a recorded position of point of the previously
+ ;; selected window. Try to find the window that is now
+ ;; at that position.
+ (let ((new-frame-selected-window
+ (window-at-x-y
+ (+ (nth 0 frame-selected-window-edges)
+ (car frame-selected-window-pos))
+ (+ (nth 1 frame-selected-window-edges)
+ (cdr frame-selected-window-pos))
+ frame t)))
+ (and new-frame-selected-window
+ ;; Select window at WINDOW's position at point.
+ (set-frame-selected-window
+ frame new-frame-selected-window)))))
+ ((and (eq delete-window-choose-selected 'mru)
+ ;; Try to use the most recently used window.
+ (let ((mru-window (get-mru-window frame nil nil t)))
+ (and mru-window
+ (set-frame-selected-window frame mru-window)))))
+ ((and (window-parameter
+ (frame-selected-window frame) 'no-other-window)
+ ;; If `delete-window-internal' selected a window with a
+ ;; non-nil 'no-other-window' parameter as its frame's
+ ;; selected window, try to choose another one.
+ (catch 'found
+ (walk-window-tree
+ (lambda (other)
+ (unless (window-parameter other 'no-other-window)
+ (set-frame-selected-window frame other)
+ (throw 'found t)))
+ frame))))
+ (t
+ ;; Record the window chosen by `delete-window-internal'.
+ (set-frame-selected-window
+ frame (frame-selected-window frame))))
+
(window--check frame)
;; Always return nil.
nil))))
diff --git a/lisp/xdg.el b/lisp/xdg.el
index 1103949..0bdfd11 100644
--- a/lisp/xdg.el
+++ b/lisp/xdg.el
@@ -231,7 +231,7 @@ admin config, and finally system cached associations."
(desktop (getenv "XDG_CURRENT_DESKTOP"))
res)
(when desktop
- (setq desktop (format "%s-mimeapps.list" desktop)))
+ (setq desktop (list (format "%s-mimeapps.list" desktop))))
(dolist (name (cons "mimeapps.list" desktop))
(push (expand-file-name name (xdg-config-home)) res)
(push (expand-file-name (format "applications/%s" name) (xdg-data-home))
diff --git a/src/character.c b/src/character.c
index e874cf5..38a81d3 100644
--- a/src/character.c
+++ b/src/character.c
@@ -328,12 +328,14 @@ strwidth (const char *str, ptrdiff_t len)
compositions. If PRECISION > 0, return the width of longest
substring that doesn't exceed PRECISION, and set number of
characters and bytes of the substring in *NCHARS and *NBYTES
- respectively. FROM and TO are zero-based character indices
- that define the substring of STRING to consider. */
+ respectively. FROM and TO are zero-based character indices that
+ define the substring of STRING to consider. If AUTO_COMP is
+ non-zero, account for automatic compositions in STRING. */
ptrdiff_t
lisp_string_width (Lisp_Object string, ptrdiff_t from, ptrdiff_t to,
- ptrdiff_t precision, ptrdiff_t *nchars, ptrdiff_t *nbytes)
+ ptrdiff_t precision, ptrdiff_t *nchars, ptrdiff_t *nbytes,
+ bool auto_comp)
{
/* This set multibyte to 0 even if STRING is multibyte when it
contains only ascii and eight-bit-graphic, but that's
@@ -370,9 +372,11 @@ lisp_string_width (Lisp_Object string, ptrdiff_t from,
ptrdiff_t to,
bytes = string_char_to_byte (string, end) - i_byte;
}
#ifdef HAVE_WINDOW_SYSTEM
- else if (f && FRAME_WINDOW_P (f)
+ else if (auto_comp
+ && f && FRAME_WINDOW_P (f)
&& multibyte
- && find_automatic_composition (i, -1, &ignore, &end, &val,
string)
+ && find_automatic_composition (i, -1, i, &ignore,
+ &end, &val, string)
&& end > i)
{
int j;
@@ -471,7 +475,7 @@ usage: (string-width STRING &optional FROM TO) */)
CHECK_STRING (str);
validate_subarray (str, from, to, SCHARS (str), &ifrom, &ito);
- XSETFASTINT (val, lisp_string_width (str, ifrom, ito, -1, NULL, NULL));
+ XSETFASTINT (val, lisp_string_width (str, ifrom, ito, -1, NULL, NULL, true));
return val;
}
diff --git a/src/character.h b/src/character.h
index 75351cd..1a74548 100644
--- a/src/character.h
+++ b/src/character.h
@@ -573,7 +573,7 @@ extern ptrdiff_t strwidth (const char *, ptrdiff_t);
extern ptrdiff_t c_string_width (const unsigned char *, ptrdiff_t, int,
ptrdiff_t *, ptrdiff_t *);
extern ptrdiff_t lisp_string_width (Lisp_Object, ptrdiff_t, ptrdiff_t,
- ptrdiff_t, ptrdiff_t *, ptrdiff_t *);
+ ptrdiff_t, ptrdiff_t *, ptrdiff_t *, bool);
extern Lisp_Object Vchar_unify_table;
extern Lisp_Object string_escape_byte8 (Lisp_Object);
diff --git a/src/composite.c b/src/composite.c
index 17d5914..129e9d6 100644
--- a/src/composite.c
+++ b/src/composite.c
@@ -1473,14 +1473,60 @@ struct position_record
(POSITION).pos--; \
} while (0)
-/* This is like find_composition, but find an automatic composition
- instead. It is assured that POS is not within a static
- composition. If found, set *GSTRING to the glyph-string
- representing the composition, and return true. Otherwise, *GSTRING to
- Qnil, and return false. */
+/* Similar to find_composition, but find an automatic composition instead.
+
+ This function looks for automatic composition at or near position
+ POS of OBJECT (a buffer or a string). OBJECT defaults to the
+ current buffer. It must be assured that POS is not within a static
+ composition. Also, the current buffer must be displayed in some
+ window, otherwise the function will return FALSE.
+
+ If LIMIT is negative, and there's no composition that includes POS
+ (i.e. starts at or before POS and ends at or after POS), return
+ FALSE. In this case, the function is allowed to look from POS as
+ far back as BACKLIM, and as far forward as POS+1 plus
+ MAX_AUTO_COMPOSITION_LOOKBACK, the maximum number of look-back for
+ automatic compositions (3) -- this is a limitation imposed by
+ composition rules in composition-function-table, which see. If
+ BACKLIM is negative, it stands for the beginning of OBJECT: BEGV
+ for a buffer or position zero for a string.
+
+ If LIMIT is positive, search for a composition forward (LIMIT >
+ POS) or backward (LIMIT < POS). In this case, LIMIT bounds the
+ search for the first character of a composed sequence.
+ (LIMIT == POS is the same as LIMIT < 0.) If LIMIT > POS, the
+ function can find a composition that starts after POS.
+
+ BACKLIM limits how far back is the function allowed to look in
+ OBJECT while trying to find a position where it is safe to start
+ searching forward for compositions. Such a safe place is generally
+ the position after a character that can never be composed.
+
+ If BACKLIM is negative, that means the first character position of
+ OBJECT; this is useful when calling the function for the first time
+ for a given buffer or string, since it is possible that a
+ composition begins before POS. However, if POS is very far from
+ the beginning of OBJECT, a negative value of BACKLIM could make the
+ function slow. Also, in this case the function may return START
+ and END that do not include POS, something that is not necessarily
+ wanted, and needs to be explicitly checked by the caller.
+
+ When calling the function in a loop for the same buffer/string, the
+ caller should generally set BACKLIM equal to POS, to avoid costly
+ repeated searches backward. This is because if the previous
+ positions were already checked for compositions, there should be no
+ reason to re-check them.
+
+ If BACKLIM is positive, it must be less or equal to LIMIT.
+
+ If an automatic composition satisfying the above conditions is
+ found, set *GSTRING to the Lispy glyph-string representing the
+ composition, set *START and *END to the start and end of the
+ composed sequence, and return TRUE. Otherwise, set *GSTRING to
+ nil, and return FALSE. */
bool
-find_automatic_composition (ptrdiff_t pos, ptrdiff_t limit,
+find_automatic_composition (ptrdiff_t pos, ptrdiff_t limit, ptrdiff_t backlim,
ptrdiff_t *start, ptrdiff_t *end,
Lisp_Object *gstring, Lisp_Object string)
{
@@ -1502,13 +1548,13 @@ find_automatic_composition (ptrdiff_t pos, ptrdiff_t
limit,
cur.pos = pos;
if (NILP (string))
{
- head = BEGV, tail = ZV, stop = GPT;
+ head = backlim < 0 ? BEGV : backlim, tail = ZV, stop = GPT;
cur.pos_byte = CHAR_TO_BYTE (cur.pos);
cur.p = BYTE_POS_ADDR (cur.pos_byte);
}
else
{
- head = 0, tail = SCHARS (string), stop = -1;
+ head = backlim < 0 ? 0 : backlim, tail = SCHARS (string), stop = -1;
cur.pos_byte = string_char_to_byte (string, cur.pos);
cur.p = SDATA (string) + cur.pos_byte;
}
@@ -1516,6 +1562,9 @@ find_automatic_composition (ptrdiff_t pos, ptrdiff_t
limit,
/* Finding a composition covering the character after POS is the
same as setting LIMIT to POS. */
limit = pos;
+
+ eassert (backlim < 0 || backlim <= limit);
+
if (limit <= pos)
fore_check_limit = min (tail, pos + 1 + MAX_AUTO_COMPOSITION_LOOKBACK);
else
@@ -1696,8 +1745,8 @@ composition_adjust_point (ptrdiff_t last_pt, ptrdiff_t
new_pt)
return new_pt;
/* Next check the automatic composition. */
- if (! find_automatic_composition (new_pt, (ptrdiff_t) -1, &beg, &end, &val,
- Qnil)
+ if (! find_automatic_composition (new_pt, (ptrdiff_t) -1, (ptrdiff_t) -1,
+ &beg, &end, &val, Qnil)
|| beg == new_pt)
return new_pt;
for (i = 0; i < LGSTRING_GLYPH_LEN (val); i++)
@@ -1893,8 +1942,8 @@ See `find-composition' for more details. */)
{
if (!NILP (BVAR (current_buffer, enable_multibyte_characters))
&& ! NILP (Vauto_composition_mode)
- && find_automatic_composition (from, to, &start, &end, &gstring,
- string))
+ && find_automatic_composition (from, to, (ptrdiff_t) -1,
+ &start, &end, &gstring, string))
return list3 (make_fixnum (start), make_fixnum (end), gstring);
return Qnil;
}
@@ -1902,7 +1951,8 @@ See `find-composition' for more details. */)
{
ptrdiff_t s, e;
- if (find_automatic_composition (from, to, &s, &e, &gstring, string)
+ if (find_automatic_composition (from, to, (ptrdiff_t) -1,
+ &s, &e, &gstring, string)
&& (e <= fixed_pos ? e > end : s < start))
return list3 (make_fixnum (s), make_fixnum (e), gstring);
}
diff --git a/src/composite.h b/src/composite.h
index 75e5f9b..67e8720 100644
--- a/src/composite.h
+++ b/src/composite.h
@@ -246,6 +246,11 @@ composition_valid_p (ptrdiff_t start, ptrdiff_t end,
Lisp_Object prop)
/* Macros for lispy glyph-string. This is completely different from
struct glyph_string. */
+/* LGSTRING is a string of font glyphs, LGLYPHs. It is represented as
+ a Lisp vector, with components shown below. Once LGSTRING was
+ processed by a shaping engine, it holds font glyphs for one or more
+ grapheme clusters. */
+
#define LGSTRING_HEADER(lgs) AREF (lgs, 0)
#define LGSTRING_SET_HEADER(lgs, header) ASET (lgs, 0, header)
@@ -259,6 +264,10 @@ composition_valid_p (ptrdiff_t start, ptrdiff_t end,
Lisp_Object prop)
#define LGSTRING_ID(lgs) AREF (lgs, 1)
#define LGSTRING_SET_ID(lgs, id) ASET (lgs, 1, id)
+/* LGSTRING_GLYPH_LEN is the maximum number of LGLYPHs that the
+ LGSTRING can hold. This is NOT the actual number of valid LGLYPHs;
+ to find the latter, walk the glyphs returned by LGSTRING_GLYPH
+ until the first one that is nil. */
#define LGSTRING_GLYPH_LEN(lgs) (ASIZE ((lgs)) - 2)
#define LGSTRING_GLYPH(lgs, idx) AREF ((lgs), (idx) + 2)
#define LGSTRING_SET_GLYPH(lgs, idx, val) ASET ((lgs), (idx) + 2, (val))
@@ -278,6 +287,14 @@ enum lglyph_indices
LGLYPH_SIZE
};
+/* Each LGLYPH is a single font glyph, whose font code is in
+ LGLYPH_CODE.
+ LGLYPH_FROM and LGLYPH_TO are indices into LGSTRING; all the
+ LGLYPHs that share the same values of LGLYPH_FROM and LGLYPH_TO
+ belong to the same grapheme cluster.
+ LGLYPH_CHAR is one of the characters, usually the first one, that
+ contributed to the glyph (since there isn't a 1:1 correspondence
+ between composed characters and the font glyphs). */
#define LGLYPH_NEW() make_nil_vector (LGLYPH_SIZE)
#define LGLYPH_FROM(g) XFIXNUM (AREF ((g), LGLYPH_IX_FROM))
#define LGLYPH_TO(g) XFIXNUM (AREF ((g), LGLYPH_IX_TO))
@@ -320,9 +337,9 @@ extern bool composition_gstring_p (Lisp_Object);
extern int composition_gstring_width (Lisp_Object, ptrdiff_t, ptrdiff_t,
struct font_metrics *);
-extern bool find_automatic_composition (ptrdiff_t, ptrdiff_t, ptrdiff_t *,
- ptrdiff_t *, Lisp_Object *,
- Lisp_Object);
+extern bool find_automatic_composition (ptrdiff_t, ptrdiff_t, ptrdiff_t,
+ ptrdiff_t *, ptrdiff_t *,
+ Lisp_Object *, Lisp_Object);
extern void composition_compute_stop_pos (struct composition_it *,
ptrdiff_t, ptrdiff_t, ptrdiff_t,
diff --git a/src/data.c b/src/data.c
index d547f5d..059f31e 100644
--- a/src/data.c
+++ b/src/data.c
@@ -2200,7 +2200,9 @@ From now on the default value will apply in this buffer.
Return VARIABLE. */)
DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1, 2, 0,
doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
-BUFFER defaults to the current buffer. */)
+BUFFER defaults to the current buffer.
+
+Also see `buffer-local-boundp'.*/)
(Lisp_Object variable, Lisp_Object buffer)
{
struct buffer *buf = decode_buffer (buffer);
diff --git a/src/editfns.c b/src/editfns.c
index 182d3ba..aa0f46f 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -3390,7 +3390,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool
message)
ptrdiff_t nch, nby;
nchars_string = SCHARS (arg);
width = lisp_string_width (arg, 0, nchars_string, prec,
- &nch, &nby);
+ &nch, &nby, false);
if (prec < 0)
nbytes = SBYTES (arg);
else
diff --git a/src/frame.c b/src/frame.c
index f8479f6..3c7c407 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -985,6 +985,7 @@ make_frame (bool mini_p)
f->ns_transparent_titlebar = false;
#endif
#endif
+ f->select_mini_window_flag = false;
/* This one should never be zero. */
f->change_stamp = 1;
root_window = make_window ();
@@ -1545,7 +1546,17 @@ do_switch_frame (Lisp_Object frame, int track, int
for_deletion, Lisp_Object nor
tty->top_frame = frame;
}
+ sf->select_mini_window_flag = MINI_WINDOW_P (XWINDOW (sf->selected_window));
+
selected_frame = frame;
+
+ move_minibuffers_onto_frame (sf, for_deletion);
+
+ if (f->select_mini_window_flag
+ && !NILP (Fminibufferp (XWINDOW (f->minibuffer_window)->contents, Qt)))
+ f->selected_window = f->minibuffer_window;
+ f->select_mini_window_flag = false;
+
if (! FRAME_MINIBUF_ONLY_P (XFRAME (selected_frame)))
last_nonminibuf_frame = XFRAME (selected_frame);
@@ -1562,7 +1573,6 @@ do_switch_frame (Lisp_Object frame, int track, int
for_deletion, Lisp_Object nor
#endif
internal_last_event_frame = Qnil;
- move_minibuffers_onto_frame (sf, for_deletion);
return frame;
}
diff --git a/src/frame.h b/src/frame.h
index b1ad525..d3ae548 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -462,6 +462,11 @@ struct frame
in X builds only. */
bool_bf was_invisible : 1;
+ /* True when the frame isn't selected, and selecting it in the
+ future should select the mini-window rather than the currently
+ selected window in the frame, assuming there is still an active
+ minibuffer in that mini-window. */
+ bool_bf select_mini_window_flag : 1;
/* Bitfield area ends here. */
/* This frame's change stamp, set the last time window change
diff --git a/src/image.c b/src/image.c
index 9b8b7d9..916edd5 100644
--- a/src/image.c
+++ b/src/image.c
@@ -3276,19 +3276,16 @@ image_find_image_fd (Lisp_Object file, int *pfd)
/* Try to find FILE in data-directory/images, then x-bitmap-file-path. */
fd = openp (search_path, file, Qnil, &file_found,
pfd ? Qt : make_fixnum (R_OK), false, false);
- if (fd >= 0 || fd == -2)
+ if (fd == -2)
{
- file_found = ENCODE_FILE (file_found);
- if (fd == -2)
- {
- /* The file exists locally, but has a file name handler.
- (This happens, e.g., under Auto Image File Mode.)
- 'openp' didn't open the file, so we should, because the
- caller expects that. */
- fd = emacs_open (SSDATA (file_found), O_RDONLY, 0);
- }
+ /* The file exists locally, but has a file name handler.
+ (This happens, e.g., under Auto Image File Mode.)
+ 'openp' didn't open the file, so we should, because the
+ caller expects that. */
+ Lisp_Object encoded_name = ENCODE_FILE (file_found);
+ fd = emacs_open (SSDATA (encoded_name), O_RDONLY, 0);
}
- else /* fd < 0, but not -2 */
+ else if (fd < 0)
return Qnil;
if (pfd)
*pfd = fd;
@@ -3296,8 +3293,8 @@ image_find_image_fd (Lisp_Object file, int *pfd)
}
/* Find image file FILE. Look in data-directory/images, then
- x-bitmap-file-path. Value is the encoded full name of the file
- found, or nil if not found. */
+ x-bitmap-file-path. Value is the full name of the file found, or
+ nil if not found. */
Lisp_Object
image_find_image_file (Lisp_Object file)
diff --git a/src/keyboard.c b/src/keyboard.c
index b2aabdd..87a9512 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -2254,8 +2254,17 @@ read_decoded_event_from_main_queue (struct timespec
*end_time,
{
int i;
if (meta_key != 2)
- for (i = 0; i < n; i++)
- events[i] = make_fixnum (XFIXNUM (events[i]) & ~0x80);
+ {
+ for (i = 0; i < n; i++)
+ {
+ int c = XFIXNUM (events[i]);
+ int modifier =
+ (meta_key == 3 && c < 0x100 && (c & 0x80))
+ ? meta_modifier
+ : 0;
+ events[i] = make_fixnum ((c & ~0x80) | modifier);
+ }
+ }
}
else
{
@@ -2264,7 +2273,7 @@ read_decoded_event_from_main_queue (struct timespec
*end_time,
int i;
for (i = 0; i < n; i++)
src[i] = XFIXNUM (events[i]);
- if (meta_key != 2)
+ if (meta_key < 2) /* input-meta-mode is t or nil */
for (i = 0; i < n; i++)
src[i] &= ~0x80;
coding->destination = dest;
@@ -2282,7 +2291,18 @@ read_decoded_event_from_main_queue (struct timespec
*end_time,
eassert (coding->carryover_bytes == 0);
n = 0;
while (n < coding->produced_char)
- events[n++] = make_fixnum (string_char_advance (&p));
+ {
+ int c = string_char_advance (&p);
+ if (meta_key == 3)
+ {
+ int modifier
+ = (c < 0x100 && (c & 0x80)
+ ? meta_modifier
+ : 0);
+ c = (c & ~0x80) | modifier;
+ }
+ events[n++] = make_fixnum (c);
+ }
}
}
}
@@ -5021,6 +5041,10 @@ static short const internal_border_parts[] = {
static Lisp_Object button_down_location;
+/* A cons recording the original frame-relative x and y coordinates of
+ the down mouse event. */
+static Lisp_Object frame_relative_event_pos;
+
/* Information about the most recent up-going button event: Which
button, what location, and what time. */
@@ -5672,6 +5696,7 @@ make_lispy_event (struct input_event *event)
double_click_count = 1;
button_down_time = event->timestamp;
*start_pos_ptr = Fcopy_alist (position);
+ frame_relative_event_pos = Fcons (event->x, event->y);
ignore_mouse_drag_p = false;
}
@@ -5694,20 +5719,12 @@ make_lispy_event (struct input_event *event)
ignore_mouse_drag_p = false;
else
{
- Lisp_Object new_down, down;
intmax_t xdiff = double_click_fuzz, ydiff = double_click_fuzz;
- /* The third element of every position
- should be the (x,y) pair. */
- down = Fcar (Fcdr (Fcdr (start_pos)));
- new_down = Fcar (Fcdr (Fcdr (position)));
-
- if (CONSP (down)
- && FIXNUMP (XCAR (down)) && FIXNUMP (XCDR (down)))
- {
- xdiff = XFIXNUM (XCAR (new_down)) - XFIXNUM (XCAR (down));
- ydiff = XFIXNUM (XCDR (new_down)) - XFIXNUM (XCDR (down));
- }
+ xdiff = XFIXNUM (event->x)
+ - XFIXNUM (XCAR (frame_relative_event_pos));
+ ydiff = XFIXNUM (event->y)
+ - XFIXNUM (XCDR (frame_relative_event_pos));
if (! (0 < double_click_fuzz
&& - double_click_fuzz < xdiff
@@ -5724,12 +5741,51 @@ make_lispy_event (struct input_event *event)
a click. But mouse-drag-region completely ignores
this case and it hasn't caused any real problem, so
it's probably OK to ignore it as well. */
- && EQ (Fcar (Fcdr (start_pos)), Fcar (Fcdr (position)))))
+ && (EQ (Fcar (Fcdr (start_pos)),
+ Fcar (Fcdr (position))) /* Same buffer pos */
+ || !EQ (Fcar (start_pos),
+ Fcar (position))))) /* Different window */
{
/* Mouse has moved enough. */
button_down_time = 0;
click_or_drag_modifier = drag_modifier;
}
+ else if (((!EQ (Fcar (start_pos), Fcar (position)))
+ || (!EQ (Fcar (Fcdr (start_pos)),
+ Fcar (Fcdr (position)))))
+ /* Was the down event in a window body? */
+ && FIXNUMP (Fcar (Fcdr (start_pos)))
+ && WINDOW_LIVE_P (Fcar (start_pos))
+ && !NILP (Ffboundp (Qwindow_edges)))
+ /* If the window (etc.) at the mouse position has
+ changed between the down event and the up event,
+ we assume there's been a redisplay between the
+ two events, and we pretend the mouse is still in
+ the old window to prevent a spurious drag event
+ being generated. */
+ {
+ Lisp_Object edges
+ = call4 (Qwindow_edges, Fcar (start_pos), Qt, Qnil, Qt);
+ int new_x = XFIXNUM (Fcar (frame_relative_event_pos));
+ int new_y = XFIXNUM (Fcdr (frame_relative_event_pos));
+
+ /* If the up-event is outside the down-event's
+ window, use coordinates that are within it. */
+ if (new_x < XFIXNUM (Fcar (edges)))
+ new_x = XFIXNUM (Fcar (edges));
+ else if (new_x >= XFIXNUM (Fcar (Fcdr (Fcdr (edges)))))
+ new_x = XFIXNUM (Fcar (Fcdr (Fcdr (edges)))) - 1;
+ if (new_y < XFIXNUM (Fcar (Fcdr (edges))))
+ new_y = XFIXNUM (Fcar (Fcdr (edges)));
+ else if (new_y
+ >= XFIXNUM (Fcar (Fcdr (Fcdr (Fcdr (edges))))))
+ new_y = XFIXNUM (Fcar (Fcdr (Fcdr (Fcdr (edges))))) - 1;
+
+ position = make_lispy_position
+ (XFRAME (event->frame_or_window),
+ make_fixnum (new_x), make_fixnum (new_y),
+ event->timestamp);
+ }
}
/* Don't check is_double; treat this as multiple if the
@@ -7040,7 +7096,7 @@ tty_read_avail_input (struct terminal *terminal,
buf.modifiers = 0;
if (tty->meta_key == 1 && (cbuf[i] & 0x80))
buf.modifiers = meta_modifier;
- if (tty->meta_key != 2)
+ if (tty->meta_key < 2)
cbuf[i] &= ~0x80;
buf.code = cbuf[i];
@@ -11047,7 +11103,10 @@ See also `current-input-mode'. */)
DEFUN ("set-input-meta-mode", Fset_input_meta_mode, Sset_input_meta_mode, 1,
2, 0,
doc: /* Enable or disable 8-bit input on TERMINAL.
If META is t, Emacs will accept 8-bit input, and interpret the 8th
-bit as the Meta modifier.
+bit as the Meta modifier before it decodes the characters.
+
+If META is `encoded', Emacs will interpret the 8th bit of single-byte
+characters after decoding the characters.
If META is nil, Emacs will ignore the top bit, on the assumption it is
parity.
@@ -11076,6 +11135,8 @@ See also `current-input-mode'. */)
new_meta = 0;
else if (EQ (meta, Qt))
new_meta = 1;
+ else if (EQ (meta, Qencoded))
+ new_meta = 3;
else
new_meta = 2;
@@ -11138,6 +11199,8 @@ Second arg FLOW non-nil means use ^S/^Q flow control
for output to terminal
(no effect except in CBREAK mode).
Third arg META t means accept 8-bit input (for a Meta key).
META nil means ignore the top bit, on the assumption it is parity.
+ META `encoded' means accept 8-bit input and interpret Meta after
+ decoding the input characters.
Otherwise, accept 8-bit input and don't use the top bit for Meta.
Optional fourth arg QUIT if non-nil specifies character to use for quitting.
See also `current-input-mode'. */)
@@ -11158,9 +11221,12 @@ The value is a list of the form (INTERRUPT FLOW META
QUIT), where
nil, Emacs is using CBREAK mode.
FLOW is non-nil if Emacs uses ^S/^Q flow control for output to the
terminal; this does not apply if Emacs uses interrupt-driven input.
- META is t if accepting 8-bit input with 8th bit as Meta flag.
- META nil means ignoring the top bit, on the assumption it is parity.
- META is neither t nor nil if accepting 8-bit input and using
+ META is t if accepting 8-bit unencoded input with 8th bit as Meta flag.
+ META is `encoded' if accepting 8-bit encoded input with 8th bit as
+ Meta flag which has to be interpreted after decoding the input.
+ META is nil if ignoring the top bit of input, on the assumption that
+ it is a parity bit.
+ META is neither t nor nil if accepting 8-bit input and using
all 8 bits as the character code.
QUIT is the character Emacs currently uses to quit.
The elements of this list correspond to the arguments of
@@ -11176,7 +11242,9 @@ The elements of this list correspond to the arguments of
flow = FRAME_TTY (sf)->flow_control ? Qt : Qnil;
meta = (FRAME_TTY (sf)->meta_key == 2
? make_fixnum (0)
- : (CURTTY ()->meta_key == 1 ? Qt : Qnil));
+ : (CURTTY ()->meta_key == 1
+ ? Qt
+ : (CURTTY ()->meta_key == 3 ? Qencoded : Qnil)));
}
else
{
@@ -11653,6 +11721,7 @@ syms_of_keyboard (void)
DEFSYM (Qmake_frame_visible, "make-frame-visible");
DEFSYM (Qselect_window, "select-window");
DEFSYM (Qselection_request, "selection-request");
+ DEFSYM (Qwindow_edges, "window-edges");
{
int i;
@@ -11666,9 +11735,11 @@ syms_of_keyboard (void)
}
}
DEFSYM (Qno_record, "no-record");
+ DEFSYM (Qencoded, "encoded");
button_down_location = make_nil_vector (5);
staticpro (&button_down_location);
+ staticpro (&frame_relative_event_pos);
mouse_syms = make_nil_vector (5);
staticpro (&mouse_syms);
wheel_syms = make_nil_vector (ARRAYELTS (lispy_wheel_names));
@@ -12273,7 +12344,10 @@ Called with three arguments:
- the error data, a list of the form (SIGNALED-CONDITION . SIGNAL-DATA)
such as what `condition-case' would bind its variable to,
- the context (a string which normally goes at the start of the message),
-- the Lisp function within which the error was signaled. */);
+- the Lisp function within which the error was signaled.
+
+Also see `set-message-function' (which controls how non-error messages
+are displayed). */);
Vcommand_error_function = intern ("command-error-default-function");
DEFVAR_LISP ("enable-disabled-menus-and-buttons",
diff --git a/src/minibuf.c b/src/minibuf.c
index cffb7fe..00069ea 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -2385,7 +2385,7 @@ default top level value is used. */);
Vminibuffer_setup_hook = Qnil;
DEFVAR_LISP ("minibuffer-exit-hook", Vminibuffer_exit_hook,
- doc: /* Normal hook run just after exit from minibuffer. */);
+ doc: /* Normal hook run whenever a minibuffer is exited. */);
Vminibuffer_exit_hook = Qnil;
DEFVAR_LISP ("history-length", Vhistory_length,
diff --git a/src/nsfns.m b/src/nsfns.m
index d14f7b5..454a6fd 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -1953,8 +1953,11 @@ DEFUN ("ns-hide-emacs", Fns_hide_emacs, Sns_hide_emacs,
doc: /* If ON is non-nil, the entire Emacs application is hidden.
Otherwise if Emacs is hidden, it is unhidden.
If ON is equal to `activate', Emacs is unhidden and becomes
-the active application. */)
- (Lisp_Object on)
+the active application.
+If ON is equal to `activate-front', Emacs is unhidden and
+becomes the active application, but only the selected frame
+is layered in front of the windows of other applications. */)
+ (Lisp_Object on)
{
check_window_system (NULL);
if (EQ (on, intern ("activate")))
@@ -1962,6 +1965,12 @@ the active application. */)
[NSApp unhide: NSApp];
[NSApp activateIgnoringOtherApps: YES];
}
+ else if (EQ (on, intern ("activate-front")))
+ {
+ [NSApp unhide: NSApp];
+ [[NSRunningApplication currentApplication]
+ activateWithOptions: NSApplicationActivateIgnoringOtherApps];
+ }
else if (NILP (on))
[NSApp unhide: NSApp];
else
@@ -3024,7 +3033,8 @@ all_nonzero_ascii (unsigned char *str, ptrdiff_t n)
}
@implementation NSString (EmacsString)
-/* Make an NSString from a Lisp string. */
+/* Make an NSString from a Lisp string. STRING must not be in an
+ encoded form (e.g. UTF-8). */
+ (NSString *)stringWithLispString:(Lisp_Object)string
{
/* Shortcut for the common case. */
diff --git a/src/nsimage.m b/src/nsimage.m
index fa81a41..3c16cd3 100644
--- a/src/nsimage.m
+++ b/src/nsimage.m
@@ -254,15 +254,15 @@ ns_image_size_in_bytes (void *img)
NSImageRep *imgRep;
Lisp_Object found;
EmacsImage *image;
+ NSString *filename;
/* Search bitmap-file-path for the file, if appropriate. */
found = image_find_image_file (file);
if (!STRINGP (found))
return nil;
- found = ENCODE_FILE (found);
+ filename = [NSString stringWithLispString:found];
- image = [[EmacsImage alloc] initByReferencingFile:
- [NSString stringWithLispString: found]];
+ image = [[EmacsImage alloc] initByReferencingFile:filename];
image->bmRep = nil;
#ifdef NS_IMPL_COCOA
@@ -277,8 +277,7 @@ ns_image_size_in_bytes (void *img)
}
[image setSize: NSMakeSize([imgRep pixelsWide], [imgRep pixelsHigh])];
-
- [image setName: [NSString stringWithLispString: file]];
+ [image setName:filename];
return image;
}
diff --git a/src/nsterm.h b/src/nsterm.h
index 017c239..e7ea907 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -443,7 +443,6 @@ typedef id instancetype;
int maximized_width, maximized_height;
NSWindow *nonfs_window;
BOOL fs_is_native;
- BOOL in_fullscreen_transition;
#ifdef NS_DRAW_TO_BUFFER
EmacsSurface *surface;
#endif
@@ -475,8 +474,6 @@ typedef id instancetype;
- (void) toggleFullScreen: (id) sender;
- (BOOL) fsIsNative;
- (BOOL) isFullscreen;
-- (BOOL) inFullScreenTransition;
-- (void) waitFullScreenTransition;
#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
- (void) updateCollectionBehavior;
#endif
@@ -724,8 +721,9 @@ typedef id instancetype;
IOSurfaceRef currentSurface;
IOSurfaceRef lastSurface;
CGContextRef context;
+ CGFloat scale;
}
-- (id) initWithSize: (NSSize)s ColorSpace: (CGColorSpaceRef)cs;
+- (id) initWithSize: (NSSize)s ColorSpace: (CGColorSpaceRef)cs Scale:
(CGFloat)scale;
- (void) dealloc;
- (NSSize) getSize;
- (CGContextRef) getContext;
diff --git a/src/nsterm.m b/src/nsterm.m
index bb20886..838c14d 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -1640,8 +1640,6 @@ ns_make_frame_visible (struct frame *f)
fullscreen also. So skip handleFS as this will print an error. */
if ([view fsIsNative] && [view isFullscreen])
{
- // maybe it is not necessary to wait
- [view waitFullScreenTransition];
return;
}
@@ -2057,11 +2055,7 @@ ns_set_parent_frame (struct frame *f, Lisp_Object
new_value, Lisp_Object old_val
#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
// child frame must not be in fullscreen
if ([view fsIsNative] && [view isFullscreen])
- {
- // in case child is going fullscreen
- [view waitFullScreenTransition];
- [view toggleFullScreen:child];
- }
+ [view toggleFullScreen:child];
NSTRACE ("child
setCollectionBehavior:NSWindowCollectionBehaviorFullScreenAuxiliary");
[child
setCollectionBehavior:NSWindowCollectionBehaviorFullScreenAuxiliary];
#endif
@@ -7489,7 +7483,6 @@ not_in_argv (NSString *arg)
#endif
fs_is_native = ns_use_native_fullscreen;
#endif
- in_fullscreen_transition = NO;
maximized_width = maximized_height = -1;
nonfs_window = nil;
@@ -7862,7 +7855,6 @@ not_in_argv (NSString *arg)
- (void)windowWillEnterFullScreen:(NSNotification *)notification
{
NSTRACE ("[EmacsView windowWillEnterFullScreen:]");
- in_fullscreen_transition = YES;
[self windowWillEnterFullScreen];
}
- (void)windowWillEnterFullScreen /* provided for direct calls */
@@ -7875,7 +7867,6 @@ not_in_argv (NSString *arg)
{
NSTRACE ("[EmacsView windowDidEnterFullScreen:]");
[self windowDidEnterFullScreen];
- in_fullscreen_transition = NO;
}
- (void)windowDidEnterFullScreen /* provided for direct calls */
@@ -7914,7 +7905,6 @@ not_in_argv (NSString *arg)
- (void)windowWillExitFullScreen:(NSNotification *)notification
{
NSTRACE ("[EmacsView windowWillExitFullScreen:]");
- in_fullscreen_transition = YES;
[self windowWillExitFullScreen];
}
@@ -7934,7 +7924,6 @@ not_in_argv (NSString *arg)
{
NSTRACE ("[EmacsView windowDidExitFullScreen:]");
[self windowDidExitFullScreen];
- in_fullscreen_transition = NO;
}
- (void)windowDidExitFullScreen /* provided for direct calls */
@@ -7963,22 +7952,6 @@ not_in_argv (NSString *arg)
[[self window] performZoom:self];
}
-- (BOOL)inFullScreenTransition
-{
- return in_fullscreen_transition;
-}
-
-- (void)waitFullScreenTransition
-{
-#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
- while ([self inFullScreenTransition])
- {
- NSTRACE ("wait for fullscreen");
- wait_reading_process_output (0, 300000000, 0, 1, Qnil, NULL, 0);
- }
-#endif
-}
-
- (BOOL)fsIsNative
{
return fs_is_native;
@@ -8058,14 +8031,8 @@ not_in_argv (NSString *arg)
#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070
if ([[self window] respondsToSelector: @selector(toggleFullScreen:)])
- {
-#endif
- [[self window] toggleFullScreen:sender];
- // wait for fullscreen animation complete (bug#28496)
- [self waitFullScreenTransition];
-#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070
- }
#endif
+ [[self window] toggleFullScreen:sender];
#endif
return;
}
@@ -8353,19 +8320,17 @@ not_in_argv (NSString *arg)
surface = [[EmacsSurface alloc] initWithSize:s
ColorSpace:[[[self window] colorSpace]
- CGColorSpace]];
+ CGColorSpace]
+ Scale:scale];
/* Since we're using NSViewLayerContentsRedrawOnSetNeedsDisplay
the layer's scale factor is not set automatically, so do it
now. */
- [[self layer] setContentsScale:[[self window] backingScaleFactor]];
+ [[self layer] setContentsScale:scale];
}
CGContextRef context = [surface getContext];
- CGContextTranslateCTM(context, 0, [surface getSize].height);
- CGContextScaleCTM(context, scale, -scale);
-
[NSGraphicsContext
setCurrentContext:[NSGraphicsContext
graphicsContextWithCGContext:context
@@ -8378,7 +8343,6 @@ not_in_argv (NSString *arg)
NSTRACE ("[EmacsView unfocusDrawingBuffer]");
[NSGraphicsContext setCurrentContext:nil];
- [surface releaseContext];
[self setNeedsDisplay:YES];
}
@@ -8516,7 +8480,11 @@ not_in_argv (NSString *arg)
There's a private method, -[CALayer setContentsChanged], that we
could use to force it, but we shouldn't often get the same
surface twice in a row. */
+ [surface releaseContext];
[[self layer] setContents:(id)[surface getSurface]];
+ [surface performSelectorOnMainThread:@selector (getContext)
+ withObject:nil
+ waitUntilDone:NO];
}
#endif
@@ -9717,17 +9685,20 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
probably be some sort of pruning job that removes excess
surfaces. */
+#define CACHE_MAX_SIZE 2
- (id) initWithSize: (NSSize)s
ColorSpace: (CGColorSpaceRef)cs
+ Scale: (CGFloat)scl
{
NSTRACE ("[EmacsSurface initWithSize:ColorSpace:]");
[super init];
- cache = [[NSMutableArray arrayWithCapacity:3] retain];
+ cache = [[NSMutableArray arrayWithCapacity:CACHE_MAX_SIZE] retain];
size = s;
colorSpace = cs;
+ scale = scl;
return self;
}
@@ -9740,8 +9711,6 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
if (currentSurface)
CFRelease (currentSurface);
- if (lastSurface)
- CFRelease (lastSurface);
for (id object in cache)
CFRelease ((IOSurfaceRef)object);
@@ -9764,50 +9733,66 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
calls cannot be nested. */
- (CGContextRef) getContext
{
- IOSurfaceRef surface = NULL;
-
- NSTRACE ("[EmacsSurface getContextWithSize:]");
- NSTRACE_MSG ("IOSurface count: %lu", [cache count] + (lastSurface ? 1 : 0));
+ NSTRACE ("[EmacsSurface getContext]");
- for (id object in cache)
+ if (!context)
{
- if (!IOSurfaceIsInUse ((IOSurfaceRef)object))
- {
- surface = (IOSurfaceRef)object;
- [cache removeObject:object];
- break;
- }
- }
+ IOSurfaceRef surface = NULL;
- if (!surface)
- {
- int bytesPerRow = IOSurfaceAlignProperty (kIOSurfaceBytesPerRow,
- size.width * 4);
+ NSTRACE_MSG ("IOSurface count: %lu", [cache count] + (lastSurface ? 1 :
0));
- surface = IOSurfaceCreate
- ((CFDictionaryRef)@{(id)kIOSurfaceWidth:[NSNumber
numberWithInt:size.width],
- (id)kIOSurfaceHeight:[NSNumber numberWithInt:size.height],
- (id)kIOSurfaceBytesPerRow:[NSNumber numberWithInt:bytesPerRow],
- (id)kIOSurfaceBytesPerElement:[NSNumber numberWithInt:4],
- (id)kIOSurfacePixelFormat:[NSNumber
numberWithUnsignedInt:'BGRA']});
- }
+ for (id object in cache)
+ {
+ if (!IOSurfaceIsInUse ((IOSurfaceRef)object))
+ {
+ surface = (IOSurfaceRef)object;
+ [cache removeObject:object];
+ break;
+ }
+ }
- IOReturn lockStatus = IOSurfaceLock (surface, 0, nil);
- if (lockStatus != kIOReturnSuccess)
- NSLog (@"Failed to lock surface: %x", lockStatus);
+ if (!surface && [cache count] >= CACHE_MAX_SIZE)
+ {
+ /* Just grab the first one off the cache. This may result
+ in tearing effects. The alternative is to wait for one
+ of the surfaces to become free. */
+ surface = (IOSurfaceRef)[cache firstObject];
+ [cache removeObject:(id)surface];
+ }
+ else if (!surface)
+ {
+ int bytesPerRow = IOSurfaceAlignProperty (kIOSurfaceBytesPerRow,
+ size.width * 4);
+
+ surface = IOSurfaceCreate
+ ((CFDictionaryRef)@{(id)kIOSurfaceWidth:[NSNumber
numberWithInt:size.width],
+ (id)kIOSurfaceHeight:[NSNumber numberWithInt:size.height],
+ (id)kIOSurfaceBytesPerRow:[NSNumber numberWithInt:bytesPerRow],
+ (id)kIOSurfaceBytesPerElement:[NSNumber numberWithInt:4],
+ (id)kIOSurfacePixelFormat:[NSNumber
numberWithUnsignedInt:'BGRA']});
+ }
+
+ IOReturn lockStatus = IOSurfaceLock (surface, 0, nil);
+ if (lockStatus != kIOReturnSuccess)
+ NSLog (@"Failed to lock surface: %x", lockStatus);
- [self copyContentsTo:surface];
+ [self copyContentsTo:surface];
- currentSurface = surface;
+ currentSurface = surface;
+
+ context = CGBitmapContextCreate (IOSurfaceGetBaseAddress
(currentSurface),
+ IOSurfaceGetWidth (currentSurface),
+ IOSurfaceGetHeight (currentSurface),
+ 8,
+ IOSurfaceGetBytesPerRow
(currentSurface),
+ colorSpace,
+ (kCGImageAlphaPremultipliedFirst
+ | kCGBitmapByteOrder32Host));
+
+ CGContextTranslateCTM(context, 0, size.height);
+ CGContextScaleCTM(context, scale, -scale);
+ }
- context = CGBitmapContextCreate (IOSurfaceGetBaseAddress (currentSurface),
- IOSurfaceGetWidth (currentSurface),
- IOSurfaceGetHeight (currentSurface),
- 8,
- IOSurfaceGetBytesPerRow (currentSurface),
- colorSpace,
- (kCGImageAlphaPremultipliedFirst
- | kCGBitmapByteOrder32Host));
return context;
}
@@ -9818,6 +9803,9 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
{
NSTRACE ("[EmacsSurface releaseContextAndGetSurface]");
+ if (!context)
+ return;
+
CGContextRelease (context);
context = NULL;
@@ -9825,11 +9813,8 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
if (lockStatus != kIOReturnSuccess)
NSLog (@"Failed to unlock surface: %x", lockStatus);
- /* Put lastSurface back on the end of the cache. It may not have
- been displayed on the screen yet, but we probably want the new
- data and not some stale data anyway. */
- if (lastSurface)
- [cache addObject:(id)lastSurface];
+ /* Put currentSurface back on the end of the cache. */
+ [cache addObject:(id)currentSurface];
lastSurface = currentSurface;
currentSurface = NULL;
}
@@ -9854,7 +9839,7 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
NSTRACE ("[EmacsSurface copyContentsTo:]");
- if (! lastSurface)
+ if (!lastSurface || lastSurface == destination)
return;
lockStatus = IOSurfaceLock (lastSurface, kIOSurfaceLockReadOnly, nil);
@@ -9874,6 +9859,7 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
NSLog (@"Failed to unlock source surface: %x", lockStatus);
}
+#undef CACHE_MAX_SIZE
@end /* EmacsSurface */
diff --git a/src/window.c b/src/window.c
index 9961c54..db324ef 100644
--- a/src/window.c
+++ b/src/window.c
@@ -468,6 +468,7 @@ Return WINDOW. */)
else
{
fset_selected_window (XFRAME (frame), window);
+ /* Don't clear FRAME's select_mini_window_flag here. */
return window;
}
}
@@ -517,6 +518,9 @@ select_window (Lisp_Object window, Lisp_Object norecord,
/* Do not select a tooltip window (Bug#47207). */
error ("Cannot select a tooltip window");
+ /* We deinitely want to select WINDOW, not the mini-window. */
+ f->select_mini_window_flag = false;
+
/* Make the selected window's buffer current. */
Fset_buffer (w->contents);
@@ -3242,6 +3246,9 @@ window-start value is reasonable when this function is
called. */)
if (EQ (selected_frame, w->frame))
Fselect_window (window, Qnil);
else
+ /* Do not clear f->select_mini_window_flag here. If the
+ last selected window on F was an active minibuffer, we
+ want to return to it on a later Fselect_frame. */
fset_selected_window (f, window);
}
}
@@ -5141,37 +5148,23 @@ Signal an error when WINDOW is the only window on its
frame. */)
adjust_frame_glyphs (f);
if (!WINDOW_LIVE_P (FRAME_SELECTED_WINDOW (f)))
- /* We deleted the frame's selected window. */
+ /* We apparently deleted the frame's selected window; use the
+ frame's first window as substitute but don't record it yet.
+ `delete-window' may have something better up its sleeves. */
{
/* Use the frame's first window as fallback ... */
Lisp_Object new_selected_window = Fframe_first_window (frame);
- /* ... but preferably use its most recently used window. */
- Lisp_Object mru_window;
- /* `get-mru-window' might fail for some reason so play it safe
- - promote the first window _without recording it_ first. */
if (EQ (FRAME_SELECTED_WINDOW (f), selected_window))
Fselect_window (new_selected_window, Qt);
else
- fset_selected_window (f, new_selected_window);
-
- unblock_input ();
-
- /* Now look whether `get-mru-window' gets us something. */
- mru_window = call1 (Qget_mru_window, frame);
- if (WINDOW_LIVE_P (mru_window)
- && EQ (XWINDOW (mru_window)->frame, frame))
- new_selected_window = mru_window;
-
- /* If all ended up well, we now promote the mru window. */
- if (EQ (FRAME_SELECTED_WINDOW (f), selected_window))
- Fselect_window (new_selected_window, Qnil);
- else
+ /* Do not clear f->select_mini_window_flag here. If the
+ last selected window on F was an active minibuffer, we
+ want to return to it on a later Fselect_frame. */
fset_selected_window (f, new_selected_window);
}
- else
- unblock_input ();
+ unblock_input ();
FRAME_WINDOW_CHANGE (f) = true;
}
else
diff --git a/src/xdisp.c b/src/xdisp.c
index 74fa0a5..e95e64a 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -10795,6 +10795,9 @@ include the height of both, if present, in the return
value. */)
it.max_descent = max (it.max_descent, it.descent);
}
}
+ else
+ bidi_unshelve_cache (it2data, true);
+
if (!NILP (x_limit))
{
/* Don't return more than X-LIMIT. */
@@ -22386,15 +22389,23 @@ extend_face_to_end_of_line (struct it *it)
it->face_id = (it->glyph_row->ends_at_zv_p ?
default_face->id : face->id);
- /* Display fill-column indicator if needed. */
- const int indicator_column = fill_column_indicator_column (it, 1);
-
/* Make sure our idea of current_x is in sync with the glyphs
actually in the glyph row. They might differ because
append_space_for_newline can insert one glyph without
updating current_x. */
it->current_x = it->glyph_row->used[TEXT_AREA];
+ /* The above assignment causes the code below to use a
+ non-standard semantics of it->current_x: it is measured
+ relative to the beginning of the text-area, thus disregarding
+ the window's hscroll. That is why we need to correct the
+ indicator column for the hscroll, otherwise the indicator
+ will not move together with the text as result of horizontal
+ scrolling. */
+ const int indicator_column =
+ fill_column_indicator_column (it, 1) - it->first_visible_x;
+
+ /* Display fill-column indicator if needed. */
while (it->current_x <= it->last_visible_x)
{
if (it->current_x != indicator_column)
@@ -30305,7 +30316,7 @@ produce_glyphless_glyph (struct it *it, bool
for_no_font, Lisp_Object acronym)
/* +4 is for vertical bars of a box plus 1-pixel spaces at both side. */
width = max (metrics_upper.width, metrics_lower.width) + 4;
- upper_xoff = upper_yoff = 2; /* the typical case */
+ upper_xoff = lower_xoff = 2; /* the typical case */
if (base_width >= width)
{
/* Align the upper to the left, the lower to the right. */
@@ -30319,13 +30330,7 @@ produce_glyphless_glyph (struct it *it, bool
for_no_font, Lisp_Object acronym)
if (metrics_upper.width >= metrics_lower.width)
lower_xoff = (width - metrics_lower.width) / 2;
else
- {
- /* FIXME: This code doesn't look right. It formerly was
- missing the "lower_xoff = 0;", which couldn't have
- been right since it left lower_xoff uninitialized. */
- lower_xoff = 0;
- upper_xoff = (width - metrics_upper.width) / 2;
- }
+ upper_xoff = (width - metrics_upper.width) / 2;
}
/* +5 is for horizontal bars of a box plus 1-pixel spaces at
@@ -35660,8 +35665,10 @@ as usual. If the function returns a string, the
returned string is
displayed in the echo area. If this function returns any other non-nil
value, this means that the message was already handled, and the original
message text will not be displayed in the echo area.
-See also `clear-message-function' that can be used to clear the
-message displayed by this function. */);
+
+Also see `clear-message-function' (which can be used to clear the
+message displayed by this function), and `command-error-function'
+(which controls how error messages are displayed). */);
Vset_message_function = Qnil;
DEFVAR_LISP ("clear-message-function", Vclear_message_function,
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-22355.pl
b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-22355.pl
new file mode 100644
index 0000000..f54d552
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-22355.pl
@@ -0,0 +1,14 @@
+# The source file contains non-ASCII characters, supposed to be saved
+# in UTF-8 encoding. Tell Perl about that, just in case.
+use utf8;
+
+# Following code is the example from the report Bug#22355 which needed
+# attention in perl-mode.
+
+printf qq
+{<?xml version="1.0" encoding="UTF-8"?>
+<kml xmlns="http://www.opengis.net/kml/2.2";>
+ <Document>
+ <Folder><name>台灣 %s 廣播電台</name>
+ <description><![CDATA[http://radioscanningtw.wikia.com/wiki/台描:地圖
%d-%02d-%02d]]></description>
+}, uc( substr( $ARGV[0], 0, 2 ) ), $year + 1900, $mon + 1, $mday;
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-23992.pl
b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-23992.pl
new file mode 100644
index 0000000..1db639c
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-23992.pl
@@ -0,0 +1,10 @@
+# Test file for Bug#23992
+#
+# The "||" case is directly from the report,
+# the "&&" case has been added for symmetry.
+
+s/LEFT/L/g || s/RIGHT/R/g || s/aVALUE\D+//g;
+s/LEFT/L/g||s/RIGHT/R/g||s/aVALUE\D+//g;
+
+s/LEFT/L/g && s/RIGHT/R/g && s/aVALUE\D+//g;
+s/LEFT/L/g&&s/RIGHT/R/g&&s/aVALUE\D+//g;
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-25098.pl
b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-25098.pl
new file mode 100644
index 0000000..0987b4e
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-25098.pl
@@ -0,0 +1,21 @@
+# Code from the bug report Bug#25098
+
+my $good = XML::LibXML->load_xml( string => q{<div class="clearfix">});
+my $bad = XML::LibXML->load_xml( string =>q{<div class="clearfix">});
+
+# Related: Method calls are no quotelike operators. That's why you
+# can't just add '>' to the character class.
+
+my $method_call = $object->q(argument);
+
+# Also related, still not fontified correctly:
+#
+# my $method_call = $object -> q (argument);
+#
+# perl-mode interprets the method call as a quotelike op (because it
+# is preceded by a space).
+# cperl-mode gets the argument right, but marks q as a quotelike op.
+#
+# my $greater = 2>q/1/;
+#
+# perl-mode doesn't identify this as a quotelike op.
diff --git a/test/lisp/progmodes/cperl-mode-tests.el
b/test/lisp/progmodes/cperl-mode-tests.el
index 7cdfa45..4d2bac6 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -37,7 +37,7 @@
;;; Utilities
(defun cperl-test-ppss (text regexp)
- "Return the `syntax-ppss' of the first character matched by REGEXP in TEXT."
+ "Return the `syntax-ppss' after the last character matched by REGEXP in
TEXT."
(interactive)
(with-temp-buffer
(insert text)
@@ -377,6 +377,55 @@ documentation it does the right thing anyway."
(cperl-indent-command)
(forward-line 1))))
+(ert-deftest cperl-test-bug-22355 ()
+ "Verify that substitutions are fontified directly after \"|&\".
+Regular expressions are strings in both perl-mode and cperl-mode."
+ (with-temp-buffer
+ (insert-file-contents (ert-resource-file "cperl-bug-22355.pl"))
+ (funcall cperl-test-mode)
+ (goto-char (point-min))
+ ;; Just check for the start of the string
+ (search-forward "{")
+ (should (nth 3 (syntax-ppss)))))
+
+(ert-deftest cperl-test-bug-23992 ()
+ "Verify that substitutions are fontified directly after \"|&\".
+Regular expressions are strings in both perl-mode and cperl-mode."
+ (with-temp-buffer
+ (insert-file-contents (ert-resource-file "cperl-bug-23992.pl"))
+ (funcall cperl-test-mode)
+ (goto-char (point-min))
+ ;; "or" operator, with spaces
+ (search-forward "RIGHT")
+ (should (nth 3 (syntax-ppss)))
+ ;; "or" operator, without spaces
+ (search-forward "RIGHT")
+ (should (nth 3 (syntax-ppss)))
+ ;; "and" operator, with spaces
+ (search-forward "RIGHT")
+ (should (nth 3 (syntax-ppss)))
+ ;; "and" operator, without spaces
+ (search-forward "RIGHT")
+ (should (nth 3 (syntax-ppss)))))
+
+(ert-deftest cperl-test-bug-25098 ()
+ "Verify that a quotelike operator is recognized after a fat comma \"=>\".
+Related, check that calling a method named q is not mistaken as a
+quotelike operator."
+ (with-temp-buffer
+ (insert-file-contents (ert-resource-file "cperl-bug-25098.pl"))
+ (funcall cperl-test-mode)
+ (goto-char (point-min))
+ ;; good example from the bug report, with a space
+ (search-forward "q{")
+ (should (nth 3 (syntax-ppss)))
+ ;; bad (but now fixed) example from the bug report, without space
+ (search-forward "q{")
+ (should (nth 3 (syntax-ppss)))
+ ;; calling a method "q" (parens instead of braces to make it valid)
+ (search-forward "q(")
+ (should-not (nth 3 (syntax-ppss)))))
+
(ert-deftest cperl-test-bug-28650 ()
"Verify that regular expressions are recognized after 'return'.
The test uses the syntax property \"inside a string\" for the
@@ -448,14 +497,14 @@ If seen as regular expression, then the slash is
displayed using
font-lock-constant-face. If seen as a division, then it doesn't
have a face property."
:tags '(:fontification)
- ;; The next two Perl expressions have divisions. Perl "punctuation"
- ;; operators don't get a face.
+ ;; The next two Perl expressions have divisions. The slash does not
+ ;; start a string.
(let ((code "{ $a++ / $b }"))
(should (equal (nth 8 (cperl-test-ppss code "/")) nil)))
(let ((code "{ $a-- / $b }"))
(should (equal (nth 8 (cperl-test-ppss code "/")) nil)))
- ;; The next two Perl expressions have regular expressions. The
- ;; delimiter of a RE is fontified with font-lock-constant-face.
+ ;; The next two Perl expressions have regular expressions. The slash
+ ;; starts a string.
(let ((code "{ $a+ / $b } # /"))
(should (equal (nth 8 (cperl-test-ppss code "/")) 7)))
(let ((code "{ $a- / $b } # /"))
diff --git a/test/lisp/progmodes/octave-tests.el
b/test/lisp/progmodes/octave-tests.el
new file mode 100644
index 0000000..e28fe73
--- /dev/null
+++ b/test/lisp/progmodes/octave-tests.el
@@ -0,0 +1,49 @@
+;;; octave-tests.el --- Test suite for octave.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'octave)
+
+(defun octave-test--indent (string)
+ (with-temp-buffer
+ (octave-mode)
+ (insert string)
+ (indent-region (point-min) (point-max))
+ (buffer-string)))
+
+(ert-deftest octave-tests--continuation-indentation ()
+ (should
+ (equal (octave-test--indent "a = b + a * \\
+c;
+")
+ "a = b + a * \\
+ c;
+"))
+ (should (equal (octave-test--indent "a = \\
+b;
+")
+ "a = \\
+ b;
+")))
+
+;;; octave-tests.el ends here
diff --git a/test/lisp/progmodes/xref-tests.el
b/test/lisp/progmodes/xref-tests.el
index 66099dc..d294522 100644
--- a/test/lisp/progmodes/xref-tests.el
+++ b/test/lisp/progmodes/xref-tests.el
@@ -117,18 +117,14 @@
(should (null (marker-position (cdr (nth 0 (cdr cons2))))))))
(ert-deftest xref--xref-file-name-display-is-abs ()
- (let* ((xref-file-name-display 'abs)
- ;; Some older BSD find versions can produce '//' in the output.
- (expected (list
- (concat xref-tests--data-dir "/?file1.txt")
- (concat xref-tests--data-dir "/?file2.txt")))
- (actual (delete-dups
- (mapcar 'xref-location-group
- (xref-tests--locations-in-data-dir
"\\(bar\\|foo\\)")))))
- (should (= (length expected) (length actual)))
- (should (cl-every (lambda (e1 e2)
- (string-match-p e1 e2))
- expected actual))))
+ (let ((xref-file-name-display 'abs))
+ (should (equal
+ (delete-dups
+ (mapcar 'xref-location-group
+ (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)")))
+ (list
+ (concat xref-tests--data-dir "file1.txt")
+ (concat xref-tests--data-dir "file2.txt"))))))
(ert-deftest xref--xref-file-name-display-is-nondirectory ()
(let ((xref-file-name-display 'nondirectory))
@@ -144,17 +140,13 @@
(file-name-directory (directory-file-name xref-tests--data-dir)))
(project-find-functions
(lambda (_) (cons 'transient data-parent-dir)))
- (xref-file-name-display 'project-relative)
- ;; Some older BSD find versions can produce '//' in the output.
- (expected (list
- "xref-resources//?file1.txt"
- "xref-resources//?file2.txt"))
- (actual (delete-dups
- (mapcar 'xref-location-group
- (xref-tests--locations-in-data-dir
"\\(bar\\|foo\\)")))))
- (should (and (= (length expected) (length actual))
- (cl-every (lambda (e1 e2)
- (string-match-p e1 e2))
- expected actual)))))
+ (xref-file-name-display 'project-relative))
+ (should (equal
+ (delete-dups
+ (mapcar 'xref-location-group
+ (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)")))
+ (list
+ "xref-resources/file1.txt"
+ "xref-resources/file2.txt")))))
;;; xref-tests.el ends here
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 1e14673..375251c 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -684,5 +684,15 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350.";
(should (>= (length (apropos-internal "^help" #'commandp)) 15))
(should-not (apropos-internal "^next-line$" #'keymapp)))
+
+(ert-deftest test-buffer-local-boundp ()
+ (let ((buf (generate-new-buffer "boundp")))
+ (with-current-buffer buf
+ (setq-local test-boundp t))
+ (setq test-global-boundp t)
+ (should (buffer-local-boundp 'test-boundp buf))
+ (should-not (buffer-local-boundp 'test-not-boundp buf))
+ (should (buffer-local-boundp 'test-global-boundp buf))))
+
(provide 'subr-tests)
;;; subr-tests.el ends here
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el
index 4ae3c19..b42271e 100644
--- a/test/lisp/time-stamp-tests.el
+++ b/test/lisp/time-stamp-tests.el
@@ -486,7 +486,10 @@
"Test time-stamp format %Y."
(with-time-stamp-test-env
;; implemented since 1997, documented since 2019
- (should (equal (time-stamp-string "%Y" ref-time1) "2006"))))
+ (should (equal (time-stamp-string "%Y" ref-time1) "2006"))
+ ;; numbers do not truncate
+ (should (equal (time-stamp-string "%2Y" ref-time1) "2006"))
+ (should (equal (time-stamp-string "%02Y" ref-time1) "2006"))))
(ert-deftest time-stamp-format-am-pm ()
"Test time-stamp formats for AM and PM strings."
@@ -522,7 +525,7 @@
(should (equal (time-stamp-string "%#Z" ref-time1) utc-abbr)))))
(ert-deftest time-stamp-format-time-zone-offset ()
- "Test time-stamp format %z."
+ "Tests time-stamp legacy format %z and new offset format %5z."
(with-time-stamp-test-env
(let ((utc-abbr (format-time-string "%#Z" ref-time1 t)))
;; documented 1995-2019, warned since 2019, will change
@@ -541,6 +544,7 @@
(should (equal (time-stamp-string "%_z" ref-time1) "+0000"))
(should (equal (time-stamp-string "%:z" ref-time1) "+00:00"))
(should (equal (time-stamp-string "%::z" ref-time1) "+00:00:00"))
+ (should (equal (time-stamp-string "%9::z" ref-time1) "+00:00:00"))
(should (equal (time-stamp-string "%:::z" ref-time1) "+00"))))
(ert-deftest time-stamp-format-non-date-conversions ()
@@ -586,6 +590,9 @@
(should (equal (time-stamp-string "%(st(u)ff)B" ref-time3) May))
;; escaped parens do not change the nesting level
(should (equal (time-stamp-string "%(st\\)u\\(ff)B" ref-time3) May))
+ ;; incorrectly nested parens do not crash us
+ (should-not (equal (time-stamp-string "%(stuffB" ref-time3) May))
+ (should-not (equal (time-stamp-string "%)B" ref-time3) May))
;; not all punctuation is allowed
(should-not (equal (time-stamp-string "%&B" ref-time3) May)))))
@@ -594,6 +601,33 @@
(with-time-stamp-test-env
(should (equal (time-stamp-string "No percent" ref-time1) "No percent"))))
+(ert-deftest time-stamp-format-multiple-conversions ()
+ "Tests that multiple %-conversions are independent."
+ (with-time-stamp-test-env
+ (let ((Mon (format-time-string "%a" ref-time1 t))
+ (MON (format-time-string "%^a" ref-time1 t))
+ (Monday (format-time-string "%A" ref-time1 t)))
+ ;; change-case flag is independent
+ (should (equal (time-stamp-string "%a.%#a.%a" ref-time1)
+ (concat Mon "." MON "." Mon)))
+ ;; up-case flag is independent
+ (should (equal (time-stamp-string "%a.%^a.%a" ref-time1)
+ (concat Mon "." MON "." Mon)))
+ ;; underscore flag is independent
+ (should (equal (time-stamp-string "%_d.%d.%_d" ref-time1) " 2.02. 2"))
+ ;; minus flag is independendent
+ (should (equal (time-stamp-string "%d.%-d.%d" ref-time1) "02.2.02"))
+ ;; 0 flag is independendent
+ (should (equal (time-stamp-string "%2d.%02d.%2d" ref-time1) " 2.02. 2"))
+ ;; field width is independent
+ (should (equal
+ (time-stamp-string "%6Y.%Y.%6Y" ref-time1) " 2006.2006.
2006"))
+ ;; colon modifier is independent
+ (should (equal (time-stamp-string "%a.%:a.%a" ref-time1)
+ (concat Mon "." Monday "." Mon)))
+ ;; format letter is independent
+ (should (equal (time-stamp-string "%H:%M" ref-time1) "15:04")))))
+
(ert-deftest time-stamp-format-string-width ()
"Test time-stamp string width modifiers."
(with-time-stamp-test-env
diff --git a/test/manual/etags/CTAGS.good b/test/manual/etags/CTAGS.good
index 3cffd6d..e265836 100644
--- a/test/manual/etags/CTAGS.good
+++ b/test/manual/etags/CTAGS.good
@@ -2461,8 +2461,47 @@ abs/f ada-src/etags-test-for.ada /^ function
"abs" (Right : Complex) return
absolute_dirname c-src/etags.c /^absolute_dirname (char *file, char
*dir)$/
absolute_filename c-src/etags.c /^absolute_filename (char *file, char
*dir)$/
abt cp-src/c.C 55
+acc_pred_info merc-src/accumulator.m /^:- pred
acc_pred_info(list(mer_type)::in, list(pro/
+acc_proc_info merc-src/accumulator.m /^:- pred
acc_proc_info(list(prog_var)::in, prog_var/
+acc_unification merc-src/accumulator.m /^:- pred
acc_unification(pair(prog_var)::in, hlds_g/
+acc_var_subst_init merc-src/accumulator.m /^:- pred
acc_var_subst_init(list(prog_var)::in,$/
accent_key_syms c-src/emacs/src/keyboard.c 4625
access_keymap_keyremap c-src/emacs/src/keyboard.c
/^access_keymap_keyremap (Lisp_Object map, Lisp_Obje/
+accu_assoc merc-src/accumulator.m /^:- pred accu_assoc(module_info::in,
vartypes::in, /
+accu_assoc merc-src/accumulator.m /^:- type accu_assoc$/
+accu_base merc-src/accumulator.m /^:- type accu_base$/
+accu_before merc-src/accumulator.m /^:- pred accu_before(module_info::in,
vartypes::in,/
+accu_case merc-src/accumulator.m /^:- type accu_case$/
+accu_construct merc-src/accumulator.m /^:- pred
accu_construct(module_info::in, vartypes::/
+accu_construct_assoc merc-src/accumulator.m /^:- pred
accu_construct_assoc(module_info::in, vart/
+accu_create_goal merc-src/accumulator.m /^:- pred
accu_create_goal(accu_goal_id::in, list(pr/
+accu_divide_base_case merc-src/accumulator.m /^:- pred
accu_divide_base_case(module_info::in, var/
+accu_goal_id merc-src/accumulator.m /^:- type accu_goal_id$/
+accu_goal_list merc-src/accumulator.m /^:- func
accu_goal_list(list(accu_goal_id), accu_go/
+accu_goal_store merc-src/accumulator.m /^:- type accu_goal_store ==
goal_store(accu_goal_id/
+accu_has_heuristic merc-src/accumulator.m /^:- pred
accu_has_heuristic(module_name::in, string/
+accu_heuristic merc-src/accumulator.m /^:- pred
accu_heuristic(module_name::in, string::in/
+accu_is_associative merc-src/accumulator.m /^:- pred
accu_is_associative(module_info::in, pred_/
+accu_is_update merc-src/accumulator.m /^:- pred
accu_is_update(module_info::in, pred_id::i/
+accu_process_assoc_set merc-src/accumulator.m /^:- pred
accu_process_assoc_set(module_info::in, ac/
+accu_process_update_set merc-src/accumulator.m /^:- pred
accu_process_update_set(module_info::in, a/
+accu_related merc-src/accumulator.m /^:- pred accu_related(module_info::in,
vartypes::in/
+accu_rename merc-src/accumulator.m /^:- func
accu_rename(list(accu_goal_id), accu_subst/
+accu_sets merc-src/accumulator.m /^:- type accu_sets$/
+accu_sets_init merc-src/accumulator.m /^:- pred
accu_sets_init(accu_sets::out) is det.$/
+accu_stage1 merc-src/accumulator.m /^:- pred accu_stage1(module_info::in,
vartypes::in,/
+accu_stage1_2 merc-src/accumulator.m /^:- pred
accu_stage1_2(module_info::in, vartypes::i/
+accu_stage2 merc-src/accumulator.m /^:- pred accu_stage2(module_info::in,
proc_info::in/
+accu_stage3 merc-src/accumulator.m /^:- pred accu_stage3(accu_goal_id::in,
list(prog_va/
+accu_standardize merc-src/accumulator.m /^:- pred
accu_standardize(hlds_goal::in, hlds_goal:/
+accu_store merc-src/accumulator.m /^:- pred accu_store(accu_case::in,
hlds_goal::in,$/
+accu_subst merc-src/accumulator.m /^:- type accu_subst == map(prog_var,
prog_var).$/
+accu_substs merc-src/accumulator.m /^:- type accu_substs$/
+accu_substs_init merc-src/accumulator.m /^:- pred
accu_substs_init(list(prog_var)::in, prog_/
+accu_top_level merc-src/accumulator.m /^:- pred accu_top_level(top_level::in,
hlds_goal::i/
+accu_transform_proc merc-src/accumulator.m /^:- pred
accu_transform_proc(pred_proc_id::in, pred/
+accu_update merc-src/accumulator.m /^:- pred accu_update(module_info::in,
vartypes::in,/
+accu_warning merc-src/accumulator.m /^:- type accu_warning$/
act prol-src/natded.prolog /^act(OutForm,OutSyn,Ws):-$/
action prol-src/natded.prolog /^action(KeyVals):-$/
active_maps c-src/emacs/src/keyboard.c /^active_maps (Lisp_Object
first_event)$/
@@ -2534,6 +2573,8 @@ assemby-code-word forth-src/test-forth.fth /^code
assemby-code-word ( dunno what
assert c-src/etags.c 135
assert c-src/etags.c /^# define assert(x) ((void) 0)$/
assign_neighbor cp-src/clheir.hpp /^ void assign_neighbor(int
direction, location */
+assoc_list merc-src/accumulator.m /^:- import_module assoc_list.$/
+associativity_assertion merc-src/accumulator.m /^:- pred
associativity_assertion(module_info::in, l/
at_end c-src/etags.c 249
at_filename c-src/etags.c 247
at_language c-src/etags.c 245
@@ -2567,6 +2608,8 @@ bas_syn prol-src/natded.prolog /^bas_syn(n(_)).$/
base c-src/emacs/src/lisp.h 2188
base cp-src/c.C /^double base (void) const { return rng_base; }$/
base cp-src/Range.h /^ double base (void) const { return rng_base; }$/
+base_case_ids merc-src/accumulator.m /^:- func
base_case_ids(accu_goal_store) = list(accu/
+base_case_ids_set merc-src/accumulator.m /^:- func
base_case_ids_set(accu_goal_store) = set(a/
baz= ruby-src/test1.ru /^ :baz,$/
bb c.c 275
bbb c.c 251
@@ -2604,6 +2647,7 @@ bodyindent tex-src/texinfo.tex
/^\\exdentamount=\\defbodyindent$/
bodyindent tex-src/texinfo.tex /^\\advance\\leftskip by
\\defbodyindent \\advance \\righ/
bodyindent tex-src/texinfo.tex /^\\exdentamount=\\defbodyindent$/
bool c.c 222
+bool merc-src/accumulator.m /^:- import_module bool.$/
bool_header_size c-src/emacs/src/lisp.h 1472
bool_vector_bitref c-src/emacs/src/lisp.h /^bool_vector_bitref
(Lisp_Object a, EMACS_INT i)$/
bool_vector_bytes c-src/emacs/src/lisp.h /^bool_vector_bytes (EMACS_INT
size)$/
@@ -2645,6 +2689,7 @@ c_ext c-src/etags.c 2271
caccacacca c.c /^caccacacca (a,b,c,d,e,f,g)$/
cacheLRUEntry_s c.c 172
cacheLRUEntry_t c.c 177
+calculate_goal_info merc-src/accumulator.m /^:- pred
calculate_goal_info(hlds_goal_expr::in, hl/
calloc c-src/emacs/src/gmalloc.c 66
calloc c-src/emacs/src/gmalloc.c 70
calloc c-src/emacs/src/gmalloc.c /^calloc (size_t nmemb, size_t size)$/
@@ -2665,6 +2710,8 @@ cgrep html-src/software.html /^cgrep$/
chain c-src/emacs/src/lisp.h 1162
chain c-src/emacs/src/lisp.h 2206
chain c-src/emacs/src/lisp.h 2396
+chain_subst merc-src/accumulator.m /^:- func chain_subst(accu_subst,
accu_subst) = accu/
+chain_subst_2 merc-src/accumulator.m /^:- pred chain_subst_2(list(A)::in,
map(A, B)::in, /
char_bits c-src/emacs/src/lisp.h 2443
char_table_specials c-src/emacs/src/lisp.h 1692
charpos c-src/emacs/src/lisp.h 2011
@@ -2707,6 +2754,7 @@ command_loop_1 c-src/emacs/src/keyboard.c
/^command_loop_1 (void)$/
command_loop_2 c-src/emacs/src/keyboard.c /^command_loop_2 (Lisp_Object
ignore)$/
command_loop_level c-src/emacs/src/keyboard.c 195
comment php-src/lce_functions.php /^ function comment($line,
$class)$/
+commutativity_assertion merc-src/accumulator.m /^:- pred
commutativity_assertion(module_info::in,li/
compile_empty prol-src/natded.prolog /^compile_empty:-$/
compile_lex prol-src/natded.prolog /^compile_lex(File):-$/
complete prol-src/natded.prolog /^complete(Cat):-$/
@@ -2740,6 +2788,13 @@ create-bar forth-src/test-forth.fth /^:
create-bar foo ;$/
createPOEntries php-src/lce_functions.php /^ function
createPOEntries()$/
createWidgets pyt-src/server.py /^ def createWidgets(self, host):$/
createWidgets pyt-src/server.py /^ def createWidgets(self):$/
+create_acc_call merc-src/accumulator.m /^:- func
create_acc_call(hlds_goal::in(goal_plain_c/
+create_acc_goal merc-src/accumulator.m /^:- pred
create_acc_goal(hlds_goal::in, accu_substs/
+create_new_base_goals merc-src/accumulator.m /^:- func
create_new_base_goals(set(accu_goal_id), a/
+create_new_orig_recursive_goals merc-src/accumulator.m /^:- func
create_new_orig_recursive_goals(set(accu_g/
+create_new_recursive_goals merc-src/accumulator.m /^:- func
create_new_recursive_goals(set(accu_goal_i/
+create_new_var merc-src/accumulator.m /^:- pred create_new_var(prog_var::in,
string::in, p/
+create_orig_goal merc-src/accumulator.m /^:- pred
create_orig_goal(hlds_goal::in, accu_subst/
cscInitTime cp-src/c.C 7
cscSegmentationTime cp-src/c.C 8
cstack c-src/etags.c 2523
@@ -3104,6 +3159,8 @@ gcpro c-src/emacs/src/lisp.h 3042
gcpro c-src/emacs/src/lisp.h 3132
gen_help_event c-src/emacs/src/keyboard.c /^gen_help_event (Lisp_Object
help, Lisp_Object fram/
genalgorithm html-src/algrthms.html /^Generating the
Data<\/font><\/i><\/b>$/
+generate_warning merc-src/accumulator.m /^:- pred
generate_warning(module_info::in, prog_var/
+generate_warnings merc-src/accumulator.m /^:- pred
generate_warnings(module_info::in, prog_va/
generic_object cp-src/clheir.cpp /^generic_object::generic_object(void)$/
generic_object cp-src/clheir.hpp 13
getArchs objc-src/PackInsp.m /^-(void)getArchs$/
@@ -3172,6 +3229,21 @@ help_char_p c-src/emacs/src/keyboard.c
/^help_char_p (Lisp_Object c)$/
help_form_saved_window_configs c-src/emacs/src/keyboard.c 2156
helpwin pyt-src/server.py /^def helpwin(helpdict):$/
hide_cursor cp-src/screen.cpp /^void hide_cursor(void)$/
+hlds merc-src/accumulator.m /^:- import_module hlds.$/
+hlds.assertion merc-src/accumulator.m /^:- import_module hlds.assertion.$/
+hlds.goal_util merc-src/accumulator.m /^:- import_module hlds.goal_util.$/
+hlds.hlds_error_util merc-src/accumulator.m /^:- import_module
hlds.hlds_error_util.$/
+hlds.hlds_goal merc-src/accumulator.m /^:- import_module hlds.hlds_goal.$/
+hlds.hlds_module merc-src/accumulator.m /^:- import_module
hlds.hlds_module.$/
+hlds.hlds_out merc-src/accumulator.m /^:- import_module hlds.hlds_out.$/
+hlds.hlds_out.hlds_out_util merc-src/accumulator.m /^:- import_module
hlds.hlds_out.hlds_out_util.$/
+hlds.hlds_pred merc-src/accumulator.m /^:- import_module hlds.hlds_pred.$/
+hlds.hlds_promise merc-src/accumulator.m /^:- import_module
hlds.hlds_promise.$/
+hlds.instmap merc-src/accumulator.m /^:- import_module hlds.instmap.$/
+hlds.pred_table merc-src/accumulator.m /^:- import_module
hlds.pred_table.$/
+hlds.quantification merc-src/accumulator.m /^:- import_module
hlds.quantification.$/
+hlds.status merc-src/accumulator.m /^:- import_module hlds.status.$/
+hlds.vartypes merc-src/accumulator.m /^:- import_module hlds.vartypes.$/
htmltreelist prol-src/natded.prolog /^htmltreelist([]).$/
hybrid_aligned_alloc c-src/emacs/src/gmalloc.c /^hybrid_aligned_alloc
(size_t alignment, size_t siz/
hybrid_calloc c-src/emacs/src/gmalloc.c /^hybrid_calloc (size_t nmemb,
size_t size)$/
@@ -3191,6 +3263,9 @@ ialpage tex-src/texinfo.tex /^
\\dimen@=\\pageheight \\advance\\dimen@ by-\\ht\
ialpage tex-src/texinfo.tex /^ \\availdimen@=\\pageheight
\\advance\\availdimen@ by/
ialpage tex-src/texinfo.tex /^ \\dimen@=\\pageheight
\\advance\\dimen@ by-\\ht\\pa/
ialpage= tex-src/texinfo.tex /^
\\output={\\global\\setbox\\partialpage=$/
+identify_goal_type merc-src/accumulator.m /^:- pred
identify_goal_type(pred_id::in, proc_id::i/
+identify_out_and_out_prime merc-src/accumulator.m /^:- pred
identify_out_and_out_prime(module_info::in/
+identify_recursive_calls merc-src/accumulator.m /^:- pred
identify_recursive_calls(pred_id::in, proc/
idx c-src/emacs/src/lisp.h 3150
ignore_case c-src/etags.c 266
ignore_mouse_drag_p c-src/emacs/src/keyboard.c 1256
@@ -3220,6 +3295,7 @@ inita c.c /^static void inita () {}$/
initb c.c /^static void initb () {}$/
initial_kboard c-src/emacs/src/keyboard.c 84
initialize-new-tags-table el-src/emacs/lisp/progmodes/etags.el
/^(defun initialize-new-tags-table ()$/
+initialize_goal_store merc-src/accumulator.m /^:- func
initialize_goal_store(list(hlds_goal), ins/
initialize_random_junk y-src/cccp.y /^initialize_random_junk ()$/
input-pending-p c-src/emacs/src/keyboard.c /^DEFUN
("input-pending-p", Finput_pending_p, Sinput/
input_available_clear_time c-src/emacs/src/keyboard.c 324
@@ -3235,6 +3311,7 @@ instance_method_exclamation! ruby-src/test.rb
/^ def instance_method_excl
instance_method_question? ruby-src/test.rb /^ def
instance_method_question?$/
instr y-src/parse.y 81
instruct c-src/etags.c 2527
+int merc-src/accumulator.m /^:- import_module int.$/
intNumber go-src/test1.go 13
integer c-src/emacs/src/lisp.h 2127
integer y-src/cccp.y 112
@@ -3257,6 +3334,7 @@ intoken c-src/etags.c /^#define intoken(c)
(_itk[CHAR (c)]) \/* c can be in/
intspec c-src/emacs/src/lisp.h 1688
intvar c-src/emacs/src/lisp.h 2277
invalidate_nodes c-src/etags.c /^invalidate_nodes (fdesc *badfdp, node
**npp)$/
+io merc-src/accumulator.m /^:- import_module io.$/
ipc3dCSC19 cp-src/c.C 6
ipc3dChannelType cp-src/c.C 1
ipc3dIslandHierarchy cp-src/c.C 1
@@ -3266,6 +3344,7 @@ irregular_location cp-src/clheir.hpp /^
irregular_location(double xi, double
isComment php-src/lce_functions.php /^ function
isComment($class)$/
isHoliday cp-src/functions.cpp /^bool isHoliday ( Date d ){$/
isLeap cp-src/functions.cpp /^bool isLeap ( int year ){$/
+is_associative_construction merc-src/accumulator.m /^:- pred
is_associative_construction(module_info::i/
is_curly_brace_form c-src/h.h 54
is_explicit c-src/h.h 49
is_func c-src/etags.c 221
@@ -3274,6 +3353,7 @@ is_idchar y-src/cccp.y 948
is_idstart y-src/cccp.y 950
is_muldiv_operation cp-src/c.C /^is_muldiv_operation(pc)$/
is_ordset prol-src/ordsets.prolog /^is_ordset(X) :- var(X), !, fail.$/
+is_recursive_case merc-src/accumulator.m /^:- pred
is_recursive_case(list(hlds_goal)::in, pre/
iso_lispy_function_keys c-src/emacs/src/keyboard.c 5151
isoperator prol-src/natded.prolog /^isoperator(Char):-$/
isoptab prol-src/natded.prolog /^isoptab('%').$/
@@ -3370,6 +3450,10 @@ letter: tex-src/texinfo.tex
/^\\xdef\\thischapter{Appendix \\appendixletter: \\n
level c-src/emacs/src/lisp.h 3153
lex prol-src/natded.prolog /^lex(W,SynOut,Sem):-$/
lexptr y-src/cccp.y 332
+libs merc-src/accumulator.m /^:- import_module libs.$/
+libs.globals merc-src/accumulator.m /^:- import_module libs.globals.$/
+libs.optimization_options merc-src/accumulator.m /^:- import_module
libs.optimization_options.$/
+libs.options merc-src/accumulator.m /^:- import_module libs.options.$/
licenze html-src/softwarelibero.html /^Licenze d'uso di un
programma$/
limit cp-src/Range.h /^ double limit (void) const { return rng_limit; }$/
line c-src/etags.c 2493
@@ -3427,6 +3511,7 @@ lispy_modifier_list c-src/emacs/src/keyboard.c
/^lispy_modifier_list (int modifi
lispy_multimedia_keys c-src/emacs/src/keyboard.c 4962
lispy_wheel_names c-src/emacs/src/keyboard.c 5174
list c-src/emacs/src/gmalloc.c 186
+list merc-src/accumulator.m /^:- import_module list.$/
list-tags el-src/emacs/lisp/progmodes/etags.el /^(defun list-tags
(file &optional _next-match)$/
list-tags-function el-src/emacs/lisp/progmodes/etags.el /^(defvar
list-tags-function nil$/
list2i c-src/emacs/src/lisp.h /^list2i (EMACS_INT x, EMACS_INT y)$/
@@ -3443,6 +3528,7 @@ local_if_set c-src/emacs/src/lisp.h 2338
location cp-src/clheir.hpp 33
location cp-src/clheir.hpp /^ location() { }$/
lookup y-src/cccp.y /^lookup (name, len, hash)$/
+lookup_call merc-src/accumulator.m /^:- pred
lookup_call(accu_goal_store::in, accu_goal/
lowcase c-src/etags.c /^#define lowcase(c) tolower (CHAR (c))$/
lucid_event_type_list_p c-src/emacs/src/keyboard.c
/^lucid_event_type_list_p (Lisp_Object object)$/
mabort c-src/emacs/src/gmalloc.c /^mabort (enum mcheck_status status)$/
@@ -3488,6 +3574,7 @@ mallochook c-src/emacs/src/gmalloc.c
/^mallochook (size_t size)$/
man manpage make-src/Makefile /^man manpage: etags.1.man$/
mao c-src/h.h 101
map c-src/emacs/src/keyboard.c 8748
+map merc-src/accumulator.m /^:- import_module map.$/
map_word prol-src/natded.prolog /^map_word([[_]|Ws],Exp):-$/
mapping html-src/algrthms.html /^Mapping the Channel Symbols$/
mapsyn prol-src/natded.prolog /^mapsyn(A\/B,AM\/BM):-$/
@@ -3501,15 +3588,19 @@ max_args c-src/emacs/src/lisp.h 1686
max_num_directions cp-src/clheir.hpp 31
max_num_generic_objects cp-src/clheir.cpp 9
maxargs c-src/emacs/src/lisp.h 2831
+maybe merc-src/accumulator.m /^:- import_module maybe.$/
maybe_gc c-src/emacs/src/lisp.h /^maybe_gc (void)$/
mcCSC cp-src/c.C 6
mcheck c-src/emacs/src/gmalloc.c /^mcheck (void (*func) (enum
mcheck_status))$/
mcheck_status c-src/emacs/src/gmalloc.c 283
mcheck_used c-src/emacs/src/gmalloc.c 2012
+mdbcomp merc-src/accumulator.m /^:- import_module mdbcomp.$/
+mdbcomp.sym_name merc-src/accumulator.m /^:- import_module
mdbcomp.sym_name.$/
me22b lua-src/test.lua /^ local function test.me22b (one)$/
me_22a lua-src/test.lua /^ function test.me_22a(one, two)$/
memalign c-src/emacs/src/gmalloc.c /^memalign (size_t alignment,
size_t size)$/
member prol-src/natded.prolog /^member(X,[X|_]).$/
+member_lessthan_goalid merc-src/accumulator.m /^:- pred
member_lessthan_goalid(accu_goal_store::in/
memclear c-src/emacs/src/lisp.h /^memclear (void *p, ptrdiff_t nbytes)$/
menu_bar_item c-src/emacs/src/keyboard.c /^menu_bar_item (Lisp_Object
key, Lisp_Object item, /
menu_bar_items c-src/emacs/src/keyboard.c /^menu_bar_items (Lisp_Object
old)$/
@@ -3780,6 +3871,7 @@ pMu c-src/emacs/src/lisp.h 151
pMu c-src/emacs/src/lisp.h 156
p_next c-src/etags.c 258
pagesize c-src/emacs/src/gmalloc.c 1703
+pair merc-src/accumulator.m /^:- import_module pair.$/
parent c-src/emacs/src/keyboard.c 8745
parent c-src/emacs/src/lisp.h 1590
parse prol-src/natded.prolog /^parse(Ws,Cat):-$/
@@ -3797,6 +3889,12 @@ parse_return y-src/parse.y 74
parse_return_error y-src/cccp.y 70
parse_solitary_modifier c-src/emacs/src/keyboard.c
/^parse_solitary_modifier (Lisp_Object symbol)$/
parse_tool_bar_item c-src/emacs/src/keyboard.c /^parse_tool_bar_item
(Lisp_Object key, Lisp_Object /
+parse_tree merc-src/accumulator.m /^:- import_module parse_tree.$/
+parse_tree.error_util merc-src/accumulator.m /^:- import_module
parse_tree.error_util.$/
+parse_tree.prog_data merc-src/accumulator.m /^:- import_module
parse_tree.prog_data.$/
+parse_tree.prog_mode merc-src/accumulator.m /^:- import_module
parse_tree.prog_mode.$/
+parse_tree.prog_util merc-src/accumulator.m /^:- import_module
parse_tree.prog_util.$/
+parse_tree.set_of_var merc-src/accumulator.m /^:- import_module
parse_tree.set_of_var.$/
pat c-src/etags.c 262
pattern c-src/etags.c 260
pdlcount c-src/emacs/src/lisp.h 3046
@@ -3989,6 +4087,7 @@ removeexp prol-src/natded.prolog
/^removeexp(E,E,'NIL'):-!.$/
reorder_modifiers c-src/emacs/src/keyboard.c /^reorder_modifiers
(Lisp_Object symbol)$/
request c.c /^request request (a, b)$/
requeued_events_pending_p c-src/emacs/src/keyboard.c
/^requeued_events_pending_p (void)$/
+require merc-src/accumulator.m /^:- import_module require.$/
required_argument c-src/getopt.h 90
reset-this-command-lengths c-src/emacs/src/keyboard.c /^DEFUN
("reset-this-command-lengths", Freset_this_c/
restore_getcjmp c-src/emacs/src/keyboard.c /^restore_getcjmp
(sys_jmp_buf temp)$/
@@ -4061,6 +4160,7 @@ separator_names c-src/emacs/src/keyboard.c 7372
serializeToVars php-src/lce_functions.php /^ function
serializeToVars($prefix)$/
serializeToVars php-src/lce_functions.php /^ function
serializeToVars($prefix)$/
set cp-src/conway.hpp /^ void set(void) { alive = 1; }$/
+set merc-src/accumulator.m /^:- import_module set.$/
set-input-interrupt-mode c-src/emacs/src/keyboard.c /^DEFUN
("set-input-interrupt-mode", Fset_input_inte/
set-input-meta-mode c-src/emacs/src/keyboard.c /^DEFUN
("set-input-meta-mode", Fset_input_meta_mode/
set-input-mode c-src/emacs/src/keyboard.c /^DEFUN ("set-input-mode",
Fset_input_mode, Sset_inp/
@@ -4088,11 +4188,14 @@ set_sub_char_table_contents c-src/emacs/src/lisp.h
/^set_sub_char_table_contents
set_symbol_function c-src/emacs/src/lisp.h /^set_symbol_function
(Lisp_Object sym, Lisp_Object /
set_symbol_next c-src/emacs/src/lisp.h /^set_symbol_next (Lisp_Object
sym, struct Lisp_Symb/
set_symbol_plist c-src/emacs/src/lisp.h /^set_symbol_plist (Lisp_Object
sym, Lisp_Object pli/
+set_upto merc-src/accumulator.m /^:- func set_upto(accu_case, int) =
set(accu_goal_i/
set_waiting_for_input c-src/emacs/src/keyboard.c /^set_waiting_for_input
(struct timespec *time_to_cl/
setref tex-src/texinfo.tex
/^\\expandafter\\expandafter\\expandafter\\appendixsetre/
setup cp-src/c.C 5
shift cp-src/functions.cpp /^void Date::shift ( void ){\/\/Shift this date
to pre/
shouldLoad objc-src/PackInsp.m /^-(BOOL)shouldLoad$/
+should_attempt_accu_transform merc-src/accumulator.m /^:- pred
should_attempt_accu_transform(module_info:/
+should_attempt_accu_transform_2 merc-src/accumulator.m /^:- pred
should_attempt_accu_transform_2(module_inf/
should_see_this_array_type cp-src/c.C 156
should_see_this_function_pointer cp-src/c.C 153
should_see_this_one_enclosed_in_extern_C cp-src/c.C 149
@@ -4122,6 +4225,7 @@ skip_non_spaces c-src/etags.c /^skip_non_spaces (char
*cp)$/
skip_spaces c-src/etags.c /^skip_spaces (char *cp)$/
snarf-tag-function el-src/emacs/lisp/progmodes/etags.el /^(defvar
snarf-tag-function nil$/
snone c-src/etags.c 2443
+solutions merc-src/accumulator.m /^:- import_module solutions.$/
some_mouse_moved c-src/emacs/src/keyboard.c /^some_mouse_moved
(void)$/
space tex-src/texinfo.tex /^ {#2\\labelspace
#1}\\dotfill\\doshortpageno{#3}}%/
space tex-src/texinfo.tex /^
\\dosubsubsecentry{#2.#3.#4.#5\\labelspace#1}{#6}}/
@@ -4171,10 +4275,12 @@ step cp-src/conway.hpp /^ void step(void) {
alive = next_alive; }$/
step cp-src/clheir.hpp /^ virtual void step(void) { }$/
step_everybody cp-src/clheir.cpp /^void step_everybody(void)$/
stop_polling c-src/emacs/src/keyboard.c /^stop_polling (void)$/
+store_info merc-src/accumulator.m /^:- type store_info$/
store_user_signal_events c-src/emacs/src/keyboard.c
/^store_user_signal_events (void)$/
str go-src/test1.go 9
strcaseeq c-src/etags.c /^#define strcaseeq(s,t) (assert
((s)!=NULL && (t)!=/
streq c-src/etags.c /^#define streq(s,t) (assert ((s)!=NULL || (t)!=NULL/
+string merc-src/accumulator.m /^:- import_module string.$/
string_intervals c-src/emacs/src/lisp.h /^string_intervals (Lisp_Object
s)$/
stripLine php-src/lce_functions.php /^ function
stripLine($line, $class)$/
stripname pas-src/common.pas /^function stripname; (* ($/
@@ -4314,6 +4420,7 @@ tee ruby-src/test1.ru /^ attr_accessor
:tee$/
tee= ruby-src/test1.ru /^ attr_accessor :tee$/
temporarily_switch_to_single_kboard c-src/emacs/src/keyboard.c
/^temporarily_switch_to_single_kboard (struct frame /
tend c-src/etags.c 2432
+term merc-src/accumulator.m /^:- import_module term.$/
terminate objc-src/Subprocess.m /^- terminate:sender$/
terminateInput objc-src/Subprocess.m /^- terminateInput$/
test c-src/emacs/src/lisp.h 1871
@@ -4365,6 +4472,7 @@ tool_bar_items c-src/emacs/src/keyboard.c
/^tool_bar_items (Lisp_Object reuse, i
tool_bar_items_vector c-src/emacs/src/keyboard.c 7965
toolkit_menubar_in_use c-src/emacs/src/keyboard.c
/^toolkit_menubar_in_use (struct frame *f)$/
top-level c-src/emacs/src/keyboard.c /^DEFUN ("top-level",
Ftop_level, Stop_level, 0, 0, /
+top_level merc-src/accumulator.m /^:- type top_level$/
top_level_1 c-src/emacs/src/keyboard.c /^top_level_1 (Lisp_Object
ignore)$/
top_level_2 c-src/emacs/src/keyboard.c /^top_level_2 (void)$/
total_keys c-src/emacs/src/keyboard.c 97
@@ -4376,6 +4484,9 @@ tpcmd c-src/h.h 15
track-mouse c-src/emacs/src/keyboard.c /^DEFUN
("internal--track-mouse", Ftrack_mouse, Stra/
tracking_off c-src/emacs/src/keyboard.c /^tracking_off (Lisp_Object
old_value)$/
traffic_light cp-src/conway.cpp /^void traffic_light(int x, int y)$/
+transform_hlds.accumulator merc-src/accumulator.m /^:- module
transform_hlds.accumulator.$/
+transform_hlds.accumulator merc-src/accumulator.m /^:- end_module
transform_hlds.accumulator.$/
+transform_hlds.goal_store merc-src/accumulator.m /^:- import_module
transform_hlds.goal_store.$/
translate c-src/emacs/src/regex.h 361
treats cp-src/c.C 131
tt prol-src/natded.prolog /^tt:-$/
@@ -4421,12 +4532,14 @@ unblock_input c-src/emacs/src/keyboard.c
/^unblock_input (void)$/
unblock_input_to c-src/emacs/src/keyboard.c /^unblock_input_to (int
level)$/
unchar c-src/h.h 99
unexpand-abbrev c-src/abbrev.c /^DEFUN ("unexpand-abbrev",
Funexpand_abbrev, Sunexp/
+univ merc-src/accumulator.m /^:- import_module univ.$/
unread_switch_frame c-src/emacs/src/keyboard.c 204
unsignedp y-src/cccp.y 112
unwind c-src/emacs/src/lisp.h 2962
unwind_int c-src/emacs/src/lisp.h 2972
unwind_ptr c-src/emacs/src/lisp.h 2967
unwind_void c-src/emacs/src/lisp.h 2976
+update_accumulator_pred merc-src/accumulator.m /^:- pred
update_accumulator_pred(pred_id::in, proc_/
uprintmax_t c-src/emacs/src/lisp.h 149
uprintmax_t c-src/emacs/src/lisp.h 154
usage perl-src/yagrip.pl /^sub usage {$/
@@ -4458,6 +4571,7 @@ varargs tex-src/texinfo.tex /^\\defvarargs
{#3}\\endgroup %$/
varargs tex-src/texinfo.tex /^\\defvarargs {#3}\\endgroup %$/
varargs tex-src/texinfo.tex /^\\defvarargs {#2}\\endgroup %$/
varargs tex-src/texinfo.tex /^\\defvarargs {#2}\\endgroup %$/
+varset merc-src/accumulator.m /^:- import_module varset.$/
vcopy c-src/emacs/src/lisp.h /^vcopy (Lisp_Object v, ptrdiff_t offset,
Lisp_Objec/
vectorlike_header c-src/emacs/src/lisp.h 1343
verde cp-src/c.C 40
diff --git a/test/manual/etags/ETAGS.good_1 b/test/manual/etags/ETAGS.good_1
index a8470ea..e05b8f2 100644
--- a/test/manual/etags/ETAGS.good_1
+++ b/test/manual/etags/ETAGS.good_1
@@ -3881,6 +3881,122 @@
Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno %
\global\def={=3307,107500
\def\normalbackslash{\normalbackslash3321,107882
+merc-src/accumulator.m,4275
+:- module transform_hlds.accumulator145,5333
+:- import_module hlds148,5386
+:- import_module hlds.hlds_module149,5409
+:- import_module hlds.hlds_pred150,5444
+:- import_module univ152,5478
+:- pred accu_transform_proc(159,5793
+:- import_module hlds.assertion168,6135
+:- import_module hlds.goal_util169,6168
+:- import_module hlds.hlds_error_util170,6201
+:- import_module hlds.hlds_goal171,6240
+:- import_module hlds.hlds_out172,6273
+:- import_module hlds.hlds_out.hlds_out_util173,6305
+:- import_module hlds.hlds_promise174,6351
+:- import_module hlds.instmap175,6387
+:- import_module hlds.pred_table176,6418
+:- import_module hlds.quantification177,6452
+:- import_module hlds.status178,6490
+:- import_module hlds.vartypes179,6520
+:- import_module libs180,6552
+:- import_module libs.globals181,6575
+:- import_module libs.optimization_options182,6606
+:- import_module libs.options183,6650
+:- import_module mdbcomp184,6681
+:- import_module mdbcomp.sym_name185,6707
+:- import_module parse_tree186,6742
+:- import_module parse_tree.error_util187,6771
+:- import_module parse_tree.prog_data188,6811
+:- import_module parse_tree.prog_mode189,6850
+:- import_module parse_tree.prog_util190,6889
+:- import_module parse_tree.set_of_var191,6928
+:- import_module transform_hlds.goal_store192,6968
+:- import_module assoc_list194,7013
+:- import_module bool195,7042
+:- import_module int196,7065
+:- import_module io197,7087
+:- import_module list198,7108
+:- import_module map199,7131
+:- import_module maybe200,7153
+:- import_module pair201,7177
+:- import_module require202,7200
+:- import_module set203,7226
+:- import_module solutions204,7248
+:- import_module string205,7276
+:- import_module term206,7301
+:- import_module varset207,7324
+:- type top_level213,7499
+:- type accu_goal_id225,7900
+:- type accu_case228,7964
+:- type accu_goal_store234,8091
+:- type accu_subst238,8216
+:- type accu_warning240,8264
+:- pred generate_warnings(334,12550
+:- pred generate_warning(342,12895
+:- pred should_attempt_accu_transform(365,13886
+:- pred should_attempt_accu_transform_2(398,15406
+:- pred accu_standardize(440,17390
+:- pred identify_goal_type(465,18169
+:- pred is_recursive_case(549,21175
+:- type store_info560,21713
+:- func initialize_goal_store(570,22060
+:- pred accu_store(580,22421
+:- pred identify_recursive_calls(601,23288
+:- pred identify_out_and_out_prime(626,24396
+:- type accu_sets676,26425
+:- pred accu_stage1(689,26977
+:- pred accu_stage1_2(727,28347
+:- pred accu_sets_init(781,30557
+:- func set_upto(796,30984
+:- pred accu_before(812,31498
+:- pred accu_assoc(835,32477
+:- pred accu_construct(862,33712
+:- pred accu_construct_assoc(896,35307
+:- pred accu_update(938,37069
+:- pred member_lessthan_goalid(964,38219
+:- type accu_assoc975,38652
+:- pred accu_is_associative(986,39138
+:- pred associativity_assertion(1014,40263
+:- pred commutativity_assertion(1037,41242
+:- pred accu_is_update(1057,41952
+:- pred is_associative_construction(1078,42802
+:- type accu_substs1095,43480
+:- type accu_base1103,43744
+:- pred accu_stage2(1124,44605
+:- pred accu_substs_init(1179,46957
+:- pred acc_var_subst_init(1194,47573
+:- pred create_new_var(1207,48147
+:- pred accu_process_assoc_set(1223,48862
+:- pred accu_has_heuristic(1297,52081
+:- pred accu_heuristic(1304,52336
+:- pred accu_process_update_set(1318,52906
+:- pred accu_divide_base_case(1380,55844
+:- pred accu_related(1412,57146
+:- pred lookup_call(1449,58601
+:- pred accu_stage3(1470,59432
+:- pred acc_proc_info(1508,61326
+:- pred acc_pred_info(1556,63449
+:- pred accu_create_goal(1600,65285
+:- func create_acc_call(1621,66400
+:- pred create_orig_goal(1634,66987
+:- pred create_acc_goal(1662,68157
+:- func create_new_orig_recursive_goals(1709,70225
+:- func create_new_recursive_goals(1723,70918
+:- func create_new_base_goals(1738,71717
+:- pred acc_unification(1749,72156
+:- pred accu_top_level(1766,72896
+:- pred update_accumulator_pred(1856,76290
+:- func accu_rename(1876,77253
+:- func base_case_ids(1889,77784
+:- func base_case_ids_set(1898,78048
+:- func accu_goal_list(1905,78269
+:- pred calculate_goal_info(1916,78680
+:- func chain_subst(1932,79319
+:- pred chain_subst_2(1938,79482
+:- end_module transform_hlds.accumulator1953,79939
+
c-src/c.c,76
T f(1,0
}T i;2,14
diff --git a/test/manual/etags/ETAGS.good_2 b/test/manual/etags/ETAGS.good_2
index 1c25683..c3d2726 100644
--- a/test/manual/etags/ETAGS.good_2
+++ b/test/manual/etags/ETAGS.good_2
@@ -4454,6 +4454,180 @@
Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno %
\global\def={=3307,107500
\def\normalbackslash{\normalbackslash3321,107882
+merc-src/accumulator.m,5996
+:- module transform_hlds.accumulator145,5333
+:- import_module hlds148,5386
+:- import_module hlds.hlds_module149,5409
+:- import_module hlds.hlds_pred150,5444
+:- import_module univ152,5478
+:- pred accu_transform_proc(159,5793
+:- import_module hlds.assertion168,6135
+:- import_module hlds.goal_util169,6168
+:- import_module hlds.hlds_error_util170,6201
+:- import_module hlds.hlds_goal171,6240
+:- import_module hlds.hlds_out172,6273
+:- import_module hlds.hlds_out.hlds_out_util173,6305
+:- import_module hlds.hlds_promise174,6351
+:- import_module hlds.instmap175,6387
+:- import_module hlds.pred_table176,6418
+:- import_module hlds.quantification177,6452
+:- import_module hlds.status178,6490
+:- import_module hlds.vartypes179,6520
+:- import_module libs180,6552
+:- import_module libs.globals181,6575
+:- import_module libs.optimization_options182,6606
+:- import_module libs.options183,6650
+:- import_module mdbcomp184,6681
+:- import_module mdbcomp.sym_name185,6707
+:- import_module parse_tree186,6742
+:- import_module parse_tree.error_util187,6771
+:- import_module parse_tree.prog_data188,6811
+:- import_module parse_tree.prog_mode189,6850
+:- import_module parse_tree.prog_util190,6889
+:- import_module parse_tree.set_of_var191,6928
+:- import_module transform_hlds.goal_store192,6968
+:- import_module assoc_list194,7013
+:- import_module bool195,7042
+:- import_module int196,7065
+:- import_module io197,7087
+:- import_module list198,7108
+:- import_module map199,7131
+:- import_module maybe200,7153
+:- import_module pair201,7177
+:- import_module require202,7200
+:- import_module set203,7226
+:- import_module solutions204,7248
+:- import_module string205,7276
+:- import_module term206,7301
+:- import_module varset207,7324
+:- type top_level213,7499
+:- type accu_goal_id225,7900
+:- type accu_case228,7964
+:- type accu_goal_store234,8091
+:- type accu_subst238,8216
+:- type accu_warning240,8264
+accu_transform_proc(247,8578
+:- pred generate_warnings(334,12550
+generate_warnings(337,12669
+:- pred generate_warning(342,12895
+generate_warning(345,13001
+:- pred should_attempt_accu_transform(365,13886
+should_attempt_accu_transform(370,14123
+:- pred should_attempt_accu_transform_2(398,15406
+should_attempt_accu_transform_2(405,15763
+:- pred accu_standardize(440,17390
+accu_standardize(442,17455
+:- pred identify_goal_type(465,18169
+identify_goal_type(469,18359
+:- pred is_recursive_case(549,21175
+is_recursive_case(551,21253
+:- type store_info560,21713
+:- func initialize_goal_store(570,22060
+initialize_goal_store(573,22166
+:- pred accu_store(580,22421
+accu_store(584,22576
+:- pred identify_recursive_calls(601,23288
+identify_recursive_calls(604,23406
+:- pred identify_out_and_out_prime(626,24396
+identify_out_and_out_prime(631,24631
+:- type accu_sets676,26425
+:- pred accu_stage1(689,26977
+accu_stage1(693,27155
+:- pred accu_stage1_2(727,28347
+accu_stage1_2(731,28515
+:- pred accu_sets_init(781,30557
+accu_sets_init(783,30605
+:- func set_upto(796,30984
+set_upto(798,31039
+:- pred accu_before(812,31498
+accu_before(815,31639
+:- pred accu_assoc(835,32477
+accu_assoc(838,32617
+:- pred accu_construct(862,33712
+accu_construct(865,33856
+:- pred accu_construct_assoc(896,35307
+accu_construct_assoc(899,35457
+:- pred accu_update(938,37069
+accu_update(941,37210
+:- pred member_lessthan_goalid(964,38219
+member_lessthan_goalid(967,38342
+:- type accu_assoc975,38652
+:- pred accu_is_associative(986,39138
+accu_is_associative(989,39250
+:- pred associativity_assertion(1014,40263
+associativity_assertion(1017,40404
+:- pred commutativity_assertion(1037,41242
+commutativity_assertion(1040,41369
+:- pred accu_is_update(1057,41952
+accu_is_update(1060,42066
+:- pred is_associative_construction(1078,42802
+is_associative_construction(1081,42898
+:- type accu_substs1095,43480
+:- type accu_base1103,43744
+:- pred accu_stage2(1124,44605
+accu_stage2(1131,44946
+:- pred accu_substs_init(1179,46957
+accu_substs_init(1182,47097
+:- pred acc_var_subst_init(1194,47573
+acc_var_subst_init(1198,47718
+:- pred create_new_var(1207,48147
+create_new_var(1210,48288
+:- pred accu_process_assoc_set(1223,48862
+accu_process_assoc_set(1229,49150
+:- pred accu_has_heuristic(1297,52081
+accu_has_heuristic(1299,52161
+:- pred accu_heuristic(1304,52336
+accu_heuristic(1307,52457
+:- pred accu_process_update_set(1318,52906
+accu_process_update_set(1325,53221
+:- pred accu_divide_base_case(1380,55844
+accu_divide_base_case(1385,56059
+:- pred accu_related(1412,57146
+accu_related(1415,57270
+:- pred lookup_call(1449,58601
+lookup_call(1452,58715
+:- pred accu_stage3(1470,59432
+accu_stage3(1477,59826
+:- pred acc_proc_info(1508,61326
+acc_proc_info(1512,61485
+:- pred acc_pred_info(1556,63449
+acc_pred_info(1559,63597
+:- pred accu_create_goal(1600,65285
+accu_create_goal(1607,65628
+:- func create_acc_call(1621,66400
+create_acc_call(1625,66569
+:- pred create_orig_goal(1634,66987
+create_orig_goal(1638,67176
+:- pred create_acc_goal(1662,68157
+create_acc_goal(1667,68380
+:- func create_new_orig_recursive_goals(1709,70225
+create_new_orig_recursive_goals(1712,70368
+:- func create_new_recursive_goals(1723,70918
+create_new_recursive_goals(1727,71108
+:- func create_new_base_goals(1738,71717
+create_new_base_goals(1741,71831
+:- pred acc_unification(1749,72156
+acc_unification(1751,72225
+:- pred accu_top_level(1766,72896
+accu_top_level(1770,73058
+:- pred update_accumulator_pred(1856,76290
+update_accumulator_pred(1859,76411
+:- func accu_rename(1876,77253
+accu_rename(1879,77363
+:- func base_case_ids(1889,77784
+base_case_ids(1891,77846
+:- func base_case_ids_set(1898,78048
+base_case_ids_set(1900,78113
+:- func accu_goal_list(1905,78269
+accu_goal_list(1907,78349
+:- pred calculate_goal_info(1916,78680
+calculate_goal_info(1918,78753
+:- func chain_subst(1932,79319
+chain_subst(1934,79378
+:- pred chain_subst_2(1938,79482
+chain_subst_2(1941,79576
+:- end_module transform_hlds.accumulator1953,79939
+
c-src/c.c,76
T f(1,0
}T i;2,14
diff --git a/test/manual/etags/ETAGS.good_3 b/test/manual/etags/ETAGS.good_3
index 5b55818..85897feb 100644
--- a/test/manual/etags/ETAGS.good_3
+++ b/test/manual/etags/ETAGS.good_3
@@ -4288,6 +4288,122 @@
Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno %
\global\def={=3307,107500
\def\normalbackslash{\normalbackslash3321,107882
+merc-src/accumulator.m,4275
+:- module transform_hlds.accumulator145,5333
+:- import_module hlds148,5386
+:- import_module hlds.hlds_module149,5409
+:- import_module hlds.hlds_pred150,5444
+:- import_module univ152,5478
+:- pred accu_transform_proc(159,5793
+:- import_module hlds.assertion168,6135
+:- import_module hlds.goal_util169,6168
+:- import_module hlds.hlds_error_util170,6201
+:- import_module hlds.hlds_goal171,6240
+:- import_module hlds.hlds_out172,6273
+:- import_module hlds.hlds_out.hlds_out_util173,6305
+:- import_module hlds.hlds_promise174,6351
+:- import_module hlds.instmap175,6387
+:- import_module hlds.pred_table176,6418
+:- import_module hlds.quantification177,6452
+:- import_module hlds.status178,6490
+:- import_module hlds.vartypes179,6520
+:- import_module libs180,6552
+:- import_module libs.globals181,6575
+:- import_module libs.optimization_options182,6606
+:- import_module libs.options183,6650
+:- import_module mdbcomp184,6681
+:- import_module mdbcomp.sym_name185,6707
+:- import_module parse_tree186,6742
+:- import_module parse_tree.error_util187,6771
+:- import_module parse_tree.prog_data188,6811
+:- import_module parse_tree.prog_mode189,6850
+:- import_module parse_tree.prog_util190,6889
+:- import_module parse_tree.set_of_var191,6928
+:- import_module transform_hlds.goal_store192,6968
+:- import_module assoc_list194,7013
+:- import_module bool195,7042
+:- import_module int196,7065
+:- import_module io197,7087
+:- import_module list198,7108
+:- import_module map199,7131
+:- import_module maybe200,7153
+:- import_module pair201,7177
+:- import_module require202,7200
+:- import_module set203,7226
+:- import_module solutions204,7248
+:- import_module string205,7276
+:- import_module term206,7301
+:- import_module varset207,7324
+:- type top_level213,7499
+:- type accu_goal_id225,7900
+:- type accu_case228,7964
+:- type accu_goal_store234,8091
+:- type accu_subst238,8216
+:- type accu_warning240,8264
+:- pred generate_warnings(334,12550
+:- pred generate_warning(342,12895
+:- pred should_attempt_accu_transform(365,13886
+:- pred should_attempt_accu_transform_2(398,15406
+:- pred accu_standardize(440,17390
+:- pred identify_goal_type(465,18169
+:- pred is_recursive_case(549,21175
+:- type store_info560,21713
+:- func initialize_goal_store(570,22060
+:- pred accu_store(580,22421
+:- pred identify_recursive_calls(601,23288
+:- pred identify_out_and_out_prime(626,24396
+:- type accu_sets676,26425
+:- pred accu_stage1(689,26977
+:- pred accu_stage1_2(727,28347
+:- pred accu_sets_init(781,30557
+:- func set_upto(796,30984
+:- pred accu_before(812,31498
+:- pred accu_assoc(835,32477
+:- pred accu_construct(862,33712
+:- pred accu_construct_assoc(896,35307
+:- pred accu_update(938,37069
+:- pred member_lessthan_goalid(964,38219
+:- type accu_assoc975,38652
+:- pred accu_is_associative(986,39138
+:- pred associativity_assertion(1014,40263
+:- pred commutativity_assertion(1037,41242
+:- pred accu_is_update(1057,41952
+:- pred is_associative_construction(1078,42802
+:- type accu_substs1095,43480
+:- type accu_base1103,43744
+:- pred accu_stage2(1124,44605
+:- pred accu_substs_init(1179,46957
+:- pred acc_var_subst_init(1194,47573
+:- pred create_new_var(1207,48147
+:- pred accu_process_assoc_set(1223,48862
+:- pred accu_has_heuristic(1297,52081
+:- pred accu_heuristic(1304,52336
+:- pred accu_process_update_set(1318,52906
+:- pred accu_divide_base_case(1380,55844
+:- pred accu_related(1412,57146
+:- pred lookup_call(1449,58601
+:- pred accu_stage3(1470,59432
+:- pred acc_proc_info(1508,61326
+:- pred acc_pred_info(1556,63449
+:- pred accu_create_goal(1600,65285
+:- func create_acc_call(1621,66400
+:- pred create_orig_goal(1634,66987
+:- pred create_acc_goal(1662,68157
+:- func create_new_orig_recursive_goals(1709,70225
+:- func create_new_recursive_goals(1723,70918
+:- func create_new_base_goals(1738,71717
+:- pred acc_unification(1749,72156
+:- pred accu_top_level(1766,72896
+:- pred update_accumulator_pred(1856,76290
+:- func accu_rename(1876,77253
+:- func base_case_ids(1889,77784
+:- func base_case_ids_set(1898,78048
+:- func accu_goal_list(1905,78269
+:- pred calculate_goal_info(1916,78680
+:- func chain_subst(1932,79319
+:- pred chain_subst_2(1938,79482
+:- end_module transform_hlds.accumulator1953,79939
+
c-src/c.c,76
T f(1,0
}T i;2,14
diff --git a/test/manual/etags/ETAGS.good_4 b/test/manual/etags/ETAGS.good_4
index d54cf1c..828a6b8 100644
--- a/test/manual/etags/ETAGS.good_4
+++ b/test/manual/etags/ETAGS.good_4
@@ -4043,6 +4043,122 @@
Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno %
\global\def={=3307,107500
\def\normalbackslash{\normalbackslash3321,107882
+merc-src/accumulator.m,4275
+:- module transform_hlds.accumulator145,5333
+:- import_module hlds148,5386
+:- import_module hlds.hlds_module149,5409
+:- import_module hlds.hlds_pred150,5444
+:- import_module univ152,5478
+:- pred accu_transform_proc(159,5793
+:- import_module hlds.assertion168,6135
+:- import_module hlds.goal_util169,6168
+:- import_module hlds.hlds_error_util170,6201
+:- import_module hlds.hlds_goal171,6240
+:- import_module hlds.hlds_out172,6273
+:- import_module hlds.hlds_out.hlds_out_util173,6305
+:- import_module hlds.hlds_promise174,6351
+:- import_module hlds.instmap175,6387
+:- import_module hlds.pred_table176,6418
+:- import_module hlds.quantification177,6452
+:- import_module hlds.status178,6490
+:- import_module hlds.vartypes179,6520
+:- import_module libs180,6552
+:- import_module libs.globals181,6575
+:- import_module libs.optimization_options182,6606
+:- import_module libs.options183,6650
+:- import_module mdbcomp184,6681
+:- import_module mdbcomp.sym_name185,6707
+:- import_module parse_tree186,6742
+:- import_module parse_tree.error_util187,6771
+:- import_module parse_tree.prog_data188,6811
+:- import_module parse_tree.prog_mode189,6850
+:- import_module parse_tree.prog_util190,6889
+:- import_module parse_tree.set_of_var191,6928
+:- import_module transform_hlds.goal_store192,6968
+:- import_module assoc_list194,7013
+:- import_module bool195,7042
+:- import_module int196,7065
+:- import_module io197,7087
+:- import_module list198,7108
+:- import_module map199,7131
+:- import_module maybe200,7153
+:- import_module pair201,7177
+:- import_module require202,7200
+:- import_module set203,7226
+:- import_module solutions204,7248
+:- import_module string205,7276
+:- import_module term206,7301
+:- import_module varset207,7324
+:- type top_level213,7499
+:- type accu_goal_id225,7900
+:- type accu_case228,7964
+:- type accu_goal_store234,8091
+:- type accu_subst238,8216
+:- type accu_warning240,8264
+:- pred generate_warnings(334,12550
+:- pred generate_warning(342,12895
+:- pred should_attempt_accu_transform(365,13886
+:- pred should_attempt_accu_transform_2(398,15406
+:- pred accu_standardize(440,17390
+:- pred identify_goal_type(465,18169
+:- pred is_recursive_case(549,21175
+:- type store_info560,21713
+:- func initialize_goal_store(570,22060
+:- pred accu_store(580,22421
+:- pred identify_recursive_calls(601,23288
+:- pred identify_out_and_out_prime(626,24396
+:- type accu_sets676,26425
+:- pred accu_stage1(689,26977
+:- pred accu_stage1_2(727,28347
+:- pred accu_sets_init(781,30557
+:- func set_upto(796,30984
+:- pred accu_before(812,31498
+:- pred accu_assoc(835,32477
+:- pred accu_construct(862,33712
+:- pred accu_construct_assoc(896,35307
+:- pred accu_update(938,37069
+:- pred member_lessthan_goalid(964,38219
+:- type accu_assoc975,38652
+:- pred accu_is_associative(986,39138
+:- pred associativity_assertion(1014,40263
+:- pred commutativity_assertion(1037,41242
+:- pred accu_is_update(1057,41952
+:- pred is_associative_construction(1078,42802
+:- type accu_substs1095,43480
+:- type accu_base1103,43744
+:- pred accu_stage2(1124,44605
+:- pred accu_substs_init(1179,46957
+:- pred acc_var_subst_init(1194,47573
+:- pred create_new_var(1207,48147
+:- pred accu_process_assoc_set(1223,48862
+:- pred accu_has_heuristic(1297,52081
+:- pred accu_heuristic(1304,52336
+:- pred accu_process_update_set(1318,52906
+:- pred accu_divide_base_case(1380,55844
+:- pred accu_related(1412,57146
+:- pred lookup_call(1449,58601
+:- pred accu_stage3(1470,59432
+:- pred acc_proc_info(1508,61326
+:- pred acc_pred_info(1556,63449
+:- pred accu_create_goal(1600,65285
+:- func create_acc_call(1621,66400
+:- pred create_orig_goal(1634,66987
+:- pred create_acc_goal(1662,68157
+:- func create_new_orig_recursive_goals(1709,70225
+:- func create_new_recursive_goals(1723,70918
+:- func create_new_base_goals(1738,71717
+:- pred acc_unification(1749,72156
+:- pred accu_top_level(1766,72896
+:- pred update_accumulator_pred(1856,76290
+:- func accu_rename(1876,77253
+:- func base_case_ids(1889,77784
+:- func base_case_ids_set(1898,78048
+:- func accu_goal_list(1905,78269
+:- pred calculate_goal_info(1916,78680
+:- func chain_subst(1932,79319
+:- pred chain_subst_2(1938,79482
+:- end_module transform_hlds.accumulator1953,79939
+
c-src/c.c,76
T f(1,0
}T i;2,14
diff --git a/test/manual/etags/ETAGS.good_5 b/test/manual/etags/ETAGS.good_5
index af70a10..5b1dc4f 100644
--- a/test/manual/etags/ETAGS.good_5
+++ b/test/manual/etags/ETAGS.good_5
@@ -5023,6 +5023,180 @@
Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno %
\global\def={=3307,107500
\def\normalbackslash{\normalbackslash3321,107882
+merc-src/accumulator.m,5996
+:- module transform_hlds.accumulator145,5333
+:- import_module hlds148,5386
+:- import_module hlds.hlds_module149,5409
+:- import_module hlds.hlds_pred150,5444
+:- import_module univ152,5478
+:- pred accu_transform_proc(159,5793
+:- import_module hlds.assertion168,6135
+:- import_module hlds.goal_util169,6168
+:- import_module hlds.hlds_error_util170,6201
+:- import_module hlds.hlds_goal171,6240
+:- import_module hlds.hlds_out172,6273
+:- import_module hlds.hlds_out.hlds_out_util173,6305
+:- import_module hlds.hlds_promise174,6351
+:- import_module hlds.instmap175,6387
+:- import_module hlds.pred_table176,6418
+:- import_module hlds.quantification177,6452
+:- import_module hlds.status178,6490
+:- import_module hlds.vartypes179,6520
+:- import_module libs180,6552
+:- import_module libs.globals181,6575
+:- import_module libs.optimization_options182,6606
+:- import_module libs.options183,6650
+:- import_module mdbcomp184,6681
+:- import_module mdbcomp.sym_name185,6707
+:- import_module parse_tree186,6742
+:- import_module parse_tree.error_util187,6771
+:- import_module parse_tree.prog_data188,6811
+:- import_module parse_tree.prog_mode189,6850
+:- import_module parse_tree.prog_util190,6889
+:- import_module parse_tree.set_of_var191,6928
+:- import_module transform_hlds.goal_store192,6968
+:- import_module assoc_list194,7013
+:- import_module bool195,7042
+:- import_module int196,7065
+:- import_module io197,7087
+:- import_module list198,7108
+:- import_module map199,7131
+:- import_module maybe200,7153
+:- import_module pair201,7177
+:- import_module require202,7200
+:- import_module set203,7226
+:- import_module solutions204,7248
+:- import_module string205,7276
+:- import_module term206,7301
+:- import_module varset207,7324
+:- type top_level213,7499
+:- type accu_goal_id225,7900
+:- type accu_case228,7964
+:- type accu_goal_store234,8091
+:- type accu_subst238,8216
+:- type accu_warning240,8264
+accu_transform_proc(247,8578
+:- pred generate_warnings(334,12550
+generate_warnings(337,12669
+:- pred generate_warning(342,12895
+generate_warning(345,13001
+:- pred should_attempt_accu_transform(365,13886
+should_attempt_accu_transform(370,14123
+:- pred should_attempt_accu_transform_2(398,15406
+should_attempt_accu_transform_2(405,15763
+:- pred accu_standardize(440,17390
+accu_standardize(442,17455
+:- pred identify_goal_type(465,18169
+identify_goal_type(469,18359
+:- pred is_recursive_case(549,21175
+is_recursive_case(551,21253
+:- type store_info560,21713
+:- func initialize_goal_store(570,22060
+initialize_goal_store(573,22166
+:- pred accu_store(580,22421
+accu_store(584,22576
+:- pred identify_recursive_calls(601,23288
+identify_recursive_calls(604,23406
+:- pred identify_out_and_out_prime(626,24396
+identify_out_and_out_prime(631,24631
+:- type accu_sets676,26425
+:- pred accu_stage1(689,26977
+accu_stage1(693,27155
+:- pred accu_stage1_2(727,28347
+accu_stage1_2(731,28515
+:- pred accu_sets_init(781,30557
+accu_sets_init(783,30605
+:- func set_upto(796,30984
+set_upto(798,31039
+:- pred accu_before(812,31498
+accu_before(815,31639
+:- pred accu_assoc(835,32477
+accu_assoc(838,32617
+:- pred accu_construct(862,33712
+accu_construct(865,33856
+:- pred accu_construct_assoc(896,35307
+accu_construct_assoc(899,35457
+:- pred accu_update(938,37069
+accu_update(941,37210
+:- pred member_lessthan_goalid(964,38219
+member_lessthan_goalid(967,38342
+:- type accu_assoc975,38652
+:- pred accu_is_associative(986,39138
+accu_is_associative(989,39250
+:- pred associativity_assertion(1014,40263
+associativity_assertion(1017,40404
+:- pred commutativity_assertion(1037,41242
+commutativity_assertion(1040,41369
+:- pred accu_is_update(1057,41952
+accu_is_update(1060,42066
+:- pred is_associative_construction(1078,42802
+is_associative_construction(1081,42898
+:- type accu_substs1095,43480
+:- type accu_base1103,43744
+:- pred accu_stage2(1124,44605
+accu_stage2(1131,44946
+:- pred accu_substs_init(1179,46957
+accu_substs_init(1182,47097
+:- pred acc_var_subst_init(1194,47573
+acc_var_subst_init(1198,47718
+:- pred create_new_var(1207,48147
+create_new_var(1210,48288
+:- pred accu_process_assoc_set(1223,48862
+accu_process_assoc_set(1229,49150
+:- pred accu_has_heuristic(1297,52081
+accu_has_heuristic(1299,52161
+:- pred accu_heuristic(1304,52336
+accu_heuristic(1307,52457
+:- pred accu_process_update_set(1318,52906
+accu_process_update_set(1325,53221
+:- pred accu_divide_base_case(1380,55844
+accu_divide_base_case(1385,56059
+:- pred accu_related(1412,57146
+accu_related(1415,57270
+:- pred lookup_call(1449,58601
+lookup_call(1452,58715
+:- pred accu_stage3(1470,59432
+accu_stage3(1477,59826
+:- pred acc_proc_info(1508,61326
+acc_proc_info(1512,61485
+:- pred acc_pred_info(1556,63449
+acc_pred_info(1559,63597
+:- pred accu_create_goal(1600,65285
+accu_create_goal(1607,65628
+:- func create_acc_call(1621,66400
+create_acc_call(1625,66569
+:- pred create_orig_goal(1634,66987
+create_orig_goal(1638,67176
+:- pred create_acc_goal(1662,68157
+create_acc_goal(1667,68380
+:- func create_new_orig_recursive_goals(1709,70225
+create_new_orig_recursive_goals(1712,70368
+:- func create_new_recursive_goals(1723,70918
+create_new_recursive_goals(1727,71108
+:- func create_new_base_goals(1738,71717
+create_new_base_goals(1741,71831
+:- pred acc_unification(1749,72156
+acc_unification(1751,72225
+:- pred accu_top_level(1766,72896
+accu_top_level(1770,73058
+:- pred update_accumulator_pred(1856,76290
+update_accumulator_pred(1859,76411
+:- func accu_rename(1876,77253
+accu_rename(1879,77363
+:- func base_case_ids(1889,77784
+base_case_ids(1891,77846
+:- func base_case_ids_set(1898,78048
+base_case_ids_set(1900,78113
+:- func accu_goal_list(1905,78269
+accu_goal_list(1907,78349
+:- pred calculate_goal_info(1916,78680
+calculate_goal_info(1918,78753
+:- func chain_subst(1932,79319
+chain_subst(1934,79378
+:- pred chain_subst_2(1938,79482
+chain_subst_2(1941,79576
+:- end_module transform_hlds.accumulator1953,79939
+
c-src/c.c,76
T f(1,0
}T i;2,14
diff --git a/test/manual/etags/ETAGS.good_6 b/test/manual/etags/ETAGS.good_6
index abf2186..68cbaa9 100644
--- a/test/manual/etags/ETAGS.good_6
+++ b/test/manual/etags/ETAGS.good_6
@@ -5023,6 +5023,180 @@
Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno %
\global\def={=3307,107500
\def\normalbackslash{\normalbackslash3321,107882
+merc-src/accumulator.m,5996
+:- module transform_hlds.accumulator145,5333
+:- import_module hlds148,5386
+:- import_module hlds.hlds_module149,5409
+:- import_module hlds.hlds_pred150,5444
+:- import_module univ152,5478
+:- pred accu_transform_proc(159,5793
+:- import_module hlds.assertion168,6135
+:- import_module hlds.goal_util169,6168
+:- import_module hlds.hlds_error_util170,6201
+:- import_module hlds.hlds_goal171,6240
+:- import_module hlds.hlds_out172,6273
+:- import_module hlds.hlds_out.hlds_out_util173,6305
+:- import_module hlds.hlds_promise174,6351
+:- import_module hlds.instmap175,6387
+:- import_module hlds.pred_table176,6418
+:- import_module hlds.quantification177,6452
+:- import_module hlds.status178,6490
+:- import_module hlds.vartypes179,6520
+:- import_module libs180,6552
+:- import_module libs.globals181,6575
+:- import_module libs.optimization_options182,6606
+:- import_module libs.options183,6650
+:- import_module mdbcomp184,6681
+:- import_module mdbcomp.sym_name185,6707
+:- import_module parse_tree186,6742
+:- import_module parse_tree.error_util187,6771
+:- import_module parse_tree.prog_data188,6811
+:- import_module parse_tree.prog_mode189,6850
+:- import_module parse_tree.prog_util190,6889
+:- import_module parse_tree.set_of_var191,6928
+:- import_module transform_hlds.goal_store192,6968
+:- import_module assoc_list194,7013
+:- import_module bool195,7042
+:- import_module int196,7065
+:- import_module io197,7087
+:- import_module list198,7108
+:- import_module map199,7131
+:- import_module maybe200,7153
+:- import_module pair201,7177
+:- import_module require202,7200
+:- import_module set203,7226
+:- import_module solutions204,7248
+:- import_module string205,7276
+:- import_module term206,7301
+:- import_module varset207,7324
+:- type top_level213,7499
+:- type accu_goal_id225,7900
+:- type accu_case228,7964
+:- type accu_goal_store234,8091
+:- type accu_subst238,8216
+:- type accu_warning240,8264
+accu_transform_proc(247,8578
+:- pred generate_warnings(334,12550
+generate_warnings(337,12669
+:- pred generate_warning(342,12895
+generate_warning(345,13001
+:- pred should_attempt_accu_transform(365,13886
+should_attempt_accu_transform(370,14123
+:- pred should_attempt_accu_transform_2(398,15406
+should_attempt_accu_transform_2(405,15763
+:- pred accu_standardize(440,17390
+accu_standardize(442,17455
+:- pred identify_goal_type(465,18169
+identify_goal_type(469,18359
+:- pred is_recursive_case(549,21175
+is_recursive_case(551,21253
+:- type store_info560,21713
+:- func initialize_goal_store(570,22060
+initialize_goal_store(573,22166
+:- pred accu_store(580,22421
+accu_store(584,22576
+:- pred identify_recursive_calls(601,23288
+identify_recursive_calls(604,23406
+:- pred identify_out_and_out_prime(626,24396
+identify_out_and_out_prime(631,24631
+:- type accu_sets676,26425
+:- pred accu_stage1(689,26977
+accu_stage1(693,27155
+:- pred accu_stage1_2(727,28347
+accu_stage1_2(731,28515
+:- pred accu_sets_init(781,30557
+accu_sets_init(783,30605
+:- func set_upto(796,30984
+set_upto(798,31039
+:- pred accu_before(812,31498
+accu_before(815,31639
+:- pred accu_assoc(835,32477
+accu_assoc(838,32617
+:- pred accu_construct(862,33712
+accu_construct(865,33856
+:- pred accu_construct_assoc(896,35307
+accu_construct_assoc(899,35457
+:- pred accu_update(938,37069
+accu_update(941,37210
+:- pred member_lessthan_goalid(964,38219
+member_lessthan_goalid(967,38342
+:- type accu_assoc975,38652
+:- pred accu_is_associative(986,39138
+accu_is_associative(989,39250
+:- pred associativity_assertion(1014,40263
+associativity_assertion(1017,40404
+:- pred commutativity_assertion(1037,41242
+commutativity_assertion(1040,41369
+:- pred accu_is_update(1057,41952
+accu_is_update(1060,42066
+:- pred is_associative_construction(1078,42802
+is_associative_construction(1081,42898
+:- type accu_substs1095,43480
+:- type accu_base1103,43744
+:- pred accu_stage2(1124,44605
+accu_stage2(1131,44946
+:- pred accu_substs_init(1179,46957
+accu_substs_init(1182,47097
+:- pred acc_var_subst_init(1194,47573
+acc_var_subst_init(1198,47718
+:- pred create_new_var(1207,48147
+create_new_var(1210,48288
+:- pred accu_process_assoc_set(1223,48862
+accu_process_assoc_set(1229,49150
+:- pred accu_has_heuristic(1297,52081
+accu_has_heuristic(1299,52161
+:- pred accu_heuristic(1304,52336
+accu_heuristic(1307,52457
+:- pred accu_process_update_set(1318,52906
+accu_process_update_set(1325,53221
+:- pred accu_divide_base_case(1380,55844
+accu_divide_base_case(1385,56059
+:- pred accu_related(1412,57146
+accu_related(1415,57270
+:- pred lookup_call(1449,58601
+lookup_call(1452,58715
+:- pred accu_stage3(1470,59432
+accu_stage3(1477,59826
+:- pred acc_proc_info(1508,61326
+acc_proc_info(1512,61485
+:- pred acc_pred_info(1556,63449
+acc_pred_info(1559,63597
+:- pred accu_create_goal(1600,65285
+accu_create_goal(1607,65628
+:- func create_acc_call(1621,66400
+create_acc_call(1625,66569
+:- pred create_orig_goal(1634,66987
+create_orig_goal(1638,67176
+:- pred create_acc_goal(1662,68157
+create_acc_goal(1667,68380
+:- func create_new_orig_recursive_goals(1709,70225
+create_new_orig_recursive_goals(1712,70368
+:- func create_new_recursive_goals(1723,70918
+create_new_recursive_goals(1727,71108
+:- func create_new_base_goals(1738,71717
+create_new_base_goals(1741,71831
+:- pred acc_unification(1749,72156
+acc_unification(1751,72225
+:- pred accu_top_level(1766,72896
+accu_top_level(1770,73058
+:- pred update_accumulator_pred(1856,76290
+update_accumulator_pred(1859,76411
+:- func accu_rename(1876,77253
+accu_rename(1879,77363
+:- func base_case_ids(1889,77784
+base_case_ids(1891,77846
+:- func base_case_ids_set(1898,78048
+base_case_ids_set(1900,78113
+:- func accu_goal_list(1905,78269
+accu_goal_list(1907,78349
+:- pred calculate_goal_info(1916,78680
+calculate_goal_info(1918,78753
+:- func chain_subst(1932,79319
+chain_subst(1934,79378
+:- pred chain_subst_2(1938,79482
+chain_subst_2(1941,79576
+:- end_module transform_hlds.accumulator1953,79939
+
c-src/c.c,76
T f(1,0
}T i;2,14
diff --git a/test/manual/etags/Makefile b/test/manual/etags/Makefile
index 8d56db2..b3a82fd 100644
--- a/test/manual/etags/Makefile
+++ b/test/manual/etags/Makefile
@@ -16,6 +16,7 @@ HTMLSRC=$(addprefix ./html-src/,softwarelibero.html
index.shtml algrthms.html so
#JAVASRC=$(addprefix ./java-src/, )
LUASRC=$(addprefix ./lua-src/,allegro.lua test.lua)
MAKESRC=$(addprefix ./make-src/,Makefile)
+MERCSRC=$(addprefix ./merc-src/,accumulator.m)
OBJCSRC=$(addprefix ./objc-src/,Subprocess.h Subprocess.m PackInsp.h
PackInsp.m)
OBJCPPSRC=$(addprefix ./objcpp-src/,SimpleCalc.H SimpleCalc.M)
PASSRC=$(addprefix ./pas-src/,common.pas)
@@ -32,7 +33,7 @@ YSRC=$(addprefix ./y-src/,parse.y parse.c atest.y cccp.c
cccp.y)
SRCS=${ADASRC} ${ASRC} ${CSRC} ${CPSRC} ${ELSRC} ${ERLSRC} ${FSRC}\
${FORTHSRC} ${GOSRC} ${HTMLSRC} ${JAVASRC} ${LUASRC} ${MAKESRC}\
${OBJCSRC} ${OBJCPPSRC} ${PASSRC} ${PHPSRC} ${PERLSRC} ${PSSRC}\
- ${PROLSRC} ${PYTSRC} ${RBSRC} ${RSSRC} ${SCMSRC} ${TEXSRC} ${YSRC}
+ ${PROLSRC} ${PYTSRC} ${RBSRC} ${RSSRC} ${SCMSRC} ${TEXSRC} ${YSRC}
${MERCSRC}
NONSRCS=./f-src/entry.strange ./erl-src/lists.erl ./cp-src/clheir.hpp.gz
ETAGS_PROG=../../../lib-src/etags
diff --git a/test/manual/etags/merc-src/accumulator.m
b/test/manual/etags/merc-src/accumulator.m
new file mode 100644
index 0000000..94a6b1d
--- /dev/null
+++ b/test/manual/etags/merc-src/accumulator.m
@@ -0,0 +1,1954 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+% Copyright (C) 1999-2000,2002-2007, 2009-2012 The University of Melbourne.
+% Copyright (C) 2015 The Mercury team.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% Module: accumulator.m.
+% Main authors: petdr.
+%
+% Attempts to transform a single proc to a tail recursive form by
+% introducing accumulators. The algorithm can do this if the code after
+% the recursive call has either the order independent state update or
+% associative property.
+%
+% /* Order independent State update property */
+% :- promise all [A,B,S0,S]
+% (
+% (some[SA] (update(A, S0, SA), update(B, SA, S)))
+% <=>
+% (some[SB] (update(B, S0, SB), update(A, SB, S)))
+% ).
+%
+% /* Associativity property */
+% :- promise all [A,B,C,ABC]
+% (
+% (some[AB] (assoc(A, B, AB), assoc(AB, C, ABC)))
+% <=>
+% (some[BC] (assoc(B, C, BC), assoc(A, BC, ABC)))
+% ).
+%
+% XXX What about exceptions and non-termination?
+%
+% The promise declarations above only provide promises about the declarative
+% semantics, but in order to apply this optimization, we ought to check that
+% it will preserve the operational semantics (modulo whatever changes are
+% allowed by the language semantics options).
+%
+% Currently we check and respect the --fully-strict option, but not the
+% --no-reorder-conj option. XXX we should check --no-reorder-conj!
+% If --no-reorder-conj was set, it would still be OK to apply this
+% transformation, but ONLY in cases where the goals which get reordered
+% are guaranteed not to throw any exceptions.
+%
+% The algorithm implemented is a combination of the algorithms from
+% "Making Mercury Programs Tail Recursive" and
+% "State Update Transformation", which can be found at
+% <http://www.cs.mu.oz.au/research/mercury/information/papers.html>.
+%
+% Note that currently "State Update Transformation" paper only resides
+% in CVS papers archive in the directory update, but has been submitted
+% to PPDP '00.
+%
+% The transformation recognises predicates in the form
+%
+% p(In, OutUpdate, OutAssoc) :-
+% minimal(In),
+% initialize(OutUpdate),
+% base(OutAssoc).
+% p(In, OutUpdate, OutAssoc) :-
+% decompose(In, Current, Rest),
+% p(Rest, OutUpdate0, OutAssoc0),
+% update(Current, OutUpdate0, OutUpdate),
+% assoc(Current, OutAssoc0, OutAssoc).
+%
+% which can be transformed by the algorithm in "State Update Transformation" to
+%
+% p(In, OutUpdate, OutAssoc) :-
+% initialize(AccUpdate),
+% p_acc(In, OutUpdate, OutAssoc, AccUpdate).
+%
+% p_acc(In, OutUpdate, OutAssoc, AccUpdate) :-
+% minimal(In),
+% base(OutAssoc),
+% OutUpdate = AccUpdate.
+% p_acc(In, OutUpdate, OutAssoc, AccUpdate0) :-
+% decompose(In, Current, Rest),
+% update(Current, AccUpdate0, AccUpdate),
+% p_acc(Rest, OutUpdate, OutAssoc0, AccUpdate),
+% assoc(Current, OutAssoc0, OutAssoc).
+%
+% we then apply the algorithm from "Making Mercury Programs Tail Recursive"
+% to p_acc to obtain
+%
+% p_acc(In, OutUpdate, OutAssoc, AccUpdate) :-
+% minimal(In),
+% base(OutAssoc),
+% OutUpdate = AccUpdate.
+% p_acc(In, OutUpdate, OutAssoc, AccUpdate0) :-
+% decompose(In, Current, Rest),
+% update(Current, AccUpdate0, AccUpdate),
+% p_acc2(Rest, OutUpdate, OutAssoc, AccUpdate, Current).
+%
+% p_acc2(In, OutUpdate, OutAssoc, AccUpdate0, AccAssoc0) :-
+% minimal(In),
+% base(Base),
+% assoc(AccAssoc0, Base, OutAssoc),
+% OutUpdate = AccUpdate0.
+% p_acc2(In, OutUpdate, OutAssoc, AccUpdate0, AccAssoc0) :-
+% decompose(In, Current, Rest),
+% update(Current, AccUpdate0, AccUpdate),
+% assoc(AccAssoc0, Current, AccAssoc),
+% p_acc2(Rest, OutUpdate, OutAssoc, AccUpdate, AccAssoc).
+%
+% p_acc is no longer recursive and is only ever called from p, so we
+% inline p_acc into p to obtain the final schema.
+%
+% p(In, OutUpdate, OutAssoc) :-
+% minimal(In),
+% base(OutAssoc),
+% initialize(AccUpdate),
+% OutUpdate = AccUpdate.
+% p(In, OutUpdate, OutAssoc) :-
+% decompose(In, Current, Rest),
+% initialize(AccUpdate0),
+% update(Current, AccUpdate0, AccUpdate),
+% p_acc2(Rest, OutUpdate, OutAssoc, AccUpdate, Current).
+%
+% p_acc2(In, OutUpdate, OutAssoc, AccUpdate0, AccAssoc0) :-
+% minimal(In),
+% base(Base),
+% assoc(AccAssoc0, Base, OutAssoc),
+% OutUpdate = AccUpdate0.
+% p_acc2(In, OutUpdate, OutAssoc, AccUpdate0, AccAssoc0) :-
+% decompose(In, Current, Rest),
+% update(Current, AccUpdate0, AccUpdate),
+% assoc(AccAssoc0, Current, AccAssoc),
+% p_acc2(Rest, OutUpdate, OutAssoc, AccUpdate, AccAssoc).
+%
+% The only real difficulty in this new transformation is identifying the
+% initialize/1 and base/1 goals from the original base case.
+%
+% Note that if the recursive clause contains multiple calls to p, the
+% transformation attempts to move each recursive call to the end
+% until one succeeds. This makes the order of independent recursive
+% calls in the body irrelevant.
+%
+% XXX Replace calls to can_reorder_goals with calls to the version that
+% use the intermodule-analysis framework.
+%
+%---------------------------------------------------------------------------%
+
+:- module transform_hlds.accumulator.
+:- interface.
+
+:- import_module hlds.
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+
+:- import_module univ.
+
+ % Attempt to transform a procedure into accumulator recursive form.
+ % If we succeed, we will add the recursive version of the procedure
+ % to the module_info. However, we may also encounter errors, which
+ % we will add to the list of error_specs in the univ accumulator.
+ %
+:- pred accu_transform_proc(pred_proc_id::in, pred_info::in,
+ proc_info::in, proc_info::out, module_info::in, module_info::out,
+ univ::in, univ::out) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module hlds.assertion.
+:- import_module hlds.goal_util.
+:- import_module hlds.hlds_error_util.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_out.
+:- import_module hlds.hlds_out.hlds_out_util.
+:- import_module hlds.hlds_promise.
+:- import_module hlds.instmap.
+:- import_module hlds.pred_table.
+:- import_module hlds.quantification.
+:- import_module hlds.status.
+:- import_module hlds.vartypes.
+:- import_module libs.
+:- import_module libs.globals.
+:- import_module libs.optimization_options.
+:- import_module libs.options.
+:- import_module mdbcomp.
+:- import_module mdbcomp.sym_name.
+:- import_module parse_tree.
+:- import_module parse_tree.error_util.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_util.
+:- import_module parse_tree.set_of_var.
+:- import_module transform_hlds.goal_store.
+
+:- import_module assoc_list.
+:- import_module bool.
+:- import_module int.
+:- import_module io.
+:- import_module list.
+:- import_module map.
+:- import_module maybe.
+:- import_module pair.
+:- import_module require.
+:- import_module set.
+:- import_module solutions.
+:- import_module string.
+:- import_module term.
+:- import_module varset.
+
+%---------------------------------------------------------------------------%
+
+ % The form of the goal around the base and recursive cases.
+ %
+:- type top_level
+ ---> switch_base_rec
+ ; switch_rec_base
+ ; disj_base_rec
+ ; disj_rec_base
+ ; ite_base_rec
+ ; ite_rec_base.
+
+ % An accu_goal_id represents a goal. The first field says which conjunction
+ % the goal came from (the base case or the recursive case), and the second
+ % gives the location of the goal in that conjunction.
+ %
+:- type accu_goal_id
+ ---> accu_goal_id(accu_case, int).
+
+:- type accu_case
+ ---> accu_base
+ ; accu_rec.
+
+ % The goal_store associates a goal with each goal_id.
+ %
+:- type accu_goal_store == goal_store(accu_goal_id).
+
+ % A substitution from the first variable name to the second.
+ %
+:- type accu_subst == map(prog_var, prog_var).
+
+:- type accu_warning
+ ---> accu_warn(prog_context, pred_id, prog_var, prog_var).
+ % Warn that two prog_vars in a call to pred_id at the given context
+ % were swapped, which may cause an efficiency problem.
+
+%---------------------------------------------------------------------------%
+
+accu_transform_proc(proc(PredId, ProcId), PredInfo, !ProcInfo, !ModuleInfo,
+ !Cookie) :-
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.get_opt_tuple(Globals, OptTuple),
+ DoLCMC = OptTuple ^ ot_opt_lcmc_accumulator,
+ globals.lookup_bool_option(Globals, fully_strict, FullyStrict),
+ ( if
+ should_attempt_accu_transform(!ModuleInfo, PredId, ProcId, PredInfo,
+ !ProcInfo, FullyStrict, DoLCMC, Warnings)
+ then
+ globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
+ (
+ VeryVerbose = yes,
+ trace [io(!IO)] (
+ module_info_get_name(!.ModuleInfo, ModuleName),
+ get_progress_output_stream(Globals, ModuleName,
+ ProgressStream, !IO),
+ PredStr = pred_id_to_string(!.ModuleInfo, PredId),
+ io.format(ProgressStream,
+ "%% Accumulators introduced into %s\n", [s(PredStr)], !IO)
+ )
+ ;
+ VeryVerbose = no
+ ),
+
+ (
+ Warnings = []
+ ;
+ Warnings = [_ | _],
+ pred_info_get_context(PredInfo, Context),
+ PredPieces = describe_one_pred_name(!.ModuleInfo,
+ should_module_qualify, PredId),
+ InPieces = [words("In") | PredPieces] ++ [suffix(":"), nl],
+ InMsg = simple_msg(Context,
+ [option_is_set(warn_accumulator_swaps, yes,
+ [always(InPieces)])]),
+
+ proc_info_get_varset(!.ProcInfo, VarSet),
+ generate_warnings(!.ModuleInfo, VarSet, Warnings, WarnMsgs),
+ (
+ Warnings = [_],
+ EnsurePieces = [words("Please ensure that this"),
+ words("argument rearrangement does not introduce"),
+ words("performance problems.")]
+ ;
+ Warnings = [_, _ | _],
+ EnsurePieces = [words("Please ensure that these"),
+ words("argument rearrangements do not introduce"),
+ words("performance problems.")]
+ ),
+ SuppressPieces =
+ [words("These warnings can be suppressed by"),
+ quote("--no-warn-accumulator-swaps"), suffix(".")],
+ VerbosePieces = [words("If a predicate has been declared"),
+ words("associative"),
+ words("via a"), quote("promise"), words("declaration,"),
+ words("the compiler will rearrange the order of"),
+ words("the arguments in calls to that predicate,"),
+ words("if by so doing it makes the containing predicate"),
+ words("tail recursive. In such situations, the compiler"),
+ words("will issue this warning. If this reordering"),
+ words("changes the performance characteristics"),
+ words("of the call to the predicate, use"),
+ quote("--no-accumulator-introduction"),
+ words("to turn the optimization off, or "),
+ quote("--no-warn-accumulator-swaps"),
+ words("to turn off the warnings.")],
+ EnsureSuppressMsg = simple_msg(Context,
+ [option_is_set(warn_accumulator_swaps, yes,
+ [always(EnsurePieces), always(SuppressPieces)]),
+ verbose_only(verbose_once, VerbosePieces)]),
+ Severity = severity_conditional(warn_accumulator_swaps, yes,
+ severity_warning, no),
+ Msgs = [InMsg | WarnMsgs] ++ [EnsureSuppressMsg],
+ Spec = error_spec($pred, Severity, phase_accumulator_intro, Msgs),
+
+ det_univ_to_type(!.Cookie, Specs0),
+ Specs = [Spec | Specs0],
+ type_to_univ(Specs, !:Cookie)
+ )
+ else
+ true
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- pred generate_warnings(module_info::in, prog_varset::in,
+ list(accu_warning)::in, list(error_msg)::out) is det.
+
+generate_warnings(_, _, [], []).
+generate_warnings(ModuleInfo, VarSet, [Warning | Warnings], [Msg | Msgs]) :-
+ generate_warning(ModuleInfo, VarSet, Warning, Msg),
+ generate_warnings(ModuleInfo, VarSet, Warnings, Msgs).
+
+:- pred generate_warning(module_info::in, prog_varset::in, accu_warning::in,
+ error_msg::out) is det.
+
+generate_warning(ModuleInfo, VarSet, Warning, Msg) :-
+ Warning = accu_warn(Context, PredId, VarA, VarB),
+ PredPieces = describe_one_pred_name(ModuleInfo, should_module_qualify,
+ PredId),
+
+ varset.lookup_name(VarSet, VarA, VarAName),
+ varset.lookup_name(VarSet, VarB, VarBName),
+
+ Pieces = [words("warning: the call to")] ++ PredPieces ++
+ [words("has had the location of the variables"),
+ quote(VarAName), words("and"), quote(VarBName),
+ words("swapped to allow accumulator introduction."), nl],
+ Msg = simplest_msg(Context, Pieces).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % should_attempt_accu_transform is only true iff the current proc
+ % has been transformed to call the newly created accumulator proc.
+ %
+:- pred should_attempt_accu_transform(module_info::in, module_info::out,
+ pred_id::in, proc_id::in, pred_info::in, proc_info::in, proc_info::out,
+ bool::in, maybe_opt_lcmc_accumulator::in,
+ list(accu_warning)::out) is semidet.
+
+should_attempt_accu_transform(!ModuleInfo, PredId, ProcId, PredInfo,
+ !ProcInfo, FullyStrict, DoLCMC, Warnings) :-
+ proc_info_get_goal(!.ProcInfo, Goal0),
+ proc_info_get_headvars(!.ProcInfo, HeadVars),
+ proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InitialInstMap),
+ accu_standardize(Goal0, Goal),
+ identify_goal_type(PredId, ProcId, Goal, InitialInstMap,
+ TopLevel, Base, BaseInstMap, Rec, RecInstMap),
+
+ C = initialize_goal_store(Rec, RecInstMap, Base, BaseInstMap),
+ identify_recursive_calls(PredId, ProcId, C, RecCallIds),
+ list.length(Rec, M),
+
+ should_attempt_accu_transform_2(!ModuleInfo, PredId, PredInfo, !ProcInfo,
+ HeadVars, InitialInstMap, TopLevel, FullyStrict, DoLCMC,
+ RecCallIds, C, M, Rec, Warnings).
+
+ % should_attempt_accu_transform_2 takes a list of locations of the
+ % recursive calls, and attempts to introduce accumulator into each of the
+ % recursive calls, stopping at the first one that succeeds.
+ % This catches the following case, as selecting the first recursive call
+ % allows the second recursive call to be moved before it, and
+ % OutA is in the correct spot in list.append.
+ %
+ % p(InA, OutA),
+ % p(InB, OutB),
+ % list.append(OutB, OutA, Out)
+ %
+:- pred should_attempt_accu_transform_2(module_info::in, module_info::out,
+ pred_id::in, pred_info::in, proc_info::in, proc_info::out,
+ list(prog_var)::in, instmap::in, top_level::in, bool::in,
+ maybe_opt_lcmc_accumulator::in,
+ list(accu_goal_id)::in, accu_goal_store::in, int::in, list(hlds_goal)::in,
+ list(accu_warning)::out) is semidet.
+
+should_attempt_accu_transform_2(!ModuleInfo, PredId, PredInfo, !ProcInfo,
+ HeadVars, InitialInstMap, TopLevel, FullyStrict, DoLCMC,
+ [Id | Ids], C, M, Rec, Warnings) :-
+ proc_info_get_vartypes(!.ProcInfo, VarTypes0),
+ identify_out_and_out_prime(!.ModuleInfo, VarTypes0, InitialInstMap,
+ Id, Rec, HeadVars, Out, OutPrime, HeadToCallSubst, CallToHeadSubst),
+ ( if
+ accu_stage1(!.ModuleInfo, VarTypes0, FullyStrict, DoLCMC, Id, M, C,
+ Sets),
+ accu_stage2(!.ModuleInfo, !.ProcInfo, Id, C, Sets, OutPrime, Out,
+ VarSet, VarTypes, Accs, BaseCase, BasePairs, Substs, CS,
+ WarningsPrime),
+ accu_stage3(Id, Accs, VarSet, VarTypes, C, CS, Substs,
+ HeadToCallSubst, CallToHeadSubst, BaseCase, BasePairs, Sets, Out,
+ TopLevel, PredId, PredInfo, !ProcInfo, !ModuleInfo)
+ then
+ Warnings = WarningsPrime
+ else
+ should_attempt_accu_transform_2(!ModuleInfo, PredId, PredInfo,
+ !ProcInfo, HeadVars, InitialInstMap, TopLevel, FullyStrict, DoLCMC,
+ Ids, C, M, Rec, Warnings)
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % Transform the goal into a standard form that is amenable to
+ % introducing accumulators.
+ %
+ % At the moment all this does is remove any extra disj/conj wrappers
+ % around the top level goal.
+ %
+ % Future work is for this code to rearrange code with multiple base
+ % and recursive cases into a single base and recursive case.
+ %
+:- pred accu_standardize(hlds_goal::in, hlds_goal::out) is det.
+
+accu_standardize(Goal0, Goal) :-
+ ( if
+ Goal0 = hlds_goal(GoalExpr0, _),
+ (
+ GoalExpr0 = conj(plain_conj, [Goal1])
+ ;
+ GoalExpr0 = disj([Goal1])
+ )
+ then
+ accu_standardize(Goal1, Goal)
+ else
+ Goal = Goal0
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % This predicate takes the original goal and identifies the `shape'
+ % of the goal around the recursive and base cases.
+ %
+ % Note that the base case can contain a recursive call, as the
+ % transformation doesn't depend on what is in the base case.
+ %
+:- pred identify_goal_type(pred_id::in, proc_id::in, hlds_goal::in,
+ instmap::in, top_level::out, list(hlds_goal)::out, instmap::out,
+ list(hlds_goal)::out, instmap::out) is semidet.
+
+identify_goal_type(PredId, ProcId, Goal, InitialInstMap, Type,
+ Base, BaseInstMap, Rec, RecInstMap) :-
+ Goal = hlds_goal(GoalExpr, _GoalInfo),
+ (
+ GoalExpr = switch(_Var, _CanFail, Cases),
+ ( if
+ Cases = [case(_IdA, [], GoalA), case(_IdB, [], GoalB)],
+ goal_to_conj_list(GoalA, GoalAList),
+ goal_to_conj_list(GoalB, GoalBList)
+ then
+ ( if is_recursive_case(GoalAList, proc(PredId, ProcId)) then
+ Type = switch_rec_base,
+ Base = GoalBList,
+ Rec = GoalAList
+ else if is_recursive_case(GoalBList, proc(PredId, ProcId)) then
+ Type = switch_base_rec,
+ Base = GoalAList,
+ Rec = GoalBList
+ else
+ fail
+ ),
+ BaseInstMap = InitialInstMap,
+ RecInstMap = InitialInstMap
+ else
+ fail
+ )
+ ;
+ GoalExpr = disj(Goals),
+ ( if
+ Goals = [GoalA, GoalB],
+ goal_to_conj_list(GoalA, GoalAList),
+ goal_to_conj_list(GoalB, GoalBList)
+ then
+ ( if is_recursive_case(GoalAList, proc(PredId, ProcId)) then
+ Type = disj_rec_base,
+ Base = GoalBList,
+ Rec = GoalAList
+ else if is_recursive_case(GoalBList, proc(PredId, ProcId)) then
+ Type = disj_base_rec,
+ Base = GoalAList,
+ Rec = GoalBList
+ else
+ fail
+ ),
+ BaseInstMap = InitialInstMap,
+ RecInstMap = InitialInstMap
+ else
+ fail
+ )
+ ;
+ GoalExpr = if_then_else(_Vars, Cond, Then, Else),
+ Cond = hlds_goal(_CondGoalExpr, CondGoalInfo),
+ CondInstMapDelta = goal_info_get_instmap_delta(CondGoalInfo),
+
+ goal_to_conj_list(Then, GoalAList),
+ goal_to_conj_list(Else, GoalBList),
+ ( if is_recursive_case(GoalAList, proc(PredId, ProcId)) then
+ Type = ite_rec_base,
+ Base = GoalBList,
+ Rec = GoalAList,
+
+ BaseInstMap = InitialInstMap,
+ apply_instmap_delta(CondInstMapDelta, InitialInstMap, RecInstMap)
+ else if is_recursive_case(GoalBList, proc(PredId, ProcId)) then
+ Type = ite_base_rec,
+ Base = GoalAList,
+ Rec = GoalBList,
+
+ RecInstMap = InitialInstMap,
+ apply_instmap_delta(CondInstMapDelta, InitialInstMap, BaseInstMap)
+ else
+ fail
+ )
+ ).
+
+ % is_recursive_case(Gs, Id) is true iff the list of goals, Gs,
+ % contains a call to the procedure specified by Id, where the call
+ % is located in a position that can be used by the transformation
+ % (i.e. not hidden in a compound goal).
+ %
+:- pred is_recursive_case(list(hlds_goal)::in, pred_proc_id::in) is semidet.
+
+is_recursive_case(Goals, proc(PredId, ProcId)) :-
+ list.append(_Initial, [RecursiveCall | _Final], Goals),
+ RecursiveCall = hlds_goal(plain_call(PredId, ProcId, _, _, _, _), _).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % The store info is folded over the list of goals which
+ % represent the base and recursive case conjunctions.
+:- type store_info
+ ---> store_info(
+ store_loc :: int,
+ % The location of the goal in the conjunction.
+ store_instmap :: instmap,
+ store_goals :: accu_goal_store
+ ).
+
+ % Initialise the goal_store, which will hold the C_{a,b} goals.
+ %
+:- func initialize_goal_store(list(hlds_goal), instmap,
+ list(hlds_goal), instmap) = accu_goal_store.
+
+initialize_goal_store(Rec, RecInstMap, Base, BaseInstMap) = C :-
+ goal_store_init(C0),
+ list.foldl3(accu_store(accu_rec), Rec,
+ 1, _, RecInstMap, _, C0, C1),
+ list.foldl3(accu_store(accu_base), Base,
+ 1, _, BaseInstMap, _, C1, C).
+
+:- pred accu_store(accu_case::in, hlds_goal::in,
+ int::in, int::out, instmap::in, instmap::out,
+ accu_goal_store::in, accu_goal_store::out) is det.
+
+accu_store(Case, Goal, !N, !InstMap, !GoalStore) :-
+ Id = accu_goal_id(Case, !.N),
+ goal_store_det_insert(Id, stored_goal(Goal, !.InstMap), !GoalStore),
+
+ !:N = !.N + 1,
+ Goal = hlds_goal(_, GoalInfo),
+ InstMapDelta = goal_info_get_instmap_delta(GoalInfo),
+ apply_instmap_delta(InstMapDelta, !InstMap).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % Determine the k's which are recursive calls.
+ % Note that this doesn't find recursive calls which are `hidden'
+ % in compound goals, this is not a problem as currently we can't use
+ % these to do transformation.
+ %
+:- pred identify_recursive_calls(pred_id::in, proc_id::in,
+ accu_goal_store::in, list(accu_goal_id)::out) is det.
+
+identify_recursive_calls(PredId, ProcId, GoalStore, Ids) :-
+ P =
+ ( pred(Key::out) is nondet :-
+ goal_store_member(GoalStore, Key, stored_goal(Goal, _InstMap)),
+ Key = accu_goal_id(accu_rec, _),
+ Goal = hlds_goal(plain_call(PredId, ProcId, _, _, _, _), _)
+ ),
+ solutions.solutions(P, Ids).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % Determine the variables which are members of the sets Out and Out',
+ % and initialize the substitutions between the two sets.
+ %
+ % This is done by identifing those variables whose instantiatedness change
+ % in the goals after the recursive call and are headvars.
+ %
+ % Note that we are only identifying the output variables which will need
+ % to be accumulated, as there may be other output variables which are
+ % produced prior to the recursive call.
+ %
+:- pred identify_out_and_out_prime(module_info::in, vartypes::in, instmap::in,
+ accu_goal_id::in, list(hlds_goal)::in,
+ list(prog_var)::in, list(prog_var)::out, list(prog_var)::out,
+ accu_subst::out, accu_subst::out) is det.
+
+identify_out_and_out_prime(ModuleInfo, VarTypes, InitialInstMap, GoalId,
+ Rec, HeadVars, Out, OutPrime, HeadToCallSubst, CallToHeadSubst) :-
+ GoalId = accu_goal_id(_Case, K),
+ ( if
+ list.take(K, Rec, InitialGoals),
+ list.drop(K-1, Rec, FinalGoals),
+ FinalGoals = [hlds_goal(plain_call(_, _, Args, _, _, _), _) | Rest]
+ then
+ goal_list_instmap_delta(InitialGoals, InitInstMapDelta),
+ apply_instmap_delta( InitInstMapDelta,
+ InitialInstMap, InstMapBeforeRest),
+
+ goal_list_instmap_delta(Rest, InstMapDelta),
+ apply_instmap_delta(InstMapDelta, InstMapBeforeRest, InstMapAfterRest),
+
+ instmap_changed_vars(ModuleInfo, VarTypes,
+ InstMapBeforeRest, InstMapAfterRest, ChangedVars),
+
+ assoc_list.from_corresponding_lists(HeadVars, Args, HeadArg0),
+
+ Member =
+ ( pred(M::in) is semidet :-
+ M = HeadVar - _,
+ set_of_var.member(ChangedVars, HeadVar)
+ ),
+ list.filter(Member, HeadArg0, HeadArg),
+ list.map(fst, HeadArg, Out),
+ list.map(snd, HeadArg, OutPrime),
+
+ map.from_assoc_list(HeadArg, HeadToCallSubst),
+
+ list.map((pred(X-Y::in, Y-X::out) is det), HeadArg, ArgHead),
+ map.from_assoc_list(ArgHead, CallToHeadSubst)
+ else
+ unexpected($pred, "test failed")
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % For each goal after the recursive call, we place that goal
+ % into a set according to what properties that goal has.
+ % For the definition of what goes into each set, inspect the documentation
+ % for the functions named before, assoc, and so on.
+ %
+:- type accu_sets
+ ---> accu_sets(
+ as_before :: set(accu_goal_id),
+ as_assoc :: set(accu_goal_id),
+ as_construct_assoc :: set(accu_goal_id),
+ as_construct :: set(accu_goal_id),
+ as_update :: set(accu_goal_id),
+ as_reject :: set(accu_goal_id)
+ ).
+
+ % Stage 1 is responsible for identifying which goals are associative,
+ % which can be moved before the recursive call and so on.
+ %
+:- pred accu_stage1(module_info::in, vartypes::in, bool::in,
+ maybe_opt_lcmc_accumulator::in, accu_goal_id::in, int::in,
+ accu_goal_store::in, accu_sets::out) is semidet.
+
+accu_stage1(ModuleInfo, VarTypes, FullyStrict, DoLCMC, GoalId, M, GoalStore,
+ Sets) :-
+ GoalId = accu_goal_id(Case, K),
+ NextGoalId = accu_goal_id(Case, K + 1),
+ accu_sets_init(Sets0),
+ accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M,
+ GoalStore, Sets0, Sets1),
+ Sets1 = accu_sets(Before, Assoc,
+ ConstructAssoc, Construct, Update, Reject),
+ Sets = accu_sets(Before `set.union` set_upto(Case, K - 1), Assoc,
+ ConstructAssoc, Construct, Update, Reject),
+
+ % Continue the transformation only if the set reject is empty and
+ % the set assoc or update contains something that needs to be moved
+ % before the recursive call.
+ set.is_empty(Reject),
+ (
+ not set.is_empty(Assoc)
+ ;
+ not set.is_empty(Update)
+ ),
+ (
+ DoLCMC = do_not_opt_lcmc_accumulator,
+ % If LCMC is not turned on, then there must be no construction
+ % unifications after the recursive call.
+ set.is_empty(Construct),
+ set.is_empty(ConstructAssoc)
+ ;
+ DoLCMC = opt_lcmc_accumulator
+ ).
+
+ % For each goal after the recursive call decide which set
+ % the goal belongs to.
+ %
+:- pred accu_stage1_2(module_info::in, vartypes::in, bool::in,
+ accu_goal_id::in, int::in, int::in, accu_goal_store::in,
+ accu_sets::in, accu_sets::out) is det.
+
+accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, GoalId, K, M, GoalStore,
+ !Sets) :-
+ GoalId = accu_goal_id(Case, I),
+ NextGoalId = accu_goal_id(Case, I + 1),
+ ( if I > M then
+ true
+ else
+ ( if
+ accu_before(ModuleInfo, VarTypes, FullyStrict, GoalId, K,
+ GoalStore, !.Sets)
+ then
+ !Sets ^ as_before := set.insert(!.Sets ^ as_before, GoalId),
+ accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M,
+ GoalStore, !Sets)
+ else if
+ accu_assoc(ModuleInfo, VarTypes, FullyStrict, GoalId, K,
+ GoalStore, !.Sets)
+ then
+ !Sets ^ as_assoc := set.insert(!.Sets ^ as_assoc, GoalId),
+ accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M,
+ GoalStore, !Sets)
+ else if
+ accu_construct(ModuleInfo, VarTypes, FullyStrict, GoalId, K,
+ GoalStore, !.Sets)
+ then
+ !Sets ^ as_construct := set.insert(!.Sets ^ as_construct, GoalId),
+ accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M,
+ GoalStore, !Sets)
+ else if
+ accu_construct_assoc(ModuleInfo, VarTypes, FullyStrict, GoalId, K,
+ GoalStore, !.Sets)
+ then
+ !Sets ^ as_construct_assoc :=
+ set.insert(!.Sets ^ as_construct_assoc, GoalId),
+ accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M,
+ GoalStore, !Sets)
+ else if
+ accu_update(ModuleInfo, VarTypes, FullyStrict, GoalId, K,
+ GoalStore, !.Sets)
+ then
+ !Sets ^ as_update := set.insert(!.Sets ^ as_update, GoalId),
+ accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M,
+ GoalStore, !Sets)
+ else
+ !Sets ^ as_reject := set.insert(!.Sets ^ as_reject, GoalId)
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred accu_sets_init(accu_sets::out) is det.
+
+accu_sets_init(Sets) :-
+ set.init(EmptySet),
+ Before = EmptySet,
+ Assoc = EmptySet,
+ ConstructAssoc = EmptySet,
+ Construct = EmptySet,
+ Update = EmptySet,
+ Reject = EmptySet,
+ Sets = accu_sets(Before, Assoc, ConstructAssoc, Construct, Update, Reject).
+
+ % set_upto(Case, K) returns the set
+ % {accu_goal_id(Case, 1) .. accu_goal_id(Case, K)}.
+ %
+:- func set_upto(accu_case, int) = set(accu_goal_id).
+
+set_upto(Case, K) = Set :-
+ ( if K =< 0 then
+ set.init(Set)
+ else
+ Set0 = set_upto(Case, K - 1),
+ set.insert(accu_goal_id(Case, K), Set0, Set)
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % A goal is a member of the before set iff the goal only depends on goals
+ % which are before the recursive call or can be moved before the recursive
+ % call (member of the before set).
+ %
+:- pred accu_before(module_info::in, vartypes::in, bool::in,
+ accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet.
+
+accu_before(ModuleInfo, VarTypes, FullyStrict, GoalId, K, GoalStore, Sets) :-
+ GoalId = accu_goal_id(Case, _I),
+ Before = Sets ^ as_before,
+ goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)),
+ (
+ member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId,
+ stored_goal(EarlierGoal, EarlierInstMap)),
+ not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict,
+ EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal)
+ )
+ =>
+ (
+ set.member(LessThanGoalId, set_upto(Case, K - 1) `union` Before)
+ ).
+
+ % A goal is a member of the assoc set iff the goal only depends on goals
+ % upto and including the recursive call and goals which can be moved
+ % before the recursive call (member of the before set) AND the goal
+ % is associative.
+ %
+:- pred accu_assoc(module_info::in, vartypes::in, bool::in,
+ accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet.
+
+accu_assoc(ModuleInfo, VarTypes, FullyStrict, GoalId, K, GoalStore, Sets) :-
+ GoalId = accu_goal_id(Case, _I),
+ Before = Sets ^ as_before,
+ goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)),
+ LaterGoal = hlds_goal(plain_call(PredId, _, Args, _, _, _), _),
+ accu_is_associative(ModuleInfo, PredId, Args, _),
+ (
+ % XXX LessThanGoalId was _N - J, not N - J: it ignored the case.
+ % See the diff with the previous version.
+ member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId,
+ stored_goal(EarlierGoal, EarlierInstMap)),
+ not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict,
+ EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal)
+ )
+ =>
+ (
+ set.member(LessThanGoalId, set_upto(Case, K) `union` Before)
+ ).
+
+ % A goal is a member of the construct set iff the goal only depends
+ % on goals upto and including the recursive call and goals which
+ % can be moved before the recursive call (member of the before set)
+ % AND the goal is construction unification.
+ %
+:- pred accu_construct(module_info::in, vartypes::in, bool::in,
+ accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet.
+
+accu_construct(ModuleInfo, VarTypes, FullyStrict, GoalId, K, GoalStore,
+ Sets) :-
+ GoalId = accu_goal_id(Case, _I),
+ Before = Sets ^ as_before,
+ Construct = Sets ^ as_construct,
+ goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)),
+ LaterGoal = hlds_goal(unify(_, _, _, Unify, _), _GoalInfo),
+ Unify = construct(_, _, _, _, _, _, _),
+ (
+ % XXX LessThanGoalId was _N - J, not N - J: it ignored the case.
+ % See the diff with the previous version.
+ member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId,
+ stored_goal(EarlierGoal, EarlierInstMap)),
+ not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict,
+ EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal)
+ )
+ =>
+ (
+ set.member(LessThanGoalId,
+ set_upto(Case, K) `union` Before `union` Construct)
+ ).
+
+ % A goal is a member of the construct_assoc set iff the goal depends only
+ % on goals upto and including the recursive call and goals which can be
+ % moved before the recursive call (member of the before set) and goals
+ % which are associative AND the goal is construction unification AND
+ % there is only one member of the assoc set which the construction
+ % unification depends on AND the construction unification can be expressed
+ % as a call to the member of the assoc set which the construction
+ % unification depends on.
+ %
+:- pred accu_construct_assoc(module_info::in, vartypes::in, bool::in,
+ accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet.
+
+accu_construct_assoc(ModuleInfo, VarTypes, FullyStrict,
+ GoalId, K, GoalStore, Sets) :-
+ GoalId = accu_goal_id(Case, _I),
+ Before = Sets ^ as_before,
+ Assoc = Sets ^ as_assoc,
+ ConstructAssoc = Sets ^ as_construct_assoc,
+ goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)),
+ LaterGoal = hlds_goal(unify(_, _, _, Unify, _), _GoalInfo),
+ Unify = construct(_, ConsId, _, _, _, _, _),
+
+ goal_store_all_ancestors(GoalStore, GoalId, VarTypes, ModuleInfo,
+ FullyStrict, Ancestors),
+
+ set.is_singleton(Assoc `intersect` Ancestors, AssocId),
+ goal_store_lookup(GoalStore, AssocId,
+ stored_goal(AssocGoal, _AssocInstMap)),
+ AssocGoal = hlds_goal(plain_call(PredId, _, _, _, _, _), _),
+
+ is_associative_construction(ModuleInfo, PredId, ConsId),
+ (
+ % XXX LessThanGoalId was _N - J, not N - J: it ignored the case.
+ % See the diff with the previous version.
+ member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId,
+ stored_goal(EarlierGoal, EarlierInstMap)),
+ not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict,
+ EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal)
+ )
+ =>
+ (
+ set.member(LessThanGoalId,
+ set_upto(Case, K) `union` Before `union` Assoc
+ `union` ConstructAssoc)
+ ).
+
+ % A goal is a member of the update set iff the goal only depends
+ % on goals upto and including the recursive call and goals which
+ % can be moved before the recursive call (member of the before set)
+ % AND the goal updates some state.
+ %
+:- pred accu_update(module_info::in, vartypes::in, bool::in,
+ accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet.
+
+accu_update(ModuleInfo, VarTypes, FullyStrict, GoalId, K, GoalStore, Sets) :-
+ GoalId = accu_goal_id(Case, _I),
+ Before = Sets ^ as_before,
+ goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)),
+ LaterGoal = hlds_goal(plain_call(PredId, _, Args, _, _, _), _),
+ accu_is_update(ModuleInfo, PredId, Args, _),
+ (
+ % XXX LessThanGoalId was _N - J, not N - J: it ignored the case.
+ % See the diff with the previous version.
+ member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId,
+ stored_goal(EarlierGoal, EarlierInstMap)),
+ not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict,
+ EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal)
+ )
+ =>
+ (
+ set.member(LessThanGoalId, set_upto(Case, K) `union` Before)
+ ).
+
+ % member_lessthan_goalid(GS, IdA, IdB, GB) is true iff the goal_id, IdB,
+ % and its associated goal, GB, is a member of the goal_store, GS,
+ % and IdB is less than IdA.
+ %
+:- pred member_lessthan_goalid(accu_goal_store::in,
+ accu_goal_id::in, accu_goal_id::out, stored_goal::out) is nondet.
+
+member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId, LessThanGoal) :-
+ goal_store_member(GoalStore, LessThanGoalId, LessThanGoal),
+ GoalId = accu_goal_id(Case, I),
+ LessThanGoalId = accu_goal_id(Case, J),
+ J < I.
+
+%---------------------------------------------------------------------------%
+
+:- type accu_assoc
+ ---> accu_assoc(
+ set_of_progvar, % the associative input args
+ prog_var, % the corresponding output arg
+ bool % is the predicate commutative?
+ ).
+
+ % If accu_is_associative is true, it returns the two arguments which are
+ % associative and the variable which depends on those two arguments,
+ % and an indicator of whether or not the predicate is commutative.
+ %
+:- pred accu_is_associative(module_info::in, pred_id::in, list(prog_var)::in,
+ accu_assoc::out) is semidet.
+
+accu_is_associative(ModuleInfo, PredId, Args, Result) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_assertions(PredInfo, Assertions),
+ AssertionsList = set.to_sorted_list(Assertions),
+ associativity_assertion(ModuleInfo, AssertionsList, Args,
+ AssociativeVarsOutputVar),
+ ( if
+ commutativity_assertion(ModuleInfo, AssertionsList, Args,
+ _CommutativeVars)
+ then
+ IsCommutative = yes
+ else
+ IsCommutative = no
+ ),
+ AssociativeVarsOutputVar =
+ associative_vars_output_var(AssociativeVars, OutputVar),
+ Result = accu_assoc(AssociativeVars, OutputVar, IsCommutative).
+
+ % Does there exist one (and only one) associativity assertion for the
+ % current predicate?
+ % The 'and only one condition' is required because we currently
+ % do not handle the case of predicates which have individual parts
+ % which are associative, because then we do not know which variable
+ % is descended from which.
+ %
+:- pred associativity_assertion(module_info::in, list(assert_id)::in,
+ list(prog_var)::in, associative_vars_output_var::out) is semidet.
+
+associativity_assertion(ModuleInfo, [AssertId | AssertIds], Args0,
+ AssociativeVarsOutputVar) :-
+ ( if
+ assertion.is_associativity_assertion(ModuleInfo, AssertId,
+ Args0, AssociativeVarsOutputVarPrime)
+ then
+ AssociativeVarsOutputVar = AssociativeVarsOutputVarPrime,
+ not associativity_assertion(ModuleInfo, AssertIds, Args0, _)
+ else
+ associativity_assertion(ModuleInfo, AssertIds, Args0,
+ AssociativeVarsOutputVar)
+ ).
+
+ % Does there exist one (and only one) commutativity assertion for the
+ % current predicate?
+ % The 'and only one condition' is required because we currently
+ % do not handle the case of predicates which have individual
+ % parts which are commutative, because then we do not know which variable
+ % is descended from which.
+ %
+:- pred commutativity_assertion(module_info::in,list(assert_id)::in,
+ list(prog_var)::in, set_of_progvar::out) is semidet.
+
+commutativity_assertion(ModuleInfo, [AssertId | AssertIds], Args0,
+ CommutativeVars) :-
+ ( if
+ assertion.is_commutativity_assertion(ModuleInfo, AssertId,
+ Args0, CommutativeVarsPrime)
+ then
+ CommutativeVars = CommutativeVarsPrime,
+ not commutativity_assertion(ModuleInfo, AssertIds, Args0, _)
+ else
+ commutativity_assertion(ModuleInfo, AssertIds, Args0,
+ CommutativeVars)
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % Does the current predicate update some state?
+ %
+:- pred accu_is_update(module_info::in, pred_id::in, list(prog_var)::in,
+ state_update_vars::out) is semidet.
+
+accu_is_update(ModuleInfo, PredId, Args, ResultStateVars) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_assertions(PredInfo, Assertions),
+ list.filter_map(
+ ( pred(AssertId::in, StateVars::out) is semidet :-
+ assertion.is_update_assertion(ModuleInfo, AssertId,
+ PredId, Args, StateVars)
+ ),
+ set.to_sorted_list(Assertions), Result),
+ % XXX Maybe we should just match on the first result,
+ % just in case there are duplicate promises.
+ Result = [ResultStateVars].
+
+%---------------------------------------------------------------------------%
+
+ % Can the construction unification be expressed as a call to the
+ % specified predicate.
+ %
+:- pred is_associative_construction(module_info::in, pred_id::in, cons_id::in)
+ is semidet.
+
+is_associative_construction(ModuleInfo, PredId, ConsId) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_assertions(PredInfo, Assertions),
+ list.filter(
+ ( pred(AssertId::in) is semidet :-
+ assertion.is_construction_equivalence_assertion(ModuleInfo,
+ AssertId, ConsId, PredId)
+ ),
+ set.to_sorted_list(Assertions), Result),
+ Result = [_ | _].
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- type accu_substs
+ ---> accu_substs(
+ acc_var_subst :: accu_subst,
+ rec_call_subst :: accu_subst,
+ assoc_call_subst :: accu_subst,
+ update_subst :: accu_subst
+ ).
+
+:- type accu_base
+ ---> accu_base(
+ % goals which initialize update
+ init_update :: set(accu_goal_id),
+
+ % goals which initialize assoc
+ init_assoc :: set(accu_goal_id),
+
+ % other goals
+ other :: set(accu_goal_id)
+ ).
+
+ % Stage 2 is responsible for identifying the substitutions which
+ % are needed to mimic the unfold/fold process that was used as
+ % the justification of the algorithm in the paper.
+ % It is also responsible for ensuring that the reordering of arguments
+ % doesn't worsen the big-O complexity of the procedure.
+ % It also divides the base case into goals that initialize the
+ % variables used by the update goals, and those used by the assoc
+ % goals and then all the rest.
+ %
+:- pred accu_stage2(module_info::in, proc_info::in,
+ accu_goal_id::in, accu_goal_store::in, accu_sets::in,
+ list(prog_var)::in, list(prog_var)::in, prog_varset::out, vartypes::out,
+ list(prog_var)::out, accu_base::out, list(pair(prog_var))::out,
+ accu_substs::out, accu_goal_store::out, list(accu_warning)::out)
+ is semidet.
+
+accu_stage2(ModuleInfo, ProcInfo0, GoalId, GoalStore, Sets, OutPrime, Out,
+ !:VarSet, !:VarTypes, Accs, BaseCase, BasePairs, !:Substs,
+ CS, Warnings) :-
+ Sets = accu_sets(Before0, Assoc, ConstructAssoc, Construct, Update, _),
+ GoalId = accu_goal_id(Case, K),
+ Before = Before0 `union` set_upto(Case, K-1),
+
+ % Note Update set is not placed in the after set, as the after set is used
+ % to determine the variables that need to be accumulated for the
+ % associative calls.
+ After = Assoc `union` ConstructAssoc `union` Construct,
+
+ P =
+ ( pred(Id::in, Set0::in, Set::out) is det :-
+ goal_store_lookup(GoalStore, Id, stored_goal(Goal, _InstMap)),
+ Goal = hlds_goal(_GoalExpr, GoalInfo),
+ NonLocals = goal_info_get_nonlocals(GoalInfo),
+ set_of_var.union(NonLocals, Set0, Set)
+ ),
+ list.foldl(P, set.to_sorted_list(Before),
+ set_of_var.init, BeforeNonLocals),
+ list.foldl(P, set.to_sorted_list(After),
+ set_of_var.init, AfterNonLocals),
+ InitAccs = set_of_var.intersect(BeforeNonLocals, AfterNonLocals),
+
+ proc_info_get_varset(ProcInfo0, !:VarSet),
+ proc_info_get_vartypes(ProcInfo0, !:VarTypes),
+
+ accu_substs_init(set_of_var.to_sorted_list(InitAccs), !VarSet, !VarTypes,
+ !:Substs),
+
+ set_of_var.list_to_set(OutPrime, OutPrimeSet),
+ accu_process_assoc_set(ModuleInfo, GoalStore, set.to_sorted_list(Assoc),
+ OutPrimeSet, !Substs, !VarSet, !VarTypes, CS, Warnings),
+
+ accu_process_update_set(ModuleInfo, GoalStore, set.to_sorted_list(Update),
+ OutPrimeSet, !Substs, !VarSet, !VarTypes, UpdateOut, UpdateAccOut,
+ BasePairs),
+
+ Accs = set_of_var.to_sorted_list(InitAccs) ++ UpdateAccOut,
+
+ accu_divide_base_case(ModuleInfo, !.VarTypes, GoalStore, UpdateOut, Out,
+ UpdateBase, AssocBase, OtherBase),
+
+ BaseCase = accu_base(UpdateBase, AssocBase, OtherBase).
+
+%---------------------------------------------------------------------------%
+
+:- pred accu_substs_init(list(prog_var)::in, prog_varset::in, prog_varset::out,
+ vartypes::in, vartypes::out, accu_substs::out) is det.
+
+accu_substs_init(InitAccs, !VarSet, !VarTypes, Substs) :-
+ map.init(Subst),
+ acc_var_subst_init(InitAccs, !VarSet, !VarTypes, AccVarSubst),
+ RecCallSubst = Subst,
+ AssocCallSubst = Subst,
+ UpdateSubst = Subst,
+ Substs = accu_substs(AccVarSubst, RecCallSubst, AssocCallSubst,
+ UpdateSubst).
+
+ % Initialise the acc_var_subst to be from Var to A_Var where Var is a
+ % member of InitAccs and A_Var is a fresh variable of the same type of Var.
+ %
+:- pred acc_var_subst_init(list(prog_var)::in,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
+ accu_subst::out) is det.
+
+acc_var_subst_init([], !VarSet, !VarTypes, map.init).
+acc_var_subst_init([Var | Vars], !VarSet, !VarTypes, Subst) :-
+ create_new_var(Var, "A_", AccVar, !VarSet, !VarTypes),
+ acc_var_subst_init(Vars, !VarSet, !VarTypes, Subst0),
+ map.det_insert(Var, AccVar, Subst0, Subst).
+
+ % Create a fresh variable which is the same type as the old variable
+ % and has the same name except that it begins with the prefix.
+ %
+:- pred create_new_var(prog_var::in, string::in, prog_var::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det.
+
+create_new_var(OldVar, Prefix, NewVar, !VarSet, !VarTypes) :-
+ varset.lookup_name(!.VarSet, OldVar, OldName),
+ string.append(Prefix, OldName, NewName),
+ varset.new_named_var(NewName, NewVar, !VarSet),
+ lookup_var_type(!.VarTypes, OldVar, Type),
+ add_var_type(NewVar, Type, !VarTypes).
+
+%---------------------------------------------------------------------------%
+
+ % For each member of the assoc set determine the substitutions needed,
+ % and also check the efficiency of the procedure isn't worsened
+ % by reordering the arguments to a call.
+ %
+:- pred accu_process_assoc_set(module_info::in, accu_goal_store::in,
+ list(accu_goal_id)::in, set_of_progvar::in,
+ accu_substs::in, accu_substs::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
+ accu_goal_store::out, list(accu_warning)::out) is semidet.
+
+accu_process_assoc_set(_ModuleInfo, _GS, [], _OutPrime, !Substs,
+ !VarSet, !VarTypes, CS, []) :-
+ goal_store_init(CS).
+accu_process_assoc_set(ModuleInfo, GS, [Id | Ids], OutPrime, !Substs,
+ !VarSet, !VarTypes, CS, Warnings) :-
+ !.Substs = accu_substs(AccVarSubst, RecCallSubst0, AssocCallSubst0,
+ UpdateSubst),
+
+ lookup_call(GS, Id, stored_goal(Goal, InstMap)),
+
+ Goal = hlds_goal(plain_call(PredId, _, Args, _, _, _), GoalInfo),
+ accu_is_associative(ModuleInfo, PredId, Args, AssocInfo),
+ AssocInfo = accu_assoc(Vars, AssocOutput, IsCommutative),
+ OutPrimeVars = set_of_var.intersect(Vars, OutPrime),
+ set_of_var.is_singleton(OutPrimeVars, DuringAssocVar),
+ set_of_var.is_singleton(set_of_var.difference(Vars, OutPrimeVars),
+ BeforeAssocVar),
+
+ map.lookup(AccVarSubst, BeforeAssocVar, AccVar),
+ create_new_var(BeforeAssocVar, "NewAcc_", NewAcc, !VarSet, !VarTypes),
+
+ map.det_insert(DuringAssocVar, AccVar, AssocCallSubst0, AssocCallSubst1),
+ map.det_insert(AssocOutput, NewAcc, AssocCallSubst1, AssocCallSubst),
+ map.det_insert(DuringAssocVar, AssocOutput, RecCallSubst0, RecCallSubst1),
+ map.det_insert(BeforeAssocVar, NewAcc, RecCallSubst1, RecCallSubst),
+
+ !:Substs = accu_substs(AccVarSubst, RecCallSubst, AssocCallSubst,
+ UpdateSubst),
+
+ % ONLY swap the order of the variables if the goal is
+ % associative and not commutative.
+ (
+ IsCommutative = yes,
+ CSGoal = stored_goal(Goal, InstMap),
+ CurWarnings = []
+ ;
+ IsCommutative = no,
+
+ % Ensure that the reordering doesn't cause a efficiency problem.
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ ModuleName = pred_info_module(PredInfo),
+ PredName = pred_info_name(PredInfo),
+ Arity = pred_info_orig_arity(PredInfo),
+ ( if accu_has_heuristic(ModuleName, PredName, Arity) then
+ % Only do the transformation if the accumulator variable is
+ % *not* in a position where it will control the running time
+ % of the predicate.
+ accu_heuristic(ModuleName, PredName, Arity, Args,
+ PossibleDuringAssocVars),
+ set_of_var.member(PossibleDuringAssocVars, DuringAssocVar),
+ CurWarnings = []
+ else
+ ProgContext = goal_info_get_context(GoalInfo),
+ CurWarnings = [accu_warn(ProgContext, PredId, BeforeAssocVar,
+ DuringAssocVar)]
+ ),
+ % Swap the arguments.
+ [A, B] = set_of_var.to_sorted_list(Vars),
+ map.from_assoc_list([A - B, B - A], Subst),
+ rename_some_vars_in_goal(Subst, Goal, SwappedGoal),
+ CSGoal = stored_goal(SwappedGoal, InstMap)
+ ),
+
+ accu_process_assoc_set(ModuleInfo, GS, Ids, OutPrime, !Substs,
+ !VarSet, !VarTypes, CS0, Warnings0),
+ goal_store_det_insert(Id, CSGoal, CS0, CS),
+ Warnings = Warnings0 ++ CurWarnings.
+
+:- pred accu_has_heuristic(module_name::in, string::in, arity::in) is semidet.
+
+accu_has_heuristic(unqualified("list"), "append", 3).
+
+ % heuristic returns the set of which head variables are important
+ % in the running time of the predicate.
+ %
+:- pred accu_heuristic(module_name::in, string::in, arity::in,
+ list(prog_var)::in, set_of_progvar::out) is semidet.
+
+accu_heuristic(unqualified("list"), "append", 3, [_Typeinfo, A, _B, _C],
+ Set) :-
+ set_of_var.make_singleton(A, Set).
+
+%---------------------------------------------------------------------------%
+
+ % For each member of the update set determine the substitutions needed
+ % (creating the accumulator variables when needed).
+ % Also associate with each Output variable which accumulator variable
+ % to get the result from.
+ %
+:- pred accu_process_update_set(module_info::in, accu_goal_store::in,
+ list(accu_goal_id)::in, set_of_progvar::in,
+ accu_substs::in, accu_substs::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
+ list(prog_var)::out, list(prog_var)::out, list(pair(prog_var))::out)
+ is semidet.
+
+accu_process_update_set(_ModuleInfo, _GS, [], _OutPrime, !Substs,
+ !VarSet, !VarTypes, [], [], []).
+accu_process_update_set(ModuleInfo, GS, [Id | Ids], OutPrime, !Substs,
+ !VarSet, !VarTypes, StateOutputVars, Accs, BasePairs) :-
+ !.Substs = accu_substs(AccVarSubst0, RecCallSubst0, AssocCallSubst,
+ UpdateSubst0),
+ lookup_call(GS, Id, stored_goal(Goal, _InstMap)),
+
+ Goal = hlds_goal(plain_call(PredId, _, Args, _, _, _), _GoalInfo),
+ accu_is_update(ModuleInfo, PredId, Args, StateVars),
+ StateVars = state_update_vars(StateVarA, StateVarB),
+
+ ( if set_of_var.member(OutPrime, StateVarA) then
+ StateInputVar = StateVarA,
+ StateOutputVar = StateVarB
+ else
+ StateInputVar = StateVarB,
+ StateOutputVar = StateVarA
+ ),
+
+ create_new_var(StateInputVar, "Acc_", Acc0, !VarSet, !VarTypes),
+ create_new_var(StateOutputVar, "Acc_", Acc, !VarSet, !VarTypes),
+
+ map.det_insert(StateInputVar, Acc0, UpdateSubst0, UpdateSubst1),
+ map.det_insert(StateOutputVar, Acc, UpdateSubst1, UpdateSubst),
+ map.det_insert(StateInputVar, StateOutputVar, RecCallSubst0, RecCallSubst),
+ map.det_insert(Acc, Acc0, AccVarSubst0, AccVarSubst),
+ !:Substs = accu_substs(AccVarSubst, RecCallSubst, AssocCallSubst,
+ UpdateSubst),
+
+ accu_process_update_set(ModuleInfo, GS, Ids, OutPrime, !Substs,
+ !VarSet, !VarTypes, StateOutputVars0, Accs0, BasePairs0),
+
+ % Rather then concatenating to start of the list we concatenate to the end
+ % of the list. This allows the accumulator introduction to be applied
+ % as the heuristic will succeed (remember after transforming the two
+ % input variables will have their order swapped, so they must be in the
+ % inefficient order to start with)
+
+ StateOutputVars = StateOutputVars0 ++ [StateOutputVar],
+ Accs = Accs0 ++ [Acc],
+ BasePairs = BasePairs0 ++ [StateOutputVar - Acc0].
+
+%---------------------------------------------------------------------------%
+
+ % divide_base_case(UpdateOut, Out, U, A, O) is true iff given the output
+ % variables which are instantiated by update goals, UpdateOut, and all
+ % the variables that need to be accumulated, Out, divide the base case up
+ % into three sets, those base case goals which initialize the variables
+ % used by update calls, U, those which initialize variables used by
+ % assoc calls, A, and the rest of the goals, O. Note that the sets
+ % are not necessarily disjoint, as the result of a goal may be used
+ % to initialize a variable in both U and A, so both U and A will contain
+ % the same goal_id.
+ %
+:- pred accu_divide_base_case(module_info::in, vartypes::in,
+ accu_goal_store::in, list(prog_var)::in, list(prog_var)::in,
+ set(accu_goal_id)::out, set(accu_goal_id)::out, set(accu_goal_id)::out)
+ is det.
+
+accu_divide_base_case(ModuleInfo, VarTypes, C, UpdateOut, Out,
+ UpdateBase, AssocBase, OtherBase) :-
+ list.delete_elems(Out, UpdateOut, AssocOut),
+
+ list.map(accu_related(ModuleInfo, VarTypes, C), UpdateOut, UpdateBaseList),
+ list.map(accu_related(ModuleInfo, VarTypes, C), AssocOut, AssocBaseList),
+ UpdateBase = set.power_union(set.list_to_set(UpdateBaseList)),
+ AssocBase = set.power_union(set.list_to_set(AssocBaseList)),
+
+ Set = base_case_ids_set(C) `difference` (UpdateBase `union` AssocBase),
+ set.to_sorted_list(Set, List),
+
+ list.map(
+ ( pred(GoalId::in, Ancestors::out) is det :-
+ goal_store_all_ancestors(C, GoalId, VarTypes,
+ ModuleInfo, no, Ancestors)
+ ), List, OtherBaseList),
+
+ OtherBase = set.list_to_set(List) `union`
+ (base_case_ids_set(C) `intersect`
+ set.power_union(set.list_to_set(OtherBaseList))).
+
+ % accu_related(ModuleInfo, VarTypes, GoalStore, Var, Related):
+ %
+ % From GoalStore, return all the goal_ids, Related, which are needed
+ % to initialize Var.
+ %
+:- pred accu_related(module_info::in, vartypes::in, accu_goal_store::in,
+ prog_var::in, set(accu_goal_id)::out) is det.
+
+accu_related(ModuleInfo, VarTypes, GoalStore, Var, Related) :-
+ solutions.solutions(
+ ( pred(Key::out) is nondet :-
+ goal_store_member(GoalStore, Key, stored_goal(Goal, InstMap0)),
+ Key = accu_goal_id(accu_base, _),
+ Goal = hlds_goal(_GoalExpr, GoalInfo),
+ InstMapDelta = goal_info_get_instmap_delta(GoalInfo),
+ apply_instmap_delta(InstMapDelta, InstMap0, InstMap),
+ instmap_changed_vars(ModuleInfo, VarTypes,
+ InstMap0, InstMap, ChangedVars),
+ set_of_var.is_singleton(ChangedVars, Var)
+ ), Ids),
+ (
+ Ids = [],
+ unexpected($pred, "no Id")
+ ;
+ Ids = [Id],
+ goal_store_all_ancestors(GoalStore, Id, VarTypes, ModuleInfo, no,
+ Ancestors),
+ list.filter((pred(accu_goal_id(accu_base, _)::in) is semidet),
+ set.to_sorted_list(set.insert(Ancestors, Id)), RelatedList),
+ Related = set.list_to_set(RelatedList)
+ ;
+ Ids = [_, _ | _],
+ unexpected($pred, "more than one Id")
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- inst stored_goal_plain_call for goal_store.stored_goal/0
+ ---> stored_goal(goal_plain_call, ground).
+
+ % Do a goal_store_lookup where the result is known to be a call.
+ %
+:- pred lookup_call(accu_goal_store::in, accu_goal_id::in,
+ stored_goal::out(stored_goal_plain_call)) is det.
+
+lookup_call(GoalStore, Id, stored_goal(Call, InstMap)) :-
+ goal_store_lookup(GoalStore, Id, stored_goal(Goal, InstMap)),
+ ( if
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ GoalExpr = plain_call(_, _, _, _, _, _)
+ then
+ Call = hlds_goal(GoalExpr, GoalInfo)
+ else
+ unexpected($pred, "not a call")
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % accu_stage3 creates the accumulator version of the predicate using
+ % the substitutions determined in stage2. It also redefines the
+ % original procedure to call the accumulator version of the procedure.
+ %
+:- pred accu_stage3(accu_goal_id::in, list(prog_var)::in, prog_varset::in,
+ vartypes::in, accu_goal_store::in, accu_goal_store::in,
+ accu_substs::in, accu_subst::in, accu_subst::in,
+ accu_base::in, list(pair(prog_var))::in, accu_sets::in,
+ list(prog_var)::in, top_level::in, pred_id::in, pred_info::in,
+ proc_info::in, proc_info::out, module_info::in, module_info::out) is det.
+
+accu_stage3(RecCallId, Accs, VarSet, VarTypes, C, CS, Substs,
+ HeadToCallSubst, CallToHeadSubst, BaseCase, BasePairs, Sets, Out,
+ TopLevel, OrigPredId, OrigPredInfo, !OrigProcInfo, !ModuleInfo) :-
+ acc_proc_info(Accs, VarSet, VarTypes, Substs, !.OrigProcInfo,
+ AccTypes, AccProcInfo),
+ acc_pred_info(AccTypes, Out, AccProcInfo, OrigPredId, OrigPredInfo,
+ AccProcId, AccPredInfo),
+ AccName = unqualified(pred_info_name(AccPredInfo)),
+
+ module_info_get_predicate_table(!.ModuleInfo, PredTable0),
+ predicate_table_insert(AccPredInfo, AccPredId, PredTable0, PredTable),
+ module_info_set_predicate_table(PredTable, !ModuleInfo),
+ accu_create_goal(RecCallId, Accs, AccPredId, AccProcId, AccName, Substs,
+ HeadToCallSubst, CallToHeadSubst, BaseCase, BasePairs, Sets, C, CS,
+ OrigBaseGoal, OrigRecGoal, AccBaseGoal, AccRecGoal),
+
+ proc_info_get_goal(!.OrigProcInfo, OrigGoal0),
+ accu_top_level(TopLevel, OrigGoal0, OrigBaseGoal, OrigRecGoal,
+ AccBaseGoal, AccRecGoal, OrigGoal, AccGoal),
+
+ proc_info_set_goal(OrigGoal, !OrigProcInfo),
+ proc_info_set_varset(VarSet, !OrigProcInfo),
+ proc_info_set_vartypes(VarTypes, !OrigProcInfo),
+
+ requantify_proc_general(ordinary_nonlocals_no_lambda, !OrigProcInfo),
+ update_accumulator_pred(AccPredId, AccProcId, AccGoal, !ModuleInfo).
+
+%---------------------------------------------------------------------------%
+
+ % Construct a proc_info for the introduced predicate.
+ %
+:- pred acc_proc_info(list(prog_var)::in, prog_varset::in, vartypes::in,
+ accu_substs::in, proc_info::in, list(mer_type)::out, proc_info::out)
+ is det.
+
+acc_proc_info(Accs0, VarSet, VarTypes, Substs, OrigProcInfo,
+ AccTypes, AccProcInfo) :-
+ % ProcInfo Stuff that must change.
+ proc_info_get_headvars(OrigProcInfo, HeadVars0),
+ proc_info_get_argmodes(OrigProcInfo, HeadModes0),
+
+ proc_info_get_inst_varset(OrigProcInfo, InstVarSet),
+ proc_info_get_inferred_determinism(OrigProcInfo, Detism),
+ proc_info_get_goal(OrigProcInfo, Goal),
+ proc_info_get_context(OrigProcInfo, Context),
+ proc_info_get_rtti_varmaps(OrigProcInfo, RttiVarMaps),
+ proc_info_get_is_address_taken(OrigProcInfo, IsAddressTaken),
+ proc_info_get_has_parallel_conj(OrigProcInfo, HasParallelConj),
+ proc_info_get_var_name_remap(OrigProcInfo, VarNameRemap),
+
+ Substs = accu_substs(AccVarSubst, _RecCallSubst, _AssocCallSubst,
+ _UpdateSubst),
+ list.map(map.lookup(AccVarSubst), Accs0, Accs),
+
+ % We place the extra accumulator variables at the start, because placing
+ % them at the end breaks the convention that the last variable of a
+ % function is the output variable.
+ HeadVars = Accs ++ HeadVars0,
+
+ % XXX we don't want to use the inst of the var as it can be more specific
+ % than it should be. ie int_const(1) when it should be any integer.
+ % However this will no longer handle partially instantiated data
+ % structures.
+ Inst = ground(shared, none_or_default_func),
+ inst_lists_to_mode_list([Inst], [Inst], Mode),
+ list.duplicate(list.length(Accs), list.det_head(Mode), AccModes),
+ HeadModes = AccModes ++ HeadModes0,
+
+ lookup_var_types(VarTypes, Accs, AccTypes),
+
+ SeqNum = item_no_seq_num,
+ proc_info_create(Context, SeqNum, VarSet, VarTypes, HeadVars,
+ InstVarSet, HeadModes, detism_decl_none, Detism, Goal, RttiVarMaps,
+ IsAddressTaken, HasParallelConj, VarNameRemap, AccProcInfo).
+
+%---------------------------------------------------------------------------%
+
+ % Construct the pred_info for the introduced predicate.
+ %
+:- pred acc_pred_info(list(mer_type)::in, list(prog_var)::in, proc_info::in,
+ pred_id::in, pred_info::in, proc_id::out, pred_info::out) is det.
+
+acc_pred_info(NewTypes, OutVars, NewProcInfo, OrigPredId, OrigPredInfo,
+ NewProcId, NewPredInfo) :-
+ % PredInfo stuff that must change.
+ pred_info_get_arg_types(OrigPredInfo, TypeVarSet, ExistQVars, Types0),
+
+ ModuleName = pred_info_module(OrigPredInfo),
+ Name = pred_info_name(OrigPredInfo),
+ PredOrFunc = pred_info_is_pred_or_func(OrigPredInfo),
+ pred_info_get_context(OrigPredInfo, PredContext),
+ pred_info_get_markers(OrigPredInfo, Markers),
+ pred_info_get_class_context(OrigPredInfo, ClassContext),
+ pred_info_get_origin(OrigPredInfo, OldOrigin),
+ pred_info_get_var_name_remap(OrigPredInfo, VarNameRemap),
+
+ set.init(Assertions),
+
+ proc_info_get_context(NewProcInfo, Context),
+ term.context_line(Context, Line),
+ Counter = 0,
+
+ Types = NewTypes ++ Types0,
+
+ make_pred_name_with_context(ModuleName, "AccFrom", PredOrFunc, Name,
+ Line, Counter, SymName),
+
+ OutVarNums = list.map(term.var_to_int, OutVars),
+ Origin = origin_transformed(transform_accumulator(OutVarNums),
+ OldOrigin, OrigPredId),
+ GoalType = goal_not_for_promise(np_goal_type_none),
+ pred_info_create(ModuleName, SymName, PredOrFunc, PredContext, Origin,
+ pred_status(status_local), Markers, Types, TypeVarSet,
+ ExistQVars, ClassContext, Assertions, VarNameRemap, GoalType,
+ NewProcInfo, NewProcId, NewPredInfo).
+
+%---------------------------------------------------------------------------%
+
+ % create_goal creates the new base and recursive case of the
+ % original procedure (OrigBaseGoal and OrigRecGoal) and the base
+ % and recursive cases of accumulator version (AccBaseGoal and
+ % AccRecGoal).
+ %
+:- pred accu_create_goal(accu_goal_id::in, list(prog_var)::in,
+ pred_id::in, proc_id::in, sym_name::in, accu_substs::in,
+ accu_subst::in, accu_subst::in, accu_base::in,
+ list(pair(prog_var))::in, accu_sets::in,
+ accu_goal_store::in, accu_goal_store::in,
+ hlds_goal::out, hlds_goal::out, hlds_goal::out, hlds_goal::out) is det.
+
+accu_create_goal(RecCallId, Accs, AccPredId, AccProcId, AccName, Substs,
+ HeadToCallSubst, CallToHeadSubst, BaseIds, BasePairs,
+ Sets, C, CS, OrigBaseGoal, OrigRecGoal, AccBaseGoal, AccRecGoal) :-
+ lookup_call(C, RecCallId, stored_goal(OrigCall, _InstMap)),
+ Call = create_acc_call(OrigCall, Accs, AccPredId, AccProcId, AccName),
+ create_orig_goal(Call, Substs, HeadToCallSubst, CallToHeadSubst,
+ BaseIds, Sets, C, OrigBaseGoal, OrigRecGoal),
+ create_acc_goal(Call, Substs, HeadToCallSubst, BaseIds, BasePairs,
+ Sets, C, CS, AccBaseGoal, AccRecGoal).
+
+ % create_acc_call takes the original call and generates a call to the
+ % accumulator version of the call, which can have the substitutions
+ % applied to it easily.
+ %
+:- func create_acc_call(hlds_goal::in(goal_plain_call), list(prog_var)::in,
+ pred_id::in, proc_id::in, sym_name::in) = (hlds_goal::out(goal_plain_call))
+ is det.
+
+create_acc_call(OrigCall, Accs, AccPredId, AccProcId, AccName) = Call :-
+ OrigCall = hlds_goal(OrigCallExpr, GoalInfo),
+ OrigCallExpr = plain_call(_PredId, _ProcId, Args, Builtin, Context, _Name),
+ CallExpr = plain_call(AccPredId, AccProcId, Accs ++ Args, Builtin,
+ Context, AccName),
+ Call = hlds_goal(CallExpr, GoalInfo).
+
+ % Create the goals which are to replace the original predicate.
+ %
+:- pred create_orig_goal(hlds_goal::in, accu_substs::in,
+ accu_subst::in, accu_subst::in, accu_base::in, accu_sets::in,
+ accu_goal_store::in, hlds_goal::out, hlds_goal::out) is det.
+
+create_orig_goal(Call, Substs, HeadToCallSubst, CallToHeadSubst,
+ BaseIds, Sets, C, OrigBaseGoal, OrigRecGoal) :-
+ Substs = accu_substs(_AccVarSubst, _RecCallSubst, _AssocCallSubst,
+ UpdateSubst),
+
+ BaseIds = accu_base(UpdateBase, _AssocBase, _OtherBase),
+ Before = Sets ^ as_before,
+ Update = Sets ^ as_update,
+
+ U = create_new_orig_recursive_goals(UpdateBase, Update,
+ HeadToCallSubst, UpdateSubst, C),
+
+ rename_some_vars_in_goal(CallToHeadSubst, Call, BaseCall),
+ Cbefore = accu_goal_list(set.to_sorted_list(Before), C),
+ Uupdate = accu_goal_list(set.to_sorted_list(UpdateBase) ++
+ set.to_sorted_list(Update), U),
+ Cbase = accu_goal_list(base_case_ids(C), C),
+ calculate_goal_info(conj(plain_conj, Cbefore ++ Uupdate ++ [BaseCall]),
+ OrigRecGoal),
+ calculate_goal_info(conj(plain_conj, Cbase), OrigBaseGoal).
+
+ % Create the goals which are to go in the new accumulator version
+ % of the predicate.
+ %
+:- pred create_acc_goal(hlds_goal::in, accu_substs::in, accu_subst::in,
+ accu_base::in, list(pair(prog_var))::in, accu_sets::in,
+ accu_goal_store::in, accu_goal_store::in,
+ hlds_goal::out, hlds_goal::out) is det.
+
+create_acc_goal(Call, Substs, HeadToCallSubst, BaseIds, BasePairs, Sets,
+ C, CS, AccBaseGoal, AccRecGoal) :-
+ Substs = accu_substs(AccVarSubst, RecCallSubst, AssocCallSubst,
+ UpdateSubst),
+
+ BaseIds = accu_base(_UpdateBase, AssocBase, OtherBase),
+ Sets = accu_sets(Before, Assoc, ConstructAssoc, Construct, Update,
+ _Reject),
+
+ rename_some_vars_in_goal(RecCallSubst, Call, RecCall),
+
+ Cbefore = accu_goal_list(set.to_sorted_list(Before), C),
+
+ % Create the goals which will be used in the new recursive case.
+ R = create_new_recursive_goals(Assoc, Construct `union` ConstructAssoc,
+ Update, AssocCallSubst, AccVarSubst, UpdateSubst, C, CS),
+
+ Rassoc = accu_goal_list(set.to_sorted_list(Assoc), R),
+ Rupdate = accu_goal_list(set.to_sorted_list(Update), R),
+ Rconstruct = accu_goal_list(set.to_sorted_list(Construct `union`
+ ConstructAssoc), R),
+
+ % Create the goals which will be used in the new base case.
+ B = create_new_base_goals(Assoc `union` Construct `union`
+ ConstructAssoc, C, AccVarSubst, HeadToCallSubst),
+ Bafter = set.to_sorted_list(Assoc `union`
+ Construct `union` ConstructAssoc),
+
+ BaseCase = accu_goal_list(set.to_sorted_list(AssocBase `union` OtherBase)
+ ++ Bafter, B),
+
+ list.map(acc_unification, BasePairs, UpdateBase),
+
+ calculate_goal_info(conj(plain_conj, Cbefore ++ Rassoc ++ Rupdate
+ ++ [RecCall] ++ Rconstruct), AccRecGoal),
+ calculate_goal_info(conj(plain_conj, UpdateBase ++ BaseCase), AccBaseGoal).
+
+ % Create the U set of goals (those that will be used in the original
+ % recursive case) by renaming all the goals which are used to initialize
+ % the update state variable using the head_to_call followed by the
+ % update_subst, and rename all the update goals using the update_subst.
+ %
+:- func create_new_orig_recursive_goals(set(accu_goal_id), set(accu_goal_id),
+ accu_subst, accu_subst, accu_goal_store) = accu_goal_store.
+
+create_new_orig_recursive_goals(UpdateBase, Update, HeadToCallSubst,
+ UpdateSubst, C)
+ = accu_rename(set.to_sorted_list(Update), UpdateSubst, C, Ubase) :-
+ Ubase = accu_rename(set.to_sorted_list(UpdateBase),
+ chain_subst(HeadToCallSubst, UpdateSubst), C, goal_store_init).
+
+ % Create the R set of goals (those that will be used in the new
+ % recursive case) by renaming all the members of assoc in CS
+ % using assoc_call_subst and all the members of (construct U
+ % construct_assoc) in C with acc_var_subst.
+ %
+:- func create_new_recursive_goals(set(accu_goal_id), set(accu_goal_id),
+ set(accu_goal_id), accu_subst, accu_subst, accu_subst,
+ accu_goal_store, accu_goal_store) = accu_goal_store.
+
+create_new_recursive_goals(Assoc, Constructs, Update,
+ AssocCallSubst, AccVarSubst, UpdateSubst, C, CS)
+ = accu_rename(set.to_sorted_list(Constructs), AccVarSubst, C, RBase) :-
+ RBase0 = accu_rename(set.to_sorted_list(Assoc), AssocCallSubst, CS,
+ goal_store_init),
+ RBase = accu_rename(set.to_sorted_list(Update), UpdateSubst, C, RBase0).
+
+ % Create the B set of goals (those that will be used in the new base case)
+ % by renaming all the base case goals of C with head_to_call and all the
+ % members of (assoc U construct U construct_assoc) of C with acc_var_subst.
+ %
+:- func create_new_base_goals(set(accu_goal_id), accu_goal_store,
+ accu_subst, accu_subst) = accu_goal_store.
+
+create_new_base_goals(Ids, C, AccVarSubst, HeadToCallSubst)
+ = accu_rename(set.to_sorted_list(Ids), AccVarSubst, C, Bbase) :-
+ Bbase = accu_rename(base_case_ids(C), HeadToCallSubst, C, goal_store_init).
+
+ % acc_unification(O-A, G):
+ %
+ % is true if G represents the assignment unification Out = Acc.
+ %
+:- pred acc_unification(pair(prog_var)::in, hlds_goal::out) is det.
+
+acc_unification(Out - Acc, Goal) :-
+ UnifyMode = unify_modes_li_lf_ri_rf(free, ground_inst,
+ ground_inst, ground_inst),
+ Context = unify_context(umc_explicit, []),
+ Expr = unify(Out, rhs_var(Acc), UnifyMode, assign(Out,Acc), Context),
+ set_of_var.list_to_set([Out, Acc], NonLocalVars),
+ InstMapDelta = instmap_delta_bind_var(Out),
+ goal_info_init(NonLocalVars, InstMapDelta, detism_det, purity_pure, Info),
+ Goal = hlds_goal(Expr, Info).
+
+%---------------------------------------------------------------------------%
+
+ % Given the top level structure of the goal create new version
+ % with new base and recursive cases plugged in.
+ %
+:- pred accu_top_level(top_level::in, hlds_goal::in,
+ hlds_goal::in, hlds_goal::in, hlds_goal::in,
+ hlds_goal::in, hlds_goal::out, hlds_goal::out) is det.
+
+accu_top_level(TopLevel, Goal, OrigBaseGoal, OrigRecGoal,
+ NewBaseGoal, NewRecGoal, OrigGoal, NewGoal) :-
+ (
+ TopLevel = switch_base_rec,
+ ( if
+ Goal = hlds_goal(switch(Var, CanFail, Cases0), GoalInfo),
+ Cases0 = [case(IdA, [], _), case(IdB, [], _)]
+ then
+ OrigCases = [case(IdA, [], OrigBaseGoal),
+ case(IdB, [], OrigRecGoal)],
+ OrigGoal = hlds_goal(switch(Var, CanFail, OrigCases), GoalInfo),
+
+ NewCases = [case(IdA, [], NewBaseGoal), case(IdB, [], NewRecGoal)],
+ NewGoal = hlds_goal(switch(Var, CanFail, NewCases), GoalInfo)
+ else
+ unexpected($pred, "not the correct top level")
+ )
+ ;
+ TopLevel = switch_rec_base,
+ ( if
+ Goal = hlds_goal(switch(Var, CanFail, Cases0), GoalInfo),
+ Cases0 = [case(IdA, [], _), case(IdB, [], _)]
+ then
+ OrigCases = [case(IdA, [], OrigRecGoal),
+ case(IdB, [], OrigBaseGoal)],
+ OrigGoal = hlds_goal(switch(Var, CanFail, OrigCases), GoalInfo),
+
+ NewCases = [case(IdA, [], NewRecGoal), case(IdB, [], NewBaseGoal)],
+ NewGoal = hlds_goal(switch(Var, CanFail, NewCases), GoalInfo)
+ else
+ unexpected($pred, "not the correct top level")
+ )
+ ;
+ TopLevel = disj_base_rec,
+ ( if
+ Goal = hlds_goal(disj(Goals), GoalInfo),
+ Goals = [_, _]
+ then
+ OrigGoals = [OrigBaseGoal, OrigRecGoal],
+ OrigGoal = hlds_goal(disj(OrigGoals), GoalInfo),
+
+ NewGoals = [NewBaseGoal, NewRecGoal],
+ NewGoal = hlds_goal(disj(NewGoals), GoalInfo)
+ else
+ unexpected($pred, "not the correct top level")
+ )
+ ;
+ TopLevel = disj_rec_base,
+ ( if
+ Goal = hlds_goal(disj(Goals), GoalInfo),
+ Goals = [_, _]
+ then
+ OrigGoals = [OrigRecGoal, OrigBaseGoal],
+ OrigGoal = hlds_goal(disj(OrigGoals), GoalInfo),
+
+ NewGoals = [NewRecGoal, NewBaseGoal],
+ NewGoal = hlds_goal(disj(NewGoals), GoalInfo)
+ else
+ unexpected($pred, "not the correct top level")
+ )
+ ;
+ TopLevel = ite_base_rec,
+ ( if Goal = hlds_goal(if_then_else(Vars, Cond, _, _), GoalInfo) then
+ OrigGoal = hlds_goal(if_then_else(Vars, Cond,
+ OrigBaseGoal, OrigRecGoal), GoalInfo),
+ NewGoal = hlds_goal(if_then_else(Vars, Cond,
+ NewBaseGoal, NewRecGoal), GoalInfo)
+ else
+ unexpected($pred, "not the correct top level")
+ )
+ ;
+ TopLevel = ite_rec_base,
+ ( if Goal = hlds_goal(if_then_else(Vars, Cond, _, _), GoalInfo) then
+ OrigGoal = hlds_goal(if_then_else(Vars, Cond,
+ OrigRecGoal, OrigBaseGoal), GoalInfo),
+ NewGoal = hlds_goal(if_then_else(Vars, Cond,
+ NewRecGoal, NewBaseGoal), GoalInfo)
+ else
+ unexpected($pred, "not the correct top level")
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % Place the accumulator version of the predicate in the HLDS.
+ %
+:- pred update_accumulator_pred(pred_id::in, proc_id::in,
+ hlds_goal::in, module_info::in, module_info::out) is det.
+
+update_accumulator_pred(NewPredId, NewProcId, AccGoal, !ModuleInfo) :-
+ module_info_pred_proc_info(!.ModuleInfo, NewPredId, NewProcId,
+ PredInfo, ProcInfo0),
+ proc_info_set_goal(AccGoal, ProcInfo0, ProcInfo1),
+ requantify_proc_general(ordinary_nonlocals_no_lambda, ProcInfo1, ProcInfo),
+ module_info_set_pred_proc_info(NewPredId, NewProcId,
+ PredInfo, ProcInfo, !ModuleInfo).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % accu_rename(Ids, Subst, From, Initial):
+ %
+ % Return a goal_store, Final, which is the result of looking up each
+ % member of set of goal_ids, Ids, in the goal_store, From, applying
+ % the substitution and then storing the goal into the goal_store, Initial.
+ %
+:- func accu_rename(list(accu_goal_id), accu_subst,
+ accu_goal_store, accu_goal_store) = accu_goal_store.
+
+accu_rename(Ids, Subst, From, Initial) = Final :-
+ list.foldl(
+ ( pred(Id::in, GS0::in, GS::out) is det :-
+ goal_store_lookup(From, Id, stored_goal(Goal0, InstMap)),
+ rename_some_vars_in_goal(Subst, Goal0, Goal),
+ goal_store_det_insert(Id, stored_goal(Goal, InstMap), GS0, GS)
+ ), Ids, Initial, Final).
+
+ % Return all the goal_ids which belong in the base case.
+ %
+:- func base_case_ids(accu_goal_store) = list(accu_goal_id).
+
+base_case_ids(GS) = Base :-
+ solutions.solutions(
+ ( pred(Key::out) is nondet :-
+ goal_store_member(GS, Key, _Goal),
+ Key = accu_goal_id(accu_base, _)
+ ), Base).
+
+:- func base_case_ids_set(accu_goal_store) = set(accu_goal_id).
+
+base_case_ids_set(GS) = set.list_to_set(base_case_ids(GS)).
+
+ % Given a list of goal_ids, return the list of hlds_goals from
+ % the goal_store.
+ %
+:- func accu_goal_list(list(accu_goal_id), accu_goal_store) = list(hlds_goal).
+
+accu_goal_list(Ids, GS) = Goals :-
+ list.map(
+ ( pred(Key::in, G::out) is det :-
+ goal_store_lookup(GS, Key, stored_goal(G, _))
+ ), Ids, Goals).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- pred calculate_goal_info(hlds_goal_expr::in, hlds_goal::out) is det.
+
+calculate_goal_info(GoalExpr, hlds_goal(GoalExpr, GoalInfo)) :-
+ ( if GoalExpr = conj(plain_conj, GoalList) then
+ goal_list_nonlocals(GoalList, NonLocals),
+ goal_list_instmap_delta(GoalList, InstMapDelta),
+ goal_list_determinism(GoalList, Detism),
+
+ goal_info_init(NonLocals, InstMapDelta, Detism, purity_pure, GoalInfo)
+ else
+ unexpected($pred, "not a conj")
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- func chain_subst(accu_subst, accu_subst) = accu_subst.
+
+chain_subst(AtoB, BtoC) = AtoC :-
+ map.keys(AtoB, Keys),
+ chain_subst_2(Keys, AtoB, BtoC, AtoC).
+
+:- pred chain_subst_2(list(A)::in, map(A, B)::in, map(B, C)::in,
+ map(A, C)::out) is det.
+
+chain_subst_2([], _, _, AtoC) :-
+ map.init(AtoC).
+chain_subst_2([A | As], AtoB, BtoC, AtoC) :-
+ chain_subst_2(As, AtoB, BtoC, AtoC0),
+ map.lookup(AtoB, A, B),
+ ( if map.search(BtoC, B, C) then
+ map.det_insert(A, C, AtoC0, AtoC)
+ else
+ AtoC = AtoC0
+ ).
+
+%---------------------------------------------------------------------------%
+:- end_module transform_hlds.accumulator.
+%---------------------------------------------------------------------------%
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index be02c30..fb9441e 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -53,7 +53,7 @@
"Compile the compiler and load it to compile it-self.
Check that the resulting binaries do not differ."
:tags '(:expensive-test :nativecomp)
- (let* ((byte-native-for-bootstrap t) ; FIXME HACK
+ (let* ((byte+native-compile t) ; FIXME HACK
(comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el"
(ert-resource-directory)))
(comp1-src (make-temp-file "stage1-" nil ".el"))