[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] comment-cache f4d5b68 2/2: Merge branch 'master' into comm
|
From: |
Alan Mackenzie |
|
Subject: |
[Emacs-diffs] comment-cache f4d5b68 2/2: Merge branch 'master' into comment-cache |
|
Date: |
Sun, 12 Feb 2017 06:05:08 -0500 (EST) |
branch: comment-cache
commit f4d5b687150810129b7a1d5b006e31ccf82b691b
Merge: d551433 148100d
Author: Alan Mackenzie <address@hidden>
Commit: Alan Mackenzie <address@hidden>
Merge branch 'master' into comment-cache
---
admin/notes/multi-tty | 5 +-
doc/emacs/display.texi | 12 +-
doc/emacs/files.texi | 6 +
doc/emacs/search.texi | 20 +-
doc/lispintro/emacs-lisp-intro.texi | 8 +-
doc/lispref/edebug.texi | 10 +-
doc/lispref/files.texi | 26 +-
doc/lispref/internals.texi | 6 +-
doc/lispref/lists.texi | 33 +
doc/lispref/processes.texi | 8 +
doc/lispref/windows.texi | 15 +
doc/misc/cc-mode.texi | 31 +-
doc/misc/cl.texi | 2 +-
doc/misc/emacs-mime.texi | 4 +
doc/misc/gnus.texi | 34 +-
doc/misc/texinfo.tex | 33 +-
etc/DEBUG | 2 +-
etc/NEWS | 65 +-
lib/c-ctype.h | 20 +-
lib/strftime.c | 12 +-
lib/time-internal.h | 4 +-
lib/verify.h | 7 +-
lisp/auth-source.el | 2 +-
lisp/battery.el | 3 +
lisp/buff-menu.el | 19 +-
lisp/calc/calc-misc.el | 2 +-
lisp/calendar/parse-time.el | 12 +-
lisp/cus-start.el | 1 +
lisp/dired-aux.el | 2 +
lisp/dired.el | 4 +
lisp/doc-view.el | 5 +
lisp/emacs-lisp/backquote.el | 10 +
lisp/emacs-lisp/cl-generic.el | 15 +-
lisp/emacs-lisp/cl-lib.el | 143 +---
lisp/emacs-lisp/cl.el | 24 -
lisp/emacs-lisp/edebug.el | 13 +-
lisp/emacs-lisp/ert-x.el | 26 +-
lisp/emacs-lisp/let-alist.el | 2 +-
lisp/emacs-lisp/pcase.el | 3 +-
lisp/emacs-lisp/subr-x.el | 41 +-
lisp/emacs-lisp/tabulated-list.el | 9 +-
lisp/emulation/edt-mapper.el | 525 ++++++------
lisp/emulation/edt.el | 8 +-
lisp/files.el | 18 +-
lisp/gnus/gnus-art.el | 22 +-
lisp/gnus/gnus-msg.el | 9 +-
lisp/gnus/gnus-salt.el | 4 +-
lisp/gnus/gnus-start.el | 9 +-
lisp/gnus/gnus-sum.el | 28 +-
lisp/gnus/gnus-topic.el | 2 +-
lisp/gnus/gnus.el | 4 -
lisp/gnus/message.el | 132 +--
lisp/gnus/mml.el | 98 ++-
lisp/gnus/nndoc.el | 20 +-
lisp/gnus/nnimap.el | 6 +-
lisp/help-fns.el | 40 +-
lisp/help-mode.el | 2 +-
lisp/hl-line.el | 3 +-
lisp/htmlfontify.el | 12 +-
lisp/ibuffer.el | 15 +-
lisp/image-dired.el | 8 +-
lisp/indent.el | 32 +-
lisp/info.el | 11 +
lisp/mail/ietf-drums.el | 11 +
lisp/mail/rfc2047.el | 12 +-
lisp/mh-e/mh-compat.el | 10 -
lisp/net/eww.el | 71 +-
lisp/net/network-stream.el | 4 +
lisp/net/shr.el | 32 +-
lisp/net/tramp.el | 30 +-
lisp/net/zeroconf.el | 6 +-
lisp/play/dunnet.el | 2 +-
lisp/progmodes/cc-align.el | 12 +
lisp/progmodes/cc-engine.el | 99 ++-
lisp/progmodes/cc-styles.el | 1 +
lisp/progmodes/cc-vars.el | 2 +-
lisp/progmodes/hideshow.el | 2 +-
lisp/progmodes/js.el | 24 +-
lisp/progmodes/python.el | 20 +-
lisp/progmodes/sql.el | 2 +-
lisp/progmodes/vhdl-mode.el | 43 +-
lisp/progmodes/xref.el | 2 +-
lisp/recentf.el | 2 +-
lisp/replace.el | 115 ++-
lisp/shell.el | 13 +-
lisp/simple.el | 8 +-
lisp/subr.el | 122 +++
lisp/term.el | 15 +-
lisp/textmodes/css-mode.el | 156 +++-
lisp/textmodes/reftex-vars.el | 2 +
lisp/vc/diff-mode.el | 190 +++--
lisp/vc/ediff-init.el | 46 +-
lisp/xml.el | 6 +-
src/alloc.c | 299 ++++---
src/atimer.c | 1 +
src/buffer.c | 13 +-
src/bytecode.c | 22 +-
src/callint.c | 2 +-
src/callproc.c | 18 +-
src/category.c | 2 +-
src/ccl.c | 2 +-
src/decompress.c | 2 +-
src/dired.c | 9 +-
src/dispextern.h | 1 +
src/doc.c | 9 +-
src/editfns.c | 12 +-
src/emacs-module.c | 2 +-
src/emacs.c | 2 +-
src/eval.c | 51 +-
src/fileio.c | 94 +--
src/filelock.c | 9 +-
src/fns.c | 377 ++++-----
src/fontset.c | 8 +-
src/frame.c | 5 +-
src/gfilenotify.c | 8 +-
src/gnutls.c | 13 +-
src/image.c | 2 +-
src/indent.c | 13 +-
src/insdel.c | 12 +-
src/keyboard.c | 109 +--
src/keyboard.h | 2 +
src/keymap.c | 12 +-
src/lisp.h | 64 +-
src/lread.c | 16 +-
src/macros.c | 2 +-
src/minibuf.c | 2 +-
src/print.c | 16 +-
src/process.c | 22 +-
src/profiler.c | 6 +-
src/regex.c | 13 +-
src/search.c | 105 +--
src/syntax.c | 250 +++---
src/sysdep.c | 131 +--
src/textprop.c | 2 +-
src/w32fns.c | 15 +-
src/w32notify.c | 2 +-
src/w32proc.c | 2 +-
src/window.c | 62 +-
src/window.h | 2 +
src/xdisp.c | 106 ++-
src/xselect.c | 4 +-
src/xterm.c | 4 +-
test/lisp/abbrev-tests.el | 3 +-
test/lisp/autorevert-tests.el | 170 ++--
test/lisp/emacs-lisp/cl-seq-tests.el | 6 +-
test/lisp/emacs-lisp/let-alist-tests.el | 5 +-
.../emacs-lisp/testcover-resources/testcases.el | 493 ++++++++++++
test/lisp/emacs-lisp/testcover-tests.el | 186 +++++
test/lisp/faces-tests.el | 9 +-
test/lisp/ffap-tests.el | 2 +-
test/lisp/filenotify-tests.el | 70 +-
test/lisp/htmlfontify-tests.el | 12 +
test/lisp/ibuffer-tests.el | 9 +
test/lisp/kmacro-tests.el | 890 +++++++++++++++++++++
test/lisp/minibuffer-tests.el | 2 +-
test/lisp/net/dbus-tests.el | 3 +-
test/lisp/progmodes/js-tests.el | 14 +
test/lisp/progmodes/python-tests.el | 23 +-
test/lisp/simple-tests.el | 6 +-
test/lisp/textmodes/css-mode-tests.el | 15 +
test/lisp/textmodes/tildify-tests.el | 2 +-
test/lisp/vc/diff-mode-tests.el | 203 +++++
test/lisp/xml-tests.el | 15 +
test/manual/indent/css-mode.css | 27 +
test/manual/indent/scss-mode.scss | 44 +-
test/manual/scroll-tests.el | 130 +++
test/src/syntax-tests.el | 85 ++
167 files changed, 4939 insertions(+), 2189 deletions(-)
diff --git a/admin/notes/multi-tty b/admin/notes/multi-tty
index b58180e..d0096ad 100644
--- a/admin/notes/multi-tty
+++ b/admin/notes/multi-tty
@@ -1239,9 +1239,8 @@ DIARY OF CHANGES
(Update: OK, it all seems so easy now (NOT). Input could be done
synchronously (with wait_reading_process_input), or asynchronously
by SIGIO or polling (SIGALRM). C-g either sets the Vquit_flag,
- signals a 'quit condition (when immediate_quit), or throws to
- 'getcjmp' when Emacs was waiting for input when the C-g event
- arrived.)
+ signals a 'quit condition, or throws to 'getcjmp' when Emacs was
+ waiting for input when the C-g event arrived.)
-- Replace wrong_kboard_jmpbuf with a special return value of
read_char. It is absurd that we use setjmp/longjmp just to return
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index c6e990d..15c7008 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -285,13 +285,17 @@ multiple variables, the order of priority is:
@code{scroll-up-aggressively} / @code{scroll-down-aggressively}.
@vindex scroll-margin
address@hidden maximum-scroll-margin
The variable @code{scroll-margin} restricts how close point can come
to the top or bottom of a window (even if aggressive scrolling
specifies a fraction @var{f} that is larger than the window portion
-between the top and the bottom margins). Its value is a number of screen
-lines; if point comes within that many lines of the top or bottom of
-the window, Emacs performs automatic scrolling. By default,
address@hidden is 0.
+between the top and the bottom margins). Its value is a number of
+screen lines; if point comes within that many lines of the top or
+bottom of the window, Emacs performs automatic scrolling. By default,
address@hidden is 0. The effective margin size is limited to a
+quarter of the window height by default, but this limit can be
+increased up to half (or decreased down to zero) by customizing
address@hidden
@node Horizontal Scrolling
@section Horizontal Scrolling
diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index 5c582e5..2b09c69 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -417,6 +417,12 @@ changes you would be saving. This calls the command
Display a help message about these options.
@end table
address@hidden
address@hidden save-some-buffers-default-predicate
+You can customize the value of
address@hidden to control which buffers
+Emacs will ask about.
+
@kbd{C-x C-c}, the key sequence to exit Emacs, invokes
@code{save-some-buffers} and therefore asks the same questions.
diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi
index b728258..fa69ba4 100644
--- a/doc/emacs/search.texi
+++ b/doc/emacs/search.texi
@@ -1670,8 +1670,9 @@ replacing regexp matches in file names.
Here are some other commands that find matches for a regular
expression. They all ignore case in matching, if the pattern contains
no upper-case letters and @code{case-fold-search} is address@hidden
-Aside from @code{occur} and its variants, all operate on the text from
-point to the end of the buffer, or on the region if it is active.
+Aside from @code{multi-occur} and @code{multi-occur-in-matching-buffers},
+which always search the whole buffer, all operate on the text from point
+to the end of the buffer, or on the region if it is active.
@findex list-matching-lines
@findex occur
@@ -1714,6 +1715,8 @@ a multi-file incremental search is activated
automatically.
@cindex mode, Occur
@cindex match (face name)
@vindex list-matching-lines-default-context-lines
address@hidden list-matching-lines-jump-to-current-line
address@hidden list-matching-lines-current-line-face (face name)
@kindex M-s o
@item M-x occur
@itemx M-s o
@@ -1721,11 +1724,14 @@ Prompt for a regexp, and display a list showing each
line in the
buffer that contains a match for it. If you type @kbd{M-n} at the
prompt, you can reuse search strings from previous incremental
searches. The text that matched is highlighted using the @code{match}
-face. To limit the search to part of the buffer, narrow to that part
-(@pxref{Narrowing}). A numeric argument @var{n} specifies that
address@hidden lines of context are to be displayed before and after each
-matching line. The default number of context lines is specified by
-the variable @code{list-matching-lines-default-context-lines}.
+face. A numeric argument @var{n} specifies that @var{n} lines of
+context are to be displayed before and after each matching line.
+The default number of context lines is specified by the variable
address@hidden
+When @code{list-matching-lines-jump-to-current-line} is non-nil,
+the current line is shown highlighted with face
address@hidden and the point is set
+at the first match after such line.
You can also run @kbd{M-s o} when an incremental search is active;
this uses the current search string.
diff --git a/doc/lispintro/emacs-lisp-intro.texi
b/doc/lispintro/emacs-lisp-intro.texi
index 830c072..36d7677 100644
--- a/doc/lispintro/emacs-lisp-intro.texi
+++ b/doc/lispintro/emacs-lisp-intro.texi
@@ -17151,9 +17151,11 @@ Here is another keybinding, with a comment:
@findex occur
The @code{occur} command shows all the lines in the current buffer
-that contain a match for a regular expression. Matching lines are
-shown in a buffer called @file{*Occur*}. That buffer serves as a menu
-to jump to occurrences.
+that contain a match for a regular expression. When the region is
+active, @code{occur} restricts matches to such region. Otherwise it
+uses the entire buffer.
+Matching lines are shown in a buffer called @file{*Occur*}.
+That buffer serves as a menu to jump to occurrences.
@findex global-unset-key
@cindex Unbinding key
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index f6f73ea..da72c9b 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -979,9 +979,13 @@ program.
@itemize @bullet
@item
address@hidden and @code{max-specpdl-size} are both
-increased to reduce Edebug's impact on the stack. You could, however,
-still run out of stack space when using Edebug.
address@hidden edebug-max-depth
address@hidden (@pxref{Eval}) and @code{max-specpdl-size}
+(@pxref{Local Variables}) are both increased to reduce Edebug's impact
+on the stack. You could, however, still run out of stack space when
+using Edebug. You can also enlarge the value of
address@hidden if Edebug reaches the limit of recursion depth
+instrumenting code that contains very large quoted lists.
@item
The state of keyboard macro execution is saved and restored. While
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index 853e844..ef37321 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -368,17 +368,21 @@ asks the user about each buffer. But if
@var{save-silently-p} is
address@hidden, it saves all the file-visiting buffers without querying
the user.
-The optional @var{pred} argument controls which buffers to ask about
-(or to save silently if @var{save-silently-p} is address@hidden).
-If it is @code{nil}, that means to ask only about file-visiting buffers.
-If it is @code{t}, that means also offer to save certain other non-file
-buffers---those that have a address@hidden buffer-local value of
address@hidden (@pxref{Killing Buffers}). A user who says
address@hidden to saving a non-file buffer is asked to specify the file
-name to use. The @code{save-buffers-kill-emacs} function passes the
-value @code{t} for @var{pred}.
-
-If @var{pred} is neither @code{t} nor @code{nil}, then it should be
address@hidden save-some-buffers-default-predicate
+The optional @var{pred} argument provides a predicate that controls
+which buffers to ask about (or to save silently if
address@hidden is address@hidden). If @var{pred} is
address@hidden, that means to use the value of
address@hidden instead of @var{pred}. If
+the result is @code{nil}, it means ask only about file-visiting
+buffers. If it is @code{t}, that means also offer to save certain
+other non-file buffers---those that have a address@hidden buffer-local
+value of @code{buffer-offer-save} (@pxref{Killing Buffers}). A user
+who says @samp{yes} to saving a non-file buffer is asked to specify
+the file name to use. The @code{save-buffers-kill-emacs} function
+passes the value @code{t} for @var{pred}.
+
+If the predicate is neither @code{t} nor @code{nil}, then it should be
a function of no arguments. It will be called in each buffer to decide
whether to offer to save that buffer. If it returns a address@hidden
value in a certain buffer, that means do offer to save that buffer.
diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi
index 69d21be..663d0fd 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -672,7 +672,7 @@ usage: (or CONDITIONS...) */)
if (!NILP (val))
break;
args = XCDR (args);
- QUIT;
+ maybe_quit ();
@}
@end group
@@ -792,8 +792,8 @@ their addresses after performing Lisp evaluation. Lisp
evaluation can
occur via calls to @code{eval_sub} or @code{Feval}, either directly or
indirectly.
address@hidden @code{QUIT}, use in Lisp primitives
- Note the call to the @code{QUIT} macro inside the loop: this macro
address@hidden @code{maybe_quit}, use in Lisp primitives
+ Note the call to @code{maybe_quit} inside the loop: this function
checks whether the user pressed @kbd{C-g}, and if so, aborts the
processing. You should do that in any loop that can potentially
require a large number of iterations; in this case, the list of
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index bd7d85a..8eab281 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -362,6 +362,39 @@ This is the same as @code{(cdr (cdr @var{cons-cell}))}
or @code{(nthcdr 2 @var{cons-cell})}.
@end defun
address@hidden caaar
address@hidden caadr
address@hidden cadar
address@hidden caddr
address@hidden cdaar
address@hidden cdadr
address@hidden cddar
address@hidden cdddr
address@hidden caaaar
address@hidden caaadr
address@hidden caadar
address@hidden caaddr
address@hidden cadaar
address@hidden cadadr
address@hidden caddar
address@hidden cadddr
address@hidden cdaaar
address@hidden cdaadr
address@hidden cdadar
address@hidden cdaddr
address@hidden cddaar
address@hidden cddadr
address@hidden cdddar
address@hidden cddddr
+In addition to the above, 24 additional compositions of @code{car} and
address@hidden are defined as @address@hidden and @address@hidden,
+where each @address@hidden is either @code{a} or @code{d}. @code{cadr},
address@hidden, and @code{cadddr} pick out the second, third or fourth
+elements of a list, respectively. @file{cl-lib} provides the same
+under the names @code{cl-second}, @code{cl-third}, and
address@hidden @xref{List Functions,,, cl, Common Lisp
+Extensions}.
+
@defun butlast x &optional n
This function returns the list @var{x} with the last element,
or the last @var{n} elements, removed. If @var{n} is greater
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 014a0ae..58e04a3 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -2414,6 +2414,14 @@ If address@hidden, the host's capability string.
The connection type: @samp{plain} or @samp{tls}.
@end table
address@hidden :shell-command @var{string-or-nil}
+If the connection @code{type} is @code{shell}, this parameter will be
+interpreted as a format-spec string that will be executed to make the
+connection. The specs available are @samp{%s} for the host name and
address@hidden for the port number. For instance, if you want to first ssh
+to @samp{gateway} before making a plain connection, then this
+parameter could be something like @samp{ssh gateway nc %s %p}.
+
@end table
@end defun
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index 6f3de0c..affa28c 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -3924,6 +3924,21 @@ redisplay scrolls the text automatically (if possible)
to move point
out of the margin, closer to the center of the window.
@end defopt
address@hidden maximum-scroll-margin
+This variable limits the effective value of @code{scroll-margin} to a
+fraction of the current window line height. For example, if the
+current window has 20 lines and @code{maximum-scroll-margin} is 0.1,
+then the scroll margins will never be larger than 2 lines, no matter
+how big @code{scroll-margin} is.
+
address@hidden itself has a maximum value of 0.5, which
+allows setting margins large to keep the cursor at the middle line of
+the window (or two middle lines if the window has an even number of
+lines). If it's set to a larger value (or any value other than a
+float between 0.0 and 0.5) then the default value of 0.25 will be used
+instead.
address@hidden defopt
+
@defopt scroll-conservatively
This variable controls how scrolling is done automatically when point
moves off the screen (or into the scroll margin). If the value is a
diff --git a/doc/misc/cc-mode.texi b/doc/misc/cc-mode.texi
index 68a16c0..14981c9 100644
--- a/doc/misc/cc-mode.texi
+++ b/doc/misc/cc-mode.texi
@@ -4141,7 +4141,8 @@ Open brace of an enum or static array list. @ref{Brace
List Symbols}.
@item brace-list-close
Close brace of an enum or static array list. @ref{Brace List Symbols}.
@item brace-list-intro
-First line in an enum or static array list. @ref{Brace List Symbols}.
+First line after the opening @address@hidden in an enum or static array
+list. @ref{Brace List Symbols}.
@item brace-list-entry
Subsequent lines in an enum or static array list. @ref{Brace List
Symbols}.
@@ -4635,11 +4636,18 @@ example:
Here, you've already seen the analysis of lines 1, 2, 3, and 11. On
line 4, things get interesting; this line is assigned
address@hidden syntactic symbol because it's a bracelist entry
-line that starts with an open brace. Lines 5 and 6 (and line 9) are
-pretty standard, and line 7 is a @code{brace-list-close} as you'd
-expect. Once again, line 8 is assigned as @code{brace-entry-open} as is
-line 10.
address@hidden syntactic symbol because it's a bracelist
+entry line that starts with an open brace. Lines 5 and 6 are pretty
+standard, and line 7 is a @code{brace-list-close} as you'd expect.
+Once again, line 8 is assigned as @code{brace-entry-open} as is line
+10. Line 9 is assigned two syntactic elements, @code{brace-list-intro}
+with anchor point at the @address@hidden of line address@hidden extra
+syntactic element was introduced in @ccmode{} 5.33.1 to allow extra
+flexibility in indenting the second line of such a construct. You can
+preserve the behaviour resulting from the former syntactic analysis by
+giving @code{brace-list-entry} an offset of
address@hidden (@pxref{Misc Line-Up}).}, and
address@hidden anchored on the @samp{1} of line 8.
@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@node External Scope Symbols, Paren List Symbols, Brace List Symbols,
Syntactic Symbols
@@ -6288,6 +6296,17 @@ already has; think of it as an identity function for
lineups.
@comment ------------------------------------------------------------
address@hidden c-lineup-under-anchor
+
+Line up a line directly underneath its anchor point. This is like
address@hidden, except any previously calculated offset contributions are
+disregarded.
+
address@hidden Any syntactic symbol which has an anchor point.
address@hidden defun
+
address@hidden ------------------------------------------------------------
+
@defun c-lineup-cpp-define
@findex lineup-cpp-define (c-)
Line up macro continuation lines according to the indentation of the
diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index 9e56a54..8baa0bd 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -3694,7 +3694,7 @@ i.e., chains of cons cells.
@defun cl-caddr x
This function is equivalent to @code{(car (cdr (cdr @var{x})))}.
-Likewise, this package defines all 24 @address@hidden functions
+Likewise, this package aliases all 24 @address@hidden functions
where @var{xxx} is up to four @samp{a}s and/or @samp{d}s.
All of these functions are @code{setf}-able, and calls to them
are expanded inline by the byte-compiler for maximum efficiency.
diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi
index 771c078..b0cfbc9 100644
--- a/doc/misc/emacs-mime.texi
+++ b/doc/misc/emacs-mime.texi
@@ -654,6 +654,10 @@ Each tag can contain zero or more parameters on the form
but that's not necessary unless the value contains white space. So
@samp{filename=/home/user/#hello$^yes} is perfectly valid.
+If you want to talk about MML in a message, you need a way to
+``quote'' these tags. The way to do that is to include an exclamation
+point after the opening two characters; i. e. @samp{<#!part ...>}.
+
The following parameters have meaning in @acronym{MML}; parameters that have no
meaning are ignored. The @acronym{MML} parameter names are the same as the
@acronym{MIME} parameter names; the things in the parentheses say which
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 05159d4..ceeb42b 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -10197,6 +10197,11 @@ Sort by lines (@code{gnus-summary-sort-by-lines}).
@findex gnus-summary-sort-by-chars
Sort by article length (@code{gnus-summary-sort-by-chars}).
address@hidden C-c C-s C-m C-m
address@hidden C-c C-s C-m C-m (Summary)
address@hidden gnus-summary-sort-by-marks
+Sort by article ``readedness'' marks (@code{gnus-summary-sort-by-marks}).
+
@item C-c C-s C-i
@kindex C-c C-s C-i (Summary)
@findex gnus-summary-sort-by-score
@@ -13515,7 +13520,8 @@ Close the connection (if any) to the server
@kindex D (Server)
@findex gnus-server-deny-server
Mark the current server as unreachable
-(@code{gnus-server-deny-server}).
+(@code{gnus-server-deny-server}). This will effectively disable the
+server.
@item M-o
@kindex M-o (Server)
@@ -21857,37 +21863,37 @@ In summary mode:
@table @kbd
address@hidden $ m
address@hidden $ m (Summary)
address@hidden G G m
address@hidden G G m (Summary)
@findex nnmairix-widget-search-from-this-article
Allows you to create a mairix query or group based on the current
message using graphical widgets (same as @code{nnmairix-widget-search})
(@code{nnmairix-widget-search-from-this-article}).
address@hidden $ g
address@hidden $ g (Summary)
address@hidden G G g
address@hidden G G g (Summary)
@findex nnmairix-create-search-group-from-message
Interactively creates a new search group with query based on the current
message, but uses the minibuffer instead of graphical widgets
(@code{nnmairix-create-search-group-from-message}).
address@hidden $ t
address@hidden $ t (Summary)
address@hidden G G t
address@hidden G G t (Summary)
@findex nnmairix-search-thread-this-article
Searches thread for the current article
(@code{nnmairix-search-thread-this-article}). This is effectively a
shortcut for calling @code{nnmairix-search} with @samp{m:msgid} of the
current article and enabled threads.
address@hidden $ f
address@hidden $ f (Summary)
address@hidden G G f
address@hidden G G f (Summary)
@findex nnmairix-search-from-this-article
Searches all messages from sender of the current article
(@code{nnmairix-search-from-this-article}). This is a shortcut for
calling @code{nnmairix-search} with @samp{f:From}.
address@hidden $ o
address@hidden $ o (Summary)
address@hidden G G o
address@hidden G G o (Summary)
@findex nnmairix-goto-original-article
(Only in @code{nnmairix} groups!) Tries determine the group this article
originally came from and displays the article in this group, so that,
@@ -21896,8 +21902,8 @@ parameters are applied
(@code{nnmairix-goto-original-article}). This
function will use the registry if available, but can also parse the
article file name as a fallback method.
address@hidden $ u
address@hidden $ u (Summary)
address@hidden G G u
address@hidden G G u (Summary)
@findex nnmairix-remove-tick-mark-original-article
Remove possibly existing tick mark from original article
(@code{nnmairix-remove-tick-mark-original-article}). (@pxref{nnmairix
@@ -22051,7 +22057,7 @@ activate the always-unread feature by using @kbd{G b r}
twice.
So far so good---but how do you remove the tick marks in the @code{nnmairix}
group? There are two options: You may simply use
address@hidden (bound to @kbd{$ u}) to remove
address@hidden (bound to @kbd{G G u}) to remove
tick marks from the original article. The other possibility is to set
@code{nnmairix-propagate-marks-to-nnmairix-groups} to @code{t}, but see the
above
comments about this option. If it works for you, the tick marks should
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex
index c8913ab..338bcf6 100644
--- a/doc/misc/texinfo.tex
+++ b/doc/misc/texinfo.tex
@@ -3,7 +3,7 @@
% Load plain if necessary, i.e., if running under initex.
\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
%
-\def\texinfoversion{2016-09-18.18}
+\def\texinfoversion{2017-01-14.15}
%
% Copyright 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995,
% 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
@@ -165,6 +165,9 @@
% Give the space character the catcode for a space.
\def\spaceisspace{\catcode`\ =10\relax}
+% Likewise for ^^M, the end of line character.
+\def\endlineisspace{\catcode13=10\relax}
+
\chardef\dashChar = `\-
\chardef\slashChar = `\/
\chardef\underChar = `\_
@@ -950,21 +953,14 @@ where each line of input produces a line of output.}
% @comment ...line which is ignored...
% @c is the same as @comment
% @ignore ... @end ignore is another way to write a comment
-%
-\def\comment{\begingroup \catcode`\^^M=\active%
address@hidden \catcode`\{=\other \catcode`\}=\other\commentxxx}%
-{\catcode`\^^M=\active%
-\gdef\commentxxx#1^^M{\endgroup%
-\futurelet\nexttoken\commentxxxx}%
-\gdef\commentxxxx{\ifx\nexttoken\aftermacro\expandafter\comment\fi}%
-}
\def\c{\begingroup \catcode`\^^M=\active%
address@hidden \catcode`\{=\other \catcode`\}=\other%
\cxxx}
{\catcode`\^^M=\active \gdef\cxxx#1^^M{\endgroup}}
-% See comment in \scanmacro about why the definitions of @c and @comment differ
+%
+\let\comment\c
% @paragraphindent NCHARS
% We'll use ems for NCHARS, close enough.
@@ -8031,9 +8027,6 @@ end
}
\fi
-\let\aftermacroxxx\relax
-\def\aftermacro{\aftermacroxxx}
-
% alias because \c means cedilla in @tex or @math
\let\texinfoc=\c
@@ -8055,18 +8048,13 @@ end
\catcode`\\=\active
%
% Process the macro body under the current catcode regime.
- address@hidden
+ address@hidden
%
address@hidden
\catcode`\\=\savedcatcodetwo
%
% The \texinfoc is to remove the \newlinechar added by \scantokens, and
% can be noticed by \parsearg.
- % The \aftermacro allows a \comment at the end of the macro definition
- % to duplicate itself past the final \newlinechar added by \scantokens:
- % this is used in the definition of \group to comment out a newline. We
- % don't do the same for \c to support Texinfo files with macros that ended
- % with a @c, which should no longer be necessary.
% We avoid surrounding the call to \scantokens with \bgroup and \egroup
% to allow macros to open or close groups themselves.
}
@@ -8538,6 +8526,13 @@ end
\ifcase\paramno
% 0
\expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup
+ \noexpand\spaceisspace
+ \noexpand\endlineisspace
+ \noexpand\expandafter % skip any whitespace after the macro name.
+ \expandafter\noexpand\csname\the\macname @@@\endcsname}%
+ \expandafter\xdef\csname\the\macname @@@\endcsname{%
+ \egroup
\noexpand\scanmacro{\macrobody}}%
\or % 1
\expandafter\xdef\csname\the\macname\endcsname{%
diff --git a/etc/DEBUG b/etc/DEBUG
index acb08c6..3719c3e 100644
--- a/etc/DEBUG
+++ b/etc/DEBUG
@@ -225,7 +225,7 @@ this command:
handle SIGINT stop nopass
After this 'handle' command, SIGINT will return control to GDB. If
-you want the C-g to cause a QUIT within Emacs as well, omit the 'nopass'.
+you want the C-g to cause a quit within Emacs as well, omit the 'nopass'.
See the GDB manual for more details about signal handling and the
'handle' command.
diff --git a/etc/NEWS b/etc/NEWS
index 051b97e..cbf2b70 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -116,7 +116,16 @@ dired buffer.
** Emacs now uses double buffering to reduce flicker when editing and
resizing graphical Emacs frames on the X Window System. This support
requires the DOUBLE-BUFFER extension, which major X servers have
-supported for many years.
+supported for many years. If your system has this extension, but an
+Emacs built with double buffering misbehaves on some displays you use,
+you can disable the feature by adding
+
+ '(inhibit-double-buffering . t)
+
+to default-frame-parameters. Or inject this parameter into the
+selected frame by evaluating this form:
+
+ (modify-frame-parameters nil '((inhibit-double-buffering . t)))
---
The group 'wp', whose label was "text", is now deprecated.
@@ -298,10 +307,23 @@ local part of a remote file name. Thus, if you have a
directory named
"/~" on the remote host "foo", you can prevent it from being
substituted by a home directory by writing it as "/foo:/:/~/file".
++++
+** The new variable 'maximum-scroll-margin' allows having effective
+settings of 'scroll-margin' up to half the window size, instead of
+always restricting the margin to a quarter of the window.
+
* Editing Changes in Emacs 26.1
+++
+** Two new user options 'list-matching-lines-jump-to-current-line' and
+'list-matching-lines-current-line-face' to show highlighted the current
+line in *Occur* buffer.
+
++++
+** The 'occur' command can now operate on the region.
+
++++
** New bindings for 'query-replace-map'.
'undo', undo the last replacement; bound to 'u'.
'undo-all', undo all replacements; bound to 'U'.
@@ -339,6 +361,16 @@ bound to 'Buffer-menu-unmark-all-buffers'.
*** Two new commands 'Buffer-menu-unmark-all', bound to 'U' and
'Buffer-menu-unmark-all-buffers', bound to 'M-DEL'.
+** Gnus
+
+---
+*** The .newsrc file will now only be saved if the native select
+method is an NNTP select method.
+
++++
+*** A new command for sorting articles by readedness marks has been
+added: `C-c C-s C-m C-m'.
+
** Ibuffer
---
@@ -432,6 +464,11 @@ viewing HTML files and the like.
breakpoint (e.g. with "f" and "o") by customizing the new option
'edebug-sit-on-break'.
++++
+*** New customizable option 'edebug-max-depth'
+This allows to enlarge the maximum recursion depth when instrumenting
+code.
+
** Eshell
*** 'eshell-input-filter's value is now a named function
@@ -594,6 +631,13 @@ HTML tags, classes and IDs using the 'completion-at-point'
command.
Completion candidates for HTML classes and IDs are retrieved from open
HTML mode buffers.
+---
+*** CSS mode now binds 'C-h S' to a function that will show
+information about a CSS construct (an at-rule, property, pseudo-class,
+pseudo-element, with the default being guessed from context). By
+default the information is looked up on the Mozilla Developer Network,
+but this can be customized using 'css-lookup-url-format'.
+
+++
** Emacs now supports character name escape sequences in character and
string literals. The syntax variants \N{character name} and
@@ -719,6 +763,13 @@ instead.
* Lisp Changes in Emacs 26.1
++++
+** 'save-some-buffers' now uses 'save-some-buffers-default-predicate'
+to decide which buffers to ask about, if the PRED argument is nil.
+The default value of 'save-some-buffers-default-predicate' is nil,
+which means ask about all file-visiting buffers.
+
+** string-(to|as|make)-(uni|multi)byte are now declared obsolete.
** New variable 'while-no-input-ignore-events' which allow
setting which special events 'while-no-input' should ignore.
It is a list of symbols.
@@ -778,6 +829,11 @@ of an arbitrary function. This generalizes 'subr-arity'
for functions
that are not built-in primitives. We recommend using this new
function instead of 'subr-arity'.
+** New function 'region-bounds' can be used in the interactive spec
+to provide region boundaries (for rectangular regions more than one)
+to an interactively callable function as a single argument instead of
+two separate arguments region-beginning and region-end.
+
+++
** 'parse-partial-sexp' state has a new element. Element 10 is
non-nil when the last character scanned might be the first character
@@ -838,6 +894,13 @@ ABBR is a time zone abbreviation. The affected functions
are
collection).
+++
+** 'car' and 'cdr' compositions 'cXXXr' and 'cXXXXr' are now part of Elisp.
+
+---
+** 'if-let*', 'when-let*', and 'and-let*' are new in subr-x.el.
+The incumbent 'if-let' and 'when-let' are now aliases.
+
++++
** The new functions 'make-nearby-temp-file' and 'temporary-file-directory'
can be used for creation of temporary files of remote or mounted directories.
diff --git a/lib/c-ctype.h b/lib/c-ctype.h
index faf2158..bcdba6b 100644
--- a/lib/c-ctype.h
+++ b/lib/c-ctype.h
@@ -115,16 +115,16 @@ extern "C" {
/* Cases for lowercase hex letters, and lowercase letters, all offset by N. */
-#define _C_CTYPE_LOWER_A_THRU_F_N(n) \
- case 'a' + (n): case 'b' + (n): case 'c' + (n): case 'd' + (n): \
- case 'e' + (n): case 'f' + (n)
-#define _C_CTYPE_LOWER_N(n) \
- _C_CTYPE_LOWER_A_THRU_F_N(n): \
- case 'g' + (n): case 'h' + (n): case 'i' + (n): case 'j' + (n): \
- case 'k' + (n): case 'l' + (n): case 'm' + (n): case 'n' + (n): \
- case 'o' + (n): case 'p' + (n): case 'q' + (n): case 'r' + (n): \
- case 's' + (n): case 't' + (n): case 'u' + (n): case 'v' + (n): \
- case 'w' + (n): case 'x' + (n): case 'y' + (n): case 'z' + (n)
+#define _C_CTYPE_LOWER_A_THRU_F_N(N) \
+ case 'a' + (N): case 'b' + (N): case 'c' + (N): case 'd' + (N): \
+ case 'e' + (N): case 'f' + (N)
+#define _C_CTYPE_LOWER_N(N) \
+ _C_CTYPE_LOWER_A_THRU_F_N(N): \
+ case 'g' + (N): case 'h' + (N): case 'i' + (N): case 'j' + (N): \
+ case 'k' + (N): case 'l' + (N): case 'm' + (N): case 'n' + (N): \
+ case 'o' + (N): case 'p' + (N): case 'q' + (N): case 'r' + (N): \
+ case 's' + (N): case 't' + (N): case 'u' + (N): case 'v' + (N): \
+ case 'w' + (N): case 'x' + (N): case 'y' + (N): case 'z' + (N)
/* Cases for hex letters, digits, lower, punct, and upper. */
diff --git a/lib/strftime.c b/lib/strftime.c
index 9aabcc6..e4d78ef 100644
--- a/lib/strftime.c
+++ b/lib/strftime.c
@@ -739,11 +739,10 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
/* The mask is not what you might think.
When the ordinal i'th bit is set, insert a colon
before the i'th digit of the time zone representation. */
-#define DO_TZ_OFFSET(d, negative, mask, v) \
+#define DO_TZ_OFFSET(d, mask, v) \
do \
{ \
digits = d; \
- negative_number = negative; \
tz_colon_mask = mask; \
u_number_value = v; \
goto do_tz_offset; \
@@ -1444,6 +1443,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
}
#endif
+ negative_number = diff < 0 || (diff == 0 && *zone == '-');
hour_diff = diff / 60 / 60;
min_diff = diff / 60 % 60;
sec_diff = diff % 60;
@@ -1451,13 +1451,13 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
switch (colons)
{
case 0: /* +hhmm */
- DO_TZ_OFFSET (5, diff < 0, 0, hour_diff * 100 + min_diff);
+ DO_TZ_OFFSET (5, 0, hour_diff * 100 + min_diff);
case 1: tz_hh_mm: /* +hh:mm */
- DO_TZ_OFFSET (6, diff < 0, 04, hour_diff * 100 + min_diff);
+ DO_TZ_OFFSET (6, 04, hour_diff * 100 + min_diff);
case 2: tz_hh_mm_ss: /* +hh:mm:ss */
- DO_TZ_OFFSET (9, diff < 0, 024,
+ DO_TZ_OFFSET (9, 024,
hour_diff * 10000 + min_diff * 100 + sec_diff);
case 3: /* +hh if possible, else +hh:mm, else +hh:mm:ss */
@@ -1465,7 +1465,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
goto tz_hh_mm_ss;
if (min_diff != 0)
goto tz_hh_mm;
- DO_TZ_OFFSET (3, diff < 0, 0, hour_diff);
+ DO_TZ_OFFSET (3, 0, hour_diff);
default:
goto bad_format;
diff --git a/lib/time-internal.h b/lib/time-internal.h
index 79cb562..bf22834 100644
--- a/lib/time-internal.h
+++ b/lib/time-internal.h
@@ -38,8 +38,8 @@ struct tm_zone
/* A sequence of null-terminated strings packed next to each other.
The strings are followed by an extra null byte. If TZ_IS_SET,
there must be at least one string and the first string (which is
- actually a TZ environment value value) may be empty. Otherwise
- all strings must be nonempty.
+ actually a TZ environment value) may be empty. Otherwise all
+ strings must be nonempty.
Abbreviations are stored here because otherwise the values of
tm_zone and/or tzname would be dead after changing TZ and calling
diff --git a/lib/verify.h b/lib/verify.h
index dcaf7ca..dcba9c8 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -248,7 +248,12 @@ template <int w>
/* Verify requirement R at compile-time, as a declaration without a
trailing ';'. */
-#define verify(R) _GL_VERIFY (R, "verify (" #R ")")
+#ifdef __GNUC__
+# define verify(R) _GL_VERIFY (R, "verify (" #R ")")
+#else
+/* PGI barfs if R is long. Play it safe. */
+# define verify(R) _GL_VERIFY (R, "verify (...)")
+#endif
#ifndef __has_builtin
# define __has_builtin(x) 0
diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index c26935f..7402ab2 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -2129,7 +2129,7 @@ MODE can be \"login\" or \"password\"."
(if user
(auth-source-search
:host host
- :user "yourusername"
+ :user user
:max 1
:require '(:user :secret)
:create nil)
diff --git a/lisp/battery.el b/lisp/battery.el
index 71268e5..b1834f0 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -542,6 +542,9 @@ The following %-sequences are provided:
(t "N/A"))))))
+(declare-function dbus-get-property "dbus.el"
+ (bus service path interface property))
+
;;; `upowerd' interface.
(defsubst battery-upower-prop (pname &optional device)
(dbus-get-property
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index 77b325f..9f618bc 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -102,9 +102,6 @@ This is set by the prefix argument to `buffer-menu' and
related
commands.")
(make-variable-buffer-local 'Buffer-menu-files-only)
-(defvar Info-current-file) ; from info.el
-(defvar Info-current-node) ; from info.el
-
(defvar Buffer-menu-mode-map
(let ((map (make-sparse-keymap))
(menu-map (make-sparse-keymap)))
@@ -702,21 +699,7 @@ means list those buffers and no others."
(defun Buffer-menu--pretty-file-name (file)
(cond (file
(abbreviate-file-name file))
- ((and (boundp 'list-buffers-directory)
- list-buffers-directory)
- list-buffers-directory)
- ((eq major-mode 'Info-mode)
- (Buffer-menu-info-node-description Info-current-file))
+ ((bound-and-true-p list-buffers-directory))
(t "")))
-(defun Buffer-menu-info-node-description (file)
- (cond
- ((equal file "dir") "*Info Directory*")
- ((eq file 'apropos) "*Info Apropos*")
- ((eq file 'history) "*Info History*")
- ((eq file 'toc) "*Info TOC*")
- ((not (stringp file)) "") ; Avoid errors
- (t
- (concat "(" (file-name-nondirectory file) ") " Info-current-node))))
-
;;; buff-menu.el ends here
diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el
index 7b7a720..e6af092 100644
--- a/lisp/calc/calc-misc.el
+++ b/lisp/calc/calc-misc.el
@@ -623,7 +623,7 @@ loaded and the keystroke automatically re-typed."
(unwind-protect
(progn
(sit-for 2)
- (identity 1) ; this forces a call to QUIT; in bytecode.c.
+ (identity 1) ; This forces a call to maybe_quit in bytecode.c.
(setq okay t))
(progn
(delete-region savemax (point-max))
diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el
index 7651c5d..b781cb0 100644
--- a/lisp/calendar/parse-time.el
+++ b/lisp/calendar/parse-time.el
@@ -1,4 +1,4 @@
-;;; parse-time.el --- parsing time strings
+;;; parse-time.el --- parsing time strings -*- lexical-binding: t -*-
;; Copyright (C) 1996, 2000-2017 Free Software Foundation, Inc.
@@ -203,12 +203,9 @@ any values that are unknown are returned as nil."
(time-second 2digit)
(time-secfrac "\\(\\.[0-9]+\\)?")
(time-numoffset (concat "\\([-+]\\)" time-hour ":?" time-minute "?"))
- (time-offset (concat "Z" time-numoffset))
(partial-time (concat time-hour colon time-minute colon time-second
time-secfrac))
- (full-date (concat date-fullyear dash date-month dash date-mday))
- (full-time (concat partial-time time-offset))
- (date-time (concat full-date "T" full-time)))
+ (full-date (concat date-fullyear dash date-month dash date-mday)))
(list (concat "^" full-date)
(concat "T" partial-time)
(concat "\\(Z\\|" time-numoffset "\\)")))
@@ -225,7 +222,7 @@ If DATE-STRING cannot be parsed, it falls back to
(time-re (nth 1 parse-time-iso8601-regexp))
(tz-re (nth 2 parse-time-iso8601-regexp))
re-start
- time seconds minute hour fractional-seconds
+ time seconds minute hour
day month year day-of-week dst tz)
;; We need to populate 'time' with
;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
@@ -240,9 +237,6 @@ If DATE-STRING cannot be parsed, it falls back to
(setq hour (string-to-number (match-string 1 date-string))
minute (string-to-number (match-string 2 date-string))
seconds (string-to-number (match-string 3 date-string))
- fractional-seconds (string-to-number (or
- (match-string 4
date-string)
- "0"))
re-start (match-end 0))
(when (string-match tz-re date-string re-start)
(if (string= "Z" (match-string 1 date-string))
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index a790419..51c43c7 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -511,6 +511,7 @@ since it could result in memory overflow and make Emacs
crash."
(scroll-step windows integer)
(scroll-conservatively windows integer)
(scroll-margin windows integer)
+ (maximum-scroll-margin windows float "26.1")
(hscroll-margin windows integer "22.1")
(hscroll-step windows number "22.1")
(truncate-partial-width-windows
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index cabcfcd..caa3b45 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -987,6 +987,8 @@ corresponding command.
Within CMD, %i denotes the input file(s), and %o denotes the
output file. %i path(s) are relative, while %o is absolute.")
+(declare-function format-spec "format-spec.el" (format specification))
+
;;;###autoload
(defun dired-do-compress-to ()
"Compress selected files and directories to an archive.
diff --git a/lisp/dired.el b/lisp/dired.el
index 350f6a7..2733372 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -59,6 +59,10 @@
May contain all other options that don't contradict `-l';
may contain even `F', `b', `i' and `s'. See also the variable
`dired-ls-F-marks-symlinks' concerning the `F' switch.
+Options that include embedded whitespace must be quoted
+like this: \\\"--option=value with spaces\\\"; you can use
+`combine-and-quote-strings' to produce the correct quoting of
+each option.
On systems such as MS-DOS and MS-Windows, which use `ls' emulation in Lisp,
some of the `ls' switches are not supported; see the doc string of
`insert-directory' in `ls-lisp.el' for more details."
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 2c11cd2..172ea16 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -442,6 +442,9 @@ Typically \"page-%s.png\".")
(defun doc-view-revert-buffer (&optional ignore-auto noconfirm)
"Like `revert-buffer', but preserves the buffer's current modes."
(interactive (list (not current-prefix-arg)))
+ (if (< undo-outer-limit (* 2 (buffer-size)))
+ ;; It's normal for this operation to result in a very large undo entry.
+ (setq-local undo-outer-limit (* 2 (buffer-size))))
(cl-labels ((revert ()
(let (revert-buffer-function)
(revert-buffer ignore-auto noconfirm
'preserve-modes))))
@@ -1763,6 +1766,8 @@ toggle between displaying the document or editing it as
text.
(unless doc-view-doc-type
(doc-view-set-doc-type))
(doc-view-set-up-single-converter)
+ (unless (memq doc-view-doc-type '(ps))
+ (setq-local require-final-newline nil))
(doc-view-make-safe-dir doc-view-cache-directory)
;; Handle compressed files, remote files, files inside archives
diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el
index 94c561c..bb877dd 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/emacs-lisp/backquote.el
@@ -247,4 +247,14 @@ LEVEL is only used internally and indicates the nesting
level:
tail))
(t (cons 'list heads)))))
+
+;; Give `,' and `,@' documentation strings which can be examined by C-h f.
+(put '\, 'function-documentation
+ "See `\\=`' (also `pcase') for the usage of `,'.")
+(put '\, 'reader-construct t)
+
+(put '\,@ 'function-documentation
+ "See `\\=`' for the usage of `,@'.")
+(put '\,@ 'reader-construct t)
+
;;; backquote.el ends here
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 8d141d7..6cc70c4 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -226,7 +226,13 @@ DEFAULT-BODY, if present, is used as the body of a default
method.
(when (eq 'setf (car-safe name))
(require 'gv)
(setq name (gv-setter (cadr name))))
- `(progn
+ `(prog1
+ (progn
+ (defalias ',name
+ (cl-generic-define ',name ',args ',(nreverse options))
+ ,(help-add-fundoc-usage doc args))
+ ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
+ (nreverse methods)))
,@(mapcar (lambda (declaration)
(let ((f (cdr (assq (car declaration)
defun-declarations-alist))))
@@ -235,12 +241,7 @@ DEFAULT-BODY, if present, is used as the body of a default
method.
(t (message "Warning: Unknown defun property `%S' in %S"
(car declaration) name)
nil))))
- (cdr declarations))
- (defalias ',name
- (cl-generic-define ',name ',args ',(nreverse options))
- ,(help-add-fundoc-usage doc args))
- ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
- (nreverse methods)))))
+ (cdr declarations)))))
;;;###autoload
(defun cl-generic-define (name args options)
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index b1db07f..5aa8f1b 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -413,125 +413,30 @@ Signal an error if X is not a list."
(declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store))))
(nth 9 x))
-(defun cl-caaar (x)
- "Return the `car' of the `car' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (car (car x))))
-
-(defun cl-caadr (x)
- "Return the `car' of the `car' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (car (cdr x))))
-
-(defun cl-cadar (x)
- "Return the `car' of the `cdr' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (cdr (car x))))
-
-(defun cl-caddr (x)
- "Return the `car' of the `cdr' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (cdr (cdr x))))
-
-(defun cl-cdaar (x)
- "Return the `cdr' of the `car' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (car (car x))))
-
-(defun cl-cdadr (x)
- "Return the `cdr' of the `car' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (car (cdr x))))
-
-(defun cl-cddar (x)
- "Return the `cdr' of the `cdr' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (cdr (car x))))
-
-(defun cl-cdddr (x)
- "Return the `cdr' of the `cdr' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (cdr (cdr x))))
-
-(defun cl-caaaar (x)
- "Return the `car' of the `car' of the `car' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (car (car (car x)))))
-
-(defun cl-caaadr (x)
- "Return the `car' of the `car' of the `car' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (car (car (cdr x)))))
-
-(defun cl-caadar (x)
- "Return the `car' of the `car' of the `cdr' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (car (cdr (car x)))))
-
-(defun cl-caaddr (x)
- "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (car (cdr (cdr x)))))
-
-(defun cl-cadaar (x)
- "Return the `car' of the `cdr' of the `car' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (cdr (car (car x)))))
-
-(defun cl-cadadr (x)
- "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (cdr (car (cdr x)))))
-
-(defun cl-caddar (x)
- "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (cdr (cdr (car x)))))
-
-(defun cl-cadddr (x)
- "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (car (cdr (cdr (cdr x)))))
-
-(defun cl-cdaaar (x)
- "Return the `cdr' of the `car' of the `car' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (car (car (car x)))))
-
-(defun cl-cdaadr (x)
- "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (car (car (cdr x)))))
-
-(defun cl-cdadar (x)
- "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (car (cdr (car x)))))
-
-(defun cl-cdaddr (x)
- "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (car (cdr (cdr x)))))
-
-(defun cl-cddaar (x)
- "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (cdr (car (car x)))))
-
-(defun cl-cddadr (x)
- "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (cdr (car (cdr x)))))
-
-(defun cl-cdddar (x)
- "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (cdr (cdr (car x)))))
-
-(defun cl-cddddr (x)
- "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
- (declare (compiler-macro internal--compiler-macro-cXXr))
- (cdr (cdr (cdr (cdr x)))))
+(defalias 'cl-caaar 'caaar)
+(defalias 'cl-caadr 'caadr)
+(defalias 'cl-cadar 'cadar)
+(defalias 'cl-caddr 'caddr)
+(defalias 'cl-cdaar 'cdaar)
+(defalias 'cl-cdadr 'cdadr)
+(defalias 'cl-cddar 'cddar)
+(defalias 'cl-cdddr 'cdddr)
+(defalias 'cl-caaaar 'caaaar)
+(defalias 'cl-caaadr 'caaadr)
+(defalias 'cl-caadar 'caadar)
+(defalias 'cl-caaddr 'caaddr)
+(defalias 'cl-cadaar 'cadaar)
+(defalias 'cl-cadadr 'cadadr)
+(defalias 'cl-caddar 'caddar)
+(defalias 'cl-cadddr 'cadddr)
+(defalias 'cl-cdaaar 'cdaaar)
+(defalias 'cl-cdaadr 'cdaadr)
+(defalias 'cl-cdadar 'cdadar)
+(defalias 'cl-cdaddr 'cdaddr)
+(defalias 'cl-cddaar 'cddaar)
+(defalias 'cl-cddadr 'cddadr)
+(defalias 'cl-cdddar 'cdddar)
+(defalias 'cl-cddddr 'cddddr)
;;(defun last* (x &optional n)
;; "Returns the last link in the list LIST.
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el
index e33a603..73eb9a4 100644
--- a/lisp/emacs-lisp/cl.el
+++ b/lisp/emacs-lisp/cl.el
@@ -258,30 +258,6 @@
copy-list
ldiff
list*
- cddddr
- cdddar
- cddadr
- cddaar
- cdaddr
- cdadar
- cdaadr
- cdaaar
- cadddr
- caddar
- cadadr
- cadaar
- caaddr
- caadar
- caaadr
- caaaar
- cdddr
- cddar
- cdadr
- cdaar
- caddr
- cadar
- caadr
- caaar
tenth
ninth
eighth
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index db54d1e..ec0f08d 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -112,6 +112,18 @@ and some not, use `def-edebug-spec' to specify an
`edebug-form-spec'."
:type 'boolean
:group 'edebug)
+(defcustom edebug-max-depth 150
+ "Maximum recursion depth when instrumenting code.
+This limit is intended to stop recursion if an Edebug specification
+contains an infinite loop. When Edebug is instrumenting code
+containing very large quoted lists, it may reach this limit and give
+the error message \"Too deep - perhaps infinite loop in spec?\".
+Make this limit larger to countermand that, but you may also need to
+increase `max-lisp-eval-depth' and `max-specpdl-size'."
+ :type 'integer
+ :group 'edebug
+ :version "26.1")
+
(defcustom edebug-save-windows t
"If non-nil, Edebug saves and restores the window configuration.
That takes some time, so if your program does not care what happens to
@@ -1452,7 +1464,6 @@ expressions; a `progn' form will be returned enclosing
these forms."
(defvar edebug-after-dotted-spec nil)
(defvar edebug-matching-depth 0) ;; initial value
-(defconst edebug-max-depth 150) ;; maximum number of matching recursions.
;;; Failure to match
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
index 7d99cb3..4cf9d96 100644
--- a/lisp/emacs-lisp/ert-x.el
+++ b/lisp/emacs-lisp/ert-x.el
@@ -97,7 +97,7 @@ To be used in ERT tests. If BODY finishes successfully, the
test
buffer is killed; if there is an error, the test buffer is kept
around on error for further inspection. Its name is derived from
the name of the test and the result of NAME-FORM."
- (declare (debug ((form) body))
+ (declare (debug ((":name" form) body))
(indent 1))
`(ert--call-with-test-buffer ,name-form (lambda () ,@body)))
@@ -285,6 +285,30 @@ BUFFER defaults to current buffer. Does not modify
BUFFER."
(kill-buffer clone)))))))
+(defmacro ert-with-message-capture (var &rest body)
+ "Execute BODY while collecting anything written with `message' in VAR.
+
+Capture all messages produced by `message' when it is called from
+Lisp, and concatenate them separated by newlines into one string.
+
+This is useful for separating the issuance of messages by the
+code under test from the behavior of the *Messages* buffer."
+ (declare (debug (symbolp body))
+ (indent 1))
+ (let ((g-advice (cl-gensym)))
+ `(let* ((,var "")
+ (,g-advice (lambda (func &rest args)
+ (if (or (null args) (equal (car args) ""))
+ (apply func args)
+ (let ((msg (apply #'format-message args)))
+ (setq ,var (concat ,var msg "\n"))
+ (funcall func "%s" msg))))))
+ (advice-add 'message :around ,g-advice)
+ (unwind-protect
+ (progn ,@body)
+ (advice-remove 'message ,g-advice)))))
+
+
(provide 'ert-x)
;;; ert-x.el ends here
diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el
index a45fc0a..cf82fe3 100644
--- a/lisp/emacs-lisp/let-alist.el
+++ b/lisp/emacs-lisp/let-alist.el
@@ -4,7 +4,7 @@
;; Author: Artur Malabarba <address@hidden>
;; Package-Requires: ((emacs "24.1"))
-;; Version: 1.0.4
+;; Version: 1.0.5
;; Keywords: extensions lisp
;; Prefix: let-alist
;; Separator: -
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 54678c5..46a5eed 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -89,7 +89,8 @@
(functionp &rest form)
sexp))
-(def-edebug-spec pcase-MACRO pcase--edebug-match-macro)
+;; See bug#24717
+(put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro)
;; Only called from edebug.
(declare-function get-edebug-spec "edebug" (symbol))
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 7736225..f7a8469 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -115,12 +115,16 @@ threading."
binding))
bindings)))
-(defmacro if-let (bindings then &rest else)
- "Process BINDINGS and if all values are non-nil eval THEN, else ELSE.
-Argument BINDINGS is a list of tuples whose car is a symbol to be
-bound and (optionally) used in THEN, and its cadr is a sexp to be
-evalled to set symbol's value. In the special case you only want
-to bind a single value, BINDINGS can just be a plain tuple."
+(defmacro if-let* (bindings then &rest else)
+ "Bind variables according to VARLIST and eval THEN or ELSE.
+Each binding is evaluated in turn with `let*', and evaluation
+stops if a binding value is nil. If all are non-nil, the value
+of THEN is returned, or the last form in ELSE is returned.
+Each element of VARLIST is a symbol (which is bound to nil)
+or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
+In the special case you only want to bind a single value,
+VARLIST can just be a plain tuple.
+\n(fn VARLIST THEN ELSE...)"
(declare (indent 2)
(debug ([&or (&rest (symbolp form)) (symbolp form)] form body)))
(when (and (<= (length bindings) 2)
@@ -132,15 +136,23 @@ to bind a single value, BINDINGS can just be a plain
tuple."
,then
,@else)))
-(defmacro when-let (bindings &rest body)
- "Process BINDINGS and if all values are non-nil eval BODY.
-Argument BINDINGS is a list of tuples whose car is a symbol to be
-bound and (optionally) used in BODY, and its cadr is a sexp to be
-evalled to set symbol's value. In the special case you only want
-to bind a single value, BINDINGS can just be a plain tuple."
+(defmacro when-let* (bindings &rest body)
+ "Bind variables according to VARLIST and conditionally eval BODY.
+Each binding is evaluated in turn with `let*', and evaluation
+stops if a binding value is nil. If all are non-nil, the value
+of the last form in BODY is returned.
+Each element of VARLIST is a symbol (which is bound to nil)
+or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
+In the special case you only want to bind a single value,
+VARLIST can just be a plain tuple.
+\n(fn VARLIST BODY...)"
(declare (indent 1) (debug if-let))
(list 'if-let bindings (macroexp-progn body)))
+(defalias 'if-let 'if-let*)
+(defalias 'when-let 'when-let*)
+(defalias 'and-let* 'when-let*)
+
(defsubst hash-table-empty-p (hash-table)
"Check whether HASH-TABLE is empty (has 0 elements)."
(zerop (hash-table-count hash-table)))
@@ -214,6 +226,11 @@ 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.
+
The return value is the matching entry from the CHOICES list.
Usage example:
diff --git a/lisp/emacs-lisp/tabulated-list.el
b/lisp/emacs-lisp/tabulated-list.el
index eadf79f..b6b49b1 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -412,8 +412,13 @@ of column descriptors."
(inhibit-read-only t))
(if (> tabulated-list-padding 0)
(insert (make-string x ?\s)))
- (dotimes (n ncols)
- (setq x (tabulated-list-print-col n (aref cols n) x)))
+ (let ((tabulated-list--near-rows ; Bind it if not bound yet (Bug#25506).
+ (or (bound-and-true-p tabulated-list--near-rows)
+ (list (or (tabulated-list-get-entry (point-at-bol 0))
+ cols)
+ cols))))
+ (dotimes (n ncols)
+ (setq x (tabulated-list-print-col n (aref cols n) x))))
(insert ?\n)
;; Ever so slightly faster than calling `put-text-property' twice.
(add-text-properties
diff --git a/lisp/emulation/edt-mapper.el b/lisp/emulation/edt-mapper.el
index 24a8f03..457ad55 100644
--- a/lisp/emulation/edt-mapper.el
+++ b/lisp/emulation/edt-mapper.el
@@ -57,9 +57,9 @@
;; Usage:
;; Simply load this file into emacs (version 19 or higher)
-;; using the following command.
+;; and run the function edt-mapper, using the following command.
-;; emacs -q -l edt-mapper.el
+;; emacs -q -l edt-mapper -f edt-mapper
;; The "-q" option prevents loading of your init file (commands
;; therein might confuse this program).
@@ -96,10 +96,6 @@
;;; Code:
-;; Otherwise it just hangs. This seems preferable.
-(if noninteractive
- (error "edt-mapper cannot be loaded in batch mode"))
-
;;;
;;; Decide Emacs Variant, GNU Emacs or XEmacs (aka Lucid Emacs).
;;; Determine Window System, and X Server Vendor (if appropriate).
@@ -124,6 +120,8 @@
;;;
;;; Key variables
;;;
+
+;; FIXME some/all of these should be let-bound, not global.
(defvar edt-key nil)
(defvar edt-enter nil)
(defvar edt-return nil)
@@ -137,88 +135,116 @@
(defvar edt-save-function-key-map)
;;;
-;;; Determine Terminal Type (if appropriate).
-;;;
-
-(if (and edt-window-system (not (eq edt-window-system 'tty)))
- (setq edt-term nil)
- (setq edt-term (getenv "TERM")))
-
-;;;
-;;; Implements a workaround for a feature that was added to simple.el.
-;;;
-;;; Many function keys have no Emacs functions assigned to them by
-;;; default. A subset of these are typically assigned functions in the
-;;; EDT emulation. This includes all the keypad keys and a some others
-;;; like Delete.
-;;;
-;;; Logic in simple.el maps some of these unassigned function keys to
-;;; ordinary typing keys. Where this is the case, a call to
-;;; read-key-sequence, below, does not return the name of the function
-;;; key pressed by the user but, instead, it returns the name of the
-;;; key to which it has been mapped. It needs to know the name of the
-;;; key pressed by the user. As a workaround, we assign a function to
-;;; each of the unassigned function keys of interest, here. These
-;;; assignments override the mapping to other keys and are only
-;;; temporary since, when edt-mapper is finished executing, it causes
-;;; Emacs to exit.
-;;;
-
-(mapc
- (lambda (function-key)
- (if (not (lookup-key (current-global-map) function-key))
- (define-key (current-global-map) function-key 'forward-char)))
- '([kp-0] [kp-1] [kp-2] [kp-3] [kp-4]
- [kp-5] [kp-6] [kp-7] [kp-8] [kp-9]
- [kp-space]
- [kp-tab]
- [kp-enter]
- [kp-multiply]
- [kp-add]
- [kp-separator]
- [kp-subtract]
- [kp-decimal]
- [kp-divide]
- [kp-equal]
- [backspace]
- [delete]
- [tab]
- [linefeed]
- [clear]))
-
-;;;
-;;; Make sure the window is big enough to display the instructions,
-;;; except where window cannot be re-sized.
-;;;
-
-(if (and edt-window-system (not (eq edt-window-system 'tty)))
- (set-frame-size (selected-frame) 80 36))
-
-;;;
-;;; Create buffers - Directions and Keys
+;;; Key mapping functions
;;;
-(if (not (get-buffer "Directions")) (generate-new-buffer "Directions"))
-(if (not (get-buffer "Keys")) (generate-new-buffer "Keys"))
+(defun edt-map-key (ident descrip)
+ (interactive)
+ (if (featurep 'xemacs)
+ (progn
+ (setq edt-key-seq (read-key-sequence (format "Press %s%s: " ident
descrip)))
+ (setq edt-key (concat "[" (format "%s" (event-key (aref edt-key-seq
0))) "]"))
+ (cond ((not (equal edt-key edt-return))
+ (set-buffer "Keys")
+ (insert (format " (\"%s\" . %s)\n" ident edt-key))
+ (set-buffer "Directions"))
+ ;; bogosity to get next prompt to come up, if the user hits <CR>!
+ ;; check periodically to see if this is still needed...
+ (t
+ (set-buffer "Keys")
+ (insert (format " (\"%s\" . \"\" )\n" ident))
+ (set-buffer "Directions"))))
+ (setq edt-key (read-key-sequence (format "Press %s%s: " ident descrip)))
+ (cond ((not (equal edt-key edt-return))
+ (set-buffer "Keys")
+ (insert (if (vectorp edt-key)
+ (format " (\"%s\" . %s)\n" ident edt-key)
+ (format " (\"%s\" . \"%s\")\n" ident edt-key)))
+ (set-buffer "Directions"))
+ ;; bogosity to get next prompt to come up, if the user hits <CR>!
+ ;; check periodically to see if this is still needed...
+ (t
+ (set-buffer "Keys")
+ (insert (format " (\"%s\" . \"\" )\n" ident))
+ (set-buffer "Directions"))))
+ edt-key)
-;;;
-;;; Put header in the Keys buffer
-;;;
-(set-buffer "Keys")
-(insert "\
+(defun edt-mapper ()
+ (if noninteractive
+ (user-error "edt-mapper cannot be loaded in batch mode"))
+ ;; Determine Terminal Type (if appropriate).
+ (if (and edt-window-system (not (eq edt-window-system 'tty)))
+ (setq edt-term nil)
+ (setq edt-term (getenv "TERM")))
+ ;;
+ ;; Implements a workaround for a feature that was added to simple.el.
+ ;;
+ ;; Many function keys have no Emacs functions assigned to them by
+ ;; default. A subset of these are typically assigned functions in the
+ ;; EDT emulation. This includes all the keypad keys and a some others
+ ;; like Delete.
+ ;;
+ ;; Logic in simple.el maps some of these unassigned function keys to
+ ;; ordinary typing keys. Where this is the case, a call to
+ ;; read-key-sequence, below, does not return the name of the function
+ ;; key pressed by the user but, instead, it returns the name of the
+ ;; key to which it has been mapped. It needs to know the name of the
+ ;; key pressed by the user. As a workaround, we assign a function to
+ ;; each of the unassigned function keys of interest, here. These
+ ;; assignments override the mapping to other keys and are only
+ ;; temporary since, when edt-mapper is finished executing, it causes
+ ;; Emacs to exit.
+ ;;
+ (mapc
+ (lambda (function-key)
+ (if (not (lookup-key (current-global-map) function-key))
+ (define-key (current-global-map) function-key 'forward-char)))
+ '([kp-0] [kp-1] [kp-2] [kp-3] [kp-4]
+ [kp-5] [kp-6] [kp-7] [kp-8] [kp-9]
+ [kp-space]
+ [kp-tab]
+ [kp-enter]
+ [kp-multiply]
+ [kp-add]
+ [kp-separator]
+ [kp-subtract]
+ [kp-decimal]
+ [kp-divide]
+ [kp-equal]
+ [backspace]
+ [delete]
+ [tab]
+ [linefeed]
+ [clear]))
+ ;;
+ ;; Make sure the window is big enough to display the instructions,
+ ;; except where window cannot be re-sized.
+ ;;
+ (if (and edt-window-system (not (eq edt-window-system 'tty)))
+ (set-frame-size (selected-frame) 80 36))
+ ;;
+ ;; Create buffers - Directions and Keys
+ ;;
+ (if (not (get-buffer "Directions")) (generate-new-buffer "Directions"))
+ (if (not (get-buffer "Keys")) (generate-new-buffer "Keys"))
+ ;;
+ ;; Put header in the Keys buffer
+ ;;
+ (set-buffer "Keys")
+ (insert "\
;;
;; Key definitions for the EDT emulation within GNU Emacs
;;
-(defconst *EDT-keys*
+\(defconst *EDT-keys*
'(
-")
-
-;;;
-;;; Display directions
-;;;
-(switch-to-buffer "Directions")
-(if (and edt-window-system (not (eq edt-window-system 'tty)))
- (insert "
+ ")
+
+ ;;
+ ;; Display directions
+ ;;
+ (switch-to-buffer "Directions")
+ (if (and edt-window-system (not (eq edt-window-system 'tty)))
+ (insert "
EDT MAPPER
You will be asked to press keys to create a custom mapping (under a
@@ -240,7 +266,7 @@
just press RETURN at the prompt.
")
- (insert "
+ (insert "
EDT MAPPER
You will be asked to press keys to create a custom mapping of your
@@ -259,39 +285,39 @@
"))
-(delete-other-windows)
-
-;;;
-;;; Save <CR> for future reference.
-;;;
-;;; For GNU Emacs, running in a Window System, first hide bindings in
-;;; function-key-map.
-;;;
-(cond
- ((featurep 'xemacs)
- (setq edt-return-seq (read-key-sequence "Hit carriage-return <CR> to
continue "))
- (setq edt-return (concat "[" (format "%s" (event-key (aref edt-return-seq
0))) "]")))
- (t
- (if edt-window-system
- (progn
- (setq edt-save-function-key-map function-key-map)
- (setq function-key-map (make-sparse-keymap))))
- (setq edt-return (read-key-sequence "Hit carriage-return <CR> to continue
"))))
-
-;;;
-;;; Remove prefix-key bindings to F1 and F2 in global-map so they can be
-;;; bound in the EDT Emulation mode.
-;;;
-(global-unset-key [f1])
-(global-unset-key [f2])
-
-;;;
-;;; Display Keypad Diagram and Begin Prompting for Keys
-;;;
-(set-buffer "Directions")
-(delete-region (point-min) (point-max))
-(if (and edt-window-system (not (eq edt-window-system 'tty)))
- (insert "
+ (delete-other-windows)
+
+ ;;
+ ;; Save <CR> for future reference.
+ ;;
+ ;; For GNU Emacs, running in a Window System, first hide bindings in
+ ;; function-key-map.
+ ;;
+ (cond
+ ((featurep 'xemacs)
+ (setq edt-return-seq (read-key-sequence "Hit carriage-return <CR> to
continue "))
+ (setq edt-return (concat "[" (format "%s" (event-key (aref edt-return-seq
0))) "]")))
+ (t
+ (if edt-window-system
+ (progn
+ (setq edt-save-function-key-map function-key-map)
+ (setq function-key-map (make-sparse-keymap))))
+ (setq edt-return (read-key-sequence "Hit carriage-return <CR> to continue
"))))
+
+ ;;
+ ;; Remove prefix-key bindings to F1 and F2 in global-map so they can be
+ ;; bound in the EDT Emulation mode.
+ ;;
+ (global-unset-key [f1])
+ (global-unset-key [f2])
+
+ ;;
+ ;; Display Keypad Diagram and Begin Prompting for Keys
+ ;;
+ (set-buffer "Directions")
+ (delete-region (point-min) (point-max))
+ (if (and edt-window-system (not (eq edt-window-system 'tty)))
+ (insert "
PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW.
@@ -321,11 +347,11 @@
REMEMBER: JUST PRESS RETURN TO SKIP MAPPING A KEY.
")
- (progn
- (insert "
+ (progn
+ (insert "
GENERATING A CUSTOM CONFIGURATION FILE FOR TERMINAL TYPE: ")
- (insert (format "%s." edt-term))
- (insert "
+ (insert (format "%s." edt-term))
+ (insert "
PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW.
@@ -347,142 +373,109 @@
REMEMBER: JUST PRESS RETURN TO SKIP MAPPING A KEY.")))
-;;;
-;;; Key mapping functions
-;;;
-(defun edt-map-key (ident descrip)
- (interactive)
- (if (featurep 'xemacs)
- (progn
- (setq edt-key-seq (read-key-sequence (format "Press %s%s: " ident
descrip)))
- (setq edt-key (concat "[" (format "%s" (event-key (aref edt-key-seq
0))) "]"))
- (cond ((not (equal edt-key edt-return))
- (set-buffer "Keys")
- (insert (format " (\"%s\" . %s)\n" ident edt-key))
- (set-buffer "Directions"))
- ;; bogosity to get next prompt to come up, if the user hits <CR>!
- ;; check periodically to see if this is still needed...
- (t
- (set-buffer "Keys")
- (insert (format " (\"%s\" . \"\" )\n" ident))
- (set-buffer "Directions"))))
- (setq edt-key (read-key-sequence (format "Press %s%s: " ident descrip)))
- (cond ((not (equal edt-key edt-return))
- (set-buffer "Keys")
- (insert (if (vectorp edt-key)
- (format " (\"%s\" . %s)\n" ident edt-key)
- (format " (\"%s\" . \"%s\")\n" ident edt-key)))
- (set-buffer "Directions"))
- ;; bogosity to get next prompt to come up, if the user hits <CR>!
- ;; check periodically to see if this is still needed...
- (t
- (set-buffer "Keys")
- (insert (format " (\"%s\" . \"\" )\n" ident))
- (set-buffer "Directions"))))
- edt-key)
-(set-buffer "Keys")
-(insert "
+ (set-buffer "Keys")
+ (insert "
;;
;; Arrows
;;
")
-(set-buffer "Directions")
+ (set-buffer "Directions")
-(edt-map-key "UP" " - The Up Arrow Key")
-(edt-map-key "DOWN" " - The Down Arrow Key")
-(edt-map-key "LEFT" " - The Left Arrow Key")
-(edt-map-key "RIGHT" " - The Right Arrow Key")
+ (edt-map-key "UP" " - The Up Arrow Key")
+ (edt-map-key "DOWN" " - The Down Arrow Key")
+ (edt-map-key "LEFT" " - The Left Arrow Key")
+ (edt-map-key "RIGHT" " - The Right Arrow Key")
-(set-buffer "Keys")
-(insert "
+ (set-buffer "Keys")
+ (insert "
;;
;; PF keys
;;
")
-(set-buffer "Directions")
+ (set-buffer "Directions")
-(edt-map-key "PF1" " - The PF1 (GOLD) Key")
-(edt-map-key "PF2" " - The Keypad PF2 Key")
-(edt-map-key "PF3" " - The Keypad PF3 Key")
-(edt-map-key "PF4" " - The Keypad PF4 Key")
+ (edt-map-key "PF1" " - The PF1 (GOLD) Key")
+ (edt-map-key "PF2" " - The Keypad PF2 Key")
+ (edt-map-key "PF3" " - The Keypad PF3 Key")
+ (edt-map-key "PF4" " - The Keypad PF4 Key")
-(set-buffer "Keys")
-(insert "
+ (set-buffer "Keys")
+ (insert "
;;
;; KP0-9 KP- KP, KPP and KPE
;;
")
-(set-buffer "Directions")
-
-(edt-map-key "KP0" " - The Keypad 0 Key")
-(edt-map-key "KP1" " - The Keypad 1 Key")
-(edt-map-key "KP2" " - The Keypad 2 Key")
-(edt-map-key "KP3" " - The Keypad 3 Key")
-(edt-map-key "KP4" " - The Keypad 4 Key")
-(edt-map-key "KP5" " - The Keypad 5 Key")
-(edt-map-key "KP6" " - The Keypad 6 Key")
-(edt-map-key "KP7" " - The Keypad 7 Key")
-(edt-map-key "KP8" " - The Keypad 8 Key")
-(edt-map-key "KP9" " - The Keypad 9 Key")
-(edt-map-key "KP-" " - The Keypad - Key")
-(edt-map-key "KP," " - The Keypad , Key")
-(edt-map-key "KPP" " - The Keypad . Key")
-(edt-map-key "KPE" " - The Keypad Enter Key")
-;; Save the enter key
-(setq edt-enter edt-key)
-(setq edt-enter-seq edt-key-seq)
-
-
-(set-buffer "Keys")
-(insert "
+ (set-buffer "Directions")
+
+ (edt-map-key "KP0" " - The Keypad 0 Key")
+ (edt-map-key "KP1" " - The Keypad 1 Key")
+ (edt-map-key "KP2" " - The Keypad 2 Key")
+ (edt-map-key "KP3" " - The Keypad 3 Key")
+ (edt-map-key "KP4" " - The Keypad 4 Key")
+ (edt-map-key "KP5" " - The Keypad 5 Key")
+ (edt-map-key "KP6" " - The Keypad 6 Key")
+ (edt-map-key "KP7" " - The Keypad 7 Key")
+ (edt-map-key "KP8" " - The Keypad 8 Key")
+ (edt-map-key "KP9" " - The Keypad 9 Key")
+ (edt-map-key "KP-" " - The Keypad - Key")
+ (edt-map-key "KP," " - The Keypad , Key")
+ (edt-map-key "KPP" " - The Keypad . Key")
+ (edt-map-key "KPE" " - The Keypad Enter Key")
+ ;; Save the enter key
+ (setq edt-enter edt-key)
+ (setq edt-enter-seq edt-key-seq)
+
+
+ (set-buffer "Keys")
+ (insert "
;;
;; Editing keypad (FIND, INSERT, REMOVE)
;; (SELECT, PREVIOUS, NEXT)
;;
")
-(set-buffer "Directions")
+ (set-buffer "Directions")
-(edt-map-key "FIND" " - The Find key on the editing keypad")
-(edt-map-key "INSERT" " - The Insert key on the editing keypad")
-(edt-map-key "REMOVE" " - The Remove key on the editing keypad")
-(edt-map-key "SELECT" " - The Select key on the editing keypad")
-(edt-map-key "PREVIOUS" " - The Prev Scr key on the editing keypad")
-(edt-map-key "NEXT" " - The Next Scr key on the editing keypad")
+ (edt-map-key "FIND" " - The Find key on the editing keypad")
+ (edt-map-key "INSERT" " - The Insert key on the editing keypad")
+ (edt-map-key "REMOVE" " - The Remove key on the editing keypad")
+ (edt-map-key "SELECT" " - The Select key on the editing keypad")
+ (edt-map-key "PREVIOUS" " - The Prev Scr key on the editing keypad")
+ (edt-map-key "NEXT" " - The Next Scr key on the editing keypad")
-(set-buffer "Keys")
-(insert "
+ (set-buffer "Keys")
+ (insert "
;;
;; F1-14 Help Do F17-F20
;;
")
-(set-buffer "Directions")
-
-(edt-map-key "F1" " - F1 Function Key")
-(edt-map-key "F2" " - F2 Function Key")
-(edt-map-key "F3" " - F3 Function Key")
-(edt-map-key "F4" " - F4 Function Key")
-(edt-map-key "F5" " - F5 Function Key")
-(edt-map-key "F6" " - F6 Function Key")
-(edt-map-key "F7" " - F7 Function Key")
-(edt-map-key "F8" " - F8 Function Key")
-(edt-map-key "F9" " - F9 Function Key")
-(edt-map-key "F10" " - F10 Function Key")
-(edt-map-key "F11" " - F11 Function Key")
-(edt-map-key "F12" " - F12 Function Key")
-(edt-map-key "F13" " - F13 Function Key")
-(edt-map-key "F14" " - F14 Function Key")
-(edt-map-key "HELP" " - HELP Function Key")
-(edt-map-key "DO" " - DO Function Key")
-(edt-map-key "F17" " - F17 Function Key")
-(edt-map-key "F18" " - F18 Function Key")
-(edt-map-key "F19" " - F19 Function Key")
-(edt-map-key "F20" " - F20 Function Key")
-
-(set-buffer "Directions")
-(delete-region (point-min) (point-max))
-(insert "
+ (set-buffer "Directions")
+
+ (edt-map-key "F1" " - F1 Function Key")
+ (edt-map-key "F2" " - F2 Function Key")
+ (edt-map-key "F3" " - F3 Function Key")
+ (edt-map-key "F4" " - F4 Function Key")
+ (edt-map-key "F5" " - F5 Function Key")
+ (edt-map-key "F6" " - F6 Function Key")
+ (edt-map-key "F7" " - F7 Function Key")
+ (edt-map-key "F8" " - F8 Function Key")
+ (edt-map-key "F9" " - F9 Function Key")
+ (edt-map-key "F10" " - F10 Function Key")
+ (edt-map-key "F11" " - F11 Function Key")
+ (edt-map-key "F12" " - F12 Function Key")
+ (edt-map-key "F13" " - F13 Function Key")
+ (edt-map-key "F14" " - F14 Function Key")
+ (edt-map-key "HELP" " - HELP Function Key")
+ (edt-map-key "DO" " - DO Function Key")
+ (edt-map-key "F17" " - F17 Function Key")
+ (edt-map-key "F18" " - F18 Function Key")
+ (edt-map-key "F19" " - F19 Function Key")
+ (edt-map-key "F20" " - F20 Function Key")
+
+ (set-buffer "Directions")
+ (delete-region (point-min) (point-max))
+ (insert "
ADDITIONAL FUNCTION KEYS
Your keyboard may have additional function keys which do not correspond
@@ -501,53 +494,53 @@
When you are done, just press RETURN at the \"EDT Key Name:\" prompt.
")
-(switch-to-buffer "Directions")
-;;;
-;;; Add support for extras keys
-;;;
-(set-buffer "Keys")
-(insert "\
+ (switch-to-buffer "Directions")
+ ;;
+ ;; Add support for extras keys
+ ;;
+ (set-buffer "Keys")
+ (insert "\
;;
;; Extra Keys
;;
")
-;;;
-;;; Restore function-key-map.
-;;;
-(if (and edt-window-system (not (featurep 'xemacs)))
- (setq function-key-map edt-save-function-key-map))
-(setq EDT-key-name "")
-(while (not
- (string-equal (setq EDT-key-name (read-string "EDT Key Name: ")) ""))
- (edt-map-key EDT-key-name ""))
-
-;
-; No more keys to add, so wrap up.
-;
-(set-buffer "Keys")
-(insert "\
+ ;;
+ ;; Restore function-key-map.
+ ;;
+ (if (and edt-window-system (not (featurep 'xemacs)))
+ (setq function-key-map edt-save-function-key-map))
+ (setq EDT-key-name "")
+ (while (not
+ (string-equal (setq EDT-key-name (read-string "EDT Key Name: ")) ""))
+ (edt-map-key EDT-key-name ""))
+
+ ;;
+ ;; No more keys to add, so wrap up.
+ ;;
+ (set-buffer "Keys")
+ (insert "\
)
)
")
-;;;
-;;; Save the key mapping program
-;;;
-;;;
-;;; Save the key mapping file
-;;;
-(let ((file (concat
- "~/.edt-" (if (featurep 'xemacs) "xemacs" "gnu")
- (if edt-term (concat "-" edt-term))
- (if edt-xserver (concat "-" edt-xserver))
- (if edt-window-system (concat "-" (upcase (symbol-name
edt-window-system))))
- "-keys")))
- (set-visited-file-name
- (read-file-name (format "Save key mapping to file (default %s): " file) nil
file)))
-(save-buffer)
-
-(message "That's it! Press any key to exit")
-(sit-for 600)
-(kill-emacs t)
+ ;;
+ ;; Save the key mapping program
+ ;;
+ ;;
+ ;; Save the key mapping file
+ ;;
+ (let ((file (concat
+ "~/.edt-" (if (featurep 'xemacs) "xemacs" "gnu")
+ (if edt-term (concat "-" edt-term))
+ (if edt-xserver (concat "-" edt-xserver))
+ (if edt-window-system (concat "-" (upcase (symbol-name
edt-window-system))))
+ "-keys")))
+ (set-visited-file-name
+ (read-file-name (format "Save key mapping to file (default %s): " file)
nil file)))
+ (save-buffer)
+
+ (message "That's it! Press any key to exit")
+ (sit-for 600)
+ (kill-emacs t))
;;; edt-mapper.el ends here
diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el
index 31f555b..a6b2d78 100644
--- a/lisp/emulation/edt.el
+++ b/lisp/emulation/edt.el
@@ -1928,6 +1928,8 @@ Optional argument NOT-YES changes the default to
negative."
;;; INITIALIZATION COMMANDS.
;;;
+(declare-function edt-mapper "edt-mapper" ())
+
;;;
;;; Function used to load LK-201 key mapping file generated by edt-mapper.el.
;;;
@@ -1968,7 +1970,7 @@ created."
You can do this by quitting Emacs and then invoking Emacs again as
follows:
- emacs -q -l edt-mapper
+ emacs -q -l edt-mapper -f edt-mapper
[NOTE: If you do nothing out of the ordinary in your init file, and
the search for edt-mapper is successful, you can try running it now.]
@@ -1983,7 +1985,9 @@ created."
(insert (format
"Ah yes, there it is, in \n\n %s \n\n" path))
(if (edt-y-or-n-p "Do you want to run it now? ")
- (load-file path)
+ (progn
+ (load-file path)
+ (edt-mapper))
(error "EDT Emulation not configured")))
(insert (substitute-command-keys
"Nope, I can't seem to find it. :-(\n\n"))
diff --git a/lisp/files.el b/lisp/files.el
index f60282b..b7d1048 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -3723,7 +3723,8 @@ Return the new variables list."
(let* ((file-name (or (buffer-file-name)
;; Handle non-file buffers, too.
(expand-file-name default-directory)))
- (sub-file-name (if file-name
+ (sub-file-name (if (and file-name
+ (file-name-absolute-p file-name))
;; FIXME: Why not use file-relative-name?
(substring file-name (length root)))))
(condition-case err
@@ -5133,6 +5134,14 @@ Before and after saving the buffer, this function runs
"Non-nil means `save-some-buffers' should save this buffer without asking.")
(make-variable-buffer-local 'buffer-save-without-query)
+(defcustom save-some-buffers-default-predicate nil
+ "Default predicate for `save-some-buffers'.
+This allows you to stop `save-some-buffers' from asking
+about certain files that you'd usually rather not save."
+ :group 'auto-save
+ :type 'function
+ :version "26.1")
+
(defun save-some-buffers (&optional arg pred)
"Save some modified file-visiting buffers. Asks user about each one.
You can answer `y' to save, `n' not to save, `C-r' to look at the
@@ -5148,10 +5157,13 @@ If PRED is nil, all the file-visiting buffers are
considered.
If PRED is t, then certain non-file buffers will also be considered.
If PRED is a zero-argument function, it indicates for each buffer whether
to consider it or not when called with that buffer current.
+PRED defaults to the value of `save-some-buffers-default-predicate'.
See `save-some-buffers-action-alist' if you want to
change the additional actions you can take on files."
(interactive "P")
+ (unless pred
+ (setq pred save-some-buffers-default-predicate))
(save-window-excursion
(let* (queried autosaved-buffers
files-done abbrevs-done)
@@ -6571,7 +6583,7 @@ normally equivalent short `-D' option is just passed on to
(unless (equal switches "")
;; Split the switches at any spaces so we can
;; pass separate options as separate args.
- (split-string switches)))
+ (split-string-and-unquote switches)))
;; Avoid lossage if FILE starts with `-'.
'("--")
(progn
@@ -6811,6 +6823,8 @@ asks whether processes should be killed.
Runs the members of `kill-emacs-query-functions' in turn and stops
if any returns nil. If `confirm-kill-emacs' is non-nil, calls it."
(interactive "P")
+ ;; Don't use save-some-buffers-default-predicate, because we want
+ ;; to ask about all the buffers before killing Emacs.
(save-some-buffers arg t)
(let ((confirm confirm-kill-emacs))
(and
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index e1af859..a4ff840 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -251,7 +251,12 @@ This can also be a list of the above values."
(integer :value 200)
(number :value 4.0)
function
- (regexp :value ".*"))
+ (regexp :value ".*")
+ (repeat (choice (const nil)
+ (integer :value 200)
+ (number :value 4.0)
+ function
+ (regexp :value ".*"))))
:group 'gnus-article-signature)
(defcustom gnus-hidden-properties
@@ -1708,9 +1713,10 @@ regexp."
;; (modify-syntax-entry ?- "w" table)
(modify-syntax-entry ?> ")<" table)
(modify-syntax-entry ?< "(>" table)
- ;; make M-. in article buffers work for `foo' strings
- (modify-syntax-entry ?' " " table)
- (modify-syntax-entry ?` " " table)
+ ;; make M-. in article buffers work for `foo' strings,
+ ;; and still allow C-s C-w to yank ' to the search ring
+ (modify-syntax-entry ?' "'" table)
+ (modify-syntax-entry ?` "'" table)
table)
"Syntax table used in article mode buffers.
Initialized from `text-mode-syntax-table'.")
@@ -6841,17 +6847,21 @@ then we display only bindings that start with that
prefix."
(let ((keymap (copy-keymap gnus-article-mode-map))
(map (copy-keymap gnus-article-send-map))
(sumkeys (where-is-internal 'gnus-article-read-summary-keys))
+ (summap (make-sparse-keymap))
parent agent draft)
(define-key keymap "S" map)
(define-key map [t] nil)
+ (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))))
(set-keymap-parent
keymap
(if (setq parent (keymap-parent gnus-article-mode-map))
(prog1
(setq parent (copy-keymap parent))
- (set-keymap-parent parent (current-local-map)))
- (current-local-map)))
+ (set-keymap-parent parent summap))
+ summap))
(set-keymap-parent map (key-binding "S"))
(let (key def gnus-pick-mode)
(while sumkeys
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index 1911117..a193ab4 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -546,7 +546,8 @@ instead."
(gnus-setup-message 'message
(message-mail to subject other-headers continue
nil yank-action send-actions return-action)))
- (setq gnus-newsgroup-name group-name))
+ (with-current-buffer buf
+ (setq gnus-newsgroup-name group-name)))
(when switch-action
(setq mail-buf (current-buffer))
(switch-to-buffer buf)
@@ -1534,11 +1535,7 @@ If YANK is non-nil, include the original article."
(message-pop-to-buffer "*Gnus Bug*"))
(let ((message-this-is-mail t))
(message-setup `((To . ,gnus-maintainer)
- (Subject . "")
- (X-Debbugs-Package
- . ,(format "%s" gnus-bug-package))
- (X-Debbugs-Version
- . ,(format "%s" (gnus-continuum-version))))))
+ (Subject . ""))))
(when gnus-bug-create-help-buffer
(push `(gnus-bug-kill-buffer) message-send-actions))
(goto-char (point-min))
diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el
index 5361c2b..7037328 100644
--- a/lisp/gnus/gnus-salt.el
+++ b/lisp/gnus/gnus-salt.el
@@ -131,9 +131,7 @@ It accepts the same format specs that
`gnus-summary-line-format' does."
(defvar gnus-pick-line-number 1)
(defun gnus-pick-line-number ()
"Return the current line number."
- (if (bobp)
- (setq gnus-pick-line-number 1)
- (incf gnus-pick-line-number)))
+ (incf gnus-pick-line-number))
(defun gnus-pick-start-reading (&optional catch-up)
"Start reading the picked articles.
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index 47e33af..be46339 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -2801,8 +2801,13 @@ If FORCE is non-nil, the .newsrc file is read."
(gnus-run-hooks 'gnus-save-newsrc-hook)
(if gnus-slave
(gnus-slave-save-newsrc)
- ;; Save .newsrc.
- (when gnus-save-newsrc-file
+ ;; Save .newsrc only if the select method is an NNTP method.
+ ;; The .newsrc file is for interoperability with other
+ ;; newsreaders, so saving non-NNTP groups there doesn't make
+ ;; much sense.
+ (when (and gnus-save-newsrc-file
+ (eq (car (gnus-server-to-method gnus-select-method))
+ 'nntp))
(gnus-message 8 "Saving %s..." gnus-current-startup-file)
(gnus-gnus-to-newsrc-format)
(gnus-message 8 "Saving %s...done" gnus-current-startup-file))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 72e902a..2631514 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -1895,6 +1895,7 @@ increase the score of each group you read."
"\C-c\C-s\C-m\C-n" gnus-summary-sort-by-most-recent-number
"\C-c\C-s\C-l" gnus-summary-sort-by-lines
"\C-c\C-s\C-c" gnus-summary-sort-by-chars
+ "\C-c\C-s\C-m\C-m" gnus-summary-sort-by-marks
"\C-c\C-s\C-a" gnus-summary-sort-by-author
"\C-c\C-s\C-t" gnus-summary-sort-by-recipient
"\C-c\C-s\C-s" gnus-summary-sort-by-subject
@@ -2748,6 +2749,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Sort by score" gnus-summary-sort-by-score t]
["Sort by lines" gnus-summary-sort-by-lines t]
["Sort by characters" gnus-summary-sort-by-chars t]
+ ["Sort by marks" gnus-summary-sort-by-marks t]
["Randomize" gnus-summary-sort-by-random t]
["Original sort" gnus-summary-sort-by-original t])
("Help"
@@ -3976,6 +3978,8 @@ If SELECT-ARTICLES, only select those articles from
GROUP."
;; The group was successfully selected.
(t
(gnus-set-global-variables)
+ (when (boundp 'gnus-pick-line-number)
+ (setq gnus-pick-line-number 0))
(when (boundp 'spam-install-hooks)
(spam-initialize))
;; Save the active value in effect when the group was entered.
@@ -4037,6 +4041,9 @@ If SELECT-ARTICLES, only select those articles from
GROUP."
(when kill-buffer
(gnus-kill-or-deaden-summary kill-buffer))
(gnus-summary-auto-select-subject)
+ ;; Don't mark any articles as selected if we haven't done that.
+ (when no-article
+ (setq overlay-arrow-position nil))
;; Show first unread article if requested.
(if (and (not no-article)
(not no-display)
@@ -4941,6 +4948,16 @@ using some other form will lead to serious barfage."
(gnus-article-sort-by-chars
(gnus-thread-header h1) (gnus-thread-header h2)))
+(defsubst gnus-article-sort-by-marks (h1 h2)
+ "Sort articles by octet length."
+ (< (gnus-article-mark (mail-header-number h1))
+ (gnus-article-mark (mail-header-number h2))))
+
+(defun gnus-thread-sort-by-marks (h1 h2)
+ "Sort threads by root article octet length."
+ (gnus-article-sort-by-marks
+ (gnus-thread-header h1) (gnus-thread-header h2)))
+
(defsubst gnus-article-sort-by-author (h1 h2)
"Sort articles by root author."
(gnus-string<
@@ -11925,6 +11942,12 @@ Argument REVERSE means reverse order."
(interactive "P")
(gnus-summary-sort 'chars reverse))
+(defun gnus-summary-sort-by-mark (&optional reverse)
+ "Sort the summary buffer by article marks.
+Argument REVERSE means reverse order."
+ (interactive "P")
+ (gnus-summary-sort 'marks reverse))
+
(defun gnus-summary-sort-by-original (&optional reverse)
"Sort the summary buffer using the default sorting method.
Argument REVERSE means reverse order."
@@ -11970,7 +11993,10 @@ save those articles instead.
The variable `gnus-default-article-saver' specifies the saver function.
If the optional second argument NOT-SAVED is non-nil, articles saved
-will not be marked as saved."
+will not be marked as saved.
+
+The `gnus-prompt-before-saving' variable says how prompting is
+performed."
(interactive "P")
(require 'gnus-art)
(let* ((articles (gnus-summary-work-articles n))
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index 8ab8f46..6d6e20d 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -1564,7 +1564,7 @@ If UNINDENT, remove an indentation."
(parent (gnus-topic-parent-topic topic))
(grandparent (gnus-topic-parent-topic parent)))
(unless grandparent
- (error "Nothing to indent %s into" topic))
+ (error "Can't unindent %s further" topic))
(when topic
(gnus-topic-goto-topic topic)
(gnus-topic-kill-group)
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index ef6bd89..bbf85fe 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -2654,10 +2654,6 @@ such as a mark that says whether an article is stored in
the cache
"address@hidden (The Gnus Bugfixing Girls + Boys)"
"The mail address of the Gnus maintainers.")
-(defconst gnus-bug-package
- "gnus"
- "The package to use in the bug submission.")
-
(defvar gnus-info-nodes
'((gnus-group-mode "(gnus)Group Buffer")
(gnus-summary-mode "(gnus)Summary Buffer")
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 4d4ba08..ce0dad9 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -2286,13 +2286,15 @@ body, set `message-archive-note' to nil."
"Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
With prefix-argument just set Follow-Up, don't cross-post."
(interactive
- (list ; Completion based on Gnus
- (completing-read "Followup To: "
- (if (boundp 'gnus-newsrc-alist)
- gnus-newsrc-alist)
- nil nil '("poster" . 0)
- (if (boundp 'gnus-group-history)
- 'gnus-group-history))))
+ (list ; Completion based on Gnus
+ (replace-regexp-in-string
+ "\\`.*:" ""
+ (completing-read "Followup To: "
+ (if (boundp 'gnus-newsrc-alist)
+ gnus-newsrc-alist)
+ nil nil '("poster" . 0)
+ (if (boundp 'gnus-group-history)
+ 'gnus-group-history)))))
(message-remove-header "Follow[Uu]p-[Tt]o" t)
(message-goto-newsgroups)
(beginning-of-line)
@@ -2361,13 +2363,15 @@ been made to before the user asked for a Crosspost."
"Crossposts message and set Followup-To to TARGET-GROUP.
With prefix-argument just set Follow-Up, don't cross-post."
(interactive
- (list ; Completion based on Gnus
- (completing-read "Followup To: "
- (if (boundp 'gnus-newsrc-alist)
- gnus-newsrc-alist)
- nil nil '("poster" . 0)
- (if (boundp 'gnus-group-history)
- 'gnus-group-history))))
+ (list ; Completion based on Gnus
+ (replace-regexp-in-string
+ "\\`.*:" ""
+ (completing-read "Followup To: "
+ (if (boundp 'gnus-newsrc-alist)
+ gnus-newsrc-alist)
+ nil nil '("poster" . 0)
+ (if (boundp 'gnus-group-history)
+ 'gnus-group-history)))))
(when (fboundp 'gnus-group-real-name)
(setq target-group (gnus-group-real-name target-group)))
(cond ((not (or (null target-group) ; new subject not empty
@@ -3108,18 +3112,29 @@ M-RET `message-newline-and-reformat' (break the line
and reformat)."
(looking-at "[ \t]*\n"))
(expand-abbrev))
(push-mark)
+ (message-goto-body-1))
+
+(defun message-goto-body-1 ()
+ "Go to the body and return point."
(goto-char (point-min))
(or (search-forward (concat "\n" mail-header-separator "\n") nil t)
- (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
+ ;; If the message is mangled, find the end of the headers the
+ ;; hard way.
+ (progn
+ ;; Skip past all headers and continuation lines.
+ (while (looking-at "[^:]+:\\|[\t ]+[^\t ]")
+ (forward-line 1))
+ ;; We're now at the first empty line, so perhaps move past it.
+ (when (and (eolp)
+ (not (eobp)))
+ (forward-line 1))
+ (point))))
(defun message-in-body-p ()
"Return t if point is in the message body."
(>= (point)
(save-excursion
- (goto-char (point-min))
- (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
- (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))
- (point))))
+ (message-goto-body-1))))
(defun message-goto-eoh ()
"Move point to the end of the headers."
@@ -3330,6 +3345,8 @@ of lines before the signature intact."
"Insert four newlines, and then reformat if inside quoted text.
Prefix arg means justify as well."
(interactive (list (if current-prefix-arg 'full)))
+ (unless (message-in-body-p)
+ (error "This command only works in the body of the message"))
(let (quoted point beg end leading-space bolp fill-paragraph-function)
(setq point (point))
(beginning-of-line)
@@ -4102,8 +4119,8 @@ It should typically alter the sending method in some way
or other."
(let ((inhibit-read-only t))
(put-text-property (point-min) (point-max) 'read-only nil))
(message-fix-before-sending)
- (mml-secure-bcc-is-safe)
(run-hooks 'message-send-hook)
+ (mml-secure-bcc-is-safe)
(when message-confirm-send
(or (y-or-n-p "Send message? ")
(keyboard-quit)))
@@ -4539,6 +4556,9 @@ This function could be useful in `message-setup-hook'."
(forward-line 1)
(unless (y-or-n-p "Send anyway? ")
(error "Failed to send the message")))))
+ ;; Fold too-long header lines. They should be no longer than
+ ;; 998 octets long.
+ (message--fold-long-headers)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
(setq options message-options)
@@ -4635,6 +4655,14 @@ If you always want Gnus to send messages in one piece,
set
(setq message-options options)
(push 'mail message-sent-message-via)))
+(defun message--fold-long-headers ()
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (and (looking-at "[^:]+:")
+ (> (- (line-end-position) (point)) 998))
+ (mail-header-fold-field))
+ (forward-line 1)))
+
(defvar sendmail-program)
(defvar smtpmail-smtp-server)
(defvar smtpmail-smtp-service)
@@ -5380,16 +5408,13 @@ Otherwise, generate and save a value for
`canlock-password' first."
"Process Fcc headers in the current buffer."
(let ((case-fold-search t)
(buf (current-buffer))
- list file
- (mml-externalize-attachments message-fcc-externalize-attachments))
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (setq file (message-fetch-field "fcc" t)))
- (when file
- (set-buffer (get-buffer-create " *message temp*"))
- (erase-buffer)
+ (mml-externalize-attachments message-fcc-externalize-attachments)
+ (file (message-field-value "fcc" t))
+ list)
+ (when file
+ (with-temp-buffer
(insert-buffer-substring buf)
+ (message-clone-locals buf)
(message-encode-message-body)
(save-restriction
(message-narrow-to-headers)
@@ -5429,8 +5454,7 @@ Otherwise, generate and save a value for
`canlock-password' first."
(if (and (file-readable-p file) (mail-file-babyl-p file))
(rmail-output file 1 nil t)
(let ((mail-use-rfc822 t))
- (rmail-output file 1 t t))))))
- (kill-buffer (current-buffer))))))
+ (rmail-output file 1 t t))))))))))
(defun message-output (filename)
"Append this article to Unix/babyl mail file FILENAME."
@@ -5761,7 +5785,7 @@ give as trustworthy answer as possible."
(not (string-match message-bogus-system-names message-user-fqdn)))
;; `message-user-fqdn' seems to be valid
message-user-fqdn)
- ((and (string-match message-bogus-system-names sysname))
+ ((not (string-match message-bogus-system-names sysname))
;; `system-name' returned the right result.
sysname)
;; Try `mail-host-address'.
@@ -6644,29 +6668,27 @@ OTHER-HEADERS is an alist of header/value pairs.
CONTINUE says whether
to continue editing a message already being composed. SWITCH-FUNCTION
is a function used to switch to and display the mail buffer."
(interactive)
- (let ((message-this-is-mail t))
- (unless (message-mail-user-agent)
- (message-pop-to-buffer
- ;; Search for the existing message buffer if `continue' is non-nil.
- (let ((message-generate-new-buffers
- (when (or (not continue)
- (eq message-generate-new-buffers 'standard)
- (functionp message-generate-new-buffers))
- message-generate-new-buffers)))
- (message-buffer-name "mail" to))
- switch-function))
- (message-setup
- (nconc
- `((To . ,(or to "")) (Subject . ,(or subject "")))
- ;; C-h f compose-mail says that headers should be specified as
- ;; (string . value); however all the rest of message expects
- ;; headers to be symbols, not strings (eg message-header-format-alist).
- ;; http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg00337.html
- ;; We need to convert any string input, eg from rmail-start-mail.
- (dolist (h other-headers other-headers)
- (if (stringp (car h)) (setcar h (intern (capitalize (car h)))))))
- yank-action send-actions continue switch-function
- return-action)))
+ (let ((message-this-is-mail t)
+ message-buffers)
+ ;; Search for the existing message buffer if `continue' is non-nil.
+ (if (and continue
+ (setq message-buffers (message-buffers)))
+ (pop-to-buffer (car message-buffers))
+ ;; Start a new buffer.
+ (unless (message-mail-user-agent)
+ (message-pop-to-buffer (message-buffer-name "mail" to) switch-function))
+ (message-setup
+ (nconc
+ `((To . ,(or to "")) (Subject . ,(or subject "")))
+ ;; C-h f compose-mail says that headers should be specified as
+ ;; (string . value); however all the rest of message expects
+ ;; headers to be symbols, not strings (eg message-header-format-alist).
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg00337.html
+ ;; We need to convert any string input, eg from rmail-start-mail.
+ (dolist (h other-headers other-headers)
+ (if (stringp (car h)) (setcar h (intern (capitalize (car h)))))))
+ yank-action send-actions continue switch-function
+ return-action))))
;;;###autoload
(defun message-news (&optional newsgroups subject)
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 6d13d89..3a31349 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -486,7 +486,8 @@ be \"related\" or \"alternate\"."
(equal (cdr (assq 'type (car cont))) "text/html"))
(setq cont (mml-expand-html-into-multipart-related (car cont))))
(prog1
- (mm-with-multibyte-buffer
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
(setq message-options options)
(cond
((and (consp (car cont))
@@ -605,28 +606,38 @@ be \"related\" or \"alternate\"."
(intern (downcase charset))))))
(if (and (not raw)
(member (car (split-string type "/")) '("text" "message")))
+ ;; We have a text-like MIME part, so we need to do
+ ;; charset encoding.
(progn
(with-temp-buffer
- (cond
- ((cdr (assq 'buffer cont))
- (insert-buffer-substring (cdr (assq 'buffer cont))))
- ((and filename
- (not (equal (cdr (assq 'nofile cont)) "yes")))
- (let ((coding-system-for-read coding))
- (mm-insert-file-contents filename)))
- ((eq 'mml (car cont))
- (insert (cdr (assq 'contents cont))))
- (t
- (save-restriction
- (narrow-to-region (point) (point))
- (insert (cdr (assq 'contents cont)))
- ;; Remove quotes from quoted tags.
- (goto-char (point-min))
- (while (re-search-forward
-
"<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)"
- nil t)
- (delete-region (+ (match-beginning 0) 2)
- (+ (match-beginning 0) 3))))))
+ (set-buffer-multibyte nil)
+ ;; First insert the data into the buffer.
+ (if (and filename
+ (not (equal (cdr (assq 'nofile cont)) "yes")))
+ (mm-insert-file-contents filename)
+ (insert
+ (with-temp-buffer
+ (cond
+ ((cdr (assq 'buffer cont))
+ (insert-buffer-substring (cdr (assq 'buffer cont))))
+ ((eq 'mml (car cont))
+ (insert (cdr (assq 'contents cont))))
+ (t
+ (insert (cdr (assq 'contents cont)))
+ ;; Remove quotes from quoted tags.
+ (goto-char (point-min))
+ (while (re-search-forward
+
"<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)"
+ nil t)
+ (delete-region (+ (match-beginning 0) 2)
+ (+ (match-beginning 0) 3)))))
+ (setq charset
+ (mm-coding-system-to-mime-charset
+ (detect-coding-region
+ (point-min) (point-max) t)))
+ (encode-coding-region (point-min) (point-max)
+ charset)
+ (buffer-string))))
(cond
((eq (car cont) 'mml)
(let ((mml-boundary (mml-compute-boundary cont))
@@ -667,21 +678,22 @@ be \"related\" or \"alternate\"."
;; insert a "; format=flowed" string unless the
;; user has already specified it.
(setq flowed (null (assq 'format cont)))))
- ;; Prefer `utf-8' for text/calendar parts.
- (if (or charset
- (not (string= type "text/calendar")))
- (setq charset (mm-encode-body charset))
- (let ((mm-coding-system-priorities
- (cons 'utf-8 mm-coding-system-priorities)))
- (setq charset (mm-encode-body))))
- (mm-disable-multibyte)
+ (unless charset
+ (setq charset
+ ;; Prefer `utf-8' for text/calendar parts.
+ (if (string= type "text/calendar")
+ 'utf-8
+ (mm-coding-system-to-mime-charset
+ (detect-coding-region
+ (point-min) (point-max) t)))))
(setq encoding (mm-body-encoding
charset (cdr (assq 'encoding cont))))))
(setq coded (buffer-string)))
(mml-insert-mime-headers cont type charset encoding flowed)
(insert "\n")
(insert coded))
- (mm-with-unibyte-buffer
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
(cond
((cdr (assq 'buffer cont))
(insert (string-as-unibyte
@@ -690,11 +702,7 @@ be \"related\" or \"alternate\"."
((and filename
(not (equal (cdr (assq 'nofile cont)) "yes")))
(let ((coding-system-for-read mm-binary-coding-system))
- (mm-insert-file-contents filename nil nil nil nil t))
- (unless charset
- (setq charset (mm-coding-system-to-mime-charset
- (mm-find-buffer-file-coding-system
- filename)))))
+ (mm-insert-file-contents filename nil nil nil nil t)))
(t
(let ((contents (cdr (assq 'contents cont))))
(if (multibyte-string-p contents)
@@ -1244,6 +1252,7 @@ If not set, `default-directory' will be used."
(defun mml-minibuffer-read-file (prompt)
(let* ((completion-ignored-extensions nil)
+ (buffer-file-name nil)
(file (read-file-name prompt
(or mml-default-directory default-directory)
nil t)))
@@ -1378,12 +1387,23 @@ content-type, a string of the form \"type/subtype\".
DESCRIPTION
is a one-line description of the attachment. The DISPOSITION
specifies how the attachment is intended to be displayed. It can
be either \"inline\" (displayed automatically within the message
-body) or \"attachment\" (separate from the body)."
+body) or \"attachment\" (separate from the body).
+
+If given a prefix interactively, no prompting will be done for
+the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults
+will be computed and used."
(interactive
(let* ((file (mml-minibuffer-read-file "Attach file: "))
- (type (mml-minibuffer-read-type file))
- (description (mml-minibuffer-read-description))
- (disposition (mml-minibuffer-read-disposition type nil file)))
+ (type (if current-prefix-arg
+ (or (mm-default-file-encoding file)
+ "application/octet-stream")
+ (mml-minibuffer-read-type file)))
+ (description (if current-prefix-arg
+ nil
+ (mml-minibuffer-read-description)))
+ (disposition (if current-prefix-arg
+ (mml-content-disposition type file)
+ (mml-minibuffer-read-disposition type nil file))))
(list file type description disposition)))
;; If in the message header, attach at the end and leave point unchanged.
(let ((head (unless (message-in-body-p) (point))))
diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el
index ede118d..7f7db87 100644
--- a/lisp/gnus/nndoc.el
+++ b/lisp/gnus/nndoc.el
@@ -356,14 +356,18 @@ from the document.")
(setq nndoc-dissection-alist nil)
(with-current-buffer nndoc-current-buffer
(erase-buffer)
- (if (and (stringp nndoc-address)
- (string-match nndoc-binary-file-names nndoc-address))
- (let ((coding-system-for-read 'binary))
- (mm-insert-file-contents nndoc-address))
- (if (stringp nndoc-address)
- (nnheader-insert-file-contents nndoc-address)
- (insert-buffer-substring nndoc-address))
- (run-hooks 'nndoc-open-document-hook)))))
+ (condition-case error
+ (if (and (stringp nndoc-address)
+ (string-match nndoc-binary-file-names nndoc-address))
+ (let ((coding-system-for-read 'binary))
+ (mm-insert-file-contents nndoc-address))
+ (if (stringp nndoc-address)
+ (nnheader-insert-file-contents nndoc-address)
+ (insert-buffer-substring nndoc-address))
+ (run-hooks 'nndoc-open-document-hook))
+ (file-error
+ (nnheader-report 'nndoc "Couldn't open %s: %s"
+ group error))))))
;; Initialize the nndoc structures according to this new document.
(when (and nndoc-current-buffer
(not nndoc-dissection-alist))
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 700e86a..2943c8d 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -67,7 +67,11 @@ back on `network'.")
(if (listp imap-shell-program)
(car imap-shell-program)
imap-shell-program)
- "ssh %s imapd"))
+ "ssh %s imapd")
+ "What command to execute to connect to an IMAP server.
+This will only be used if the connection type is `shell'. See
+the `open-network-stream' documentation for an explanation of
+the format.")
(defvoo nnimap-inbox nil
"The mail box where incoming mail arrives and should be split out of.
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index fa16fa0..742c669 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -115,13 +115,15 @@ When called from lisp, FUNCTION may also be a function
object."
(if fn
(format "Describe function (default %s): " fn)
"Describe function: ")
- #'help--symbol-completion-table #'fboundp t nil nil
+ #'help--symbol-completion-table
+ (lambda (f) (or (fboundp f) (get f 'function-documentation)))
+ t nil nil
(and fn (symbol-name fn)))))
(unless (equal val "")
(setq fn (intern val)))
(unless (and fn (symbolp fn))
(user-error "You didn't specify a function symbol"))
- (unless (fboundp fn)
+ (unless (or (fboundp fn) (get fn 'function-documentation))
(user-error "Symbol's function definition is void: %s" fn))
(list fn)))
@@ -144,7 +146,9 @@ When called from lisp, FUNCTION may also be a function
object."
(save-excursion
(with-help-window (help-buffer)
- (prin1 function)
+ (if (get function 'reader-construct)
+ (princ function)
+ (prin1 function))
;; Use " is " instead of a colon so that
;; it is easier to get out the function name using forward-sexp.
(princ " is ")
@@ -469,7 +473,8 @@ suitable file is found, return nil."
(let ((fill-begin (point))
(high-usage (car high))
(high-doc (cdr high)))
- (insert high-usage "\n")
+ (unless (get function 'reader-construct)
+ (insert high-usage "\n"))
(fill-region fill-begin (point))
high-doc)))))
@@ -565,18 +570,21 @@ FILE is the file where FUNCTION was probably defined."
(or (and advised
(advice--cd*r (advice--symbol-function function)))
function))
- ;; Get the real definition.
+ ;; Get the real definition, if any.
(def (if (symbolp real-function)
- (or (symbol-function real-function)
- (signal 'void-function (list real-function)))
+ (cond ((symbol-function real-function))
+ ((get real-function 'function-documentation)
+ nil)
+ (t (signal 'void-function (list real-function))))
real-function))
- (aliased (or (symbolp def)
- ;; Advised & aliased function.
- (and advised (symbolp real-function)
- (not (eq 'autoload (car-safe def))))
- (and (subrp def)
- (not (string= (subr-name def)
- (symbol-name function))))))
+ (aliased (and def
+ (or (symbolp def)
+ ;; Advised & aliased function.
+ (and advised (symbolp real-function)
+ (not (eq 'autoload (car-safe def))))
+ (and (subrp def)
+ (not (string= (subr-name def)
+ (symbol-name function)))))))
(real-def (cond
((and aliased (not (subrp def)))
(let ((f real-function))
@@ -605,6 +613,8 @@ FILE is the file where FUNCTION was probably defined."
;; Print what kind of function-like object FUNCTION is.
(princ (cond ((or (stringp def) (vectorp def))
"a keyboard macro")
+ ((get function 'reader-construct)
+ "a reader construct")
;; Aliases are Lisp functions, so we need to check
;; aliases before functions.
(aliased
@@ -842,7 +852,7 @@ it is displayed along with the global value."
(terpri)
(pp val)
;; Remove trailing newline.
- (delete-char -1))
+ (and (= (char-before) ?\n) (delete-char -1)))
(let* ((sv (get variable 'standard-value))
(origval (and (consp sv)
(condition-case nil
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index a8d7294..3fb793e 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -328,7 +328,7 @@ Commands:
"\\(source \\(?:code \\)?\\(?:of\\|for\\)\\)\\)"
"[ \t\n]+\\)?"
;; Note starting with word-syntax character:
- "['`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\)['’]"))
+ "['`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\|`\\)['’]"))
"Regexp matching doc string references to symbols.
The words preceding the quoted symbol can be used in doc strings to
diff --git a/lisp/hl-line.el b/lisp/hl-line.el
index 4cf0573..38fe683 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -189,7 +189,8 @@ Specifically, when `hl-line-sticky-flag' is nil deactivate
all
such overlays in all buffers except the current one."
(let ((hlob hl-line-overlay-buffer)
(curbuf (current-buffer)))
- (when (and (not hl-line-sticky-flag)
+ (when (and (buffer-live-p hlob)
+ (not hl-line-sticky-flag)
(not (eq curbuf hlob))
(not (minibufferp)))
(with-current-buffer hlob
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index 21aac1a..74393ff 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -365,9 +365,15 @@ commands in `hfy-etags-cmd-alist'."
(defun hfy-which-etags ()
"Return a string indicating which flavor of etags we are using."
- (let ((v (shell-command-to-string (concat hfy-etags-bin " --version"))))
- (cond ((string-match "exube" v) "exuberant ctags")
- ((string-match "GNU E" v) "emacs etags" )) ))
+ (with-temp-buffer
+ (condition-case nil
+ (when (eq (call-process hfy-etags-bin nil t nil "--version") 0)
+ (goto-char (point-min))
+ (cond
+ ((looking-at-p "exube") "exuberant ctags")
+ ((looking-at-p "GNU E") "emacs etags")))
+ ;; Return nil if the etags binary isn't executable (Bug#25468).
+ (file-error nil))))
(defcustom hfy-etags-cmd
;; We used to wrap this in a `eval-and-compile', but:
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index c6e5e47..71bf1d6 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1319,13 +1319,14 @@ a new window in the current frame, splitting
vertically."
(cl-assert (derived-mode-p 'ibuffer-mode)))
(defun ibuffer-buffer-file-name ()
- (or buffer-file-name
- (let ((dirname (or (and (boundp 'dired-directory)
- (if (stringp dired-directory)
- dired-directory
- (car dired-directory)))
- (bound-and-true-p list-buffers-directory))))
- (and dirname (expand-file-name dirname)))))
+ (cond
+ ((buffer-file-name))
+ ((bound-and-true-p list-buffers-directory))
+ ((let ((dirname (and (boundp 'dired-directory)
+ (if (stringp dired-directory)
+ dired-directory
+ (car dired-directory)))))
+ (and dirname (expand-file-name dirname))))))
(define-ibuffer-op ibuffer-do-save ()
"Save marked buffers as with `save-buffer'."
diff --git a/lisp/image-dired.el b/lisp/image-dired.el
index 901225f..2a40645 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -94,6 +94,7 @@
;; * WARNING: The "database" format used might be changed so keep a
;; backup of `image-dired-db-file' when testing new versions.
;;
+;; * `image-dired-display-image-mode' does not support animation
;;
;; TODO
;; ====
@@ -228,7 +229,7 @@ Used together with
`image-dired-cmd-create-thumbnail-options'."
:group 'image-dired)
(defcustom image-dired-cmd-create-thumbnail-options
- '("-size" "%wx%h" "%f" "-resize" "%wx%h>" "-strip" "jpeg:%t")
+ '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t")
"Options of command used to create thumbnail image.
Used with `image-dired-cmd-create-thumbnail-program'.
Available format specifiers are: %w which is replaced by
@@ -246,7 +247,7 @@ Used together with
`image-dired-cmd-create-temp-image-options'."
:group 'image-dired)
(defcustom image-dired-cmd-create-temp-image-options
- '("-size" "%wx%h" "%f" "-resize" "%wx%h>" "-strip" "jpeg:%t")
+ '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t")
"Options of command used to create temporary image for display window.
Used together with `image-dired-cmd-create-temp-image-program',
Available format specifiers are: %w and %h which are replaced by
@@ -316,7 +317,7 @@ Available format specifiers are described in
:group 'image-dired)
(defcustom image-dired-cmd-create-standard-thumbnail-options
- (append '("-size" "%wx%h" "%f")
+ (append '("-size" "%wx%h" "%f[0]")
(unless (or image-dired-cmd-pngcrush-program
image-dired-cmd-pngnq-program)
(list
@@ -1626,6 +1627,7 @@ Resized or in full-size."
:group 'image-dired
(buffer-disable-undo)
(image-mode-setup-winprops)
+ (setq cursor-type nil)
(add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil
t))
(defvar image-dired-minor-mode-map
diff --git a/lisp/indent.el b/lisp/indent.el
index db31f04..fdd184c 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -487,9 +487,9 @@ line, but does not move past any whitespace that was
explicitly inserted
(if (memq (current-justification) '(center right))
(skip-chars-forward " \t")))
-(defvar indent-region-function nil
+(defvar indent-region-function #'indent-region-line-by-line
"Short cut function to indent region using `indent-according-to-mode'.
-A value of nil means really run `indent-according-to-mode' on each line.")
+Default is to really run `indent-according-to-mode' on each line.")
(defun indent-region (start end &optional column)
"Indent each nonblank line in the region.
@@ -541,24 +541,26 @@ column to indent to; if it is nil, use one of the three
methods above."
(funcall indent-region-function start end))
;; Else, use a default implementation that calls indent-line-function on
;; each line.
- (t
- (save-excursion
- (setq end (copy-marker end))
- (goto-char start)
- (let ((pr (unless (minibufferp)
- (make-progress-reporter "Indenting region..." (point) end))))
- (while (< (point) end)
- (or (and (bolp) (eolp))
- (indent-according-to-mode))
- (forward-line 1)
- (and pr (progress-reporter-update pr (point))))
- (and pr (progress-reporter-done pr))
- (move-marker end nil)))))
+ (t (indent-region-line-by-line start end)))
;; In most cases, reindenting modifies the buffer, but it may also
;; leave it unmodified, in which case we have to deactivate the mark
;; by hand.
(setq deactivate-mark t))
+(defun indent-region-line-by-line (start end)
+ (save-excursion
+ (setq end (copy-marker end))
+ (goto-char start)
+ (let ((pr (unless (minibufferp)
+ (make-progress-reporter "Indenting region..." (point) end))))
+ (while (< (point) end)
+ (or (and (bolp) (eolp))
+ (indent-according-to-mode))
+ (forward-line 1)
+ (and pr (progress-reporter-update pr (point))))
+ (and pr (progress-reporter-done pr))
+ (move-marker end nil))))
+
(define-obsolete-function-alias 'indent-relative-maybe
'indent-relative-first-indent-point "26.1")
diff --git a/lisp/info.el b/lisp/info.el
index e32b6b3..0cfcec3 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -1599,6 +1599,16 @@ escaped (\\\",\\\\)."
parameter-alist))
parameter-alist))
+(defun Info-node-description (file)
+ (cond
+ ((equal file "dir") "*Info Directory*")
+ ((eq file 'apropos) "*Info Apropos*")
+ ((eq file 'history) "*Info History*")
+ ((eq file 'toc) "*Info TOC*")
+ ((not (stringp file)) "") ; Avoid errors
+ (t
+ (concat "(" (file-name-nondirectory file) ") " Info-current-node))))
+
(defun Info-display-images-node ()
"Display images in current node."
(save-excursion
@@ -1693,6 +1703,7 @@ escaped (\\\",\\\\)."
(setq Info-history-forward nil))
(if (not (eq Info-fontify-maximum-menu-size nil))
(Info-fontify-node))
+ (setq list-buffers-directory (Info-node-description Info-current-file))
(Info-display-images-node)
(Info-hide-cookies-node)
(run-hooks 'Info-selection-hook)))))
diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el
index a3e53cf..fd793a2 100644
--- a/lisp/mail/ietf-drums.el
+++ b/lisp/mail/ietf-drums.el
@@ -192,6 +192,17 @@ the Content-Transfer-Encoding header of a mail."
(ietf-drums-init string)
(while (not (eobp))
(setq c (char-after))
+ ;; If we have an uneven number of quote characters,
+ ;; `forward-sexp' will fail. In these cases, just delete the
+ ;; final of these quote characters.
+ (when (and (eq c ?\")
+ (not
+ (save-excursion
+ (ignore-errors
+ (forward-sexp 1)
+ t))))
+ (delete-char 1)
+ (setq c (char-after)))
(cond
((or (eq c ? )
(eq c ?\t))
diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el
index 2a81609..bcbdc17 100644
--- a/lisp/mail/rfc2047.el
+++ b/lisp/mail/rfc2047.el
@@ -281,17 +281,7 @@ Should be called narrowed to the head of the message."
(encode-coding-region
(point-min) (point-max)
(mm-charset-to-coding-system
- (car message-posting-charset))))
- ;; No encoding necessary, but folding is nice
- (when nil
- (rfc2047-fold-region
- (save-excursion
- (goto-char (point-min))
- (skip-chars-forward "^:")
- (when (looking-at ": ")
- (forward-char 2))
- (point))
- (point-max))))
+ (car message-posting-charset)))))
;; We found something that may perhaps be encoded.
(re-search-forward "^[^:]+: *" nil t)
(cond
diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el
index aae751e..3f3990e 100644
--- a/lisp/mh-e/mh-compat.el
+++ b/lisp/mh-e/mh-compat.el
@@ -283,16 +283,6 @@ DOCSTRING arguments."
See documentation for `make-obsolete-variable' for a description
of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN
and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and
-ACCESS-TYPE arguments."
- (if (featurep 'xemacs)
- `(make-obsolete-variable ,obsolete-name ,current-name)
- `(make-obsolete-variable ,obsolete-name ,current-name ,when ,access-type)))
-
-(defmacro mh-make-obsolete-variable (obsolete-name current-name &optional when
access-type)
- "Make the byte-compiler warn that OBSOLETE-NAME is obsolete.
-See documentation for `make-obsolete-variable' for a description
-of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN
-and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and
ACCESS-TYPE arguments and by Emacs versions that lack ACCESS-TYPE,
introduced in Emacs 24."
(if (featurep 'xemacs)
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index d421807..f7e0634 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -59,7 +59,7 @@
"Directory where files will downloaded."
:version "24.4"
:group 'eww
- :type 'string)
+ :type 'directory)
;;;###autoload
(defcustom eww-suggest-uris
@@ -81,7 +81,7 @@ duplicate entries (if any) removed."
"Directory where bookmark files will be stored."
:version "25.1"
:group 'eww
- :type 'string)
+ :type 'directory)
(defcustom eww-desktop-remove-duplicates t
"Whether to remove duplicates from the history when saving desktop data.
@@ -251,6 +251,29 @@ word(s) will be searched for via `eww-search-prefix'."
(if uris (format " (default %s)" (car uris)) "")
": ")))
(list (read-string prompt nil nil uris))))
+ (setq url (eww--dwim-expand-url url))
+ (pop-to-buffer-same-window
+ (if (eq major-mode 'eww-mode)
+ (current-buffer)
+ (get-buffer-create "*eww*")))
+ (eww-setup-buffer)
+ ;; Check whether the domain only uses "Highly Restricted" Unicode
+ ;; IDNA characters. If not, transform to punycode to indicate that
+ ;; there may be funny business going on.
+ (let ((parsed (url-generic-parse-url url)))
+ (unless (puny-highly-restrictive-domain-p (url-host parsed))
+ (setf (url-host parsed) (puny-encode-domain (url-host parsed)))
+ (setq url (url-recreate-url parsed))))
+ (plist-put eww-data :url url)
+ (plist-put eww-data :title "")
+ (eww-update-header-line-format)
+ (let ((inhibit-read-only t))
+ (insert (format "Loading %s..." url))
+ (goto-char (point-min)))
+ (url-retrieve url 'eww-render
+ (list url nil (current-buffer))))
+
+(defun eww--dwim-expand-url (url)
(setq url (string-trim url))
(cond ((string-match-p "\\`file:/" url))
;; Don't mangle file: URLs at all.
@@ -275,26 +298,7 @@ word(s) will be searched for via `eww-search-prefix'."
(setq url (concat url "/"))))
(setq url (concat eww-search-prefix
(replace-regexp-in-string " " "+" url))))))
- (pop-to-buffer-same-window
- (if (eq major-mode 'eww-mode)
- (current-buffer)
- (get-buffer-create "*eww*")))
- (eww-setup-buffer)
- ;; Check whether the domain only uses "Highly Restricted" Unicode
- ;; IDNA characters. If not, transform to punycode to indicate that
- ;; there may be funny business going on.
- (let ((parsed (url-generic-parse-url url)))
- (unless (puny-highly-restrictive-domain-p (url-host parsed))
- (setf (url-host parsed) (puny-encode-domain (url-host parsed)))
- (setq url (url-recreate-url parsed))))
- (plist-put eww-data :url url)
- (plist-put eww-data :title "")
- (eww-update-header-line-format)
- (let ((inhibit-read-only t))
- (insert (format "Loading %s..." url))
- (goto-char (point-min)))
- (url-retrieve url 'eww-render
- (list url nil (current-buffer))))
+ url)
;;;###autoload (defalias 'browse-web 'eww)
@@ -351,16 +355,25 @@ Currently this means either text/html or
application/xhtml+xml."
"utf-8"))))
(data-buffer (current-buffer))
last-coding-system-used)
- ;; Save the https peer status.
(with-current-buffer buffer
- (plist-put eww-data :peer (plist-get status :peer)))
+ ;; Save the https peer status.
+ (plist-put eww-data :peer (plist-get status :peer))
+ ;; Make buffer listings more informative.
+ (setq list-buffers-directory url))
(unwind-protect
(progn
(cond
((and eww-use-external-browser-for-content-type
(string-match-p eww-use-external-browser-for-content-type
(car content-type)))
- (eww-browse-with-external-browser url))
+ (erase-buffer)
+ (insert "<title>Unsupported content type</title>")
+ (insert (format "<h1>Content-type %s is unsupported</h1>"
+ (car content-type)))
+ (insert (format "<a href=%S>Direct link to the document</a>"
+ url))
+ (goto-char (point-min))
+ (eww-display-html charset url nil point buffer encode))
((eww-html-p (car content-type))
(eww-display-html charset url nil point buffer encode))
((equal (car content-type) "application/pdf")
@@ -804,7 +817,10 @@ the like."
;;;###autoload
(defun eww-browse-url (url &optional new-window)
(when new-window
- (pop-to-buffer-same-window (generate-new-buffer "*eww*"))
+ (pop-to-buffer-same-window
+ (generate-new-buffer
+ (format "*eww-%s*" (url-host (url-generic-parse-url
+ (eww--dwim-expand-url url))))))
(eww-mode))
(eww url))
@@ -835,6 +851,8 @@ the like."
(erase-buffer)
(insert text)
(goto-char (plist-get elem :point))
+ ;; Make buffer listings more informative.
+ (setq list-buffers-directory (plist-get elem :url))
(eww-update-header-line-format))))
(defun eww-next-url ()
@@ -1483,6 +1501,7 @@ Differences in #targets are ignored."
(defun eww-download ()
"Download URL under point to `eww-download-directory'."
(interactive)
+ (access-file eww-download-directory "Download failed")
(let ((url (get-text-property (point) 'shr-url)))
(if (not url)
(message "No URL under point")
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 93e1bae..bf60eee 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -139,6 +139,10 @@ a greeting from the server.
:nowait, if non-nil, says the connection should be made
asynchronously, if possible.
+:shell-command is a format-spec string that can be used if :type
+is `shell'. It has two specs, %s for host and %p for port
+number. Example: \"ssh gateway nc %s %p\".
+
:tls-parameters is a list that should be supplied if you're
opening a TLS connection. The first element is the TLS
type (either `gnutls-x509pki' or `gnutls-anon'), and the
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index e0bb3db..b7c4828 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -96,8 +96,9 @@ If nil, don't draw horizontal table lines."
(defcustom shr-width nil
"Frame width to use for rendering.
May either be an integer specifying a fixed width in characters,
-or nil, meaning that the full width of the window should be
-used."
+or nil, meaning that the full width of the window should be used.
+If `shr-use-fonts' is set, the mean character width is used to
+compute the pixel width, which is used instead."
:version "25.1"
:type '(choice (integer :tag "Fixed width in characters")
(const :tag "Use the width of the window" nil))
@@ -978,7 +979,7 @@ element is the data blob and the second element is the
content-type."
(create-image data nil t :ascent 100
:format content-type))
((eq content-type 'image/svg+xml)
- (create-image data 'svg t :ascent 100))
+ (create-image data 'imagemagick t :ascent 100))
((eq size 'full)
(ignore-errors
(shr-rescale-image data content-type
@@ -1011,18 +1012,25 @@ element is the data blob and the second element is the
content-type."
image)
(insert (or alt ""))))
-(defun shr-rescale-image (data content-type width height)
+(defun shr-rescale-image (data content-type width height
+ &optional max-width max-height)
"Rescale DATA, if too big, to fit the current buffer.
-WIDTH and HEIGHT are the sizes given in the HTML data, if any."
+WIDTH and HEIGHT are the sizes given in the HTML data, if any.
+
+The size of the displayed image will not exceed
+MAX-WIDTH/MAX-HEIGHT. If not given, use the current window
+width/height instead."
(if (or (not (fboundp 'imagemagick-types))
(not (get-buffer-window (current-buffer))))
(create-image data nil t :ascent 100)
(let* ((edges (window-inside-pixel-edges
(get-buffer-window (current-buffer))))
(max-width (truncate (* shr-max-image-proportion
- (- (nth 2 edges) (nth 0 edges)))))
+ (or max-width
+ (- (nth 2 edges) (nth 0 edges))))))
(max-height (truncate (* shr-max-image-proportion
- (- (nth 3 edges) (nth 1 edges)))))
+ (or max-height
+ (- (nth 3 edges) (nth 1 edges))))))
(scaling (image-compute-scaling-factor image-scaling-factor)))
(when (or (and width
(> width max-width))
@@ -1059,8 +1067,7 @@ Return a string with image data."
(when (ignore-errors
(url-cache-extract (url-cache-create-filename (shr-encode-url url)))
t)
- (when (or (search-forward "\n\n" nil t)
- (search-forward "\r\n\r\n" nil t))
+ (when (re-search-forward "\r?\n\r?\n" nil t)
(shr-parse-image-data)))))
(declare-function libxml-parse-xml-region "xml.c"
@@ -1079,9 +1086,12 @@ Return a string with image data."
obarray)))))))
;; SVG images may contain references to further images that we may
;; want to block. So special-case these by parsing the XML data
- ;; and remove the blocked bits.
- (when (eq content-type 'image/svg+xml)
+ ;; and remove anything that looks like a blocked bit.
+ (when (and shr-blocked-images
+ (eq content-type 'image/svg+xml))
(setq data
+ ;; Note that libxml2 doesn't parse everything perfectly,
+ ;; so glitches may occur during this transformation.
(shr-dom-to-xml
(libxml-parse-xml-region (point) (point-max)))))
(list data content-type)))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index fc7fdd3..48dcd5e 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -3614,18 +3614,36 @@ connection buffer."
;;; Utility functions:
-(defun tramp-accept-process-output (&optional proc timeout timeout-msecs)
+(defun tramp-accept-process-output (proc timeout)
"Like `accept-process-output' for Tramp processes.
This is needed in order to hide `last-coding-system-used', which is set
for process communication also."
+ ;; FIXME: There are problems, when an asynchronous process runs in
+ ;; parallel, and also timers are active. See
+ ;; <http://lists.gnu.org/archive/html/tramp-devel/2017-01/msg00010.html>.
+ (when (and timer-event-last
+ (string-prefix-p "*tramp/" (process-name proc))
+ (let (result)
+ (maphash
+ (lambda (key _value)
+ (and (processp key)
+ (not (string-prefix-p "*tramp/" (process-name key)))
+ (tramp-compat-process-live-p key)
+ (setq result t)))
+ tramp-cache-data)
+ result))
+ (sit-for 0.01 'nodisp))
(with-current-buffer (process-buffer proc)
(let (buffer-read-only last-coding-system-used)
;; Under Windows XP, accept-process-output doesn't return
- ;; sometimes. So we add an additional timeout.
- (with-timeout ((or timeout 1))
- (accept-process-output proc timeout timeout-msecs (and proc t)))
- (tramp-message proc 10 "%s %s\n%s"
- proc (process-status proc) (buffer-string)))))
+ ;; sometimes. So we add an additional timeout. JUST-THIS-ONE
+ ;; is set due to Bug#12145.
+ (tramp-message
+ proc 10 "%s %s %s\n%s"
+ proc (process-status proc)
+ (with-timeout (timeout)
+ (accept-process-output proc timeout nil t))
+ (buffer-string)))))
(defun tramp-check-for-regexp (proc regexp)
"Check, whether REGEXP is contained in process buffer of PROC.
diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el
index 37816bb..393f3a5 100644
--- a/lisp/net/zeroconf.el
+++ b/lisp/net/zeroconf.el
@@ -256,7 +256,7 @@ supported keys depend on the service type.")
"Returns all discovered Avahi service names as list."
(let (result)
(maphash
- (lambda (key value) (add-to-list 'result (zeroconf-service-name value)))
+ (lambda (_key value) (add-to-list 'result (zeroconf-service-name value)))
zeroconf-services-hash)
result))
@@ -264,7 +264,7 @@ supported keys depend on the service type.")
"Returns all discovered Avahi service types as list."
(let (result)
(maphash
- (lambda (key value) (add-to-list 'result (zeroconf-service-type value)))
+ (lambda (_key value) (add-to-list 'result (zeroconf-service-type value)))
zeroconf-services-hash)
result))
@@ -276,7 +276,7 @@ The service type is one of the returned values of
format of SERVICE."
(let (result)
(maphash
- (lambda (key value)
+ (lambda (_key value)
(when (equal type (zeroconf-service-type value))
(add-to-list 'result value)))
zeroconf-services-hash)
diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el
index 981b846..ed5b4c6 100644
--- a/lisp/play/dunnet.el
+++ b/lisp/play/dunnet.el
@@ -267,7 +267,7 @@ on your head.")
(dun-mprincl "You can't drop anything while on the bus.")
(let (objnum)
(when (setq objnum (dun-objnum-from-args-std obj))
- (if (not (setq ptr (member objnum dun-inventory)))
+ (if (not (member objnum dun-inventory))
(dun-mprincl "You don't have that.")
(progn
(dun-remove-obj-from-inven objnum)
diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el
index 7cb36c4..0f7e4b5 100644
--- a/lisp/progmodes/cc-align.el
+++ b/lisp/progmodes/cc-align.el
@@ -1221,6 +1221,18 @@ Works with: arglist-cont, arglist-cont-nonempty."
(vector (progn (goto-char alignto) (current-column)))))))
+(defun c-lineup-under-anchor (langelem)
+ "Line up the current line directly under the anchor position in LANGELEM.
+
+This is like 0, except it supersedes any indentation already calculated for
+previous syntactic elements in the syntactic context.
+
+Works with: Any syntactic symbol which has an anchor position."
+ (save-excursion
+ (goto-char (c-langelem-pos langelem))
+ (vector (current-column))))
+
+
(defun c-lineup-dont-change (langelem)
"Do not change the indentation of the current line.
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index f214242..7f49557 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -10260,13 +10260,22 @@ comment at the start of cc-engine.el for more info."
(t nil)))))
(setq pos (point))
- (if (and after-type-id-pos
- (goto-char after-type-id-pos)
- (setq res (c-back-over-member-initializers))
- (goto-char res)
- (eq (car (c-beginning-of-decl-1 lim)) 'same))
- (cons (point) nil) ; Return value.
+ (cond
+ ((and after-type-id-pos
+ (goto-char after-type-id-pos)
+ (setq res (c-back-over-member-initializers))
+ (goto-char res)
+ (eq (car (c-beginning-of-decl-1 lim)) 'same))
+ (cons (point) nil)) ; Return value.
+
+ ((and after-type-id-pos
+ (progn
+ (c-backward-syntactic-ws)
+ (eq (char-before) ?\()))
+ ;; Single identifier between '(' and '{'. We have a bracelist.
+ (cons after-type-id-pos nil))
+ (t
(goto-char pos)
;; Checks to do on all sexps before the brace, up to the
;; beginning of the statement.
@@ -10368,7 +10377,7 @@ comment at the start of cc-engine.el for more info."
; languages where
; `c-opt-inexpr-brace-list-key' is
; non-nil and we have macros.
- (t t))) ;; The caller can go up one level.
+ (t t)))) ;; The caller can go up one level.
)))
(defun c-inside-bracelist-p (containing-sexp paren-state)
@@ -10493,6 +10502,30 @@ comment at the start of cc-engine.el for more info."
(c-at-statement-start-p))
(make-obsolete 'c-looking-at-bos 'c-at-statement-start-p "22.1")
+(defun c-looking-at-statement-block ()
+ ;; Point is at an opening brace. If this is a statement block (i.e. the
+ ;; elements in it are terminated by semicolons) return t. Otherwise, return
+ ;; nil.
+ (let ((here (point)))
+ (prog1
+ (if (c-go-list-forward)
+ (let ((there (point)))
+ (backward-char)
+ (c-syntactic-skip-backward
+ "^;," here t)
+ (cond
+ ((eq (char-before) ?\;) t)
+ ((eq (char-before) ?,) nil)
+ (t (goto-char here)
+ (forward-char)
+ (and (c-syntactic-re-search-forward "{" there t t)
+ (progn (backward-char)
+ (c-looking-at-statement-block))))))
+ (forward-char)
+ (and (c-syntactic-re-search-forward "[;,]" nil t t)
+ (eq (char-before) ?\;)))
+ (goto-char here))))
+
(defun c-looking-at-inexpr-block (lim containing-sexp &optional check-at-end)
;; Return non-nil if we're looking at the beginning of a block
;; inside an expression. The value returned is actually a cons of
@@ -10648,15 +10681,7 @@ comment at the start of cc-engine.el for more info."
(and (c-major-mode-is 'c++-mode)
(save-excursion
(goto-char block-follows)
- (if (c-go-list-forward)
- (progn
- (backward-char)
- (c-syntactic-skip-backward
- "^;," block-follows t)
- (not (eq (char-before) ?\;)))
- (or (not (c-syntactic-re-search-forward
- "[;,]" nil t t))
- (not (eq (char-before) ?\;)))))))
+ (not (c-looking-at-statement-block)))))
nil
(cons 'inexpr-statement (point)))))
@@ -10792,17 +10817,20 @@ comment at the start of cc-engine.el for more info."
syntax-extra-args
stop-at-boi-only
containing-sexp
- paren-state)
+ paren-state
+ &optional fixed-anchor)
;; Add the indicated SYNTAX-SYMBOL to `c-syntactic-context', extending it as
;; needed with further syntax elements of the types `substatement',
- ;; `inexpr-statement', `arglist-cont-nonempty', `statement-block-intro', and
- ;; `defun-block-intro'.
+ ;; `inexpr-statement', `arglist-cont-nonempty', `statement-block-intro',
+ ;; `defun-block-intro', and `brace-list-intro'.
;;
- ;; Do the generic processing to anchor the given syntax symbol on
- ;; the preceding statement: Skip over any labels and containing
- ;; statements on the same line, and then search backward until we
- ;; find a statement or block start that begins at boi without a
- ;; label or comment.
+ ;; Do the generic processing to anchor the given syntax symbol on the
+ ;; preceding statement: First skip over any labels and containing statements
+ ;; on the same line. If FIXED-ANCHOR is non-nil, use this as the
+ ;; anchor-point for the given syntactic symbol, and don't make syntactic
+ ;; entries for constructs beginning on lines before that containing
+ ;; ANCHOR-POINT. Otherwise search backward until we find a statement or
+ ;; block start that begins at boi without a label or comment.
;;
;; Point is assumed to be at the prospective anchor point for the
;; given SYNTAX-SYMBOL. More syntax entries are added if we need to
@@ -10831,6 +10859,7 @@ comment at the start of cc-engine.el for more info."
(let ((syntax-last c-syntactic-context)
(boi (c-point 'boi))
+ (anchor-boi (c-point 'boi))
;; Set when we're on a label, so that we don't stop there.
;; FIXME: To be complete we should check if we're on a label
;; now at the start.
@@ -10908,7 +10937,9 @@ comment at the start of cc-engine.el for more info."
(c-add-syntax 'substatement nil))))
)))
- containing-sexp)
+ containing-sexp
+ (or (null fixed-anchor)
+ (> containing-sexp anchor-boi)))
;; Now we have to go out of this block.
(goto-char containing-sexp)
@@ -10982,6 +11013,14 @@ comment at the start of cc-engine.el for more info."
(cdr (assoc (match-string 1)
c-other-decl-block-key-in-symbols-alist))
(max (c-point 'boi paren-pos) (point))))
+ ((save-excursion
+ (goto-char paren-pos)
+ (c-looking-at-or-maybe-in-bracelist containing-sexp))
+ (if (save-excursion
+ (goto-char paren-pos)
+ (c-looking-at-statement-block))
+ (c-add-syntax 'defun-block-intro nil)
+ (c-add-syntax 'brace-list-intro nil)))
(t (c-add-syntax 'defun-block-intro nil))))
(c-add-syntax 'statement-block-intro nil)))
@@ -11001,7 +11040,10 @@ comment at the start of cc-engine.el for more info."
(setq q (cdr (car p))) ; e.g. (nil 28) [from (arglist-cont-nonempty
nil 28)]
(while q
(unless (car q)
- (setcar q (point)))
+ (setcar q (if (or (cdr p)
+ (null fixed-anchor))
+ (point)
+ fixed-anchor)))
(setq q (cdr q)))
(setq p (cdr p))))
)))
@@ -12354,7 +12396,8 @@ comment at the start of cc-engine.el for more info."
(c-forward-syntactic-ws (c-point 'eol))
(c-looking-at-special-brace-list (point)))))
(c-add-syntax 'brace-entry-open (point))
- (c-add-syntax 'brace-list-entry (point))
+ (c-add-stmt-syntax 'brace-list-entry nil t containing-sexp
+ paren-state (point))
))
))))
@@ -12848,7 +12891,7 @@ Cannot combine absolute offsets %S and %S in `add'
method"
;;
;; Note that topmost-intro always has an anchor position at bol, for
;; historical reasons. It's often used together with other symbols
- ;; that has more sane positions. Since we always use the first
+ ;; that have more sane positions. Since we always use the first
;; found anchor position, we rely on that these other symbols always
;; precede topmost-intro in the LANGELEMS list.
;;
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index d350549..b3848a7 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -67,6 +67,7 @@
(arglist-close . c-lineup-arglist)
(inline-open . 0)
(brace-list-open . +)
+ (brace-list-intro . c-lineup-arglist-intro-after-paren)
(topmost-intro-cont
. (first c-lineup-topmost-intro-cont
c-lineup-gnu-DEFUN-intro-cont))))
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index a6a96d1..1114b21 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -1115,7 +1115,7 @@ can always override the use of `c-default-style' by
making calls to
;; Anchor pos: At the brace list decl start(*).
(brace-list-intro . +)
;; Anchor pos: At the brace list decl start(*).
- (brace-list-entry . 0)
+ (brace-list-entry . c-lineup-under-anchor)
;; Anchor pos: At the first non-ws char after the open paren if
;; the first token is on the same line, otherwise boi at that
;; token.
diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el
index 0e4e670..5328526 100644
--- a/lisp/progmodes/hideshow.el
+++ b/lisp/progmodes/hideshow.el
@@ -582,7 +582,7 @@ and then further adjusted to be at the end of the line."
(setq p (line-end-position)))
;; `q' is the point at the end of the block
(hs-forward-sexp mdata 1)
- (setq q (if (looking-back hs-block-end-regexp)
+ (setq q (if (looking-back hs-block-end-regexp nil)
(match-beginning 0)
(point)))
(when (and (< p q) (> (count-lines p q) 1))
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 2e5c6ae..e42e014 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -574,8 +574,8 @@ then the \".\"s will be lined up:
(define-key keymap [(control ?c) (control ?j)] #'js-set-js-context)
(define-key keymap [(control meta ?x)] #'js-eval-defun)
(define-key keymap [(meta ?.)] #'js-find-symbol)
- (easy-menu-define nil keymap "Javascript Menu"
- '("Javascript"
+ (easy-menu-define nil keymap "JavaScript Menu"
+ '("JavaScript"
["Select New Mozilla Context..." js-set-js-context
(fboundp #'inferior-moz-process)]
["Evaluate Expression in Mozilla Context..." js-eval
@@ -1712,7 +1712,7 @@ This performs fontification according to
`js--class-styles'."
nil))))))
(defun js-syntax-propertize (start end)
- ;; Javascript allows immediate regular expression objects, written /.../.
+ ;; JavaScript allows immediate regular expression objects, written /.../.
(goto-char start)
(js-syntax-propertize-regexp end)
(funcall
@@ -2710,7 +2710,7 @@ current buffer. Pushes a mark onto the tag ring just like
;;; MozRepl integration
(define-error 'js-moz-bad-rpc "Mozilla RPC Error") ;; '(timeout error))
-(define-error 'js-js-error "Javascript Error") ;; '(js-error error))
+(define-error 'js-js-error "JavaScript Error") ;; '(js-error error))
(defun js--wait-for-matching-output
(process regexp timeout &optional start)
@@ -3214,7 +3214,7 @@ with `js--js-encode-value'."
Inside the lexical scope of `with-js', `js?', `js!',
`js-new', `js-eval', `js-list', `js<', `js>', `js-get-service',
`js-create-instance', and `js-qi' are defined."
-
+ (declare (indent 0) (debug t))
`(progn
(js--js-enter-repl)
(unwind-protect
@@ -3391,7 +3391,7 @@ With argument, run even if no intervening GC has
happened."
(defun js-eval (js)
"Evaluate the JavaScript in JS and return JSON-decoded result."
- (interactive "MJavascript to evaluate: ")
+ (interactive "MJavaScript to evaluate: ")
(with-js
(let* ((content-window (js--js-content-window
(js--get-js-context)))
@@ -3431,11 +3431,8 @@ left-to-right."
(eq (cl-fifth window-info) 2))
do (push window-info windows))
- (cl-loop for window-info in windows
- for window = (cl-first window-info)
- collect (list (cl-second window-info)
- (cl-third window-info)
- window)
+ (cl-loop for (window title location) in windows
+ collect (list title location window)
for gbrowser = (js< window "gBrowser")
if (js-handle? gbrowser)
@@ -3668,7 +3665,7 @@ Change with `js-set-js-context'.")
(defun js-set-js-context (context)
"Set the JavaScript context to CONTEXT.
When called interactively, prompt for CONTEXT."
- (interactive (list (js--read-tab "Javascript Context: ")))
+ (interactive (list (js--read-tab "JavaScript Context: ")))
(setq js--js-context context))
(defun js--get-js-context ()
@@ -3682,7 +3679,7 @@ If one hasn't been set, or if it's stale, prompt for a
new one."
(`browser (not (js? (js< (cdr js--js-context)
"contentDocument"))))
(x (error "Unmatched case in js--get-js-context: %S" x))))
- (setq js--js-context (js--read-tab "Javascript Context: ")))
+ (setq js--js-context (js--read-tab "JavaScript Context: ")))
js--js-context))
(defun js--js-content-window (context)
@@ -3852,6 +3849,7 @@ If one hasn't been set, or if it's stale, prompt for a
new one."
comment-start-skip "\\(//+\\|/\\*+\\)\\s *")
(setq-local comment-line-break-function #'c-indent-new-comment-line)
(setq-local c-block-comment-start-regexp "/\\*")
+ (setq-local comment-multi-line t)
(setq-local electric-indent-chars
(append "{}():;," electric-indent-chars)) ;FIXME: js2-mode adds
"[]*".
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index d8262dd..90b5e4e 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -4693,7 +4693,8 @@ likely an invalid python file."
(let ((dedenter-pos (python-info-dedenter-statement-p)))
(when dedenter-pos
(goto-char dedenter-pos)
- (let* ((pairs '(("elif" "elif" "if")
+ (let* ((cur-line (line-beginning-position))
+ (pairs '(("elif" "elif" "if")
("else" "if" "elif" "except" "for" "while")
("except" "except" "try")
("finally" "else" "except" "try")))
@@ -4709,7 +4710,22 @@ likely an invalid python file."
(let ((indentation (current-indentation)))
(when (and (not (memq indentation collected-indentations))
(or (not collected-indentations)
- (< indentation (apply #'min
collected-indentations))))
+ (< indentation (apply #'min
collected-indentations)))
+ ;; There must be no line with indentation
+ ;; smaller than `indentation' (except for
+ ;; blank lines) between the found opening
+ ;; block and the current line, otherwise it
+ ;; is not an opening block.
+ (save-excursion
+ (forward-line)
+ (let ((no-back-indent t))
+ (save-match-data
+ (while (and (< (point) cur-line)
+ (setq no-back-indent
+ (or (>
(current-indentation) indentation)
+
(python-info-current-line-empty-p))))
+ (forward-line)))
+ no-back-indent)))
(setq collected-indentations
(cons indentation collected-indentations))
(when (member (match-string-no-properties 0)
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 7156348..8868343 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -2790,7 +2790,7 @@ local variable."
;; Iterate until we've moved the desired number of stmt ends
(while (not (= (cl-signum arg) 0))
;; if we're looking at the terminator, jump by 2
- (if (or (and (> 0 arg) (looking-back term))
+ (if (or (and (> 0 arg) (looking-back term nil))
(and (< 0 arg) (looking-at term)))
(setq n 2)
(setq n 1))
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index 0e8ff52..6c76d7e 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -126,6 +126,14 @@
;;; Code:
+(eval-when-compile (require 'cl))
+(eval-and-compile
+ ;; Before Emacs-24.4, `pushnew' expands to runtime calls to `cl-adjoin'
+ ;; even for relatively simple cases such as used here. We only test <25
+ ;; because it's easier and sufficient.
+ (when (or (featurep 'xemacs) (< emacs-major-version 25))
+ (require 'cl)))
+
;; Emacs 21+ handling
(defconst vhdl-emacs-21 (and (<= 21 emacs-major-version) (not (featurep
'xemacs)))
"Non-nil if GNU Emacs 21, 22, ... is used.")
@@ -14314,7 +14322,7 @@ of PROJECT."
(vhdl-scan-directory-contents dir-name project nil
(format "(%s/%s) " act-dir num-dir)
(cdr dir-list))
- (add-to-list 'dir-list-tmp (file-name-directory dir-name))
+ (pushnew (file-name-directory dir-name) dir-list-tmp :test #'equal)
(setq dir-list (cdr dir-list)
act-dir (1+ act-dir)))
(vhdl-aput 'vhdl-directory-alist project (list (nreverse dir-list-tmp)))
@@ -16406,8 +16414,8 @@ component instantiation."
(if (or (member constant-name single-list)
(member constant-name multi-list))
(progn (setq single-list (delete constant-name single-list))
- (add-to-list 'multi-list constant-name))
- (add-to-list 'single-list constant-name))
+ (pushnew constant-name multi-list :test #'equal))
+ (pushnew constant-name single-list :test #'equal))
(unless (match-string 1)
(setq generic-alist (cdr generic-alist)))
(vhdl-forward-syntactic-ws))
@@ -16433,12 +16441,12 @@ component instantiation."
(member signal-name multi-out-list))
(setq single-out-list (delete signal-name single-out-list))
(setq multi-out-list (delete signal-name multi-out-list))
- (add-to-list 'local-list signal-name))
+ (pushnew signal-name local-list :test #'equal))
((member signal-name single-in-list)
(setq single-in-list (delete signal-name single-in-list))
- (add-to-list 'multi-in-list signal-name))
+ (pushnew signal-name multi-in-list :test #'equal))
((not (member signal-name multi-in-list))
- (add-to-list 'single-in-list signal-name)))
+ (pushnew signal-name single-in-list :test #'equal)))
;; output signal
(cond
((member signal-name local-list)
@@ -16447,17 +16455,18 @@ component instantiation."
(member signal-name multi-in-list))
(setq single-in-list (delete signal-name single-in-list))
(setq multi-in-list (delete signal-name multi-in-list))
- (add-to-list 'local-list signal-name))
+ (pushnew signal-name local-list :test #'equal))
((member signal-name single-out-list)
(setq single-out-list (delete signal-name single-out-list))
- (add-to-list 'multi-out-list signal-name))
+ (pushnew signal-name multi-out-list :test #'equal))
((not (member signal-name multi-out-list))
- (add-to-list 'single-out-list signal-name))))
+ (pushnew signal-name single-out-list :test #'equal))))
(unless (match-string 1)
(setq port-alist (cdr port-alist)))
(vhdl-forward-syntactic-ws))
(push (list inst-name (nreverse constant-alist)
- (nreverse signal-alist)) inst-alist))
+ (nreverse signal-alist))
+ inst-alist))
;; prepare signal insertion
(vhdl-goto-marker arch-decl-pos)
(forward-line 1)
@@ -16534,14 +16543,14 @@ component instantiation."
generic-end-pos
(vhdl-compose-insert-generic constant-entry)))
(setq generic-pos (point-marker))
- (add-to-list 'written-list constant-name))
+ (pushnew constant-name written-list :test #'equal))
(t
(vhdl-goto-marker
(vhdl-max-marker generic-inst-pos generic-pos))
(setq generic-end-pos
(vhdl-compose-insert-generic constant-entry))
(setq generic-inst-pos (point-marker))
- (add-to-list 'written-list constant-name))))
+ (pushnew constant-name written-list :test #'equal))))
(setq constant-alist (cdr constant-alist)))
(when (/= constant-temp-pos generic-inst-pos)
(vhdl-goto-marker (vhdl-max-marker constant-temp-pos generic-pos))
@@ -16560,14 +16569,14 @@ component instantiation."
(vhdl-max-marker
port-end-pos (vhdl-compose-insert-port signal-entry)))
(setq port-in-pos (point-marker))
- (add-to-list 'written-list signal-name))
+ (pushnew signal-name written-list :test #'equal))
((member signal-name multi-out-list)
(vhdl-goto-marker (vhdl-max-marker port-out-pos port-in-pos))
(setq port-end-pos
(vhdl-max-marker
port-end-pos (vhdl-compose-insert-port signal-entry)))
(setq port-out-pos (point-marker))
- (add-to-list 'written-list signal-name))
+ (pushnew signal-name written-list :test #'equal))
((or (member signal-name single-in-list)
(member signal-name single-out-list))
(vhdl-goto-marker
@@ -16576,12 +16585,12 @@ component instantiation."
(vhdl-max-marker port-out-pos port-in-pos)))
(setq port-end-pos (vhdl-compose-insert-port signal-entry))
(setq port-inst-pos (point-marker))
- (add-to-list 'written-list signal-name))
+ (pushnew signal-name written-list :test #'equal))
((equal (upcase (nth 2 signal-entry)) "OUT")
(vhdl-goto-marker signal-pos)
(vhdl-compose-insert-signal signal-entry)
(setq signal-pos (point-marker))
- (add-to-list 'written-list signal-name)))
+ (pushnew signal-name written-list :test #'equal)))
(setq signal-alist (cdr signal-alist)))
(when (/= port-temp-pos port-inst-pos)
(vhdl-goto-marker
@@ -16932,7 +16941,7 @@ no project is defined."
"Remove duplicate elements from IN-LIST."
(let (out-list)
(while in-list
- (add-to-list 'out-list (car in-list))
+ (pushnew (car in-list) out-list :test #'equal)
(setq in-list (cdr in-list)))
out-list))
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index d8098c5..a8933b0 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -918,7 +918,7 @@ IGNORES is a list of glob patterns."
(grep-compute-defaults)
(defvar grep-find-template)
(defvar grep-highlight-matches)
- (let* ((grep-find-template (replace-regexp-in-string "-e " "-E "
+ (let* ((grep-find-template (replace-regexp-in-string "<C>" "<C> -E"
grep-find-template t t))
(grep-highlight-matches nil)
(command (xref--rgrep-command (xref--regexp-to-extended regexp)
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 2b1d22b..4f05739 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -82,7 +82,7 @@ See the command `recentf-save-list'."
recentf-mode
(recentf-load-list)))))
-(defcustom recentf-save-file-modes 384 ;; 0600
+(defcustom recentf-save-file-modes #o600
"Mode bits of recentf save file, as an integer, or nil.
If non-nil, after writing `recentf-save-file', set its mode bits to
this value. By default give R/W access only to the user who owns that
diff --git a/lisp/replace.el b/lisp/replace.el
index ff91734..a825040 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -1304,6 +1304,19 @@ If the value is nil, don't highlight the buffer names
specially."
:type 'face
:group 'matching)
+(defcustom list-matching-lines-current-line-face 'lazy-highlight
+ "Face used by \\[list-matching-lines] to highlight the current line."
+ :type 'face
+ :group 'matching
+ :version "26.1")
+
+(defcustom list-matching-lines-jump-to-current-line nil
+ "If non-nil, \\[list-matching-lines] shows the current line highlighted.
+Set the point right after such line when there are matches after it."
+:type 'boolean
+:group 'matching
+:version "26.1")
+
(defcustom list-matching-lines-prefix-face 'shadow
"Face used by \\[list-matching-lines] to show the prefix column.
If the face doesn't differ from the default face,
@@ -1360,7 +1373,15 @@ invoke `occur'."
"*")
(or unique-p (not interactive-p)))))
-(defun occur (regexp &optional nlines)
+;; Region limits when `occur' applies on a region.
+(defvar occur--region-start nil)
+(defvar occur--region-end nil)
+(defvar occur--matches-threshold nil)
+(defvar occur--orig-line nil)
+(defvar occur--orig-line-str nil)
+(defvar occur--final-pos nil)
+
+(defun occur (regexp &optional nlines region)
"Show all lines in the current buffer containing a match for REGEXP.
If a match spreads across multiple lines, all those lines are shown.
@@ -1369,9 +1390,17 @@ before if NLINES is negative.
NLINES defaults to `list-matching-lines-default-context-lines'.
Interactively it is the prefix arg.
+Optional arg REGION, if non-nil, mean restrict search to the
+specified region. Otherwise search the entire buffer.
+REGION must be a list of (START . END) positions as returned by
+`region-bounds'.
+
The lines are shown in a buffer named `*Occur*'.
It serves as a menu to find any of the occurrences in this buffer.
\\<occur-mode-map>\\[describe-mode] in that buffer will explain how.
+If `list-matching-lines-jump-to-current-line' is non-nil, then show
+the current line highlighted with `list-matching-lines-current-line-face'
+and set point at the first match after such line.
If REGEXP contains upper case characters (excluding those preceded by `\\')
and `search-upper-case' is non-nil, the matching is case-sensitive.
@@ -1386,8 +1415,30 @@ For example, providing \"defun\\s +\\(\\S +\\)\" for
REGEXP and
program. When there is no parenthesized subexpressions in REGEXP
the entire match is collected. In any case the searched buffer
is not modified."
- (interactive (occur-read-primary-args))
- (occur-1 regexp nlines (list (current-buffer))))
+ (interactive
+ (nconc (occur-read-primary-args)
+ (and (use-region-p) (list (region-bounds)))))
+ (let* ((start (and (caar region) (max (caar region) (point-min))))
+ (end (and (cdar region) (min (cdar region) (point-max))))
+ (in-region-p (or start end)))
+ (when in-region-p
+ (or start (setq start (point-min)))
+ (or end (setq end (point-max))))
+ (let ((occur--region-start start)
+ (occur--region-end end)
+ (occur--matches-threshold
+ (and in-region-p
+ (line-number-at-pos (min start end))))
+ (occur--orig-line
+ (line-number-at-pos (point)))
+ (occur--orig-line-str
+ (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position))))
+ (save-excursion ; If no matches `occur-1' doesn't restore the point.
+ (and in-region-p (narrow-to-region start end))
+ (occur-1 regexp nlines (list (current-buffer)))
+ (and in-region-p (widen))))))
(defvar ido-ignore-item-temp-list)
@@ -1482,7 +1533,8 @@ See also `multi-occur'."
(occur-mode))
(let ((inhibit-read-only t)
;; Don't generate undo entries for creation of the initial contents.
- (buffer-undo-list t))
+ (buffer-undo-list t)
+ (occur--final-pos nil))
(erase-buffer)
(let ((count
(if (stringp nlines)
@@ -1534,6 +1586,10 @@ See also `multi-occur'."
(if (= count 0)
(kill-buffer occur-buf)
(display-buffer occur-buf)
+ (when occur--final-pos
+ (set-window-point
+ (get-buffer-window occur-buf 'all-frames)
+ occur--final-pos))
(setq next-error-last-buffer occur-buf)
(setq buffer-read-only t)
(set-buffer-modified-p nil)
@@ -1545,19 +1601,26 @@ See also `multi-occur'."
(let ((global-lines 0) ;; total count of matching lines
(global-matches 0) ;; total count of matches
(coding nil)
- (case-fold-search case-fold))
+ (case-fold-search case-fold)
+ (in-region-p (and occur--region-start occur--region-end))
+ (multi-occur-p (cdr buffers)))
;; Map over all the buffers
(dolist (buf buffers)
(when (buffer-live-p buf)
(let ((lines 0) ;; count of matching lines
(matches 0) ;; count of matches
- (curr-line 1) ;; line count
+ (curr-line ;; line count
+ (or occur--matches-threshold 1))
+ (orig-line occur--orig-line)
+ (orig-line-str occur--orig-line-str)
+ (orig-line-shown-p)
(prev-line nil) ;; line number of prev match endpt
(prev-after-lines nil) ;; context lines of prev match
(matchbeg 0)
(origpt nil)
(begpt nil)
(endpt nil)
+ (finalpt nil)
(marker nil)
(curstring "")
(ret nil)
@@ -1658,6 +1721,18 @@ See also `multi-occur'."
(nth 0 ret))))
;; Actually insert the match display data
(with-current-buffer out-buf
+ (when (and list-matching-lines-jump-to-current-line
+ (not multi-occur-p)
+ (not orig-line-shown-p)
+ (>= curr-line orig-line))
+ (insert
+ (concat
+ (propertize
+ (format "%7d:%s" orig-line orig-line-str)
+ 'face list-matching-lines-current-line-face
+ 'mouse-face 'mode-line-highlight
+ 'help-echo "Current line") "\n"))
+ (setq orig-line-shown-p t finalpt (point)))
(insert data)))
(goto-char endpt))
(if endpt
@@ -1671,6 +1746,18 @@ See also `multi-occur'."
(forward-line 1))
(goto-char (point-max)))
(setq prev-line (1- curr-line)))
+ ;; Insert original line if haven't done yet.
+ (when (and list-matching-lines-jump-to-current-line
+ (not multi-occur-p)
+ (not orig-line-shown-p))
+ (with-current-buffer out-buf
+ (insert
+ (concat
+ (propertize
+ (format "%7d:%s" orig-line orig-line-str)
+ 'face list-matching-lines-current-line-face
+ 'mouse-face 'mode-line-highlight
+ 'help-echo "Current line") "\n"))))
;; Flush remaining context after-lines.
(when prev-after-lines
(with-current-buffer out-buf
@@ -1684,7 +1771,7 @@ See also `multi-occur'."
(let ((beg (point))
end)
(insert (propertize
- (format "%d match%s%s%s in buffer: %s\n"
+ (format "%d match%s%s%s in buffer: %s%s\n"
matches (if (= matches 1) "" "es")
;; Don't display the same number of lines
;; and matches in case of 1 match per line.
@@ -1694,13 +1781,21 @@ See also `multi-occur'."
;; Don't display regexp for multi-buffer.
(if (> (length buffers) 1)
"" (occur-regexp-descr regexp))
- (buffer-name buf))
+ (buffer-name buf)
+ (if in-region-p
+ (format " within region: %d-%d"
+ occur--region-start
+ occur--region-end)
+ ""))
'read-only t))
(setq end (point))
(add-text-properties beg end `(occur-title ,buf))
(when title-face
- (add-face-text-property beg end title-face)))
- (goto-char (point-min)))))))
+ (add-face-text-property beg end title-face))
+ (goto-char (if finalpt
+ (setq occur--final-pos
+ (cl-incf finalpt (- end beg)))
+ (point-min)))))))))
;; Display total match count and regexp for multi-buffer.
(when (and (not (zerop global-lines)) (> (length buffers) 1))
(goto-char (point-min))
diff --git a/lisp/shell.el b/lisp/shell.el
index 133771a..c8a8555 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -544,11 +544,14 @@ control whether input and output cause the window to
scroll to the end of the
buffer."
(setq comint-prompt-regexp shell-prompt-pattern)
(shell-completion-vars)
- (set (make-local-variable 'paragraph-separate) "\\'")
- (set (make-local-variable 'paragraph-start) comint-prompt-regexp)
- (set (make-local-variable 'font-lock-defaults) '(shell-font-lock-keywords t))
- (set (make-local-variable 'shell-dirstack) nil)
- (set (make-local-variable 'shell-last-dir) nil)
+ (setq-local paragraph-separate "\\'")
+ (setq-local paragraph-start comint-prompt-regexp)
+ (setq-local font-lock-defaults '(shell-font-lock-keywords t))
+ (setq-local shell-dirstack nil)
+ (setq-local shell-last-dir nil)
+ ;; People expect Shell mode to keep the last line of output at
+ ;; window bottom.
+ (setq-local scroll-conservatively 101)
(shell-dirtrack-mode 1)
;; By default, ansi-color applies faces using overlays. This is
diff --git a/lisp/simple.el b/lisp/simple.el
index f798cd4..441713a 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -5410,11 +5410,15 @@ also checks the value of `use-empty-active-region'."
;; region is active when there's no mark.
(progn (cl-assert (mark)) t)))
+(defun region-bounds ()
+ "Return the boundaries of the region as a list of (START . END) positions."
+ (funcall region-extract-function 'bounds))
+
(defun region-noncontiguous-p ()
"Return non-nil if the region contains several pieces.
An example is a rectangular region handled as a list of
separate contiguous regions for each line."
- (> (length (funcall region-extract-function 'bounds)) 1))
+ (> (length (region-bounds)) 1))
(defvar redisplay-unhighlight-region-function
(lambda (rol) (when (overlayp rol) (delete-overlay rol))))
@@ -7568,7 +7572,7 @@ More precisely, a char with closeparen syntax is
self-inserted.")
;; This executes C-g typed while Emacs is waiting for a command.
;; Quitting out of a program does not go through here;
-;; that happens in the QUIT macro at the C code level.
+;; that happens in the maybe_quit function at the C code level.
(defun keyboard-quit ()
"Signal a `quit' condition.
During execution of Lisp code, this character causes a quit directly.
diff --git a/lisp/subr.el b/lisp/subr.el
index 5377416..a204577 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -384,6 +384,126 @@ configuration."
(declare (compiler-macro internal--compiler-macro-cXXr))
(cdr (cdr x)))
+(defun caaar (x)
+ "Return the `car' of the `car' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (car (car x))))
+
+(defun caadr (x)
+ "Return the `car' of the `car' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (car (cdr x))))
+
+(defun cadar (x)
+ "Return the `car' of the `cdr' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (cdr (car x))))
+
+(defun caddr (x)
+ "Return the `car' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (cdr (cdr x))))
+
+(defun cdaar (x)
+ "Return the `cdr' of the `car' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (car (car x))))
+
+(defun cdadr (x)
+ "Return the `cdr' of the `car' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (car (cdr x))))
+
+(defun cddar (x)
+ "Return the `cdr' of the `cdr' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (cdr (car x))))
+
+(defun cdddr (x)
+ "Return the `cdr' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (cdr (cdr x))))
+
+(defun caaaar (x)
+ "Return the `car' of the `car' of the `car' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (car (car (car x)))))
+
+(defun caaadr (x)
+ "Return the `car' of the `car' of the `car' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (car (car (cdr x)))))
+
+(defun caadar (x)
+ "Return the `car' of the `car' of the `cdr' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (car (cdr (car x)))))
+
+(defun caaddr (x)
+ "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (car (cdr (cdr x)))))
+
+(defun cadaar (x)
+ "Return the `car' of the `cdr' of the `car' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (cdr (car (car x)))))
+
+(defun cadadr (x)
+ "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (cdr (car (cdr x)))))
+
+(defun caddar (x)
+ "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (cdr (cdr (car x)))))
+
+(defun cadddr (x)
+ "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (car (cdr (cdr (cdr x)))))
+
+(defun cdaaar (x)
+ "Return the `cdr' of the `car' of the `car' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (car (car (car x)))))
+
+(defun cdaadr (x)
+ "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (car (car (cdr x)))))
+
+(defun cdadar (x)
+ "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (car (cdr (car x)))))
+
+(defun cdaddr (x)
+ "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (car (cdr (cdr x)))))
+
+(defun cddaar (x)
+ "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (cdr (car (car x)))))
+
+(defun cddadr (x)
+ "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (cdr (car (cdr x)))))
+
+(defun cdddar (x)
+ "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (cdr (cdr (car x)))))
+
+(defun cddddr (x)
+ "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro internal--compiler-macro-cXXr))
+ (cdr (cdr (cdr (cdr x)))))
+
(defun last (list &optional n)
"Return the last link of LIST. Its car is the last element.
If LIST is nil, return nil.
@@ -1297,8 +1417,10 @@ be a list of the form returned by `event-start' and
`event-end'."
;; bug#23850
(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1")
(make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1")
+(make-obsolete 'string-make-unibyte "use `encode-coding-string'." "26.1")
(make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1")
(make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1")
+(make-obsolete 'string-make-multibyte "use `decode-coding-string'." "26.1")
(defun log10 (x)
"Return (log X 10), the log base 10 of X."
diff --git a/lisp/term.el b/lisp/term.el
index 5259571..063a6ea 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -2901,15 +2901,16 @@ See `term-prompt-regexp'."
((eq char ?\017)) ; Shift In - ignored
((eq char ?\^G) ;; (terminfo: bel)
(beep t))
- ((and (eq char ?\032)
- (not handled-ansi-message))
+ ((eq char ?\032)
(let ((end (string-match "\r?\n" str i)))
(if end
- (funcall term-command-hook
- (decode-coding-string
- (prog1 (substring str (1+ i) end)
- (setq i (1- (match-end 0))))
- locale-coding-system))
+ (progn
+ (unless handled-ansi-message
+ (funcall term-command-hook
+ (decode-coding-string
+ (substring str (1+ i) end)
+ locale-coding-system)))
+ (setq i (1- (match-end 0))))
(setq term-terminal-parameter (substring str i))
(setq term-terminal-state 4)
(setq i str-length))))
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index c81c3f6..0c7d76f 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -32,9 +32,11 @@
;;; Code:
+(require 'eww)
(require 'seq)
(require 'sgml-mode)
(require 'smie)
+(require 'subr-x)
(defgroup css nil
"Cascading Style Sheets (CSS) editing mode."
@@ -621,6 +623,12 @@ cannot be completed sensibly: `custom-ident',
(modify-syntax-entry ?- "_" st)
st))
+(defvar css-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap info-lookup-symbol] 'css-lookup-symbol)
+ map)
+ "Keymap used in `css-mode'.")
+
(eval-and-compile
(defconst css--uri-re
(concat
@@ -734,7 +742,30 @@ cannot be completed sensibly: `custom-ident',
(defconst css-smie-grammar
(smie-prec2->grammar
- (smie-precs->prec2 '((assoc ";") (assoc ",") (left ":")))))
+ (smie-precs->prec2
+ '((assoc ";")
+ ;; Colons that belong to a CSS property. These get a higher
+ ;; precedence than other colons, such as colons in selectors,
+ ;; which are represented by a plain ":" token.
+ (left ":-property")
+ (assoc ",")
+ (assoc ":")))))
+
+(defun css--colon-inside-selector-p ()
+ "Return t if point looks to be inside a CSS selector.
+This function is intended to be good enough to help SMIE during
+tokenization, but should not be regarded as a reliable function
+for determining whether point is within a selector."
+ (save-excursion
+ (re-search-forward "[{};)]" nil t)
+ (eq (char-before) ?\{)))
+
+(defun css--colon-inside-funcall ()
+ "Return t if point is inside a function call."
+ (when-let (opening-paren-pos (nth 1 (syntax-ppss)))
+ (save-excursion
+ (goto-char opening-paren-pos)
+ (eq (char-after) ?\())))
(defun css-smie--forward-token ()
(cond
@@ -748,7 +779,13 @@ cannot be completed sensibly: `custom-ident',
";")
((progn (forward-comment (point-max))
(looking-at "[;,:]"))
- (forward-char 1) (match-string 0))
+ (forward-char 1)
+ (if (equal (match-string 0) ":")
+ (if (or (css--colon-inside-selector-p)
+ (css--colon-inside-funcall))
+ ":"
+ ":-property")
+ (match-string 0)))
(t (smie-default-forward-token))))
(defun css-smie--backward-token ()
@@ -759,7 +796,13 @@ cannot be completed sensibly: `custom-ident',
((and (eq (char-before) ?\}) (scss-smie--not-interpolation-p)
(> pos (point))) ";")
((memq (char-before) '(?\; ?\, ?\:))
- (forward-char -1) (string (char-after)))
+ (forward-char -1)
+ (if (eq (char-after) ?\:)
+ (if (or (css--colon-inside-selector-p)
+ (css--colon-inside-funcall))
+ ":"
+ ":-property")
+ (string (char-after))))
(t (smie-default-backward-token)))))
(defun css-smie-rules (kind token)
@@ -1087,5 +1130,112 @@ pseudo-elements, pseudo-classes, at-rules, and
bang-rules."
(setq-local font-lock-defaults
(list (scss-font-lock-keywords) nil t)))
+
+
+(defvar css--mdn-lookup-history nil)
+
+(defcustom css-lookup-url-format
+ "https://developer.mozilla.org/en-US/docs/Web/CSS/%s?raw¯os";
+ "Format for a URL where CSS documentation can be found.
+The format should include a single \"%s\" substitution.
+The name of the CSS property, @-id, pseudo-class, or pseudo-element
+to look up will be substituted there."
+ :version "26.1"
+ :type 'string
+ :group 'css)
+
+(defun css--mdn-after-render ()
+ (setf header-line-format nil)
+ (goto-char (point-min))
+ (let ((window (get-buffer-window (current-buffer) 'visible)))
+ (when window
+ (when (re-search-forward "^Summary" nil 'move)
+ (beginning-of-line)
+ (set-window-start window (point))))))
+
+(defconst css--mdn-symbol-regexp
+ (concat "\\("
+ ;; @-ids.
+ "\\(@" (regexp-opt css-at-ids) "\\)"
+ "\\|"
+ ;; ;; Known properties.
+ (regexp-opt css-property-ids t)
+ "\\|"
+ ;; Pseudo-classes.
+ "\\(:" (regexp-opt css-pseudo-class-ids) "\\)"
+ "\\|"
+ ;; Pseudo-elements with either one or two ":"s.
+ "\\(::?" (regexp-opt css-pseudo-element-ids) "\\)"
+ "\\)")
+ "Regular expression to match the CSS symbol at point.")
+
+(defconst css--mdn-property-regexp
+ (concat "\\_<" (regexp-opt css-property-ids t) "\\s-*\\(?:\\=\\|:\\)")
+ "Regular expression to match a CSS property.")
+
+(defconst css--mdn-completion-list
+ (nconc
+ ;; @-ids.
+ (mapcar (lambda (atrule) (concat "@" atrule)) css-at-ids)
+ ;; Pseudo-classes.
+ (mapcar (lambda (class) (concat ":" class)) css-pseudo-class-ids)
+ ;; Pseudo-elements with either one or two ":"s.
+ (mapcar (lambda (elt) (concat ":" elt)) css-pseudo-element-ids)
+ (mapcar (lambda (elt) (concat "::" elt)) css-pseudo-element-ids)
+ ;; Properties.
+ css-property-ids)
+ "List of all symbols available for lookup via MDN.")
+
+(defun css--mdn-find-symbol ()
+ "A helper for `css-lookup-symbol' that finds the symbol at point.
+Returns the symbol, a string, or nil if none found."
+ (save-excursion
+ ;; Skip backward over a word first.
+ (skip-chars-backward "-[:alnum:] \t")
+ ;; Now skip ":" or "@" to see if it's a pseudo-element or at-id.
+ (skip-chars-backward "@:")
+ (if (looking-at css--mdn-symbol-regexp)
+ (match-string-no-properties 0)
+ (let ((bound (save-excursion
+ (beginning-of-line)
+ (point))))
+ (when (re-search-backward css--mdn-property-regexp bound t)
+ (match-string-no-properties 1))))))
+
+;;;###autoload
+(defun css-lookup-symbol (symbol)
+ "Display the CSS documentation for SYMBOL, as found on MDN.
+When this command is used interactively, it picks a default
+symbol based on the CSS text before point -- either an @-keyword,
+a property name, a pseudo-class, or a pseudo-element, depending
+on what is seen near point."
+ (interactive
+ (list
+ (let* ((sym (css--mdn-find-symbol))
+ (enable-recursive-minibuffers t)
+ (value (completing-read
+ (if sym
+ (format "Describe CSS symbol (default %s): " sym)
+ "Describe CSS symbol: ")
+ css--mdn-completion-list nil nil nil
+ 'css--mdn-lookup-history sym)))
+ (if (equal value "") sym value))))
+ (when symbol
+ ;; If we see a single-colon pseudo-element like ":after", turn it
+ ;; into "::after".
+ (when (and (eq (aref symbol 0) ?:)
+ (member (substring symbol 1) css-pseudo-element-ids))
+ (setq symbol (concat ":" symbol)))
+ (let ((url (format css-lookup-url-format symbol))
+ (buffer (get-buffer-create "*MDN CSS*")))
+ (save-selected-window
+ ;; Make sure to display the buffer before calling `eww', as
+ ;; that calls `pop-to-buffer-same-window'.
+ (switch-to-buffer-other-window buffer)
+ (with-current-buffer buffer
+ (eww-mode)
+ (add-hook 'eww-after-render-hook #'css--mdn-after-render nil t)
+ (eww url))))))
+
(provide 'css-mode)
;;; css-mode.el ends here
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index 63abd04..03da584 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -164,6 +164,8 @@ distribution. Mixed-case symbols are convenience aliases.")
(?U . "\\autocite*[][]{%l}")
(?a . "\\citeauthor{%l}")
(?A . "\\citeauthor*{%l}")
+ (?i . "\\citetitle{%l}")
+ (?I . "\\citetitle*{%l}")
(?y . "\\citeyear{%l}")
(?Y . "\\citeyear*{%l}")
(?n . "\\nocite{%l}")))
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index b7ad8e8..31c33e6 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -437,6 +437,9 @@ See
http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01990.html";)
(defconst diff-hunk-header-re
(concat "^\\(?:" diff-hunk-header-re-unified ".*\\|\\*\\{15\\}.*\n\\*\\*\\*
.+ \\*\\*\\*\\*\\|[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?\\)$"))
(defconst diff-file-header-re (concat "^\\(--- .+\n\\+\\+\\+ \\|\\*\\*\\*
.+\n--- \\|[^-+!<>address@hidden \n]\\).+\n" (substring diff-hunk-header-re 1)))
+
+(defconst diff-separator-re "^--+ ?$")
+
(defvar diff-narrowed-to nil)
(defun diff-hunk-style (&optional style)
@@ -501,7 +504,8 @@ See
http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01990.html";)
;; "index ", "old mode", "new mode", "new file mode" and
;; "deleted file mode" are output by git-diff.
(defconst diff-file-junk-re
- "diff \\|index \\|\\(?:deleted file\\|new\\(?: file\\)?\\|old\\) mode\\|===
modified file")
+ (concat "Index: \\|=\\{20,\\}\\|" ; SVN
+ "diff \\|index \\|\\(?:deleted file\\|new\\(?: file\\)?\\|old\\)
mode\\|=== modified file"))
;; If point is in a diff header, then return beginning
;; of hunk position otherwise return nil.
@@ -545,7 +549,8 @@ next hunk if TRY-HARDER is non-nil; otherwise signal an
error."
(error "Can't find the beginning of the hunk")))
((re-search-backward regexp nil t)) ; In the middle of a hunk.
((re-search-forward regexp nil t) ; At first hunk header.
- (forward-line 0))
+ (forward-line 0)
+ (point))
(t (error "Can't find the beginning of the hunk"))))))
(defun diff-unified-hunk-p ()
@@ -645,28 +650,36 @@ If the prefix ARG is given, restrict the view to the
current file instead."
(if arg (diff-bounds-of-file) (diff-bounds-of-hunk)))
(set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk)))
+(defun diff--some-hunks-p ()
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward diff-hunk-header-re nil t)))
+
(defun diff-hunk-kill ()
"Kill the hunk at point."
(interactive)
- (let* ((hunk-bounds (diff-bounds-of-hunk))
- (file-bounds (ignore-errors (diff-bounds-of-file)))
- ;; If the current hunk is the only one for its file, kill the
- ;; file header too.
- (bounds (if (and file-bounds
- (progn (goto-char (car file-bounds))
- (= (progn (diff-hunk-next) (point))
- (car hunk-bounds)))
- (progn (goto-char (cadr hunk-bounds))
- ;; bzr puts a newline after the last hunk.
- (while (looking-at "^\n")
- (forward-char 1))
- (= (point) (cadr file-bounds))))
- file-bounds
- hunk-bounds))
- (inhibit-read-only t))
- (apply 'kill-region bounds)
- (goto-char (car bounds))
- (diff-beginning-of-hunk t)))
+ (if (not (diff--some-hunks-p))
+ (error "No hunks")
+ (diff-beginning-of-hunk t)
+ (let* ((hunk-bounds (diff-bounds-of-hunk))
+ (file-bounds (ignore-errors (diff-bounds-of-file)))
+ ;; If the current hunk is the only one for its file, kill the
+ ;; file header too.
+ (bounds (if (and file-bounds
+ (progn (goto-char (car file-bounds))
+ (= (progn (diff-hunk-next) (point))
+ (car hunk-bounds)))
+ (progn (goto-char (cadr hunk-bounds))
+ ;; bzr puts a newline after the last hunk.
+ (while (looking-at "^\n")
+ (forward-char 1))
+ (= (point) (cadr file-bounds))))
+ file-bounds
+ hunk-bounds))
+ (inhibit-read-only t))
+ (apply 'kill-region bounds)
+ (goto-char (car bounds))
+ (ignore-errors (diff-beginning-of-hunk t)))))
(defun diff-beginning-of-file-and-junk ()
"Go to the beginning of file-related diff-info.
@@ -718,9 +731,12 @@ data such as \"Index: ...\" and such."
(defun diff-file-kill ()
"Kill current file's hunks."
(interactive)
- (let ((inhibit-read-only t))
- (apply 'kill-region (diff-bounds-of-file)))
- (diff-beginning-of-hunk t))
+ (if (not (diff--some-hunks-p))
+ (error "No hunks")
+ (diff-beginning-of-hunk t)
+ (let ((inhibit-read-only t))
+ (apply 'kill-region (diff-bounds-of-file)))
+ (ignore-errors (diff-beginning-of-hunk t))))
(defun diff-kill-junk ()
"Kill spurious empty diffs."
@@ -1535,15 +1551,20 @@ Only works for unified diffs."
(pcase (char-after)
(?\s (cl-decf before) (cl-decf after) t)
(?-
- (if (and (looking-at diff-file-header-re)
- (zerop before) (zerop after))
- ;; No need to query: this is a case where two patches
- ;; are concatenated and only counting the lines will
- ;; give the right result. Let's just add an empty
- ;; line so that our code which doesn't count lines
- ;; will not get confused.
- (progn (save-excursion (insert "\n")) nil)
- (cl-decf before) t))
+ (cond
+ ((and (looking-at diff-separator-re)
+ (zerop before) (zerop after))
+ nil)
+ ((and (looking-at diff-file-header-re)
+ (zerop before) (zerop after))
+ ;; No need to query: this is a case where two patches
+ ;; are concatenated and only counting the lines will
+ ;; give the right result. Let's just add an empty
+ ;; line so that our code which doesn't count lines
+ ;; will not get confused.
+ (save-excursion (insert "\n")) nil)
+ (t
+ (cl-decf before) t)))
(?+ (cl-decf after) t)
(_
(cond
@@ -1998,57 +2019,58 @@ Return new point, if it was moved."
"Highlight changes of hunk at point at a finer granularity."
(interactive)
(require 'smerge-mode)
- (save-excursion
- (diff-beginning-of-hunk t)
- (let* ((start (point))
- (style (diff-hunk-style)) ;Skips the hunk header as well.
- (beg (point))
- (props-c '((diff-mode . fine) (face diff-refine-changed)))
- (props-r '((diff-mode . fine) (face diff-refine-removed)))
- (props-a '((diff-mode . fine) (face diff-refine-added)))
- ;; Be careful to go back to `start' so diff-end-of-hunk gets
- ;; to read the hunk header's line info.
- (end (progn (goto-char start) (diff-end-of-hunk) (point))))
-
- (remove-overlays beg end 'diff-mode 'fine)
-
- (goto-char beg)
- (pcase style
- (`unified
- (while (re-search-forward "^-" end t)
- (let ((beg-del (progn (beginning-of-line) (point)))
- beg-add end-add)
- (when (and (diff--forward-while-leading-char ?- end)
- ;; Allow for "\ No newline at end of file".
- (progn (diff--forward-while-leading-char ?\\ end)
- (setq beg-add (point)))
- (diff--forward-while-leading-char ?+ end)
- (progn (diff--forward-while-leading-char ?\\ end)
- (setq end-add (point))))
- (smerge-refine-subst beg-del beg-add beg-add end-add
- nil 'diff-refine-preproc props-r
props-a)))))
- (`context
- (let* ((middle (save-excursion (re-search-forward "^---")))
- (other middle))
- (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
- (smerge-refine-subst (match-beginning 0) (match-end 0)
- (save-excursion
- (goto-char other)
- (re-search-forward "^\\(?:!.*\n\\)+" end)
- (setq other (match-end 0))
- (match-beginning 0))
- other
- (if diff-use-changed-face props-c)
- 'diff-refine-preproc
- (unless diff-use-changed-face props-r)
- (unless diff-use-changed-face props-a)))))
- (_ ;; Normal diffs.
- (let ((beg1 (1+ (point))))
- (when (re-search-forward "^---.*\n" end t)
- ;; It's a combined add&remove, so there's something to do.
- (smerge-refine-subst beg1 (match-beginning 0)
- (match-end 0) end
- nil 'diff-refine-preproc props-r
props-a))))))))
+ (when (diff--some-hunks-p)
+ (save-excursion
+ (diff-beginning-of-hunk t)
+ (let* ((start (point))
+ (style (diff-hunk-style)) ;Skips the hunk header as well.
+ (beg (point))
+ (props-c '((diff-mode . fine) (face diff-refine-changed)))
+ (props-r '((diff-mode . fine) (face diff-refine-removed)))
+ (props-a '((diff-mode . fine) (face diff-refine-added)))
+ ;; Be careful to go back to `start' so diff-end-of-hunk gets
+ ;; to read the hunk header's line info.
+ (end (progn (goto-char start) (diff-end-of-hunk) (point))))
+
+ (remove-overlays beg end 'diff-mode 'fine)
+
+ (goto-char beg)
+ (pcase style
+ (`unified
+ (while (re-search-forward "^-" end t)
+ (let ((beg-del (progn (beginning-of-line) (point)))
+ beg-add end-add)
+ (when (and (diff--forward-while-leading-char ?- end)
+ ;; Allow for "\ No newline at end of file".
+ (progn (diff--forward-while-leading-char ?\\ end)
+ (setq beg-add (point)))
+ (diff--forward-while-leading-char ?+ end)
+ (progn (diff--forward-while-leading-char ?\\ end)
+ (setq end-add (point))))
+ (smerge-refine-subst beg-del beg-add beg-add end-add
+ nil 'diff-refine-preproc props-r
props-a)))))
+ (`context
+ (let* ((middle (save-excursion (re-search-forward "^---")))
+ (other middle))
+ (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
+ (smerge-refine-subst (match-beginning 0) (match-end 0)
+ (save-excursion
+ (goto-char other)
+ (re-search-forward "^\\(?:!.*\n\\)+" end)
+ (setq other (match-end 0))
+ (match-beginning 0))
+ other
+ (if diff-use-changed-face props-c)
+ 'diff-refine-preproc
+ (unless diff-use-changed-face props-r)
+ (unless diff-use-changed-face props-a)))))
+ (_ ;; Normal diffs.
+ (let ((beg1 (1+ (point))))
+ (when (re-search-forward "^---.*\n" end t)
+ ;; It's a combined add&remove, so there's something to do.
+ (smerge-refine-subst beg1 (match-beginning 0)
+ (match-end 0) end
+ nil 'diff-refine-preproc props-r
props-a)))))))))
(defun diff-undo (&optional arg)
"Perform `undo', ignoring the buffer's read-only status."
diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el
index 95568b2..0235926 100644
--- a/lisp/vc/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -150,6 +150,26 @@ It needs to be killed when we quit the session.")
(defsubst ediff-get-symbol-from-alist (buf-type alist)
(cdr (assoc buf-type alist)))
+;; Vector of differences between the variants. Each difference is
+;; represented by a vector of two overlays plus a vector of fine diffs,
+;; plus a no-fine-diffs flag. The first overlay spans the
+;; difference region in the A buffer and the second overlays the diff in
+;; the B buffer. If a difference section is empty, the corresponding
+;; overlay's endpoints coincide.
+;;
+;; The precise form of a Difference Vector for one buffer is:
+;; [diff diff diff ...]
+;; where each diff has the form:
+;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-diff]
+;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...]
+;; no-fine-diffs-flag says if there are fine differences.
+;; state-of-difference is A, B, C, or nil, indicating which buffer is
+;; different from the other two (used only in 3-way jobs.
+(ediff-defvar-local ediff-difference-vector-A nil "")
+(ediff-defvar-local ediff-difference-vector-B nil "")
+(ediff-defvar-local ediff-difference-vector-C nil "")
+(ediff-defvar-local ediff-difference-vector-Ancestor nil "")
+;; A-list of diff vector types associated with buffer types
(defconst ediff-difference-vector-alist
'((A . ediff-difference-vector-A)
(B . ediff-difference-vector-B)
@@ -642,32 +662,6 @@ shown in brighter colors."
;;buffer-read-only
mode-line-format))
-;; Vector of differences between the variants. Each difference is
-;; represented by a vector of two overlays plus a vector of fine diffs,
-;; plus a no-fine-diffs flag. The first overlay spans the
-;; difference region in the A buffer and the second overlays the diff in
-;; the B buffer. If a difference section is empty, the corresponding
-;; overlay's endpoints coincide.
-;;
-;; The precise form of a Difference Vector for one buffer is:
-;; [diff diff diff ...]
-;; where each diff has the form:
-;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-diff]
-;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...]
-;; no-fine-diffs-flag says if there are fine differences.
-;; state-of-difference is A, B, C, or nil, indicating which buffer is
-;; different from the other two (used only in 3-way jobs.
-(ediff-defvar-local ediff-difference-vector-A nil "")
-(ediff-defvar-local ediff-difference-vector-B nil "")
-(ediff-defvar-local ediff-difference-vector-C nil "")
-(ediff-defvar-local ediff-difference-vector-Ancestor nil "")
-;; A-list of diff vector types associated with buffer types
-(defconst ediff-difference-vector-alist
- '((A . ediff-difference-vector-A)
- (B . ediff-difference-vector-B)
- (C . ediff-difference-vector-C)
- (Ancestor . ediff-difference-vector-Ancestor)))
-
;; [ status status status ...]
;; Each status: [state-of-merge state-of-ancestor]
;; state-of-merge is default-A, default-B, prefer-A, or prefer-B. It
diff --git a/lisp/xml.el b/lisp/xml.el
index cd801be..be2ac96 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -646,8 +646,10 @@ surpassed `xml-entity-expansion-limit'"))))
(defun xml-parse-attlist (&optional xml-ns)
"Return the attribute-list after point.
Leave point at the first non-blank character after the tag."
- (let ((attlist ())
- end-pos name)
+ (let* ((attlist ())
+ (symbol-qnames (eq (car-safe xml-ns) 'symbol-qnames))
+ (xml-ns (if symbol-qnames (cdr xml-ns) xml-ns))
+ end-pos name)
(skip-syntax-forward " ")
(while (looking-at (eval-when-compile
(concat "\\(" xml-name-re "\\)\\s-*=\\s-*")))
diff --git a/src/alloc.c b/src/alloc.c
index 1a6d4e2..62f4366 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -2872,45 +2872,15 @@ usage: (list &rest OBJECTS) */)
DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
doc: /* Return a newly created list of length LENGTH, with each element
being INIT. */)
- (register Lisp_Object length, Lisp_Object init)
+ (Lisp_Object length, Lisp_Object init)
{
- register Lisp_Object val;
- register EMACS_INT size;
-
+ Lisp_Object val = Qnil;
CHECK_NATNUM (length);
- size = XFASTINT (length);
- val = Qnil;
- while (size > 0)
+ for (EMACS_INT size = XFASTINT (length); 0 < size; size--)
{
val = Fcons (init, val);
- --size;
-
- if (size > 0)
- {
- val = Fcons (init, val);
- --size;
-
- if (size > 0)
- {
- val = Fcons (init, val);
- --size;
-
- if (size > 0)
- {
- val = Fcons (init, val);
- --size;
-
- if (size > 0)
- {
- val = Fcons (init, val);
- --size;
- }
- }
- }
- }
-
- QUIT;
+ rarely_quit (size);
}
return val;
@@ -4917,12 +4887,19 @@ mark_memory (void *start, void *end)
}
}
-#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
+#ifndef HAVE___BUILTIN_UNWIND_INIT
+
+# ifdef GC_SETJMP_WORKS
+static void
+test_setjmp (void)
+{
+}
+# else
static bool setjmp_tested_p;
static int longjmps_done;
-#define SETJMP_WILL_LIKELY_WORK "\
+# define SETJMP_WILL_LIKELY_WORK "\
\n\
Emacs garbage collector has been changed to use conservative stack\n\
marking. Emacs has determined that the method it uses to do the\n\
@@ -4935,7 +4912,7 @@ verify that the methods used are appropriate for your
system.\n\
Please mail the result to <address@hidden>.\n\
"
-#define SETJMP_WILL_NOT_WORK "\
+# define SETJMP_WILL_NOT_WORK "\
\n\
Emacs garbage collector has been changed to use conservative stack\n\
marking. Emacs has determined that the default method it uses to do the\n\
@@ -4961,6 +4938,9 @@ Please mail the result to <address@hidden>.\n\
static void
test_setjmp (void)
{
+ if (setjmp_tested_p)
+ return;
+ setjmp_tested_p = true;
char buf[10];
register int x;
sys_jmp_buf jbuf;
@@ -4997,9 +4977,60 @@ test_setjmp (void)
if (longjmps_done == 1)
sys_longjmp (jbuf, 1);
}
+# endif /* ! GC_SETJMP_WORKS */
+#endif /* ! HAVE___BUILTIN_UNWIND_INIT */
-#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
+/* The type of an object near the stack top, whose address can be used
+ as a stack scan limit. */
+typedef union
+{
+ /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT,
+ jmp_buf may not be aligned enough on darwin-ppc64. */
+ max_align_t o;
+#ifndef HAVE___BUILTIN_UNWIND_INIT
+ sys_jmp_buf j;
+ char c;
+#endif
+} stacktop_sentry;
+
+/* Force callee-saved registers and register windows onto the stack.
+ Use the platform-defined __builtin_unwind_init if available,
+ obviating the need for machine dependent methods. */
+#ifndef HAVE___BUILTIN_UNWIND_INIT
+# ifdef __sparc__
+ /* This trick flushes the register windows so that all the state of
+ the process is contained in the stack.
+ FreeBSD does not have a ta 3 handler, so handle it specially.
+ FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is
+ needed on ia64 too. See mach_dep.c, where it also says inline
+ assembler doesn't work with relevant proprietary compilers. */
+# if defined __sparc64__ && defined __FreeBSD__
+# define __builtin_unwind_init() asm ("flushw")
+# else
+# define __builtin_unwind_init() asm ("ta 3")
+# endif
+# else
+# define __builtin_unwind_init() ((void) 0)
+# endif
+#endif
+/* Set *P to the address of the top of the stack. This must be a
+ macro, not a function, so that it is executed in the caller’s
+ environment. It is not inside a do-while so that its storage
+ survives the macro. */
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+# define SET_STACK_TOP_ADDRESS(p) \
+ stacktop_sentry sentry; \
+ __builtin_unwind_init (); \
+ *(p) = &sentry
+#else
+# define SET_STACK_TOP_ADDRESS(p) \
+ stacktop_sentry sentry; \
+ __builtin_unwind_init (); \
+ test_setjmp (); \
+ sys_setjmp (sentry.j); \
+ *(p) = &sentry + (stack_bottom < &sentry.c)
+#endif
/* Mark live Lisp objects on the C stack.
@@ -5011,12 +5042,7 @@ test_setjmp (void)
We have to mark Lisp objects in CPU registers that can hold local
variables or are used to pass parameters.
- If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
- something that either saves relevant registers on the stack, or
- calls mark_maybe_object passing it each register's contents.
-
- If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
- implementation assumes that calling setjmp saves registers we need
+ This code assumes that calling setjmp saves registers we need
to see in a jmp_buf which itself lies on the stack. This doesn't
have to be true! It must be verified for each system, possibly
by taking a look at the source code of setjmp.
@@ -5080,62 +5106,9 @@ flush_stack_call_func (void (*func) (void *arg), void
*arg)
{
void *end;
struct thread_state *self = current_thread;
-
-#ifdef HAVE___BUILTIN_UNWIND_INIT
- /* Force callee-saved registers and register windows onto the stack.
- This is the preferred method if available, obviating the need for
- machine dependent methods. */
- __builtin_unwind_init ();
- end = &end;
-#else /* not HAVE___BUILTIN_UNWIND_INIT */
-#ifndef GC_SAVE_REGISTERS_ON_STACK
- /* jmp_buf may not be aligned enough on darwin-ppc64 */
- union aligned_jmpbuf {
- Lisp_Object o;
- sys_jmp_buf j;
- } j;
- volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom;
-#endif
- /* This trick flushes the register windows so that all the state of
- the process is contained in the stack. */
- /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
- needed on ia64 too. See mach_dep.c, where it also says inline
- assembler doesn't work with relevant proprietary compilers. */
-#ifdef __sparc__
-#if defined (__sparc64__) && defined (__FreeBSD__)
- /* FreeBSD does not have a ta 3 handler. */
- asm ("flushw");
-#else
- asm ("ta 3");
-#endif
-#endif
-
- /* Save registers that we need to see on the stack. We need to see
- registers used to hold register variables and registers used to
- pass parameters. */
-#ifdef GC_SAVE_REGISTERS_ON_STACK
- GC_SAVE_REGISTERS_ON_STACK (end);
-#else /* not GC_SAVE_REGISTERS_ON_STACK */
-
-#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
- setjmp will definitely work, test it
- and print a message with the result
- of the test. */
- if (!setjmp_tested_p)
- {
- setjmp_tested_p = 1;
- test_setjmp ();
- }
-#endif /* GC_SETJMP_WORKS */
-
- sys_setjmp (j.j);
- end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
-#endif /* not GC_SAVE_REGISTERS_ON_STACK */
-#endif /* not HAVE___BUILTIN_UNWIND_INIT */
-
+ SET_STACK_TOP_ADDRESS (&end);
self->stack_top = end;
- (*func) (arg);
-
+ func (arg);
eassert (current_thread == self);
}
@@ -5464,6 +5437,38 @@ make_pure_vector (ptrdiff_t len)
return new;
}
+/* Copy all contents and parameters of TABLE to a new table allocated
+ from pure space, return the purified table. */
+static struct Lisp_Hash_Table *
+purecopy_hash_table (struct Lisp_Hash_Table *table)
+{
+ eassert (NILP (table->weak));
+ eassert (!NILP (table->pure));
+
+ struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
+ struct hash_table_test pure_test = table->test;
+
+ /* Purecopy the hash table test. */
+ pure_test.name = purecopy (table->test.name);
+ pure_test.user_hash_function = purecopy (table->test.user_hash_function);
+ pure_test.user_cmp_function = purecopy (table->test.user_cmp_function);
+
+ pure->test = pure_test;
+ pure->header = table->header;
+ pure->weak = purecopy (Qnil);
+ pure->rehash_size = purecopy (table->rehash_size);
+ pure->rehash_threshold = purecopy (table->rehash_threshold);
+ pure->hash = purecopy (table->hash);
+ pure->next = purecopy (table->next);
+ pure->next_free = purecopy (table->next_free);
+ pure->index = purecopy (table->index);
+ pure->count = table->count;
+ pure->key_and_value = purecopy (table->key_and_value);
+ pure->pure = purecopy (table->pure);
+
+ return pure;
+}
+
DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
doc: /* Make a copy of object OBJ in pure storage.
Recursively copies contents of vectors and cons cells.
@@ -5472,14 +5477,20 @@ Does not copy symbols. Copies strings without text
properties. */)
{
if (NILP (Vpurify_flag))
return obj;
- else if (MARKERP (obj) || OVERLAYP (obj)
- || HASH_TABLE_P (obj) || SYMBOLP (obj))
+ else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj))
/* Can't purify those. */
return obj;
else
return purecopy (obj);
}
+/* Pinned objects are marked before every GC cycle. */
+static struct pinned_object
+{
+ Lisp_Object object;
+ struct pinned_object *next;
+} *pinned_objects;
+
static Lisp_Object
purecopy (Lisp_Object obj)
{
@@ -5507,7 +5518,27 @@ purecopy (Lisp_Object obj)
obj = make_pure_string (SSDATA (obj), SCHARS (obj),
SBYTES (obj),
STRING_MULTIBYTE (obj));
- else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj))
+ else if (HASH_TABLE_P (obj))
+ {
+ struct Lisp_Hash_Table *table = XHASH_TABLE (obj);
+ /* Do not purify hash tables which haven't been defined with
+ :purecopy as non-nil or are weak - they aren't guaranteed to
+ not change. */
+ if (!NILP (table->weak) || NILP (table->pure))
+ {
+ /* Instead, add the hash table to the list of pinned objects,
+ so that it will be marked during GC. */
+ struct pinned_object *o = xmalloc (sizeof *o);
+ o->object = obj;
+ o->next = pinned_objects;
+ pinned_objects = o;
+ return obj; /* Don't hash cons it. */
+ }
+
+ struct Lisp_Hash_Table *h = purecopy_hash_table (table);
+ XSET_HASH_TABLE (obj, h);
+ }
+ else if (COMPILEDP (obj) || VECTORP (obj))
{
struct Lisp_Vector *objp = XVECTOR (obj);
ptrdiff_t nbytes = vector_nbytes (objp);
@@ -5724,6 +5755,13 @@ compact_undo_list (Lisp_Object list)
}
static void
+mark_pinned_objects (void)
+{
+ for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next)
+ mark_object (pobj->object);
+}
+
+static void
mark_pinned_symbols (void)
{
struct symbol_block *sblk;
@@ -5843,6 +5881,7 @@ garbage_collect_1 (void *end)
for (i = 0; i < staticidx; i++)
mark_object (*staticvec[i]);
+ mark_pinned_objects ();
mark_pinned_symbols ();
mark_terminals ();
mark_kboards ();
@@ -6011,58 +6050,7 @@ See Info node `(elisp)Garbage Collection'. */)
(void)
{
void *end;
-
-#ifdef HAVE___BUILTIN_UNWIND_INIT
- /* Force callee-saved registers and register windows onto the stack.
- This is the preferred method if available, obviating the need for
- machine dependent methods. */
- __builtin_unwind_init ();
- end = &end;
-#else /* not HAVE___BUILTIN_UNWIND_INIT */
-#ifndef GC_SAVE_REGISTERS_ON_STACK
- /* jmp_buf may not be aligned enough on darwin-ppc64 */
- union aligned_jmpbuf {
- Lisp_Object o;
- sys_jmp_buf j;
- } j;
- volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
-#endif
- /* This trick flushes the register windows so that all the state of
- the process is contained in the stack. */
- /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
- needed on ia64 too. See mach_dep.c, where it also says inline
- assembler doesn't work with relevant proprietary compilers. */
-#ifdef __sparc__
-#if defined (__sparc64__) && defined (__FreeBSD__)
- /* FreeBSD does not have a ta 3 handler. */
- asm ("flushw");
-#else
- asm ("ta 3");
-#endif
-#endif
-
- /* Save registers that we need to see on the stack. We need to see
- registers used to hold register variables and registers used to
- pass parameters. */
-#ifdef GC_SAVE_REGISTERS_ON_STACK
- GC_SAVE_REGISTERS_ON_STACK (end);
-#else /* not GC_SAVE_REGISTERS_ON_STACK */
-
-#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
- setjmp will definitely work, test it
- and print a message with the result
- of the test. */
- if (!setjmp_tested_p)
- {
- setjmp_tested_p = 1;
- test_setjmp ();
- }
-#endif /* GC_SETJMP_WORKS */
-
- sys_setjmp (j.j);
- end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
-#endif /* not GC_SAVE_REGISTERS_ON_STACK */
-#endif /* not HAVE___BUILTIN_UNWIND_INIT */
+ SET_STACK_TOP_ADDRESS (&end);
return garbage_collect_1 (end);
}
@@ -7372,9 +7360,6 @@ init_alloc_once (void)
void
init_alloc (void)
{
-#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
- setjmp_tested_p = longjmps_done = 0;
-#endif
Vgc_elapsed = make_float (0.0);
gcs_done = 0;
diff --git a/src/atimer.c b/src/atimer.c
index 7f09980..5feb1f6 100644
--- a/src/atimer.c
+++ b/src/atimer.c
@@ -20,6 +20,7 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
#include <stdio.h>
#include "lisp.h"
+#include "keyboard.h"
#include "syssignal.h"
#include "systime.h"
#include "atimer.h"
diff --git a/src/buffer.c b/src/buffer.c
index 0a317ad..713c1e5 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -420,19 +420,16 @@ followed by the rest of the buffers. */)
}
/* Like Fassoc, but use Fstring_equal to compare
- (which ignores text properties),
- and don't ever QUIT. */
+ (which ignores text properties), and don't ever quit. */
static Lisp_Object
-assoc_ignore_text_properties (register Lisp_Object key, Lisp_Object list)
+assoc_ignore_text_properties (Lisp_Object key, Lisp_Object list)
{
- register Lisp_Object tail;
+ Lisp_Object tail;
for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- register Lisp_Object elt, tem;
- elt = XCAR (tail);
- tem = Fstring_equal (Fcar (elt), key);
- if (!NILP (tem))
+ Lisp_Object elt = XCAR (tail);
+ if (!NILP (Fstring_equal (Fcar (elt), key)))
return elt;
}
return Qnil;
diff --git a/src/bytecode.c b/src/bytecode.c
index a64bc17..0f7420c 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -679,7 +679,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
{
quitcounter = 1;
maybe_gc ();
- QUIT;
+ maybe_quit ();
}
pc += op;
NEXT;
@@ -841,11 +841,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
{
Lisp_Object v2 = POP, v1 = TOP;
CHECK_NUMBER (v1);
- EMACS_INT n = XINT (v1);
- immediate_quit = true;
- while (--n >= 0 && CONSP (v2))
- v2 = XCDR (v2);
- immediate_quit = false;
+ for (EMACS_INT n = XINT (v1); 0 < n && CONSP (v2); n--)
+ {
+ v2 = XCDR (v2);
+ rarely_quit (n);
+ }
TOP = CAR (v2);
NEXT;
}
@@ -1275,11 +1275,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object
vector, Lisp_Object maxdepth,
/* Exchange args and then do nth. */
Lisp_Object v2 = POP, v1 = TOP;
CHECK_NUMBER (v2);
- EMACS_INT n = XINT (v2);
- immediate_quit = true;
- while (--n >= 0 && CONSP (v1))
- v1 = XCDR (v1);
- immediate_quit = false;
+ for (EMACS_INT n = XINT (v2); 0 < n && CONSP (v1); n--)
+ {
+ v1 = XCDR (v1);
+ rarely_quit (n);
+ }
TOP = CAR (v1);
}
else
diff --git a/src/callint.c b/src/callint.c
index 565fac8..d964548 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -794,7 +794,7 @@ invoke it. If KEYS is omitted or nil, the return value of
}
unbind_to (speccount, Qnil);
- QUIT;
+ maybe_quit ();
args[0] = Qfuncall_interactively;
args[1] = function;
diff --git a/src/callproc.c b/src/callproc.c
index 90c15de..84324c4 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -198,11 +198,11 @@ call_process_cleanup (Lisp_Object buffer)
{
kill (-synch_process_pid, SIGINT);
message1 ("Waiting for process to die...(type C-g again to kill it
instantly)");
- immediate_quit = 1;
- QUIT;
+
+ /* This will quit on C-g. */
wait_for_termination (synch_process_pid, 0, 1);
+
synch_process_pid = 0;
- immediate_quit = 0;
message1 ("Waiting for process to die...done");
}
#endif /* !MSDOS */
@@ -726,9 +726,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
process_coding.src_multibyte = 0;
}
- immediate_quit = 1;
- QUIT;
-
if (0 <= fd0)
{
enum { CALLPROC_BUFFER_SIZE_MIN = 16 * 1024 };
@@ -749,8 +746,8 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
nread = carryover;
while (nread < bufsize - 1024)
{
- int this_read = emacs_read (fd0, buf + nread,
- bufsize - nread);
+ int this_read = emacs_read_quit (fd0, buf + nread,
+ bufsize - nread);
if (this_read < 0)
goto give_up;
@@ -769,7 +766,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
}
/* Now NREAD is the total amount of data in the buffer. */
- immediate_quit = 0;
if (!nread)
;
@@ -842,8 +838,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
we should have already detected a coding system. */
display_on_the_fly = true;
}
- immediate_quit = true;
- QUIT;
}
give_up: ;
@@ -860,8 +854,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
wait_for_termination (pid, &status, fd0 < 0);
#endif
- immediate_quit = 0;
-
/* Don't kill any children that the subprocess may have left behind
when exiting. */
synch_process_pid = 0;
diff --git a/src/category.c b/src/category.c
index e5d261c..ff287a4 100644
--- a/src/category.c
+++ b/src/category.c
@@ -67,7 +67,7 @@ hash_get_category_set (Lisp_Object table, Lisp_Object
category_set)
make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil));
+ Qnil, Qnil));
h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
i = hash_lookup (h, category_set, &hash);
if (i >= 0)
diff --git a/src/ccl.c b/src/ccl.c
index c172fc6..90bd2f4 100644
--- a/src/ccl.c
+++ b/src/ccl.c
@@ -1993,7 +1993,7 @@ programs. */)
: 0);
ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil);
- QUIT;
+ maybe_quit ();
if (ccl.status != CCL_STAT_SUCCESS)
error ("Error in CCL program at %dth code", ccl.ic);
diff --git a/src/decompress.c b/src/decompress.c
index f6628d5..a53a66d 100644
--- a/src/decompress.c
+++ b/src/decompress.c
@@ -186,7 +186,7 @@ This function can be called only in unibyte buffers. */)
decompressed = avail_out - stream.avail_out;
insert_from_gap (decompressed, decompressed, 0);
unwind_data.nbytes += decompressed;
- QUIT;
+ maybe_quit ();
}
while (inflate_status == Z_OK);
diff --git a/src/dired.c b/src/dired.c
index bf10f17..5ea00fb 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -139,7 +139,7 @@ read_dirent (DIR *dir, Lisp_Object dirname)
#endif
report_file_error ("Reading directory", dirname);
}
- QUIT;
+ maybe_quit ();
}
}
@@ -248,14 +248,11 @@ directory_files_internal (Lisp_Object directory,
Lisp_Object full,
/* Now that we have unwind_protect in place, we might as well
allow matching to be interrupted. */
- immediate_quit = 1;
- QUIT;
+ maybe_quit ();
bool wanted = (NILP (match)
|| re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0);
- immediate_quit = 0;
-
if (wanted)
{
if (!NILP (full))
@@ -508,7 +505,7 @@ file_name_completion (Lisp_Object file, Lisp_Object
dirname, bool all_flag,
ptrdiff_t len = dirent_namelen (dp);
bool canexclude = 0;
- QUIT;
+ maybe_quit ();
if (len < SCHARS (encoded_file)
|| (scmp (dp->d_name, SSDATA (encoded_file),
SCHARS (encoded_file))
diff --git a/src/dispextern.h b/src/dispextern.h
index 51222e6..eb71a82 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -3263,6 +3263,7 @@ void move_it_past_eol (struct it *);
void move_it_in_display_line (struct it *it,
ptrdiff_t to_charpos, int to_x,
enum move_operation_enum op);
+int partial_line_height (struct it *it_origin);
bool in_display_vector_p (struct it *);
int frame_mode_line_height (struct frame *);
extern bool redisplaying_p;
diff --git a/src/doc.c b/src/doc.c
index 361d09a..1e7e3fc 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -186,7 +186,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool
definition)
If we read the same block last time, maybe skip this? */
if (space_left > 1024 * 8)
space_left = 1024 * 8;
- nread = emacs_read (fd, p, space_left);
+ nread = emacs_read_quit (fd, p, space_left);
if (nread < 0)
report_file_error ("Read error on documentation file", file);
p[nread] = 0;
@@ -590,16 +590,15 @@ the same file name is found in the `doc-directory'. */)
Vdoc_file_name = filename;
filled = 0;
pos = 0;
- while (1)
+ while (true)
{
- register char *end;
if (filled < 512)
- filled += emacs_read (fd, &buf[filled], sizeof buf - 1 - filled);
+ filled += emacs_read_quit (fd, &buf[filled], sizeof buf - 1 - filled);
if (!filled)
break;
buf[filled] = 0;
- end = buf + (filled < 512 ? filled : filled - 128);
+ char *end = buf + (filled < 512 ? filled : filled - 128);
p = memchr (buf, '\037', end - buf);
/* p points to ^_Ffunctionname\n or ^_Vvarname\n or ^_Sfilename\n. */
if (p)
diff --git a/src/editfns.c b/src/editfns.c
index bee3bbc..4618164 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -2695,7 +2695,7 @@ called interactively, INHERIT is t. */)
string[i] = str[i % len];
while (n > stringlen)
{
- QUIT;
+ maybe_quit ();
if (!NILP (inherit))
insert_and_inherit (string, stringlen);
else
@@ -3060,8 +3060,6 @@ determines whether case is significant or ignored. */)
characters, not just the bytes. */
int c1, c2;
- QUIT;
-
if (! NILP (BVAR (bp1, enable_multibyte_characters)))
{
c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
@@ -3093,12 +3091,12 @@ determines whether case is significant or ignored. */)
c1 = char_table_translate (trt, c1);
c2 = char_table_translate (trt, c2);
}
- if (c1 < c2)
- return make_number (- 1 - chars);
- if (c1 > c2)
- return make_number (chars + 1);
+
+ if (c1 != c2)
+ return make_number (c1 < c2 ? -1 - chars : chars + 1);
chars++;
+ rarely_quit (chars);
}
/* The strings match as far as they go.
diff --git a/src/emacs-module.c b/src/emacs-module.c
index e22c7dc..69fa5c8 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -1016,7 +1016,7 @@ syms_of_module (void)
= make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil);
+ Qnil, Qnil);
Funintern (Qmodule_refs_hash, Qnil);
DEFSYM (Qmodule_environments, "module-environments");
diff --git a/src/emacs.c b/src/emacs.c
index 28b395c..3083d0d 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -688,7 +688,7 @@ main (int argc, char **argv)
dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0
|| strcmp (argv[argc - 1], "bootstrap") == 0 );
- generating_ldefs_boot = getenv ("GENERATE_LDEFS_BOOT");
+ generating_ldefs_boot = !!getenv ("GENERATE_LDEFS_BOOT");
/* True if address randomization interferes with memory allocation. */
diff --git a/src/eval.c b/src/eval.c
index c05c8d8..22b02b4 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -856,11 +856,9 @@ usage: (let* VARLIST BODY...) */)
lexenv = Vinternal_interpreter_environment;
- varlist = XCAR (args);
- CHECK_LIST (varlist);
- while (CONSP (varlist))
+ for (varlist = XCAR (args); CONSP (varlist); varlist = XCDR (varlist))
{
- QUIT;
+ maybe_quit ();
elt = XCAR (varlist);
if (SYMBOLP (elt))
@@ -894,9 +892,8 @@ usage: (let* VARLIST BODY...) */)
}
else
specbind (var, val);
-
- varlist = XCDR (varlist);
}
+ CHECK_LIST_END (varlist, XCAR (args));
val = Fprogn (XCDR (args));
return unbind_to (count, val);
@@ -928,7 +925,7 @@ usage: (let VARLIST BODY...) */)
for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
{
- QUIT;
+ maybe_quit ();
elt = XCAR (varlist);
if (SYMBOLP (elt))
temps [argnum++] = Qnil;
@@ -981,7 +978,7 @@ usage: (while TEST BODY...) */)
body = XCDR (args);
while (!NILP (eval_sub (test)))
{
- QUIT;
+ maybe_quit ();
prog_ignore (body);
}
@@ -1014,7 +1011,7 @@ definitions to shadow the loaded ones for use in file
byte-compilation. */)
until we get a symbol that is not an alias. */
while (SYMBOLP (def))
{
- QUIT;
+ maybe_quit ();
sym = def;
tem = Fassq (sym, environment);
if (NILP (tem))
@@ -1134,7 +1131,6 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
/* Restore certain special C variables. */
set_poll_suppress_count (catch->poll_suppress_count);
unblock_input_to (catch->interrupt_input_blocked);
- immediate_quit = 0;
do
{
@@ -1453,7 +1449,7 @@ static Lisp_Object find_handler_clause (Lisp_Object,
Lisp_Object);
static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig,
Lisp_Object data);
-void
+static void
process_quit_flag (void)
{
Lisp_Object flag = Vquit_flag;
@@ -1465,6 +1461,28 @@ process_quit_flag (void)
quit ();
}
+/* Check quit-flag and quit if it is non-nil. Typing C-g does not
+ directly cause a quit; it only sets Vquit_flag. So the program
+ needs to call maybe_quit at times when it is safe to quit. Every
+ loop that might run for a long time or might not exit ought to call
+ maybe_quit at least once, at a safe place. Unless that is
+ impossible, of course. But it is very desirable to avoid creating
+ loops where maybe_quit is impossible.
+
+ If quit-flag is set to `kill-emacs' the SIGINT handler has received
+ a request to exit Emacs when it is safe to do.
+
+ When not quitting, process any pending signals. */
+
+void
+maybe_quit (void)
+{
+ if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
+ process_quit_flag ();
+ else if (pending_signals)
+ process_pending_signals ();
+}
+
DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
doc: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
This function does not return.
@@ -1508,10 +1526,9 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object
data, bool keyboard_quit)
Lisp_Object string;
Lisp_Object real_error_symbol
= (NILP (error_symbol) ? Fcar (data) : error_symbol);
- register Lisp_Object clause = Qnil;
+ Lisp_Object clause = Qnil;
struct handler *h;
- immediate_quit = 0;
if (gc_in_progress || waiting_for_input)
emacs_abort ();
@@ -2129,7 +2146,7 @@ eval_sub (Lisp_Object form)
if (!CONSP (form))
return form;
- QUIT;
+ maybe_quit ();
maybe_gc ();
@@ -2715,7 +2732,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
Lisp_Object val;
ptrdiff_t count;
- QUIT;
+ maybe_quit ();
if (++lisp_eval_depth > max_lisp_eval_depth)
{
@@ -2960,7 +2977,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
bool previous_optional_or_rest = false;
for (; CONSP (syms_left); syms_left = XCDR (syms_left))
{
- QUIT;
+ maybe_quit ();
next = XCAR (syms_left);
if (!SYMBOLP (next))
@@ -3098,7 +3115,7 @@ lambda_arity (Lisp_Object fun)
if (EQ (XCAR (fun), Qclosure))
{
fun = XCDR (fun); /* Drop `closure'. */
- CHECK_LIST_CONS (fun, fun);
+ CHECK_CONS (fun);
}
syms_left = XCDR (fun);
if (CONSP (syms_left))
diff --git a/src/fileio.c b/src/fileio.c
index 8c8cba9..3840062 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -316,7 +316,7 @@ use the standard functions without calling themselves
recursively. */)
}
}
- QUIT;
+ maybe_quit ();
}
return result;
}
@@ -1960,9 +1960,7 @@ permissions. */)
report_file_error ("Copying permissions to", newname);
}
#else /* not WINDOWSNT */
- immediate_quit = 1;
ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0);
- immediate_quit = 0;
if (ifd < 0)
report_file_error ("Opening input file", file);
@@ -2024,8 +2022,7 @@ permissions. */)
oldsize = out_st.st_size;
}
- immediate_quit = 1;
- QUIT;
+ maybe_quit ();
if (clone_file (ofd, ifd))
newsize = st.st_size;
@@ -2033,9 +2030,9 @@ permissions. */)
{
char buf[MAX_ALLOCA];
ptrdiff_t n;
- for (newsize = 0; 0 < (n = emacs_read (ifd, buf, sizeof buf));
+ for (newsize = 0; 0 < (n = emacs_read_quit (ifd, buf, sizeof buf));
newsize += n)
- if (emacs_write_sig (ofd, buf, n) != n)
+ if (emacs_write_quit (ofd, buf, n) != n)
report_file_error ("Write error", newname);
if (n < 0)
report_file_error ("Read error", file);
@@ -2047,8 +2044,6 @@ permissions. */)
if (newsize < oldsize && ftruncate (ofd, newsize) != 0)
report_file_error ("Truncating output file", newname);
- immediate_quit = 0;
-
#ifndef MSDOS
/* Preserve the original file permissions, and if requested, also its
owner and group. */
@@ -2682,7 +2677,7 @@ DEFUN ("file-writable-p", Ffile_writable_p,
Sfile_writable_p, 1, 1, 0,
DEFUN ("access-file", Faccess_file, Saccess_file, 2, 2, 0,
doc: /* Access file FILENAME, and get an error if that does not work.
-The second argument STRING is used in the error message.
+The second argument STRING is prepended to the error message.
If there is no error, returns nil. */)
(Lisp_Object filename, Lisp_Object string)
{
@@ -2815,7 +2810,17 @@ really is a readable and searchable directory. */)
if (!NILP (handler))
{
Lisp_Object r = call2 (handler, Qfile_accessible_directory_p, absname);
- errno = 0;
+
+ /* Set errno in case the handler failed. EACCES might be a lie
+ (e.g., the directory might not exist, or be a regular file),
+ but at least it does TRT in the "usual" case of an existing
+ directory that is not accessible by the current user, and
+ avoids reporting "Success" for a failed operation. Perhaps
+ someday we can fix this in a better way, by improving
+ file-accessible-directory-p's API; see Bug#25419. */
+ if (!EQ (r, Qt))
+ errno = EACCES;
+
return r;
}
@@ -3391,15 +3396,10 @@ decide_coding_unwind (Lisp_Object unwind_data)
static Lisp_Object
read_non_regular (Lisp_Object state)
{
- int nbytes;
-
- immediate_quit = 1;
- QUIT;
- nbytes = emacs_read (XSAVE_INTEGER (state, 0),
- ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
- + XSAVE_INTEGER (state, 1)),
- XSAVE_INTEGER (state, 2));
- immediate_quit = 0;
+ int nbytes = emacs_read_quit (XSAVE_INTEGER (state, 0),
+ ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
+ + XSAVE_INTEGER (state, 1)),
+ XSAVE_INTEGER (state, 2));
/* Fast recycle this object for the likely next call. */
free_misc (state);
return make_number (nbytes);
@@ -3743,17 +3743,17 @@ by calling `format-decode', which see. */)
int nread;
if (st.st_size <= (1024 * 4))
- nread = emacs_read (fd, read_buf, 1024 * 4);
+ nread = emacs_read_quit (fd, read_buf, 1024 * 4);
else
{
- nread = emacs_read (fd, read_buf, 1024);
+ nread = emacs_read_quit (fd, read_buf, 1024);
if (nread == 1024)
{
int ntail;
if (lseek (fd, - (1024 * 3), SEEK_END) < 0)
report_file_error ("Setting file position",
orig_filename);
- ntail = emacs_read (fd, read_buf + nread, 1024 * 3);
+ ntail = emacs_read_quit (fd, read_buf + nread, 1024 * 3);
nread = ntail < 0 ? ntail : nread + ntail;
}
}
@@ -3858,15 +3858,11 @@ by calling `format-decode', which see. */)
report_file_error ("Setting file position", orig_filename);
}
- immediate_quit = 1;
- QUIT;
/* Count how many chars at the start of the file
match the text at the beginning of the buffer. */
- while (1)
+ while (true)
{
- int nread, bufpos;
-
- nread = emacs_read (fd, read_buf, sizeof read_buf);
+ int nread = emacs_read_quit (fd, read_buf, sizeof read_buf);
if (nread < 0)
report_file_error ("Read error", orig_filename);
else if (nread == 0)
@@ -3888,7 +3884,7 @@ by calling `format-decode', which see. */)
break;
}
- bufpos = 0;
+ int bufpos = 0;
while (bufpos < nread && same_at_start < ZV_BYTE
&& FETCH_BYTE (same_at_start) == read_buf[bufpos])
same_at_start++, bufpos++;
@@ -3897,7 +3893,6 @@ by calling `format-decode', which see. */)
if (bufpos != nread)
break;
}
- immediate_quit = false;
/* If the file matches the buffer completely,
there's no need to replace anything. */
if (same_at_start - BEGV_BYTE == end_offset - beg_offset)
@@ -3909,8 +3904,7 @@ by calling `format-decode', which see. */)
del_range_1 (same_at_start, same_at_end, 0, 0);
goto handled;
}
- immediate_quit = true;
- QUIT;
+
/* Count how many chars at the end of the file
match the text at the end of the buffer. But, if we have
already found that decoding is necessary, don't waste time. */
@@ -3932,7 +3926,8 @@ by calling `format-decode', which see. */)
total_read = nread = 0;
while (total_read < trial)
{
- nread = emacs_read (fd, read_buf + total_read, trial -
total_read);
+ nread = emacs_read_quit (fd, read_buf + total_read,
+ trial - total_read);
if (nread < 0)
report_file_error ("Read error", orig_filename);
else if (nread == 0)
@@ -3967,7 +3962,6 @@ by calling `format-decode', which see. */)
if (nread == 0)
break;
}
- immediate_quit = 0;
if (! giveup_match_end)
{
@@ -4059,18 +4053,13 @@ by calling `format-decode', which see. */)
inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */
unprocessed = 0; /* Bytes not processed in previous loop. */
- while (1)
+ while (true)
{
/* Read at most READ_BUF_SIZE bytes at a time, to allow
quitting while reading a huge file. */
- /* Allow quitting out of the actual I/O. */
- immediate_quit = 1;
- QUIT;
- this = emacs_read (fd, read_buf + unprocessed,
- READ_BUF_SIZE - unprocessed);
- immediate_quit = 0;
-
+ this = emacs_read_quit (fd, read_buf + unprocessed,
+ READ_BUF_SIZE - unprocessed);
if (this <= 0)
break;
@@ -4284,13 +4273,10 @@ by calling `format-decode', which see. */)
/* Allow quitting out of the actual I/O. We don't make text
part of the buffer until all the reading is done, so a C-g
here doesn't do any harm. */
- immediate_quit = 1;
- QUIT;
- this = emacs_read (fd,
- ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
- + inserted),
- trytry);
- immediate_quit = 0;
+ this = emacs_read_quit (fd,
+ ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
+ + inserted),
+ trytry);
}
if (this <= 0)
@@ -4602,7 +4588,7 @@ by calling `format-decode', which see. */)
}
}
- QUIT;
+ maybe_quit ();
p = XCDR (p);
}
@@ -4992,8 +4978,6 @@ write_region (Lisp_Object start, Lisp_Object end,
Lisp_Object filename,
}
}
- immediate_quit = 1;
-
if (STRINGP (start))
ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding);
else if (XINT (start) != XINT (end))
@@ -5016,8 +5000,6 @@ write_region (Lisp_Object start, Lisp_Object end,
Lisp_Object filename,
save_errno = errno;
}
- immediate_quit = 0;
-
/* fsync is not crucial for temporary files. Nor for auto-save
files, since they might lose some work anyway. */
if (open_and_close_file && !auto_saving && !write_region_inhibit_fsync)
@@ -5407,7 +5389,7 @@ e_write (int desc, Lisp_Object string, ptrdiff_t start,
ptrdiff_t end,
: (STRINGP (coding->dst_object)
? SSDATA (coding->dst_object)
: (char *) BYTE_POS_ADDR (coding->dst_pos_byte)));
- coding->produced -= emacs_write_sig (desc, buf, coding->produced);
+ coding->produced -= emacs_write_quit (desc, buf, coding->produced);
if (coding->raw_destination)
{
diff --git a/src/filelock.c b/src/filelock.c
index 886ab61..67e8dbd 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -407,9 +407,7 @@ create_lock_file (char *lfname, char *lock_info_str, bool
force)
fcntl (fd, F_SETFD, FD_CLOEXEC);
lock_info_len = strlen (lock_info_str);
err = 0;
- /* Use 'write', not 'emacs_write', as garbage collection
- might signal an error, which would leak FD. */
- if (write (fd, lock_info_str, lock_info_len) != lock_info_len
+ if (emacs_write (fd, lock_info_str, lock_info_len) != lock_info_len
|| fchmod (fd, S_IRUSR | S_IRGRP | S_IROTH) != 0)
err = errno;
/* There is no need to call fsync here, as the contents of
@@ -490,8 +488,7 @@ read_lock_data (char *lfname, char lfinfo[MAX_LFINFO + 1])
int fd = emacs_open (lfname, O_RDONLY | O_NOFOLLOW, 0);
if (0 <= fd)
{
- /* Use read, not emacs_read, since FD isn't unwind-protected. */
- ptrdiff_t read_bytes = read (fd, lfinfo, MAX_LFINFO + 1);
+ ptrdiff_t read_bytes = emacs_read (fd, lfinfo, MAX_LFINFO + 1);
int read_errno = errno;
if (emacs_close (fd) != 0)
return -1;
@@ -505,7 +502,7 @@ read_lock_data (char *lfname, char lfinfo[MAX_LFINFO + 1])
/* readlinkat saw a non-symlink, but emacs_open saw a symlink.
The former must have been removed and replaced by the latter.
Try again. */
- QUIT;
+ maybe_quit ();
}
return nbytes;
diff --git a/src/fns.c b/src/fns.c
index 00fa658..ac7c1f2 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -34,6 +34,7 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "intervals.h"
#include "window.h"
+#include "puresize.h"
static void sort_vector_copy (Lisp_Object, ptrdiff_t,
Lisp_Object *restrict, Lisp_Object *restrict);
@@ -83,18 +84,8 @@ See Info node `(elisp)Random Numbers' for more details. */)
return make_number (val);
}
-/* Heuristic on how many iterations of a tight loop can be safely done
- before it's time to do a QUIT. This must be a power of 2. */
-enum { QUIT_COUNT_HEURISTIC = 1 << 16 };
-
/* Random data-structure functions. */
-static void
-CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
-{
- CHECK_TYPE (NILP (x), Qlistp, y);
-}
-
DEFUN ("length", Flength, Slength, 1, 1, 0,
doc: /* Return the length of vector, list or string SEQUENCE.
A byte-code function object is also allowed.
@@ -126,7 +117,7 @@ To get the number of bytes, use `string-bytes'. */)
{
if (MOST_POSITIVE_FIXNUM < i)
error ("List too long");
- QUIT;
+ maybe_quit ();
}
sequence = XCDR (sequence);
}
@@ -172,7 +163,7 @@ which is at least the number of distinct elements. */)
halftail = XCDR (halftail);
if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0)
{
- QUIT;
+ maybe_quit ();
if (lolen == 0)
hilen += UINTMAX_MAX + 1.0;
}
@@ -1202,17 +1193,12 @@ are shared, however.
Elements of ALIST that are not conses are also shared. */)
(Lisp_Object alist)
{
- register Lisp_Object tem;
-
- CHECK_LIST (alist);
if (NILP (alist))
return alist;
- alist = concat (1, &alist, Lisp_Cons, 0);
- for (tem = alist; CONSP (tem); tem = XCDR (tem))
+ alist = concat (1, &alist, Lisp_Cons, false);
+ for (Lisp_Object tem = alist; !NILP (tem); tem = XCDR (tem))
{
- register Lisp_Object car;
- car = XCAR (tem);
-
+ Lisp_Object car = XCAR (tem);
if (CONSP (car))
XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
}
@@ -1356,16 +1342,19 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
doc: /* Take cdr N times on LIST, return the result. */)
(Lisp_Object n, Lisp_Object list)
{
- EMACS_INT i, num;
CHECK_NUMBER (n);
- num = XINT (n);
- for (i = 0; i < num && !NILP (list); i++)
+ Lisp_Object tail = list;
+ for (EMACS_INT num = XINT (n); 0 < num; num--)
{
- QUIT;
- CHECK_LIST_CONS (list, list);
- list = XCDR (list);
+ if (! CONSP (tail))
+ {
+ CHECK_LIST_END (tail, list);
+ return Qnil;
+ }
+ tail = XCDR (tail);
+ rarely_quit (num);
}
- return list;
+ return tail;
}
DEFUN ("nth", Fnth, Snth, 2, 2, 0,
@@ -1392,66 +1381,55 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0,
DEFUN ("member", Fmember, Smember, 2, 2, 0,
doc: /* Return non-nil if ELT is an element of LIST. Comparison done
with `equal'.
The value is actually the tail of LIST whose car is ELT. */)
- (register Lisp_Object elt, Lisp_Object list)
+ (Lisp_Object elt, Lisp_Object list)
{
- register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = XCDR (tail))
+ unsigned short int quit_count = 0;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- register Lisp_Object tem;
- CHECK_LIST_CONS (tail, list);
- tem = XCAR (tail);
- if (! NILP (Fequal (elt, tem)))
+ if (! NILP (Fequal (elt, XCAR (tail))))
return tail;
- QUIT;
+ rarely_quit (++quit_count);
}
+ CHECK_LIST_END (tail, list);
return Qnil;
}
DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
doc: /* Return non-nil if ELT is an element of LIST. Comparison done
with `eq'.
The value is actually the tail of LIST whose car is ELT. */)
- (register Lisp_Object elt, Lisp_Object list)
+ (Lisp_Object elt, Lisp_Object list)
{
- while (1)
+ unsigned short int quit_count = 0;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- if (!CONSP (list) || EQ (XCAR (list), elt))
- break;
-
- list = XCDR (list);
- if (!CONSP (list) || EQ (XCAR (list), elt))
- break;
-
- list = XCDR (list);
- if (!CONSP (list) || EQ (XCAR (list), elt))
- break;
-
- list = XCDR (list);
- QUIT;
+ if (EQ (XCAR (tail), elt))
+ return tail;
+ rarely_quit (++quit_count);
}
-
- CHECK_LIST (list);
- return list;
+ CHECK_LIST_END (tail, list);
+ return Qnil;
}
DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
doc: /* Return non-nil if ELT is an element of LIST. Comparison done
with `eql'.
The value is actually the tail of LIST whose car is ELT. */)
- (register Lisp_Object elt, Lisp_Object list)
+ (Lisp_Object elt, Lisp_Object list)
{
- register Lisp_Object tail;
-
if (!FLOATP (elt))
return Fmemq (elt, list);
- for (tail = list; !NILP (tail); tail = XCDR (tail))
+ unsigned short int quit_count = 0;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- register Lisp_Object tem;
- CHECK_LIST_CONS (tail, list);
- tem = XCAR (tail);
+ Lisp_Object tem = XCAR (tail);
if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil))
return tail;
- QUIT;
+ rarely_quit (++quit_count);
}
+ CHECK_LIST_END (tail, list);
return Qnil;
}
@@ -1461,44 +1439,28 @@ The value is actually the first element of LIST whose
car is KEY.
Elements of LIST that are not conses are ignored. */)
(Lisp_Object key, Lisp_Object list)
{
- while (1)
+ unsigned short int quit_count = 0;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && EQ (XCAR (XCAR (list)), key)))
- break;
-
- list = XCDR (list);
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && EQ (XCAR (XCAR (list)), key)))
- break;
-
- list = XCDR (list);
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && EQ (XCAR (XCAR (list)), key)))
- break;
-
- list = XCDR (list);
- QUIT;
+ if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
+ return XCAR (tail);
+ rarely_quit (++quit_count);
}
-
- return CAR (list);
+ CHECK_LIST_END (tail, list);
+ return Qnil;
}
/* Like Fassq but never report an error and do not allow quits.
- Use only on lists known never to be circular. */
+ Use only on objects known to be non-circular lists. */
Lisp_Object
assq_no_quit (Lisp_Object key, Lisp_Object list)
{
- while (CONSP (list)
- && (!CONSP (XCAR (list))
- || !EQ (XCAR (XCAR (list)), key)))
- list = XCDR (list);
-
- return CAR_SAFE (list);
+ for (; ! NILP (list); list = XCDR (list))
+ if (CONSP (XCAR (list)) && EQ (XCAR (XCAR (list)), key))
+ return XCAR (list);
+ return Qnil;
}
DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
@@ -1506,81 +1468,51 @@ DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
The value is actually the first element of LIST whose car equals KEY. */)
(Lisp_Object key, Lisp_Object list)
{
- Lisp_Object car;
-
- while (1)
+ unsigned short int quit_count = 0;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && (car = XCAR (XCAR (list)),
- EQ (car, key) || !NILP (Fequal (car, key)))))
- break;
-
- list = XCDR (list);
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && (car = XCAR (XCAR (list)),
- EQ (car, key) || !NILP (Fequal (car, key)))))
- break;
-
- list = XCDR (list);
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && (car = XCAR (XCAR (list)),
- EQ (car, key) || !NILP (Fequal (car, key)))))
- break;
-
- list = XCDR (list);
- QUIT;
+ Lisp_Object car = XCAR (tail);
+ if (CONSP (car)
+ && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key))))
+ return car;
+ rarely_quit (++quit_count);
}
-
- return CAR (list);
+ CHECK_LIST_END (tail, list);
+ return Qnil;
}
/* Like Fassoc but never report an error and do not allow quits.
- Use only on lists known never to be circular. */
+ Use only on objects known to be non-circular lists. */
Lisp_Object
assoc_no_quit (Lisp_Object key, Lisp_Object list)
{
- while (CONSP (list)
- && (!CONSP (XCAR (list))
- || (!EQ (XCAR (XCAR (list)), key)
- && NILP (Fequal (XCAR (XCAR (list)), key)))))
- list = XCDR (list);
-
- return CONSP (list) ? XCAR (list) : Qnil;
+ for (; ! NILP (list); list = XCDR (list))
+ {
+ Lisp_Object car = XCAR (list);
+ if (CONSP (car)
+ && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key))))
+ return car;
+ }
+ return Qnil;
}
DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
The value is actually the first element of LIST whose cdr is KEY. */)
- (register Lisp_Object key, Lisp_Object list)
+ (Lisp_Object key, Lisp_Object list)
{
- while (1)
+ unsigned short int quit_count = 0;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && EQ (XCDR (XCAR (list)), key)))
- break;
-
- list = XCDR (list);
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && EQ (XCDR (XCAR (list)), key)))
- break;
-
- list = XCDR (list);
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && EQ (XCDR (XCAR (list)), key)))
- break;
-
- list = XCDR (list);
- QUIT;
+ if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key))
+ return XCAR (tail);
+ rarely_quit (++quit_count);
}
-
- return CAR (list);
+ CHECK_LIST_END (tail, list);
+ return Qnil;
}
DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
@@ -1588,35 +1520,18 @@ DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
The value is actually the first element of LIST whose cdr equals KEY. */)
(Lisp_Object key, Lisp_Object list)
{
- Lisp_Object cdr;
-
- while (1)
+ unsigned short int quit_count = 0;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && (cdr = XCDR (XCAR (list)),
- EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
- break;
-
- list = XCDR (list);
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && (cdr = XCDR (XCAR (list)),
- EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
- break;
-
- list = XCDR (list);
- if (!CONSP (list)
- || (CONSP (XCAR (list))
- && (cdr = XCDR (XCAR (list)),
- EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
- break;
-
- list = XCDR (list);
- QUIT;
+ Lisp_Object car = XCAR (tail);
+ if (CONSP (car)
+ && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key))))
+ return car;
+ rarely_quit (++quit_count);
}
-
- return CAR (list);
+ CHECK_LIST_END (tail, list);
+ return Qnil;
}
DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
@@ -1647,6 +1562,7 @@ argument. */)
else
prev = tail;
}
+ CHECK_LIST_END (tail, list);
return list;
}
@@ -1754,12 +1670,11 @@ changing the value of a sequence `foo'. */)
}
else
{
+ unsigned short int quit_count = 0;
Lisp_Object tail, prev;
- for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail))
+ for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
{
- CHECK_LIST_CONS (tail, seq);
-
if (!NILP (Fequal (elt, XCAR (tail))))
{
if (NILP (prev))
@@ -1769,8 +1684,9 @@ changing the value of a sequence `foo'. */)
}
else
prev = tail;
- QUIT;
+ rarely_quit (++quit_count);
}
+ CHECK_LIST_END (tail, seq);
}
return seq;
@@ -1788,16 +1704,17 @@ This function may destructively modify SEQ to produce
the value. */)
return Freverse (seq);
else if (CONSP (seq))
{
+ unsigned short int quit_count = 0;
Lisp_Object prev, tail, next;
- for (prev = Qnil, tail = seq; !NILP (tail); tail = next)
+ for (prev = Qnil, tail = seq; CONSP (tail); tail = next)
{
- QUIT;
- CHECK_LIST_CONS (tail, tail);
next = XCDR (tail);
Fsetcdr (tail, prev);
prev = tail;
+ rarely_quit (++quit_count);
}
+ CHECK_LIST_END (tail, seq);
seq = prev;
}
else if (VECTORP (seq))
@@ -1838,10 +1755,11 @@ See also the function `nreverse', which is used more
often. */)
return Qnil;
else if (CONSP (seq))
{
+ unsigned short int quit_count = 0;
for (new = Qnil; CONSP (seq); seq = XCDR (seq))
{
- QUIT;
new = Fcons (XCAR (seq), new);
+ rarely_quit (++quit_count);
}
CHECK_LIST_END (seq, seq);
}
@@ -2130,12 +2048,11 @@ If PROP is already a property on the list, its value is
set to VAL,
otherwise the new PROP VAL pair is added. The new plist is returned;
use `(setq x (plist-put x prop val))' to be sure to use the new value.
The PLIST is modified by side effects. */)
- (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val)
+ (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
{
- register Lisp_Object tail, prev;
- Lisp_Object newcell;
- prev = Qnil;
- for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
+ unsigned short int quit_count = 0;
+ Lisp_Object prev = Qnil;
+ for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail));
tail = XCDR (XCDR (tail)))
{
if (EQ (prop, XCAR (tail)))
@@ -2145,13 +2062,13 @@ The PLIST is modified by side effects. */)
}
prev = tail;
- QUIT;
+ rarely_quit (++quit_count);
}
- newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR
(prev))));
+ Lisp_Object newcell
+ = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
if (NILP (prev))
return newcell;
- else
- Fsetcdr (XCDR (prev), newcell);
+ Fsetcdr (XCDR (prev), newcell);
return plist;
}
@@ -2174,6 +2091,7 @@ corresponding to the given PROP, or nil if PROP is not
one of the properties on the list. */)
(Lisp_Object plist, Lisp_Object prop)
{
+ unsigned short int quit_count = 0;
Lisp_Object tail;
for (tail = plist;
@@ -2182,8 +2100,7 @@ one of the properties on the list. */)
{
if (! NILP (Fequal (prop, XCAR (tail))))
return XCAR (XCDR (tail));
-
- QUIT;
+ rarely_quit (++quit_count);
}
CHECK_LIST_END (tail, prop);
@@ -2199,12 +2116,11 @@ If PROP is already a property on the list, its value is
set to VAL,
otherwise the new PROP VAL pair is added. The new plist is returned;
use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
The PLIST is modified by side effects. */)
- (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val)
+ (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
{
- register Lisp_Object tail, prev;
- Lisp_Object newcell;
- prev = Qnil;
- for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
+ unsigned short int quit_count = 0;
+ Lisp_Object prev = Qnil;
+ for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail));
tail = XCDR (XCDR (tail)))
{
if (! NILP (Fequal (prop, XCAR (tail))))
@@ -2214,13 +2130,12 @@ The PLIST is modified by side effects. */)
}
prev = tail;
- QUIT;
+ rarely_quit (++quit_count);
}
- newcell = list2 (prop, val);
+ Lisp_Object newcell = list2 (prop, val);
if (NILP (prev))
return newcell;
- else
- Fsetcdr (XCDR (prev), newcell);
+ Fsetcdr (XCDR (prev), newcell);
return plist;
}
@@ -2293,8 +2208,9 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int
depth, bool props,
}
}
+ unsigned short int quit_count = 0;
tail_recurse:
- QUIT;
+ rarely_quit (++quit_count);
if (EQ (o1, o2))
return 1;
if (XTYPE (o1) != XTYPE (o2))
@@ -2483,14 +2399,12 @@ Only the last argument is not altered, and need not be
a list.
usage: (nconc &rest LISTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- ptrdiff_t argnum;
- register Lisp_Object tail, tem, val;
-
- val = tail = Qnil;
+ unsigned short int quit_count = 0;
+ Lisp_Object val = Qnil;
- for (argnum = 0; argnum < nargs; argnum++)
+ for (ptrdiff_t argnum = 0; argnum < nargs; argnum++)
{
- tem = args[argnum];
+ Lisp_Object tem = args[argnum];
if (NILP (tem)) continue;
if (NILP (val))
@@ -2498,14 +2412,16 @@ usage: (nconc &rest LISTS) */)
if (argnum + 1 == nargs) break;
- CHECK_LIST_CONS (tem, tem);
+ CHECK_CONS (tem);
- while (CONSP (tem))
+ Lisp_Object tail;
+ do
{
tail = tem;
tem = XCDR (tail);
- QUIT;
+ rarely_quit (++quit_count);
}
+ while (CONSP (tem));
tem = args[argnum + 1];
Fsetcdr (tail, tem);
@@ -2927,11 +2843,12 @@ property and a property with the value nil.
The value is actually the tail of PLIST whose car is PROP. */)
(Lisp_Object plist, Lisp_Object prop)
{
+ unsigned short int quit_count = 0;
while (CONSP (plist) && !EQ (XCAR (plist), prop))
{
plist = XCDR (plist);
plist = CDR (plist);
- QUIT;
+ rarely_quit (++quit_count);
}
return plist;
}
@@ -3804,12 +3721,17 @@ allocate_hash_table (void)
(table size) is >= REHASH_THRESHOLD.
WEAK specifies the weakness of the table. If non-nil, it must be
- one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
+ one of the symbols `key', `value', `key-or-value', or `key-and-value'.
+
+ If PURECOPY is non-nil, the table can be copied to pure storage via
+ `purecopy' when Emacs is being dumped. Such tables can no longer be
+ changed after purecopy. */
Lisp_Object
make_hash_table (struct hash_table_test test,
Lisp_Object size, Lisp_Object rehash_size,
- Lisp_Object rehash_threshold, Lisp_Object weak)
+ Lisp_Object rehash_threshold, Lisp_Object weak,
+ Lisp_Object pure)
{
struct Lisp_Hash_Table *h;
Lisp_Object table;
@@ -3850,6 +3772,7 @@ make_hash_table (struct hash_table_test test,
h->hash = Fmake_vector (size, Qnil);
h->next = Fmake_vector (size, Qnil);
h->index = Fmake_vector (make_number (index_size), Qnil);
+ h->pure = pure;
/* Set up the free list. */
for (i = 0; i < sz - 1; ++i)
@@ -4514,10 +4437,15 @@ key, value, one of key or value, or both key and value,
depending on
WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
is nil.
+:purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
+to pure storage when Emacs is being dumped, making the contents of the
+table read only. Any further changes to purified tables will result
+in an error.
+
usage: (make-hash-table &rest KEYWORD-ARGS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- Lisp_Object test, size, rehash_size, rehash_threshold, weak;
+ Lisp_Object test, size, rehash_size, rehash_threshold, weak, pure;
struct hash_table_test testdesc;
ptrdiff_t i;
USE_SAFE_ALLOCA;
@@ -4551,6 +4479,9 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
testdesc.cmpfn = cmpfn_user_defined;
}
+ /* See if there's a `:purecopy PURECOPY' argument. */
+ i = get_key_arg (QCpurecopy, nargs, args, used);
+ pure = i ? args[i] : Qnil;
/* See if there's a `:size SIZE' argument. */
i = get_key_arg (QCsize, nargs, args, used);
size = i ? args[i] : Qnil;
@@ -4592,7 +4523,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
signal_error ("Invalid argument list", args[i]);
SAFE_FREE ();
- return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak);
+ return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak,
+ pure);
}
@@ -4671,7 +4603,9 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
doc: /* Clear hash table TABLE and return it. */)
(Lisp_Object table)
{
- hash_clear (check_hash_table (table));
+ struct Lisp_Hash_Table *h = check_hash_table (table);
+ CHECK_IMPURE (table, h);
+ hash_clear (h);
/* Be compatible with XEmacs. */
return table;
}
@@ -4695,9 +4629,10 @@ VALUE. In any case, return VALUE. */)
(Lisp_Object key, Lisp_Object value, Lisp_Object table)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
+ CHECK_IMPURE (table, h);
+
ptrdiff_t i;
EMACS_UINT hash;
-
i = hash_lookup (h, key, &hash);
if (i >= 0)
set_hash_value_slot (h, i, value);
@@ -4713,6 +4648,7 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
(Lisp_Object key, Lisp_Object table)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
+ CHECK_IMPURE (table, h);
hash_remove_from_table (h, key);
return Qnil;
}
@@ -5083,6 +5019,7 @@ syms_of_fns (void)
DEFSYM (Qequal, "equal");
DEFSYM (QCtest, ":test");
DEFSYM (QCsize, ":size");
+ DEFSYM (QCpurecopy, ":purecopy");
DEFSYM (QCrehash_size, ":rehash-size");
DEFSYM (QCrehash_threshold, ":rehash-threshold");
DEFSYM (QCweakness, ":weakness");
diff --git a/src/fontset.c b/src/fontset.c
index 33d1d24..850558b 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -1677,11 +1677,10 @@ FONT-SPEC is a vector, a cons, or a string. See the
documentation of
`set-fontset-font' for the meaning. */)
(Lisp_Object name, Lisp_Object fontlist)
{
- Lisp_Object fontset;
+ Lisp_Object fontset, tail;
int id;
CHECK_STRING (name);
- CHECK_LIST (fontlist);
name = Fdowncase (name);
id = fs_query_fontset (name, 0);
@@ -1714,11 +1713,11 @@ FONT-SPEC is a vector, a cons, or a string. See the
documentation of
Fset_char_table_range (fontset, Qt, Qnil);
}
- for (; CONSP (fontlist); fontlist = XCDR (fontlist))
+ for (tail = fontlist; CONSP (tail); tail = XCDR (tail))
{
Lisp_Object elt, script;
- elt = XCAR (fontlist);
+ elt = XCAR (tail);
script = Fcar (elt);
elt = Fcdr (elt);
if (CONSP (elt) && (NILP (XCDR (elt)) || CONSP (XCDR (elt))))
@@ -1727,6 +1726,7 @@ FONT-SPEC is a vector, a cons, or a string. See the
documentation of
else
Fset_fontset_font (name, script, elt, Qnil, Qappend);
}
+ CHECK_LIST_END (tail, fontlist);
return name;
}
diff --git a/src/frame.c b/src/frame.c
index 2c2c1e1..d0f653f 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -2691,9 +2691,7 @@ list, but are otherwise ignored. */)
(Lisp_Object frame, Lisp_Object alist)
{
struct frame *f = decode_live_frame (frame);
- register Lisp_Object prop, val;
-
- CHECK_LIST (alist);
+ Lisp_Object prop, val;
/* I think this should be done with a hook. */
#ifdef HAVE_WINDOW_SYSTEM
@@ -3142,6 +3140,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object
alist)
for (size = 0, tail = alist; CONSP (tail); tail = XCDR (tail))
size++;
+ CHECK_LIST_END (tail, alist);
USE_SAFE_ALLOCA;
SAFE_ALLOCA_LISP (parms, 2 * size);
diff --git a/src/gfilenotify.c b/src/gfilenotify.c
index 6ec5c64..285a253 100644
--- a/src/gfilenotify.c
+++ b/src/gfilenotify.c
@@ -178,20 +178,18 @@ will be reported only in case of the `moved' event. */)
if (NILP (Ffile_exists_p (file)))
report_file_error ("File does not exist", file);
- CHECK_LIST (flags);
-
if (!FUNCTIONP (callback))
wrong_type_argument (Qinvalid_function, callback);
- /* Create GFile name. */
- gfile = g_file_new_for_path (SSDATA (ENCODE_FILE (file)));
-
/* Assemble flags. */
if (!NILP (Fmember (Qwatch_mounts, flags)))
gflags |= G_FILE_MONITOR_WATCH_MOUNTS;
if (!NILP (Fmember (Qsend_moved, flags)))
gflags |= G_FILE_MONITOR_SEND_MOVED;
+ /* Create GFile name. */
+ gfile = g_file_new_for_path (SSDATA (ENCODE_FILE (file)));
+
/* Enable watch. */
monitor = g_file_monitor (gfile, gflags, NULL, &gerror);
g_object_unref (gfile);
diff --git a/src/gnutls.c b/src/gnutls.c
index 735d2e3..d0d7f2d 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -390,7 +390,7 @@ gnutls_try_handshake (struct Lisp_Process *proc)
{
ret = gnutls_handshake (state);
emacs_gnutls_handle_error (state, ret);
- QUIT;
+ maybe_quit ();
}
while (ret < 0
&& gnutls_error_is_fatal (ret) == 0
@@ -582,8 +582,17 @@ emacs_gnutls_handle_error (gnutls_session_t session, int
err)
if (gnutls_error_is_fatal (err))
{
+ int level = 1;
+ /* Mostly ignore "The TLS connection was non-properly
+ terminated" message which just means that the peer closed the
+ connection. */
+#ifdef HAVE_GNUTLS3
+ if (err == GNUTLS_E_PREMATURE_TERMINATION)
+ level = 3;
+#endif
+
+ GNUTLS_LOG2 (level, max_log_level, "fatal error:", str);
ret = 0;
- GNUTLS_LOG2 (1, max_log_level, "fatal error:", str);
}
else
{
diff --git a/src/image.c b/src/image.c
index 39677d2..ad0143b 100644
--- a/src/image.c
+++ b/src/image.c
@@ -4020,7 +4020,7 @@ xpm_make_color_table_h (void (**put_func) (Lisp_Object,
const char *, int,
return make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil);
+ Qnil, Qnil);
}
static void
diff --git a/src/indent.c b/src/indent.c
index 3444995..f630ebb 100644
--- a/src/indent.c
+++ b/src/indent.c
@@ -1200,9 +1200,6 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte,
EMACS_INT fromvpos,
continuation_glyph_width = 0; /* In the fringe. */
#endif
- immediate_quit = 1;
- QUIT;
-
/* It's just impossible to be too paranoid here. */
eassert (from == BYTE_TO_CHAR (frombyte) && frombyte == CHAR_TO_BYTE (from));
@@ -1214,8 +1211,12 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte,
EMACS_INT fromvpos,
cmp_it.id = -1;
composition_compute_stop_pos (&cmp_it, pos, pos_byte, to, Qnil);
- while (1)
+ unsigned short int quit_count = 0;
+
+ while (true)
{
+ rarely_quit (++quit_count);
+
while (pos == next_boundary)
{
ptrdiff_t pos_here = pos;
@@ -1280,6 +1281,8 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte,
EMACS_INT fromvpos,
pos = newpos;
pos_byte = CHAR_TO_BYTE (pos);
}
+
+ rarely_quit (++quit_count);
}
/* Handle right margin. */
@@ -1602,6 +1605,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte,
EMACS_INT fromvpos,
pos = find_before_next_newline (pos, to, 1,
&pos_byte);
if (pos < to)
INC_BOTH (pos, pos_byte);
+ rarely_quit (++quit_count);
}
while (pos < to
&& indented_beyond_p (pos, pos_byte,
@@ -1694,7 +1698,6 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte,
EMACS_INT fromvpos,
/* Nonzero if have just continued a line */
val_compute_motion.contin = (contin_hpos && prev_hpos == 0);
- immediate_quit = 0;
return &val_compute_motion;
}
diff --git a/src/insdel.c b/src/insdel.c
index ce496044..4627bd5 100644
--- a/src/insdel.c
+++ b/src/insdel.c
@@ -129,7 +129,7 @@ gap_left (ptrdiff_t charpos, ptrdiff_t bytepos, bool newgap)
Change BYTEPOS to be where we have actually moved the gap to.
Note that this cannot happen when we are called to make the
gap larger or smaller, since make_gap_larger and
- make_gap_smaller prevent QUIT by setting inhibit-quit. */
+ make_gap_smaller set inhibit-quit. */
if (QUITP)
{
bytepos = new_s1;
@@ -151,7 +151,7 @@ gap_left (ptrdiff_t charpos, ptrdiff_t bytepos, bool newgap)
GPT = charpos;
eassert (charpos <= bytepos);
if (GAP_SIZE > 0) *(GPT_ADDR) = 0; /* Put an anchor. */
- QUIT;
+ maybe_quit ();
}
/* Move the gap to a position greater than the current GPT.
@@ -185,7 +185,7 @@ gap_right (ptrdiff_t charpos, ptrdiff_t bytepos)
Change BYTEPOS to be where we have actually moved the gap to.
Note that this cannot happen when we are called to make the
gap larger or smaller, since make_gap_larger and
- make_gap_smaller prevent QUIT by setting inhibit-quit. */
+ make_gap_smaller set inhibit-quit. */
if (QUITP)
{
bytepos = new_s1;
@@ -204,7 +204,7 @@ gap_right (ptrdiff_t charpos, ptrdiff_t bytepos)
GPT_BYTE = bytepos;
eassert (charpos <= bytepos);
if (GAP_SIZE > 0) *(GPT_ADDR) = 0; /* Put an anchor. */
- QUIT;
+ maybe_quit ();
}
/* If the selected window's old pointm is adjacent or covered by the
@@ -464,7 +464,7 @@ make_gap_larger (ptrdiff_t nbytes_added)
enlarge_buffer_text (current_buffer, nbytes_added);
- /* Prevent quitting in gap_left. We cannot allow a QUIT there,
+ /* Prevent quitting in gap_left. We cannot allow a quit there,
because that would leave the buffer text in an inconsistent
state, with 2 gap holes instead of just one. */
tem = Vinhibit_quit;
@@ -512,7 +512,7 @@ make_gap_smaller (ptrdiff_t nbytes_removed)
if (GAP_SIZE - nbytes_removed < GAP_BYTES_MIN)
nbytes_removed = GAP_SIZE - GAP_BYTES_MIN;
- /* Prevent quitting in gap_right. We cannot allow a QUIT there,
+ /* Prevent quitting in gap_right. We cannot allow a quit there,
because that would leave the buffer text in an inconsistent
state, with 2 gap holes instead of just one. */
tem = Vinhibit_quit;
diff --git a/src/keyboard.c b/src/keyboard.c
index 6aad0ac..a86e7c5 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -87,7 +87,7 @@ char const DEV_TTY[] = "/dev/tty";
volatile int interrupt_input_blocked;
/* True means an input interrupt or alarm signal has arrived.
- The QUIT macro checks this. */
+ The maybe_quit function checks this. */
volatile bool pending_signals;
#define KBD_BUFFER_SIZE 4096
@@ -169,9 +169,6 @@ struct kboard *echo_kboard;
Lisp_Object echo_message_buffer;
-/* True means C-g should cause immediate error-signal. */
-bool immediate_quit;
-
/* Character that causes a quit. Normally C-g.
If we are running on an ordinary terminal, this must be an ordinary
@@ -1416,7 +1413,7 @@ command_loop_1 (void)
if (!NILP (Vquit_flag))
{
Vexecuting_kbd_macro = Qt;
- QUIT; /* Make some noise. */
+ maybe_quit (); /* Make some noise. */
/* Will return since macro now empty. */
}
}
@@ -3584,16 +3581,7 @@ kbd_buffer_store_buffered_event (union
buffered_input_event *event,
as input, set quit-flag to cause an interrupt. */
if (!NILP (Vthrow_on_input)
&& NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events)))
- {
- Vquit_flag = Vthrow_on_input;
- /* If we're inside a function that wants immediate quits,
- do it now. */
- if (immediate_quit && NILP (Vinhibit_quit))
- {
- immediate_quit = false;
- QUIT;
- }
- }
+ Vquit_flag = Vthrow_on_input;
}
@@ -7053,40 +7041,22 @@ tty_read_avail_input (struct terminal *terminal,
/* Now read; for one reason or another, this will not block.
NREAD is set to the number of chars read. */
- do
- {
- nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read);
- /* POSIX infers that processes which are not in the session leader's
- process group won't get SIGHUPs at logout time. BSDI adheres to
- this part standard and returns -1 from read (0) with errno==EIO
- when the control tty is taken away.
- Jeffrey Honig <address@hidden> says this is generally safe. */
- if (nread == -1 && errno == EIO)
- return -2; /* Close this terminal. */
-#if defined (AIX) && defined (_BSD)
- /* The kernel sometimes fails to deliver SIGHUP for ptys.
- This looks incorrect, but it isn't, because _BSD causes
- O_NDELAY to be defined in fcntl.h as O_NONBLOCK,
- and that causes a value other than 0 when there is no input. */
- if (nread == 0)
- return -2; /* Close this terminal. */
-#endif
- }
- while (
- /* We used to retry the read if it was interrupted.
- But this does the wrong thing when O_NONBLOCK causes
- an EAGAIN error. Does anybody know of a situation
- where a retry is actually needed? */
-#if 0
- nread < 0 && (errno == EAGAIN || errno == EFAULT
-#ifdef EBADSLT
- || errno == EBADSLT
-#endif
- )
-#else
- 0
+ nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read);
+ /* POSIX infers that processes which are not in the session leader's
+ process group won't get SIGHUPs at logout time. BSDI adheres to
+ this part standard and returns -1 from read (0) with errno==EIO
+ when the control tty is taken away.
+ Jeffrey Honig <address@hidden> says this is generally safe. */
+ if (nread == -1 && errno == EIO)
+ return -2; /* Close this terminal. */
+#if defined AIX && defined _BSD
+ /* The kernel sometimes fails to deliver SIGHUP for ptys.
+ This looks incorrect, but it isn't, because _BSD causes
+ O_NDELAY to be defined in fcntl.h as O_NONBLOCK,
+ and that causes a value other than 0 when there is no input. */
+ if (nread == 0)
+ return -2; /* Close this terminal. */
#endif
- );
#ifndef USABLE_FIONREAD
#if defined (USG) || defined (CYGWIN)
@@ -7426,7 +7396,7 @@ menu_bar_items (Lisp_Object old)
USE_SAFE_ALLOCA;
/* In order to build the menus, we need to call the keymap
- accessors. They all call QUIT. But this function is called
+ accessors. They all call maybe_quit. But this function is called
during redisplay, during which a quit is fatal. So inhibit
quitting while building the menus.
We do this instead of specbind because (1) errors will clear it anyway
@@ -7987,7 +7957,7 @@ tool_bar_items (Lisp_Object reuse, int *nitems)
*nitems = 0;
/* In order to build the menus, we need to call the keymap
- accessors. They all call QUIT. But this function is called
+ accessors. They all call maybe_quit. But this function is called
during redisplay, during which a quit is fatal. So inhibit
quitting while building the menus. We do this instead of
specbind because (1) errors will clear it anyway and (2) this
@@ -9806,7 +9776,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object
continue_echo,
if (!NILP (prompt))
CHECK_STRING (prompt);
- QUIT;
+ maybe_quit ();
specbind (Qinput_method_exit_on_first_char,
(NILP (cmd_loop) ? Qt : Qnil));
@@ -9840,7 +9810,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object
continue_echo,
if (i == -1)
{
Vquit_flag = Qt;
- QUIT;
+ maybe_quit ();
}
return unbind_to (count,
@@ -10278,7 +10248,7 @@ clear_waiting_for_input (void)
If we have a frame on the controlling tty, we assume that the
SIGINT was generated by C-g, so we call handle_interrupt.
- Otherwise, tell QUIT to kill Emacs. */
+ Otherwise, tell maybe_quit to kill Emacs. */
static void
handle_interrupt_signal (int sig)
@@ -10289,7 +10259,7 @@ handle_interrupt_signal (int sig)
{
/* If there are no frames there, let's pretend that we are a
well-behaving UN*X program and quit. We must not call Lisp
- in a signal handler, so tell QUIT to exit when it is
+ in a signal handler, so tell maybe_quit to exit when it is
safe. */
Vquit_flag = Qkill_emacs;
}
@@ -10445,30 +10415,12 @@ handle_interrupt (bool in_signal_handler)
}
else
{
- /* If executing a function that wants to be interrupted out of
- and the user has not deferred quitting by binding `inhibit-quit'
- then quit right away. */
- if (immediate_quit && NILP (Vinhibit_quit))
- {
- struct gl_state_s saved;
-
- immediate_quit = false;
- pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
- saved = gl_state;
- quit ();
- gl_state = saved;
- }
- else
- { /* Else request quit when it's safe. */
- int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1;
- force_quit_count = count;
- if (count == 3)
- {
- immediate_quit = true;
- Vinhibit_quit = Qnil;
- }
- Vquit_flag = Qt;
- }
+ /* Request quit when it's safe. */
+ int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1;
+ force_quit_count = count;
+ if (count == 3)
+ Vinhibit_quit = Qnil;
+ Vquit_flag = Qt;
}
pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
@@ -10907,7 +10859,6 @@ init_keyboard (void)
{
/* This is correct before outermost invocation of the editor loop. */
command_loop_level = -1;
- immediate_quit = false;
quit_char = Ctl ('g');
Vunread_command_events = Qnil;
timer_idleness_start_time = invalid_timespec ();
diff --git a/src/keyboard.h b/src/keyboard.h
index 7cd41ae..2219c01 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -486,6 +486,8 @@ extern bool kbd_buffer_events_waiting (void);
extern void add_user_signal (int, const char *);
extern int tty_read_avail_input (struct terminal *, struct input_event *);
+extern bool volatile pending_signals;
+extern void process_pending_signals (void);
extern struct timespec timer_check (void);
extern void mark_kboards (void);
diff --git a/src/keymap.c b/src/keymap.c
index 9e75947..9caf55f 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -523,7 +523,7 @@ access_keymap_1 (Lisp_Object map, Lisp_Object idx,
retval = Fcons (Qkeymap, Fcons (retval, retval_tail));
}
}
- QUIT;
+ maybe_quit ();
}
return EQ (Qunbound, retval) ? get_keyelt (t_binding, autoload) : retval;
@@ -877,7 +877,7 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object
idx, Lisp_Object def)
should be inserted before it. */
goto keymap_end;
- QUIT;
+ maybe_quit ();
}
keymap_end:
@@ -1250,7 +1250,7 @@ recognize the default bindings, just as
`read-key-sequence' does. */)
if (!CONSP (keymap))
return make_number (idx);
- QUIT;
+ maybe_quit ();
}
}
@@ -2466,7 +2466,7 @@ where_is_internal (Lisp_Object definition, Lisp_Object
keymaps,
non-ascii prefixes like `C-down-mouse-2'. */
continue;
- QUIT;
+ maybe_quit ();
data.definition = definition;
data.noindirect = noindirect;
@@ -3173,7 +3173,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix,
for (tail = map; CONSP (tail); tail = XCDR (tail))
{
- QUIT;
+ maybe_quit ();
if (VECTORP (XCAR (tail))
|| CHAR_TABLE_P (XCAR (tail)))
@@ -3426,7 +3426,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix,
Lisp_Object args,
int range_beg, range_end;
Lisp_Object val;
- QUIT;
+ maybe_quit ();
if (i == stop)
{
diff --git a/src/lisp.h b/src/lisp.h
index 005d1e7..2a32db6 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -310,7 +310,6 @@ error !;
# define lisp_h_XLI(o) (o)
# define lisp_h_XIL(i) (i)
#endif
-#define lisp_h_CHECK_LIST_CONS(x, y) CHECK_TYPE (CONSP (x), Qlistp, y)
#define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x)
#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
#define lisp_h_CHECK_TYPE(ok, predicate, x) \
@@ -367,7 +366,6 @@ error !;
#if DEFINE_KEY_OPS_AS_MACROS
# define XLI(o) lisp_h_XLI (o)
# define XIL(i) lisp_h_XIL (i)
-# define CHECK_LIST_CONS(x, y) lisp_h_CHECK_LIST_CONS (x, y)
# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x)
# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
@@ -1997,6 +1995,10 @@ struct Lisp_Hash_Table
hash table size to reduce collisions. */
Lisp_Object index;
+ /* Non-nil if the table can be purecopied. The table cannot be
+ changed afterwards. */
+ Lisp_Object pure;
+
/* Only the fields above are traced normally by the GC. The ones below
`count' are special and are either ignored by the GC or traced in
a special way (e.g. because of weakness). */
@@ -2751,9 +2753,9 @@ CHECK_LIST (Lisp_Object x)
}
INLINE void
-(CHECK_LIST_CONS) (Lisp_Object x, Lisp_Object y)
+CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
{
- lisp_h_CHECK_LIST_CONS (x, y);
+ CHECK_TYPE (NILP (x), Qlistp, y);
}
INLINE void
@@ -3121,38 +3123,28 @@ struct handler
extern Lisp_Object memory_signal_data;
-/* Check quit-flag and quit if it is non-nil.
- Typing C-g does not directly cause a quit; it only sets Vquit_flag.
- So the program needs to do QUIT at times when it is safe to quit.
- Every loop that might run for a long time or might not exit
- ought to do QUIT at least once, at a safe place.
- Unless that is impossible, of course.
- But it is very desirable to avoid creating loops where QUIT is impossible.
-
- Exception: if you set immediate_quit to true,
- then the handler that responds to the C-g does the quit itself.
- This is a good thing to do around a loop that has no side effects
- and (in particular) cannot call arbitrary Lisp code.
+extern void maybe_quit (void);
- If quit-flag is set to `kill-emacs' the SIGINT handler has received
- a request to exit Emacs when it is safe to do. */
+/* True if ought to quit now. */
-extern void process_pending_signals (void);
-extern bool volatile pending_signals;
+#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
-extern void process_quit_flag (void);
-#define QUIT \
- do { \
- if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
- process_quit_flag (); \
- else if (pending_signals) \
- process_pending_signals (); \
- } while (false)
+/* Heuristic on how many iterations of a tight loop can be safely done
+ before it's time to do a quit. This must be a power of 2. It
+ is nice but not necessary for it to equal USHRT_MAX + 1. */
+enum { QUIT_COUNT_HEURISTIC = 1 << 16 };
-/* True if ought to quit now. */
+/* Process a quit rarely, based on a counter COUNT, for efficiency.
+ "Rarely" means once per QUIT_COUNT_HEURISTIC or per USHRT_MAX + 1
+ times, whichever is smaller (somewhat arbitrary, but often faster). */
-#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
+INLINE void
+rarely_quit (unsigned short int count)
+{
+ if (! (count & (QUIT_COUNT_HEURISTIC - 1)))
+ maybe_quit ();
+}
extern Lisp_Object Vascii_downcase_table;
extern Lisp_Object Vascii_canon_table;
@@ -3375,7 +3367,7 @@ extern void sweep_weak_hash_tables (void);
EMACS_UINT hash_string (char const *, ptrdiff_t);
EMACS_UINT sxhash (Lisp_Object, int);
Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object);
+ Lisp_Object, Lisp_Object, Lisp_Object);
ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
EMACS_UINT);
@@ -4233,8 +4225,10 @@ extern int emacs_open (const char *, int, int);
extern int emacs_pipe (int[2]);
extern int emacs_close (int);
extern ptrdiff_t emacs_read (int, void *, ptrdiff_t);
+extern ptrdiff_t emacs_read_quit (int, void *, ptrdiff_t);
extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t);
extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t);
+extern ptrdiff_t emacs_write_quit (int, void const *, ptrdiff_t);
extern void emacs_perror (char const *);
extern void unlock_all_files (void);
@@ -4360,9 +4354,6 @@ extern char my_edata[];
extern char my_endbss[];
extern char *my_endbss_static;
-/* True means ^G can quit instantly. */
-extern bool immediate_quit;
-
extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2));
@@ -4549,7 +4540,7 @@ enum
use these only in macros like AUTO_CONS that declare a local
variable whose lifetime will be clear to the programmer. */
#define STACK_CONS(a, b) \
- make_lisp_ptr (&(union Aligned_Cons) { { a, { b } } }.s, Lisp_Cons)
+ make_lisp_ptr (&((union Aligned_Cons) { { a, { b } } }).s, Lisp_Cons)
#define AUTO_CONS_EXPR(a, b) \
(USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b))
@@ -4595,8 +4586,7 @@ enum
Lisp_Object name = \
(USE_STACK_STRING \
? (make_lisp_ptr \
- ((&(union Aligned_String) \
- {{len, -1, 0, (unsigned char *) (str)}}.s), \
+ ((&((union Aligned_String) {{len, -1, 0, (unsigned char *) (str)}}).s),
\
Lisp_String)) \
: make_unibyte_string (str, len))
diff --git a/src/lread.c b/src/lread.c
index 284fd1a..094aa62 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -451,7 +451,7 @@ readbyte_from_file (int c, Lisp_Object readcharfun)
while (c == EOF && ferror (instream) && errno == EINTR)
{
unblock_input ();
- QUIT;
+ maybe_quit ();
block_input ();
clearerr (instream);
c = getc (instream);
@@ -910,7 +910,7 @@ safe_to_load_version (int fd)
/* Read the first few bytes from the file, and look for a line
specifying the byte compiler version used. */
- nbytes = emacs_read (fd, buf, sizeof buf);
+ nbytes = emacs_read_quit (fd, buf, sizeof buf);
if (nbytes > 0)
{
/* Skip to the next newline, skipping over the initial `ELC'
@@ -1702,14 +1702,14 @@ build_load_history (Lisp_Object filename, bool entire)
Fcons (newelt, XCDR (tem))));
tem2 = XCDR (tem2);
- QUIT;
+ maybe_quit ();
}
}
}
else
prev = tail;
tail = XCDR (tail);
- QUIT;
+ maybe_quit ();
}
/* If we're loading an entire file, cons the new assoc onto the
@@ -2599,7 +2599,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
Lisp_Object val = Qnil;
/* The size is 2 * number of allowed keywords to
make-hash-table. */
- Lisp_Object params[10];
+ Lisp_Object params[12];
Lisp_Object ht;
Lisp_Object key = Qnil;
int param_count = 0;
@@ -2636,6 +2636,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
if (!NILP (params[param_count + 1]))
param_count += 2;
+ params[param_count] = QCpurecopy;
+ params[param_count + 1] = Fplist_get (tmp, Qpurecopy);
+ if (!NILP (params[param_count + 1]))
+ param_count += 2;
+
/* This is the hash table data. */
data = Fplist_get (tmp, Qdata);
@@ -4849,6 +4854,7 @@ that are loaded before your customizations are read! */);
DEFSYM (Qdata, "data");
DEFSYM (Qtest, "test");
DEFSYM (Qsize, "size");
+ DEFSYM (Qpurecopy, "purecopy");
DEFSYM (Qweakness, "weakness");
DEFSYM (Qrehash_size, "rehash-size");
DEFSYM (Qrehash_threshold, "rehash-threshold");
diff --git a/src/macros.c b/src/macros.c
index 3b29cc6..f0ffda3 100644
--- a/src/macros.c
+++ b/src/macros.c
@@ -325,7 +325,7 @@ each iteration of the macro. Iteration stops if LOOPFUNC
returns nil. */)
executing_kbd_macro_iterations = ++success_count;
- QUIT;
+ maybe_quit ();
}
while (--repeat
&& (STRINGP (Vexecuting_kbd_macro) || VECTORP (Vexecuting_kbd_macro)));
diff --git a/src/minibuf.c b/src/minibuf.c
index d44bb44..1bbe276 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -1865,7 +1865,7 @@ single string, rather than a cons cell whose car is a
string. */)
case_fold);
if (EQ (tem, Qt))
return elt;
- QUIT;
+ maybe_quit ();
}
return Qnil;
}
diff --git a/src/print.c b/src/print.c
index dfaa489..db3d00f 100644
--- a/src/print.c
+++ b/src/print.c
@@ -279,7 +279,7 @@ printchar (unsigned int ch, Lisp_Object fun)
unsigned char str[MAX_MULTIBYTE_LENGTH];
int len = CHAR_STRING (ch, str);
- QUIT;
+ maybe_quit ();
if (NILP (fun))
{
@@ -1352,7 +1352,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t),
40))];
- QUIT;
+ maybe_quit ();
/* Detect circularities and truncate them. */
if (NILP (Vprint_circle))
@@ -1446,7 +1446,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte);
- QUIT;
+ maybe_quit ();
if (multibyte
? (CHAR_BYTE8_P (c) && (c = CHAR_TO_BYTE8 (c), true))
@@ -1550,7 +1550,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
/* Here, we must convert each multi-byte form to the
corresponding character code before handing it to PRINTCHAR. */
FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte);
- QUIT;
+ maybe_quit ();
if (escapeflag)
{
@@ -1707,7 +1707,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
for (i = 0; i < size_in_chars; i++)
{
- QUIT;
+ maybe_quit ();
c = bool_vector_uchar_data (obj)[i];
if (c == '\n' && print_escape_newlines)
print_c_string ("\\n", printcharfun);
@@ -1818,6 +1818,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
print_object (h->rehash_threshold, printcharfun, escapeflag);
}
+ if (!NILP (h->pure))
+ {
+ print_c_string (" purecopy ", printcharfun);
+ print_object (h->pure, printcharfun, escapeflag);
+ }
+
print_c_string (" data ", printcharfun);
/* Print the data here as a plist. */
diff --git a/src/process.c b/src/process.c
index ab9657b..434a395 100644
--- a/src/process.c
+++ b/src/process.c
@@ -3431,16 +3431,14 @@ connect_network_socket (Lisp_Object proc, Lisp_Object
addrinfos,
break;
}
- immediate_quit = 1;
- QUIT;
+ maybe_quit ();
ret = connect (s, sa, addrlen);
xerrno = errno;
if (ret == 0 || xerrno == EISCONN)
{
- /* The unwind-protect will be discarded afterwards.
- Likewise for immediate_quit. */
+ /* The unwind-protect will be discarded afterwards. */
break;
}
@@ -3459,7 +3457,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object
addrinfos,
retry_select:
FD_ZERO (&fdset);
FD_SET (s, &fdset);
- QUIT;
+ maybe_quit ();
sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL);
if (sc == -1)
{
@@ -3481,8 +3479,6 @@ connect_network_socket (Lisp_Object proc, Lisp_Object
addrinfos,
}
#endif /* !WINDOWSNT */
- immediate_quit = 0;
-
/* Discard the unwind protect closing S. */
specpdl_ptr = specpdl + count;
emacs_close (s);
@@ -3539,8 +3535,6 @@ connect_network_socket (Lisp_Object proc, Lisp_Object
addrinfos,
#endif
}
- immediate_quit = 0;
-
if (s < 0)
{
/* If non-blocking got this far - and failed - assume non-blocking is
@@ -4012,8 +4006,7 @@ usage: (make-network-process &rest ARGS) */)
struct addrinfo *res, *lres;
int ret;
- immediate_quit = 1;
- QUIT;
+ maybe_quit ();
struct addrinfo hints;
memset (&hints, 0, sizeof hints);
@@ -4034,7 +4027,6 @@ usage: (make-network-process &rest ARGS) */)
#else
error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret);
#endif
- immediate_quit = 0;
for (lres = res; lres; lres = lres->ai_next)
addrinfos = Fcons (conv_addrinfo_to_lisp (lres), addrinfos);
@@ -5020,7 +5012,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
since we want to return C-g as an input character.
Otherwise, do pending quit if requested. */
if (read_kbd >= 0)
- QUIT;
+ maybe_quit ();
else if (pending_signals)
process_pending_signals ();
@@ -5748,7 +5740,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
{
/* Prevent input_pending from remaining set if we quit. */
clear_input_pending ();
- QUIT;
+ maybe_quit ();
}
return got_some_output;
@@ -7486,7 +7478,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
since we want to return C-g as an input character.
Otherwise, do pending quit if requested. */
if (read_kbd >= 0)
- QUIT;
+ maybe_quit ();
/* Exit now if the cell we're waiting for became non-nil. */
if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
diff --git a/src/profiler.c b/src/profiler.c
index efc0cb3..a223a7e 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -48,7 +48,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth)
make_number (heap_size),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil);
+ Qnil, Qnil);
struct Lisp_Hash_Table *h = XHASH_TABLE (log);
/* What is special about our hash-tables is that the keys are pre-filled
@@ -174,8 +174,8 @@ record_backtrace (log_t *log, EMACS_INT count)
some global flag so that some Elisp code can offload its
data elsewhere, so as to avoid the eviction code.
There are 2 ways to do that, AFAICT:
- - Set a flag checked in QUIT, such that QUIT can then call
- Fprofiler_cpu_log and stash the full log for later use.
+ - Set a flag checked in maybe_quit, such that maybe_quit can then
+ call Fprofiler_cpu_log and stash the full log for later use.
- Set a flag check in post-gc-hook, so that Elisp code can call
profiler-cpu-log. That gives us more flexibility since that
Elisp code can then do all kinds of fun stuff like write
diff --git a/src/regex.c b/src/regex.c
index db3f0c1..796f868 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -1728,13 +1728,8 @@ typedef struct
/* Explicit quit checking is needed for Emacs, which uses polling to
process input events. */
-#ifdef emacs
-# define IMMEDIATE_QUIT_CHECK \
- do { \
- if (immediate_quit) QUIT; \
- } while (0)
-#else
-# define IMMEDIATE_QUIT_CHECK ((void)0)
+#ifndef emacs
+static void maybe_quit (void) {}
#endif
/* Structure to manage work area for range table. */
@@ -5823,7 +5818,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
const_re_char *string1,
/* Unconditionally jump (without popping any failure points). */
case jump:
unconditional_jump:
- IMMEDIATE_QUIT_CHECK;
+ maybe_quit ();
EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */
DEBUG_PRINT ("EXECUTING jump %d ", mcnt);
p += mcnt; /* Do the jump. */
@@ -6171,7 +6166,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
const_re_char *string1,
/* We goto here if a matching operation fails. */
fail:
- IMMEDIATE_QUIT_CHECK;
+ maybe_quit ();
if (!FAIL_STACK_EMPTY ())
{
re_char *str, *pat;
diff --git a/src/search.c b/src/search.c
index d304510..33cb02a 100644
--- a/src/search.c
+++ b/src/search.c
@@ -99,6 +99,25 @@ matcher_overflow (void)
error ("Stack overflow in regexp matcher");
}
+static void
+freeze_buffer_relocation (void)
+{
+#ifdef REL_ALLOC
+ /* Prevent ralloc.c from relocating the current buffer while
+ searching it. */
+ r_alloc_inhibit_buffer_relocation (1);
+ record_unwind_protect_int (r_alloc_inhibit_buffer_relocation, 0);
+#endif
+}
+
+static void
+thaw_buffer_relocation (void)
+{
+#ifdef REL_ALLOC
+ unbind_to (SPECPDL_INDEX () - 1, Qnil);
+#endif
+}
+
/* Compile a regexp and signal a Lisp error if anything goes wrong.
PATTERN is the pattern to compile.
CP is the place to put the result.
@@ -276,8 +295,8 @@ looking_at_1 (Lisp_Object string, bool posix)
posix,
!NILP (BVAR (current_buffer,
enable_multibyte_characters)));
- immediate_quit = 1;
- QUIT; /* Do a pending quit right away, to avoid
paradoxical behavior */
+ /* Do a pending quit right away, to avoid paradoxical behavior */
+ maybe_quit ();
/* Get pointers and sizes of the two strings
that make up the visible portion of the buffer. */
@@ -300,20 +319,13 @@ looking_at_1 (Lisp_Object string, bool posix)
re_match_object = Qnil;
-#ifdef REL_ALLOC
- /* Prevent ralloc.c from relocating the current buffer while
- searching it. */
- r_alloc_inhibit_buffer_relocation (1);
-#endif
+ freeze_buffer_relocation ();
i = re_match_2 (bufp, (char *) p1, s1, (char *) p2, s2,
PT_BYTE - BEGV_BYTE,
(NILP (Vinhibit_changing_match_data)
? &search_regs : NULL),
ZV_BYTE - BEGV_BYTE);
- immediate_quit = 0;
-#ifdef REL_ALLOC
- r_alloc_inhibit_buffer_relocation (0);
-#endif
+ thaw_buffer_relocation ();
if (i == -2)
matcher_overflow ();
@@ -398,7 +410,6 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string,
Lisp_Object start,
? BVAR (current_buffer, case_canon_table) : Qnil),
posix,
STRING_MULTIBYTE (string));
- immediate_quit = 1;
re_match_object = string;
val = re_search (bufp, SSDATA (string),
@@ -406,7 +417,6 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string,
Lisp_Object start,
SBYTES (string) - pos_byte,
(NILP (Vinhibit_changing_match_data)
? &search_regs : NULL));
- immediate_quit = 0;
/* Set last_thing_searched only when match data is changed. */
if (NILP (Vinhibit_changing_match_data))
@@ -470,13 +480,11 @@ fast_string_match_internal (Lisp_Object regexp,
Lisp_Object string,
bufp = compile_pattern (regexp, 0, table,
0, STRING_MULTIBYTE (string));
- immediate_quit = 1;
re_match_object = string;
val = re_search (bufp, SSDATA (string),
SBYTES (string), 0,
SBYTES (string), 0);
- immediate_quit = 0;
return val;
}
@@ -497,9 +505,7 @@ fast_c_string_match_ignore_case (Lisp_Object regexp,
bufp = compile_pattern (regexp, 0,
Vascii_canon_table, 0,
0);
- immediate_quit = 1;
val = re_search (bufp, string, len, 0, len, 0);
- immediate_quit = 0;
return val;
}
@@ -560,18 +566,10 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos,
ptrdiff_t pos_byte,
}
buf = compile_pattern (regexp, 0, Qnil, 0, multibyte);
- immediate_quit = 1;
-#ifdef REL_ALLOC
- /* Prevent ralloc.c from relocating the current buffer while
- searching it. */
- r_alloc_inhibit_buffer_relocation (1);
-#endif
+ freeze_buffer_relocation ();
len = re_match_2 (buf, (char *) p1, s1, (char *) p2, s2,
pos_byte, NULL, limit_byte);
-#ifdef REL_ALLOC
- r_alloc_inhibit_buffer_relocation (0);
-#endif
- immediate_quit = 0;
+ thaw_buffer_relocation ();
return len;
}
@@ -648,7 +646,7 @@ newline_cache_on_off (struct buffer *buf)
If BYTEPOS is not NULL, set *BYTEPOS to the byte position corresponding
to the returned character position.
- If ALLOW_QUIT, set immediate_quit. That's good to do
+ If ALLOW_QUIT, check for quitting. That's good to do
except when inside redisplay. */
ptrdiff_t
@@ -684,8 +682,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
if (shortage != 0)
*shortage = 0;
- immediate_quit = allow_quit;
-
if (count > 0)
while (start != end)
{
@@ -703,7 +699,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
ptrdiff_t next_change;
int result = 1;
- immediate_quit = 0;
while (start < end && result)
{
ptrdiff_t lim1;
@@ -756,7 +751,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
start_byte = end_byte;
break;
}
- immediate_quit = allow_quit;
/* START should never be after END. */
if (start_byte > ceiling_byte)
@@ -809,11 +803,12 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
if (--count == 0)
{
- immediate_quit = 0;
if (bytepos)
*bytepos = lim_byte + next;
return BYTE_TO_CHAR (lim_byte + next);
}
+ if (allow_quit)
+ maybe_quit ();
}
start_byte = lim_byte;
@@ -832,7 +827,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
ptrdiff_t next_change;
int result = 1;
- immediate_quit = 0;
while (start > end && result)
{
ptrdiff_t lim1;
@@ -869,7 +863,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
start_byte = end_byte;
break;
}
- immediate_quit = allow_quit;
/* Start should never be at or before end. */
if (start_byte <= ceiling_byte)
@@ -917,11 +910,12 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
if (++count >= 0)
{
- immediate_quit = 0;
if (bytepos)
*bytepos = ceiling_byte + prev + 1;
return BYTE_TO_CHAR (ceiling_byte + prev + 1);
}
+ if (allow_quit)
+ maybe_quit ();
}
start_byte = ceiling_byte;
@@ -929,7 +923,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
}
}
- immediate_quit = 0;
if (shortage)
*shortage = count * direction;
if (bytepos)
@@ -953,7 +946,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
the number of line boundaries left unfound, and position at
the limit we bumped up against.
- If ALLOW_QUIT, set immediate_quit. That's good to do
+ If ALLOW_QUIT, check for quitting. That's good to do
except in special cases. */
ptrdiff_t
@@ -1196,10 +1189,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos,
ptrdiff_t pos_byte,
trt, posix,
!NILP (BVAR (current_buffer,
enable_multibyte_characters)));
- immediate_quit = 1; /* Quit immediately if user types ^G,
- because letting this function finish
- can take too long. */
- QUIT; /* Do a pending quit right away,
+ maybe_quit (); /* Do a pending quit right away,
to avoid paradoxical behavior */
/* Get pointers and sizes of the two strings
that make up the visible portion of the buffer. */
@@ -1221,11 +1211,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos,
ptrdiff_t pos_byte,
}
re_match_object = Qnil;
-#ifdef REL_ALLOC
- /* Prevent ralloc.c from relocating the current buffer while
- searching it. */
- r_alloc_inhibit_buffer_relocation (1);
-#endif
+ freeze_buffer_relocation ();
while (n < 0)
{
@@ -1267,13 +1253,11 @@ search_buffer (Lisp_Object string, ptrdiff_t pos,
ptrdiff_t pos_byte,
}
else
{
- immediate_quit = 0;
-#ifdef REL_ALLOC
- r_alloc_inhibit_buffer_relocation (0);
-#endif
+ thaw_buffer_relocation ();
return (n);
}
n++;
+ maybe_quit ();
}
while (n > 0)
{
@@ -1312,18 +1296,13 @@ search_buffer (Lisp_Object string, ptrdiff_t pos,
ptrdiff_t pos_byte,
}
else
{
- immediate_quit = 0;
-#ifdef REL_ALLOC
- r_alloc_inhibit_buffer_relocation (0);
-#endif
+ thaw_buffer_relocation ();
return (0 - n);
}
n--;
+ maybe_quit ();
}
- immediate_quit = 0;
-#ifdef REL_ALLOC
- r_alloc_inhibit_buffer_relocation (0);
-#endif
+ thaw_buffer_relocation ();
return (pos);
}
else /* non-RE case */
@@ -1927,7 +1906,7 @@ boyer_moore (EMACS_INT n, unsigned char *base_pat,
< 0)
return (n * (0 - direction));
/* First we do the part we can by pointers (maybe nothing) */
- QUIT;
+ maybe_quit ();
pat = base_pat;
limit = pos_byte - dirlen + direction;
if (direction > 0)
@@ -3230,8 +3209,6 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
if (shortage != 0)
*shortage = 0;
- immediate_quit = allow_quit;
-
if (count > 0)
while (start != end)
{
@@ -3274,11 +3251,12 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
if (--count == 0)
{
- immediate_quit = 0;
if (bytepos)
*bytepos = lim_byte + next;
return BYTE_TO_CHAR (lim_byte + next);
}
+ if (allow_quit)
+ maybe_quit ();
}
start_byte = lim_byte;
@@ -3286,7 +3264,6 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t end,
}
}
- immediate_quit = 0;
if (shortage)
*shortage = count;
if (bytepos)
diff --git a/src/syntax.c b/src/syntax.c
index 5bc0efa..34a9e63 100644
--- a/src/syntax.c
+++ b/src/syntax.c
@@ -1672,29 +1672,23 @@ DEFUN ("internal-describe-syntax-value",
Finternal_describe_syntax_value,
COUNT negative means scan backward and stop at word beginning. */
ptrdiff_t
-scan_words (register ptrdiff_t from, register EMACS_INT count)
+scan_words (ptrdiff_t from, EMACS_INT count)
{
- register ptrdiff_t beg = BEGV;
- register ptrdiff_t end = ZV;
- register ptrdiff_t from_byte = CHAR_TO_BYTE (from);
- register enum syntaxcode code;
+ ptrdiff_t beg = BEGV;
+ ptrdiff_t end = ZV;
+ ptrdiff_t from_byte = CHAR_TO_BYTE (from);
+ enum syntaxcode code;
int ch0, ch1;
Lisp_Object func, pos;
- immediate_quit = 1;
- QUIT;
-
SETUP_SYNTAX_TABLE (from, count);
while (count > 0)
{
- while (1)
+ while (true)
{
if (from == end)
- {
- immediate_quit = 0;
- return 0;
- }
+ return 0;
UPDATE_SYNTAX_TABLE_FORWARD (from);
ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte);
code = SYNTAX (ch0);
@@ -1704,6 +1698,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT
count)
break;
if (code == Sword)
break;
+ rarely_quit (from);
}
/* Now CH0 is a character which begins a word and FROM is the
position of the next character. */
@@ -1732,19 +1727,17 @@ scan_words (register ptrdiff_t from, register EMACS_INT
count)
break;
INC_BOTH (from, from_byte);
ch0 = ch1;
+ rarely_quit (from);
}
}
count--;
}
while (count < 0)
{
- while (1)
+ while (true)
{
if (from == beg)
- {
- immediate_quit = 0;
- return 0;
- }
+ return 0;
DEC_BOTH (from, from_byte);
UPDATE_SYNTAX_TABLE_BACKWARD (from);
ch1 = FETCH_CHAR_AS_MULTIBYTE (from_byte);
@@ -1754,6 +1747,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT
count)
break;
if (code == Sword)
break;
+ rarely_quit (from);
}
/* Now CH1 is a character which ends a word and FROM is the
position of it. */
@@ -1786,13 +1780,12 @@ scan_words (register ptrdiff_t from, register EMACS_INT
count)
break;
}
ch1 = ch0;
+ rarely_quit (from);
}
}
count++;
}
- immediate_quit = 0;
-
return from;
}
@@ -2176,7 +2169,6 @@ skip_chars (bool forwardp, Lisp_Object string,
Lisp_Object lim,
stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp;
}
- immediate_quit = 1;
/* This code may look up syntax tables using functions that rely on the
gl_state object. To make sure this object is not out of date,
let's initialize it manually.
@@ -2226,9 +2218,10 @@ skip_chars (bool forwardp, Lisp_Object string,
Lisp_Object lim,
}
fwd_ok:
p += nbytes, pos++, pos_byte += nbytes;
+ rarely_quit (pos);
}
else
- while (1)
+ while (true)
{
if (p >= stop)
{
@@ -2250,15 +2243,14 @@ skip_chars (bool forwardp, Lisp_Object string,
Lisp_Object lim,
break;
fwd_unibyte_ok:
p++, pos++, pos_byte++;
+ rarely_quit (pos);
}
}
else
{
if (multibyte)
- while (1)
+ while (true)
{
- unsigned char *prev_p;
-
if (p <= stop)
{
if (p <= endp)
@@ -2266,8 +2258,11 @@ skip_chars (bool forwardp, Lisp_Object string,
Lisp_Object lim,
p = GPT_ADDR;
stop = endp;
}
- prev_p = p;
- while (--p >= stop && ! CHAR_HEAD_P (*p));
+ unsigned char *prev_p = p;
+ do
+ p--;
+ while (stop <= p && ! CHAR_HEAD_P (*p));
+
c = STRING_CHAR (p);
if (! NILP (iso_classes) && in_classes (c, iso_classes))
@@ -2291,9 +2286,10 @@ skip_chars (bool forwardp, Lisp_Object string,
Lisp_Object lim,
}
back_ok:
pos--, pos_byte -= prev_p - p;
+ rarely_quit (pos);
}
else
- while (1)
+ while (true)
{
if (p <= stop)
{
@@ -2315,11 +2311,11 @@ skip_chars (bool forwardp, Lisp_Object string,
Lisp_Object lim,
break;
back_unibyte_ok:
p--, pos--, pos_byte--;
+ rarely_quit (pos);
}
}
SET_PT_BOTH (pos, pos_byte);
- immediate_quit = 0;
SAFE_FREE ();
return make_number (PT - start_point);
@@ -2393,7 +2389,6 @@ skip_syntaxes (bool forwardp, Lisp_Object string,
Lisp_Object lim)
ptrdiff_t pos_byte = PT_BYTE;
unsigned char *p, *endp, *stop;
- immediate_quit = 1;
SETUP_SYNTAX_TABLE (pos, forwardp ? 1 : -1);
if (forwardp)
@@ -2422,6 +2417,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string,
Lisp_Object lim)
if (! fastmap[SYNTAX (c)])
goto done;
p += nbytes, pos++, pos_byte += nbytes;
+ rarely_quit (pos);
}
while (!parse_sexp_lookup_properties
|| pos < gl_state.e_property);
@@ -2438,10 +2434,8 @@ skip_syntaxes (bool forwardp, Lisp_Object string,
Lisp_Object lim)
if (multibyte)
{
- while (1)
+ while (true)
{
- unsigned char *prev_p;
-
if (p <= stop)
{
if (p <= endp)
@@ -2450,17 +2444,22 @@ skip_syntaxes (bool forwardp, Lisp_Object string,
Lisp_Object lim)
stop = endp;
}
UPDATE_SYNTAX_TABLE_BACKWARD (pos - 1);
- prev_p = p;
- while (--p >= stop && ! CHAR_HEAD_P (*p));
+
+ unsigned char *prev_p = p;
+ do
+ p--;
+ while (stop <= p && ! CHAR_HEAD_P (*p));
+
c = STRING_CHAR (p);
if (! fastmap[SYNTAX (c)])
break;
pos--, pos_byte -= prev_p - p;
+ rarely_quit (pos);
}
}
else
{
- while (1)
+ while (true)
{
if (p <= stop)
{
@@ -2473,13 +2472,13 @@ skip_syntaxes (bool forwardp, Lisp_Object string,
Lisp_Object lim)
if (! fastmap[SYNTAX (p[-1])])
break;
p--, pos--, pos_byte--;
+ rarely_quit (pos);
}
}
}
done:
SET_PT_BOTH (pos, pos_byte);
- immediate_quit = 0;
return make_number (PT - start_point);
}
@@ -2541,9 +2540,10 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte,
ptrdiff_t stop,
ptrdiff_t *charpos_ptr, ptrdiff_t *bytepos_ptr,
EMACS_INT *incomment_ptr, int *last_syntax_ptr)
{
- register int c, c1;
- register enum syntaxcode code;
- register int syntax, other_syntax;
+ unsigned short int quit_count = 0;
+ int c, c1;
+ enum syntaxcode code;
+ int syntax, other_syntax;
if (nesting <= 0) nesting = -1;
@@ -2635,6 +2635,8 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte,
ptrdiff_t stop,
UPDATE_SYNTAX_TABLE_FORWARD (from);
nesting++;
}
+
+ rarely_quit (++quit_count);
}
*charpos_ptr = from;
*bytepos_ptr = from_byte;
@@ -2662,14 +2664,12 @@ between them, return t; otherwise return nil. */)
ptrdiff_t out_charpos, out_bytepos;
EMACS_INT dummy;
int dummy2;
+ unsigned short int quit_count = 0;
CHECK_NUMBER (count);
count1 = XINT (count);
stop = count1 > 0 ? ZV : BEGV;
- immediate_quit = 1;
- QUIT;
-
from = PT;
from_byte = PT_BYTE;
@@ -2684,7 +2684,6 @@ between them, return t; otherwise return nil. */)
if (from == stop)
{
SET_PT_BOTH (from, from_byte);
- immediate_quit = 0;
return Qnil;
}
c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
@@ -2711,6 +2710,7 @@ between them, return t; otherwise return nil. */)
INC_BOTH (from, from_byte);
UPDATE_SYNTAX_TABLE_FORWARD (from);
}
+ rarely_quit (++quit_count);
}
while (code == Swhitespace || (code == Sendcomment && c == '\n'));
@@ -2718,7 +2718,6 @@ between them, return t; otherwise return nil. */)
comstyle = ST_COMMENT_STYLE;
else if (code != Scomment)
{
- immediate_quit = 0;
DEC_BOTH (from, from_byte);
SET_PT_BOTH (from, from_byte);
return Qnil;
@@ -2729,7 +2728,6 @@ between them, return t; otherwise return nil. */)
from = out_charpos; from_byte = out_bytepos;
if (!found)
{
- immediate_quit = 0;
SET_PT_BOTH (from, from_byte);
return Qnil;
}
@@ -2741,23 +2739,19 @@ between them, return t; otherwise return nil. */)
while (count1 < 0)
{
- while (1)
+ while (true)
{
- bool quoted;
- int syntax;
-
if (from <= stop)
{
SET_PT_BOTH (BEGV, BEGV_BYTE);
- immediate_quit = 0;
return Qnil;
}
DEC_BOTH (from, from_byte);
/* char_quoted does UPDATE_SYNTAX_TABLE_BACKWARD (from). */
- quoted = char_quoted (from, from_byte);
+ bool quoted = char_quoted (from, from_byte);
c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
- syntax = SYNTAX_WITH_FLAGS (c);
+ int syntax = SYNTAX_WITH_FLAGS (c);
code = SYNTAX (c);
comstyle = 0;
comnested = SYNTAX_FLAGS_COMMENT_NESTED (syntax);
@@ -2800,6 +2794,7 @@ between them, return t; otherwise return nil. */)
}
else if (from == stop)
break;
+ rarely_quit (++quit_count);
}
if (fence_found == 0)
{
@@ -2842,18 +2837,18 @@ between them, return t; otherwise return nil. */)
else if (code != Swhitespace || quoted)
{
leave:
- immediate_quit = 0;
INC_BOTH (from, from_byte);
SET_PT_BOTH (from, from_byte);
return Qnil;
}
+
+ rarely_quit (++quit_count);
}
count1++;
}
SET_PT_BOTH (from, from_byte);
- immediate_quit = 0;
return Qt;
}
@@ -2887,6 +2882,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
EMACS_INT dummy;
int dummy2;
bool multibyte_symbol_p = sexpflag && multibyte_syntax_as_symbol;
+ unsigned short int quit_count = 0;
if (depth > 0) min_depth = 0;
@@ -2895,14 +2891,14 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
from_byte = CHAR_TO_BYTE (from);
- immediate_quit = 1;
- QUIT;
+ maybe_quit ();
SETUP_SYNTAX_TABLE (from, count);
while (count > 0)
{
while (from < stop)
{
+ rarely_quit (++quit_count);
bool comstart_first, prefix;
int syntax, other_syntax;
UPDATE_SYNTAX_TABLE_FORWARD (from);
@@ -2971,6 +2967,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
goto done;
}
INC_BOTH (from, from_byte);
+ rarely_quit (++quit_count);
}
goto done;
@@ -3042,6 +3039,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
if (c_code == Scharquote || c_code == Sescape)
INC_BOTH (from, from_byte);
INC_BOTH (from, from_byte);
+ rarely_quit (++quit_count);
}
INC_BOTH (from, from_byte);
if (!depth && sexpflag) goto done;
@@ -3056,7 +3054,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
if (depth)
goto lose;
- immediate_quit = 0;
return Qnil;
/* End of object reached */
@@ -3068,11 +3065,11 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
{
while (from > stop)
{
- int syntax;
+ rarely_quit (++quit_count);
DEC_BOTH (from, from_byte);
UPDATE_SYNTAX_TABLE_BACKWARD (from);
c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
- syntax= SYNTAX_WITH_FLAGS (c);
+ int syntax = SYNTAX_WITH_FLAGS (c);
code = syntax_multibyte (c, multibyte_symbol_p);
if (depth == min_depth)
last_good = from;
@@ -3144,6 +3141,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
default: goto done2;
}
DEC_BOTH (from, from_byte);
+ rarely_quit (++quit_count);
}
goto done2;
@@ -3206,13 +3204,14 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
if (syntax_multibyte (c, multibyte_symbol_p) == code)
break;
}
+ rarely_quit (++quit_count);
}
if (code == Sstring_fence && !depth && sexpflag) goto done2;
break;
case Sstring:
stringterm = FETCH_CHAR_AS_MULTIBYTE (from_byte);
- while (1)
+ while (true)
{
if (from == stop)
goto lose;
@@ -3226,6 +3225,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
== Sstring))
break;
}
+ rarely_quit (++quit_count);
}
if (!depth && sexpflag) goto done2;
break;
@@ -3239,7 +3239,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
if (depth)
goto lose;
- immediate_quit = 0;
return Qnil;
done2:
@@ -3247,7 +3246,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT
depth, bool sexpflag)
}
- immediate_quit = 0;
XSETFASTINT (val, from);
return val;
@@ -3340,6 +3338,7 @@ the prefix syntax flag (p). */)
if (pos <= beg)
break;
DEC_BOTH (pos, pos_byte);
+ rarely_quit (pos);
}
SET_PT_BOTH (opoint, opoint_byte);
@@ -3347,6 +3346,36 @@ the prefix syntax flag (p). */)
return Qnil;
}
+
+/* If the character at FROM_BYTE is the second part of a 2-character
+ comment opener based on PREV_FROM_SYNTAX, update STATE and return
+ true. */
+static bool
+in_2char_comment_start (struct lisp_parse_state *state,
+ int prev_from_syntax,
+ ptrdiff_t prev_from,
+ ptrdiff_t from_byte)
+{
+ int c1, syntax;
+ if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax)
+ && (c1 = FETCH_CHAR_AS_MULTIBYTE (from_byte),
+ syntax = SYNTAX_WITH_FLAGS (c1),
+ SYNTAX_FLAGS_COMSTART_SECOND (syntax)))
+ {
+ /* Record the comment style we have entered so that only
+ the comment-end sequence of the same style actually
+ terminates the comment section. */
+ state->comstyle
+ = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax);
+ bool comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax)
+ | SYNTAX_FLAGS_COMMENT_NESTED (syntax));
+ state->incomment = comnested ? 1 : -1;
+ state->comstr_start = prev_from;
+ return true;
+ }
+ return false;
+}
+
/* Parse forward from FROM / FROM_BYTE to END,
assuming that FROM has state STATE,
and return a description of the state of the parse at END.
@@ -3362,8 +3391,6 @@ scan_sexps_forward (struct lisp_parse_state *state,
int commentstop)
{
enum syntaxcode code;
- int c1;
- bool comnested;
struct level { ptrdiff_t last, prev; };
struct level levelstart[100];
struct level *curlevel = levelstart;
@@ -3377,12 +3404,12 @@ scan_sexps_forward (struct lisp_parse_state *state,
ptrdiff_t prev_from; /* Keep one character before FROM. */
ptrdiff_t prev_from_byte;
int prev_from_syntax, prev_prev_from_syntax;
- int syntax;
bool boundary_stop = commentstop == -1;
bool nofence;
bool found;
ptrdiff_t out_bytepos, out_charpos;
int temp;
+ unsigned short int quit_count = 0;
prev_from = from;
prev_from_byte = from_byte;
@@ -3401,8 +3428,7 @@ do { prev_from = from; \
UPDATE_SYNTAX_TABLE_FORWARD (from); \
} while (0)
- immediate_quit = 1;
- QUIT;
+ maybe_quit ();
depth = state->depth;
start_quoted = state->quoted;
@@ -3442,53 +3468,32 @@ do { prev_from = from; \
}
else if (start_quoted)
goto startquoted;
+ else if ((from < end)
+ && (in_2char_comment_start (state, prev_from_syntax,
+ prev_from, from_byte)))
+ {
+ INC_FROM;
+ prev_from_syntax = Smax; /* the syntax has already been "used up". */
+ goto atcomment;
+ }
while (from < end)
{
- if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax)
- && (c1 = FETCH_CHAR (from_byte),
- syntax = SYNTAX_WITH_FLAGS (c1),
- SYNTAX_FLAGS_COMSTART_SECOND (syntax)))
- {
- /* Record the comment style we have entered so that only
- the comment-end sequence of the same style actually
- terminates the comment section. */
- state->comstyle
- = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax);
- comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax)
- | SYNTAX_FLAGS_COMMENT_NESTED (syntax));
- state->incomment = comnested ? 1 : -1;
- state->comstr_start = prev_from;
- INC_FROM;
- prev_from_syntax = Smax; /* the syntax has already been
- "used up". */
- code = Scomment;
- }
- else
+ rarely_quit (++quit_count);
+ INC_FROM;
+
+ if ((from < end)
+ && (in_2char_comment_start (state, prev_from_syntax,
+ prev_from, from_byte)))
{
INC_FROM;
- code = prev_from_syntax & 0xff;
- if (code == Scomment_fence)
- {
- /* Record the comment style we have entered so that only
- the comment-end sequence of the same style actually
- terminates the comment section. */
- state->comstyle = ST_COMMENT_STYLE;
- state->incomment = -1;
- state->comstr_start = prev_from;
- code = Scomment;
- }
- else if (code == Scomment)
- {
- state->comstyle = SYNTAX_FLAGS_COMMENT_STYLE (prev_from_syntax,
0);
- state->incomment = (SYNTAX_FLAGS_COMMENT_NESTED
(prev_from_syntax) ?
- 1 : -1);
- state->comstr_start = prev_from;
- }
+ prev_from_syntax = Smax; /* the syntax has already been "used up". */
+ goto atcomment;
}
if (SYNTAX_FLAGS_PREFIX (prev_from_syntax))
continue;
+ code = prev_from_syntax & 0xff;
switch (code)
{
case Sescape:
@@ -3507,24 +3512,15 @@ do { prev_from = from; \
symstarted:
while (from < end)
{
- int symchar = FETCH_CHAR_AS_MULTIBYTE (from_byte);
-
- if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax)
- && (syntax = SYNTAX_WITH_FLAGS (symchar),
- SYNTAX_FLAGS_COMSTART_SECOND (syntax)))
+ if (in_2char_comment_start (state, prev_from_syntax,
+ prev_from, from_byte))
{
- state->comstyle
- = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax);
- comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax)
- | SYNTAX_FLAGS_COMMENT_NESTED (syntax));
- state->incomment = comnested ? 1 : -1;
- state->comstr_start = prev_from;
INC_FROM;
- prev_from_syntax = Smax;
- code = Scomment;
+ prev_from_syntax = Smax; /* the syntax has already been
"used up". */
goto atcomment;
}
+ int symchar = FETCH_CHAR_AS_MULTIBYTE (from_byte);
switch (SYNTAX (symchar))
{
case Scharquote:
@@ -3540,13 +3536,25 @@ do { prev_from = from; \
goto symdone;
}
INC_FROM;
+ rarely_quit (++quit_count);
}
symdone:
curlevel->prev = curlevel->last;
break;
- case Scomment_fence: /* Can't happen because it's handled above. */
+ case Scomment_fence:
+ /* Record the comment style we have entered so that only
+ the comment-end sequence of the same style actually
+ terminates the comment section. */
+ state->comstyle = ST_COMMENT_STYLE;
+ state->incomment = -1;
+ state->comstr_start = prev_from;
+ goto atcomment;
case Scomment:
+ state->comstyle = SYNTAX_FLAGS_COMMENT_STYLE (prev_from_syntax, 0);
+ state->incomment = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) ?
+ 1 : -1);
+ state->comstr_start = prev_from;
atcomment:
if (commentstop || boundary_stop) goto done;
startincomment:
@@ -3639,6 +3647,7 @@ do { prev_from = from; \
break;
}
INC_FROM;
+ rarely_quit (++quit_count);
}
}
string_end:
@@ -3680,7 +3689,6 @@ do { prev_from = from; \
state->levelstarts);
state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax)
|| state->quoted) ? prev_from_syntax : Smax;
- immediate_quit = 0;
}
/* Convert a (lisp) parse state to the internal form used in
diff --git a/src/sysdep.c b/src/sysdep.c
index 4316c21..91b2a5c 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -382,19 +382,23 @@ get_child_status (pid_t child, int *status, int options,
bool interruptible)
so that another thread running glib won't find them. */
eassert (child > 0);
- while ((pid = waitpid (child, status, options)) < 0)
+ while (true)
{
+ /* Note: the MS-Windows emulation of waitpid calls maybe_quit
+ internally. */
+ if (interruptible)
+ maybe_quit ();
+
+ pid = waitpid (child, status, options);
+ if (0 <= pid)
+ break;
+
/* Check that CHILD is a child process that has not been reaped,
and that STATUS and OPTIONS are valid. Otherwise abort,
as continuing after this internal error could cause Emacs to
become confused and kill innocent-victim processes. */
if (errno != EINTR)
emacs_abort ();
-
- /* Note: the MS-Windows emulation of waitpid calls QUIT
- internally. */
- if (interruptible)
- QUIT;
}
/* If successful and status is requested, tell wait_reading_process_output
@@ -2383,7 +2387,7 @@ emacs_open (const char *file, int oflags, int mode)
oflags |= O_BINARY;
oflags |= O_CLOEXEC;
while ((fd = open (file, oflags, mode)) < 0 && errno == EINTR)
- QUIT;
+ maybe_quit ();
if (! O_CLOEXEC && 0 <= fd)
fcntl (fd, F_SETFD, FD_CLOEXEC);
return fd;
@@ -2503,78 +2507,113 @@ emacs_close (int fd)
#define MAX_RW_COUNT (INT_MAX >> 18 << 18)
#endif
-/* Read from FILEDESC to a buffer BUF with size NBYTE, retrying if interrupted.
+/* Read from FD to a buffer BUF with size NBYTE.
+ If interrupted, process any quits and pending signals immediately
+ if INTERRUPTIBLE, and then retry the read unless quitting.
Return the number of bytes read, which might be less than NBYTE.
- On error, set errno and return -1. */
-ptrdiff_t
-emacs_read (int fildes, void *buf, ptrdiff_t nbyte)
+ On error, set errno to a value other than EINTR, and return -1. */
+static ptrdiff_t
+emacs_intr_read (int fd, void *buf, ptrdiff_t nbyte, bool interruptible)
{
- ssize_t rtnval;
+ ssize_t result;
/* There is no need to check against MAX_RW_COUNT, since no caller ever
passes a size that large to emacs_read. */
+ do
+ {
+ if (interruptible)
+ maybe_quit ();
+ result = read (fd, buf, nbyte);
+ }
+ while (result < 0 && errno == EINTR);
- while ((rtnval = read (fildes, buf, nbyte)) == -1
- && (errno == EINTR))
- QUIT;
- return (rtnval);
+ return result;
}
-/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if interrupted
- or if a partial write occurs. If interrupted, process pending
- signals if PROCESS SIGNALS. Return the number of bytes written, setting
- errno if this is less than NBYTE. */
+/* Read from FD to a buffer BUF with size NBYTE.
+ If interrupted, retry the read. Return the number of bytes read,
+ which might be less than NBYTE. On error, set errno to a value
+ other than EINTR, and return -1. */
+ptrdiff_t
+emacs_read (int fd, void *buf, ptrdiff_t nbyte)
+{
+ return emacs_intr_read (fd, buf, nbyte, false);
+}
+
+/* Like emacs_read, but also process quits and pending signals. */
+ptrdiff_t
+emacs_read_quit (int fd, void *buf, ptrdiff_t nbyte)
+{
+ return emacs_intr_read (fd, buf, nbyte, true);
+}
+
+/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if
+ interrupted or if a partial write occurs. Process any quits
+ immediately if INTERRUPTIBLE is positive, and process any pending
+ signals immediately if INTERRUPTIBLE is nonzero. Return the number
+ of bytes written; if this is less than NBYTE, set errno to a value
+ other than EINTR. */
static ptrdiff_t
-emacs_full_write (int fildes, char const *buf, ptrdiff_t nbyte,
- bool process_signals)
+emacs_full_write (int fd, char const *buf, ptrdiff_t nbyte,
+ int interruptible)
{
ptrdiff_t bytes_written = 0;
while (nbyte > 0)
{
- ssize_t n = write (fildes, buf, min (nbyte, MAX_RW_COUNT));
+ ssize_t n = write (fd, buf, min (nbyte, MAX_RW_COUNT));
if (n < 0)
{
- if (errno == EINTR)
+ if (errno != EINTR)
+ break;
+
+ if (interruptible)
{
- /* I originally used `QUIT' but that might cause files to
- be truncated if you hit C-g in the middle of it. --Stef */
- if (process_signals && pending_signals)
+ if (0 < interruptible)
+ maybe_quit ();
+ if (pending_signals)
process_pending_signals ();
- continue;
}
- else
- break;
}
-
- buf += n;
- nbyte -= n;
- bytes_written += n;
+ else
+ {
+ buf += n;
+ nbyte -= n;
+ bytes_written += n;
+ }
}
return bytes_written;
}
-/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if
- interrupted or if a partial write occurs. Return the number of
- bytes written, setting errno if this is less than NBYTE. */
+/* Write to FD from a buffer BUF with size NBYTE, retrying if
+ interrupted or if a partial write occurs. Do not process quits or
+ pending signals. Return the number of bytes written, setting errno
+ if this is less than NBYTE. */
+ptrdiff_t
+emacs_write (int fd, void const *buf, ptrdiff_t nbyte)
+{
+ return emacs_full_write (fd, buf, nbyte, 0);
+}
+
+/* Like emacs_write, but also process pending signals. */
ptrdiff_t
-emacs_write (int fildes, void const *buf, ptrdiff_t nbyte)
+emacs_write_sig (int fd, void const *buf, ptrdiff_t nbyte)
{
- return emacs_full_write (fildes, buf, nbyte, 0);
+ return emacs_full_write (fd, buf, nbyte, -1);
}
-/* Like emacs_write, but also process pending signals if interrupted. */
+/* Like emacs_write, but also process quits and pending signals. */
ptrdiff_t
-emacs_write_sig (int fildes, void const *buf, ptrdiff_t nbyte)
+emacs_write_quit (int fd, void const *buf, ptrdiff_t nbyte)
{
- return emacs_full_write (fildes, buf, nbyte, 1);
+ return emacs_full_write (fd, buf, nbyte, 1);
}
/* Write a diagnostic to standard error that contains MESSAGE and a
string derived from errno. Preserve errno. Do not buffer stderr.
- Do not process pending signals if interrupted. */
+ Do not process quits or pending signals if interrupted. */
void
emacs_perror (char const *message)
{
@@ -3168,7 +3207,7 @@ system_process_attributes (Lisp_Object pid)
else
{
record_unwind_protect_int (close_file_unwind, fd);
- nread = emacs_read (fd, procbuf, sizeof procbuf - 1);
+ nread = emacs_read_quit (fd, procbuf, sizeof procbuf - 1);
}
if (0 < nread)
{
@@ -3289,7 +3328,7 @@ system_process_attributes (Lisp_Object pid)
/* Leave room even if every byte needs escaping below. */
readsize = (cmdline_size >> 1) - nread;
- nread_incr = emacs_read (fd, cmdline + nread, readsize);
+ nread_incr = emacs_read_quit (fd, cmdline + nread, readsize);
nread += max (0, nread_incr);
}
while (nread_incr == readsize);
@@ -3402,7 +3441,7 @@ system_process_attributes (Lisp_Object pid)
else
{
record_unwind_protect_int (close_file_unwind, fd);
- nread = emacs_read (fd, &pinfo, sizeof pinfo);
+ nread = emacs_read_quit (fd, &pinfo, sizeof pinfo);
}
if (nread == sizeof pinfo)
diff --git a/src/textprop.c b/src/textprop.c
index bf77f84..116bf3f 100644
--- a/src/textprop.c
+++ b/src/textprop.c
@@ -212,7 +212,7 @@ validate_plist (Lisp_Object list)
if (! CONSP (tail))
error ("Odd length text property list");
tail = XCDR (tail);
- QUIT;
+ maybe_quit ();
}
while (CONSP (tail));
diff --git a/src/w32fns.c b/src/w32fns.c
index c24fce1..1b628b0 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -778,7 +778,7 @@ w32_color_map_lookup (const char *colorname)
break;
}
- QUIT;
+ maybe_quit ();
}
unblock_input ();
@@ -3166,18 +3166,9 @@ signal_user_input (void)
if (!NILP (Vthrow_on_input))
{
Vquit_flag = Vthrow_on_input;
- /* Doing a QUIT from this thread is a bad idea, since this
+ /* Calling maybe_quit from this thread is a bad idea, since this
unwinds the stack of the Lisp thread, and the Windows runtime
- rightfully barfs. Disabled. */
-#if 0
- /* If we're inside a function that wants immediate quits,
- do it now. */
- if (immediate_quit && NILP (Vinhibit_quit))
- {
- immediate_quit = 0;
- QUIT;
- }
-#endif
+ rightfully barfs. */
}
}
diff --git a/src/w32notify.c b/src/w32notify.c
index 1f4cbe2..2520581 100644
--- a/src/w32notify.c
+++ b/src/w32notify.c
@@ -664,7 +664,7 @@ w32_get_watch_object (void *desc)
Lisp_Object descriptor = make_pointer_integer (desc);
/* This is called from the input queue handling code, inside a
- critical section, so we cannot possibly QUIT if watch_list is not
+ critical section, so we cannot possibly quit if watch_list is not
in the right condition. */
return NILP (watch_list) ? Qnil : assoc_no_quit (descriptor, watch_list);
}
diff --git a/src/w32proc.c b/src/w32proc.c
index a7f2b4a..0aa248a 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -1449,7 +1449,7 @@ waitpid (pid_t pid, int *status, int options)
do
{
- QUIT;
+ maybe_quit ();
active = WaitForMultipleObjects (nh, wait_hnd, FALSE, timeout_ms);
} while (active == WAIT_TIMEOUT && !dont_wait);
diff --git a/src/window.c b/src/window.c
index 0a6b94d..9569044 100644
--- a/src/window.c
+++ b/src/window.c
@@ -521,9 +521,10 @@ select_window (Lisp_Object window, Lisp_Object norecord,
bset_last_selected_window (XBUFFER (w->contents), window);
record_and_return:
- /* record_buffer can run QUIT, so make sure it is run only after we have
- re-established the invariant between selected_window and selected_frame,
- otherwise the temporary broken invariant might "escape" (bug#14161). */
+ /* record_buffer can call maybe_quit, so make sure it is run only
+ after we have re-established the invariant between
+ selected_window and selected_frame, otherwise the temporary
+ broken invariant might "escape" (Bug#14161). */
if (NILP (norecord))
{
w->use_time = ++window_select_count;
@@ -4769,7 +4770,6 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool
whole, bool noerror)
{
ptrdiff_t count = SPECPDL_INDEX ();
- immediate_quit = true;
n = clip_to_bounds (INT_MIN, n, INT_MAX);
wset_redisplay (XWINDOW (window));
@@ -4788,7 +4788,36 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool
whole, bool noerror)
/* Bug#15957. */
XWINDOW (window)->window_end_valid = false;
- immediate_quit = false;
+}
+
+/* Compute scroll margin for WINDOW.
+ We scroll when point is within this distance from the top or bottom
+ of the window. The result is measured in lines or in pixels
+ depending on the second parameter. */
+int
+window_scroll_margin (struct window *window, enum margin_unit unit)
+{
+ if (scroll_margin > 0)
+ {
+ int frame_line_height = default_line_pixel_height (window);
+ int window_lines = window_box_height (window) / frame_line_height;
+
+ double ratio = 0.25;
+ if (FLOATP (Vmaximum_scroll_margin))
+ {
+ ratio = XFLOAT_DATA (Vmaximum_scroll_margin);
+ ratio = max (0.0, ratio);
+ ratio = min (ratio, 0.5);
+ }
+ int max_margin = min ((window_lines - 1)/2,
+ (int) (window_lines * ratio));
+ int margin = clip_to_bounds (0, scroll_margin, max_margin);
+ return (unit == MARGIN_IN_PIXELS)
+ ? margin * frame_line_height
+ : margin;
+ }
+ else
+ return 0;
}
@@ -4807,7 +4836,6 @@ window_scroll_pixel_based (Lisp_Object window, int n,
bool whole, bool noerror)
bool vscrolled = false;
int x, y, rtop, rbot, rowh, vpos;
void *itdata = NULL;
- int window_total_lines;
int frame_line_height = default_line_pixel_height (w);
bool adjust_old_pointm = !NILP (Fequal (Fwindow_point (window),
Fwindow_old_point (window)));
@@ -5063,12 +5091,7 @@ window_scroll_pixel_based (Lisp_Object window, int n,
bool whole, bool noerror)
/* Move PT out of scroll margins.
This code wants current_y to be zero at the window start position
even if there is a header line. */
- window_total_lines
- = w->total_lines * WINDOW_FRAME_LINE_HEIGHT (w) / frame_line_height;
- this_scroll_margin = max (0, scroll_margin);
- this_scroll_margin
- = min (this_scroll_margin, window_total_lines / 4);
- this_scroll_margin *= frame_line_height;
+ this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
if (n > 0)
{
@@ -5124,7 +5147,7 @@ window_scroll_pixel_based (Lisp_Object window, int n,
bool whole, bool noerror)
in the scroll margin at the bottom. */
move_it_to (&it, PT, -1,
(it.last_visible_y - WINDOW_HEADER_LINE_HEIGHT (w)
- - this_scroll_margin - 1),
+ - partial_line_height (&it) - this_scroll_margin - 1),
-1,
MOVE_TO_POS | MOVE_TO_Y);
@@ -5291,9 +5314,7 @@ window_scroll_line_based (Lisp_Object window, int n, bool
whole, bool noerror)
if (pos < ZV)
{
- /* Don't use a scroll margin that is negative or too large. */
- int this_scroll_margin =
- max (0, min (scroll_margin, w->total_lines / 4));
+ int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
set_marker_restricted_both (w->start, w->contents, pos, pos_byte);
w->start_at_line_beg = !NILP (bolp);
@@ -5723,8 +5744,7 @@ and redisplay normally--don't erase and redraw the frame.
*/)
/* Do this after making BUF current
in case scroll_margin is buffer-local. */
- this_scroll_margin
- = max (0, min (scroll_margin, w->total_lines / 4));
+ this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
/* Don't use redisplay code for initial frames, as the necessary
data structures might not be set up yet then. */
@@ -5963,10 +5983,6 @@ from the top of the window. */)
lines = displayed_window_lines (w);
-#if false
- this_scroll_margin = max (0, min (scroll_margin, lines / 4));
-#endif
-
if (NILP (arg))
XSETFASTINT (arg, lines / 2);
else
@@ -5982,6 +5998,8 @@ from the top of the window. */)
it is probably better not to install it. However, it is here
inside #if false so as not to lose it. -- rms. */
+ this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
+
/* Don't let it get into the margin at either top or bottom. */
iarg = max (iarg, this_scroll_margin);
iarg = min (iarg, lines - this_scroll_margin - 1);
diff --git a/src/window.h b/src/window.h
index 061cf24..acb8a5c 100644
--- a/src/window.h
+++ b/src/window.h
@@ -1120,6 +1120,8 @@ extern bool compare_window_configurations (Lisp_Object,
Lisp_Object, bool);
extern void mark_window_cursors_off (struct window *);
extern int window_internal_height (struct window *);
extern int window_body_width (struct window *w, bool);
+enum margin_unit { MARGIN_IN_LINES, MARGIN_IN_PIXELS };
+extern int window_scroll_margin (struct window *, enum margin_unit);
extern void temp_output_buffer_show (Lisp_Object);
extern void replace_buffer_in_windows (Lisp_Object);
extern void replace_buffer_in_windows_safely (Lisp_Object);
diff --git a/src/xdisp.c b/src/xdisp.c
index 168922e..0e329df 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -9859,6 +9859,32 @@ move_it_by_lines (struct it *it, ptrdiff_t dvpos)
}
}
+int
+partial_line_height (struct it *it_origin)
+{
+ int partial_height;
+ void *it_data = NULL;
+ struct it it;
+ SAVE_IT (it, *it_origin, it_data);
+ move_it_to (&it, ZV, -1, it.last_visible_y, -1,
+ MOVE_TO_POS | MOVE_TO_Y);
+ if (it.what == IT_EOB)
+ {
+ int vis_height = it.last_visible_y - it.current_y;
+ int height = it.ascent + it.descent;
+ partial_height = (vis_height < height) ? vis_height : 0;
+ }
+ else
+ {
+ int last_line_y = it.current_y;
+ move_it_by_lines (&it, 1);
+ partial_height = (it.current_y > it.last_visible_y)
+ ? it.last_visible_y - last_line_y : 0;
+ }
+ RESTORE_IT (&it, &it, it_data);
+ return partial_height;
+}
+
/* Return true if IT points into the middle of a display vector. */
bool
@@ -15316,7 +15342,6 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
bool temp_scroll_step, bool last_line_misfit)
{
struct window *w = XWINDOW (window);
- struct frame *f = XFRAME (w->frame);
struct text_pos pos, startp;
struct it it;
int this_scroll_margin, scroll_max, rc, height;
@@ -15327,8 +15352,6 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
/* We will never try scrolling more than this number of lines. */
int scroll_limit = SCROLL_LIMIT;
int frame_line_height = default_line_pixel_height (w);
- int window_total_lines
- = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
#ifdef GLYPH_DEBUG
debug_method_add (w, "try_scrolling");
@@ -15336,13 +15359,7 @@ try_scrolling (Lisp_Object window, bool
just_this_one_p,
SET_TEXT_POS_FROM_MARKER (startp, w->start);
- /* Compute scroll margin height in pixels. We scroll when point is
- within this distance from the top or bottom of the window. */
- if (scroll_margin > 0)
- this_scroll_margin = min (scroll_margin, window_total_lines / 4)
- * frame_line_height;
- else
- this_scroll_margin = 0;
+ this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
/* Force arg_scroll_conservatively to have a reasonable value, to
avoid scrolling too far away with slow move_it_* functions. Note
@@ -15377,7 +15394,8 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
/* Compute the pixel ypos of the scroll margin, then move IT to
either that ypos or PT, whichever comes first. */
start_display (&it, w, startp);
- scroll_margin_y = it.last_visible_y - this_scroll_margin
+ scroll_margin_y = it.last_visible_y - partial_line_height (&it)
+ - this_scroll_margin
- frame_line_height * extra_scroll_margin_lines;
move_it_to (&it, PT, -1, scroll_margin_y - 1, -1,
(MOVE_TO_POS | MOVE_TO_Y));
@@ -15816,23 +15834,12 @@ try_cursor_movement (Lisp_Object window, struct
text_pos startp,
{
int this_scroll_margin, top_scroll_margin;
struct glyph_row *row = NULL;
- int frame_line_height = default_line_pixel_height (w);
- int window_total_lines
- = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
#ifdef GLYPH_DEBUG
debug_method_add (w, "cursor movement");
#endif
- /* Scroll if point within this distance from the top or bottom
- of the window. This is a pixel value. */
- if (scroll_margin > 0)
- {
- this_scroll_margin = min (scroll_margin, window_total_lines / 4);
- this_scroll_margin *= frame_line_height;
- }
- else
- this_scroll_margin = 0;
+ this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
top_scroll_margin = this_scroll_margin;
if (WINDOW_WANTS_HEADER_LINE_P (w))
@@ -16280,7 +16287,7 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
int centering_position = -1;
bool last_line_misfit = false;
ptrdiff_t beg_unchanged, end_unchanged;
- int frame_line_height;
+ int frame_line_height, margin;
bool use_desired_matrix;
void *itdata = NULL;
@@ -16310,6 +16317,8 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
restart:
reconsider_clip_changes (w);
frame_line_height = default_line_pixel_height (w);
+ margin = window_scroll_margin (w, MARGIN_IN_LINES);
+
/* Has the mode line to be updated? */
update_mode_line = (w->update_mode_line
@@ -16614,10 +16623,7 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
/* Some people insist on not letting point enter the scroll
margin, even though this part handles windows that didn't
scroll at all. */
- int window_total_lines
- = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) /
frame_line_height;
- int margin = min (scroll_margin, window_total_lines / 4);
- int pixel_margin = margin * frame_line_height;
+ int pixel_margin = margin * frame_line_height;
bool header_line = WINDOW_WANTS_HEADER_LINE_P (w);
/* Note: We add an extra FRAME_LINE_HEIGHT, because the loop
@@ -16901,12 +16907,6 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
it.current_y = it.last_visible_y;
if (centering_position < 0)
{
- int window_total_lines
- = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
- int margin
- = scroll_margin > 0
- ? min (scroll_margin, window_total_lines / 4)
- : 0;
ptrdiff_t margin_pos = CHARPOS (startp);
Lisp_Object aggressive;
bool scrolling_up;
@@ -17150,10 +17150,6 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
{
int window_total_lines
= WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) /
frame_line_height;
- int margin =
- scroll_margin > 0
- ? min (scroll_margin, window_total_lines / 4)
- : 0;
bool move_down = w->cursor.vpos >= window_total_lines / 2;
move_it_by_lines (&it, move_down ? margin + 1 : -(margin + 1));
@@ -17359,7 +17355,6 @@ try_window (Lisp_Object window, struct text_pos pos,
int flags)
struct it it;
struct glyph_row *last_text_row = NULL;
struct frame *f = XFRAME (w->frame);
- int frame_line_height = default_line_pixel_height (w);
/* Make POS the new window start. */
set_marker_both (w->start, Qnil, CHARPOS (pos), BYTEPOS (pos));
@@ -17385,17 +17380,7 @@ try_window (Lisp_Object window, struct text_pos pos,
int flags)
if ((flags & TRY_WINDOW_CHECK_MARGINS)
&& !MINI_WINDOW_P (w))
{
- int this_scroll_margin;
- int window_total_lines
- = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
-
- if (scroll_margin > 0)
- {
- this_scroll_margin = min (scroll_margin, window_total_lines / 4);
- this_scroll_margin *= frame_line_height;
- }
- else
- this_scroll_margin = 0;
+ int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
if ((w->cursor.y >= 0 /* not vscrolled */
&& w->cursor.y < this_scroll_margin
@@ -18679,15 +18664,8 @@ try_window_id (struct window *w)
/* Don't let the cursor end in the scroll margins. */
{
- int this_scroll_margin, cursor_height;
- int frame_line_height = default_line_pixel_height (w);
- int window_total_lines
- = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (it.f) / frame_line_height;
-
- this_scroll_margin =
- max (0, min (scroll_margin, window_total_lines / 4));
- this_scroll_margin *= frame_line_height;
- cursor_height = MATRIX_ROW (w->desired_matrix, w->cursor.vpos)->height;
+ int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
+ int cursor_height = MATRIX_ROW (w->desired_matrix, w->cursor.vpos)->height;
if ((w->cursor.y < this_scroll_margin
&& CHARPOS (start) > BEGV)
@@ -22635,7 +22613,7 @@ move_elt_to_front (Lisp_Object elt, Lisp_Object list)
else
prev = tail;
tail = XCDR (tail);
- QUIT;
+ maybe_quit ();
}
/* Not found--return unchanged LIST. */
@@ -31569,6 +31547,14 @@ Recenter the window whenever point gets within this
many lines
of the top or bottom of the window. */);
scroll_margin = 0;
+ DEFVAR_LISP ("maximum-scroll-margin", Vmaximum_scroll_margin,
+ doc: /* Maximum effective value of `scroll-margin'.
+Given as a fraction of the current window's lines. The value should
+be a floating point number between 0.0 and 0.5. The effective maximum
+is limited to (/ (1- window-lines) 2). Non-float values for this
+variable are ignored and the default 0.25 is used instead. */);
+ Vmaximum_scroll_margin = make_float (0.25);
+
DEFVAR_LISP ("display-pixels-per-inch", Vdisplay_pixels_per_inch,
doc: /* Pixels per inch value for non-window system displays.
Value is a number or a cons (WIDTH-DPI . HEIGHT-DPI). */);
diff --git a/src/xselect.c b/src/xselect.c
index 47ccf68..2249828 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -329,7 +329,7 @@ x_own_selection (Lisp_Object selection_name, Lisp_Object
selection_value,
Fcons (selection_data, dpyinfo->terminal->Vselection_alist));
/* If we already owned the selection, remove the old selection
- data. Don't use Fdelq as that may QUIT. */
+ data. Don't use Fdelq as that may quit. */
if (!NILP (prev_value))
{
/* We know it's not the CAR, so it's easy. */
@@ -929,7 +929,7 @@ x_handle_selection_clear (struct selection_input_event
*event)
&& local_selection_time > changed_owner_time)
return;
- /* Otherwise, really clear. Don't use Fdelq as that may QUIT;. */
+ /* Otherwise, really clear. Don't use Fdelq as that may quit. */
Vselection_alist = dpyinfo->terminal->Vselection_alist;
if (EQ (local_selection_data, CAR (Vselection_alist)))
Vselection_alist = XCDR (Vselection_alist);
diff --git a/src/xterm.c b/src/xterm.c
index db561c9..38229a5 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -635,7 +635,7 @@ x_cr_export_frames (Lisp_Object frames,
cairo_surface_type_t surface_type)
(*surface_set_size_func) (surface, width, height);
unblock_input ();
- QUIT;
+ maybe_quit ();
block_input ();
}
@@ -12877,7 +12877,7 @@ keysyms. The default is nil, which is the same as
`super'. */);
Vx_keysym_table = make_hash_table (hashtest_eql, make_number (900),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil);
+ Qnil, Qnil);
DEFVAR_BOOL ("x-frame-normalize-before-maximize",
x_frame_normalize_before_maximize,
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el
index a454471..1ffcd6a 100644
--- a/test/lisp/abbrev-tests.el
+++ b/test/lisp/abbrev-tests.el
@@ -45,8 +45,7 @@
(should-not (abbrev-table-p []))
;; Missing :abbrev-table-modiff counter:
(should-not (abbrev-table-p (obarray-make)))
- (let* ((table (obarray-make)))
- (should (abbrev-table-empty-p (make-abbrev-table)))))
+ (should (abbrev-table-empty-p (make-abbrev-table))))
(ert-deftest abbrev-make-abbrev-table-test ()
;; Table without properties:
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el
index aea855a..c6f1033 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -24,24 +24,29 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'autorevert)
(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded"
auto-revert-stop-on-user-input nil)
(defconst auto-revert--timeout 10
- "Time to wait until a message appears in the *Messages* buffer.")
+ "Time to wait for a message.")
+
+(defvar auto-revert--messages nil
+ "Used to collect messages issued during a section of a test.")
(defun auto-revert--wait-for-revert (buffer)
- "Wait until the *Messages* buffer reports reversion of BUFFER."
+ "Wait until a message reports reversion of BUFFER.
+This expects `auto-revert--messages' to be bound by
+`ert-with-message-capture' before calling."
(with-timeout (auto-revert--timeout nil)
- (with-current-buffer "*Messages*"
- (while
- (null (string-match
- (format-message "Reverting buffer `%s'." (buffer-name buffer))
- (buffer-string)))
- (if (with-current-buffer buffer auto-revert-use-notify)
- (read-event nil nil 0.1)
- (sleep-for 0.1))))))
+ (while
+ (null (string-match
+ (format-message "Reverting buffer `%s'." (buffer-name buffer))
+ auto-revert--messages))
+ (if (with-current-buffer buffer auto-revert-use-notify)
+ (read-event nil nil 0.1)
+ (sleep-for 0.1)))))
(ert-deftest auto-revert-test00-auto-revert-mode ()
"Check autorevert for a file."
@@ -51,41 +56,38 @@
buf)
(unwind-protect
(progn
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (write-region "any text" nil tmpfile nil 'no-message)
+ (write-region "any text" nil tmpfile nil 'no-message)
(setq buf (find-file-noselect tmpfile))
- (with-current-buffer buf
- (should (string-equal (buffer-string) "any text"))
- ;; `buffer-stale--default-function' checks for
- ;; `verify-visited-file-modtime'. We must ensure that it
- ;; returns nil.
- (sleep-for 1)
- (auto-revert-mode 1)
- (should auto-revert-mode)
+ (with-current-buffer buf
+ (ert-with-message-capture auto-revert--messages
+ (should (string-equal (buffer-string) "any text"))
+ ;; `buffer-stale--default-function' checks for
+ ;; `verify-visited-file-modtime'. We must ensure that it
+ ;; returns nil.
+ (sleep-for 1)
+ (auto-revert-mode 1)
+ (should auto-revert-mode)
- ;; Modify file. We wait for a second, in order to have
- ;; another timestamp.
- (sleep-for 1)
- (write-region "another text" nil tmpfile nil 'no-message)
+ ;; Modify file. We wait for a second, in order to have
+ ;; another timestamp.
+ (sleep-for 1)
+ (write-region "another text" nil tmpfile nil 'no-message)
- ;; Check, that the buffer has been reverted.
- (auto-revert--wait-for-revert buf)
+ ;; Check, that the buffer has been reverted.
+ (auto-revert--wait-for-revert buf))
(should (string-match "another text" (buffer-string)))
;; When the buffer is modified, it shall not be reverted.
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (set-buffer-modified-p t)
- (sleep-for 1)
- (write-region "any text" nil tmpfile nil 'no-message)
+ (ert-with-message-capture auto-revert--messages
+ (set-buffer-modified-p t)
+ (sleep-for 1)
+ (write-region "any text" nil tmpfile nil 'no-message)
- ;; Check, that the buffer hasn't been reverted.
- (auto-revert--wait-for-revert buf)
+ ;; Check, that the buffer hasn't been reverted.
+ (auto-revert--wait-for-revert buf))
(should-not (string-match "any text" (buffer-string)))))
;; Exit.
- (with-current-buffer "*Messages*" (widen))
(ignore-errors
(with-current-buffer buf (set-buffer-modified-p nil))
(kill-buffer buf))
@@ -106,13 +108,11 @@
(make-temp-file (expand-file-name "auto-revert-test" tmpdir1)))
buf1 buf2)
(unwind-protect
- (progn
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (write-region "any text" nil tmpfile1 nil 'no-message)
- (setq buf1 (find-file-noselect tmpfile1))
- (write-region "any text" nil tmpfile2 nil 'no-message)
- (setq buf2 (find-file-noselect tmpfile2))
+ (ert-with-message-capture auto-revert--messages
+ (write-region "any text" nil tmpfile1 nil 'no-message)
+ (setq buf1 (find-file-noselect tmpfile1))
+ (write-region "any text" nil tmpfile2 nil 'no-message)
+ (setq buf2 (find-file-noselect tmpfile2))
(dolist (buf (list buf1 buf2))
(with-current-buffer buf
@@ -148,7 +148,6 @@
(should (string-match "another text" (buffer-string))))))
;; Exit.
- (with-current-buffer "*Messages*" (widen))
(ignore-errors
(dolist (buf (list buf1 buf2))
(with-current-buffer buf (set-buffer-modified-p nil))
@@ -165,8 +164,6 @@
buf)
(unwind-protect
(progn
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
(write-region "any text" nil tmpfile nil 'no-message)
(setq buf (find-file-noselect tmpfile))
(with-current-buffer buf
@@ -184,42 +181,38 @@
'before-revert-hook
(lambda () (delete-file buffer-file-name))
nil t)
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (sleep-for 1)
- (write-region "another text" nil tmpfile nil 'no-message)
- ;; Check, that the buffer hasn't been reverted. File
- ;; notification should be disabled, falling back to
- ;; polling.
- (auto-revert--wait-for-revert buf)
+ (ert-with-message-capture auto-revert--messages
+ (sleep-for 1)
+ (write-region "another text" nil tmpfile nil 'no-message)
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer hasn't been reverted. File
+ ;; notification should be disabled, falling back to
+ ;; polling.
(should (string-match "any text" (buffer-string)))
- (should-not auto-revert-use-notify)
+ ;; With w32notify, the 'stopped' events are not sent.
+ (or (eq file-notify--library 'w32notify)
+ (should-not auto-revert-use-notify))
;; Once the file has been recreated, the buffer shall be
;; reverted.
(kill-local-variable 'before-revert-hook)
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (sleep-for 1)
- (write-region "another text" nil tmpfile nil 'no-message)
-
- ;; Check, that the buffer has been reverted.
- (auto-revert--wait-for-revert buf)
+ (ert-with-message-capture auto-revert--messages
+ (sleep-for 1)
+ (write-region "another text" nil tmpfile nil 'no-message)
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer has been reverted.
(should (string-match "another text" (buffer-string)))
;; An empty file shall still be reverted.
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (sleep-for 1)
- (write-region "" nil tmpfile nil 'no-message)
-
- ;; Check, that the buffer has been reverted.
- (auto-revert--wait-for-revert buf)
+ (ert-with-message-capture auto-revert--messages
+ (sleep-for 1)
+ (write-region "" nil tmpfile nil 'no-message)
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer has been reverted.
(should (string-equal "" (buffer-string)))))
;; Exit.
- (with-current-buffer "*Messages*" (widen))
(ignore-errors
(with-current-buffer buf (set-buffer-modified-p nil))
(kill-buffer buf))
@@ -232,9 +225,7 @@
(let ((tmpfile (make-temp-file "auto-revert-test"))
buf)
(unwind-protect
- (progn
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
+ (ert-with-message-capture auto-revert--messages
(write-region "any text" nil tmpfile nil 'no-message)
(setq buf (find-file-noselect tmpfile))
(with-current-buffer buf
@@ -259,7 +250,6 @@
(string-match "modified text\nanother text" (buffer-string)))))
;; Exit.
- (with-current-buffer "*Messages*" (widen))
(ignore-errors (kill-buffer buf))
(ignore-errors (delete-file tmpfile)))))
@@ -283,33 +273,29 @@
(should
(string-match name (substring-no-properties (buffer-string))))
- ;; Delete file. We wait for a second, in order to have
- ;; another timestamp.
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (sleep-for 1)
- (delete-file tmpfile)
-
- ;; Check, that the buffer has been reverted.
- (auto-revert--wait-for-revert buf)
+ (ert-with-message-capture auto-revert--messages
+ ;; Delete file. We wait for a second, in order to have
+ ;; another timestamp.
+ (sleep-for 1)
+ (delete-file tmpfile)
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer has been reverted.
(should-not
(string-match name (substring-no-properties (buffer-string))))
- ;; Make dired buffer modified. Check, that the buffer has
- ;; been still reverted.
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (set-buffer-modified-p t)
- (sleep-for 1)
- (write-region "any text" nil tmpfile nil 'no-message)
+ (ert-with-message-capture auto-revert--messages
+ ;; Make dired buffer modified. Check, that the buffer has
+ ;; been still reverted.
+ (set-buffer-modified-p t)
+ (sleep-for 1)
+ (write-region "any text" nil tmpfile nil 'no-message)
- ;; Check, that the buffer has been reverted.
- (auto-revert--wait-for-revert buf)
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer has been reverted.
(should
(string-match name (substring-no-properties (buffer-string))))))
;; Exit.
- (with-current-buffer "*Messages*" (widen))
(ignore-errors
(with-current-buffer buf (set-buffer-modified-p nil))
(kill-buffer buf))
diff --git a/test/lisp/emacs-lisp/cl-seq-tests.el
b/test/lisp/emacs-lisp/cl-seq-tests.el
index 3740b5c..61e3d72 100644
--- a/test/lisp/emacs-lisp/cl-seq-tests.el
+++ b/test/lisp/emacs-lisp/cl-seq-tests.el
@@ -250,9 +250,9 @@ Body are forms defining the test."
(should (= 0 (cl-count -5 list)))
(should (= 0 (cl-count 2 list :start 2 :end 4)))
(should (= 4 (cl-count 'foo list :key (lambda (x) (and (cl-evenp x)
'foo)))))
- (should (= 4 (cl-count 'foo list :test (lambda (a b) (cl-evenp b)))))
- (should (equal (cl-count 'foo list :test (lambda (a b) (cl-oddp b)))
- (cl-count 'foo list :test-not (lambda (a b) (cl-evenp
b)))))))
+ (should (= 4 (cl-count 'foo list :test (lambda (_a b) (cl-evenp b)))))
+ (should (equal (cl-count 'foo list :test (lambda (_a b) (cl-oddp b)))
+ (cl-count 'foo list :test-not (lambda (_a b) (cl-evenp
b)))))))
;; keywords supported: :test :test-not :key :start1 :end1 :start2 :end2
:from-end
(ert-deftest cl-seq-mismatch-test ()
diff --git a/test/lisp/emacs-lisp/let-alist-tests.el
b/test/lisp/emacs-lisp/let-alist-tests.el
index fbcde4e..d046457 100644
--- a/test/lisp/emacs-lisp/let-alist-tests.el
+++ b/test/lisp/emacs-lisp/let-alist-tests.el
@@ -31,7 +31,7 @@
(.test-two (cdr (assq 'test-two symbol))))
(list .test-one .test-two
.test-two .test-two)))
- (cl-letf (((symbol-function #'make-symbol) (lambda (x) 'symbol)))
+ (cl-letf (((symbol-function #'make-symbol) (lambda (_x) 'symbol)))
(macroexpand
'(let-alist data (list .test-one .test-two
.test-two .test-two))))))
@@ -51,8 +51,7 @@
(ert-deftest let-alist-cons ()
(should
(equal
- (let ((.external "ext")
- (.external.too "et"))
+ (let ((.external "ext"))
(let-alist '((test-two . 0)
(test-three . 1)
(sublist . ((foo . 2)
diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el
b/test/lisp/emacs-lisp/testcover-resources/testcases.el
new file mode 100644
index 0000000..1eb791a
--- /dev/null
+++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el
@@ -0,0 +1,493 @@
+;;;; testcases.el -- Test cases for testcover-tests.el
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see `http://www.gnu.org/licenses/'.
+
+;;; Commentary:
+
+;; * This file should not be loaded directly. It is meant to be read
+;; by `testcover-tests-build-test-cases'.
+;;
+;; * Test cases begin with ;; ==== name ====. The symbol name between
+;; the ===='s is used to create the name of the test.
+;;
+;; * Following the beginning comment place the test docstring and
+;; any tags or keywords for ERT. These will be spliced into the
+;; ert-deftest for the test.
+;;
+;; * To separate the above from the test case code, use another
+;; comment: ;; ====
+;;
+;; * These special comments should start at the beginning of a line.
+;;
+;; * `testcover-tests-skeleton' will prompt you for a test name and
+;; insert the special comments.
+;;
+;; * The test case code should be annotated with %%% at the end of
+;; each form where a tan splotch is expected, and !!! at the end
+;; of each form where a red mark is expected.
+;;
+;; * If Testcover is working correctly on your code sample, using
+;; `testcover-tests-markup-region' and
+;; `testcover-tests-unmarkup-region' can make creating test cases
+;; easier.
+
+;;; Code:
+;;; Test Cases:
+
+;; ==== constants-bug-25316 ====
+"Testcover doesn't splotch constants."
+:expected-result :failed
+;; ====
+(defconst testcover-testcase-const "apples")
+(defun testcover-testcase-zero () 0)
+(defun testcover-testcase-list-consts ()
+ (list
+ emacs-version 10
+ "hello"
+ `(a b c ,testcover-testcase-const)
+ '(1 2 3)
+ testcover-testcase-const
+ (testcover-testcase-zero)
+ nil))
+
+(defun testcover-testcase-add-to-const-list (arg)
+ (cons arg%%% (testcover-testcase-list-consts))%%%)
+
+(should (equal (testcover-testcase-add-to-const-list 'a)
+ `(a ,emacs-version 10 "hello" (a b c "apples") (1 2 3)
+ "apples" 0 nil)))
+
+;; ==== customize-defcustom-bug-25326 ====
+"Testcover doesn't prevent testing of defcustom values."
+:expected-result :failed
+;; ====
+(defgroup testcover-testcase nil
+ "Test case for testcover"
+ :group 'lisp
+ :prefix "testcover-testcase-"
+ :version "26.0")
+(defcustom testcover-testcase-flag t
+ "Test value used by testcover-tests.el"
+ :type 'boolean
+ :group 'testcover-testcase)
+(defun testcover-testcase-get-flag ()
+ testcover-testcase-flag)
+
+(testcover-testcase-get-flag)
+(setq testcover-testcase-flag (not testcover-testcase-flag))
+(testcover-testcase-get-flag)
+
+;; ==== no-returns ====
+"Testcover doesn't splotch functions which don't return."
+;; ====
+(defun testcover-testcase-play-ball (retval)
+ (catch 'ball
+ (throw 'ball retval%%%))%%%) ; catch gets marked but not throw
+
+(defun testcover-testcase-not-my-favorite-error-message ()
+ (signal 'wrong-type-argument (list 'consp nil)))
+
+(should (testcover-testcase-play-ball t))
+(condition-case nil
+ (testcover-testcase-not-my-favorite-error-message)
+ (error nil))
+
+;; ==== noreturn-symbol ====
+"Wrapping a form with noreturn prevents splotching."
+;; ====
+(defun testcover-testcase-cancel (spacecraft)
+ (error "no destination for %s" spacecraft))
+(defun testcover-testcase-launch (spacecraft planet)
+ (if (null planet)
+ (noreturn (testcover-testcase-cancel spacecraft%%%))
+ (list spacecraft%%% planet%%%)%%%)%%%)
+(defun testcover-testcase-launch-2 (spacecraft planet)
+ (if (null planet%%%)%%%
+ (testcover-testcase-cancel spacecraft%%%)!!!
+ (list spacecraft!!! planet!!!)!!!)!!!)
+(should (equal (testcover-testcase-launch "Curiosity" "Mars") '("Curiosity"
"Mars")))
+(condition-case err
+ (testcover-testcase-launch "Voyager" nil)
+ (error err))
+(condition-case err
+ (testcover-testcase-launch-2 "Voyager II" nil)
+ (error err))
+
+(should-error (testcover-testcase-launch "Voyager" nil))
+(should-error (testcover-testcase-launch-2 "Voyager II" nil))
+
+;; ==== 1-value-symbol-bug-25316 ====
+"Wrapping a form with 1value prevents splotching."
+:expected-result :failed
+;; ====
+(defun testcover-testcase-always-zero (num)
+ (- num%%% num%%%)%%%)
+(defun testcover-testcase-still-always-zero (num)
+ (1value (- num%%% num%%% (- num%%% num%%%)%%%)))
+(defun testcover-testcase-never-called (num)
+ (1value (/ num!!! num!!!)!!!)!!!)
+(should (eql 0 (testcover-testcase-always-zero 3)))
+(should (eql 0 (testcover-testcase-still-always-zero 5)))
+
+;; ==== dotimes-dolist ====
+"Dolist and dotimes with a 1valued return value are 1valued."
+;; ====
+(defun testcover-testcase-do-over (things)
+ (dolist (thing things%%%)
+ (list thing))
+ (dolist (thing things%%% 42)
+ (list thing))
+ (dolist (thing things%%% things%%%)
+ (list thing))%%%)
+(defun testcover-testcase-do-more (count)
+ (dotimes (num count%%%)
+ (+ num num))
+ (dotimes (num count%%% count%%%)
+ (+ num num))%%%
+ (dotimes (num count%%% 0)
+ (+ num num)))
+(should (equal '(a b c) (testcover-testcase-do-over '(a b c))))
+(should (eql 0 (testcover-testcase-do-more 2)))
+
+;; ==== let-last-form ====
+"A let form is 1valued if its last form is 1valued."
+;; ====
+(defun testcover-testcase-double (num)
+ (let ((double (* num%%% 2)%%%))
+ double%%%)%%%)
+(defun testcover-testcase-nullbody-let (num)
+ (let* ((square (* num%%% num%%%)%%%)
+ (double (* 2 num%%%)%%%))))
+(defun testcover-testcase-answer ()
+ (let ((num 100))
+ 42))
+(should-not (testcover-testcase-nullbody-let 3))
+(should (eql (testcover-testcase-answer) 42))
+(should (eql (testcover-testcase-double 10) 20))
+
+;; ==== if-with-1value-clauses ====
+"An if is 1valued if both then and else are 1valued."
+;; ====
+(defun testcover-testcase-describe (val)
+ (if (zerop val%%%)%%%
+ "a number"
+ "a different number"))
+(defun testcover-testcase-describe-2 (val)
+ (if (zerop val)
+ "zero"
+ "not zero"))
+(defun testcover-testcase-describe-3 (val)
+ (if (zerop val%%%)%%%
+ "zero"
+ (format "%d" val%%%)%%%)%%%)
+(should (equal (testcover-testcase-describe 0) "a number"))
+(should (equal (testcover-testcase-describe-2 0) "zero"))
+(should (equal (testcover-testcase-describe-2 1) "not zero"))
+(should (equal (testcover-testcase-describe-3 1) "1"))
+
+;; ==== cond-with-1value-clauses ====
+"A cond form is marked 1valued if all clauses are 1valued."
+;; ====
+(defun testcover-testcase-cond (num)
+ (cond
+ ((eql num%%% 0)%%% 'a)
+ ((eql num%%% 1)%%% 'b)
+ ((eql num!!! 2)!!! 'c)))
+(defun testcover-testcase-cond-2 (num)
+ (cond
+ ((eql num%%% 0)%%% (cons 'a 0)!!!)
+ ((eql num%%% 1)%%% 'b))%%%)
+(should (eql (testcover-testcase-cond 1) 'b))
+(should (eql (testcover-testcase-cond-2 1) 'b))
+
+;; ==== condition-case-with-1value-components ====
+"A condition-case is marked 1valued if its body and handlers are."
+;; ====
+(defun testcover-testcase-cc (arg)
+ (condition-case nil
+ (if (null arg%%%)%%%
+ (error "foo")
+ "0")!!!
+ (error nil)))
+(should-not (testcover-testcase-cc nil))
+
+;; ==== quotes-within-backquotes-bug-25316 ====
+"Forms to instrument are found within quotes within backquotes."
+:expected-result :failed
+;; ====
+(defun testcover-testcase-make-list ()
+ (list 'defun 'defvar))
+(defmacro testcover-testcase-bq-macro (arg)
+ (declare (debug t))
+ `(memq ,arg%%% '(defconst ,@(testcover-testcase-make-list)))%%%)
+(defun testcover-testcase-use-bq-macro (arg)
+ (testcover-testcase-bq-macro arg%%%)%%%)
+(should (equal '(defun defvar) (testcover-testcase-use-bq-macro 'defun)))
+
+;; ==== progn-functions ====
+"Some forms are 1value if their last argument is 1value."
+;; ====
+(defun testcover-testcase-one (arg)
+ (progn
+ (setq arg (1- arg%%%)%%%)%%%)%%%
+ (progn
+ (setq arg (1+ arg%%%)%%%)%%%
+ 1))
+
+(should (eql 1 (testcover-testcase-one 0)))
+;; ==== prog1-functions ====
+"Some forms are 1value if their first argument is 1value."
+;; ====
+(defun testcover-testcase-unwinder (arg)
+ (unwind-protect
+ (if ( > arg%%% 0)%%%
+ 1
+ 0)
+ (format "unwinding %s!" arg%%%)%%%))
+(defun testcover-testcase-divider (arg)
+ (unwind-protect
+ (/ 100 arg%%%)%%%
+ (format "unwinding! %s" arg%%%)%%%)%%%)
+
+(should (eq 0 (testcover-testcase-unwinder 0)))
+(should (eq 1 (testcover-testcase-divider 100)))
+
+;; ==== compose-functions ====
+"Some functions are 1value if all their arguments are 1value."
+;; ====
+(defconst testcover-testcase-count 3)
+(defun testcover-testcase-number ()
+ (+ 1 testcover-testcase-count))
+(defun testcover-testcase-more ()
+ (+ 1 (testcover-testcase-number) testcover-testcase-count))
+
+(should (equal (testcover-testcase-more) 8))
+
+;; ==== apply-quoted-symbol ====
+"Apply with a quoted function symbol treated as 1value if function is."
+;; ====
+(defun testcover-testcase-numlist (flag)
+ (if flag%%%
+ '(1 2 3)
+ '(4 5 6)))
+(defun testcover-testcase-sum (flag)
+ (apply '+ (testcover-testcase-numlist flag%%%)))
+(defun testcover-testcase-label ()
+ (apply 'message "edebug uses: %s %s" (list 1 2)!!!)!!!)
+
+(should (equal 6 (testcover-testcase-sum t)))
+
+;; ==== backquote-1value-bug-24509 ====
+"Commas within backquotes are recognized as non-1value."
+:expected-result :failed
+;; ====
+(defmacro testcover-testcase-lambda (&rest body)
+ `(lambda () ,@body))
+
+(defun testcover-testcase-example ()
+ (let ((lambda-1 (testcover-testcase-lambda (format "lambda-%d" 1))%%%)
+ (lambda-2 (testcover-testcase-lambda (format "lambda-%d" 2))%%%))
+ (concat (funcall lambda-1%%%)%%% " "
+ (funcall lambda-2%%%)%%%)%%%)%%%)
+
+(defmacro testcover-testcase-message-symbol (name)
+ `(message "%s" ',name))
+
+(defun testcover-testcase-example-2 ()
+ (concat
+ (testcover-testcase-message-symbol foo)%%%
+ (testcover-testcase-message-symbol bar)%%%)%%%)
+
+(should (equal "lambda-1 lambda-2" (testcover-testcase-example)))
+(should (equal "foobar" (testcover-testcase-example-2)))
+
+;; ==== pcase-bug-24688 ====
+"Testcover copes with condition-case within backquoted list."
+:expected-result :failed
+;; ====
+(defun testcover-testcase-pcase (form)
+ (pcase form%%%
+ (`(condition-case ,var ,protected-form . ,handlers)
+ (list var%%% protected-form%%% handlers%%%)%%%)
+ (_ nil))%%%)
+
+(should (equal (testcover-testcase-pcase '(condition-case a
+ (/ 5 a)
+ (error 0)))
+ '(a (/ 5 a) ((error 0)))))
+
+;; ==== defun-in-backquote-bug-11307-and-24743 ====
+"Testcover handles defun forms within backquoted list."
+:expected-result :failed
+;; ====
+(defmacro testcover-testcase-defun (name &rest body)
+ (declare (debug (symbolp def-body)))
+ `(defun ,name () ,@body))
+
+(testcover-testcase-defun foo (+ 1 2))
+(testcover-testcase-defun bar (+ 3 4))
+(should (eql (foo) 3))
+(should (eql (bar) 7))
+
+;; ==== closure-1value-bug ====
+"Testcover does not mark closures as 1value."
+:expected-result :failed
+;; ====
+;; -*- lexical-binding:t -*-
+(setq testcover-testcase-foo nil)
+(setq testcover-testcase-bar 0)
+
+(defun testcover-testcase-baz (arg)
+ (setq testcover-testcase-foo
+ (lambda () (+ arg testcover-testcase-bar%%%))))
+
+(testcover-testcase-baz 2)
+(should (equal 2 (funcall testcover-testcase-foo)))
+(testcover-testcase-baz 3)
+(should (equal 3 (funcall testcover-testcase-foo)))
+
+;; ==== by-value-vs-by-reference-bug-25351 ====
+"An object created by a 1value expression may be modified by other code."
+:expected-result :failed
+;; ====
+(defun testcover-testcase-ab ()
+ (list 'a 'b))
+(defun testcover-testcase-change-it (arg)
+ (setf (cadr arg%%%)%%% 'c)%%%
+ arg%%%)
+
+(should (equal (testcover-testcase-change-it (testcover-testcase-ab)) '(a c)))
+(should (equal (testcover-testcase-ab) '(a b)))
+
+;; ==== 1value-error-test ====
+"Forms wrapped by `1value' should always return the same value."
+;; ====
+(defun testcover-testcase-thing (arg)
+ (1value (list 1 arg 3)))
+
+(should (equal '(1 2 3) (testcover-testcase-thing 2)))
+(should-error (testcover-testcase-thing 3))
+
+;; ==== dotted-backquote ====
+"Testcover correctly instruments dotted backquoted lists."
+;; ====
+(defun testcover-testcase-dotted-bq (flag extras)
+ (let* ((bq
+ `(a b c . ,(and flag extras%%%))))
+ bq))
+
+(should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e))))
+(should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e))))
+
+;; ==== backquoted-vector-bug-25316 ====
+"Testcover reinstruments within backquoted vectors."
+:expected-result :failed
+;; ====
+(defun testcover-testcase-vec (a b c)
+ `[,a%%% ,(list b%%% c%%%)%%%]%%%)
+
+(defun testcover-testcase-vec-in-list (d e f)
+ `([[,d%%% ,e%%%] ,f%%%])%%%)
+
+(defun testcover-testcase-vec-arg (num)
+ (list `[,num%%%]%%%)%%%)
+
+(should (equal [1 (2 3)] (testcover-testcase-vec 1 2 3)))
+(should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6)))
+(should (equal '([100]) (testcover-testcase-vec-arg 100)))
+
+;; ==== vector-in-macro-spec-bug-25316 ====
+"Testcover reinstruments within vectors."
+:expected-result :failed
+;; ====
+(defmacro testcover-testcase-nth-case (arg vec)
+ (declare (indent 1)
+ (debug (form (vector &rest form))))
+ `(eval (aref ,vec%%% ,arg%%%))%%%)
+
+(defun testcover-testcase-use-nth-case (choice val)
+ (testcover-testcase-nth-case choice
+ [(+ 1 val!!!)!!!
+ (- 1 val%%%)%%%
+ (* 7 val)
+ (/ 4 val!!!)!!!]))
+
+(should (eql 42 (testcover-testcase-use-nth-case 2 6)))
+(should (eql 49 (testcover-testcase-use-nth-case 2 7)))
+(should (eql 0 (testcover-testcase-use-nth-case 1 1 )))
+
+;; ==== mapcar-is-not-compose ====
+"Mapcar with 1value arguments is not 1value."
+:expected-result :failed
+;; ====
+(defvar testcover-testcase-num 0)
+(defun testcover-testcase-add-num (n)
+ (+ testcover-testcase-num n))
+(defun testcover-testcase-mapcar-sides ()
+ (mapcar 'testcover-testcase-add-num '(1 2 3)))
+
+(setq testcover-testcase-num 1)
+(should (equal (testcover-testcase-mapcar-sides) '(2 3 4)))
+(setq testcover-testcase-num 2)
+(should (equal (testcover-testcase-mapcar-sides) '(3 4 5)))
+
+;; ==== function-with-edebug-spec-bug-25316 ====
+"Functions can have edebug specs too.
+See c-make-font-lock-search-function for an example in the Emacs
+sources. The other issue is that it's ok to use quote in an
+edebug spec, so testcover needs to cope with that."
+:expected-result :failed
+;; ====
+(defun testcover-testcase-make-function (forms)
+ `(lambda (flag) (if flag 0 ,@forms%%%))%%%)
+
+(def-edebug-spec testcover-testcase-make-function
+ (("quote" (&rest def-form))))
+
+(defun testcover-testcase-thing ()
+ (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%)
+
+(defun testcover-testcase-use-thing ()
+ (funcall (testcover-testcase-thing)%%% nil)%%%)
+
+(should (equal (testcover-testcase-use-thing) 15))
+
+;; ==== backquoted-dotted-alist ====
+"Testcover can instrument a dotted alist constructed with backquote."
+;; ====
+(defun testcover-testcase-make-alist (expr entries)
+ `((0 . ,expr%%%) . ,entries%%%)%%%)
+
+(should (equal (testcover-testcase-make-alist "foo" '((1 . "bar") (2 . "baz")))
+ '((0 . "foo") (1 . "bar") (2 . "baz"))))
+
+;; ==== coverage-of-the-unknown-symbol-bug-25471 ====
+"Testcover correctly records coverage of code which uses `unknown'"
+:expected-result :failed
+;; ====
+(defun testcover-testcase-how-do-i-know-you (name)
+ (let ((val 'unknown))
+ (when (equal name%%% "Bob")%%%
+ (setq val 'known)!!!)
+ val%%%)%%%)
+
+(should (eq (testcover-testcase-how-do-i-know-you "Liz") 'unknown))
+
+;; testcases.el ends here.
diff --git a/test/lisp/emacs-lisp/testcover-tests.el
b/test/lisp/emacs-lisp/testcover-tests.el
new file mode 100644
index 0000000..d31379c
--- /dev/null
+++ b/test/lisp/emacs-lisp/testcover-tests.el
@@ -0,0 +1,186 @@
+;;; testcover-tests.el --- Testcover test suite -*- lexical-binding:t -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see `http://www.gnu.org/licenses/'.
+
+;;; Commentary:
+
+;; Testcover test suite.
+;; * All the test cases are in testcover-resources/testcover-cases.el.
+;; See that file for an explanation of the test case format.
+;; * `testcover-tests-define-tests', which is run when this file is
+;; loaded, reads testcover-resources/testcover-cases.el and defines
+;; ERT tests for each test case.
+
+;;; Code:
+
+(require 'ert)
+(require 'testcover)
+(require 'skeleton)
+
+;; Use `eval-and-compile' around all these definitions because they're
+;; used by the macro `testcover-tests-define-tests'.
+
+(eval-and-compile
+ (defvar testcover-tests-file-dir
+ (expand-file-name
+ "testcover-resources/"
+ (file-name-directory (or (bound-and-true-p byte-compile-current-file)
+ load-file-name
+ buffer-file-name)))
+ "Directory of the \"testcover-tests.el\" file."))
+
+(eval-and-compile
+ (defvar testcover-tests-test-cases
+ (expand-file-name "testcases.el" testcover-tests-file-dir)
+ "File containing marked up code to instrument and check."))
+
+;; Convert Testcover's overlays to plain text.
+
+(eval-and-compile
+ (defun testcover-tests-markup-region (beg end &rest optargs)
+ "Mark up test code within region between BEG and END.
+Convert Testcover's tan and red splotches to %%% and !!! for
+testcases.el. This can be used to create test cases if Testcover
+is working correctly on a code sample. OPTARGS are optional
+arguments for `testcover-start'."
+ (interactive "r")
+ (let ((tempfile (make-temp-file "testcover-tests-" nil ".el"))
+ (code (buffer-substring beg end))
+ (marked-up-code))
+ (unwind-protect
+ (progn
+ (with-temp-file tempfile
+ (insert code))
+ (save-current-buffer
+ (let ((buf (find-file-noselect tempfile)))
+ (set-buffer buf)
+ (apply 'testcover-start (cons tempfile optargs))
+ (testcover-mark-all buf)
+ (dolist (overlay (overlays-in (point-min) (point-max)))
+ (let ((ov-face (overlay-get overlay 'face)))
+ (goto-char (overlay-end overlay))
+ (cond
+ ((eq ov-face 'testcover-nohits) (insert "!!!"))
+ ((eq ov-face 'testcover-1value) (insert "%%%"))
+ (t nil))))
+ (setq marked-up-code (buffer-string)))
+ (set-buffer-modified-p nil)))
+ (ignore-errors (kill-buffer (find-file-noselect tempfile)))
+ (ignore-errors (delete-file tempfile)))
+
+ ;; Now replace the original code with the marked up code.
+ (delete-region beg end)
+ (insert marked-up-code))))
+
+(eval-and-compile
+ (defun testcover-tests-unmarkup-region (beg end)
+ "Remove the markup used in testcases.el between BEG and END."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (while (re-search-forward "!!!\\|%%%" nil t)
+ (replace-match ""))))))
+
+(define-skeleton testcover-tests-skeleton
+ "Write a testcase for testcover-tests.el."
+ "Enter name of test: "
+ ";; ==== " str " ====\n"
+ "\"docstring\"\n"
+ ";; Directives for ERT should go here, if any.\n"
+ ";; ====\n"
+ ";; Replace this line with annotated test code.\n")
+
+;; Check a test case.
+
+(eval-and-compile
+ (defun testcover-tests-run-test-case (marked-up-code)
+ "Test the operation of Testcover on the string MARKED-UP-CODE."
+ (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")))
+ (unwind-protect
+ (progn
+ (with-temp-file tempfile
+ (insert marked-up-code))
+ ;; Remove the marks and mark the code up again. The original
+ ;; and recreated versions should match.
+ (save-current-buffer
+ (set-buffer (find-file-noselect tempfile))
+ ;; Fail the test if the debugger tries to become active,
+ ;; which will happen if Testcover's reinstrumentation
+ ;; leaves an edebug-enter in the code. This will also
+ ;; prevent debugging these tests using Edebug.
+ (cl-letf (((symbol-function #'edebug-enter)
+ (lambda (&rest _args)
+ (ert-fail
+ (concat "Debugger invoked during test run "
+ "(possible edebug-enter not replaced)")))))
+ (dolist (byte-compile '(t nil))
+ (testcover-tests-unmarkup-region (point-min) (point-max))
+ (unwind-protect
+ (testcover-tests-markup-region (point-min) (point-max)
byte-compile)
+ (set-buffer-modified-p nil))
+ (should (string= marked-up-code
+ (buffer-string)))))))
+ (ignore-errors (kill-buffer (find-file-noselect tempfile)))
+ (ignore-errors (delete-file tempfile))))))
+
+;; Convert test case file to ert-defmethod.
+
+(eval-and-compile
+ (defun testcover-tests-build-test-cases ()
+ "Parse the test case file and return a list of ERT test definitions.
+Construct and return a list of `ert-deftest' forms. See testcases.el
+for documentation of the test definition format."
+ (let (results)
+ (with-temp-buffer
+ (insert-file-contents testcover-tests-test-cases)
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "^;; ==== \\([^ ]+?\\) ====\n"
+ "\\(\\(?:.*\n\\)*?\\)"
+ ";; ====\n"
+ "\\(\\(?:.*\n\\)*?\\)"
+ "\\(\\'\\|;; ====\\)")
+ nil t)
+ (let ((name (match-string 1))
+ (splice (car (read-from-string
+ (format "(%s)" (match-string 2)))))
+ (code (match-string 3)))
+ (push
+ `(ert-deftest ,(intern (concat "testcover-tests-" name)) ()
+ ,@splice
+ (testcover-tests-run-test-case ,code))
+ results))
+ (beginning-of-line)))
+ results)))
+
+;; Define all the tests.
+
+(defmacro testcover-tests-define-tests ()
+ "Construct and define ERT test methods using the test case file."
+ (let* ((test-cases (testcover-tests-build-test-cases)))
+ `(progn ,@test-cases)))
+
+(testcover-tests-define-tests)
+
+(provide 'testcover-tests)
+
+;;; testcover-tests.el ends here
diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el
index a30ba25..2b3456d 100644
--- a/test/lisp/faces-tests.el
+++ b/test/lisp/faces-tests.el
@@ -23,13 +23,18 @@
(require 'ert)
(require 'faces)
+(defgroup faces--test nil ""
+ :group 'faces--test)
+
(defface faces--test1
'((t :background "black" :foreground "black"))
- "")
+ ""
+ :group 'faces--test)
(defface faces--test2
'((t :box 1))
- "")
+ ""
+ :group 'faces--test)
(ert-deftest faces--test-color-at-point ()
(with-temp-buffer
diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el
index a3fe350..827d751 100644
--- a/test/lisp/ffap-tests.el
+++ b/test/lisp/ffap-tests.el
@@ -44,7 +44,7 @@ index 3d7cebadcf..ad4b70d737 100644
str
(make-string ffap-max-region-length #xa)
(format "%s ENDS HERE" file)))
- (mark-whole-buffer)
+ (call-interactively 'mark-whole-buffer)
(should (equal "" (ffap-string-at-point)))
(should (equal '(1 1) ffap-string-at-point-region)))))
(and (file-exists-p file) (delete-file file)))))
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index d237d0c..27434bc 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -36,6 +36,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'filenotify)
(require 'tramp)
@@ -703,21 +704,19 @@ delivered."
(should auto-revert-notify-watch-descriptor)
;; Modify file. We wait for a second, in order to have
- ;; another timestamp.
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (sleep-for 1)
- (write-region
- "another text" nil file-notify--test-tmpfile nil 'no-message)
-
- ;; Check, that the buffer has been reverted.
- (with-current-buffer (get-buffer-create "*Messages*")
- (file-notify--wait-for-events
- timeout
- (string-match
+ ;; another timestamp.
+ (ert-with-message-capture captured-messages
+ (sleep-for 1)
+ (write-region
+ "another text" nil file-notify--test-tmpfile nil 'no-message)
+
+ ;; Check, that the buffer has been reverted.
+ (file-notify--wait-for-events
+ timeout
+ (string-match
(format-message "Reverting buffer `%s'." (buffer-name buf))
- (buffer-string))))
- (should (string-match "another text" (buffer-string)))
+ captured-messages))
+ (should (string-match "another text" (buffer-string))))
;; Stop file notification. Autorevert shall still work via
polling.
(file-notify-rm-watch auto-revert-notify-watch-descriptor)
@@ -728,27 +727,24 @@ delivered."
;; Modify file. We wait for two seconds, in order to
;; have another timestamp. One second seems to be too
- ;; short.
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
- (sleep-for 2)
- (write-region
- "foo bla" nil file-notify--test-tmpfile nil 'no-message)
-
- ;; Check, that the buffer has been reverted.
- (with-current-buffer (get-buffer-create "*Messages*")
- (file-notify--wait-for-events
- timeout
- (string-match
- (format-message "Reverting buffer `%s'." (buffer-name buf))
- (buffer-string))))
- (should (string-match "foo bla" (buffer-string))))
+ ;; short.
+ (ert-with-message-capture captured-messages
+ (sleep-for 2)
+ (write-region
+ "foo bla" nil file-notify--test-tmpfile nil 'no-message)
+
+ ;; Check, that the buffer has been reverted.
+ (file-notify--wait-for-events
+ timeout
+ (string-match
+ (format-message "Reverting buffer `%s'." (buffer-name buf))
+ captured-messages))
+ (should (string-match "foo bla" (buffer-string)))))
;; The environment shall be cleaned up.
(file-notify--test-cleanup-p))
;; Cleanup.
- (with-current-buffer "*Messages*" (widen))
(ignore-errors (kill-buffer buf))
(file-notify--test-cleanup))))
@@ -850,6 +846,13 @@ delivered."
;; After deleting the parent directory, the descriptor must
;; not be valid anymore.
(should-not (file-notify-valid-p file-notify--test-desc))
+ ;; w32notify doesn't generate 'stopped' events when the parent
+ ;; directory is deleted, which doesn't provide a chance for
+ ;; filenotify.el to remove the descriptor from the internal
+ ;; hash table it maintains. So we must remove the descriptor
+ ;; manually.
+ (if (string-equal (file-notify--test-library) "w32notify")
+ (file-notify--rm-descriptor file-notify--test-desc))
;; The environment shall be cleaned up.
(file-notify--test-cleanup-p))
@@ -906,6 +909,8 @@ delivered."
(file-notify--test-timeout)
(not (file-notify-valid-p file-notify--test-desc)))
(should-not (file-notify-valid-p file-notify--test-desc))
+ (if (string-equal (file-notify--test-library) "w32notify")
+ (file-notify--rm-descriptor file-notify--test-desc))
;; The environment shall be cleaned up.
(file-notify--test-cleanup-p))
@@ -975,6 +980,8 @@ delivered."
(file-notify--test-read-event)
(delete-file file)))
(delete-directory file-notify--test-tmpfile)
+ (if (string-equal (file-notify--test-library) "w32notify")
+ (file-notify--rm-descriptor file-notify--test-desc))
;; The environment shall be cleaned up.
(file-notify--test-cleanup-p))
@@ -1184,6 +1191,9 @@ the file watch."
(delete-directory file-notify--test-tmpfile 'recursive))
(should-not (file-notify-valid-p file-notify--test-desc1))
(should-not (file-notify-valid-p file-notify--test-desc2))
+ (when (string-equal (file-notify--test-library) "w32notify")
+ (file-notify--rm-descriptor file-notify--test-desc1)
+ (file-notify--rm-descriptor file-notify--test-desc2))
;; The environment shall be cleaned up.
(file-notify--test-cleanup-p))
diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el
index 15eb7c1..4a1d566 100644
--- a/test/lisp/htmlfontify-tests.el
+++ b/test/lisp/htmlfontify-tests.el
@@ -30,5 +30,17 @@
(symbol-function
'htmlfontify-load-rgb-file))))
+(ert-deftest htmlfontify-bug25468 ()
+ "Tests that htmlfontify can be loaded even if no shell is
+available (Bug#25468)."
+ (should (equal (let ((process-environment
+ (cons "SHELL=/does/not/exist" process-environment)))
+ (call-process
+ (expand-file-name (invocation-name) (invocation-directory))
+ nil nil nil
+ "--quick" "--batch"
+ (concat "--load=" (locate-library "htmlfontify"))))
+ 0)))
+
(provide 'htmlfontify-tests)
;; htmlfontify-tests.el ends here
diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el
index fb632e2..b9f7fe7 100644
--- a/test/lisp/ibuffer-tests.el
+++ b/test/lisp/ibuffer-tests.el
@@ -23,6 +23,15 @@
(eval-when-compile
(require 'ibuf-macs))
+(defvar ibuffer-filter-groups)
+(defvar ibuffer-filtering-alist)
+(defvar ibuffer-filtering-qualifiers)
+(defvar ibuffer-save-with-custom)
+(defvar ibuffer-saved-filter-groups)
+(defvar ibuffer-saved-filters)
+(declare-function ibuffer-format-qualifier "ibuf-ext" (qualifier))
+(declare-function ibuffer-unary-operand "ibuf-ext" (filter))
+
(ert-deftest ibuffer-autoload ()
"Tests to see whether ibuffer has been autoloaded"
(skip-unless (not (featurep 'ibuf-ext)))
diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el
new file mode 100644
index 0000000..5124cbb
--- /dev/null
+++ b/test/lisp/kmacro-tests.el
@@ -0,0 +1,890 @@
+;;; kmacro-tests.el --- Tests for kmacro.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell <address@hidden>
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'kmacro)
+(require 'ert)
+(require 'ert-x)
+
+;;; Test fixtures:
+
+(defmacro kmacro-tests-with-kmacro-clean-slate (&rest body)
+ "Create a clean environment for a kmacro test BODY to run in."
+ (declare (debug (body)))
+ `(cl-letf* ((kmacro-execute-before-append t)
+ (kmacro-ring-max 8)
+ (kmacro-repeat-no-prefix t)
+ (kmacro-call-repeat-key nil)
+ (kmacro-call-repeat-with-arg nil)
+
+ (kbd-macro-termination-hook nil)
+ (defining-kbd-macro nil)
+ (executing-kbd-macro nil)
+ (executing-kbd-macro-index 0)
+ (last-kbd-macro nil)
+
+ (kmacro-ring nil)
+
+ (kmacro-counter 0)
+ (kmacro-default-counter-format "%d")
+ (kmacro-counter-format "%d")
+ (kmacro-counter-format-start "%d")
+ (kmacro-counter-value-start 0)
+ (kmacro-last-counter 0)
+ (kmacro-initial-counter-value nil)
+
+ (kmacro-tests-macros nil)
+ (kmacro-tests-events nil)
+ (kmacro-tests-sequences nil))
+ (advice-add 'end-kbd-macro :after #'kmacro-tests-end-macro-advice)
+ (advice-add 'read-event :around #'kmacro-tests-read-event-advice )
+ (advice-add 'read-key-sequence :around
#'kmacro-tests-read-key-sequence-advice)
+ (unwind-protect
+ (ert-with-test-buffer (:name "")
+ (switch-to-buffer (current-buffer))
+ ,@body)
+ (advice-remove 'read-key-sequence
#'kmacro-tests-read-key-sequence-advice)
+ (advice-remove 'read-event #'kmacro-tests-read-event-advice)
+ (advice-remove 'end-kbd-macro #'kmacro-tests-end-macro-advice))))
+
+(defmacro kmacro-tests-deftest (name _args docstring &rest keys-and-body)
+ "Define a kmacro unit test.
+NAME is the name of the test, _ARGS should be nil, and DOCSTRING
+is required. To avoid having to duplicate ert's keyword parsing
+here, its keywords and values (if any) must be inside a list
+after the docstring, preceding the body, here combined with the
+body in KEYS-AND-BODY."
+ (declare (debug (&define name sexp stringp
+ [&optional (&rest &or [keywordp sexp])]
+ def-body))
+ (doc-string 3)
+ (indent 2))
+
+ (let* ((keys (when (and (listp (car keys-and-body))
+ (keywordp (caar keys-and-body)))
+ (car keys-and-body)))
+ (body (if keys (cdr keys-and-body)
+ keys-and-body)))
+ `(ert-deftest ,name ()
+ ,docstring ,@keys
+ (kmacro-tests-with-kmacro-clean-slate ,@body))))
+
+(defvar kmacro-tests-keymap
+ (let ((map (make-sparse-keymap)))
+ (dotimes (i 26)
+ (define-key map (string (+ ?a i)) 'self-insert-command))
+ (dotimes (i 10)
+ (define-key map (string (+ ?0 i)) 'self-insert-command))
+ ;; Define a few key sequences of different lengths.
+ (dolist (item '(("\C-a" . beginning-of-line)
+ ("\C-b" . backward-char)
+ ("\C-e" . end-of-line)
+ ("\C-f" . forward-char)
+ ("\C-r" . isearch-backward)
+ ("\C-u" . universal-argument)
+ ("\C-w" . kill-region)
+ ("\C-SPC" . set-mark-command)
+ ("\M-w" . kill-ring-save)
+ ("\M-x" . execute-extended-command)
+ ("\C-cd" . downcase-word)
+ ("\C-cxu" . upcase-word)
+ ("\C-cxq" . quoted-insert)
+ ("\C-cxi" . kmacro-insert-counter)
+ ("\C-x\C-k" . kmacro-keymap)))
+ (define-key map (car item) (cdr item)))
+ map)
+ "Keymap to use for testing keyboard macros.
+This is used to obtain consistent results even if tests are run
+in an environment with rebound keys.")
+
+(defvar kmacro-tests-events nil
+ "Input events used by the kmacro test in progress.")
+
+(defun kmacro-tests-read-event-advice (orig-func &rest args)
+ "Pop and return an event from `kmacro-tests-events'.
+Return the result of calling ORIG-FUNC with ARGS if
+`kmacro-tests-events' is empty, or if a keyboard macro is
+running."
+ (if (or executing-kbd-macro (null kmacro-tests-events))
+ (apply orig-func args)
+ (pop kmacro-tests-events)))
+
+(defvar kmacro-tests-sequences nil
+ "Input sequences used by the kmacro test in progress.")
+
+(defun kmacro-tests-read-key-sequence-advice (orig-func &rest args)
+ "Pop and return a string from `kmacro-tests-sequences'.
+Return the result of calling ORIG-FUNC with ARGS if
+`kmacro-tests-sequences' is empty, or if a keyboard macro is
+running."
+ (if (or executing-kbd-macro (null kmacro-tests-sequences))
+ (apply orig-func args)
+ (pop kmacro-tests-sequences)))
+
+(defvar kmacro-tests-macros nil
+ "Keyboard macros (in vector form) used by the kmacro test in progress.")
+
+(defun kmacro-tests-end-macro-advice (&rest _args)
+ "Pop a macro from `kmacro-tests-macros' and assign it to `last-kbd-macro'.
+If `kmacro-tests-macros' is empty, do nothing."
+ (when kmacro-tests-macros
+ (setq last-kbd-macro (pop kmacro-tests-macros))))
+
+;;; Some more powerful expectations:
+
+(defmacro kmacro-tests-should-insert (value &rest body)
+ "Verify that VALUE is inserted by the execution of BODY.
+Execute BODY, then check that the string VALUE was inserted
+into the current buffer at point."
+ (declare (debug (stringp body))
+ (indent 1))
+ (let ((g-p (cl-gensym))
+ (g-bsize (cl-gensym)))
+ `(let ((,g-p (point))
+ (,g-bsize (buffer-size)))
+ ,@body
+ (should (equal (buffer-substring ,g-p (point)) ,value))
+ (should (equal (- (buffer-size) ,g-bsize) (length ,value))))))
+
+(defmacro kmacro-tests-should-match-message (value &rest body)
+ "Verify that a message matching VALUE is issued while executing BODY.
+Execute BODY, and then if there is not a regexp match between
+VALUE and any text written to *Messages* during the execution,
+cause the current test to fail."
+ (declare (debug (form body))
+ (indent 1))
+ (let ((g-captured-messages (cl-gensym)))
+ `(ert-with-message-capture ,g-captured-messages
+ ,@body
+ (should (string-match-p ,value ,g-captured-messages)))))
+
+;;; Tests:
+
+(kmacro-tests-deftest kmacro-tests-test-insert-counter-01-nil ()
+ "`kmacro-insert-counter' adds one to macro counter with nil arg."
+ (kmacro-tests-should-insert "0"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
+ (kmacro-tests-should-insert "1"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
+
+(kmacro-tests-deftest kmacro-tests-test-insert-counter-02-int ()
+ "`kmacro-insert-counter' increments by value of list argument."
+ (kmacro-tests-should-insert "0"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter 2)))
+ (kmacro-tests-should-insert "2"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter 3)))
+ (kmacro-tests-should-insert "5"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
+
+(kmacro-tests-deftest kmacro-tests-test-insert-counter-03-list ()
+ "`kmacro-insert-counter' doesn't increment when given universal argument."
+ (kmacro-tests-should-insert "0"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter (16))))
+ (kmacro-tests-should-insert "0"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter (4)))))
+
+(kmacro-tests-deftest kmacro-tests-test-insert-counter-04-neg ()
+ "`kmacro-insert-counter' decrements with '- prefix argument"
+ (kmacro-tests-should-insert "0"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter -)))
+ (kmacro-tests-should-insert "-1"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
+
+(kmacro-tests-deftest kmacro-tests-test-start-format-counter ()
+ "`kmacro-insert-counter' uses start value and format."
+ (kmacro-tests-simulate-command '(kmacro-set-counter 10))
+ (kmacro-tests-should-insert "10"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
+ (kmacro-tests-should-insert "11"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
+ (kmacro-set-format "c=%s")
+ (kmacro-tests-simulate-command '(kmacro-set-counter 50))
+ (kmacro-tests-should-insert "c=50"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
+
+(kmacro-tests-deftest kmacro-tests-test-start-macro-when-defining-macro ()
+ "Starting a macro while defining a macro does not start a second macro."
+ (kmacro-tests-simulate-command '(kmacro-start-macro nil))
+ ;; We should now be in the macro-recording state.
+ (should defining-kbd-macro)
+ (should-not last-kbd-macro)
+ ;; Calling it again should leave us in the same state.
+ (kmacro-tests-simulate-command '(kmacro-start-macro nil))
+ (should defining-kbd-macro)
+ (should-not last-kbd-macro))
+
+
+(kmacro-tests-deftest kmacro-tests-set-macro-counter-while-defining ()
+ "Use of the prefix arg with kmacro-start sets kmacro-counter."
+ ;; Give kmacro-start-macro an argument.
+ (kmacro-tests-simulate-command '(kmacro-start-macro 5))
+ (should defining-kbd-macro)
+ ;; Verify that the counter is set to that value.
+ (kmacro-tests-should-insert "5"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
+ ;; Change it while defining a macro.
+ (kmacro-tests-simulate-command '(kmacro-set-counter 1))
+ (kmacro-tests-should-insert "1"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
+ ;; Using universal arg to to set counter should reset to starting value.
+ (kmacro-tests-simulate-command '(kmacro-set-counter (4)) '(4))
+ (kmacro-tests-should-insert "5"
+ (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
+
+
+(kmacro-tests-deftest kmacro-tests-start-insert-counter-appends-to-macro ()
+ "Use of the universal arg appends to the previous macro."
+ (let ((kmacro-tests-macros (list (string-to-vector "hello"))))
+ ;; Start recording a macro.
+ (kmacro-tests-simulate-command '(kmacro-start-macro-or-insert-counter nil))
+ ;; Make sure we are recording.
+ (should defining-kbd-macro)
+ ;; Call it again and it should insert the counter.
+ (kmacro-tests-should-insert "0"
+ (kmacro-tests-simulate-command '(kmacro-start-macro-or-insert-counter
nil)))
+ ;; We should still be in the recording state.
+ (should defining-kbd-macro)
+ ;; End recording with repeat count.
+ (kmacro-tests-simulate-command '(kmacro-end-or-call-macro 3))
+ ;; Recording should be finished.
+ (should-not defining-kbd-macro)
+ ;; Now use prefix arg to append to the previous macro.
+ ;; This should run the previous macro first.
+ (kmacro-tests-should-insert "hello"
+ (kmacro-tests-simulate-command
+ '(kmacro-start-macro-or-insert-counter (4))))
+ ;; Verify that the recording state has changed.
+ (should (equal defining-kbd-macro 'append))))
+
+(kmacro-tests-deftest kmacro-tests-end-call-macro-prefix-args ()
+ "kmacro-end-call-macro changes behavior based on prefix arg."
+ ;; "Record" two macros.
+ (dotimes (i 2)
+ (kmacro-tests-define-macro (vconcat (format "macro #%d" (1+ i)))))
+ ;; With no prefix arg, it should call the second macro.
+ (kmacro-tests-should-insert "macro #2"
+ (kmacro-tests-simulate-command '(kmacro-end-or-call-macro nil)))
+ ;; With universal arg, it should call the first one.
+ (kmacro-tests-should-insert "macro #1"
+ (kmacro-tests-simulate-command '(kmacro-end-or-call-macro (4)))))
+
+(kmacro-tests-deftest kmacro-tests-end-and-call-macro ()
+ "Keyboard command to end and call macro works under various conditions."
+ ;; First, try it with no macro to record.
+ (setq kmacro-tests-macros '(""))
+ (kmacro-tests-simulate-command '(kmacro-start-macro nil))
+ (condition-case err
+ (kmacro-tests-simulate-command '(kmacro-end-and-call-macro 2) 2)
+ (error (should (string= (cadr err)
+ "No kbd macro has been defined"))))
+
+ ;; Check that it stopped defining and that no macro was recorded.
+ (should-not defining-kbd-macro)
+ (should-not last-kbd-macro)
+
+ ;; Now try it while not recording, but first record a non-nil macro.
+ (kmacro-tests-define-macro "macro")
+ (kmacro-tests-should-insert "macro"
+ (kmacro-tests-simulate-command '(kmacro-end-and-call-macro nil))))
+
+(kmacro-tests-deftest kmacro-tests-end-and-call-macro-mouse ()
+ "Commands to end and call macro work under various conditions.
+This is a regression test for Bug#24992."
+ (:expected-result :failed)
+ (cl-letf (((symbol-function #'mouse-set-point) #'ignore))
+ ;; First, try it with no macro to record.
+ (setq kmacro-tests-macros '(""))
+ (kmacro-tests-simulate-command '(kmacro-start-macro nil))
+ (condition-case err
+ (kmacro-tests-simulate-command '(kmacro-end-call-mouse 2) 2)
+ (error (should (string= (cadr err)
+ "No kbd macro has been defined"))))
+
+ ;; Check that it stopped defining and that no macro was recorded.
+ (should-not defining-kbd-macro)
+ (should-not last-kbd-macro)
+
+ ;; Now try it while not recording, but first record a non-nil macro.
+ (kmacro-tests-define-macro "macro")
+ (kmacro-tests-should-insert "macro"
+ (kmacro-tests-simulate-command '(kmacro-end-call-mouse nil)))))
+
+(kmacro-tests-deftest kmacro-tests-call-macro-hint-and-repeat ()
+ "`kmacro-call-macro' gives hint in Messages and sets up repeat keymap.
+This is a regression test for: Bug#3412, Bug#11817."
+ (kmacro-tests-define-macro [?m])
+ (let ((kmacro-call-repeat-key t)
+ (kmacro-call-repeat-with-arg t)
+ (overriding-terminal-local-map overriding-terminal-local-map)
+ (last-input-event ?e))
+ (message "") ; Clear the echo area. (Bug#3412)
+ (kmacro-tests-should-match-message "Type e to repeat macro"
+ (kmacro-tests-should-insert "mmmmmm"
+ (cl-letf (((symbol-function #'this-single-command-keys) (lambda ()
+ [?\C-x ?e])))
+ (kmacro-call-macro 3))
+ ;; Check that it set up for repeat, and run the repeat.
+ (funcall (lookup-key overriding-terminal-local-map "e"))))))
+
+(kmacro-tests-deftest
+ kmacro-tests-run-macro-command-recorded-in-macro ()
+ "No infinite loop if `kmacro-end-and-call-macro' is recorded in the macro.
+\(Bug#15126)"
+ (:expected-result :failed)
+ (ert-skip "Skipping due to Bug#24921 (an ERT bug)")
+ (kmacro-tests-define-macro (vconcat "foo" [return] "\M-x"
+ "kmacro-end-and-call-macro"))
+ (use-local-map kmacro-tests-keymap)
+ (kmacro-tests-simulate-command '(kmacro-end-and-call-macro nil)))
+
+
+(kmacro-tests-deftest kmacro-tests-test-ring-2nd-commands ()
+ "2nd macro in ring is displayed and executed normally and on repeat."
+ (use-local-map kmacro-tests-keymap)
+ ;; Record one macro, with count.
+ (push (vconcat "\C-cxi" "\C-u\C-cxi") kmacro-tests-macros)
+ (kmacro-tests-simulate-command '(kmacro-start-macro 1))
+ (kmacro-tests-simulate-command '(kmacro-end-macro nil))
+ ;; Check that execute and display do nothing with no 2nd macro.
+ (kmacro-tests-should-insert ""
+ (kmacro-tests-simulate-command '(kmacro-call-ring-2nd nil)))
+ (kmacro-tests-should-match-message "Only one keyboard macro defined"
+ (kmacro-tests-simulate-command '(kmacro-view-ring-2nd)))
+ ;; Record another one, with format.
+ (kmacro-set-format "=%d=")
+ (kmacro-tests-define-macro (vconcat "bar"))
+ ;; Execute the first one, mocked up to insert counter.
+ ;; Should get default format.
+ (kmacro-tests-should-insert "11"
+ (kmacro-tests-simulate-command '(kmacro-call-ring-2nd nil)))
+ ;; Now display the 2nd ring macro and check result.
+ (kmacro-tests-should-match-message "C-c x i C-u C-c x i"
+ (kmacro-view-ring-2nd)))
+
+(kmacro-tests-deftest kmacro-tests-fill-ring-and-rotate ()
+ "Macro ring can shift one way, shift the other way, swap and pop."
+ (cl-letf ((kmacro-ring-max 4))
+ ;; Record enough macros that the first one drops off the history.
+ (dotimes (n (1+ kmacro-ring-max))
+ (kmacro-tests-define-macro (make-vector (1+ n) (+ ?a n))))
+ ;; Cycle the ring and check that #2 comes up.
+ (kmacro-tests-should-match-message "2*b"
+ (kmacro-tests-simulate-command '(kmacro-cycle-ring-next nil)))
+ ;; Execute the current macro and check arguments.
+ (kmacro-tests-should-insert "bbbb"
+ (kmacro-call-macro 2 t))
+ ;; Cycle the ring the other way; #5 expected.
+ (kmacro-tests-should-match-message "5*e" (kmacro-cycle-ring-previous nil))
+ ;; Swapping the top two should give #4.
+ (kmacro-tests-should-match-message "4*d" (kmacro-swap-ring))
+ ;; Delete the top and expect #5.
+ (kmacro-tests-should-match-message "5*e" (kmacro-delete-ring-head))))
+
+
+(kmacro-tests-deftest kmacro-tests-test-ring-commands-when-no-macros ()
+ "Ring commands give appropriate message when no macros exist."
+ (dolist (cmd '((kmacro-cycle-ring-next nil)
+ (kmacro-cycle-ring-previous nil)
+ (kmacro-swap-ring)
+ (kmacro-delete-ring-head)
+ (kmacro-view-ring-2nd)
+ (kmacro-call-ring-2nd nil)
+ (kmacro-view-macro)))
+ (kmacro-tests-should-match-message "No keyboard macro defined"
+ (kmacro-tests-simulate-command cmd))))
+
+(kmacro-tests-deftest kmacro-tests-repeat-on-last-key ()
+ "Kmacro commands can be run in sequence without prefix keys."
+ (let* ((prefix (where-is-internal 'kmacro-keymap nil t))
+ ;; Make a sequence of events to run.
+ ;; Comments are expected output of mock macros
+ ;; on the first and second run of the sequence (see below).
+ (events (mapcar #'kmacro-tests-get-kmacro-key
+ '(kmacro-end-or-call-macro-repeat ;c / b
+ kmacro-end-or-call-macro-repeat ;c / b
+ kmacro-call-ring-2nd-repeat ;b / a
+ kmacro-cycle-ring-next
+ kmacro-end-or-call-macro-repeat ;a / a
+ kmacro-cycle-ring-previous
+ kmacro-end-or-call-macro-repeat ;c / b
+ kmacro-delete-ring-head
+ kmacro-end-or-call-macro-repeat ;b / a
+ )))
+ (kmacro-tests-macros (list [?a] [?b] [?c]))
+ ;; What we want kmacro to see as keyboard command sequence
+ (first-event (seq-concatenate
+ 'vector
+ prefix
+ (vector (kmacro-tests-get-kmacro-key
+ 'kmacro-end-or-call-macro-repeat)))))
+ (cl-letf
+ ;; standardize repeat options
+ ((kmacro-repeat-no-prefix t)
+ (kmacro-call-repeat-key t)
+ (kmacro-call-repeat-with-arg nil))
+ ;; "Record" two macros
+ (dotimes (_n 2)
+ (kmacro-tests-simulate-command '(kmacro-start-macro nil))
+ (kmacro-tests-simulate-command '(kmacro-end-macro nil)))
+ ;; Start recording #3
+ (kmacro-tests-simulate-command '(kmacro-start-macro nil))
+
+ ;; Set up pending keyboard events and a fresh buffer
+ ;; kmacro-set-counter is not one of the repeating kmacro
+ ;; commands so it should end the sequence.
+ (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-set-counter))
+ (kmacro-tests-events (append events (list end-key))))
+ (cl-letf (((symbol-function #'this-single-command-keys)
+ (lambda () first-event)))
+ (use-local-map kmacro-tests-keymap)
+ (kmacro-tests-should-insert "ccbacb"
+ ;; End #3 and launch loop to read events.
+ (kmacro-end-or-call-macro-repeat nil))))
+
+ ;; `kmacro-edit-macro-repeat' should also stop the sequence,
+ ;; so run it again with that at the end.
+ (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-edit-macro-repeat))
+ (kmacro-tests-events (append events (list end-key))))
+ (cl-letf (((symbol-function #'edit-kbd-macro) #'ignore)
+ ((symbol-function #'this-single-command-keys)
+ (lambda () first-event)))
+ (use-local-map kmacro-tests-keymap)
+ (kmacro-tests-should-insert "bbbbbaaba"
+ (kmacro-end-or-call-macro-repeat 3)))))))
+
+(kmacro-tests-deftest kmacro-tests-repeat-view-and-run ()
+ "Kmacro view cycles through ring and executes macro just viewed."
+ (let* ((prefix (where-is-internal 'kmacro-keymap nil t))
+ (kmacro-tests-events
+ (mapcar #'kmacro-tests-get-kmacro-key
+ (append (make-list 5 'kmacro-view-macro-repeat)
+ '(kmacro-end-or-call-macro-repeat
+ kmacro-set-counter))))
+ ;; Make kmacro see this as keyboard command sequence.
+ (first-event (seq-concatenate
+ 'vector
+ prefix
+ (vector (kmacro-tests-get-kmacro-key
+ 'kmacro-view-macro-repeat))))
+ ;; Construct a regexp to match the messages which should be
+ ;; produced by repeated view-repeats.
+ (macros-regexp (apply #'concat
+ (mapcar (lambda (c) (format ".+%s\n" c))
+ '("d" "c" "b" "a" "d" "c")))))
+ (cl-letf ((kmacro-repeat-no-prefix t)
+ (kmacro-call-repeat-key t)
+ (kmacro-call-repeat-with-arg nil)
+ ((symbol-function #'this-single-command-keys) (lambda ()
+ first-event)))
+ ;; "Record" some macros.
+ (dotimes (n 4)
+ (kmacro-tests-define-macro (make-vector 1 (+ ?a n))))
+
+ (use-local-map kmacro-tests-keymap)
+ ;; 6 views (the direct call plus the 5 in events) should
+ ;; cycle through the ring and get to the second-to-last
+ ;; macro defined.
+ (kmacro-tests-should-insert "c"
+ (kmacro-tests-should-match-message macros-regexp
+ (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil)))))))
+
+(kmacro-tests-deftest kmacro-tests-bind-to-key-when-recording ()
+ "Bind to key doesn't bind a key during macro recording."
+ (cl-letf ((global-map global-map)
+ (saved-binding (key-binding "\C-a"))
+ (kmacro-tests-sequences (list "\C-a")))
+ (kmacro-tests-simulate-command '(kmacro-start-macro 1))
+ (kmacro-bind-to-key nil)
+ (should (eq saved-binding (key-binding "\C-a")))))
+
+(kmacro-tests-deftest kmacro-tests-name-or-bind-to-key-when-no-macro ()
+ "Bind to key, symbol or register fails when when no macro exists."
+ (should-error (kmacro-bind-to-key nil))
+ (should-error (kmacro-name-last-macro 'kmacro-tests-symbol-for-test))
+ (should-error (kmacro-to-register)))
+
+(kmacro-tests-deftest kmacro-tests-bind-to-key-bad-key-sequence ()
+ "Bind to key fails to bind to ^G."
+ (let ((global-map global-map)
+ (saved-binding (key-binding "\C-g"))
+ (kmacro-tests-sequences (list "\C-g")))
+ (kmacro-tests-define-macro [1])
+ (kmacro-bind-to-key nil)
+ (should (eq saved-binding (key-binding "\C-g")))))
+
+(kmacro-tests-deftest kmacro-tests-bind-to-key-with-key-sequence-in-use ()
+ "Bind to key respects yes-or-no-p when given already bound key sequence."
+ (kmacro-tests-define-macro (vconcat "abaab"))
+ (let ((global-map global-map)
+ (map (make-sparse-keymap))
+ (kmacro-tests-sequences (make-list 2 "\C-hi")))
+ (define-key map "\C-hi" 'info)
+ (use-local-map map)
+ ;; Try the command with yes-or-no-p set up to say no.
+ (cl-letf (((symbol-function #'yes-or-no-p)
+ (lambda (prompt)
+ (should (string-match-p "info" prompt))
+ (should (string-match-p "C-h i" prompt))
+ nil)))
+ (kmacro-bind-to-key nil))
+
+ (should (equal (where-is-internal 'info nil t)
+ (vconcat "\C-hi")))
+ ;; Try it again with yes.
+ (cl-letf (((symbol-function #' yes-or-no-p)
+ (lambda (_prompt) t)))
+ (kmacro-bind-to-key nil))
+
+ (should-not (equal (where-is-internal 'info global-map t)
+ (vconcat "\C-hi")))
+ (use-local-map nil)
+ (kmacro-tests-should-insert "abaab"
+ (funcall (key-binding "\C-hi")))))
+
+(kmacro-tests-deftest kmacro-tests-kmacro-bind-to-single-key ()
+ "Bind to key uses C-x C-k A when asked to bind to A."
+ (let ((global-map global-map)
+ (kmacro-tests-macros (list (string-to-vector "\C-cxi"))))
+ (use-local-map kmacro-tests-keymap)
+
+ ;; Record a macro with counter and format set.
+ (kmacro-set-format "<%d>")
+ (kmacro-tests-simulate-command '(kmacro-start-macro-or-insert-counter 5))
+ (kmacro-tests-simulate-command '(kmacro-end-macro nil))
+
+ (let ((kmacro-tests-sequences (list "A")))
+ (kmacro-bind-to-key nil))
+
+ ;; Record a second macro with different counter and format.
+ (kmacro-set-format "%d")
+ (kmacro-tests-define-macro [2])
+
+ ;; Check the bound key and run it and verify correct counter
+ ;; and format.
+ (should (equal (string-to-vector "\C-cxi")
+ (car (kmacro-extract-lambda
+ (key-binding "\C-x\C-kA")))))
+ (kmacro-tests-should-insert "<5>"
+ (funcall (key-binding "\C-x\C-kA")))))
+
+(kmacro-tests-deftest kmacro-tests-name-last-macro-unable-to-bind ()
+ "Name last macro won't bind to symbol which is already bound."
+ (kmacro-tests-define-macro [1])
+ ;; Set up a test symbol which looks like a function.
+ (setplist 'kmacro-tests-symbol-for-test nil)
+ (fset 'kmacro-tests-symbol-for-test #'ignore)
+ (should-error (kmacro-name-last-macro 'kmacro-tests-symbol-for-test))
+ ;; The empty string symbol also can't be bound.
+ (should-error (kmacro-name-last-macro (make-symbol ""))))
+
+(kmacro-tests-deftest kmacro-tests-name-last-macro-bind-and-rebind ()
+ "Name last macro can rebind a symbol it binds."
+ ;; Make sure our symbol is unbound.
+ (when (fboundp 'kmacro-tests-symbol-for-test)
+ (fmakunbound 'kmacro-tests-symbol-for-test))
+ (setplist 'kmacro-tests-symbol-for-test nil)
+ ;; Make two macros and bind them to the same symbol.
+ (dotimes (i 2)
+ (kmacro-tests-define-macro (make-vector (1+ i) (+ ?a i)))
+ (kmacro-name-last-macro 'kmacro-tests-symbol-for-test)
+ (should (fboundp 'kmacro-tests-symbol-for-test)))
+
+ ;; Now run the function bound to the symbol. Result should be the
+ ;; second macro.
+ (kmacro-tests-should-insert "bb"
+ (kmacro-tests-simulate-command '(kmacro-tests-symbol-for-test))))
+
+(kmacro-tests-deftest kmacro-tests-store-in-register ()
+ "Macro can be stored in and retrieved from a register."
+ (use-local-map kmacro-tests-keymap)
+ ;; Save and restore register 200 so we can use it for the test.
+ (let ((saved-reg-contents (get-register 200)))
+ (unwind-protect
+ (progn
+ ;; Define a macro, and save it to a register.
+ (kmacro-tests-define-macro (vconcat "a\C-a\C-cxu"))
+ (kmacro-to-register 200)
+ ;; Then make a new different macro.
+ (kmacro-tests-define-macro (vconcat "bb\C-a\C-cxu"))
+ ;; When called from the register, result should be first macro.
+ (kmacro-tests-should-insert "AAA"
+ (kmacro-tests-simulate-command '(jump-to-register 200 3) 3))
+ (kmacro-tests-should-insert "a C-a C-c x u"
+ (kmacro-tests-simulate-command '(insert-register 200 t) '(4))))
+ (set-register 200 saved-reg-contents))))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-act ()
+ "Step-edit steps-through a macro with act and act-repeat."
+ (kmacro-tests-run-step-edit "he\C-u2lo"
+ :events (make-list 6 'act)
+ :result "hello"
+ :macro-result "he\C-u2lo")
+
+ (kmacro-tests-run-step-edit "f\C-aoo\C-abar"
+ :events (make-list 5 'act-repeat)
+ :result "baroof"
+ :macro-result "f\C-aoo\C-abar"))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-skip ()
+ "Step-editing can skip parts of macro."
+ (kmacro-tests-run-step-edit "ofoofff"
+ :events '(skip skip-keep skip-keep skip-keep
+ skip-rest)
+ :result ""
+ :macro-result "foo"))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-quit ()
+ "Quit while step-editing leaves macro unchanged."
+ (kmacro-tests-run-step-edit "bar"
+ :events '(help insert skip help quit)
+ :sequences '("f" "o" "o" "\C-j")
+ :result "foo"
+ :macro-result "bar"))
+
+(kmacro-tests-deftest kmacro-tests-step-insert ()
+ "Step edit can insert in macro."
+ (kmacro-tests-run-step-edit "fbazbop"
+ :events '(insert act insert-1 act-repeat)
+ :sequences '("o" "o" "\C-a" "\C-j" "\C-e")
+ :result "foobazbop"
+ :macro-result "oo\C-af\C-ebazbop"))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-replace-digit-argument ()
+ "Step-edit replace can replace a numeric argument in a macro.
+This is a regression for item 1 in Bug#24991."
+ (:expected-result :failed)
+ (kmacro-tests-run-step-edit "\C-u3b\C-a\C-cxu"
+ :events '(act replace automatic)
+ :sequences '("8" "x" "\C-j")
+ :result "XXXXXXXX"
+ :macro-result "\C-u8x\C-a\C-cxu"))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-replace ()
+ "Step-edit replace and replace-1 can replace parts of a macro."
+ (kmacro-tests-run-step-edit "a\C-a\C-cxu"
+ :events '(act act replace)
+ :sequences '("b" "c" "\C-j")
+ :result "bca"
+ :macro-result "a\C-abc")
+ (kmacro-tests-run-step-edit "a\C-a\C-cxucd"
+ :events '(act replace-1 automatic)
+ :sequences '("b")
+ :result "abcd"
+ :macro-result "ab\C-cxucd")
+ (kmacro-tests-run-step-edit "by"
+ :events '(act replace)
+ :sequences '("a" "r" "\C-j")
+ :result "bar"
+ :macro-result "bar"))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-append ()
+ "Step edit append inserts after point, and append-end inserts at end."
+ (kmacro-tests-run-step-edit "f-b"
+ :events '(append append-end)
+ :sequences '("o" "o" "\C-j" "a" "r" "\C-j")
+ :result "foo-bar"
+ :macro-result "foo-bar")
+ (kmacro-tests-run-step-edit "x"
+ :events '(append)
+ :sequences '("\C-a" "\C-cxu" "\C-e" "y" "\C-j")
+ :result "Xy"
+ :macro-result "x\C-a\C-cxu\C-ey"))
+
+(kmacro-tests-deftest kmacro-tests-append-end-at-end-appends ()
+ "Append-end when already at end of macro appends to end of macro.
+This is a regression for item 2 in Bug#24991."
+ (:expected-result :failed)
+ (kmacro-tests-run-step-edit "x"
+ :events '(append-end)
+ :sequences '("\C-a" "\C-cxu" "\C-e" "y" "\C-j")
+ :result "Xy"
+ :macro-result "x\C-a\C-cxu\C-ey"))
+
+
+(kmacro-tests-deftest kmacro-tests-step-edit-skip-entire ()
+ "Skipping a whole macro in step-edit leaves macro unchanged.
+This is a regression for item 3 in Bug#24991."
+ (:expected-result :failed)
+ (kmacro-tests-run-step-edit "xyzzy"
+ :events '(skip-rest)
+ :result ""
+ :macro-result "xyzzy"))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-step-through-negative-argument ()
+ "Step edit works on macros using negative universal argument.
+This is a regression for item 4 in Bug#24991."
+ (:expected-result :failed)
+ (kmacro-tests-run-step-edit "boo\C-u-\C-cu"
+ :events '(act-repeat automatic)
+ :result "BOO"
+ :macro-result "boo\C-u-\C-cd"))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-with-quoted-insert ()
+ "Stepping through a macro that uses quoted insert leaves macro unchanged.
+This is a regression for item 5 in Bug#24991."
+ (:expected-result :failed)
+ (let ((read-quoted-char-radix 8))
+ (kmacro-tests-run-step-edit "\C-cxq17051i there"
+ :events '(act automatic)
+ :result "ḩi there"
+ :macro-result "\C-cxq17051i there")
+ (kmacro-tests-run-step-edit "g\C-cxq17051i"
+ :events '(act insert-1 automatic)
+ :sequences '("-")
+ :result "g-ḩi"
+ :macro-result "g-\C-cxq17051i")))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-can-replace-meta-keys ()
+ "Replacing C-w with M-w produces the expected result.
+This is a regression for item 7 in Bug#24991."
+ (:expected-result :failed)
+ (kmacro-tests-run-step-edit "abc\C-b\C-b\C-SPC\C-f\C-w\C-e\C-y"
+ :events '(act-repeat act-repeat
+ act-repeat act-repeat
+ replace automatic)
+ :sequences '("\M-w" "\C-j")
+ :result "abcb"
+ :macro-result
"abc\C-b\C-b\C-SPC\C-f\M-w\C-e\C-y")
+ (kmacro-tests-should-insert "abcb" (kmacro-call-macro nil)))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-ignores-qr-map-commands ()
+ "Unimplemented commands from `query-replace-map' are ignored."
+ (kmacro-tests-run-step-edit "yep"
+ :events '(edit-replacement
+ act-and-show act-and-exit
+ delete-and-edit
+ recenter backup
+ scroll-up scroll-down
+ scroll-other-window
+ scroll-other-window-down
+ exit-prefix
+ act act act)
+ :result "yep"
+ :macro-result "yep"))
+
+(kmacro-tests-deftest
+ kmacro-tests-step-edit-edits-macro-with-extended-command ()
+ "Step-editing a macro which uses the minibuffer can change the macro."
+ (let ((mac (vconcat [?\M-x] "eval-expression" '[return]
+ "(insert-char (+ ?a \C-e" [?1] "))" '[return]))
+ (mac-after (vconcat [?\M-x] "eval-expression" '[return]
+ "(insert-char (+ ?a \C-e" [?2] "))" '[return])))
+
+ (kmacro-tests-run-step-edit mac
+ :events '(act act-repeat
+ act act-repeat act
+ replace-1 act-repeat act)
+ :sequences '("2")
+ :result "c"
+ :macro-result mac-after)))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-step-through-isearch ()
+ "Step-editing can edit a macro which uses `isearch-backward' (Bug#22488)."
+ (:expected-result :failed)
+ (let ((mac (vconcat "test Input" '[return]
+ [?\C-r] "inp" '[return] "\C-cxu"))
+ (mac-after (vconcat "test input" '[return]
+ [?\C-r] "inp" '[return] "\C-cd")))
+
+ (kmacro-tests-run-step-edit mac
+ :events '(act-repeat act act
+ act-repeat act
+ replace-1)
+ :sequences '("\C-cd")
+ :result "test input\n"
+ :macro-result mac-after)))
+
+(kmacro-tests-deftest kmacro-tests-step-edit-cleans-up-hook ()
+ "Step-editing properly cleans up `post-command-hook.' (Bug #18708)"
+ (:expected-result :failed)
+ (let (post-command-hook)
+ (setq-local post-command-hook '(t))
+ (kmacro-tests-run-step-edit "x"
+ :events '(act)
+ :result "x"
+ :macro-result "x")
+ (kmacro-tests-simulate-command '(beginning-of-line))))
+
+(cl-defun kmacro-tests-run-step-edit
+ (macro &key events sequences result macro-result)
+ "Set up and run a test of `kmacro-step-edit-macro'.
+
+Run `kmacro-step-edit-macro' with MACRO defined as a keyboard macro
+and `read-event' and `read-key-sequence' set up to return items from
+EVENTS and SEQUENCES respectively. SEQUENCES may be nil, but
+EVENTS should not be. EVENTS should be a list of symbols bound
+in `kmacro-step-edit-map' or `query-replace' map, and this function
+will do the keymap lookup for you. SEQUENCES should contain
+return values for `read-key-sequence'.
+
+Before running the macro, the current buffer will be erased.
+RESULT is the string that should be inserted during the
+step-editing process, and MACRO-RESULT is the expected value of
+`last-kbd-macro' after the editing is complete."
+
+ (let* ((kmacro-tests-events (mapcar #'kmacro-tests-get-kmacro-step-edit-key
events))
+ (kmacro-tests-sequences sequences))
+
+ (kmacro-tests-define-macro (string-to-vector macro))
+ (use-local-map kmacro-tests-keymap)
+ (erase-buffer)
+ (kmacro-step-edit-macro)
+ (when result
+ (should (equal result (buffer-string))))
+ (when macro-result
+ (should (equal last-kbd-macro (string-to-vector macro-result))))))
+
+;;; Utilities:
+
+(defun kmacro-tests-simulate-command (command &optional arg)
+ "Call `ert-simulate-command' after setting `current-prefix-arg'.
+Sets `current-prefix-arg' to ARG if it is non-nil, otherwise to
+the second element of COMMAND, before executing COMMAND using
+`ert-simulate-command'."
+ (let ((current-prefix-arg (or arg (cadr command))))
+ (ert-simulate-command command)))
+
+(defun kmacro-tests-define-macro (mac)
+ "Define MAC as a keyboard macro using kmacro commands."
+ (push mac kmacro-tests-macros)
+ (kmacro-tests-simulate-command '(kmacro-start-macro nil))
+ (should defining-kbd-macro)
+ (kmacro-tests-simulate-command '(kmacro-end-macro nil))
+ (should (equal mac last-kbd-macro)))
+
+(defun kmacro-tests-get-kmacro-key (sym)
+ "Look up kmacro command SYM in kmacro's keymap.
+Return the integer key value found."
+ (aref (where-is-internal sym kmacro-keymap t) 0))
+
+(defun kmacro-tests-get-kmacro-step-edit-key (sym)
+ "Return the first key bound to SYM in `kmacro-step-edit-map'."
+ (let ((where (aref (where-is-internal sym kmacro-step-edit-map t) 0)))
+ (if (consp where)
+ (car where)
+ where)))
+
+(provide 'kmacro-tests)
+
+;;; kmacro-tests.el ends here
diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el
index efed8f8..7c5fcb4 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -28,7 +28,7 @@
(ert-deftest completion-test1 ()
(with-temp-buffer
- (cl-flet* ((test/completion-table (string pred action)
+ (cl-flet* ((test/completion-table (_string _pred action)
(if (eq action 'lambda)
nil
"test: "))
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 525709b..0a59e3b 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -22,7 +22,8 @@
(require 'ert)
(require 'dbus)
-(setq dbus-debug nil)
+(defvar dbus-debug nil)
+(declare-function dbus-get-unique-name "dbusbind.c" (bus))
(defvar dbus--test-enabled-session-bus
(and (featurep 'dbusbind)
diff --git a/test/lisp/progmodes/js-tests.el b/test/lisp/progmodes/js-tests.el
index 84749ef..7cb737c 100644
--- a/test/lisp/progmodes/js-tests.el
+++ b/test/lisp/progmodes/js-tests.el
@@ -85,6 +85,20 @@ if (!/[ (:,='\"]/.test(value)) {
(should (= (current-column) x))
(forward-line))))
+(ert-deftest js-mode-auto-fill ()
+ (with-temp-buffer
+ (js-mode)
+ (setq fill-column 70)
+ (insert "/* ")
+ (dotimes (_ 16)
+ (insert "test "))
+ (do-auto-fill)
+ ;; The bug is that, after auto-fill, the second line starts with
+ ;; "/*", whereas it should start with " * ".
+ (goto-char (point-min))
+ (forward-line)
+ (should (looking-at " \\* test"))))
+
(provide 'js-tests)
;;; js-tests.el ends here
diff --git a/test/lisp/progmodes/python-tests.el
b/test/lisp/progmodes/python-tests.el
index 2df1bbf..1e6b867 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -1156,6 +1156,27 @@ if do:
(python-tests-look-at "that)")
(should (= (current-indentation) 6))))
+(ert-deftest python-indent-electric-colon-4 ()
+ "Test indentation case where there is one more-indented previous open block."
+ (python-tests-with-temp-buffer
+ "
+def f():
+ if True:
+ a = 5
+
+ if True:
+ a = 10
+
+ b = 3
+
+else
+"
+ (python-tests-look-at "else")
+ (goto-char (line-end-position))
+ (python-tests-self-insert ":")
+ (python-tests-look-at "else" -1)
+ (should (= (current-indentation) 4))))
+
(ert-deftest python-indent-region-1 ()
"Test indentation case from Bug#18843."
(let ((contents "
@@ -2457,7 +2478,7 @@ if x:
(python-tests-with-temp-buffer
" \"\n"
(goto-char (point-min))
- (font-lock-fontify-buffer)))
+ (call-interactively 'font-lock-fontify-buffer)))
;;; Shell integration
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 6194cad..f4849c4 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -30,8 +30,9 @@
(insert "(a b")
(save-excursion (insert " c d)"))
,@body
- (cons (buffer-substring (point-min) (point))
- (buffer-substring (point) (point-max)))))
+ (with-no-warnings
+ (cons (buffer-substring (point-min) (point))
+ (buffer-substring (point) (point-max))))))
(defmacro simple-test--transpositions (&rest body)
@@ -266,7 +267,6 @@
(with-temp-buffer
(setq buffer-undo-list nil)
(insert "hello")
- (car buffer-undo-list)
(undo-auto--boundaries 'test))))
;;; Transposition with negative args (bug#20698, bug#21885)
diff --git a/test/lisp/textmodes/css-mode-tests.el
b/test/lisp/textmodes/css-mode-tests.el
index 6eb32ea..5372c37 100644
--- a/test/lisp/textmodes/css-mode-tests.el
+++ b/test/lisp/textmodes/css-mode-tests.el
@@ -218,5 +218,20 @@
(should (member "body" completions))
(should-not (member "article" completions)))))
+(ert-deftest css-mdn-symbol-guessing ()
+ (dolist (item '(("@med" "ia" "@media")
+ ("@keyframes " "{" "@keyframes")
+ ("p::after" "" "::after")
+ ("p:before" "" ":before")
+ ("a:v" "isited" ":visited")
+ ("border-" "color: red" "border-color")
+ ("border-color: red" ";" "border-color")
+ ("border-color: red; color: green" ";" "color")))
+ (with-temp-buffer
+ (css-mode)
+ (insert (nth 0 item))
+ (save-excursion (insert (nth 1 item)))
+ (should (equal (nth 2 item) (css--mdn-find-symbol))))))
+
(provide 'css-mode-tests)
;;; css-mode-tests.el ends here
diff --git a/test/lisp/textmodes/tildify-tests.el
b/test/lisp/textmodes/tildify-tests.el
index 0a82b25..f958fbc 100644
--- a/test/lisp/textmodes/tildify-tests.el
+++ b/test/lisp/textmodes/tildify-tests.el
@@ -226,7 +226,7 @@ The function must terminate as soon as callback returns
nil."
(defun tildify-space-undo-test--test
- (modes nbsp env-open &optional set-space-string)
+ (modes nbsp _env-open &optional set-space-string)
(with-temp-buffer
(setq-local buffer-file-coding-system 'utf-8)
(dolist (mode modes)
diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el
new file mode 100644
index 0000000..807a411
--- /dev/null
+++ b/test/lisp/vc/diff-mode-tests.el
@@ -0,0 +1,203 @@
+;; Copyright (C) 2017 Free Software Foundation, Inc
+
+;; Author: Dima Kogan <address@hidden>
+;; Maintainer: address@hidden
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'diff-mode)
+
+
+(ert-deftest diff-mode-test-ignore-trailing-dashes ()
+ "Check to make sure we successfully ignore trailing -- made by
+'git format-patch'. This is bug #9597"
+
+ ;; I made a test repo, put some files in it, made arbitrary changes
+ ;; and invoked 'git format-patch' to get a patch out of it. The
+ ;; patch and the before and after versions of the files appear here.
+ ;; The test simply tries to apply the patch. The patch contains
+ ;; trailing --, which confused diff-mode previously
+ (let ((patch "From 18ed35640be496647e0a02fc155b4ee4a0490eca Mon Sep 17
00:00:00 2001
+From: Dima Kogan <address@hidden>
+Date: Mon, 30 Jan 2017 22:24:13 -0800
+Subject: [PATCH] test commit
+
+---
+ fil | 3 ---
+ fil2 | 4 ----
+ 2 files changed, 7 deletions(-)
+
+diff --git a/fil b/fil
+index 10344f1..2a56245 100644
+--- a/fil
++++ b/fil
+@@ -2,10 +2,8 @@ Afrocentrism
+ Americanisms
+ Americanization
+ Americanizations
+-Americanized
+ Americanizes
+ Americanizing
+-Andrianampoinimerina
+ Anglicanisms
+ Antananarivo
+ Apalachicola
+@@ -15,6 +13,5 @@ Aristophanes
+ Aristotelian
+ Ashurbanipal
+ Australopithecus
+-Austronesian
+ Bangladeshis
+ Barquisimeto
+diff --git a/fil2 b/fil2
+index 8858f0d..86e8ea5 100644
+--- a/fil2
++++ b/fil2
+@@ -1,20 +1,16 @@
+ whippoorwills
+ whitewashing
+ wholehearted
+-wholeheartedly
+ wholesomeness
+ wildernesses
+ windbreakers
+ wisecracking
+ withstanding
+-woodcarvings
+ woolgathering
+ workstations
+ worthlessness
+ wretchedness
+ wristwatches
+-wrongfulness
+ wrongheadedly
+ wrongheadedness
+-xylophonists
+ youthfulness
+--
+2.11.0
+
+")
+ (fil_before "Afrocentrism
+Americanisms
+Americanization
+Americanizations
+Americanized
+Americanizes
+Americanizing
+Andrianampoinimerina
+Anglicanisms
+Antananarivo
+Apalachicola
+Appalachians
+Argentinians
+Aristophanes
+Aristotelian
+Ashurbanipal
+Australopithecus
+Austronesian
+Bangladeshis
+Barquisimeto
+")
+ (fil_after "Afrocentrism
+Americanisms
+Americanization
+Americanizations
+Americanizes
+Americanizing
+Anglicanisms
+Antananarivo
+Apalachicola
+Appalachians
+Argentinians
+Aristophanes
+Aristotelian
+Ashurbanipal
+Australopithecus
+Bangladeshis
+Barquisimeto
+")
+ (fil2_before "whippoorwills
+whitewashing
+wholehearted
+wholeheartedly
+wholesomeness
+wildernesses
+windbreakers
+wisecracking
+withstanding
+woodcarvings
+woolgathering
+workstations
+worthlessness
+wretchedness
+wristwatches
+wrongfulness
+wrongheadedly
+wrongheadedness
+xylophonists
+youthfulness
+")
+ (fil2_after "whippoorwills
+whitewashing
+wholehearted
+wholesomeness
+wildernesses
+windbreakers
+wisecracking
+withstanding
+woolgathering
+workstations
+worthlessness
+wretchedness
+wristwatches
+wrongheadedly
+wrongheadedness
+youthfulness
+")
+ (temp-dir (make-temp-file "diff-mode-test" 'dir)))
+
+ (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" )))
+ (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2"))))
+ (unwind-protect
+ (progn
+ (with-current-buffer buf (insert fil_before) (save-buffer))
+ (with-current-buffer buf2 (insert fil2_before) (save-buffer))
+
+ (with-temp-buffer
+ (cd temp-dir)
+ (insert patch)
+ (beginning-of-buffer)
+ (diff-apply-hunk)
+ (diff-apply-hunk)
+ (diff-apply-hunk))
+
+ (should (equal (with-current-buffer buf (buffer-string))
+ fil_after))
+ (should (equal (with-current-buffer buf2 (buffer-string))
+ fil2_after)))
+
+ (ignore-errors
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (kill-buffer buf)
+ (with-current-buffer buf2 (set-buffer-modified-p nil))
+ (kill-buffer buf2)
+ (delete-directory temp-dir 'recursive))))))
+
+
+(provide 'diff-mode-tests)
diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el
index 0f2182a..d0da209 100644
--- a/test/lisp/xml-tests.el
+++ b/test/lisp/xml-tests.el
@@ -134,6 +134,21 @@ Parser is called with and without 'symbol-qnames
argument.")
(append xml-default-ns
'(("F" . "FOOBAR:"))))))))))
+;; Test bug #23440 (proper expansion of default namespace)
+; Test data for default namespace
+(defvar xml-parse-test--default-namespace-qnames
+ (cons "<something xmlns=\"myns:\"><whatever></whatever></something>"
+ '((myns:something
+ ((("http://www.w3.org/2000/xmlns/"; . "")
+ . "myns:"))
+ (myns:whatever nil)))))
+
+(ert-deftest xml-parse-test-default-namespace-qnames ()
+ (with-temp-buffer
+ (insert (car xml-parse-test--default-namespace-qnames))
+ (should (equal (cdr xml-parse-test--default-namespace-qnames)
+ (xml-parse-region nil nil nil nil 'symbol-qnames)))))
+
;; Local Variables:
;; no-byte-compile: t
;; End:
diff --git a/test/manual/indent/css-mode.css b/test/manual/indent/css-mode.css
index 3a00739..0845c02 100644
--- a/test/manual/indent/css-mode.css
+++ b/test/manual/indent/css-mode.css
@@ -43,3 +43,30 @@ article:hover
{
color: black;
}
+
+/* bug:13425 */
+div:first-child,
+div:last-child,
+div[disabled],
+div::before {
+ font: 15px "Helvetica Neue",
+ Helvetica,
+ Arial,
+ "Nimbus Sans L",
+ sans-serif;
+ font: 15px "Helvetica Neue", Helvetica, Arial,
+ "Nimbus Sans L", sans-serif;
+ transform: matrix(1.0, 2.0,
+ 3.0, 4.0,
+ 5.0, 6.0);
+ transform: matrix(
+ 1.0, 2.0,
+ 3.0, 4.0,
+ 5.0, 6.0
+ );
+}
address@hidden {
+ src: url("Sans-Regular.eot") format("eot"),
+ url("Sans-Regular.woff") format("woff"),
+ url("Sans-Regular.ttf") format("truetype");
+}
diff --git a/test/manual/indent/scss-mode.scss
b/test/manual/indent/scss-mode.scss
index e1ec90a..f9911ad 100644
--- a/test/manual/indent/scss-mode.scss
+++ b/test/manual/indent/scss-mode.scss
@@ -16,20 +16,20 @@ nav {
}
}
nav ul {
- margin: 0;
- padding: 0;
- list-style: none;
+ margin: 0;
+ padding: 0;
+ list-style: none;
}
nav li {
- display: inline-block;
+ display: inline-block;
}
nav a var
{
- display: block;
- padding: 6px 12px;
- text-decoration: none;
+ display: block;
+ padding: 6px 12px;
+ text-decoration: none;
}
$name: foo;
@@ -67,10 +67,28 @@ button {
// bug:21230
$list: (
- ('a', #000000, #fff)
- ('b', #000000, #fff)
- ('c', #000000, #fff)
- ('d', #000000, #fff)
- ('e', #000000, #fff)
- ('f', #000000, #fff)
+ ('a', #000000, #fff)
+ ('b', #000000, #fff)
+ ('c', #000000, #fff)
+ ('d', #000000, #fff)
+ ('e', #000000, #fff)
+ ('f', #000000, #fff)
);
+
+// bug:13425
+div:first-child,
+div:last-child {
+ @include foo-mixin(
+ $foo: 'foo',
+ $bar: 'bar',
+ );
+
+ font: 15px "Helvetica Neue", Helvetica, Arial,
+ "Nimbus Sans L", sans-serif;
+
+ div:first-child,
+ div:last-child {
+ font: 15px "Helvetica Neue", Helvetica, Arial,
+ "Nimbus Sans L", sans-serif;
+ }
+}
diff --git a/test/manual/scroll-tests.el b/test/manual/scroll-tests.el
new file mode 100644
index 0000000..1167efd
--- /dev/null
+++ b/test/manual/scroll-tests.el
@@ -0,0 +1,130 @@
+;;; scroll-tests.el -- tests for scrolling -*- lexical-binding: t -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; These are mostly automated ert tests, but they don't work in batch
+;; mode which is why they are under test/manual.
+
+;;; Code:
+
+(require 'ert)
+(eval-when-compile (require 'cl-lib))
+
+(defun scroll-tests-up-and-down (margin &optional effective-margin)
+ (unless effective-margin
+ (setq effective-margin margin))
+ (erase-buffer)
+ (insert (mapconcat #'number-to-string
+ (number-sequence 1 200) "\n"))
+ (goto-char 1)
+ (sit-for 0)
+ (let ((scroll-margin margin)
+ (wstart (window-start)))
+ ;; Stopping before `scroll-margin' so we shouldn't have
+ ;; scrolled.
+ (let ((current-prefix-arg (- (window-text-height) 1 effective-margin)))
+ (call-interactively 'next-line))
+ (sit-for 0)
+ (should (= wstart (window-start)))
+ ;; Passing `scroll-margin' should trigger scrolling.
+ (call-interactively 'next-line)
+ (sit-for 0)
+ (should (/= wstart (window-start)))
+ ;; Scroll back to top.
+ (let ((current-prefix-arg (window-start)))
+ (call-interactively 'scroll-down-command))
+ (sit-for 0)
+ (should (= 1 (window-start)))))
+
+(defmacro scroll-tests-with-buffer-window (&rest body)
+ (declare (debug t))
+ `(with-temp-buffer
+ (with-selected-window (display-buffer (current-buffer))
+ ,@body)))
+
+(ert-deftest scroll-tests-scroll-margin-0 ()
+ (skip-unless (not noninteractive))
+ (scroll-tests-with-buffer-window
+ (scroll-tests-up-and-down 0)))
+
+(ert-deftest scroll-tests-scroll-margin-negative ()
+ "A negative `scroll-margin' should be the same as 0."
+ (skip-unless (not noninteractive))
+ (scroll-tests-with-buffer-window
+ (scroll-tests-up-and-down -10 0)))
+
+(ert-deftest scroll-tests-scroll-margin-max ()
+ (skip-unless (not noninteractive))
+ (scroll-tests-with-buffer-window
+ (let ((max-margin (/ (window-text-height) 4)))
+ (scroll-tests-up-and-down max-margin))))
+
+(ert-deftest scroll-tests-scroll-margin-over-max ()
+ "A `scroll-margin' more than max should be the same as max."
+ (skip-unless (not noninteractive))
+ (scroll-tests-with-buffer-window
+ (set-window-text-height nil 7)
+ (let ((max-margin (/ (window-text-height) 4)))
+ (scroll-tests-up-and-down (+ max-margin 1) max-margin)
+ (scroll-tests-up-and-down (+ max-margin 2) max-margin))))
+
+(defun scroll-tests--point-in-middle-of-window-p ()
+ (= (count-lines (window-start) (window-point))
+ (/ (1- (window-text-height)) 2)))
+
+(cl-defun scroll-tests--scroll-margin-whole-window (&key with-line-spacing)
+ "Test `maximum-scroll-margin' at 0.5.
+With a high `scroll-margin', this should keep cursor in the
+middle of the window."
+ (let ((maximum-scroll-margin 0.5)
+ (scroll-margin 100))
+ (scroll-tests-with-buffer-window
+ (setq-local line-spacing with-line-spacing)
+ ;; Choose an odd number, so there is one line in the middle.
+ (set-window-text-height nil 7)
+ ;; `set-window-text-height' doesn't count `line-spacing'.
+ (when with-line-spacing
+ (window-resize nil (* line-spacing 7) nil nil 'pixels))
+ (erase-buffer)
+ (insert (mapconcat #'number-to-string
+ (number-sequence 1 200) "\n"))
+ (goto-char 1)
+ (sit-for 0)
+ (call-interactively 'scroll-up-command)
+ (sit-for 0)
+ (should (scroll-tests--point-in-middle-of-window-p))
+ (call-interactively 'scroll-up-command)
+ (sit-for 0)
+ (should (scroll-tests--point-in-middle-of-window-p))
+ (call-interactively 'scroll-down-command)
+ (sit-for 0)
+ (should (scroll-tests--point-in-middle-of-window-p)))))
+
+(ert-deftest scroll-tests-scroll-margin-whole-window ()
+ (skip-unless (not noninteractive))
+ (scroll-tests--scroll-margin-whole-window))
+
+(ert-deftest scroll-tests-scroll-margin-whole-window-line-spacing ()
+ ;; `line-spacing' has no effect on tty displays.
+ (skip-unless (display-graphic-p))
+ (scroll-tests--scroll-margin-whole-window :with-line-spacing 3))
+
+
+;;; scroll-tests.el ends here
diff --git a/test/src/syntax-tests.el b/test/src/syntax-tests.el
new file mode 100644
index 0000000..6edde0b
--- /dev/null
+++ b/test/src/syntax-tests.el
@@ -0,0 +1,85 @@
+;;; syntax-tests.el --- tests for syntax.c functions -*- lexical-binding: t -*-
+
+;; Copyright (C) 2017 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 <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest parse-partial-sexp-continue-over-comment-marker ()
+ "Continue a parse that stopped in the middle of a comment marker."
+ (with-temp-buffer
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?/ ". 124")
+ (modify-syntax-entry ?* ". 23b")
+ (set-syntax-table table))
+ (insert "/*C*/\nX")
+ (goto-char (point-min))
+ (let* ((pointC (progn (search-forward "C") (1- (point))))
+ (preC (1- pointC))
+ (pointX (progn (search-forward "X") (1- (point))))
+ (aftC (+ 2 pointC))
+ (ppsC (parse-partial-sexp (point-min) pointC))
+ (pps-preC (parse-partial-sexp (point-min) preC))
+ (pps-aftC (parse-partial-sexp (point-min) aftC))
+ (ppsX (parse-partial-sexp (point-min) pointX)))
+ ;; C should be inside comment.
+ (should (= (nth 0 ppsC) 0))
+ (should (eq (nth 4 ppsC) t))
+ (should (= (nth 8 ppsC) (- pointC 2)))
+ ;; X should not be in comment or list.
+ (should (= (nth 0 ppsX) 0))
+ (should-not (nth 4 ppsX))
+ ;; Try using OLDSTATE.
+ (should (equal (parse-partial-sexp preC pointC nil nil pps-preC)
+ ppsC))
+ (should (equal (parse-partial-sexp pointC aftC nil nil ppsC)
+ pps-aftC))
+ (should (equal (parse-partial-sexp preC aftC nil nil pps-preC)
+ pps-aftC))
+ (should (equal (parse-partial-sexp aftC pointX nil nil pps-aftC)
+ ppsX)))))
+
+(ert-deftest parse-partial-sexp-paren-comments ()
+ "Test syntax parsing with paren comment markers.
+Specifically, where the first character of the comment marker is
+also has open paren syntax (see Bug#24870)."
+ (with-temp-buffer
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?\{ "(}1nb" table)
+ (modify-syntax-entry ?\} "){4nb" table)
+ (modify-syntax-entry ?- ". 123" table)
+ (set-syntax-table table))
+ (insert "{-C-}\nX")
+ (goto-char (point-min))
+ (let* ((pointC (progn (search-forward "C") (1- (point))))
+ (pointX (progn (search-forward "X") (1- (point))))
+ (ppsC (parse-partial-sexp (point-min) pointC))
+ (ppsX (parse-partial-sexp (point-min) pointX)))
+ ;; C should be inside nestable comment, not list.
+ (should (= (nth 0 ppsC) 0))
+ (should (= (nth 4 ppsC) 1))
+ (should (= (nth 8 ppsC) (- pointC 2)))
+ ;; X should not be in comment or list.
+ (should (= (nth 0 ppsX) 0))
+ (should-not (nth 4 ppsX))
+ ;; Try using OLDSTATE.
+ (should (equal (parse-partial-sexp pointC pointX nil nil ppsC)
+ ppsX)))))
+
+;;; syntax-tests.el ends here