aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorVibhav Pant2017-02-05 23:08:53 +0530
committerVibhav Pant2017-02-05 23:08:53 +0530
commitad70ca1dad26da79f0a95cc0ec687902ef20fa9b (patch)
tree732e8e9ace1fdd7aaf982f0fa5ac6c8e4eb5f7c7
parent2db473bda8be72cf3c1e4694d70ce48f60492b0e (diff)
parent148100d98319499f0ac6f57b8be08cbd14884a5c (diff)
downloademacs-ad70ca1dad26da79f0a95cc0ec687902ef20fa9b.tar.gz
emacs-ad70ca1dad26da79f0a95cc0ec687902ef20fa9b.zip
Merge remote-tracking branch 'origin/master' into feature/byte-switch
-rw-r--r--admin/notes/multi-tty5
-rw-r--r--doc/emacs/display.texi12
-rw-r--r--doc/emacs/files.texi6
-rw-r--r--doc/emacs/search.texi20
-rw-r--r--doc/lispintro/emacs-lisp-intro.texi8
-rw-r--r--doc/lispref/edebug.texi10
-rw-r--r--doc/lispref/files.texi26
-rw-r--r--doc/lispref/windows.texi15
-rw-r--r--doc/misc/cc-mode.texi31
-rw-r--r--doc/misc/texinfo.tex33
-rw-r--r--etc/NEWS36
-rw-r--r--lib/c-ctype.h20
-rw-r--r--lib/strftime.c12
-rw-r--r--lib/time-internal.h4
-rw-r--r--lib/verify.h7
-rw-r--r--lisp/auth-source.el2
-rw-r--r--lisp/buff-menu.el19
-rw-r--r--lisp/calendar/parse-time.el12
-rw-r--r--lisp/cus-start.el1
-rw-r--r--lisp/dired.el4
-rw-r--r--lisp/doc-view.el5
-rw-r--r--lisp/emacs-lisp/edebug.el13
-rw-r--r--lisp/emacs-lisp/ert-x.el26
-rw-r--r--lisp/emacs-lisp/let-alist.el2
-rw-r--r--lisp/emacs-lisp/pcase.el3
-rw-r--r--lisp/emacs-lisp/subr-x.el41
-rw-r--r--lisp/emulation/edt-mapper.el525
-rw-r--r--lisp/emulation/edt.el8
-rw-r--r--lisp/files.el15
-rw-r--r--lisp/gnus/gnus-art.el7
-rw-r--r--lisp/ibuffer.el15
-rw-r--r--lisp/image-dired.el8
-rw-r--r--lisp/indent.el32
-rw-r--r--lisp/info.el11
-rw-r--r--lisp/mh-e/mh-compat.el10
-rw-r--r--lisp/net/tramp.el30
-rw-r--r--lisp/progmodes/cc-align.el12
-rw-r--r--lisp/progmodes/cc-engine.el101
-rw-r--r--lisp/progmodes/cc-styles.el1
-rw-r--r--lisp/progmodes/cc-vars.el2
-rw-r--r--lisp/progmodes/js.el1
-rw-r--r--lisp/progmodes/xref.el6
-rw-r--r--lisp/replace.el115
-rw-r--r--lisp/subr.el2
-rw-r--r--lisp/textmodes/css-mode.el156
-rw-r--r--lisp/vc/diff-mode.el184
-rw-r--r--src/alloc.c215
-rw-r--r--src/bytecode.c20
-rw-r--r--src/callproc.c18
-rw-r--r--src/dired.c3
-rw-r--r--src/dispextern.h1
-rw-r--r--src/doc.c9
-rw-r--r--src/editfns.c10
-rw-r--r--src/emacs.c2
-rw-r--r--src/eval.c15
-rw-r--r--src/fileio.c74
-rw-r--r--src/filelock.c7
-rw-r--r--src/fns.c96
-rw-r--r--src/indent.c13
-rw-r--r--src/keyboard.c93
-rw-r--r--src/lisp.h47
-rw-r--r--src/lread.c2
-rw-r--r--src/process.c10
-rw-r--r--src/regex.c10
-rw-r--r--src/search.c98
-rw-r--r--src/syntax.c140
-rw-r--r--src/sysdep.c129
-rw-r--r--src/w32fns.c11
-rw-r--r--src/window.c55
-rw-r--r--src/window.h2
-rw-r--r--src/xdisp.c104
-rw-r--r--test/lisp/autorevert-tests.el170
-rw-r--r--test/lisp/emacs-lisp/testcover-resources/testcases.el493
-rw-r--r--test/lisp/emacs-lisp/testcover-tests.el186
-rw-r--r--test/lisp/filenotify-tests.el56
-rw-r--r--test/lisp/kmacro-tests.el890
-rw-r--r--test/lisp/progmodes/js-tests.el14
-rw-r--r--test/lisp/textmodes/css-mode-tests.el15
-rw-r--r--test/lisp/vc/diff-mode-tests.el203
-rw-r--r--test/manual/indent/css-mode.css27
-rw-r--r--test/manual/indent/scss-mode.scss44
-rw-r--r--test/manual/scroll-tests.el130
82 files changed, 3655 insertions, 1371 deletions
diff --git a/admin/notes/multi-tty b/admin/notes/multi-tty
index b58180e6fab..d0096adc6d2 100644
--- a/admin/notes/multi-tty
+++ b/admin/notes/multi-tty
@@ -1239,9 +1239,8 @@ DIARY OF CHANGES
1239 (Update: OK, it all seems so easy now (NOT). Input could be done 1239 (Update: OK, it all seems so easy now (NOT). Input could be done
1240 synchronously (with wait_reading_process_input), or asynchronously 1240 synchronously (with wait_reading_process_input), or asynchronously
1241 by SIGIO or polling (SIGALRM). C-g either sets the Vquit_flag, 1241 by SIGIO or polling (SIGALRM). C-g either sets the Vquit_flag,
1242 signals a 'quit condition (when immediate_quit), or throws to 1242 signals a 'quit condition, or throws to 'getcjmp' when Emacs was
1243 'getcjmp' when Emacs was waiting for input when the C-g event 1243 waiting for input when the C-g event arrived.)
1244 arrived.)
1245 1244
1246-- Replace wrong_kboard_jmpbuf with a special return value of 1245-- Replace wrong_kboard_jmpbuf with a special return value of
1247 read_char. It is absurd that we use setjmp/longjmp just to return 1246 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 c6e990d9082..15c700892bc 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -285,13 +285,17 @@ multiple variables, the order of priority is:
285@code{scroll-up-aggressively} / @code{scroll-down-aggressively}. 285@code{scroll-up-aggressively} / @code{scroll-down-aggressively}.
286 286
287@vindex scroll-margin 287@vindex scroll-margin
288@vindex maximum-scroll-margin
288 The variable @code{scroll-margin} restricts how close point can come 289 The variable @code{scroll-margin} restricts how close point can come
289to the top or bottom of a window (even if aggressive scrolling 290to the top or bottom of a window (even if aggressive scrolling
290specifies a fraction @var{f} that is larger than the window portion 291specifies a fraction @var{f} that is larger than the window portion
291between the top and the bottom margins). Its value is a number of screen 292between the top and the bottom margins). Its value is a number of
292lines; if point comes within that many lines of the top or bottom of 293screen lines; if point comes within that many lines of the top or
293the window, Emacs performs automatic scrolling. By default, 294bottom of the window, Emacs performs automatic scrolling. By default,
294@code{scroll-margin} is 0. 295@code{scroll-margin} is 0. The effective margin size is limited to a
296quarter of the window height by default, but this limit can be
297increased up to half (or decreased down to zero) by customizing
298@code{maximum-scroll-margin}.
295 299
296@node Horizontal Scrolling 300@node Horizontal Scrolling
297@section Horizontal Scrolling 301@section Horizontal Scrolling
diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index 5c582e571e2..2b09c69945c 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -417,6 +417,12 @@ changes you would be saving. This calls the command
417Display a help message about these options. 417Display a help message about these options.
418@end table 418@end table
419 419
420@noindent
421@vindex save-some-buffers-default-predicate
422You can customize the value of
423@code{save-some-buffers-default-predicate} to control which buffers
424Emacs will ask about.
425
420 @kbd{C-x C-c}, the key sequence to exit Emacs, invokes 426 @kbd{C-x C-c}, the key sequence to exit Emacs, invokes
421@code{save-some-buffers} and therefore asks the same questions. 427@code{save-some-buffers} and therefore asks the same questions.
422 428
diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi
index b7282589735..fa69ba48f6a 100644
--- a/doc/emacs/search.texi
+++ b/doc/emacs/search.texi
@@ -1670,8 +1670,9 @@ replacing regexp matches in file names.
1670 Here are some other commands that find matches for a regular 1670 Here are some other commands that find matches for a regular
1671expression. They all ignore case in matching, if the pattern contains 1671expression. They all ignore case in matching, if the pattern contains
1672no upper-case letters and @code{case-fold-search} is non-@code{nil}. 1672no upper-case letters and @code{case-fold-search} is non-@code{nil}.
1673Aside from @code{occur} and its variants, all operate on the text from 1673Aside from @code{multi-occur} and @code{multi-occur-in-matching-buffers},
1674point to the end of the buffer, or on the region if it is active. 1674which always search the whole buffer, all operate on the text from point
1675to the end of the buffer, or on the region if it is active.
1675 1676
1676@findex list-matching-lines 1677@findex list-matching-lines
1677@findex occur 1678@findex occur
@@ -1714,6 +1715,8 @@ a multi-file incremental search is activated automatically.
1714@cindex mode, Occur 1715@cindex mode, Occur
1715@cindex match (face name) 1716@cindex match (face name)
1716@vindex list-matching-lines-default-context-lines 1717@vindex list-matching-lines-default-context-lines
1718@vindex list-matching-lines-jump-to-current-line
1719@cindex list-matching-lines-current-line-face (face name)
1717@kindex M-s o 1720@kindex M-s o
1718@item M-x occur 1721@item M-x occur
1719@itemx M-s o 1722@itemx M-s o
@@ -1721,11 +1724,14 @@ Prompt for a regexp, and display a list showing each line in the
1721buffer that contains a match for it. If you type @kbd{M-n} at the 1724buffer that contains a match for it. If you type @kbd{M-n} at the
1722prompt, you can reuse search strings from previous incremental 1725prompt, you can reuse search strings from previous incremental
1723searches. The text that matched is highlighted using the @code{match} 1726searches. The text that matched is highlighted using the @code{match}
1724face. To limit the search to part of the buffer, narrow to that part 1727face. A numeric argument @var{n} specifies that @var{n} lines of
1725(@pxref{Narrowing}). A numeric argument @var{n} specifies that 1728context are to be displayed before and after each matching line.
1726@var{n} lines of context are to be displayed before and after each 1729The default number of context lines is specified by the variable
1727matching line. The default number of context lines is specified by 1730@code{list-matching-lines-default-context-lines}.
1728the variable @code{list-matching-lines-default-context-lines}. 1731When @code{list-matching-lines-jump-to-current-line} is non-nil,
1732the current line is shown highlighted with face
1733@code{list-matching-lines-current-line-face} and the point is set
1734at the first match after such line.
1729 1735
1730You can also run @kbd{M-s o} when an incremental search is active; 1736You can also run @kbd{M-s o} when an incremental search is active;
1731this uses the current search string. 1737this uses the current search string.
diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi
index 830c072cf5e..36d767737df 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:
17151 17151
17152@findex occur 17152@findex occur
17153The @code{occur} command shows all the lines in the current buffer 17153The @code{occur} command shows all the lines in the current buffer
17154that contain a match for a regular expression. Matching lines are 17154that contain a match for a regular expression. When the region is
17155shown in a buffer called @file{*Occur*}. That buffer serves as a menu 17155active, @code{occur} restricts matches to such region. Otherwise it
17156to jump to occurrences. 17156uses the entire buffer.
17157Matching lines are shown in a buffer called @file{*Occur*}.
17158That buffer serves as a menu to jump to occurrences.
17157 17159
17158@findex global-unset-key 17160@findex global-unset-key
17159@cindex Unbinding key 17161@cindex Unbinding key
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index f6f73ea8947..da72c9b700c 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -979,9 +979,13 @@ program.
979 979
980@itemize @bullet 980@itemize @bullet
981@item 981@item
982@code{max-lisp-eval-depth} and @code{max-specpdl-size} are both 982@vindex edebug-max-depth
983increased to reduce Edebug's impact on the stack. You could, however, 983@code{max-lisp-eval-depth} (@pxref{Eval}) and @code{max-specpdl-size}
984still run out of stack space when using Edebug. 984(@pxref{Local Variables}) are both increased to reduce Edebug's impact
985on the stack. You could, however, still run out of stack space when
986using Edebug. You can also enlarge the value of
987@code{edebug-max-depth} if Edebug reaches the limit of recursion depth
988instrumenting code that contains very large quoted lists.
985 989
986@item 990@item
987The state of keyboard macro execution is saved and restored. While 991The state of keyboard macro execution is saved and restored. While
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index 853e84477e2..ef373211415 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
368non-@code{nil}, it saves all the file-visiting buffers without querying 368non-@code{nil}, it saves all the file-visiting buffers without querying
369the user. 369the user.
370 370
371The optional @var{pred} argument controls which buffers to ask about 371@vindex save-some-buffers-default-predicate
372(or to save silently if @var{save-silently-p} is non-@code{nil}). 372The optional @var{pred} argument provides a predicate that controls
373If it is @code{nil}, that means to ask only about file-visiting buffers. 373which buffers to ask about (or to save silently if
374If it is @code{t}, that means also offer to save certain other non-file 374@var{save-silently-p} is non-@code{nil}). If @var{pred} is
375buffers---those that have a non-@code{nil} buffer-local value of 375@code{nil}, that means to use the value of
376@code{buffer-offer-save} (@pxref{Killing Buffers}). A user who says 376@code{save-some-buffers-default-predicate} instead of @var{pred}. If
377@samp{yes} to saving a non-file buffer is asked to specify the file 377the result is @code{nil}, it means ask only about file-visiting
378name to use. The @code{save-buffers-kill-emacs} function passes the 378buffers. If it is @code{t}, that means also offer to save certain
379value @code{t} for @var{pred}. 379other non-file buffers---those that have a non-@code{nil} buffer-local
380 380value of @code{buffer-offer-save} (@pxref{Killing Buffers}). A user
381If @var{pred} is neither @code{t} nor @code{nil}, then it should be 381who says @samp{yes} to saving a non-file buffer is asked to specify
382the file name to use. The @code{save-buffers-kill-emacs} function
383passes the value @code{t} for @var{pred}.
384
385If the predicate is neither @code{t} nor @code{nil}, then it should be
382a function of no arguments. It will be called in each buffer to decide 386a function of no arguments. It will be called in each buffer to decide
383whether to offer to save that buffer. If it returns a non-@code{nil} 387whether to offer to save that buffer. If it returns a non-@code{nil}
384value in a certain buffer, that means do offer to save that buffer. 388value in a certain buffer, that means do offer to save that buffer.
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index 6f3de0c8a0e..affa28c9202 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
3924out of the margin, closer to the center of the window. 3924out of the margin, closer to the center of the window.
3925@end defopt 3925@end defopt
3926 3926
3927@defopt maximum-scroll-margin
3928This variable limits the effective value of @code{scroll-margin} to a
3929fraction of the current window line height. For example, if the
3930current window has 20 lines and @code{maximum-scroll-margin} is 0.1,
3931then the scroll margins will never be larger than 2 lines, no matter
3932how big @code{scroll-margin} is.
3933
3934@code{maximum-scroll-margin} itself has a maximum value of 0.5, which
3935allows setting margins large to keep the cursor at the middle line of
3936the window (or two middle lines if the window has an even number of
3937lines). If it's set to a larger value (or any value other than a
3938float between 0.0 and 0.5) then the default value of 0.25 will be used
3939instead.
3940@end defopt
3941
3927@defopt scroll-conservatively 3942@defopt scroll-conservatively
3928This variable controls how scrolling is done automatically when point 3943This variable controls how scrolling is done automatically when point
3929moves off the screen (or into the scroll margin). If the value is a 3944moves 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 68a16c0ed74..14981c9c58b 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}.
4141@item brace-list-close 4141@item brace-list-close
4142Close brace of an enum or static array list. @ref{Brace List Symbols}. 4142Close brace of an enum or static array list. @ref{Brace List Symbols}.
4143@item brace-list-intro 4143@item brace-list-intro
4144First line in an enum or static array list. @ref{Brace List Symbols}. 4144First line after the opening @samp{@{} in an enum or static array
4145list. @ref{Brace List Symbols}.
4145@item brace-list-entry 4146@item brace-list-entry
4146Subsequent lines in an enum or static array list. @ref{Brace List 4147Subsequent lines in an enum or static array list. @ref{Brace List
4147Symbols}. 4148Symbols}.
@@ -4635,11 +4636,18 @@ example:
4635 4636
4636Here, you've already seen the analysis of lines 1, 2, 3, and 11. On 4637Here, you've already seen the analysis of lines 1, 2, 3, and 11. On
4637line 4, things get interesting; this line is assigned 4638line 4, things get interesting; this line is assigned
4638@code{brace-entry-open} syntactic symbol because it's a bracelist entry 4639@code{brace-entry-open} syntactic symbol because it's a bracelist
4639line that starts with an open brace. Lines 5 and 6 (and line 9) are 4640entry line that starts with an open brace. Lines 5 and 6 are pretty
4640pretty standard, and line 7 is a @code{brace-list-close} as you'd 4641standard, and line 7 is a @code{brace-list-close} as you'd expect.
4641expect. Once again, line 8 is assigned as @code{brace-entry-open} as is 4642Once again, line 8 is assigned as @code{brace-entry-open} as is line
4642line 10. 464310. Line 9 is assigned two syntactic elements, @code{brace-list-intro}
4644with anchor point at the @samp{@{} of line 8@footnote{This extra
4645syntactic element was introduced in @ccmode{} 5.33.1 to allow extra
4646flexibility in indenting the second line of such a construct. You can
4647preserve the behaviour resulting from the former syntactic analysis by
4648giving @code{brace-list-entry} an offset of
4649@code{c-lineup-under-anchor} (@pxref{Misc Line-Up}).}, and
4650@code{brace-list-entry} anchored on the @samp{1} of line 8.
4643 4651
4644@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4652@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4645@node External Scope Symbols, Paren List Symbols, Brace List Symbols, Syntactic Symbols 4653@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.
6288 6296
6289@comment ------------------------------------------------------------ 6297@comment ------------------------------------------------------------
6290 6298
6299@defun c-lineup-under-anchor
6300
6301Line up a line directly underneath its anchor point. This is like
6302@samp{0}, except any previously calculated offset contributions are
6303disregarded.
6304
6305@workswith Any syntactic symbol which has an anchor point.
6306@end defun
6307
6308@comment ------------------------------------------------------------
6309
6291@defun c-lineup-cpp-define 6310@defun c-lineup-cpp-define
6292@findex lineup-cpp-define (c-) 6311@findex lineup-cpp-define (c-)
6293Line up macro continuation lines according to the indentation of the 6312Line up macro continuation lines according to the indentation of the
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex
index c8913ab918e..338bcf65040 100644
--- a/doc/misc/texinfo.tex
+++ b/doc/misc/texinfo.tex
@@ -3,7 +3,7 @@
3% Load plain if necessary, i.e., if running under initex. 3% Load plain if necessary, i.e., if running under initex.
4\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi 4\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
5% 5%
6\def\texinfoversion{2016-09-18.18} 6\def\texinfoversion{2017-01-14.15}
7% 7%
8% Copyright 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995, 8% Copyright 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995,
9% 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 9% 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
@@ -165,6 +165,9 @@
165% Give the space character the catcode for a space. 165% Give the space character the catcode for a space.
166\def\spaceisspace{\catcode`\ =10\relax} 166\def\spaceisspace{\catcode`\ =10\relax}
167 167
168% Likewise for ^^M, the end of line character.
169\def\endlineisspace{\catcode13=10\relax}
170
168\chardef\dashChar = `\- 171\chardef\dashChar = `\-
169\chardef\slashChar = `\/ 172\chardef\slashChar = `\/
170\chardef\underChar = `\_ 173\chardef\underChar = `\_
@@ -950,21 +953,14 @@ where each line of input produces a line of output.}
950% @comment ...line which is ignored... 953% @comment ...line which is ignored...
951% @c is the same as @comment 954% @c is the same as @comment
952% @ignore ... @end ignore is another way to write a comment 955% @ignore ... @end ignore is another way to write a comment
953%
954\def\comment{\begingroup \catcode`\^^M=\active%
955\catcode`\@=\other \catcode`\{=\other \catcode`\}=\other\commentxxx}%
956 956
957{\catcode`\^^M=\active%
958\gdef\commentxxx#1^^M{\endgroup%
959\futurelet\nexttoken\commentxxxx}%
960\gdef\commentxxxx{\ifx\nexttoken\aftermacro\expandafter\comment\fi}%
961}
962 957
963\def\c{\begingroup \catcode`\^^M=\active% 958\def\c{\begingroup \catcode`\^^M=\active%
964\catcode`\@=\other \catcode`\{=\other \catcode`\}=\other% 959\catcode`\@=\other \catcode`\{=\other \catcode`\}=\other%
965\cxxx} 960\cxxx}
966{\catcode`\^^M=\active \gdef\cxxx#1^^M{\endgroup}} 961{\catcode`\^^M=\active \gdef\cxxx#1^^M{\endgroup}}
967% See comment in \scanmacro about why the definitions of @c and @comment differ 962%
963\let\comment\c
968 964
969% @paragraphindent NCHARS 965% @paragraphindent NCHARS
970% We'll use ems for NCHARS, close enough. 966% We'll use ems for NCHARS, close enough.
@@ -8031,9 +8027,6 @@ end
8031 } 8027 }
8032\fi 8028\fi
8033 8029
8034\let\aftermacroxxx\relax
8035\def\aftermacro{\aftermacroxxx}
8036
8037% alias because \c means cedilla in @tex or @math 8030% alias because \c means cedilla in @tex or @math
8038\let\texinfoc=\c 8031\let\texinfoc=\c
8039 8032
@@ -8055,18 +8048,13 @@ end
8055 \catcode`\\=\active 8048 \catcode`\\=\active
8056 % 8049 %
8057 % Process the macro body under the current catcode regime. 8050 % Process the macro body under the current catcode regime.
8058 \scantokens{#1@texinfoc}\aftermacro% 8051 \scantokens{#1@texinfoc}%
8059 % 8052 %
8060 \catcode`\@=\savedcatcodeone 8053 \catcode`\@=\savedcatcodeone
8061 \catcode`\\=\savedcatcodetwo 8054 \catcode`\\=\savedcatcodetwo
8062 % 8055 %
8063 % The \texinfoc is to remove the \newlinechar added by \scantokens, and 8056 % The \texinfoc is to remove the \newlinechar added by \scantokens, and
8064 % can be noticed by \parsearg. 8057 % can be noticed by \parsearg.
8065 % The \aftermacro allows a \comment at the end of the macro definition
8066 % to duplicate itself past the final \newlinechar added by \scantokens:
8067 % this is used in the definition of \group to comment out a newline. We
8068 % don't do the same for \c to support Texinfo files with macros that ended
8069 % with a @c, which should no longer be necessary.
8070 % We avoid surrounding the call to \scantokens with \bgroup and \egroup 8058 % We avoid surrounding the call to \scantokens with \bgroup and \egroup
8071 % to allow macros to open or close groups themselves. 8059 % to allow macros to open or close groups themselves.
8072} 8060}
@@ -8538,6 +8526,13 @@ end
8538 \ifcase\paramno 8526 \ifcase\paramno
8539 % 0 8527 % 0
8540 \expandafter\xdef\csname\the\macname\endcsname{% 8528 \expandafter\xdef\csname\the\macname\endcsname{%
8529 \bgroup
8530 \noexpand\spaceisspace
8531 \noexpand\endlineisspace
8532 \noexpand\expandafter % skip any whitespace after the macro name.
8533 \expandafter\noexpand\csname\the\macname @@@\endcsname}%
8534 \expandafter\xdef\csname\the\macname @@@\endcsname{%
8535 \egroup
8541 \noexpand\scanmacro{\macrobody}}% 8536 \noexpand\scanmacro{\macrobody}}%
8542 \or % 1 8537 \or % 1
8543 \expandafter\xdef\csname\the\macname\endcsname{% 8538 \expandafter\xdef\csname\the\macname\endcsname{%
diff --git a/etc/NEWS b/etc/NEWS
index 12ff21f39ae..cbf2b70c821 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -307,10 +307,23 @@ local part of a remote file name. Thus, if you have a directory named
307"/~" on the remote host "foo", you can prevent it from being 307"/~" on the remote host "foo", you can prevent it from being
308substituted by a home directory by writing it as "/foo:/:/~/file". 308substituted by a home directory by writing it as "/foo:/:/~/file".
309 309
310+++
311** The new variable 'maximum-scroll-margin' allows having effective
312settings of 'scroll-margin' up to half the window size, instead of
313always restricting the margin to a quarter of the window.
314
310 315
311* Editing Changes in Emacs 26.1 316* Editing Changes in Emacs 26.1
312 317
313+++ 318+++
319** Two new user options 'list-matching-lines-jump-to-current-line' and
320'list-matching-lines-current-line-face' to show highlighted the current
321line in *Occur* buffer.
322
323+++
324** The 'occur' command can now operate on the region.
325
326+++
314** New bindings for 'query-replace-map'. 327** New bindings for 'query-replace-map'.
315'undo', undo the last replacement; bound to 'u'. 328'undo', undo the last replacement; bound to 'u'.
316'undo-all', undo all replacements; bound to 'U'. 329'undo-all', undo all replacements; bound to 'U'.
@@ -451,6 +464,11 @@ viewing HTML files and the like.
451breakpoint (e.g. with "f" and "o") by customizing the new option 464breakpoint (e.g. with "f" and "o") by customizing the new option
452'edebug-sit-on-break'. 465'edebug-sit-on-break'.
453 466
467+++
468*** New customizable option 'edebug-max-depth'
469This allows to enlarge the maximum recursion depth when instrumenting
470code.
471
454** Eshell 472** Eshell
455 473
456*** 'eshell-input-filter's value is now a named function 474*** 'eshell-input-filter's value is now a named function
@@ -613,6 +631,13 @@ HTML tags, classes and IDs using the 'completion-at-point' command.
613Completion candidates for HTML classes and IDs are retrieved from open 631Completion candidates for HTML classes and IDs are retrieved from open
614HTML mode buffers. 632HTML mode buffers.
615 633
634---
635*** CSS mode now binds 'C-h S' to a function that will show
636information about a CSS construct (an at-rule, property, pseudo-class,
637pseudo-element, with the default being guessed from context). By
638default the information is looked up on the Mozilla Developer Network,
639but this can be customized using 'css-lookup-url-format'.
640
616+++ 641+++
617** Emacs now supports character name escape sequences in character and 642** Emacs now supports character name escape sequences in character and
618string literals. The syntax variants \N{character name} and 643string literals. The syntax variants \N{character name} and
@@ -738,6 +763,13 @@ instead.
738 763
739* Lisp Changes in Emacs 26.1 764* Lisp Changes in Emacs 26.1
740 765
766+++
767** 'save-some-buffers' now uses 'save-some-buffers-default-predicate'
768to decide which buffers to ask about, if the PRED argument is nil.
769The default value of 'save-some-buffers-default-predicate' is nil,
770which means ask about all file-visiting buffers.
771
772** string-(to|as|make)-(uni|multi)byte are now declared obsolete.
741** New variable 'while-no-input-ignore-events' which allow 773** New variable 'while-no-input-ignore-events' which allow
742setting which special events 'while-no-input' should ignore. 774setting which special events 'while-no-input' should ignore.
743It is a list of symbols. 775It is a list of symbols.
@@ -864,6 +896,10 @@ collection).
864+++ 896+++
865** 'car' and 'cdr' compositions 'cXXXr' and 'cXXXXr' are now part of Elisp. 897** 'car' and 'cdr' compositions 'cXXXr' and 'cXXXXr' are now part of Elisp.
866 898
899---
900** 'if-let*', 'when-let*', and 'and-let*' are new in subr-x.el.
901The incumbent 'if-let' and 'when-let' are now aliases.
902
867+++ 903+++
868** The new functions 'make-nearby-temp-file' and 'temporary-file-directory' 904** The new functions 'make-nearby-temp-file' and 'temporary-file-directory'
869can be used for creation of temporary files of remote or mounted directories. 905can 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 faf21581ca0..bcdba6b9962 100644
--- a/lib/c-ctype.h
+++ b/lib/c-ctype.h
@@ -115,16 +115,16 @@ extern "C" {
115 115
116/* Cases for lowercase hex letters, and lowercase letters, all offset by N. */ 116/* Cases for lowercase hex letters, and lowercase letters, all offset by N. */
117 117
118#define _C_CTYPE_LOWER_A_THRU_F_N(n) \ 118#define _C_CTYPE_LOWER_A_THRU_F_N(N) \
119 case 'a' + (n): case 'b' + (n): case 'c' + (n): case 'd' + (n): \ 119 case 'a' + (N): case 'b' + (N): case 'c' + (N): case 'd' + (N): \
120 case 'e' + (n): case 'f' + (n) 120 case 'e' + (N): case 'f' + (N)
121#define _C_CTYPE_LOWER_N(n) \ 121#define _C_CTYPE_LOWER_N(N) \
122 _C_CTYPE_LOWER_A_THRU_F_N(n): \ 122 _C_CTYPE_LOWER_A_THRU_F_N(N): \
123 case 'g' + (n): case 'h' + (n): case 'i' + (n): case 'j' + (n): \ 123 case 'g' + (N): case 'h' + (N): case 'i' + (N): case 'j' + (N): \
124 case 'k' + (n): case 'l' + (n): case 'm' + (n): case 'n' + (n): \ 124 case 'k' + (N): case 'l' + (N): case 'm' + (N): case 'n' + (N): \
125 case 'o' + (n): case 'p' + (n): case 'q' + (n): case 'r' + (n): \ 125 case 'o' + (N): case 'p' + (N): case 'q' + (N): case 'r' + (N): \
126 case 's' + (n): case 't' + (n): case 'u' + (n): case 'v' + (n): \ 126 case 's' + (N): case 't' + (N): case 'u' + (N): case 'v' + (N): \
127 case 'w' + (n): case 'x' + (n): case 'y' + (n): case 'z' + (n) 127 case 'w' + (N): case 'x' + (N): case 'y' + (N): case 'z' + (N)
128 128
129/* Cases for hex letters, digits, lower, punct, and upper. */ 129/* Cases for hex letters, digits, lower, punct, and upper. */
130 130
diff --git a/lib/strftime.c b/lib/strftime.c
index 9aabcc6748c..e4d78ef7011 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)
739 /* The mask is not what you might think. 739 /* The mask is not what you might think.
740 When the ordinal i'th bit is set, insert a colon 740 When the ordinal i'th bit is set, insert a colon
741 before the i'th digit of the time zone representation. */ 741 before the i'th digit of the time zone representation. */
742#define DO_TZ_OFFSET(d, negative, mask, v) \ 742#define DO_TZ_OFFSET(d, mask, v) \
743 do \ 743 do \
744 { \ 744 { \
745 digits = d; \ 745 digits = d; \
746 negative_number = negative; \
747 tz_colon_mask = mask; \ 746 tz_colon_mask = mask; \
748 u_number_value = v; \ 747 u_number_value = v; \
749 goto do_tz_offset; \ 748 goto do_tz_offset; \
@@ -1444,6 +1443,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
1444 } 1443 }
1445#endif 1444#endif
1446 1445
1446 negative_number = diff < 0 || (diff == 0 && *zone == '-');
1447 hour_diff = diff / 60 / 60; 1447 hour_diff = diff / 60 / 60;
1448 min_diff = diff / 60 % 60; 1448 min_diff = diff / 60 % 60;
1449 sec_diff = diff % 60; 1449 sec_diff = diff % 60;
@@ -1451,13 +1451,13 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
1451 switch (colons) 1451 switch (colons)
1452 { 1452 {
1453 case 0: /* +hhmm */ 1453 case 0: /* +hhmm */
1454 DO_TZ_OFFSET (5, diff < 0, 0, hour_diff * 100 + min_diff); 1454 DO_TZ_OFFSET (5, 0, hour_diff * 100 + min_diff);
1455 1455
1456 case 1: tz_hh_mm: /* +hh:mm */ 1456 case 1: tz_hh_mm: /* +hh:mm */
1457 DO_TZ_OFFSET (6, diff < 0, 04, hour_diff * 100 + min_diff); 1457 DO_TZ_OFFSET (6, 04, hour_diff * 100 + min_diff);
1458 1458
1459 case 2: tz_hh_mm_ss: /* +hh:mm:ss */ 1459 case 2: tz_hh_mm_ss: /* +hh:mm:ss */
1460 DO_TZ_OFFSET (9, diff < 0, 024, 1460 DO_TZ_OFFSET (9, 024,
1461 hour_diff * 10000 + min_diff * 100 + sec_diff); 1461 hour_diff * 10000 + min_diff * 100 + sec_diff);
1462 1462
1463 case 3: /* +hh if possible, else +hh:mm, else +hh:mm:ss */ 1463 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)
1465 goto tz_hh_mm_ss; 1465 goto tz_hh_mm_ss;
1466 if (min_diff != 0) 1466 if (min_diff != 0)
1467 goto tz_hh_mm; 1467 goto tz_hh_mm;
1468 DO_TZ_OFFSET (3, diff < 0, 0, hour_diff); 1468 DO_TZ_OFFSET (3, 0, hour_diff);
1469 1469
1470 default: 1470 default:
1471 goto bad_format; 1471 goto bad_format;
diff --git a/lib/time-internal.h b/lib/time-internal.h
index 79cb5621991..bf22834b2e1 100644
--- a/lib/time-internal.h
+++ b/lib/time-internal.h
@@ -38,8 +38,8 @@ struct tm_zone
38 /* A sequence of null-terminated strings packed next to each other. 38 /* A sequence of null-terminated strings packed next to each other.
39 The strings are followed by an extra null byte. If TZ_IS_SET, 39 The strings are followed by an extra null byte. If TZ_IS_SET,
40 there must be at least one string and the first string (which is 40 there must be at least one string and the first string (which is
41 actually a TZ environment value value) may be empty. Otherwise 41 actually a TZ environment value) may be empty. Otherwise all
42 all strings must be nonempty. 42 strings must be nonempty.
43 43
44 Abbreviations are stored here because otherwise the values of 44 Abbreviations are stored here because otherwise the values of
45 tm_zone and/or tzname would be dead after changing TZ and calling 45 tm_zone and/or tzname would be dead after changing TZ and calling
diff --git a/lib/verify.h b/lib/verify.h
index dcaf7cab938..dcba9c8cb0a 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -248,7 +248,12 @@ template <int w>
248/* Verify requirement R at compile-time, as a declaration without a 248/* Verify requirement R at compile-time, as a declaration without a
249 trailing ';'. */ 249 trailing ';'. */
250 250
251#define verify(R) _GL_VERIFY (R, "verify (" #R ")") 251#ifdef __GNUC__
252# define verify(R) _GL_VERIFY (R, "verify (" #R ")")
253#else
254/* PGI barfs if R is long. Play it safe. */
255# define verify(R) _GL_VERIFY (R, "verify (...)")
256#endif
252 257
253#ifndef __has_builtin 258#ifndef __has_builtin
254# define __has_builtin(x) 0 259# define __has_builtin(x) 0
diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index c26935fcc97..7402ab21d74 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -2129,7 +2129,7 @@ MODE can be \"login\" or \"password\"."
2129 (if user 2129 (if user
2130 (auth-source-search 2130 (auth-source-search
2131 :host host 2131 :host host
2132 :user "yourusername" 2132 :user user
2133 :max 1 2133 :max 1
2134 :require '(:user :secret) 2134 :require '(:user :secret)
2135 :create nil) 2135 :create nil)
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index 77b325ff25d..9f618bcb7de 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
102commands.") 102commands.")
103(make-variable-buffer-local 'Buffer-menu-files-only) 103(make-variable-buffer-local 'Buffer-menu-files-only)
104 104
105(defvar Info-current-file) ; from info.el
106(defvar Info-current-node) ; from info.el
107
108(defvar Buffer-menu-mode-map 105(defvar Buffer-menu-mode-map
109 (let ((map (make-sparse-keymap)) 106 (let ((map (make-sparse-keymap))
110 (menu-map (make-sparse-keymap))) 107 (menu-map (make-sparse-keymap)))
@@ -702,21 +699,7 @@ means list those buffers and no others."
702(defun Buffer-menu--pretty-file-name (file) 699(defun Buffer-menu--pretty-file-name (file)
703 (cond (file 700 (cond (file
704 (abbreviate-file-name file)) 701 (abbreviate-file-name file))
705 ((and (boundp 'list-buffers-directory) 702 ((bound-and-true-p list-buffers-directory))
706 list-buffers-directory)
707 list-buffers-directory)
708 ((eq major-mode 'Info-mode)
709 (Buffer-menu-info-node-description Info-current-file))
710 (t ""))) 703 (t "")))
711 704
712(defun Buffer-menu-info-node-description (file)
713 (cond
714 ((equal file "dir") "*Info Directory*")
715 ((eq file 'apropos) "*Info Apropos*")
716 ((eq file 'history) "*Info History*")
717 ((eq file 'toc) "*Info TOC*")
718 ((not (stringp file)) "") ; Avoid errors
719 (t
720 (concat "(" (file-name-nondirectory file) ") " Info-current-node))))
721
722;;; buff-menu.el ends here 705;;; buff-menu.el ends here
diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el
index 7651c5da1f4..b781cb0eb48 100644
--- a/lisp/calendar/parse-time.el
+++ b/lisp/calendar/parse-time.el
@@ -1,4 +1,4 @@
1;;; parse-time.el --- parsing time strings 1;;; parse-time.el --- parsing time strings -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1996, 2000-2017 Free Software Foundation, Inc. 3;; Copyright (C) 1996, 2000-2017 Free Software Foundation, Inc.
4 4
@@ -203,12 +203,9 @@ any values that are unknown are returned as nil."
203 (time-second 2digit) 203 (time-second 2digit)
204 (time-secfrac "\\(\\.[0-9]+\\)?") 204 (time-secfrac "\\(\\.[0-9]+\\)?")
205 (time-numoffset (concat "\\([-+]\\)" time-hour ":?" time-minute "?")) 205 (time-numoffset (concat "\\([-+]\\)" time-hour ":?" time-minute "?"))
206 (time-offset (concat "Z" time-numoffset))
207 (partial-time (concat time-hour colon time-minute colon time-second 206 (partial-time (concat time-hour colon time-minute colon time-second
208 time-secfrac)) 207 time-secfrac))
209 (full-date (concat date-fullyear dash date-month dash date-mday)) 208 (full-date (concat date-fullyear dash date-month dash date-mday)))
210 (full-time (concat partial-time time-offset))
211 (date-time (concat full-date "T" full-time)))
212 (list (concat "^" full-date) 209 (list (concat "^" full-date)
213 (concat "T" partial-time) 210 (concat "T" partial-time)
214 (concat "\\(Z\\|" time-numoffset "\\)"))) 211 (concat "\\(Z\\|" time-numoffset "\\)")))
@@ -225,7 +222,7 @@ If DATE-STRING cannot be parsed, it falls back to
225 (time-re (nth 1 parse-time-iso8601-regexp)) 222 (time-re (nth 1 parse-time-iso8601-regexp))
226 (tz-re (nth 2 parse-time-iso8601-regexp)) 223 (tz-re (nth 2 parse-time-iso8601-regexp))
227 re-start 224 re-start
228 time seconds minute hour fractional-seconds 225 time seconds minute hour
229 day month year day-of-week dst tz) 226 day month year day-of-week dst tz)
230 ;; We need to populate 'time' with 227 ;; We need to populate 'time' with
231 ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) 228 ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
@@ -240,9 +237,6 @@ If DATE-STRING cannot be parsed, it falls back to
240 (setq hour (string-to-number (match-string 1 date-string)) 237 (setq hour (string-to-number (match-string 1 date-string))
241 minute (string-to-number (match-string 2 date-string)) 238 minute (string-to-number (match-string 2 date-string))
242 seconds (string-to-number (match-string 3 date-string)) 239 seconds (string-to-number (match-string 3 date-string))
243 fractional-seconds (string-to-number (or
244 (match-string 4 date-string)
245 "0"))
246 re-start (match-end 0)) 240 re-start (match-end 0))
247 (when (string-match tz-re date-string re-start) 241 (when (string-match tz-re date-string re-start)
248 (if (string= "Z" (match-string 1 date-string)) 242 (if (string= "Z" (match-string 1 date-string))
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index a790419b86f..51c43c7d21a 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."
511 (scroll-step windows integer) 511 (scroll-step windows integer)
512 (scroll-conservatively windows integer) 512 (scroll-conservatively windows integer)
513 (scroll-margin windows integer) 513 (scroll-margin windows integer)
514 (maximum-scroll-margin windows float "26.1")
514 (hscroll-margin windows integer "22.1") 515 (hscroll-margin windows integer "22.1")
515 (hscroll-step windows number "22.1") 516 (hscroll-step windows number "22.1")
516 (truncate-partial-width-windows 517 (truncate-partial-width-windows
diff --git a/lisp/dired.el b/lisp/dired.el
index 350f6a7d2e3..2733372eb7b 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -59,6 +59,10 @@
59May contain all other options that don't contradict `-l'; 59May contain all other options that don't contradict `-l';
60may contain even `F', `b', `i' and `s'. See also the variable 60may contain even `F', `b', `i' and `s'. See also the variable
61`dired-ls-F-marks-symlinks' concerning the `F' switch. 61`dired-ls-F-marks-symlinks' concerning the `F' switch.
62Options that include embedded whitespace must be quoted
63like this: \\\"--option=value with spaces\\\"; you can use
64`combine-and-quote-strings' to produce the correct quoting of
65each option.
62On systems such as MS-DOS and MS-Windows, which use `ls' emulation in Lisp, 66On systems such as MS-DOS and MS-Windows, which use `ls' emulation in Lisp,
63some of the `ls' switches are not supported; see the doc string of 67some of the `ls' switches are not supported; see the doc string of
64`insert-directory' in `ls-lisp.el' for more details." 68`insert-directory' in `ls-lisp.el' for more details."
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 2c11cd23a7f..172ea163c18 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -442,6 +442,9 @@ Typically \"page-%s.png\".")
442(defun doc-view-revert-buffer (&optional ignore-auto noconfirm) 442(defun doc-view-revert-buffer (&optional ignore-auto noconfirm)
443 "Like `revert-buffer', but preserves the buffer's current modes." 443 "Like `revert-buffer', but preserves the buffer's current modes."
444 (interactive (list (not current-prefix-arg))) 444 (interactive (list (not current-prefix-arg)))
445 (if (< undo-outer-limit (* 2 (buffer-size)))
446 ;; It's normal for this operation to result in a very large undo entry.
447 (setq-local undo-outer-limit (* 2 (buffer-size))))
445 (cl-labels ((revert () 448 (cl-labels ((revert ()
446 (let (revert-buffer-function) 449 (let (revert-buffer-function)
447 (revert-buffer ignore-auto noconfirm 'preserve-modes)))) 450 (revert-buffer ignore-auto noconfirm 'preserve-modes))))
@@ -1763,6 +1766,8 @@ toggle between displaying the document or editing it as text.
1763 (unless doc-view-doc-type 1766 (unless doc-view-doc-type
1764 (doc-view-set-doc-type)) 1767 (doc-view-set-doc-type))
1765 (doc-view-set-up-single-converter) 1768 (doc-view-set-up-single-converter)
1769 (unless (memq doc-view-doc-type '(ps))
1770 (setq-local require-final-newline nil))
1766 1771
1767 (doc-view-make-safe-dir doc-view-cache-directory) 1772 (doc-view-make-safe-dir doc-view-cache-directory)
1768 ;; Handle compressed files, remote files, files inside archives 1773 ;; Handle compressed files, remote files, files inside archives
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index db54d1eeb20..ec0f08de356 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'."
112 :type 'boolean 112 :type 'boolean
113 :group 'edebug) 113 :group 'edebug)
114 114
115(defcustom edebug-max-depth 150
116 "Maximum recursion depth when instrumenting code.
117This limit is intended to stop recursion if an Edebug specification
118contains an infinite loop. When Edebug is instrumenting code
119containing very large quoted lists, it may reach this limit and give
120the error message \"Too deep - perhaps infinite loop in spec?\".
121Make this limit larger to countermand that, but you may also need to
122increase `max-lisp-eval-depth' and `max-specpdl-size'."
123 :type 'integer
124 :group 'edebug
125 :version "26.1")
126
115(defcustom edebug-save-windows t 127(defcustom edebug-save-windows t
116 "If non-nil, Edebug saves and restores the window configuration. 128 "If non-nil, Edebug saves and restores the window configuration.
117That takes some time, so if your program does not care what happens to 129That 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."
1452(defvar edebug-after-dotted-spec nil) 1464(defvar edebug-after-dotted-spec nil)
1453 1465
1454(defvar edebug-matching-depth 0) ;; initial value 1466(defvar edebug-matching-depth 0) ;; initial value
1455(defconst edebug-max-depth 150) ;; maximum number of matching recursions.
1456 1467
1457 1468
1458;;; Failure to match 1469;;; Failure to match
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
index 7d99cb30274..4cf9d9609e9 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
97buffer is killed; if there is an error, the test buffer is kept 97buffer is killed; if there is an error, the test buffer is kept
98around on error for further inspection. Its name is derived from 98around on error for further inspection. Its name is derived from
99the name of the test and the result of NAME-FORM." 99the name of the test and the result of NAME-FORM."
100 (declare (debug ((form) body)) 100 (declare (debug ((":name" form) body))
101 (indent 1)) 101 (indent 1))
102 `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) 102 `(ert--call-with-test-buffer ,name-form (lambda () ,@body)))
103 103
@@ -285,6 +285,30 @@ BUFFER defaults to current buffer. Does not modify BUFFER."
285 (kill-buffer clone))))))) 285 (kill-buffer clone)))))))
286 286
287 287
288(defmacro ert-with-message-capture (var &rest body)
289 "Execute BODY while collecting anything written with `message' in VAR.
290
291Capture all messages produced by `message' when it is called from
292Lisp, and concatenate them separated by newlines into one string.
293
294This is useful for separating the issuance of messages by the
295code under test from the behavior of the *Messages* buffer."
296 (declare (debug (symbolp body))
297 (indent 1))
298 (let ((g-advice (cl-gensym)))
299 `(let* ((,var "")
300 (,g-advice (lambda (func &rest args)
301 (if (or (null args) (equal (car args) ""))
302 (apply func args)
303 (let ((msg (apply #'format-message args)))
304 (setq ,var (concat ,var msg "\n"))
305 (funcall func "%s" msg))))))
306 (advice-add 'message :around ,g-advice)
307 (unwind-protect
308 (progn ,@body)
309 (advice-remove 'message ,g-advice)))))
310
311
288(provide 'ert-x) 312(provide 'ert-x)
289 313
290;;; ert-x.el ends here 314;;; ert-x.el ends here
diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el
index a45fc0a05c3..cf82fe3ec63 100644
--- a/lisp/emacs-lisp/let-alist.el
+++ b/lisp/emacs-lisp/let-alist.el
@@ -4,7 +4,7 @@
4 4
5;; Author: Artur Malabarba <emacs@endlessparentheses.com> 5;; Author: Artur Malabarba <emacs@endlessparentheses.com>
6;; Package-Requires: ((emacs "24.1")) 6;; Package-Requires: ((emacs "24.1"))
7;; Version: 1.0.4 7;; Version: 1.0.5
8;; Keywords: extensions lisp 8;; Keywords: extensions lisp
9;; Prefix: let-alist 9;; Prefix: let-alist
10;; Separator: - 10;; Separator: -
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 54678c5f324..46a5eedd150 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -89,7 +89,8 @@
89 (functionp &rest form) 89 (functionp &rest form)
90 sexp)) 90 sexp))
91 91
92(def-edebug-spec pcase-MACRO pcase--edebug-match-macro) 92;; See bug#24717
93(put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro)
93 94
94;; Only called from edebug. 95;; Only called from edebug.
95(declare-function get-edebug-spec "edebug" (symbol)) 96(declare-function get-edebug-spec "edebug" (symbol))
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 7736225b5fa..f7a846927c0 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -115,12 +115,16 @@ threading."
115 binding)) 115 binding))
116 bindings))) 116 bindings)))
117 117
118(defmacro if-let (bindings then &rest else) 118(defmacro if-let* (bindings then &rest else)
119 "Process BINDINGS and if all values are non-nil eval THEN, else ELSE. 119 "Bind variables according to VARLIST and eval THEN or ELSE.
120Argument BINDINGS is a list of tuples whose car is a symbol to be 120Each binding is evaluated in turn with `let*', and evaluation
121bound and (optionally) used in THEN, and its cadr is a sexp to be 121stops if a binding value is nil. If all are non-nil, the value
122evalled to set symbol's value. In the special case you only want 122of THEN is returned, or the last form in ELSE is returned.
123to bind a single value, BINDINGS can just be a plain tuple." 123Each element of VARLIST is a symbol (which is bound to nil)
124or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
125In the special case you only want to bind a single value,
126VARLIST can just be a plain tuple.
127\n(fn VARLIST THEN ELSE...)"
124 (declare (indent 2) 128 (declare (indent 2)
125 (debug ([&or (&rest (symbolp form)) (symbolp form)] form body))) 129 (debug ([&or (&rest (symbolp form)) (symbolp form)] form body)))
126 (when (and (<= (length bindings) 2) 130 (when (and (<= (length bindings) 2)
@@ -132,15 +136,23 @@ to bind a single value, BINDINGS can just be a plain tuple."
132 ,then 136 ,then
133 ,@else))) 137 ,@else)))
134 138
135(defmacro when-let (bindings &rest body) 139(defmacro when-let* (bindings &rest body)
136 "Process BINDINGS and if all values are non-nil eval BODY. 140 "Bind variables according to VARLIST and conditionally eval BODY.
137Argument BINDINGS is a list of tuples whose car is a symbol to be 141Each binding is evaluated in turn with `let*', and evaluation
138bound and (optionally) used in BODY, and its cadr is a sexp to be 142stops if a binding value is nil. If all are non-nil, the value
139evalled to set symbol's value. In the special case you only want 143of the last form in BODY is returned.
140to bind a single value, BINDINGS can just be a plain tuple." 144Each element of VARLIST is a symbol (which is bound to nil)
145or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
146In the special case you only want to bind a single value,
147VARLIST can just be a plain tuple.
148\n(fn VARLIST BODY...)"
141 (declare (indent 1) (debug if-let)) 149 (declare (indent 1) (debug if-let))
142 (list 'if-let bindings (macroexp-progn body))) 150 (list 'if-let bindings (macroexp-progn body)))
143 151
152(defalias 'if-let 'if-let*)
153(defalias 'when-let 'when-let*)
154(defalias 'and-let* 'when-let*)
155
144(defsubst hash-table-empty-p (hash-table) 156(defsubst hash-table-empty-p (hash-table)
145 "Check whether HASH-TABLE is empty (has 0 elements)." 157 "Check whether HASH-TABLE is empty (has 0 elements)."
146 (zerop (hash-table-count hash-table))) 158 (zerop (hash-table-count hash-table)))
@@ -214,6 +226,11 @@ user enters `recenter', `scroll-up', or `scroll-down' responses,
214perform the requested window recentering or scrolling and ask 226perform the requested window recentering or scrolling and ask
215again. 227again.
216 228
229When `use-dialog-box' is t (the default), this function can pop
230up a dialog window to collect the user input. That functionality
231requires `display-popup-menus-p' to return t. Otherwise, a text
232dialog will be used.
233
217The return value is the matching entry from the CHOICES list. 234The return value is the matching entry from the CHOICES list.
218 235
219Usage example: 236Usage example:
diff --git a/lisp/emulation/edt-mapper.el b/lisp/emulation/edt-mapper.el
index 24a8f039fa5..457ad55dd6c 100644
--- a/lisp/emulation/edt-mapper.el
+++ b/lisp/emulation/edt-mapper.el
@@ -57,9 +57,9 @@
57;; Usage: 57;; Usage:
58 58
59;; Simply load this file into emacs (version 19 or higher) 59;; Simply load this file into emacs (version 19 or higher)
60;; using the following command. 60;; and run the function edt-mapper, using the following command.
61 61
62;; emacs -q -l edt-mapper.el 62;; emacs -q -l edt-mapper -f edt-mapper
63 63
64;; The "-q" option prevents loading of your init file (commands 64;; The "-q" option prevents loading of your init file (commands
65;; therein might confuse this program). 65;; therein might confuse this program).
@@ -96,10 +96,6 @@
96 96
97;;; Code: 97;;; Code:
98 98
99;; Otherwise it just hangs. This seems preferable.
100(if noninteractive
101 (error "edt-mapper cannot be loaded in batch mode"))
102
103;;; 99;;;
104;;; Decide Emacs Variant, GNU Emacs or XEmacs (aka Lucid Emacs). 100;;; Decide Emacs Variant, GNU Emacs or XEmacs (aka Lucid Emacs).
105;;; Determine Window System, and X Server Vendor (if appropriate). 101;;; Determine Window System, and X Server Vendor (if appropriate).
@@ -124,6 +120,8 @@
124;;; 120;;;
125;;; Key variables 121;;; Key variables
126;;; 122;;;
123
124;; FIXME some/all of these should be let-bound, not global.
127(defvar edt-key nil) 125(defvar edt-key nil)
128(defvar edt-enter nil) 126(defvar edt-enter nil)
129(defvar edt-return nil) 127(defvar edt-return nil)
@@ -137,88 +135,116 @@
137(defvar edt-save-function-key-map) 135(defvar edt-save-function-key-map)
138 136
139;;; 137;;;
140;;; Determine Terminal Type (if appropriate). 138;;; Key mapping functions
141;;;
142
143(if (and edt-window-system (not (eq edt-window-system 'tty)))
144 (setq edt-term nil)
145 (setq edt-term (getenv "TERM")))
146
147;;;
148;;; Implements a workaround for a feature that was added to simple.el.
149;;;
150;;; Many function keys have no Emacs functions assigned to them by
151;;; default. A subset of these are typically assigned functions in the
152;;; EDT emulation. This includes all the keypad keys and a some others
153;;; like Delete.
154;;;
155;;; Logic in simple.el maps some of these unassigned function keys to
156;;; ordinary typing keys. Where this is the case, a call to
157;;; read-key-sequence, below, does not return the name of the function
158;;; key pressed by the user but, instead, it returns the name of the
159;;; key to which it has been mapped. It needs to know the name of the
160;;; key pressed by the user. As a workaround, we assign a function to
161;;; each of the unassigned function keys of interest, here. These
162;;; assignments override the mapping to other keys and are only
163;;; temporary since, when edt-mapper is finished executing, it causes
164;;; Emacs to exit.
165;;;
166
167(mapc
168 (lambda (function-key)
169 (if (not (lookup-key (current-global-map) function-key))
170 (define-key (current-global-map) function-key 'forward-char)))
171 '([kp-0] [kp-1] [kp-2] [kp-3] [kp-4]
172 [kp-5] [kp-6] [kp-7] [kp-8] [kp-9]
173 [kp-space]
174 [kp-tab]
175 [kp-enter]
176 [kp-multiply]
177 [kp-add]
178 [kp-separator]
179 [kp-subtract]
180 [kp-decimal]
181 [kp-divide]
182 [kp-equal]
183 [backspace]
184 [delete]
185 [tab]
186 [linefeed]
187 [clear]))
188
189;;;
190;;; Make sure the window is big enough to display the instructions,
191;;; except where window cannot be re-sized.
192;;;
193
194(if (and edt-window-system (not (eq edt-window-system 'tty)))
195 (set-frame-size (selected-frame) 80 36))
196
197;;;
198;;; Create buffers - Directions and Keys
199;;; 139;;;
200(if (not (get-buffer "Directions")) (generate-new-buffer "Directions")) 140(defun edt-map-key (ident descrip)
201(if (not (get-buffer "Keys")) (generate-new-buffer "Keys")) 141 (interactive)
142 (if (featurep 'xemacs)
143 (progn
144 (setq edt-key-seq (read-key-sequence (format "Press %s%s: " ident descrip)))
145 (setq edt-key (concat "[" (format "%s" (event-key (aref edt-key-seq 0))) "]"))
146 (cond ((not (equal edt-key edt-return))
147 (set-buffer "Keys")
148 (insert (format " (\"%s\" . %s)\n" ident edt-key))
149 (set-buffer "Directions"))
150 ;; bogosity to get next prompt to come up, if the user hits <CR>!
151 ;; check periodically to see if this is still needed...
152 (t
153 (set-buffer "Keys")
154 (insert (format " (\"%s\" . \"\" )\n" ident))
155 (set-buffer "Directions"))))
156 (setq edt-key (read-key-sequence (format "Press %s%s: " ident descrip)))
157 (cond ((not (equal edt-key edt-return))
158 (set-buffer "Keys")
159 (insert (if (vectorp edt-key)
160 (format " (\"%s\" . %s)\n" ident edt-key)
161 (format " (\"%s\" . \"%s\")\n" ident edt-key)))
162 (set-buffer "Directions"))
163 ;; bogosity to get next prompt to come up, if the user hits <CR>!
164 ;; check periodically to see if this is still needed...
165 (t
166 (set-buffer "Keys")
167 (insert (format " (\"%s\" . \"\" )\n" ident))
168 (set-buffer "Directions"))))
169 edt-key)
202 170
203;;; 171(defun edt-mapper ()
204;;; Put header in the Keys buffer 172 (if noninteractive
205;;; 173 (user-error "edt-mapper cannot be loaded in batch mode"))
206(set-buffer "Keys") 174 ;; Determine Terminal Type (if appropriate).
207(insert "\ 175 (if (and edt-window-system (not (eq edt-window-system 'tty)))
176 (setq edt-term nil)
177 (setq edt-term (getenv "TERM")))
178 ;;
179 ;; Implements a workaround for a feature that was added to simple.el.
180 ;;
181 ;; Many function keys have no Emacs functions assigned to them by
182 ;; default. A subset of these are typically assigned functions in the
183 ;; EDT emulation. This includes all the keypad keys and a some others
184 ;; like Delete.
185 ;;
186 ;; Logic in simple.el maps some of these unassigned function keys to
187 ;; ordinary typing keys. Where this is the case, a call to
188 ;; read-key-sequence, below, does not return the name of the function
189 ;; key pressed by the user but, instead, it returns the name of the
190 ;; key to which it has been mapped. It needs to know the name of the
191 ;; key pressed by the user. As a workaround, we assign a function to
192 ;; each of the unassigned function keys of interest, here. These
193 ;; assignments override the mapping to other keys and are only
194 ;; temporary since, when edt-mapper is finished executing, it causes
195 ;; Emacs to exit.
196 ;;
197 (mapc
198 (lambda (function-key)
199 (if (not (lookup-key (current-global-map) function-key))
200 (define-key (current-global-map) function-key 'forward-char)))
201 '([kp-0] [kp-1] [kp-2] [kp-3] [kp-4]
202 [kp-5] [kp-6] [kp-7] [kp-8] [kp-9]
203 [kp-space]
204 [kp-tab]
205 [kp-enter]
206 [kp-multiply]
207 [kp-add]
208 [kp-separator]
209 [kp-subtract]
210 [kp-decimal]
211 [kp-divide]
212 [kp-equal]
213 [backspace]
214 [delete]
215 [tab]
216 [linefeed]
217 [clear]))
218 ;;
219 ;; Make sure the window is big enough to display the instructions,
220 ;; except where window cannot be re-sized.
221 ;;
222 (if (and edt-window-system (not (eq edt-window-system 'tty)))
223 (set-frame-size (selected-frame) 80 36))
224 ;;
225 ;; Create buffers - Directions and Keys
226 ;;
227 (if (not (get-buffer "Directions")) (generate-new-buffer "Directions"))
228 (if (not (get-buffer "Keys")) (generate-new-buffer "Keys"))
229 ;;
230 ;; Put header in the Keys buffer
231 ;;
232 (set-buffer "Keys")
233 (insert "\
208;; 234;;
209;; Key definitions for the EDT emulation within GNU Emacs 235;; Key definitions for the EDT emulation within GNU Emacs
210;; 236;;
211 237
212(defconst *EDT-keys* 238\(defconst *EDT-keys*
213 '( 239 '(
214") 240 ")
215 241
216;;; 242 ;;
217;;; Display directions 243 ;; Display directions
218;;; 244 ;;
219(switch-to-buffer "Directions") 245 (switch-to-buffer "Directions")
220(if (and edt-window-system (not (eq edt-window-system 'tty))) 246 (if (and edt-window-system (not (eq edt-window-system 'tty)))
221 (insert " 247 (insert "
222 EDT MAPPER 248 EDT MAPPER
223 249
224 You will be asked to press keys to create a custom mapping (under a 250 You will be asked to press keys to create a custom mapping (under a
@@ -240,7 +266,7 @@
240 just press RETURN at the prompt. 266 just press RETURN at the prompt.
241 267
242") 268")
243 (insert " 269 (insert "
244 EDT MAPPER 270 EDT MAPPER
245 271
246 You will be asked to press keys to create a custom mapping of your 272 You will be asked to press keys to create a custom mapping of your
@@ -259,39 +285,39 @@
259 285
260")) 286"))
261 287
262(delete-other-windows) 288 (delete-other-windows)
263 289
264;;; 290 ;;
265;;; Save <CR> for future reference. 291 ;; Save <CR> for future reference.
266;;; 292 ;;
267;;; For GNU Emacs, running in a Window System, first hide bindings in 293 ;; For GNU Emacs, running in a Window System, first hide bindings in
268;;; function-key-map. 294 ;; function-key-map.
269;;; 295 ;;
270(cond 296 (cond
271 ((featurep 'xemacs) 297 ((featurep 'xemacs)
272 (setq edt-return-seq (read-key-sequence "Hit carriage-return <CR> to continue ")) 298 (setq edt-return-seq (read-key-sequence "Hit carriage-return <CR> to continue "))
273 (setq edt-return (concat "[" (format "%s" (event-key (aref edt-return-seq 0))) "]"))) 299 (setq edt-return (concat "[" (format "%s" (event-key (aref edt-return-seq 0))) "]")))
274 (t 300 (t
275 (if edt-window-system 301 (if edt-window-system
276 (progn 302 (progn
277 (setq edt-save-function-key-map function-key-map) 303 (setq edt-save-function-key-map function-key-map)
278 (setq function-key-map (make-sparse-keymap)))) 304 (setq function-key-map (make-sparse-keymap))))
279 (setq edt-return (read-key-sequence "Hit carriage-return <CR> to continue ")))) 305 (setq edt-return (read-key-sequence "Hit carriage-return <CR> to continue "))))
280 306
281;;; 307 ;;
282;;; Remove prefix-key bindings to F1 and F2 in global-map so they can be 308 ;; Remove prefix-key bindings to F1 and F2 in global-map so they can be
283;;; bound in the EDT Emulation mode. 309 ;; bound in the EDT Emulation mode.
284;;; 310 ;;
285(global-unset-key [f1]) 311 (global-unset-key [f1])
286(global-unset-key [f2]) 312 (global-unset-key [f2])
287 313
288;;; 314 ;;
289;;; Display Keypad Diagram and Begin Prompting for Keys 315 ;; Display Keypad Diagram and Begin Prompting for Keys
290;;; 316 ;;
291(set-buffer "Directions") 317 (set-buffer "Directions")
292(delete-region (point-min) (point-max)) 318 (delete-region (point-min) (point-max))
293(if (and edt-window-system (not (eq edt-window-system 'tty))) 319 (if (and edt-window-system (not (eq edt-window-system 'tty)))
294 (insert " 320 (insert "
295 321
296 PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW. 322 PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW.
297 323
@@ -321,11 +347,11 @@
321 REMEMBER: JUST PRESS RETURN TO SKIP MAPPING A KEY. 347 REMEMBER: JUST PRESS RETURN TO SKIP MAPPING A KEY.
322 348
323") 349")
324 (progn 350 (progn
325 (insert " 351 (insert "
326 GENERATING A CUSTOM CONFIGURATION FILE FOR TERMINAL TYPE: ") 352 GENERATING A CUSTOM CONFIGURATION FILE FOR TERMINAL TYPE: ")
327 (insert (format "%s." edt-term)) 353 (insert (format "%s." edt-term))
328 (insert " 354 (insert "
329 355
330 PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW. 356 PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW.
331 357
@@ -347,142 +373,109 @@
347 REMEMBER: JUST PRESS RETURN TO SKIP MAPPING A KEY."))) 373 REMEMBER: JUST PRESS RETURN TO SKIP MAPPING A KEY.")))
348 374
349 375
350;;;
351;;; Key mapping functions
352;;;
353(defun edt-map-key (ident descrip)
354 (interactive)
355 (if (featurep 'xemacs)
356 (progn
357 (setq edt-key-seq (read-key-sequence (format "Press %s%s: " ident descrip)))
358 (setq edt-key (concat "[" (format "%s" (event-key (aref edt-key-seq 0))) "]"))
359 (cond ((not (equal edt-key edt-return))
360 (set-buffer "Keys")
361 (insert (format " (\"%s\" . %s)\n" ident edt-key))
362 (set-buffer "Directions"))
363 ;; bogosity to get next prompt to come up, if the user hits <CR>!
364 ;; check periodically to see if this is still needed...
365 (t
366 (set-buffer "Keys")
367 (insert (format " (\"%s\" . \"\" )\n" ident))
368 (set-buffer "Directions"))))
369 (setq edt-key (read-key-sequence (format "Press %s%s: " ident descrip)))
370 (cond ((not (equal edt-key edt-return))
371 (set-buffer "Keys")
372 (insert (if (vectorp edt-key)
373 (format " (\"%s\" . %s)\n" ident edt-key)
374 (format " (\"%s\" . \"%s\")\n" ident edt-key)))
375 (set-buffer "Directions"))
376 ;; bogosity to get next prompt to come up, if the user hits <CR>!
377 ;; check periodically to see if this is still needed...
378 (t
379 (set-buffer "Keys")
380 (insert (format " (\"%s\" . \"\" )\n" ident))
381 (set-buffer "Directions"))))
382 edt-key)
383 376
384(set-buffer "Keys") 377 (set-buffer "Keys")
385(insert " 378 (insert "
386;; 379;;
387;; Arrows 380;; Arrows
388;; 381;;
389") 382")
390(set-buffer "Directions") 383 (set-buffer "Directions")
391 384
392(edt-map-key "UP" " - The Up Arrow Key") 385 (edt-map-key "UP" " - The Up Arrow Key")
393(edt-map-key "DOWN" " - The Down Arrow Key") 386 (edt-map-key "DOWN" " - The Down Arrow Key")
394(edt-map-key "LEFT" " - The Left Arrow Key") 387 (edt-map-key "LEFT" " - The Left Arrow Key")
395(edt-map-key "RIGHT" " - The Right Arrow Key") 388 (edt-map-key "RIGHT" " - The Right Arrow Key")
396 389
397 390
398(set-buffer "Keys") 391 (set-buffer "Keys")
399(insert " 392 (insert "
400;; 393;;
401;; PF keys 394;; PF keys
402;; 395;;
403") 396")
404(set-buffer "Directions") 397 (set-buffer "Directions")
405 398
406(edt-map-key "PF1" " - The PF1 (GOLD) Key") 399 (edt-map-key "PF1" " - The PF1 (GOLD) Key")
407(edt-map-key "PF2" " - The Keypad PF2 Key") 400 (edt-map-key "PF2" " - The Keypad PF2 Key")
408(edt-map-key "PF3" " - The Keypad PF3 Key") 401 (edt-map-key "PF3" " - The Keypad PF3 Key")
409(edt-map-key "PF4" " - The Keypad PF4 Key") 402 (edt-map-key "PF4" " - The Keypad PF4 Key")
410 403
411(set-buffer "Keys") 404 (set-buffer "Keys")
412(insert " 405 (insert "
413;; 406;;
414;; KP0-9 KP- KP, KPP and KPE 407;; KP0-9 KP- KP, KPP and KPE
415;; 408;;
416") 409")
417(set-buffer "Directions") 410 (set-buffer "Directions")
418 411
419(edt-map-key "KP0" " - The Keypad 0 Key") 412 (edt-map-key "KP0" " - The Keypad 0 Key")
420(edt-map-key "KP1" " - The Keypad 1 Key") 413 (edt-map-key "KP1" " - The Keypad 1 Key")
421(edt-map-key "KP2" " - The Keypad 2 Key") 414 (edt-map-key "KP2" " - The Keypad 2 Key")
422(edt-map-key "KP3" " - The Keypad 3 Key") 415 (edt-map-key "KP3" " - The Keypad 3 Key")
423(edt-map-key "KP4" " - The Keypad 4 Key") 416 (edt-map-key "KP4" " - The Keypad 4 Key")
424(edt-map-key "KP5" " - The Keypad 5 Key") 417 (edt-map-key "KP5" " - The Keypad 5 Key")
425(edt-map-key "KP6" " - The Keypad 6 Key") 418 (edt-map-key "KP6" " - The Keypad 6 Key")
426(edt-map-key "KP7" " - The Keypad 7 Key") 419 (edt-map-key "KP7" " - The Keypad 7 Key")
427(edt-map-key "KP8" " - The Keypad 8 Key") 420 (edt-map-key "KP8" " - The Keypad 8 Key")
428(edt-map-key "KP9" " - The Keypad 9 Key") 421 (edt-map-key "KP9" " - The Keypad 9 Key")
429(edt-map-key "KP-" " - The Keypad - Key") 422 (edt-map-key "KP-" " - The Keypad - Key")
430(edt-map-key "KP," " - The Keypad , Key") 423 (edt-map-key "KP," " - The Keypad , Key")
431(edt-map-key "KPP" " - The Keypad . Key") 424 (edt-map-key "KPP" " - The Keypad . Key")
432(edt-map-key "KPE" " - The Keypad Enter Key") 425 (edt-map-key "KPE" " - The Keypad Enter Key")
433;; Save the enter key 426 ;; Save the enter key
434(setq edt-enter edt-key) 427 (setq edt-enter edt-key)
435(setq edt-enter-seq edt-key-seq) 428 (setq edt-enter-seq edt-key-seq)
436 429
437 430
438(set-buffer "Keys") 431 (set-buffer "Keys")
439(insert " 432 (insert "
440;; 433;;
441;; Editing keypad (FIND, INSERT, REMOVE) 434;; Editing keypad (FIND, INSERT, REMOVE)
442;; (SELECT, PREVIOUS, NEXT) 435;; (SELECT, PREVIOUS, NEXT)
443;; 436;;
444") 437")
445(set-buffer "Directions") 438 (set-buffer "Directions")
446 439
447(edt-map-key "FIND" " - The Find key on the editing keypad") 440 (edt-map-key "FIND" " - The Find key on the editing keypad")
448(edt-map-key "INSERT" " - The Insert key on the editing keypad") 441 (edt-map-key "INSERT" " - The Insert key on the editing keypad")
449(edt-map-key "REMOVE" " - The Remove key on the editing keypad") 442 (edt-map-key "REMOVE" " - The Remove key on the editing keypad")
450(edt-map-key "SELECT" " - The Select key on the editing keypad") 443 (edt-map-key "SELECT" " - The Select key on the editing keypad")
451(edt-map-key "PREVIOUS" " - The Prev Scr key on the editing keypad") 444 (edt-map-key "PREVIOUS" " - The Prev Scr key on the editing keypad")
452(edt-map-key "NEXT" " - The Next Scr key on the editing keypad") 445 (edt-map-key "NEXT" " - The Next Scr key on the editing keypad")
453 446
454(set-buffer "Keys") 447 (set-buffer "Keys")
455(insert " 448 (insert "
456;; 449;;
457;; F1-14 Help Do F17-F20 450;; F1-14 Help Do F17-F20
458;; 451;;
459") 452")
460(set-buffer "Directions") 453 (set-buffer "Directions")
461 454
462(edt-map-key "F1" " - F1 Function Key") 455 (edt-map-key "F1" " - F1 Function Key")
463(edt-map-key "F2" " - F2 Function Key") 456 (edt-map-key "F2" " - F2 Function Key")
464(edt-map-key "F3" " - F3 Function Key") 457 (edt-map-key "F3" " - F3 Function Key")
465(edt-map-key "F4" " - F4 Function Key") 458 (edt-map-key "F4" " - F4 Function Key")
466(edt-map-key "F5" " - F5 Function Key") 459 (edt-map-key "F5" " - F5 Function Key")
467(edt-map-key "F6" " - F6 Function Key") 460 (edt-map-key "F6" " - F6 Function Key")
468(edt-map-key "F7" " - F7 Function Key") 461 (edt-map-key "F7" " - F7 Function Key")
469(edt-map-key "F8" " - F8 Function Key") 462 (edt-map-key "F8" " - F8 Function Key")
470(edt-map-key "F9" " - F9 Function Key") 463 (edt-map-key "F9" " - F9 Function Key")
471(edt-map-key "F10" " - F10 Function Key") 464 (edt-map-key "F10" " - F10 Function Key")
472(edt-map-key "F11" " - F11 Function Key") 465 (edt-map-key "F11" " - F11 Function Key")
473(edt-map-key "F12" " - F12 Function Key") 466 (edt-map-key "F12" " - F12 Function Key")
474(edt-map-key "F13" " - F13 Function Key") 467 (edt-map-key "F13" " - F13 Function Key")
475(edt-map-key "F14" " - F14 Function Key") 468 (edt-map-key "F14" " - F14 Function Key")
476(edt-map-key "HELP" " - HELP Function Key") 469 (edt-map-key "HELP" " - HELP Function Key")
477(edt-map-key "DO" " - DO Function Key") 470 (edt-map-key "DO" " - DO Function Key")
478(edt-map-key "F17" " - F17 Function Key") 471 (edt-map-key "F17" " - F17 Function Key")
479(edt-map-key "F18" " - F18 Function Key") 472 (edt-map-key "F18" " - F18 Function Key")
480(edt-map-key "F19" " - F19 Function Key") 473 (edt-map-key "F19" " - F19 Function Key")
481(edt-map-key "F20" " - F20 Function Key") 474 (edt-map-key "F20" " - F20 Function Key")
482 475
483(set-buffer "Directions") 476 (set-buffer "Directions")
484(delete-region (point-min) (point-max)) 477 (delete-region (point-min) (point-max))
485(insert " 478 (insert "
486 ADDITIONAL FUNCTION KEYS 479 ADDITIONAL FUNCTION KEYS
487 480
488 Your keyboard may have additional function keys which do not correspond 481 Your keyboard may have additional function keys which do not correspond
@@ -501,53 +494,53 @@
501 494
502 When you are done, just press RETURN at the \"EDT Key Name:\" prompt. 495 When you are done, just press RETURN at the \"EDT Key Name:\" prompt.
503") 496")
504(switch-to-buffer "Directions") 497 (switch-to-buffer "Directions")
505;;; 498 ;;
506;;; Add support for extras keys 499 ;; Add support for extras keys
507;;; 500 ;;
508(set-buffer "Keys") 501 (set-buffer "Keys")
509(insert "\ 502 (insert "\
510;; 503;;
511;; Extra Keys 504;; Extra Keys
512;; 505;;
513") 506")
514;;; 507 ;;
515;;; Restore function-key-map. 508 ;; Restore function-key-map.
516;;; 509 ;;
517(if (and edt-window-system (not (featurep 'xemacs))) 510 (if (and edt-window-system (not (featurep 'xemacs)))
518 (setq function-key-map edt-save-function-key-map)) 511 (setq function-key-map edt-save-function-key-map))
519(setq EDT-key-name "") 512 (setq EDT-key-name "")
520(while (not 513 (while (not
521 (string-equal (setq EDT-key-name (read-string "EDT Key Name: ")) "")) 514 (string-equal (setq EDT-key-name (read-string "EDT Key Name: ")) ""))
522 (edt-map-key EDT-key-name "")) 515 (edt-map-key EDT-key-name ""))
523 516
524; 517 ;;
525; No more keys to add, so wrap up. 518 ;; No more keys to add, so wrap up.
526; 519 ;;
527(set-buffer "Keys") 520 (set-buffer "Keys")
528(insert "\ 521 (insert "\
529 ) 522 )
530 ) 523 )
531") 524")
532 525
533;;; 526 ;;
534;;; Save the key mapping program 527 ;; Save the key mapping program
535;;; 528 ;;
536;;; 529 ;;
537;;; Save the key mapping file 530 ;; Save the key mapping file
538;;; 531 ;;
539(let ((file (concat 532 (let ((file (concat
540 "~/.edt-" (if (featurep 'xemacs) "xemacs" "gnu") 533 "~/.edt-" (if (featurep 'xemacs) "xemacs" "gnu")
541 (if edt-term (concat "-" edt-term)) 534 (if edt-term (concat "-" edt-term))
542 (if edt-xserver (concat "-" edt-xserver)) 535 (if edt-xserver (concat "-" edt-xserver))
543 (if edt-window-system (concat "-" (upcase (symbol-name edt-window-system)))) 536 (if edt-window-system (concat "-" (upcase (symbol-name edt-window-system))))
544 "-keys"))) 537 "-keys")))
545 (set-visited-file-name 538 (set-visited-file-name
546 (read-file-name (format "Save key mapping to file (default %s): " file) nil file))) 539 (read-file-name (format "Save key mapping to file (default %s): " file) nil file)))
547(save-buffer) 540 (save-buffer)
548 541
549(message "That's it! Press any key to exit") 542 (message "That's it! Press any key to exit")
550(sit-for 600) 543 (sit-for 600)
551(kill-emacs t) 544 (kill-emacs t))
552 545
553;;; edt-mapper.el ends here 546;;; edt-mapper.el ends here
diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el
index 31f555b0326..a6b2d785ac5 100644
--- a/lisp/emulation/edt.el
+++ b/lisp/emulation/edt.el
@@ -1928,6 +1928,8 @@ Optional argument NOT-YES changes the default to negative."
1928;;; INITIALIZATION COMMANDS. 1928;;; INITIALIZATION COMMANDS.
1929;;; 1929;;;
1930 1930
1931(declare-function edt-mapper "edt-mapper" ())
1932
1931;;; 1933;;;
1932;;; Function used to load LK-201 key mapping file generated by edt-mapper.el. 1934;;; Function used to load LK-201 key mapping file generated by edt-mapper.el.
1933;;; 1935;;;
@@ -1968,7 +1970,7 @@ created."
1968 You can do this by quitting Emacs and then invoking Emacs again as 1970 You can do this by quitting Emacs and then invoking Emacs again as
1969 follows: 1971 follows:
1970 1972
1971 emacs -q -l edt-mapper 1973 emacs -q -l edt-mapper -f edt-mapper
1972 1974
1973 [NOTE: If you do nothing out of the ordinary in your init file, and 1975 [NOTE: If you do nothing out of the ordinary in your init file, and
1974 the search for edt-mapper is successful, you can try running it now.] 1976 the search for edt-mapper is successful, you can try running it now.]
@@ -1983,7 +1985,9 @@ created."
1983 (insert (format 1985 (insert (format
1984 "Ah yes, there it is, in \n\n %s \n\n" path)) 1986 "Ah yes, there it is, in \n\n %s \n\n" path))
1985 (if (edt-y-or-n-p "Do you want to run it now? ") 1987 (if (edt-y-or-n-p "Do you want to run it now? ")
1986 (load-file path) 1988 (progn
1989 (load-file path)
1990 (edt-mapper))
1987 (error "EDT Emulation not configured"))) 1991 (error "EDT Emulation not configured")))
1988 (insert (substitute-command-keys 1992 (insert (substitute-command-keys
1989 "Nope, I can't seem to find it. :-(\n\n")) 1993 "Nope, I can't seem to find it. :-(\n\n"))
diff --git a/lisp/files.el b/lisp/files.el
index 25392fdcc71..b7d104853c3 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -5134,6 +5134,14 @@ Before and after saving the buffer, this function runs
5134 "Non-nil means `save-some-buffers' should save this buffer without asking.") 5134 "Non-nil means `save-some-buffers' should save this buffer without asking.")
5135(make-variable-buffer-local 'buffer-save-without-query) 5135(make-variable-buffer-local 'buffer-save-without-query)
5136 5136
5137(defcustom save-some-buffers-default-predicate nil
5138 "Default predicate for `save-some-buffers'.
5139This allows you to stop `save-some-buffers' from asking
5140about certain files that you'd usually rather not save."
5141 :group 'auto-save
5142 :type 'function
5143 :version "26.1")
5144
5137(defun save-some-buffers (&optional arg pred) 5145(defun save-some-buffers (&optional arg pred)
5138 "Save some modified file-visiting buffers. Asks user about each one. 5146 "Save some modified file-visiting buffers. Asks user about each one.
5139You can answer `y' to save, `n' not to save, `C-r' to look at the 5147You can answer `y' to save, `n' not to save, `C-r' to look at the
@@ -5149,10 +5157,13 @@ If PRED is nil, all the file-visiting buffers are considered.
5149If PRED is t, then certain non-file buffers will also be considered. 5157If PRED is t, then certain non-file buffers will also be considered.
5150If PRED is a zero-argument function, it indicates for each buffer whether 5158If PRED is a zero-argument function, it indicates for each buffer whether
5151to consider it or not when called with that buffer current. 5159to consider it or not when called with that buffer current.
5160PRED defaults to the value of `save-some-buffers-default-predicate'.
5152 5161
5153See `save-some-buffers-action-alist' if you want to 5162See `save-some-buffers-action-alist' if you want to
5154change the additional actions you can take on files." 5163change the additional actions you can take on files."
5155 (interactive "P") 5164 (interactive "P")
5165 (unless pred
5166 (setq pred save-some-buffers-default-predicate))
5156 (save-window-excursion 5167 (save-window-excursion
5157 (let* (queried autosaved-buffers 5168 (let* (queried autosaved-buffers
5158 files-done abbrevs-done) 5169 files-done abbrevs-done)
@@ -6572,7 +6583,7 @@ normally equivalent short `-D' option is just passed on to
6572 (unless (equal switches "") 6583 (unless (equal switches "")
6573 ;; Split the switches at any spaces so we can 6584 ;; Split the switches at any spaces so we can
6574 ;; pass separate options as separate args. 6585 ;; pass separate options as separate args.
6575 (split-string switches))) 6586 (split-string-and-unquote switches)))
6576 ;; Avoid lossage if FILE starts with `-'. 6587 ;; Avoid lossage if FILE starts with `-'.
6577 '("--") 6588 '("--")
6578 (progn 6589 (progn
@@ -6812,6 +6823,8 @@ asks whether processes should be killed.
6812Runs the members of `kill-emacs-query-functions' in turn and stops 6823Runs the members of `kill-emacs-query-functions' in turn and stops
6813if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." 6824if any returns nil. If `confirm-kill-emacs' is non-nil, calls it."
6814 (interactive "P") 6825 (interactive "P")
6826 ;; Don't use save-some-buffers-default-predicate, because we want
6827 ;; to ask about all the buffers before killing Emacs.
6815 (save-some-buffers arg t) 6828 (save-some-buffers arg t)
6816 (let ((confirm confirm-kill-emacs)) 6829 (let ((confirm confirm-kill-emacs))
6817 (and 6830 (and
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 43e1231914c..a4ff840f755 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -1713,9 +1713,10 @@ regexp."
1713 ;; (modify-syntax-entry ?- "w" table) 1713 ;; (modify-syntax-entry ?- "w" table)
1714 (modify-syntax-entry ?> ")<" table) 1714 (modify-syntax-entry ?> ")<" table)
1715 (modify-syntax-entry ?< "(>" table) 1715 (modify-syntax-entry ?< "(>" table)
1716 ;; make M-. in article buffers work for `foo' strings 1716 ;; make M-. in article buffers work for `foo' strings,
1717 (modify-syntax-entry ?' " " table) 1717 ;; and still allow C-s C-w to yank ' to the search ring
1718 (modify-syntax-entry ?` " " table) 1718 (modify-syntax-entry ?' "'" table)
1719 (modify-syntax-entry ?` "'" table)
1719 table) 1720 table)
1720 "Syntax table used in article mode buffers. 1721 "Syntax table used in article mode buffers.
1721Initialized from `text-mode-syntax-table'.") 1722Initialized from `text-mode-syntax-table'.")
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index c6e5e471a36..71bf1d6dcc2 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1319,13 +1319,14 @@ a new window in the current frame, splitting vertically."
1319 (cl-assert (derived-mode-p 'ibuffer-mode))) 1319 (cl-assert (derived-mode-p 'ibuffer-mode)))
1320 1320
1321(defun ibuffer-buffer-file-name () 1321(defun ibuffer-buffer-file-name ()
1322 (or buffer-file-name 1322 (cond
1323 (let ((dirname (or (and (boundp 'dired-directory) 1323 ((buffer-file-name))
1324 (if (stringp dired-directory) 1324 ((bound-and-true-p list-buffers-directory))
1325 dired-directory 1325 ((let ((dirname (and (boundp 'dired-directory)
1326 (car dired-directory))) 1326 (if (stringp dired-directory)
1327 (bound-and-true-p list-buffers-directory)))) 1327 dired-directory
1328 (and dirname (expand-file-name dirname))))) 1328 (car dired-directory)))))
1329 (and dirname (expand-file-name dirname))))))
1329 1330
1330(define-ibuffer-op ibuffer-do-save () 1331(define-ibuffer-op ibuffer-do-save ()
1331 "Save marked buffers as with `save-buffer'." 1332 "Save marked buffers as with `save-buffer'."
diff --git a/lisp/image-dired.el b/lisp/image-dired.el
index 901225fa2e9..2a4064560a7 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -94,6 +94,7 @@
94;; * WARNING: The "database" format used might be changed so keep a 94;; * WARNING: The "database" format used might be changed so keep a
95;; backup of `image-dired-db-file' when testing new versions. 95;; backup of `image-dired-db-file' when testing new versions.
96;; 96;;
97;; * `image-dired-display-image-mode' does not support animation
97;; 98;;
98;; TODO 99;; TODO
99;; ==== 100;; ====
@@ -228,7 +229,7 @@ Used together with `image-dired-cmd-create-thumbnail-options'."
228 :group 'image-dired) 229 :group 'image-dired)
229 230
230(defcustom image-dired-cmd-create-thumbnail-options 231(defcustom image-dired-cmd-create-thumbnail-options
231 '("-size" "%wx%h" "%f" "-resize" "%wx%h>" "-strip" "jpeg:%t") 232 '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t")
232 "Options of command used to create thumbnail image. 233 "Options of command used to create thumbnail image.
233Used with `image-dired-cmd-create-thumbnail-program'. 234Used with `image-dired-cmd-create-thumbnail-program'.
234Available format specifiers are: %w which is replaced by 235Available format specifiers are: %w which is replaced by
@@ -246,7 +247,7 @@ Used together with `image-dired-cmd-create-temp-image-options'."
246 :group 'image-dired) 247 :group 'image-dired)
247 248
248(defcustom image-dired-cmd-create-temp-image-options 249(defcustom image-dired-cmd-create-temp-image-options
249 '("-size" "%wx%h" "%f" "-resize" "%wx%h>" "-strip" "jpeg:%t") 250 '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t")
250 "Options of command used to create temporary image for display window. 251 "Options of command used to create temporary image for display window.
251Used together with `image-dired-cmd-create-temp-image-program', 252Used together with `image-dired-cmd-create-temp-image-program',
252Available format specifiers are: %w and %h which are replaced by 253Available format specifiers are: %w and %h which are replaced by
@@ -316,7 +317,7 @@ Available format specifiers are described in
316 :group 'image-dired) 317 :group 'image-dired)
317 318
318(defcustom image-dired-cmd-create-standard-thumbnail-options 319(defcustom image-dired-cmd-create-standard-thumbnail-options
319 (append '("-size" "%wx%h" "%f") 320 (append '("-size" "%wx%h" "%f[0]")
320 (unless (or image-dired-cmd-pngcrush-program 321 (unless (or image-dired-cmd-pngcrush-program
321 image-dired-cmd-pngnq-program) 322 image-dired-cmd-pngnq-program)
322 (list 323 (list
@@ -1626,6 +1627,7 @@ Resized or in full-size."
1626 :group 'image-dired 1627 :group 'image-dired
1627 (buffer-disable-undo) 1628 (buffer-disable-undo)
1628 (image-mode-setup-winprops) 1629 (image-mode-setup-winprops)
1630 (setq cursor-type nil)
1629 (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)) 1631 (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t))
1630 1632
1631(defvar image-dired-minor-mode-map 1633(defvar image-dired-minor-mode-map
diff --git a/lisp/indent.el b/lisp/indent.el
index db31f0454ce..fdd184c7998 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
487 (if (memq (current-justification) '(center right)) 487 (if (memq (current-justification) '(center right))
488 (skip-chars-forward " \t"))) 488 (skip-chars-forward " \t")))
489 489
490(defvar indent-region-function nil 490(defvar indent-region-function #'indent-region-line-by-line
491 "Short cut function to indent region using `indent-according-to-mode'. 491 "Short cut function to indent region using `indent-according-to-mode'.
492A value of nil means really run `indent-according-to-mode' on each line.") 492Default is to really run `indent-according-to-mode' on each line.")
493 493
494(defun indent-region (start end &optional column) 494(defun indent-region (start end &optional column)
495 "Indent each nonblank line in the region. 495 "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."
541 (funcall indent-region-function start end)) 541 (funcall indent-region-function start end))
542 ;; Else, use a default implementation that calls indent-line-function on 542 ;; Else, use a default implementation that calls indent-line-function on
543 ;; each line. 543 ;; each line.
544 (t 544 (t (indent-region-line-by-line start end)))
545 (save-excursion
546 (setq end (copy-marker end))
547 (goto-char start)
548 (let ((pr (unless (minibufferp)
549 (make-progress-reporter "Indenting region..." (point) end))))
550 (while (< (point) end)
551 (or (and (bolp) (eolp))
552 (indent-according-to-mode))
553 (forward-line 1)
554 (and pr (progress-reporter-update pr (point))))
555 (and pr (progress-reporter-done pr))
556 (move-marker end nil)))))
557 ;; In most cases, reindenting modifies the buffer, but it may also 545 ;; In most cases, reindenting modifies the buffer, but it may also
558 ;; leave it unmodified, in which case we have to deactivate the mark 546 ;; leave it unmodified, in which case we have to deactivate the mark
559 ;; by hand. 547 ;; by hand.
560 (setq deactivate-mark t)) 548 (setq deactivate-mark t))
561 549
550(defun indent-region-line-by-line (start end)
551 (save-excursion
552 (setq end (copy-marker end))
553 (goto-char start)
554 (let ((pr (unless (minibufferp)
555 (make-progress-reporter "Indenting region..." (point) end))))
556 (while (< (point) end)
557 (or (and (bolp) (eolp))
558 (indent-according-to-mode))
559 (forward-line 1)
560 (and pr (progress-reporter-update pr (point))))
561 (and pr (progress-reporter-done pr))
562 (move-marker end nil))))
563
562(define-obsolete-function-alias 'indent-relative-maybe 564(define-obsolete-function-alias 'indent-relative-maybe
563 'indent-relative-first-indent-point "26.1") 565 'indent-relative-first-indent-point "26.1")
564 566
diff --git a/lisp/info.el b/lisp/info.el
index e32b6b35632..0cfcec32f82 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -1599,6 +1599,16 @@ escaped (\\\",\\\\)."
1599 parameter-alist)) 1599 parameter-alist))
1600 parameter-alist)) 1600 parameter-alist))
1601 1601
1602(defun Info-node-description (file)
1603 (cond
1604 ((equal file "dir") "*Info Directory*")
1605 ((eq file 'apropos) "*Info Apropos*")
1606 ((eq file 'history) "*Info History*")
1607 ((eq file 'toc) "*Info TOC*")
1608 ((not (stringp file)) "") ; Avoid errors
1609 (t
1610 (concat "(" (file-name-nondirectory file) ") " Info-current-node))))
1611
1602(defun Info-display-images-node () 1612(defun Info-display-images-node ()
1603 "Display images in current node." 1613 "Display images in current node."
1604 (save-excursion 1614 (save-excursion
@@ -1693,6 +1703,7 @@ escaped (\\\",\\\\)."
1693 (setq Info-history-forward nil)) 1703 (setq Info-history-forward nil))
1694 (if (not (eq Info-fontify-maximum-menu-size nil)) 1704 (if (not (eq Info-fontify-maximum-menu-size nil))
1695 (Info-fontify-node)) 1705 (Info-fontify-node))
1706 (setq list-buffers-directory (Info-node-description Info-current-file))
1696 (Info-display-images-node) 1707 (Info-display-images-node)
1697 (Info-hide-cookies-node) 1708 (Info-hide-cookies-node)
1698 (run-hooks 'Info-selection-hook))))) 1709 (run-hooks 'Info-selection-hook)))))
diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el
index aae751e8d2d..3f3990e8695 100644
--- a/lisp/mh-e/mh-compat.el
+++ b/lisp/mh-e/mh-compat.el
@@ -283,16 +283,6 @@ DOCSTRING arguments."
283See documentation for `make-obsolete-variable' for a description 283See documentation for `make-obsolete-variable' for a description
284of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN 284of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN
285and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and 285and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and
286ACCESS-TYPE arguments."
287 (if (featurep 'xemacs)
288 `(make-obsolete-variable ,obsolete-name ,current-name)
289 `(make-obsolete-variable ,obsolete-name ,current-name ,when ,access-type)))
290
291(defmacro mh-make-obsolete-variable (obsolete-name current-name &optional when access-type)
292 "Make the byte-compiler warn that OBSOLETE-NAME is obsolete.
293See documentation for `make-obsolete-variable' for a description
294of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN
295and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and
296ACCESS-TYPE arguments and by Emacs versions that lack ACCESS-TYPE, 286ACCESS-TYPE arguments and by Emacs versions that lack ACCESS-TYPE,
297introduced in Emacs 24." 287introduced in Emacs 24."
298 (if (featurep 'xemacs) 288 (if (featurep 'xemacs)
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index fc7fdd30850..48dcd5edd11 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -3614,18 +3614,36 @@ connection buffer."
3614 3614
3615;;; Utility functions: 3615;;; Utility functions:
3616 3616
3617(defun tramp-accept-process-output (&optional proc timeout timeout-msecs) 3617(defun tramp-accept-process-output (proc timeout)
3618 "Like `accept-process-output' for Tramp processes. 3618 "Like `accept-process-output' for Tramp processes.
3619This is needed in order to hide `last-coding-system-used', which is set 3619This is needed in order to hide `last-coding-system-used', which is set
3620for process communication also." 3620for process communication also."
3621 ;; FIXME: There are problems, when an asynchronous process runs in
3622 ;; parallel, and also timers are active. See
3623 ;; <http://lists.gnu.org/archive/html/tramp-devel/2017-01/msg00010.html>.
3624 (when (and timer-event-last
3625 (string-prefix-p "*tramp/" (process-name proc))
3626 (let (result)
3627 (maphash
3628 (lambda (key _value)
3629 (and (processp key)
3630 (not (string-prefix-p "*tramp/" (process-name key)))
3631 (tramp-compat-process-live-p key)
3632 (setq result t)))
3633 tramp-cache-data)
3634 result))
3635 (sit-for 0.01 'nodisp))
3621 (with-current-buffer (process-buffer proc) 3636 (with-current-buffer (process-buffer proc)
3622 (let (buffer-read-only last-coding-system-used) 3637 (let (buffer-read-only last-coding-system-used)
3623 ;; Under Windows XP, accept-process-output doesn't return 3638 ;; Under Windows XP, accept-process-output doesn't return
3624 ;; sometimes. So we add an additional timeout. 3639 ;; sometimes. So we add an additional timeout. JUST-THIS-ONE
3625 (with-timeout ((or timeout 1)) 3640 ;; is set due to Bug#12145.
3626 (accept-process-output proc timeout timeout-msecs (and proc t))) 3641 (tramp-message
3627 (tramp-message proc 10 "%s %s\n%s" 3642 proc 10 "%s %s %s\n%s"
3628 proc (process-status proc) (buffer-string))))) 3643 proc (process-status proc)
3644 (with-timeout (timeout)
3645 (accept-process-output proc timeout nil t))
3646 (buffer-string)))))
3629 3647
3630(defun tramp-check-for-regexp (proc regexp) 3648(defun tramp-check-for-regexp (proc regexp)
3631 "Check, whether REGEXP is contained in process buffer of PROC. 3649 "Check, whether REGEXP is contained in process buffer of PROC.
diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el
index 7cb36c4396b..0f7e4b598dc 100644
--- a/lisp/progmodes/cc-align.el
+++ b/lisp/progmodes/cc-align.el
@@ -1221,6 +1221,18 @@ Works with: arglist-cont, arglist-cont-nonempty."
1221 1221
1222 (vector (progn (goto-char alignto) (current-column))))))) 1222 (vector (progn (goto-char alignto) (current-column)))))))
1223 1223
1224(defun c-lineup-under-anchor (langelem)
1225 "Line up the current line directly under the anchor position in LANGELEM.
1226
1227This is like 0, except it supersedes any indentation already calculated for
1228previous syntactic elements in the syntactic context.
1229
1230Works with: Any syntactic symbol which has an anchor position."
1231 (save-excursion
1232 (goto-char (c-langelem-pos langelem))
1233 (vector (current-column))))
1234
1235
1224(defun c-lineup-dont-change (langelem) 1236(defun c-lineup-dont-change (langelem)
1225 "Do not change the indentation of the current line. 1237 "Do not change the indentation of the current line.
1226 1238
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index fd7aa50840f..dfd7aebd569 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."
10260 (t nil))))) 10260 (t nil)))))
10261 10261
10262 (setq pos (point)) 10262 (setq pos (point))
10263 (if (and after-type-id-pos 10263 (cond
10264 (goto-char after-type-id-pos) 10264 ((and after-type-id-pos
10265 (setq res (c-back-over-member-initializers)) 10265 (goto-char after-type-id-pos)
10266 (goto-char res) 10266 (setq res (c-back-over-member-initializers))
10267 (eq (car (c-beginning-of-decl-1 lim)) 'same)) 10267 (goto-char res)
10268 (cons (point) nil) ; Return value. 10268 (eq (car (c-beginning-of-decl-1 lim)) 'same))
10269 10269 (cons (point) nil)) ; Return value.
10270
10271 ((and after-type-id-pos
10272 (progn
10273 (c-backward-syntactic-ws)
10274 (eq (char-before) ?\()))
10275 ;; Single identifier between '(' and '{'. We have a bracelist.
10276 (cons after-type-id-pos nil))
10277
10278 (t
10270 (goto-char pos) 10279 (goto-char pos)
10271 ;; Checks to do on all sexps before the brace, up to the 10280 ;; Checks to do on all sexps before the brace, up to the
10272 ;; beginning of the statement. 10281 ;; beginning of the statement.
@@ -10368,7 +10377,7 @@ comment at the start of cc-engine.el for more info."
10368 ; languages where 10377 ; languages where
10369 ; `c-opt-inexpr-brace-list-key' is 10378 ; `c-opt-inexpr-brace-list-key' is
10370 ; non-nil and we have macros. 10379 ; non-nil and we have macros.
10371 (t t))) ;; The caller can go up one level. 10380 (t t)))) ;; The caller can go up one level.
10372 ))) 10381 )))
10373 10382
10374(defun c-inside-bracelist-p (containing-sexp paren-state) 10383(defun c-inside-bracelist-p (containing-sexp paren-state)
@@ -10493,6 +10502,30 @@ comment at the start of cc-engine.el for more info."
10493 (c-at-statement-start-p)) 10502 (c-at-statement-start-p))
10494(make-obsolete 'c-looking-at-bos 'c-at-statement-start-p "22.1") 10503(make-obsolete 'c-looking-at-bos 'c-at-statement-start-p "22.1")
10495 10504
10505(defun c-looking-at-statement-block ()
10506 ;; Point is at an opening brace. If this is a statement block (i.e. the
10507 ;; elements in it are terminated by semicolons) return t. Otherwise, return
10508 ;; nil.
10509 (let ((here (point)))
10510 (prog1
10511 (if (c-go-list-forward)
10512 (let ((there (point)))
10513 (backward-char)
10514 (c-syntactic-skip-backward
10515 "^;," here t)
10516 (cond
10517 ((eq (char-before) ?\;) t)
10518 ((eq (char-before) ?,) nil)
10519 (t (goto-char here)
10520 (forward-char)
10521 (and (c-syntactic-re-search-forward "{" there t t)
10522 (progn (backward-char)
10523 (c-looking-at-statement-block))))))
10524 (forward-char)
10525 (and (c-syntactic-re-search-forward "[;,]" nil t t)
10526 (eq (char-before) ?\;)))
10527 (goto-char here))))
10528
10496(defun c-looking-at-inexpr-block (lim containing-sexp &optional check-at-end) 10529(defun c-looking-at-inexpr-block (lim containing-sexp &optional check-at-end)
10497 ;; Return non-nil if we're looking at the beginning of a block 10530 ;; Return non-nil if we're looking at the beginning of a block
10498 ;; inside an expression. The value returned is actually a cons of 10531 ;; 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."
10648 (and (c-major-mode-is 'c++-mode) 10681 (and (c-major-mode-is 'c++-mode)
10649 (save-excursion 10682 (save-excursion
10650 (goto-char block-follows) 10683 (goto-char block-follows)
10651 (if (c-go-list-forward) 10684 (not (c-looking-at-statement-block)))))
10652 (progn
10653 (backward-char)
10654 (c-syntactic-skip-backward
10655 "^;," block-follows t)
10656 (not (eq (char-before) ?\;)))
10657 (or (not (c-syntactic-re-search-forward
10658 "[;,]" nil t t))
10659 (not (eq (char-before) ?\;)))))))
10660 nil 10685 nil
10661 (cons 'inexpr-statement (point))))) 10686 (cons 'inexpr-statement (point)))))
10662 10687
@@ -10792,17 +10817,20 @@ comment at the start of cc-engine.el for more info."
10792 syntax-extra-args 10817 syntax-extra-args
10793 stop-at-boi-only 10818 stop-at-boi-only
10794 containing-sexp 10819 containing-sexp
10795 paren-state) 10820 paren-state
10821 &optional fixed-anchor)
10796 ;; Add the indicated SYNTAX-SYMBOL to `c-syntactic-context', extending it as 10822 ;; Add the indicated SYNTAX-SYMBOL to `c-syntactic-context', extending it as
10797 ;; needed with further syntax elements of the types `substatement', 10823 ;; needed with further syntax elements of the types `substatement',
10798 ;; `inexpr-statement', `arglist-cont-nonempty', `statement-block-intro', and 10824 ;; `inexpr-statement', `arglist-cont-nonempty', `statement-block-intro',
10799 ;; `defun-block-intro'. 10825 ;; `defun-block-intro', and `brace-list-intro'.
10800 ;; 10826 ;;
10801 ;; Do the generic processing to anchor the given syntax symbol on 10827 ;; Do the generic processing to anchor the given syntax symbol on the
10802 ;; the preceding statement: Skip over any labels and containing 10828 ;; preceding statement: First skip over any labels and containing statements
10803 ;; statements on the same line, and then search backward until we 10829 ;; on the same line. If FIXED-ANCHOR is non-nil, use this as the
10804 ;; find a statement or block start that begins at boi without a 10830 ;; anchor-point for the given syntactic symbol, and don't make syntactic
10805 ;; label or comment. 10831 ;; entries for constructs beginning on lines before that containing
10832 ;; ANCHOR-POINT. Otherwise search backward until we find a statement or
10833 ;; block start that begins at boi without a label or comment.
10806 ;; 10834 ;;
10807 ;; Point is assumed to be at the prospective anchor point for the 10835 ;; Point is assumed to be at the prospective anchor point for the
10808 ;; given SYNTAX-SYMBOL. More syntax entries are added if we need to 10836 ;; 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."
10831 10859
10832 (let ((syntax-last c-syntactic-context) 10860 (let ((syntax-last c-syntactic-context)
10833 (boi (c-point 'boi)) 10861 (boi (c-point 'boi))
10862 (anchor-boi (c-point 'boi))
10834 ;; Set when we're on a label, so that we don't stop there. 10863 ;; Set when we're on a label, so that we don't stop there.
10835 ;; FIXME: To be complete we should check if we're on a label 10864 ;; FIXME: To be complete we should check if we're on a label
10836 ;; now at the start. 10865 ;; now at the start.
@@ -10908,7 +10937,9 @@ comment at the start of cc-engine.el for more info."
10908 (c-add-syntax 'substatement nil)))) 10937 (c-add-syntax 'substatement nil))))
10909 ))) 10938 )))
10910 10939
10911 containing-sexp) 10940 containing-sexp
10941 (or (null fixed-anchor)
10942 (> containing-sexp anchor-boi)))
10912 10943
10913 ;; Now we have to go out of this block. 10944 ;; Now we have to go out of this block.
10914 (goto-char containing-sexp) 10945 (goto-char containing-sexp)
@@ -10982,6 +11013,14 @@ comment at the start of cc-engine.el for more info."
10982 (cdr (assoc (match-string 1) 11013 (cdr (assoc (match-string 1)
10983 c-other-decl-block-key-in-symbols-alist)) 11014 c-other-decl-block-key-in-symbols-alist))
10984 (max (c-point 'boi paren-pos) (point)))) 11015 (max (c-point 'boi paren-pos) (point))))
11016 ((save-excursion
11017 (goto-char paren-pos)
11018 (c-looking-at-or-maybe-in-bracelist containing-sexp))
11019 (if (save-excursion
11020 (goto-char paren-pos)
11021 (c-looking-at-statement-block))
11022 (c-add-syntax 'defun-block-intro nil)
11023 (c-add-syntax 'brace-list-intro nil)))
10985 (t (c-add-syntax 'defun-block-intro nil)))) 11024 (t (c-add-syntax 'defun-block-intro nil))))
10986 11025
10987 (c-add-syntax 'statement-block-intro nil))) 11026 (c-add-syntax 'statement-block-intro nil)))
@@ -11001,7 +11040,10 @@ comment at the start of cc-engine.el for more info."
11001 (setq q (cdr (car p))) ; e.g. (nil 28) [from (arglist-cont-nonempty nil 28)] 11040 (setq q (cdr (car p))) ; e.g. (nil 28) [from (arglist-cont-nonempty nil 28)]
11002 (while q 11041 (while q
11003 (unless (car q) 11042 (unless (car q)
11004 (setcar q (point))) 11043 (setcar q (if (or (cdr p)
11044 (null fixed-anchor))
11045 (point)
11046 fixed-anchor)))
11005 (setq q (cdr q))) 11047 (setq q (cdr q)))
11006 (setq p (cdr p)))) 11048 (setq p (cdr p))))
11007 ))) 11049 )))
@@ -12354,7 +12396,8 @@ comment at the start of cc-engine.el for more info."
12354 (c-forward-syntactic-ws (c-point 'eol)) 12396 (c-forward-syntactic-ws (c-point 'eol))
12355 (c-looking-at-special-brace-list (point))))) 12397 (c-looking-at-special-brace-list (point)))))
12356 (c-add-syntax 'brace-entry-open (point)) 12398 (c-add-syntax 'brace-entry-open (point))
12357 (c-add-syntax 'brace-list-entry (point)) 12399 (c-add-stmt-syntax 'brace-list-entry nil t containing-sexp
12400 paren-state (point))
12358 )) 12401 ))
12359 )))) 12402 ))))
12360 12403
@@ -12848,7 +12891,7 @@ Cannot combine absolute offsets %S and %S in `add' method"
12848 ;; 12891 ;;
12849 ;; Note that topmost-intro always has an anchor position at bol, for 12892 ;; Note that topmost-intro always has an anchor position at bol, for
12850 ;; historical reasons. It's often used together with other symbols 12893 ;; historical reasons. It's often used together with other symbols
12851 ;; that has more sane positions. Since we always use the first 12894 ;; that have more sane positions. Since we always use the first
12852 ;; found anchor position, we rely on that these other symbols always 12895 ;; found anchor position, we rely on that these other symbols always
12853 ;; precede topmost-intro in the LANGELEMS list. 12896 ;; precede topmost-intro in the LANGELEMS list.
12854 ;; 12897 ;;
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index d3505490505..b3848a74f97 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -67,6 +67,7 @@
67 (arglist-close . c-lineup-arglist) 67 (arglist-close . c-lineup-arglist)
68 (inline-open . 0) 68 (inline-open . 0)
69 (brace-list-open . +) 69 (brace-list-open . +)
70 (brace-list-intro . c-lineup-arglist-intro-after-paren)
70 (topmost-intro-cont 71 (topmost-intro-cont
71 . (first c-lineup-topmost-intro-cont 72 . (first c-lineup-topmost-intro-cont
72 c-lineup-gnu-DEFUN-intro-cont)))) 73 c-lineup-gnu-DEFUN-intro-cont))))
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index a6a96d15188..1114b21381d 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
1115 ;; Anchor pos: At the brace list decl start(*). 1115 ;; Anchor pos: At the brace list decl start(*).
1116 (brace-list-intro . +) 1116 (brace-list-intro . +)
1117 ;; Anchor pos: At the brace list decl start(*). 1117 ;; Anchor pos: At the brace list decl start(*).
1118 (brace-list-entry . 0) 1118 (brace-list-entry . c-lineup-under-anchor)
1119 ;; Anchor pos: At the first non-ws char after the open paren if 1119 ;; Anchor pos: At the first non-ws char after the open paren if
1120 ;; the first token is on the same line, otherwise boi at that 1120 ;; the first token is on the same line, otherwise boi at that
1121 ;; token. 1121 ;; token.
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 74dd4add9e2..e42e01481b6 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -3849,6 +3849,7 @@ If one hasn't been set, or if it's stale, prompt for a new one."
3849 comment-start-skip "\\(//+\\|/\\*+\\)\\s *") 3849 comment-start-skip "\\(//+\\|/\\*+\\)\\s *")
3850 (setq-local comment-line-break-function #'c-indent-new-comment-line) 3850 (setq-local comment-line-break-function #'c-indent-new-comment-line)
3851 (setq-local c-block-comment-start-regexp "/\\*") 3851 (setq-local c-block-comment-start-regexp "/\\*")
3852 (setq-local comment-multi-line t)
3852 3853
3853 (setq-local electric-indent-chars 3854 (setq-local electric-indent-chars
3854 (append "{}():;," electric-indent-chars)) ;FIXME: js2-mode adds "[]*". 3855 (append "{}():;," electric-indent-chars)) ;FIXME: js2-mode adds "[]*".
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index a507755d42e..a8933b0103e 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -918,11 +918,7 @@ IGNORES is a list of glob patterns."
918 (grep-compute-defaults) 918 (grep-compute-defaults)
919 (defvar grep-find-template) 919 (defvar grep-find-template)
920 (defvar grep-highlight-matches) 920 (defvar grep-highlight-matches)
921 ;; 'grep -E -foo' results in 'grep: oo: No such file or directory'. 921 (let* ((grep-find-template (replace-regexp-in-string "<C>" "<C> -E"
922 ;; while 'grep -e -foo' inexplicably doesn't.
923 (when (eq (aref regexp 0) ?-)
924 (setq regexp (concat "\\" regexp)))
925 (let* ((grep-find-template (replace-regexp-in-string "-e " "-E "
926 grep-find-template t t)) 922 grep-find-template t t))
927 (grep-highlight-matches nil) 923 (grep-highlight-matches nil)
928 (command (xref--rgrep-command (xref--regexp-to-extended regexp) 924 (command (xref--rgrep-command (xref--regexp-to-extended regexp)
diff --git a/lisp/replace.el b/lisp/replace.el
index ff917344453..a825040a979 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."
1304 :type 'face 1304 :type 'face
1305 :group 'matching) 1305 :group 'matching)
1306 1306
1307(defcustom list-matching-lines-current-line-face 'lazy-highlight
1308 "Face used by \\[list-matching-lines] to highlight the current line."
1309 :type 'face
1310 :group 'matching
1311 :version "26.1")
1312
1313(defcustom list-matching-lines-jump-to-current-line nil
1314 "If non-nil, \\[list-matching-lines] shows the current line highlighted.
1315Set the point right after such line when there are matches after it."
1316:type 'boolean
1317:group 'matching
1318:version "26.1")
1319
1307(defcustom list-matching-lines-prefix-face 'shadow 1320(defcustom list-matching-lines-prefix-face 'shadow
1308 "Face used by \\[list-matching-lines] to show the prefix column. 1321 "Face used by \\[list-matching-lines] to show the prefix column.
1309If the face doesn't differ from the default face, 1322If the face doesn't differ from the default face,
@@ -1360,7 +1373,15 @@ invoke `occur'."
1360 "*") 1373 "*")
1361 (or unique-p (not interactive-p))))) 1374 (or unique-p (not interactive-p)))))
1362 1375
1363(defun occur (regexp &optional nlines) 1376;; Region limits when `occur' applies on a region.
1377(defvar occur--region-start nil)
1378(defvar occur--region-end nil)
1379(defvar occur--matches-threshold nil)
1380(defvar occur--orig-line nil)
1381(defvar occur--orig-line-str nil)
1382(defvar occur--final-pos nil)
1383
1384(defun occur (regexp &optional nlines region)
1364 "Show all lines in the current buffer containing a match for REGEXP. 1385 "Show all lines in the current buffer containing a match for REGEXP.
1365If a match spreads across multiple lines, all those lines are shown. 1386If a match spreads across multiple lines, all those lines are shown.
1366 1387
@@ -1369,9 +1390,17 @@ before if NLINES is negative.
1369NLINES defaults to `list-matching-lines-default-context-lines'. 1390NLINES defaults to `list-matching-lines-default-context-lines'.
1370Interactively it is the prefix arg. 1391Interactively it is the prefix arg.
1371 1392
1393Optional arg REGION, if non-nil, mean restrict search to the
1394specified region. Otherwise search the entire buffer.
1395REGION must be a list of (START . END) positions as returned by
1396`region-bounds'.
1397
1372The lines are shown in a buffer named `*Occur*'. 1398The lines are shown in a buffer named `*Occur*'.
1373It serves as a menu to find any of the occurrences in this buffer. 1399It serves as a menu to find any of the occurrences in this buffer.
1374\\<occur-mode-map>\\[describe-mode] in that buffer will explain how. 1400\\<occur-mode-map>\\[describe-mode] in that buffer will explain how.
1401If `list-matching-lines-jump-to-current-line' is non-nil, then show
1402the current line highlighted with `list-matching-lines-current-line-face'
1403and set point at the first match after such line.
1375 1404
1376If REGEXP contains upper case characters (excluding those preceded by `\\') 1405If REGEXP contains upper case characters (excluding those preceded by `\\')
1377and `search-upper-case' is non-nil, the matching is case-sensitive. 1406and `search-upper-case' is non-nil, the matching is case-sensitive.
@@ -1386,8 +1415,30 @@ For example, providing \"defun\\s +\\(\\S +\\)\" for REGEXP and
1386program. When there is no parenthesized subexpressions in REGEXP 1415program. When there is no parenthesized subexpressions in REGEXP
1387the entire match is collected. In any case the searched buffer 1416the entire match is collected. In any case the searched buffer
1388is not modified." 1417is not modified."
1389 (interactive (occur-read-primary-args)) 1418 (interactive
1390 (occur-1 regexp nlines (list (current-buffer)))) 1419 (nconc (occur-read-primary-args)
1420 (and (use-region-p) (list (region-bounds)))))
1421 (let* ((start (and (caar region) (max (caar region) (point-min))))
1422 (end (and (cdar region) (min (cdar region) (point-max))))
1423 (in-region-p (or start end)))
1424 (when in-region-p
1425 (or start (setq start (point-min)))
1426 (or end (setq end (point-max))))
1427 (let ((occur--region-start start)
1428 (occur--region-end end)
1429 (occur--matches-threshold
1430 (and in-region-p
1431 (line-number-at-pos (min start end))))
1432 (occur--orig-line
1433 (line-number-at-pos (point)))
1434 (occur--orig-line-str
1435 (buffer-substring-no-properties
1436 (line-beginning-position)
1437 (line-end-position))))
1438 (save-excursion ; If no matches `occur-1' doesn't restore the point.
1439 (and in-region-p (narrow-to-region start end))
1440 (occur-1 regexp nlines (list (current-buffer)))
1441 (and in-region-p (widen))))))
1391 1442
1392(defvar ido-ignore-item-temp-list) 1443(defvar ido-ignore-item-temp-list)
1393 1444
@@ -1482,7 +1533,8 @@ See also `multi-occur'."
1482 (occur-mode)) 1533 (occur-mode))
1483 (let ((inhibit-read-only t) 1534 (let ((inhibit-read-only t)
1484 ;; Don't generate undo entries for creation of the initial contents. 1535 ;; Don't generate undo entries for creation of the initial contents.
1485 (buffer-undo-list t)) 1536 (buffer-undo-list t)
1537 (occur--final-pos nil))
1486 (erase-buffer) 1538 (erase-buffer)
1487 (let ((count 1539 (let ((count
1488 (if (stringp nlines) 1540 (if (stringp nlines)
@@ -1534,6 +1586,10 @@ See also `multi-occur'."
1534 (if (= count 0) 1586 (if (= count 0)
1535 (kill-buffer occur-buf) 1587 (kill-buffer occur-buf)
1536 (display-buffer occur-buf) 1588 (display-buffer occur-buf)
1589 (when occur--final-pos
1590 (set-window-point
1591 (get-buffer-window occur-buf 'all-frames)
1592 occur--final-pos))
1537 (setq next-error-last-buffer occur-buf) 1593 (setq next-error-last-buffer occur-buf)
1538 (setq buffer-read-only t) 1594 (setq buffer-read-only t)
1539 (set-buffer-modified-p nil) 1595 (set-buffer-modified-p nil)
@@ -1545,19 +1601,26 @@ See also `multi-occur'."
1545 (let ((global-lines 0) ;; total count of matching lines 1601 (let ((global-lines 0) ;; total count of matching lines
1546 (global-matches 0) ;; total count of matches 1602 (global-matches 0) ;; total count of matches
1547 (coding nil) 1603 (coding nil)
1548 (case-fold-search case-fold)) 1604 (case-fold-search case-fold)
1605 (in-region-p (and occur--region-start occur--region-end))
1606 (multi-occur-p (cdr buffers)))
1549 ;; Map over all the buffers 1607 ;; Map over all the buffers
1550 (dolist (buf buffers) 1608 (dolist (buf buffers)
1551 (when (buffer-live-p buf) 1609 (when (buffer-live-p buf)
1552 (let ((lines 0) ;; count of matching lines 1610 (let ((lines 0) ;; count of matching lines
1553 (matches 0) ;; count of matches 1611 (matches 0) ;; count of matches
1554 (curr-line 1) ;; line count 1612 (curr-line ;; line count
1613 (or occur--matches-threshold 1))
1614 (orig-line occur--orig-line)
1615 (orig-line-str occur--orig-line-str)
1616 (orig-line-shown-p)
1555 (prev-line nil) ;; line number of prev match endpt 1617 (prev-line nil) ;; line number of prev match endpt
1556 (prev-after-lines nil) ;; context lines of prev match 1618 (prev-after-lines nil) ;; context lines of prev match
1557 (matchbeg 0) 1619 (matchbeg 0)
1558 (origpt nil) 1620 (origpt nil)
1559 (begpt nil) 1621 (begpt nil)
1560 (endpt nil) 1622 (endpt nil)
1623 (finalpt nil)
1561 (marker nil) 1624 (marker nil)
1562 (curstring "") 1625 (curstring "")
1563 (ret nil) 1626 (ret nil)
@@ -1658,6 +1721,18 @@ See also `multi-occur'."
1658 (nth 0 ret)))) 1721 (nth 0 ret))))
1659 ;; Actually insert the match display data 1722 ;; Actually insert the match display data
1660 (with-current-buffer out-buf 1723 (with-current-buffer out-buf
1724 (when (and list-matching-lines-jump-to-current-line
1725 (not multi-occur-p)
1726 (not orig-line-shown-p)
1727 (>= curr-line orig-line))
1728 (insert
1729 (concat
1730 (propertize
1731 (format "%7d:%s" orig-line orig-line-str)
1732 'face list-matching-lines-current-line-face
1733 'mouse-face 'mode-line-highlight
1734 'help-echo "Current line") "\n"))
1735 (setq orig-line-shown-p t finalpt (point)))
1661 (insert data))) 1736 (insert data)))
1662 (goto-char endpt)) 1737 (goto-char endpt))
1663 (if endpt 1738 (if endpt
@@ -1671,6 +1746,18 @@ See also `multi-occur'."
1671 (forward-line 1)) 1746 (forward-line 1))
1672 (goto-char (point-max))) 1747 (goto-char (point-max)))
1673 (setq prev-line (1- curr-line))) 1748 (setq prev-line (1- curr-line)))
1749 ;; Insert original line if haven't done yet.
1750 (when (and list-matching-lines-jump-to-current-line
1751 (not multi-occur-p)
1752 (not orig-line-shown-p))
1753 (with-current-buffer out-buf
1754 (insert
1755 (concat
1756 (propertize
1757 (format "%7d:%s" orig-line orig-line-str)
1758 'face list-matching-lines-current-line-face
1759 'mouse-face 'mode-line-highlight
1760 'help-echo "Current line") "\n"))))
1674 ;; Flush remaining context after-lines. 1761 ;; Flush remaining context after-lines.
1675 (when prev-after-lines 1762 (when prev-after-lines
1676 (with-current-buffer out-buf 1763 (with-current-buffer out-buf
@@ -1684,7 +1771,7 @@ See also `multi-occur'."
1684 (let ((beg (point)) 1771 (let ((beg (point))
1685 end) 1772 end)
1686 (insert (propertize 1773 (insert (propertize
1687 (format "%d match%s%s%s in buffer: %s\n" 1774 (format "%d match%s%s%s in buffer: %s%s\n"
1688 matches (if (= matches 1) "" "es") 1775 matches (if (= matches 1) "" "es")
1689 ;; Don't display the same number of lines 1776 ;; Don't display the same number of lines
1690 ;; and matches in case of 1 match per line. 1777 ;; and matches in case of 1 match per line.
@@ -1694,13 +1781,21 @@ See also `multi-occur'."
1694 ;; Don't display regexp for multi-buffer. 1781 ;; Don't display regexp for multi-buffer.
1695 (if (> (length buffers) 1) 1782 (if (> (length buffers) 1)
1696 "" (occur-regexp-descr regexp)) 1783 "" (occur-regexp-descr regexp))
1697 (buffer-name buf)) 1784 (buffer-name buf)
1785 (if in-region-p
1786 (format " within region: %d-%d"
1787 occur--region-start
1788 occur--region-end)
1789 ""))
1698 'read-only t)) 1790 'read-only t))
1699 (setq end (point)) 1791 (setq end (point))
1700 (add-text-properties beg end `(occur-title ,buf)) 1792 (add-text-properties beg end `(occur-title ,buf))
1701 (when title-face 1793 (when title-face
1702 (add-face-text-property beg end title-face))) 1794 (add-face-text-property beg end title-face))
1703 (goto-char (point-min))))))) 1795 (goto-char (if finalpt
1796 (setq occur--final-pos
1797 (cl-incf finalpt (- end beg)))
1798 (point-min)))))))))
1704 ;; Display total match count and regexp for multi-buffer. 1799 ;; Display total match count and regexp for multi-buffer.
1705 (when (and (not (zerop global-lines)) (> (length buffers) 1)) 1800 (when (and (not (zerop global-lines)) (> (length buffers) 1))
1706 (goto-char (point-min)) 1801 (goto-char (point-min))
diff --git a/lisp/subr.el b/lisp/subr.el
index a6ba05c2021..a204577ddf9 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1417,8 +1417,10 @@ be a list of the form returned by `event-start' and `event-end'."
1417;; bug#23850 1417;; bug#23850
1418(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") 1418(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1")
1419(make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1") 1419(make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1")
1420(make-obsolete 'string-make-unibyte "use `encode-coding-string'." "26.1")
1420(make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1") 1421(make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1")
1421(make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1") 1422(make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1")
1423(make-obsolete 'string-make-multibyte "use `decode-coding-string'." "26.1")
1422 1424
1423(defun log10 (x) 1425(defun log10 (x)
1424 "Return (log X 10), the log base 10 of X." 1426 "Return (log X 10), the log base 10 of X."
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index c81c3f62e16..0c7d76f7924 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -32,9 +32,11 @@
32 32
33;;; Code: 33;;; Code:
34 34
35(require 'eww)
35(require 'seq) 36(require 'seq)
36(require 'sgml-mode) 37(require 'sgml-mode)
37(require 'smie) 38(require 'smie)
39(require 'subr-x)
38 40
39(defgroup css nil 41(defgroup css nil
40 "Cascading Style Sheets (CSS) editing mode." 42 "Cascading Style Sheets (CSS) editing mode."
@@ -621,6 +623,12 @@ cannot be completed sensibly: `custom-ident',
621 (modify-syntax-entry ?- "_" st) 623 (modify-syntax-entry ?- "_" st)
622 st)) 624 st))
623 625
626(defvar css-mode-map
627 (let ((map (make-sparse-keymap)))
628 (define-key map [remap info-lookup-symbol] 'css-lookup-symbol)
629 map)
630 "Keymap used in `css-mode'.")
631
624(eval-and-compile 632(eval-and-compile
625 (defconst css--uri-re 633 (defconst css--uri-re
626 (concat 634 (concat
@@ -734,7 +742,30 @@ cannot be completed sensibly: `custom-ident',
734 742
735(defconst css-smie-grammar 743(defconst css-smie-grammar
736 (smie-prec2->grammar 744 (smie-prec2->grammar
737 (smie-precs->prec2 '((assoc ";") (assoc ",") (left ":"))))) 745 (smie-precs->prec2
746 '((assoc ";")
747 ;; Colons that belong to a CSS property. These get a higher
748 ;; precedence than other colons, such as colons in selectors,
749 ;; which are represented by a plain ":" token.
750 (left ":-property")
751 (assoc ",")
752 (assoc ":")))))
753
754(defun css--colon-inside-selector-p ()
755 "Return t if point looks to be inside a CSS selector.
756This function is intended to be good enough to help SMIE during
757tokenization, but should not be regarded as a reliable function
758for determining whether point is within a selector."
759 (save-excursion
760 (re-search-forward "[{};)]" nil t)
761 (eq (char-before) ?\{)))
762
763(defun css--colon-inside-funcall ()
764 "Return t if point is inside a function call."
765 (when-let (opening-paren-pos (nth 1 (syntax-ppss)))
766 (save-excursion
767 (goto-char opening-paren-pos)
768 (eq (char-after) ?\())))
738 769
739(defun css-smie--forward-token () 770(defun css-smie--forward-token ()
740 (cond 771 (cond
@@ -748,7 +779,13 @@ cannot be completed sensibly: `custom-ident',
748 ";") 779 ";")
749 ((progn (forward-comment (point-max)) 780 ((progn (forward-comment (point-max))
750 (looking-at "[;,:]")) 781 (looking-at "[;,:]"))
751 (forward-char 1) (match-string 0)) 782 (forward-char 1)
783 (if (equal (match-string 0) ":")
784 (if (or (css--colon-inside-selector-p)
785 (css--colon-inside-funcall))
786 ":"
787 ":-property")
788 (match-string 0)))
752 (t (smie-default-forward-token)))) 789 (t (smie-default-forward-token))))
753 790
754(defun css-smie--backward-token () 791(defun css-smie--backward-token ()
@@ -759,7 +796,13 @@ cannot be completed sensibly: `custom-ident',
759 ((and (eq (char-before) ?\}) (scss-smie--not-interpolation-p) 796 ((and (eq (char-before) ?\}) (scss-smie--not-interpolation-p)
760 (> pos (point))) ";") 797 (> pos (point))) ";")
761 ((memq (char-before) '(?\; ?\, ?\:)) 798 ((memq (char-before) '(?\; ?\, ?\:))
762 (forward-char -1) (string (char-after))) 799 (forward-char -1)
800 (if (eq (char-after) ?\:)
801 (if (or (css--colon-inside-selector-p)
802 (css--colon-inside-funcall))
803 ":"
804 ":-property")
805 (string (char-after))))
763 (t (smie-default-backward-token))))) 806 (t (smie-default-backward-token)))))
764 807
765(defun css-smie-rules (kind token) 808(defun css-smie-rules (kind token)
@@ -1087,5 +1130,112 @@ pseudo-elements, pseudo-classes, at-rules, and bang-rules."
1087 (setq-local font-lock-defaults 1130 (setq-local font-lock-defaults
1088 (list (scss-font-lock-keywords) nil t))) 1131 (list (scss-font-lock-keywords) nil t)))
1089 1132
1133
1134
1135(defvar css--mdn-lookup-history nil)
1136
1137(defcustom css-lookup-url-format
1138 "https://developer.mozilla.org/en-US/docs/Web/CSS/%s?raw&macros"
1139 "Format for a URL where CSS documentation can be found.
1140The format should include a single \"%s\" substitution.
1141The name of the CSS property, @-id, pseudo-class, or pseudo-element
1142to look up will be substituted there."
1143 :version "26.1"
1144 :type 'string
1145 :group 'css)
1146
1147(defun css--mdn-after-render ()
1148 (setf header-line-format nil)
1149 (goto-char (point-min))
1150 (let ((window (get-buffer-window (current-buffer) 'visible)))
1151 (when window
1152 (when (re-search-forward "^Summary" nil 'move)
1153 (beginning-of-line)
1154 (set-window-start window (point))))))
1155
1156(defconst css--mdn-symbol-regexp
1157 (concat "\\("
1158 ;; @-ids.
1159 "\\(@" (regexp-opt css-at-ids) "\\)"
1160 "\\|"
1161 ;; ;; Known properties.
1162 (regexp-opt css-property-ids t)
1163 "\\|"
1164 ;; Pseudo-classes.
1165 "\\(:" (regexp-opt css-pseudo-class-ids) "\\)"
1166 "\\|"
1167 ;; Pseudo-elements with either one or two ":"s.
1168 "\\(::?" (regexp-opt css-pseudo-element-ids) "\\)"
1169 "\\)")
1170 "Regular expression to match the CSS symbol at point.")
1171
1172(defconst css--mdn-property-regexp
1173 (concat "\\_<" (regexp-opt css-property-ids t) "\\s-*\\(?:\\=\\|:\\)")
1174 "Regular expression to match a CSS property.")
1175
1176(defconst css--mdn-completion-list
1177 (nconc
1178 ;; @-ids.
1179 (mapcar (lambda (atrule) (concat "@" atrule)) css-at-ids)
1180 ;; Pseudo-classes.
1181 (mapcar (lambda (class) (concat ":" class)) css-pseudo-class-ids)
1182 ;; Pseudo-elements with either one or two ":"s.
1183 (mapcar (lambda (elt) (concat ":" elt)) css-pseudo-element-ids)
1184 (mapcar (lambda (elt) (concat "::" elt)) css-pseudo-element-ids)
1185 ;; Properties.
1186 css-property-ids)
1187 "List of all symbols available for lookup via MDN.")
1188
1189(defun css--mdn-find-symbol ()
1190 "A helper for `css-lookup-symbol' that finds the symbol at point.
1191Returns the symbol, a string, or nil if none found."
1192 (save-excursion
1193 ;; Skip backward over a word first.
1194 (skip-chars-backward "-[:alnum:] \t")
1195 ;; Now skip ":" or "@" to see if it's a pseudo-element or at-id.
1196 (skip-chars-backward "@:")
1197 (if (looking-at css--mdn-symbol-regexp)
1198 (match-string-no-properties 0)
1199 (let ((bound (save-excursion
1200 (beginning-of-line)
1201 (point))))
1202 (when (re-search-backward css--mdn-property-regexp bound t)
1203 (match-string-no-properties 1))))))
1204
1205;;;###autoload
1206(defun css-lookup-symbol (symbol)
1207 "Display the CSS documentation for SYMBOL, as found on MDN.
1208When this command is used interactively, it picks a default
1209symbol based on the CSS text before point -- either an @-keyword,
1210a property name, a pseudo-class, or a pseudo-element, depending
1211on what is seen near point."
1212 (interactive
1213 (list
1214 (let* ((sym (css--mdn-find-symbol))
1215 (enable-recursive-minibuffers t)
1216 (value (completing-read
1217 (if sym
1218 (format "Describe CSS symbol (default %s): " sym)
1219 "Describe CSS symbol: ")
1220 css--mdn-completion-list nil nil nil
1221 'css--mdn-lookup-history sym)))
1222 (if (equal value "") sym value))))
1223 (when symbol
1224 ;; If we see a single-colon pseudo-element like ":after", turn it
1225 ;; into "::after".
1226 (when (and (eq (aref symbol 0) ?:)
1227 (member (substring symbol 1) css-pseudo-element-ids))
1228 (setq symbol (concat ":" symbol)))
1229 (let ((url (format css-lookup-url-format symbol))
1230 (buffer (get-buffer-create "*MDN CSS*")))
1231 (save-selected-window
1232 ;; Make sure to display the buffer before calling `eww', as
1233 ;; that calls `pop-to-buffer-same-window'.
1234 (switch-to-buffer-other-window buffer)
1235 (with-current-buffer buffer
1236 (eww-mode)
1237 (add-hook 'eww-after-render-hook #'css--mdn-after-render nil t)
1238 (eww url))))))
1239
1090(provide 'css-mode) 1240(provide 'css-mode)
1091;;; css-mode.el ends here 1241;;; css-mode.el ends here
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index e609ca9f943..31c33e6a720 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")
437(defconst diff-hunk-header-re 437(defconst diff-hunk-header-re
438 (concat "^\\(?:" diff-hunk-header-re-unified ".*\\|\\*\\{15\\}.*\n\\*\\*\\* .+ \\*\\*\\*\\*\\|[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?\\)$")) 438 (concat "^\\(?:" diff-hunk-header-re-unified ".*\\|\\*\\{15\\}.*\n\\*\\*\\* .+ \\*\\*\\*\\*\\|[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?\\)$"))
439(defconst diff-file-header-re (concat "^\\(--- .+\n\\+\\+\\+ \\|\\*\\*\\* .+\n--- \\|[^-+!<>0-9@* \n]\\).+\n" (substring diff-hunk-header-re 1))) 439(defconst diff-file-header-re (concat "^\\(--- .+\n\\+\\+\\+ \\|\\*\\*\\* .+\n--- \\|[^-+!<>0-9@* \n]\\).+\n" (substring diff-hunk-header-re 1)))
440
441(defconst diff-separator-re "^--+ ?$")
442
440(defvar diff-narrowed-to nil) 443(defvar diff-narrowed-to nil)
441 444
442(defun diff-hunk-style (&optional style) 445(defun diff-hunk-style (&optional style)
@@ -647,28 +650,36 @@ If the prefix ARG is given, restrict the view to the current file instead."
647 (if arg (diff-bounds-of-file) (diff-bounds-of-hunk))) 650 (if arg (diff-bounds-of-file) (diff-bounds-of-hunk)))
648 (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk))) 651 (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk)))
649 652
653(defun diff--some-hunks-p ()
654 (save-excursion
655 (goto-char (point-min))
656 (re-search-forward diff-hunk-header-re nil t)))
657
650(defun diff-hunk-kill () 658(defun diff-hunk-kill ()
651 "Kill the hunk at point." 659 "Kill the hunk at point."
652 (interactive) 660 (interactive)
653 (let* ((hunk-bounds (diff-bounds-of-hunk)) 661 (if (not (diff--some-hunks-p))
654 (file-bounds (ignore-errors (diff-bounds-of-file))) 662 (error "No hunks")
655 ;; If the current hunk is the only one for its file, kill the 663 (diff-beginning-of-hunk t)
656 ;; file header too. 664 (let* ((hunk-bounds (diff-bounds-of-hunk))
657 (bounds (if (and file-bounds 665 (file-bounds (ignore-errors (diff-bounds-of-file)))
658 (progn (goto-char (car file-bounds)) 666 ;; If the current hunk is the only one for its file, kill the
659 (= (progn (diff-hunk-next) (point)) 667 ;; file header too.
660 (car hunk-bounds))) 668 (bounds (if (and file-bounds
661 (progn (goto-char (cadr hunk-bounds)) 669 (progn (goto-char (car file-bounds))
662 ;; bzr puts a newline after the last hunk. 670 (= (progn (diff-hunk-next) (point))
663 (while (looking-at "^\n") 671 (car hunk-bounds)))
664 (forward-char 1)) 672 (progn (goto-char (cadr hunk-bounds))
665 (= (point) (cadr file-bounds)))) 673 ;; bzr puts a newline after the last hunk.
666 file-bounds 674 (while (looking-at "^\n")
667 hunk-bounds)) 675 (forward-char 1))
668 (inhibit-read-only t)) 676 (= (point) (cadr file-bounds))))
669 (apply 'kill-region bounds) 677 file-bounds
670 (goto-char (car bounds)) 678 hunk-bounds))
671 (diff-beginning-of-hunk t))) 679 (inhibit-read-only t))
680 (apply 'kill-region bounds)
681 (goto-char (car bounds))
682 (ignore-errors (diff-beginning-of-hunk t)))))
672 683
673(defun diff-beginning-of-file-and-junk () 684(defun diff-beginning-of-file-and-junk ()
674 "Go to the beginning of file-related diff-info. 685 "Go to the beginning of file-related diff-info.
@@ -720,9 +731,12 @@ data such as \"Index: ...\" and such."
720(defun diff-file-kill () 731(defun diff-file-kill ()
721 "Kill current file's hunks." 732 "Kill current file's hunks."
722 (interactive) 733 (interactive)
723 (let ((inhibit-read-only t)) 734 (if (not (diff--some-hunks-p))
724 (apply 'kill-region (diff-bounds-of-file))) 735 (error "No hunks")
725 (diff-beginning-of-hunk t)) 736 (diff-beginning-of-hunk t)
737 (let ((inhibit-read-only t))
738 (apply 'kill-region (diff-bounds-of-file)))
739 (ignore-errors (diff-beginning-of-hunk t))))
726 740
727(defun diff-kill-junk () 741(defun diff-kill-junk ()
728 "Kill spurious empty diffs." 742 "Kill spurious empty diffs."
@@ -1537,15 +1551,20 @@ Only works for unified diffs."
1537 (pcase (char-after) 1551 (pcase (char-after)
1538 (?\s (cl-decf before) (cl-decf after) t) 1552 (?\s (cl-decf before) (cl-decf after) t)
1539 (?- 1553 (?-
1540 (if (and (looking-at diff-file-header-re) 1554 (cond
1541 (zerop before) (zerop after)) 1555 ((and (looking-at diff-separator-re)
1542 ;; No need to query: this is a case where two patches 1556 (zerop before) (zerop after))
1543 ;; are concatenated and only counting the lines will 1557 nil)
1544 ;; give the right result. Let's just add an empty 1558 ((and (looking-at diff-file-header-re)
1545 ;; line so that our code which doesn't count lines 1559 (zerop before) (zerop after))
1546 ;; will not get confused. 1560 ;; No need to query: this is a case where two patches
1547 (progn (save-excursion (insert "\n")) nil) 1561 ;; are concatenated and only counting the lines will
1548 (cl-decf before) t)) 1562 ;; give the right result. Let's just add an empty
1563 ;; line so that our code which doesn't count lines
1564 ;; will not get confused.
1565 (save-excursion (insert "\n")) nil)
1566 (t
1567 (cl-decf before) t)))
1549 (?+ (cl-decf after) t) 1568 (?+ (cl-decf after) t)
1550 (_ 1569 (_
1551 (cond 1570 (cond
@@ -2000,57 +2019,58 @@ Return new point, if it was moved."
2000 "Highlight changes of hunk at point at a finer granularity." 2019 "Highlight changes of hunk at point at a finer granularity."
2001 (interactive) 2020 (interactive)
2002 (require 'smerge-mode) 2021 (require 'smerge-mode)
2003 (save-excursion 2022 (when (diff--some-hunks-p)
2004 (diff-beginning-of-hunk t) 2023 (save-excursion
2005 (let* ((start (point)) 2024 (diff-beginning-of-hunk t)
2006 (style (diff-hunk-style)) ;Skips the hunk header as well. 2025 (let* ((start (point))
2007 (beg (point)) 2026 (style (diff-hunk-style)) ;Skips the hunk header as well.
2008 (props-c '((diff-mode . fine) (face diff-refine-changed))) 2027 (beg (point))
2009 (props-r '((diff-mode . fine) (face diff-refine-removed))) 2028 (props-c '((diff-mode . fine) (face diff-refine-changed)))
2010 (props-a '((diff-mode . fine) (face diff-refine-added))) 2029 (props-r '((diff-mode . fine) (face diff-refine-removed)))
2011 ;; Be careful to go back to `start' so diff-end-of-hunk gets 2030 (props-a '((diff-mode . fine) (face diff-refine-added)))
2012 ;; to read the hunk header's line info. 2031 ;; Be careful to go back to `start' so diff-end-of-hunk gets
2013 (end (progn (goto-char start) (diff-end-of-hunk) (point)))) 2032 ;; to read the hunk header's line info.
2014 2033 (end (progn (goto-char start) (diff-end-of-hunk) (point))))
2015 (remove-overlays beg end 'diff-mode 'fine) 2034
2016 2035 (remove-overlays beg end 'diff-mode 'fine)
2017 (goto-char beg) 2036
2018 (pcase style 2037 (goto-char beg)
2019 (`unified 2038 (pcase style
2020 (while (re-search-forward "^-" end t) 2039 (`unified
2021 (let ((beg-del (progn (beginning-of-line) (point))) 2040 (while (re-search-forward "^-" end t)
2022 beg-add end-add) 2041 (let ((beg-del (progn (beginning-of-line) (point)))
2023 (when (and (diff--forward-while-leading-char ?- end) 2042 beg-add end-add)
2024 ;; Allow for "\ No newline at end of file". 2043 (when (and (diff--forward-while-leading-char ?- end)
2025 (progn (diff--forward-while-leading-char ?\\ end) 2044 ;; Allow for "\ No newline at end of file".
2026 (setq beg-add (point))) 2045 (progn (diff--forward-while-leading-char ?\\ end)
2027 (diff--forward-while-leading-char ?+ end) 2046 (setq beg-add (point)))
2028 (progn (diff--forward-while-leading-char ?\\ end) 2047 (diff--forward-while-leading-char ?+ end)
2029 (setq end-add (point)))) 2048 (progn (diff--forward-while-leading-char ?\\ end)
2030 (smerge-refine-subst beg-del beg-add beg-add end-add 2049 (setq end-add (point))))
2031 nil 'diff-refine-preproc props-r props-a))))) 2050 (smerge-refine-subst beg-del beg-add beg-add end-add
2032 (`context 2051 nil 'diff-refine-preproc props-r props-a)))))
2033 (let* ((middle (save-excursion (re-search-forward "^---"))) 2052 (`context
2034 (other middle)) 2053 (let* ((middle (save-excursion (re-search-forward "^---")))
2035 (while (re-search-forward "^\\(?:!.*\n\\)+" middle t) 2054 (other middle))
2036 (smerge-refine-subst (match-beginning 0) (match-end 0) 2055 (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
2037 (save-excursion 2056 (smerge-refine-subst (match-beginning 0) (match-end 0)
2038 (goto-char other) 2057 (save-excursion
2039 (re-search-forward "^\\(?:!.*\n\\)+" end) 2058 (goto-char other)
2040 (setq other (match-end 0)) 2059 (re-search-forward "^\\(?:!.*\n\\)+" end)
2041 (match-beginning 0)) 2060 (setq other (match-end 0))
2042 other 2061 (match-beginning 0))
2043 (if diff-use-changed-face props-c) 2062 other
2044 'diff-refine-preproc 2063 (if diff-use-changed-face props-c)
2045 (unless diff-use-changed-face props-r) 2064 'diff-refine-preproc
2046 (unless diff-use-changed-face props-a))))) 2065 (unless diff-use-changed-face props-r)
2047 (_ ;; Normal diffs. 2066 (unless diff-use-changed-face props-a)))))
2048 (let ((beg1 (1+ (point)))) 2067 (_ ;; Normal diffs.
2049 (when (re-search-forward "^---.*\n" end t) 2068 (let ((beg1 (1+ (point))))
2050 ;; It's a combined add&remove, so there's something to do. 2069 (when (re-search-forward "^---.*\n" end t)
2051 (smerge-refine-subst beg1 (match-beginning 0) 2070 ;; It's a combined add&remove, so there's something to do.
2052 (match-end 0) end 2071 (smerge-refine-subst beg1 (match-beginning 0)
2053 nil 'diff-refine-preproc props-r props-a)))))))) 2072 (match-end 0) end
2073 nil 'diff-refine-preproc props-r props-a)))))))))
2054 2074
2055(defun diff-undo (&optional arg) 2075(defun diff-undo (&optional arg)
2056 "Perform `undo', ignoring the buffer's read-only status." 2076 "Perform `undo', ignoring the buffer's read-only status."
diff --git a/src/alloc.c b/src/alloc.c
index dd2b688f91e..62f43669f2a 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -2880,7 +2880,7 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2880 for (EMACS_INT size = XFASTINT (length); 0 < size; size--) 2880 for (EMACS_INT size = XFASTINT (length); 0 < size; size--)
2881 { 2881 {
2882 val = Fcons (init, val); 2882 val = Fcons (init, val);
2883 maybe_quit (); 2883 rarely_quit (size);
2884 } 2884 }
2885 2885
2886 return val; 2886 return val;
@@ -4887,12 +4887,19 @@ mark_memory (void *start, void *end)
4887 } 4887 }
4888} 4888}
4889 4889
4890#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS 4890#ifndef HAVE___BUILTIN_UNWIND_INIT
4891
4892# ifdef GC_SETJMP_WORKS
4893static void
4894test_setjmp (void)
4895{
4896}
4897# else
4891 4898
4892static bool setjmp_tested_p; 4899static bool setjmp_tested_p;
4893static int longjmps_done; 4900static int longjmps_done;
4894 4901
4895#define SETJMP_WILL_LIKELY_WORK "\ 4902# define SETJMP_WILL_LIKELY_WORK "\
4896\n\ 4903\n\
4897Emacs garbage collector has been changed to use conservative stack\n\ 4904Emacs garbage collector has been changed to use conservative stack\n\
4898marking. Emacs has determined that the method it uses to do the\n\ 4905marking. Emacs has determined that the method it uses to do the\n\
@@ -4905,7 +4912,7 @@ verify that the methods used are appropriate for your system.\n\
4905Please mail the result to <emacs-devel@gnu.org>.\n\ 4912Please mail the result to <emacs-devel@gnu.org>.\n\
4906" 4913"
4907 4914
4908#define SETJMP_WILL_NOT_WORK "\ 4915# define SETJMP_WILL_NOT_WORK "\
4909\n\ 4916\n\
4910Emacs garbage collector has been changed to use conservative stack\n\ 4917Emacs garbage collector has been changed to use conservative stack\n\
4911marking. Emacs has determined that the default method it uses to do the\n\ 4918marking. Emacs has determined that the default method it uses to do the\n\
@@ -4931,6 +4938,9 @@ Please mail the result to <emacs-devel@gnu.org>.\n\
4931static void 4938static void
4932test_setjmp (void) 4939test_setjmp (void)
4933{ 4940{
4941 if (setjmp_tested_p)
4942 return;
4943 setjmp_tested_p = true;
4934 char buf[10]; 4944 char buf[10];
4935 register int x; 4945 register int x;
4936 sys_jmp_buf jbuf; 4946 sys_jmp_buf jbuf;
@@ -4967,9 +4977,60 @@ test_setjmp (void)
4967 if (longjmps_done == 1) 4977 if (longjmps_done == 1)
4968 sys_longjmp (jbuf, 1); 4978 sys_longjmp (jbuf, 1);
4969} 4979}
4980# endif /* ! GC_SETJMP_WORKS */
4981#endif /* ! HAVE___BUILTIN_UNWIND_INIT */
4970 4982
4971#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */ 4983/* The type of an object near the stack top, whose address can be used
4984 as a stack scan limit. */
4985typedef union
4986{
4987 /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT,
4988 jmp_buf may not be aligned enough on darwin-ppc64. */
4989 max_align_t o;
4990#ifndef HAVE___BUILTIN_UNWIND_INIT
4991 sys_jmp_buf j;
4992 char c;
4993#endif
4994} stacktop_sentry;
4995
4996/* Force callee-saved registers and register windows onto the stack.
4997 Use the platform-defined __builtin_unwind_init if available,
4998 obviating the need for machine dependent methods. */
4999#ifndef HAVE___BUILTIN_UNWIND_INIT
5000# ifdef __sparc__
5001 /* This trick flushes the register windows so that all the state of
5002 the process is contained in the stack.
5003 FreeBSD does not have a ta 3 handler, so handle it specially.
5004 FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is
5005 needed on ia64 too. See mach_dep.c, where it also says inline
5006 assembler doesn't work with relevant proprietary compilers. */
5007# if defined __sparc64__ && defined __FreeBSD__
5008# define __builtin_unwind_init() asm ("flushw")
5009# else
5010# define __builtin_unwind_init() asm ("ta 3")
5011# endif
5012# else
5013# define __builtin_unwind_init() ((void) 0)
5014# endif
5015#endif
4972 5016
5017/* Set *P to the address of the top of the stack. This must be a
5018 macro, not a function, so that it is executed in the caller’s
5019 environment. It is not inside a do-while so that its storage
5020 survives the macro. */
5021#ifdef HAVE___BUILTIN_UNWIND_INIT
5022# define SET_STACK_TOP_ADDRESS(p) \
5023 stacktop_sentry sentry; \
5024 __builtin_unwind_init (); \
5025 *(p) = &sentry
5026#else
5027# define SET_STACK_TOP_ADDRESS(p) \
5028 stacktop_sentry sentry; \
5029 __builtin_unwind_init (); \
5030 test_setjmp (); \
5031 sys_setjmp (sentry.j); \
5032 *(p) = &sentry + (stack_bottom < &sentry.c)
5033#endif
4973 5034
4974/* Mark live Lisp objects on the C stack. 5035/* Mark live Lisp objects on the C stack.
4975 5036
@@ -4981,12 +5042,7 @@ test_setjmp (void)
4981 We have to mark Lisp objects in CPU registers that can hold local 5042 We have to mark Lisp objects in CPU registers that can hold local
4982 variables or are used to pass parameters. 5043 variables or are used to pass parameters.
4983 5044
4984 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to 5045 This code assumes that calling setjmp saves registers we need
4985 something that either saves relevant registers on the stack, or
4986 calls mark_maybe_object passing it each register's contents.
4987
4988 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4989 implementation assumes that calling setjmp saves registers we need
4990 to see in a jmp_buf which itself lies on the stack. This doesn't 5046 to see in a jmp_buf which itself lies on the stack. This doesn't
4991 have to be true! It must be verified for each system, possibly 5047 have to be true! It must be verified for each system, possibly
4992 by taking a look at the source code of setjmp. 5048 by taking a look at the source code of setjmp.
@@ -5050,62 +5106,9 @@ flush_stack_call_func (void (*func) (void *arg), void *arg)
5050{ 5106{
5051 void *end; 5107 void *end;
5052 struct thread_state *self = current_thread; 5108 struct thread_state *self = current_thread;
5053 5109 SET_STACK_TOP_ADDRESS (&end);
5054#ifdef HAVE___BUILTIN_UNWIND_INIT
5055 /* Force callee-saved registers and register windows onto the stack.
5056 This is the preferred method if available, obviating the need for
5057 machine dependent methods. */
5058 __builtin_unwind_init ();
5059 end = &end;
5060#else /* not HAVE___BUILTIN_UNWIND_INIT */
5061#ifndef GC_SAVE_REGISTERS_ON_STACK
5062 /* jmp_buf may not be aligned enough on darwin-ppc64 */
5063 union aligned_jmpbuf {
5064 Lisp_Object o;
5065 sys_jmp_buf j;
5066 } j;
5067 volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom;
5068#endif
5069 /* This trick flushes the register windows so that all the state of
5070 the process is contained in the stack. */
5071 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
5072 needed on ia64 too. See mach_dep.c, where it also says inline
5073 assembler doesn't work with relevant proprietary compilers. */
5074#ifdef __sparc__
5075#if defined (__sparc64__) && defined (__FreeBSD__)
5076 /* FreeBSD does not have a ta 3 handler. */
5077 asm ("flushw");
5078#else
5079 asm ("ta 3");
5080#endif
5081#endif
5082
5083 /* Save registers that we need to see on the stack. We need to see
5084 registers used to hold register variables and registers used to
5085 pass parameters. */
5086#ifdef GC_SAVE_REGISTERS_ON_STACK
5087 GC_SAVE_REGISTERS_ON_STACK (end);
5088#else /* not GC_SAVE_REGISTERS_ON_STACK */
5089
5090#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
5091 setjmp will definitely work, test it
5092 and print a message with the result
5093 of the test. */
5094 if (!setjmp_tested_p)
5095 {
5096 setjmp_tested_p = 1;
5097 test_setjmp ();
5098 }
5099#endif /* GC_SETJMP_WORKS */
5100
5101 sys_setjmp (j.j);
5102 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
5103#endif /* not GC_SAVE_REGISTERS_ON_STACK */
5104#endif /* not HAVE___BUILTIN_UNWIND_INIT */
5105
5106 self->stack_top = end; 5110 self->stack_top = end;
5107 (*func) (arg); 5111 func (arg);
5108
5109 eassert (current_thread == self); 5112 eassert (current_thread == self);
5110} 5113}
5111 5114
@@ -5437,7 +5440,8 @@ make_pure_vector (ptrdiff_t len)
5437/* Copy all contents and parameters of TABLE to a new table allocated 5440/* Copy all contents and parameters of TABLE to a new table allocated
5438 from pure space, return the purified table. */ 5441 from pure space, return the purified table. */
5439static struct Lisp_Hash_Table * 5442static struct Lisp_Hash_Table *
5440purecopy_hash_table (struct Lisp_Hash_Table *table) { 5443purecopy_hash_table (struct Lisp_Hash_Table *table)
5444{
5441 eassert (NILP (table->weak)); 5445 eassert (NILP (table->weak));
5442 eassert (!NILP (table->pure)); 5446 eassert (!NILP (table->pure));
5443 5447
@@ -5480,14 +5484,12 @@ Does not copy symbols. Copies strings without text properties. */)
5480 return purecopy (obj); 5484 return purecopy (obj);
5481} 5485}
5482 5486
5483struct pinned_object 5487/* Pinned objects are marked before every GC cycle. */
5488static struct pinned_object
5484{ 5489{
5485 Lisp_Object object; 5490 Lisp_Object object;
5486 struct pinned_object *next; 5491 struct pinned_object *next;
5487}; 5492} *pinned_objects;
5488
5489/* Pinned objects are marked before every GC cycle. */
5490static struct pinned_object *pinned_objects;
5491 5493
5492static Lisp_Object 5494static Lisp_Object
5493purecopy (Lisp_Object obj) 5495purecopy (Lisp_Object obj)
@@ -5519,13 +5521,13 @@ purecopy (Lisp_Object obj)
5519 else if (HASH_TABLE_P (obj)) 5521 else if (HASH_TABLE_P (obj))
5520 { 5522 {
5521 struct Lisp_Hash_Table *table = XHASH_TABLE (obj); 5523 struct Lisp_Hash_Table *table = XHASH_TABLE (obj);
5522 /* We cannot purify hash tables which haven't been defined with 5524 /* Do not purify hash tables which haven't been defined with
5523 :purecopy as non-nil or are weak - they aren't guaranteed to 5525 :purecopy as non-nil or are weak - they aren't guaranteed to
5524 not change. */ 5526 not change. */
5525 if (!NILP (table->weak) || NILP (table->pure)) 5527 if (!NILP (table->weak) || NILP (table->pure))
5526 { 5528 {
5527 /* Instead, the hash table is added to the list of pinned objects, 5529 /* Instead, add the hash table to the list of pinned objects,
5528 and is marked before GC. */ 5530 so that it will be marked during GC. */
5529 struct pinned_object *o = xmalloc (sizeof *o); 5531 struct pinned_object *o = xmalloc (sizeof *o);
5530 o->object = obj; 5532 o->object = obj;
5531 o->next = pinned_objects; 5533 o->next = pinned_objects;
@@ -5755,11 +5757,8 @@ compact_undo_list (Lisp_Object list)
5755static void 5757static void
5756mark_pinned_objects (void) 5758mark_pinned_objects (void)
5757{ 5759{
5758 struct pinned_object *pobj; 5760 for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next)
5759 for (pobj = pinned_objects; pobj; pobj = pobj->next) 5761 mark_object (pobj->object);
5760 {
5761 mark_object (pobj->object);
5762 }
5763} 5762}
5764 5763
5765static void 5764static void
@@ -6051,58 +6050,7 @@ See Info node `(elisp)Garbage Collection'. */)
6051 (void) 6050 (void)
6052{ 6051{
6053 void *end; 6052 void *end;
6054 6053 SET_STACK_TOP_ADDRESS (&end);
6055#ifdef HAVE___BUILTIN_UNWIND_INIT
6056 /* Force callee-saved registers and register windows onto the stack.
6057 This is the preferred method if available, obviating the need for
6058 machine dependent methods. */
6059 __builtin_unwind_init ();
6060 end = &end;
6061#else /* not HAVE___BUILTIN_UNWIND_INIT */
6062#ifndef GC_SAVE_REGISTERS_ON_STACK
6063 /* jmp_buf may not be aligned enough on darwin-ppc64 */
6064 union aligned_jmpbuf {
6065 Lisp_Object o;
6066 sys_jmp_buf j;
6067 } j;
6068 volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
6069#endif
6070 /* This trick flushes the register windows so that all the state of
6071 the process is contained in the stack. */
6072 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
6073 needed on ia64 too. See mach_dep.c, where it also says inline
6074 assembler doesn't work with relevant proprietary compilers. */
6075#ifdef __sparc__
6076#if defined (__sparc64__) && defined (__FreeBSD__)
6077 /* FreeBSD does not have a ta 3 handler. */
6078 asm ("flushw");
6079#else
6080 asm ("ta 3");
6081#endif
6082#endif
6083
6084 /* Save registers that we need to see on the stack. We need to see
6085 registers used to hold register variables and registers used to
6086 pass parameters. */
6087#ifdef GC_SAVE_REGISTERS_ON_STACK
6088 GC_SAVE_REGISTERS_ON_STACK (end);
6089#else /* not GC_SAVE_REGISTERS_ON_STACK */
6090
6091#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
6092 setjmp will definitely work, test it
6093 and print a message with the result
6094 of the test. */
6095 if (!setjmp_tested_p)
6096 {
6097 setjmp_tested_p = 1;
6098 test_setjmp ();
6099 }
6100#endif /* GC_SETJMP_WORKS */
6101
6102 sys_setjmp (j.j);
6103 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
6104#endif /* not GC_SAVE_REGISTERS_ON_STACK */
6105#endif /* not HAVE___BUILTIN_UNWIND_INIT */
6106 return garbage_collect_1 (end); 6054 return garbage_collect_1 (end);
6107} 6055}
6108 6056
@@ -7412,9 +7360,6 @@ init_alloc_once (void)
7412void 7360void
7413init_alloc (void) 7361init_alloc (void)
7414{ 7362{
7415#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
7416 setjmp_tested_p = longjmps_done = 0;
7417#endif
7418 Vgc_elapsed = make_float (0.0); 7363 Vgc_elapsed = make_float (0.0);
7419 gcs_done = 0; 7364 gcs_done = 0;
7420 7365
diff --git a/src/bytecode.c b/src/bytecode.c
index 288d78efe41..f9531761b3c 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -843,11 +843,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
843 { 843 {
844 Lisp_Object v2 = POP, v1 = TOP; 844 Lisp_Object v2 = POP, v1 = TOP;
845 CHECK_NUMBER (v1); 845 CHECK_NUMBER (v1);
846 EMACS_INT n = XINT (v1); 846 for (EMACS_INT n = XINT (v1); 0 < n && CONSP (v2); n--)
847 immediate_quit = true; 847 {
848 while (--n >= 0 && CONSP (v2)) 848 v2 = XCDR (v2);
849 v2 = XCDR (v2); 849 rarely_quit (n);
850 immediate_quit = false; 850 }
851 TOP = CAR (v2); 851 TOP = CAR (v2);
852 NEXT; 852 NEXT;
853 } 853 }
@@ -1277,11 +1277,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
1277 /* Exchange args and then do nth. */ 1277 /* Exchange args and then do nth. */
1278 Lisp_Object v2 = POP, v1 = TOP; 1278 Lisp_Object v2 = POP, v1 = TOP;
1279 CHECK_NUMBER (v2); 1279 CHECK_NUMBER (v2);
1280 EMACS_INT n = XINT (v2); 1280 for (EMACS_INT n = XINT (v2); 0 < n && CONSP (v1); n--)
1281 immediate_quit = true; 1281 {
1282 while (--n >= 0 && CONSP (v1)) 1282 v1 = XCDR (v1);
1283 v1 = XCDR (v1); 1283 rarely_quit (n);
1284 immediate_quit = false; 1284 }
1285 TOP = CAR (v1); 1285 TOP = CAR (v1);
1286 } 1286 }
1287 else 1287 else
diff --git a/src/callproc.c b/src/callproc.c
index 301ccf383b5..84324c48dcf 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -198,11 +198,11 @@ call_process_cleanup (Lisp_Object buffer)
198 { 198 {
199 kill (-synch_process_pid, SIGINT); 199 kill (-synch_process_pid, SIGINT);
200 message1 ("Waiting for process to die...(type C-g again to kill it instantly)"); 200 message1 ("Waiting for process to die...(type C-g again to kill it instantly)");
201 immediate_quit = true; 201
202 maybe_quit (); 202 /* This will quit on C-g. */
203 wait_for_termination (synch_process_pid, 0, 1); 203 wait_for_termination (synch_process_pid, 0, 1);
204
204 synch_process_pid = 0; 205 synch_process_pid = 0;
205 immediate_quit = false;
206 message1 ("Waiting for process to die...done"); 206 message1 ("Waiting for process to die...done");
207 } 207 }
208#endif /* !MSDOS */ 208#endif /* !MSDOS */
@@ -726,9 +726,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
726 process_coding.src_multibyte = 0; 726 process_coding.src_multibyte = 0;
727 } 727 }
728 728
729 immediate_quit = true;
730 maybe_quit ();
731
732 if (0 <= fd0) 729 if (0 <= fd0)
733 { 730 {
734 enum { CALLPROC_BUFFER_SIZE_MIN = 16 * 1024 }; 731 enum { CALLPROC_BUFFER_SIZE_MIN = 16 * 1024 };
@@ -749,8 +746,8 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
749 nread = carryover; 746 nread = carryover;
750 while (nread < bufsize - 1024) 747 while (nread < bufsize - 1024)
751 { 748 {
752 int this_read = emacs_read (fd0, buf + nread, 749 int this_read = emacs_read_quit (fd0, buf + nread,
753 bufsize - nread); 750 bufsize - nread);
754 751
755 if (this_read < 0) 752 if (this_read < 0)
756 goto give_up; 753 goto give_up;
@@ -769,7 +766,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
769 } 766 }
770 767
771 /* Now NREAD is the total amount of data in the buffer. */ 768 /* Now NREAD is the total amount of data in the buffer. */
772 immediate_quit = false;
773 769
774 if (!nread) 770 if (!nread)
775 ; 771 ;
@@ -842,8 +838,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
842 we should have already detected a coding system. */ 838 we should have already detected a coding system. */
843 display_on_the_fly = true; 839 display_on_the_fly = true;
844 } 840 }
845 immediate_quit = true;
846 maybe_quit ();
847 } 841 }
848 give_up: ; 842 give_up: ;
849 843
@@ -860,8 +854,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
860 wait_for_termination (pid, &status, fd0 < 0); 854 wait_for_termination (pid, &status, fd0 < 0);
861#endif 855#endif
862 856
863 immediate_quit = false;
864
865 /* Don't kill any children that the subprocess may have left behind 857 /* Don't kill any children that the subprocess may have left behind
866 when exiting. */ 858 when exiting. */
867 synch_process_pid = 0; 859 synch_process_pid = 0;
diff --git a/src/dired.c b/src/dired.c
index 52e81fb380b..5ea00fb8db4 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -248,14 +248,11 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
248 248
249 /* Now that we have unwind_protect in place, we might as well 249 /* Now that we have unwind_protect in place, we might as well
250 allow matching to be interrupted. */ 250 allow matching to be interrupted. */
251 immediate_quit = true;
252 maybe_quit (); 251 maybe_quit ();
253 252
254 bool wanted = (NILP (match) 253 bool wanted = (NILP (match)
255 || re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0); 254 || re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0);
256 255
257 immediate_quit = false;
258
259 if (wanted) 256 if (wanted)
260 { 257 {
261 if (!NILP (full)) 258 if (!NILP (full))
diff --git a/src/dispextern.h b/src/dispextern.h
index 51222e636be..eb71a82311c 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -3263,6 +3263,7 @@ void move_it_past_eol (struct it *);
3263void move_it_in_display_line (struct it *it, 3263void move_it_in_display_line (struct it *it,
3264 ptrdiff_t to_charpos, int to_x, 3264 ptrdiff_t to_charpos, int to_x,
3265 enum move_operation_enum op); 3265 enum move_operation_enum op);
3266int partial_line_height (struct it *it_origin);
3266bool in_display_vector_p (struct it *); 3267bool in_display_vector_p (struct it *);
3267int frame_mode_line_height (struct frame *); 3268int frame_mode_line_height (struct frame *);
3268extern bool redisplaying_p; 3269extern bool redisplaying_p;
diff --git a/src/doc.c b/src/doc.c
index 361d09a0878..1e7e3fcf6a6 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -186,7 +186,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
186 If we read the same block last time, maybe skip this? */ 186 If we read the same block last time, maybe skip this? */
187 if (space_left > 1024 * 8) 187 if (space_left > 1024 * 8)
188 space_left = 1024 * 8; 188 space_left = 1024 * 8;
189 nread = emacs_read (fd, p, space_left); 189 nread = emacs_read_quit (fd, p, space_left);
190 if (nread < 0) 190 if (nread < 0)
191 report_file_error ("Read error on documentation file", file); 191 report_file_error ("Read error on documentation file", file);
192 p[nread] = 0; 192 p[nread] = 0;
@@ -590,16 +590,15 @@ the same file name is found in the `doc-directory'. */)
590 Vdoc_file_name = filename; 590 Vdoc_file_name = filename;
591 filled = 0; 591 filled = 0;
592 pos = 0; 592 pos = 0;
593 while (1) 593 while (true)
594 { 594 {
595 register char *end;
596 if (filled < 512) 595 if (filled < 512)
597 filled += emacs_read (fd, &buf[filled], sizeof buf - 1 - filled); 596 filled += emacs_read_quit (fd, &buf[filled], sizeof buf - 1 - filled);
598 if (!filled) 597 if (!filled)
599 break; 598 break;
600 599
601 buf[filled] = 0; 600 buf[filled] = 0;
602 end = buf + (filled < 512 ? filled : filled - 128); 601 char *end = buf + (filled < 512 ? filled : filled - 128);
603 p = memchr (buf, '\037', end - buf); 602 p = memchr (buf, '\037', end - buf);
604 /* p points to ^_Ffunctionname\n or ^_Vvarname\n or ^_Sfilename\n. */ 603 /* p points to ^_Ffunctionname\n or ^_Vvarname\n or ^_Sfilename\n. */
605 if (p) 604 if (p)
diff --git a/src/editfns.c b/src/editfns.c
index 82c6abb9987..4618164d008 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -3053,7 +3053,6 @@ determines whether case is significant or ignored. */)
3053 i2 = begp2; 3053 i2 = begp2;
3054 i1_byte = buf_charpos_to_bytepos (bp1, i1); 3054 i1_byte = buf_charpos_to_bytepos (bp1, i1);
3055 i2_byte = buf_charpos_to_bytepos (bp2, i2); 3055 i2_byte = buf_charpos_to_bytepos (bp2, i2);
3056 immediate_quit = true;
3057 3056
3058 while (i1 < endp1 && i2 < endp2) 3057 while (i1 < endp1 && i2 < endp2)
3059 { 3058 {
@@ -3092,17 +3091,14 @@ determines whether case is significant or ignored. */)
3092 c1 = char_table_translate (trt, c1); 3091 c1 = char_table_translate (trt, c1);
3093 c2 = char_table_translate (trt, c2); 3092 c2 = char_table_translate (trt, c2);
3094 } 3093 }
3094
3095 if (c1 != c2) 3095 if (c1 != c2)
3096 { 3096 return make_number (c1 < c2 ? -1 - chars : chars + 1);
3097 immediate_quit = false;
3098 return make_number (c1 < c2 ? -1 - chars : chars + 1);
3099 }
3100 3097
3101 chars++; 3098 chars++;
3099 rarely_quit (chars);
3102 } 3100 }
3103 3101
3104 immediate_quit = false;
3105
3106 /* The strings match as far as they go. 3102 /* The strings match as far as they go.
3107 If one is shorter, that one is less. */ 3103 If one is shorter, that one is less. */
3108 if (chars < endp1 - begp1) 3104 if (chars < endp1 - begp1)
diff --git a/src/emacs.c b/src/emacs.c
index 28b395c4fb4..3083d0df302 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -688,7 +688,7 @@ main (int argc, char **argv)
688 dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0 688 dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0
689 || strcmp (argv[argc - 1], "bootstrap") == 0 ); 689 || strcmp (argv[argc - 1], "bootstrap") == 0 );
690 690
691 generating_ldefs_boot = getenv ("GENERATE_LDEFS_BOOT"); 691 generating_ldefs_boot = !!getenv ("GENERATE_LDEFS_BOOT");
692 692
693 693
694 /* True if address randomization interferes with memory allocation. */ 694 /* True if address randomization interferes with memory allocation. */
diff --git a/src/eval.c b/src/eval.c
index 62d4af15e27..22b02b49521 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1131,7 +1131,6 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
1131 /* Restore certain special C variables. */ 1131 /* Restore certain special C variables. */
1132 set_poll_suppress_count (catch->poll_suppress_count); 1132 set_poll_suppress_count (catch->poll_suppress_count);
1133 unblock_input_to (catch->interrupt_input_blocked); 1133 unblock_input_to (catch->interrupt_input_blocked);
1134 immediate_quit = false;
1135 1134
1136 do 1135 do
1137 { 1136 {
@@ -1462,6 +1461,19 @@ process_quit_flag (void)
1462 quit (); 1461 quit ();
1463} 1462}
1464 1463
1464/* Check quit-flag and quit if it is non-nil. Typing C-g does not
1465 directly cause a quit; it only sets Vquit_flag. So the program
1466 needs to call maybe_quit at times when it is safe to quit. Every
1467 loop that might run for a long time or might not exit ought to call
1468 maybe_quit at least once, at a safe place. Unless that is
1469 impossible, of course. But it is very desirable to avoid creating
1470 loops where maybe_quit is impossible.
1471
1472 If quit-flag is set to `kill-emacs' the SIGINT handler has received
1473 a request to exit Emacs when it is safe to do.
1474
1475 When not quitting, process any pending signals. */
1476
1465void 1477void
1466maybe_quit (void) 1478maybe_quit (void)
1467{ 1479{
@@ -1517,7 +1529,6 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
1517 Lisp_Object clause = Qnil; 1529 Lisp_Object clause = Qnil;
1518 struct handler *h; 1530 struct handler *h;
1519 1531
1520 immediate_quit = false;
1521 if (gc_in_progress || waiting_for_input) 1532 if (gc_in_progress || waiting_for_input)
1522 emacs_abort (); 1533 emacs_abort ();
1523 1534
diff --git a/src/fileio.c b/src/fileio.c
index a46cfc7ac69..38400623793 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -1960,9 +1960,7 @@ permissions. */)
1960 report_file_error ("Copying permissions to", newname); 1960 report_file_error ("Copying permissions to", newname);
1961 } 1961 }
1962#else /* not WINDOWSNT */ 1962#else /* not WINDOWSNT */
1963 immediate_quit = true;
1964 ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0); 1963 ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0);
1965 immediate_quit = false;
1966 1964
1967 if (ifd < 0) 1965 if (ifd < 0)
1968 report_file_error ("Opening input file", file); 1966 report_file_error ("Opening input file", file);
@@ -2024,7 +2022,6 @@ permissions. */)
2024 oldsize = out_st.st_size; 2022 oldsize = out_st.st_size;
2025 } 2023 }
2026 2024
2027 immediate_quit = true;
2028 maybe_quit (); 2025 maybe_quit ();
2029 2026
2030 if (clone_file (ofd, ifd)) 2027 if (clone_file (ofd, ifd))
@@ -2033,9 +2030,9 @@ permissions. */)
2033 { 2030 {
2034 char buf[MAX_ALLOCA]; 2031 char buf[MAX_ALLOCA];
2035 ptrdiff_t n; 2032 ptrdiff_t n;
2036 for (newsize = 0; 0 < (n = emacs_read (ifd, buf, sizeof buf)); 2033 for (newsize = 0; 0 < (n = emacs_read_quit (ifd, buf, sizeof buf));
2037 newsize += n) 2034 newsize += n)
2038 if (emacs_write_sig (ofd, buf, n) != n) 2035 if (emacs_write_quit (ofd, buf, n) != n)
2039 report_file_error ("Write error", newname); 2036 report_file_error ("Write error", newname);
2040 if (n < 0) 2037 if (n < 0)
2041 report_file_error ("Read error", file); 2038 report_file_error ("Read error", file);
@@ -2047,8 +2044,6 @@ permissions. */)
2047 if (newsize < oldsize && ftruncate (ofd, newsize) != 0) 2044 if (newsize < oldsize && ftruncate (ofd, newsize) != 0)
2048 report_file_error ("Truncating output file", newname); 2045 report_file_error ("Truncating output file", newname);
2049 2046
2050 immediate_quit = false;
2051
2052#ifndef MSDOS 2047#ifndef MSDOS
2053 /* Preserve the original file permissions, and if requested, also its 2048 /* Preserve the original file permissions, and if requested, also its
2054 owner and group. */ 2049 owner and group. */
@@ -3401,15 +3396,10 @@ decide_coding_unwind (Lisp_Object unwind_data)
3401static Lisp_Object 3396static Lisp_Object
3402read_non_regular (Lisp_Object state) 3397read_non_regular (Lisp_Object state)
3403{ 3398{
3404 int nbytes; 3399 int nbytes = emacs_read_quit (XSAVE_INTEGER (state, 0),
3405 3400 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
3406 immediate_quit = true; 3401 + XSAVE_INTEGER (state, 1)),
3407 maybe_quit (); 3402 XSAVE_INTEGER (state, 2));
3408 nbytes = emacs_read (XSAVE_INTEGER (state, 0),
3409 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
3410 + XSAVE_INTEGER (state, 1)),
3411 XSAVE_INTEGER (state, 2));
3412 immediate_quit = false;
3413 /* Fast recycle this object for the likely next call. */ 3403 /* Fast recycle this object for the likely next call. */
3414 free_misc (state); 3404 free_misc (state);
3415 return make_number (nbytes); 3405 return make_number (nbytes);
@@ -3753,17 +3743,17 @@ by calling `format-decode', which see. */)
3753 int nread; 3743 int nread;
3754 3744
3755 if (st.st_size <= (1024 * 4)) 3745 if (st.st_size <= (1024 * 4))
3756 nread = emacs_read (fd, read_buf, 1024 * 4); 3746 nread = emacs_read_quit (fd, read_buf, 1024 * 4);
3757 else 3747 else
3758 { 3748 {
3759 nread = emacs_read (fd, read_buf, 1024); 3749 nread = emacs_read_quit (fd, read_buf, 1024);
3760 if (nread == 1024) 3750 if (nread == 1024)
3761 { 3751 {
3762 int ntail; 3752 int ntail;
3763 if (lseek (fd, - (1024 * 3), SEEK_END) < 0) 3753 if (lseek (fd, - (1024 * 3), SEEK_END) < 0)
3764 report_file_error ("Setting file position", 3754 report_file_error ("Setting file position",
3765 orig_filename); 3755 orig_filename);
3766 ntail = emacs_read (fd, read_buf + nread, 1024 * 3); 3756 ntail = emacs_read_quit (fd, read_buf + nread, 1024 * 3);
3767 nread = ntail < 0 ? ntail : nread + ntail; 3757 nread = ntail < 0 ? ntail : nread + ntail;
3768 } 3758 }
3769 } 3759 }
@@ -3868,15 +3858,11 @@ by calling `format-decode', which see. */)
3868 report_file_error ("Setting file position", orig_filename); 3858 report_file_error ("Setting file position", orig_filename);
3869 } 3859 }
3870 3860
3871 immediate_quit = true;
3872 maybe_quit ();
3873 /* Count how many chars at the start of the file 3861 /* Count how many chars at the start of the file
3874 match the text at the beginning of the buffer. */ 3862 match the text at the beginning of the buffer. */
3875 while (1) 3863 while (true)
3876 { 3864 {
3877 int nread, bufpos; 3865 int nread = emacs_read_quit (fd, read_buf, sizeof read_buf);
3878
3879 nread = emacs_read (fd, read_buf, sizeof read_buf);
3880 if (nread < 0) 3866 if (nread < 0)
3881 report_file_error ("Read error", orig_filename); 3867 report_file_error ("Read error", orig_filename);
3882 else if (nread == 0) 3868 else if (nread == 0)
@@ -3898,7 +3884,7 @@ by calling `format-decode', which see. */)
3898 break; 3884 break;
3899 } 3885 }
3900 3886
3901 bufpos = 0; 3887 int bufpos = 0;
3902 while (bufpos < nread && same_at_start < ZV_BYTE 3888 while (bufpos < nread && same_at_start < ZV_BYTE
3903 && FETCH_BYTE (same_at_start) == read_buf[bufpos]) 3889 && FETCH_BYTE (same_at_start) == read_buf[bufpos])
3904 same_at_start++, bufpos++; 3890 same_at_start++, bufpos++;
@@ -3907,7 +3893,6 @@ by calling `format-decode', which see. */)
3907 if (bufpos != nread) 3893 if (bufpos != nread)
3908 break; 3894 break;
3909 } 3895 }
3910 immediate_quit = false;
3911 /* If the file matches the buffer completely, 3896 /* If the file matches the buffer completely,
3912 there's no need to replace anything. */ 3897 there's no need to replace anything. */
3913 if (same_at_start - BEGV_BYTE == end_offset - beg_offset) 3898 if (same_at_start - BEGV_BYTE == end_offset - beg_offset)
@@ -3919,8 +3904,7 @@ by calling `format-decode', which see. */)
3919 del_range_1 (same_at_start, same_at_end, 0, 0); 3904 del_range_1 (same_at_start, same_at_end, 0, 0);
3920 goto handled; 3905 goto handled;
3921 } 3906 }
3922 immediate_quit = true; 3907
3923 maybe_quit ();
3924 /* Count how many chars at the end of the file 3908 /* Count how many chars at the end of the file
3925 match the text at the end of the buffer. But, if we have 3909 match the text at the end of the buffer. But, if we have
3926 already found that decoding is necessary, don't waste time. */ 3910 already found that decoding is necessary, don't waste time. */
@@ -3942,7 +3926,8 @@ by calling `format-decode', which see. */)
3942 total_read = nread = 0; 3926 total_read = nread = 0;
3943 while (total_read < trial) 3927 while (total_read < trial)
3944 { 3928 {
3945 nread = emacs_read (fd, read_buf + total_read, trial - total_read); 3929 nread = emacs_read_quit (fd, read_buf + total_read,
3930 trial - total_read);
3946 if (nread < 0) 3931 if (nread < 0)
3947 report_file_error ("Read error", orig_filename); 3932 report_file_error ("Read error", orig_filename);
3948 else if (nread == 0) 3933 else if (nread == 0)
@@ -3977,7 +3962,6 @@ by calling `format-decode', which see. */)
3977 if (nread == 0) 3962 if (nread == 0)
3978 break; 3963 break;
3979 } 3964 }
3980 immediate_quit = false;
3981 3965
3982 if (! giveup_match_end) 3966 if (! giveup_match_end)
3983 { 3967 {
@@ -4069,18 +4053,13 @@ by calling `format-decode', which see. */)
4069 inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */ 4053 inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */
4070 unprocessed = 0; /* Bytes not processed in previous loop. */ 4054 unprocessed = 0; /* Bytes not processed in previous loop. */
4071 4055
4072 while (1) 4056 while (true)
4073 { 4057 {
4074 /* Read at most READ_BUF_SIZE bytes at a time, to allow 4058 /* Read at most READ_BUF_SIZE bytes at a time, to allow
4075 quitting while reading a huge file. */ 4059 quitting while reading a huge file. */
4076 4060
4077 /* Allow quitting out of the actual I/O. */ 4061 this = emacs_read_quit (fd, read_buf + unprocessed,
4078 immediate_quit = true; 4062 READ_BUF_SIZE - unprocessed);
4079 maybe_quit ();
4080 this = emacs_read (fd, read_buf + unprocessed,
4081 READ_BUF_SIZE - unprocessed);
4082 immediate_quit = false;
4083
4084 if (this <= 0) 4063 if (this <= 0)
4085 break; 4064 break;
4086 4065
@@ -4294,13 +4273,10 @@ by calling `format-decode', which see. */)
4294 /* Allow quitting out of the actual I/O. We don't make text 4273 /* Allow quitting out of the actual I/O. We don't make text
4295 part of the buffer until all the reading is done, so a C-g 4274 part of the buffer until all the reading is done, so a C-g
4296 here doesn't do any harm. */ 4275 here doesn't do any harm. */
4297 immediate_quit = true; 4276 this = emacs_read_quit (fd,
4298 maybe_quit (); 4277 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
4299 this = emacs_read (fd, 4278 + inserted),
4300 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE 4279 trytry);
4301 + inserted),
4302 trytry);
4303 immediate_quit = false;
4304 } 4280 }
4305 4281
4306 if (this <= 0) 4282 if (this <= 0)
@@ -5002,8 +4978,6 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
5002 } 4978 }
5003 } 4979 }
5004 4980
5005 immediate_quit = true;
5006
5007 if (STRINGP (start)) 4981 if (STRINGP (start))
5008 ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding); 4982 ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding);
5009 else if (XINT (start) != XINT (end)) 4983 else if (XINT (start) != XINT (end))
@@ -5026,8 +5000,6 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
5026 save_errno = errno; 5000 save_errno = errno;
5027 } 5001 }
5028 5002
5029 immediate_quit = false;
5030
5031 /* fsync is not crucial for temporary files. Nor for auto-save 5003 /* fsync is not crucial for temporary files. Nor for auto-save
5032 files, since they might lose some work anyway. */ 5004 files, since they might lose some work anyway. */
5033 if (open_and_close_file && !auto_saving && !write_region_inhibit_fsync) 5005 if (open_and_close_file && !auto_saving && !write_region_inhibit_fsync)
@@ -5417,7 +5389,7 @@ e_write (int desc, Lisp_Object string, ptrdiff_t start, ptrdiff_t end,
5417 : (STRINGP (coding->dst_object) 5389 : (STRINGP (coding->dst_object)
5418 ? SSDATA (coding->dst_object) 5390 ? SSDATA (coding->dst_object)
5419 : (char *) BYTE_POS_ADDR (coding->dst_pos_byte))); 5391 : (char *) BYTE_POS_ADDR (coding->dst_pos_byte)));
5420 coding->produced -= emacs_write_sig (desc, buf, coding->produced); 5392 coding->produced -= emacs_write_quit (desc, buf, coding->produced);
5421 5393
5422 if (coding->raw_destination) 5394 if (coding->raw_destination)
5423 { 5395 {
diff --git a/src/filelock.c b/src/filelock.c
index de65c52efa1..67e8dbd34ed 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -407,9 +407,7 @@ create_lock_file (char *lfname, char *lock_info_str, bool force)
407 fcntl (fd, F_SETFD, FD_CLOEXEC); 407 fcntl (fd, F_SETFD, FD_CLOEXEC);
408 lock_info_len = strlen (lock_info_str); 408 lock_info_len = strlen (lock_info_str);
409 err = 0; 409 err = 0;
410 /* Use 'write', not 'emacs_write', as garbage collection 410 if (emacs_write (fd, lock_info_str, lock_info_len) != lock_info_len
411 might signal an error, which would leak FD. */
412 if (write (fd, lock_info_str, lock_info_len) != lock_info_len
413 || fchmod (fd, S_IRUSR | S_IRGRP | S_IROTH) != 0) 411 || fchmod (fd, S_IRUSR | S_IRGRP | S_IROTH) != 0)
414 err = errno; 412 err = errno;
415 /* There is no need to call fsync here, as the contents of 413 /* 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])
490 int fd = emacs_open (lfname, O_RDONLY | O_NOFOLLOW, 0); 488 int fd = emacs_open (lfname, O_RDONLY | O_NOFOLLOW, 0);
491 if (0 <= fd) 489 if (0 <= fd)
492 { 490 {
493 /* Use read, not emacs_read, since FD isn't unwind-protected. */ 491 ptrdiff_t read_bytes = emacs_read (fd, lfinfo, MAX_LFINFO + 1);
494 ptrdiff_t read_bytes = read (fd, lfinfo, MAX_LFINFO + 1);
495 int read_errno = errno; 492 int read_errno = errno;
496 if (emacs_close (fd) != 0) 493 if (emacs_close (fd) != 0)
497 return -1; 494 return -1;
diff --git a/src/fns.c b/src/fns.c
index 5769eac9987..ac7c1f265a4 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -84,22 +84,6 @@ See Info node `(elisp)Random Numbers' for more details. */)
84 return make_number (val); 84 return make_number (val);
85} 85}
86 86
87/* Heuristic on how many iterations of a tight loop can be safely done
88 before it's time to do a quit. This must be a power of 2. It
89 is nice but not necessary for it to equal USHRT_MAX + 1. */
90enum { QUIT_COUNT_HEURISTIC = 1 << 16 };
91
92/* Process a quit, but do it only rarely, for efficiency. "Rarely"
93 means once per QUIT_COUNT_HEURISTIC or per USHRT_MAX + 1 times,
94 whichever is smaller. Use *QUIT_COUNT to count this. */
95
96static void
97rarely_quit (unsigned short int *quit_count)
98{
99 if (! (++*quit_count & (QUIT_COUNT_HEURISTIC - 1)))
100 maybe_quit ();
101}
102
103/* Random data-structure functions. */ 87/* Random data-structure functions. */
104 88
105DEFUN ("length", Flength, Slength, 1, 1, 0, 89DEFUN ("length", Flength, Slength, 1, 1, 0,
@@ -1359,20 +1343,17 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1359 (Lisp_Object n, Lisp_Object list) 1343 (Lisp_Object n, Lisp_Object list)
1360{ 1344{
1361 CHECK_NUMBER (n); 1345 CHECK_NUMBER (n);
1362 EMACS_INT num = XINT (n);
1363 Lisp_Object tail = list; 1346 Lisp_Object tail = list;
1364 immediate_quit = true; 1347 for (EMACS_INT num = XINT (n); 0 < num; num--)
1365 for (EMACS_INT i = 0; i < num; i++)
1366 { 1348 {
1367 if (! CONSP (tail)) 1349 if (! CONSP (tail))
1368 { 1350 {
1369 immediate_quit = false;
1370 CHECK_LIST_END (tail, list); 1351 CHECK_LIST_END (tail, list);
1371 return Qnil; 1352 return Qnil;
1372 } 1353 }
1373 tail = XCDR (tail); 1354 tail = XCDR (tail);
1355 rarely_quit (num);
1374 } 1356 }
1375 immediate_quit = false;
1376 return tail; 1357 return tail;
1377} 1358}
1378 1359
@@ -1408,7 +1389,7 @@ The value is actually the tail of LIST whose car is ELT. */)
1408 { 1389 {
1409 if (! NILP (Fequal (elt, XCAR (tail)))) 1390 if (! NILP (Fequal (elt, XCAR (tail))))
1410 return tail; 1391 return tail;
1411 rarely_quit (&quit_count); 1392 rarely_quit (++quit_count);
1412 } 1393 }
1413 CHECK_LIST_END (tail, list); 1394 CHECK_LIST_END (tail, list);
1414 return Qnil; 1395 return Qnil;
@@ -1419,17 +1400,14 @@ DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1419The value is actually the tail of LIST whose car is ELT. */) 1400The value is actually the tail of LIST whose car is ELT. */)
1420 (Lisp_Object elt, Lisp_Object list) 1401 (Lisp_Object elt, Lisp_Object list)
1421{ 1402{
1422 immediate_quit = true; 1403 unsigned short int quit_count = 0;
1423 Lisp_Object tail; 1404 Lisp_Object tail;
1424 for (tail = list; CONSP (tail); tail = XCDR (tail)) 1405 for (tail = list; CONSP (tail); tail = XCDR (tail))
1425 { 1406 {
1426 if (EQ (XCAR (tail), elt)) 1407 if (EQ (XCAR (tail), elt))
1427 { 1408 return tail;
1428 immediate_quit = false; 1409 rarely_quit (++quit_count);
1429 return tail;
1430 }
1431 } 1410 }
1432 immediate_quit = false;
1433 CHECK_LIST_END (tail, list); 1411 CHECK_LIST_END (tail, list);
1434 return Qnil; 1412 return Qnil;
1435} 1413}
@@ -1442,18 +1420,15 @@ The value is actually the tail of LIST whose car is ELT. */)
1442 if (!FLOATP (elt)) 1420 if (!FLOATP (elt))
1443 return Fmemq (elt, list); 1421 return Fmemq (elt, list);
1444 1422
1445 immediate_quit = true; 1423 unsigned short int quit_count = 0;
1446 Lisp_Object tail; 1424 Lisp_Object tail;
1447 for (tail = list; CONSP (tail); tail = XCDR (tail)) 1425 for (tail = list; CONSP (tail); tail = XCDR (tail))
1448 { 1426 {
1449 Lisp_Object tem = XCAR (tail); 1427 Lisp_Object tem = XCAR (tail);
1450 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil)) 1428 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil))
1451 { 1429 return tail;
1452 immediate_quit = false; 1430 rarely_quit (++quit_count);
1453 return tail;
1454 }
1455 } 1431 }
1456 immediate_quit = false;
1457 CHECK_LIST_END (tail, list); 1432 CHECK_LIST_END (tail, list);
1458 return Qnil; 1433 return Qnil;
1459} 1434}
@@ -1464,15 +1439,14 @@ The value is actually the first element of LIST whose car is KEY.
1464Elements of LIST that are not conses are ignored. */) 1439Elements of LIST that are not conses are ignored. */)
1465 (Lisp_Object key, Lisp_Object list) 1440 (Lisp_Object key, Lisp_Object list)
1466{ 1441{
1467 immediate_quit = true; 1442 unsigned short int quit_count = 0;
1468 Lisp_Object tail; 1443 Lisp_Object tail;
1469 for (tail = list; CONSP (tail); tail = XCDR (tail)) 1444 for (tail = list; CONSP (tail); tail = XCDR (tail))
1470 if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key)) 1445 {
1471 { 1446 if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
1472 immediate_quit = false;
1473 return XCAR (tail); 1447 return XCAR (tail);
1474 } 1448 rarely_quit (++quit_count);
1475 immediate_quit = true; 1449 }
1476 CHECK_LIST_END (tail, list); 1450 CHECK_LIST_END (tail, list);
1477 return Qnil; 1451 return Qnil;
1478} 1452}
@@ -1502,7 +1476,7 @@ The value is actually the first element of LIST whose car equals KEY. */)
1502 if (CONSP (car) 1476 if (CONSP (car)
1503 && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))) 1477 && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key))))
1504 return car; 1478 return car;
1505 rarely_quit (&quit_count); 1479 rarely_quit (++quit_count);
1506 } 1480 }
1507 CHECK_LIST_END (tail, list); 1481 CHECK_LIST_END (tail, list);
1508 return Qnil; 1482 return Qnil;
@@ -1529,15 +1503,14 @@ DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1529The value is actually the first element of LIST whose cdr is KEY. */) 1503The value is actually the first element of LIST whose cdr is KEY. */)
1530 (Lisp_Object key, Lisp_Object list) 1504 (Lisp_Object key, Lisp_Object list)
1531{ 1505{
1532 immediate_quit = true; 1506 unsigned short int quit_count = 0;
1533 Lisp_Object tail; 1507 Lisp_Object tail;
1534 for (tail = list; CONSP (tail); tail = XCDR (tail)) 1508 for (tail = list; CONSP (tail); tail = XCDR (tail))
1535 if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key)) 1509 {
1536 { 1510 if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key))
1537 immediate_quit = false;
1538 return XCAR (tail); 1511 return XCAR (tail);
1539 } 1512 rarely_quit (++quit_count);
1540 immediate_quit = true; 1513 }
1541 CHECK_LIST_END (tail, list); 1514 CHECK_LIST_END (tail, list);
1542 return Qnil; 1515 return Qnil;
1543} 1516}
@@ -1555,7 +1528,7 @@ The value is actually the first element of LIST whose cdr equals KEY. */)
1555 if (CONSP (car) 1528 if (CONSP (car)
1556 && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key)))) 1529 && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key))))
1557 return car; 1530 return car;
1558 rarely_quit (&quit_count); 1531 rarely_quit (++quit_count);
1559 } 1532 }
1560 CHECK_LIST_END (tail, list); 1533 CHECK_LIST_END (tail, list);
1561 return Qnil; 1534 return Qnil;
@@ -1589,6 +1562,7 @@ argument. */)
1589 else 1562 else
1590 prev = tail; 1563 prev = tail;
1591 } 1564 }
1565 CHECK_LIST_END (tail, list);
1592 return list; 1566 return list;
1593} 1567}
1594 1568
@@ -1710,7 +1684,7 @@ changing the value of a sequence `foo'. */)
1710 } 1684 }
1711 else 1685 else
1712 prev = tail; 1686 prev = tail;
1713 rarely_quit (&quit_count); 1687 rarely_quit (++quit_count);
1714 } 1688 }
1715 CHECK_LIST_END (tail, seq); 1689 CHECK_LIST_END (tail, seq);
1716 } 1690 }
@@ -1735,10 +1709,10 @@ This function may destructively modify SEQ to produce the value. */)
1735 1709
1736 for (prev = Qnil, tail = seq; CONSP (tail); tail = next) 1710 for (prev = Qnil, tail = seq; CONSP (tail); tail = next)
1737 { 1711 {
1738 rarely_quit (&quit_count);
1739 next = XCDR (tail); 1712 next = XCDR (tail);
1740 Fsetcdr (tail, prev); 1713 Fsetcdr (tail, prev);
1741 prev = tail; 1714 prev = tail;
1715 rarely_quit (++quit_count);
1742 } 1716 }
1743 CHECK_LIST_END (tail, seq); 1717 CHECK_LIST_END (tail, seq);
1744 seq = prev; 1718 seq = prev;
@@ -1784,8 +1758,8 @@ See also the function `nreverse', which is used more often. */)
1784 unsigned short int quit_count = 0; 1758 unsigned short int quit_count = 0;
1785 for (new = Qnil; CONSP (seq); seq = XCDR (seq)) 1759 for (new = Qnil; CONSP (seq); seq = XCDR (seq))
1786 { 1760 {
1787 rarely_quit (&quit_count);
1788 new = Fcons (XCAR (seq), new); 1761 new = Fcons (XCAR (seq), new);
1762 rarely_quit (++quit_count);
1789 } 1763 }
1790 CHECK_LIST_END (seq, seq); 1764 CHECK_LIST_END (seq, seq);
1791 } 1765 }
@@ -2076,21 +2050,20 @@ use `(setq x (plist-put x prop val))' to be sure to use the new value.
2076The PLIST is modified by side effects. */) 2050The PLIST is modified by side effects. */)
2077 (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) 2051 (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
2078{ 2052{
2079 immediate_quit = true; 2053 unsigned short int quit_count = 0;
2080 Lisp_Object prev = Qnil; 2054 Lisp_Object prev = Qnil;
2081 for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail)); 2055 for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2082 tail = XCDR (XCDR (tail))) 2056 tail = XCDR (XCDR (tail)))
2083 { 2057 {
2084 if (EQ (prop, XCAR (tail))) 2058 if (EQ (prop, XCAR (tail)))
2085 { 2059 {
2086 immediate_quit = false;
2087 Fsetcar (XCDR (tail), val); 2060 Fsetcar (XCDR (tail), val);
2088 return plist; 2061 return plist;
2089 } 2062 }
2090 2063
2091 prev = tail; 2064 prev = tail;
2065 rarely_quit (++quit_count);
2092 } 2066 }
2093 immediate_quit = true;
2094 Lisp_Object newcell 2067 Lisp_Object newcell
2095 = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev)))); 2068 = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
2096 if (NILP (prev)) 2069 if (NILP (prev))
@@ -2127,7 +2100,7 @@ one of the properties on the list. */)
2127 { 2100 {
2128 if (! NILP (Fequal (prop, XCAR (tail)))) 2101 if (! NILP (Fequal (prop, XCAR (tail))))
2129 return XCAR (XCDR (tail)); 2102 return XCAR (XCDR (tail));
2130 rarely_quit (&quit_count); 2103 rarely_quit (++quit_count);
2131 } 2104 }
2132 2105
2133 CHECK_LIST_END (tail, prop); 2106 CHECK_LIST_END (tail, prop);
@@ -2157,7 +2130,7 @@ The PLIST is modified by side effects. */)
2157 } 2130 }
2158 2131
2159 prev = tail; 2132 prev = tail;
2160 rarely_quit (&quit_count); 2133 rarely_quit (++quit_count);
2161 } 2134 }
2162 Lisp_Object newcell = list2 (prop, val); 2135 Lisp_Object newcell = list2 (prop, val);
2163 if (NILP (prev)) 2136 if (NILP (prev))
@@ -2237,7 +2210,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props,
2237 2210
2238 unsigned short int quit_count = 0; 2211 unsigned short int quit_count = 0;
2239 tail_recurse: 2212 tail_recurse:
2240 rarely_quit (&quit_count); 2213 rarely_quit (++quit_count);
2241 if (EQ (o1, o2)) 2214 if (EQ (o1, o2))
2242 return 1; 2215 return 1;
2243 if (XTYPE (o1) != XTYPE (o2)) 2216 if (XTYPE (o1) != XTYPE (o2))
@@ -2441,18 +2414,15 @@ usage: (nconc &rest LISTS) */)
2441 2414
2442 CHECK_CONS (tem); 2415 CHECK_CONS (tem);
2443 2416
2444 immediate_quit = true;
2445 Lisp_Object tail; 2417 Lisp_Object tail;
2446 do 2418 do
2447 { 2419 {
2448 tail = tem; 2420 tail = tem;
2449 tem = XCDR (tail); 2421 tem = XCDR (tail);
2422 rarely_quit (++quit_count);
2450 } 2423 }
2451 while (CONSP (tem)); 2424 while (CONSP (tem));
2452 2425
2453 immediate_quit = false;
2454 rarely_quit (&quit_count);
2455
2456 tem = args[argnum + 1]; 2426 tem = args[argnum + 1];
2457 Fsetcdr (tail, tem); 2427 Fsetcdr (tail, tem);
2458 if (NILP (tem)) 2428 if (NILP (tem))
@@ -2873,13 +2843,13 @@ property and a property with the value nil.
2873The value is actually the tail of PLIST whose car is PROP. */) 2843The value is actually the tail of PLIST whose car is PROP. */)
2874 (Lisp_Object plist, Lisp_Object prop) 2844 (Lisp_Object plist, Lisp_Object prop)
2875{ 2845{
2876 immediate_quit = true; 2846 unsigned short int quit_count = 0;
2877 while (CONSP (plist) && !EQ (XCAR (plist), prop)) 2847 while (CONSP (plist) && !EQ (XCAR (plist), prop))
2878 { 2848 {
2879 plist = XCDR (plist); 2849 plist = XCDR (plist);
2880 plist = CDR (plist); 2850 plist = CDR (plist);
2851 rarely_quit (++quit_count);
2881 } 2852 }
2882 immediate_quit = false;
2883 return plist; 2853 return plist;
2884} 2854}
2885 2855
diff --git a/src/indent.c b/src/indent.c
index 23951a16eb6..f630ebb847c 100644
--- a/src/indent.c
+++ b/src/indent.c
@@ -1200,9 +1200,6 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
1200 continuation_glyph_width = 0; /* In the fringe. */ 1200 continuation_glyph_width = 0; /* In the fringe. */
1201#endif 1201#endif
1202 1202
1203 immediate_quit = true;
1204 maybe_quit ();
1205
1206 /* It's just impossible to be too paranoid here. */ 1203 /* It's just impossible to be too paranoid here. */
1207 eassert (from == BYTE_TO_CHAR (frombyte) && frombyte == CHAR_TO_BYTE (from)); 1204 eassert (from == BYTE_TO_CHAR (frombyte) && frombyte == CHAR_TO_BYTE (from));
1208 1205
@@ -1214,8 +1211,12 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
1214 cmp_it.id = -1; 1211 cmp_it.id = -1;
1215 composition_compute_stop_pos (&cmp_it, pos, pos_byte, to, Qnil); 1212 composition_compute_stop_pos (&cmp_it, pos, pos_byte, to, Qnil);
1216 1213
1217 while (1) 1214 unsigned short int quit_count = 0;
1215
1216 while (true)
1218 { 1217 {
1218 rarely_quit (++quit_count);
1219
1219 while (pos == next_boundary) 1220 while (pos == next_boundary)
1220 { 1221 {
1221 ptrdiff_t pos_here = pos; 1222 ptrdiff_t pos_here = pos;
@@ -1280,6 +1281,8 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
1280 pos = newpos; 1281 pos = newpos;
1281 pos_byte = CHAR_TO_BYTE (pos); 1282 pos_byte = CHAR_TO_BYTE (pos);
1282 } 1283 }
1284
1285 rarely_quit (++quit_count);
1283 } 1286 }
1284 1287
1285 /* Handle right margin. */ 1288 /* Handle right margin. */
@@ -1602,6 +1605,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
1602 pos = find_before_next_newline (pos, to, 1, &pos_byte); 1605 pos = find_before_next_newline (pos, to, 1, &pos_byte);
1603 if (pos < to) 1606 if (pos < to)
1604 INC_BOTH (pos, pos_byte); 1607 INC_BOTH (pos, pos_byte);
1608 rarely_quit (++quit_count);
1605 } 1609 }
1606 while (pos < to 1610 while (pos < to
1607 && indented_beyond_p (pos, pos_byte, 1611 && indented_beyond_p (pos, pos_byte,
@@ -1694,7 +1698,6 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
1694 /* Nonzero if have just continued a line */ 1698 /* Nonzero if have just continued a line */
1695 val_compute_motion.contin = (contin_hpos && prev_hpos == 0); 1699 val_compute_motion.contin = (contin_hpos && prev_hpos == 0);
1696 1700
1697 immediate_quit = false;
1698 return &val_compute_motion; 1701 return &val_compute_motion;
1699} 1702}
1700 1703
diff --git a/src/keyboard.c b/src/keyboard.c
index d41603b2e50..a86e7c5f8e4 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -169,9 +169,6 @@ struct kboard *echo_kboard;
169 169
170Lisp_Object echo_message_buffer; 170Lisp_Object echo_message_buffer;
171 171
172/* True means C-g should cause immediate error-signal. */
173bool immediate_quit;
174
175/* Character that causes a quit. Normally C-g. 172/* Character that causes a quit. Normally C-g.
176 173
177 If we are running on an ordinary terminal, this must be an ordinary 174 If we are running on an ordinary terminal, this must be an ordinary
@@ -3584,16 +3581,7 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event,
3584 as input, set quit-flag to cause an interrupt. */ 3581 as input, set quit-flag to cause an interrupt. */
3585 if (!NILP (Vthrow_on_input) 3582 if (!NILP (Vthrow_on_input)
3586 && NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events))) 3583 && NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events)))
3587 { 3584 Vquit_flag = Vthrow_on_input;
3588 Vquit_flag = Vthrow_on_input;
3589 /* If we're inside a function that wants immediate quits,
3590 do it now. */
3591 if (immediate_quit && NILP (Vinhibit_quit))
3592 {
3593 immediate_quit = false;
3594 maybe_quit ();
3595 }
3596 }
3597} 3585}
3598 3586
3599 3587
@@ -7053,40 +7041,22 @@ tty_read_avail_input (struct terminal *terminal,
7053 7041
7054 /* Now read; for one reason or another, this will not block. 7042 /* Now read; for one reason or another, this will not block.
7055 NREAD is set to the number of chars read. */ 7043 NREAD is set to the number of chars read. */
7056 do 7044 nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read);
7057 { 7045 /* POSIX infers that processes which are not in the session leader's
7058 nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read); 7046 process group won't get SIGHUPs at logout time. BSDI adheres to
7059 /* POSIX infers that processes which are not in the session leader's 7047 this part standard and returns -1 from read (0) with errno==EIO
7060 process group won't get SIGHUPs at logout time. BSDI adheres to 7048 when the control tty is taken away.
7061 this part standard and returns -1 from read (0) with errno==EIO 7049 Jeffrey Honig <jch@bsdi.com> says this is generally safe. */
7062 when the control tty is taken away. 7050 if (nread == -1 && errno == EIO)
7063 Jeffrey Honig <jch@bsdi.com> says this is generally safe. */ 7051 return -2; /* Close this terminal. */
7064 if (nread == -1 && errno == EIO) 7052#if defined AIX && defined _BSD
7065 return -2; /* Close this terminal. */ 7053 /* The kernel sometimes fails to deliver SIGHUP for ptys.
7066#if defined (AIX) && defined (_BSD) 7054 This looks incorrect, but it isn't, because _BSD causes
7067 /* The kernel sometimes fails to deliver SIGHUP for ptys. 7055 O_NDELAY to be defined in fcntl.h as O_NONBLOCK,
7068 This looks incorrect, but it isn't, because _BSD causes 7056 and that causes a value other than 0 when there is no input. */
7069 O_NDELAY to be defined in fcntl.h as O_NONBLOCK, 7057 if (nread == 0)
7070 and that causes a value other than 0 when there is no input. */ 7058 return -2; /* Close this terminal. */
7071 if (nread == 0)
7072 return -2; /* Close this terminal. */
7073#endif
7074 }
7075 while (
7076 /* We used to retry the read if it was interrupted.
7077 But this does the wrong thing when O_NONBLOCK causes
7078 an EAGAIN error. Does anybody know of a situation
7079 where a retry is actually needed? */
7080#if 0
7081 nread < 0 && (errno == EAGAIN || errno == EFAULT
7082#ifdef EBADSLT
7083 || errno == EBADSLT
7084#endif
7085 )
7086#else
7087 0
7088#endif 7059#endif
7089 );
7090 7060
7091#ifndef USABLE_FIONREAD 7061#ifndef USABLE_FIONREAD
7092#if defined (USG) || defined (CYGWIN) 7062#if defined (USG) || defined (CYGWIN)
@@ -10445,30 +10415,12 @@ handle_interrupt (bool in_signal_handler)
10445 } 10415 }
10446 else 10416 else
10447 { 10417 {
10448 /* If executing a function that wants to be interrupted out of 10418 /* Request quit when it's safe. */
10449 and the user has not deferred quitting by binding `inhibit-quit' 10419 int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1;
10450 then quit right away. */ 10420 force_quit_count = count;
10451 if (immediate_quit && NILP (Vinhibit_quit)) 10421 if (count == 3)
10452 { 10422 Vinhibit_quit = Qnil;
10453 struct gl_state_s saved; 10423 Vquit_flag = Qt;
10454
10455 immediate_quit = false;
10456 pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
10457 saved = gl_state;
10458 quit ();
10459 gl_state = saved;
10460 }
10461 else
10462 { /* Else request quit when it's safe. */
10463 int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1;
10464 force_quit_count = count;
10465 if (count == 3)
10466 {
10467 immediate_quit = true;
10468 Vinhibit_quit = Qnil;
10469 }
10470 Vquit_flag = Qt;
10471 }
10472 } 10424 }
10473 10425
10474 pthread_sigmask (SIG_SETMASK, &empty_mask, 0); 10426 pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
@@ -10907,7 +10859,6 @@ init_keyboard (void)
10907{ 10859{
10908 /* This is correct before outermost invocation of the editor loop. */ 10860 /* This is correct before outermost invocation of the editor loop. */
10909 command_loop_level = -1; 10861 command_loop_level = -1;
10910 immediate_quit = false;
10911 quit_char = Ctl ('g'); 10862 quit_char = Ctl ('g');
10912 Vunread_command_events = Qnil; 10863 Vunread_command_events = Qnil;
10913 timer_idleness_start_time = invalid_timespec (); 10864 timer_idleness_start_time = invalid_timespec ();
diff --git a/src/lisp.h b/src/lisp.h
index 91c430fe98d..a9011b4a8be 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1995,8 +1995,8 @@ struct Lisp_Hash_Table
1995 hash table size to reduce collisions. */ 1995 hash table size to reduce collisions. */
1996 Lisp_Object index; 1996 Lisp_Object index;
1997 1997
1998 /* Non-nil if the table can be purecopied. Any changes the table after 1998 /* Non-nil if the table can be purecopied. The table cannot be
1999 purecopy will result in an error. */ 1999 changed afterwards. */
2000 Lisp_Object pure; 2000 Lisp_Object pure;
2001 2001
2002 /* Only the fields above are traced normally by the GC. The ones below 2002 /* Only the fields above are traced normally by the GC. The ones below
@@ -3123,29 +3123,28 @@ struct handler
3123 3123
3124extern Lisp_Object memory_signal_data; 3124extern Lisp_Object memory_signal_data;
3125 3125
3126/* Check quit-flag and quit if it is non-nil. Typing C-g does not 3126extern void maybe_quit (void);
3127 directly cause a quit; it only sets Vquit_flag. So the program
3128 needs to call maybe_quit at times when it is safe to quit. Every
3129 loop that might run for a long time or might not exit ought to call
3130 maybe_quit at least once, at a safe place. Unless that is
3131 impossible, of course. But it is very desirable to avoid creating
3132 loops where maybe_quit is impossible.
3133 3127
3134 Exception: if you set immediate_quit, the handler that responds to 3128/* True if ought to quit now. */
3135 the C-g does the quit itself. This is a good thing to do around a
3136 loop that has no side effects and (in particular) cannot call
3137 arbitrary Lisp code.
3138 3129
3139 If quit-flag is set to `kill-emacs' the SIGINT handler has received 3130#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
3140 a request to exit Emacs when it is safe to do.
3141 3131
3142 When not quitting, process any pending signals. */ 3132/* Heuristic on how many iterations of a tight loop can be safely done
3133 before it's time to do a quit. This must be a power of 2. It
3134 is nice but not necessary for it to equal USHRT_MAX + 1. */
3143 3135
3144extern void maybe_quit (void); 3136enum { QUIT_COUNT_HEURISTIC = 1 << 16 };
3145 3137
3146/* True if ought to quit now. */ 3138/* Process a quit rarely, based on a counter COUNT, for efficiency.
3139 "Rarely" means once per QUIT_COUNT_HEURISTIC or per USHRT_MAX + 1
3140 times, whichever is smaller (somewhat arbitrary, but often faster). */
3147 3141
3148#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) 3142INLINE void
3143rarely_quit (unsigned short int count)
3144{
3145 if (! (count & (QUIT_COUNT_HEURISTIC - 1)))
3146 maybe_quit ();
3147}
3149 3148
3150extern Lisp_Object Vascii_downcase_table; 3149extern Lisp_Object Vascii_downcase_table;
3151extern Lisp_Object Vascii_canon_table; 3150extern Lisp_Object Vascii_canon_table;
@@ -4221,8 +4220,10 @@ extern int emacs_open (const char *, int, int);
4221extern int emacs_pipe (int[2]); 4220extern int emacs_pipe (int[2]);
4222extern int emacs_close (int); 4221extern int emacs_close (int);
4223extern ptrdiff_t emacs_read (int, void *, ptrdiff_t); 4222extern ptrdiff_t emacs_read (int, void *, ptrdiff_t);
4223extern ptrdiff_t emacs_read_quit (int, void *, ptrdiff_t);
4224extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t); 4224extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t);
4225extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t); 4225extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t);
4226extern ptrdiff_t emacs_write_quit (int, void const *, ptrdiff_t);
4226extern void emacs_perror (char const *); 4227extern void emacs_perror (char const *);
4227 4228
4228extern void unlock_all_files (void); 4229extern void unlock_all_files (void);
@@ -4348,9 +4349,6 @@ extern char my_edata[];
4348extern char my_endbss[]; 4349extern char my_endbss[];
4349extern char *my_endbss_static; 4350extern char *my_endbss_static;
4350 4351
4351/* True means ^G can quit instantly. */
4352extern bool immediate_quit;
4353
4354extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); 4352extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
4355extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); 4353extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
4356extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); 4354extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2));
@@ -4537,7 +4535,7 @@ enum
4537 use these only in macros like AUTO_CONS that declare a local 4535 use these only in macros like AUTO_CONS that declare a local
4538 variable whose lifetime will be clear to the programmer. */ 4536 variable whose lifetime will be clear to the programmer. */
4539#define STACK_CONS(a, b) \ 4537#define STACK_CONS(a, b) \
4540 make_lisp_ptr (&(union Aligned_Cons) { { a, { b } } }.s, Lisp_Cons) 4538 make_lisp_ptr (&((union Aligned_Cons) { { a, { b } } }).s, Lisp_Cons)
4541#define AUTO_CONS_EXPR(a, b) \ 4539#define AUTO_CONS_EXPR(a, b) \
4542 (USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b)) 4540 (USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b))
4543 4541
@@ -4583,8 +4581,7 @@ enum
4583 Lisp_Object name = \ 4581 Lisp_Object name = \
4584 (USE_STACK_STRING \ 4582 (USE_STACK_STRING \
4585 ? (make_lisp_ptr \ 4583 ? (make_lisp_ptr \
4586 ((&(union Aligned_String) \ 4584 ((&((union Aligned_String) {{len, -1, 0, (unsigned char *) (str)}}).s), \
4587 {{len, -1, 0, (unsigned char *) (str)}}.s), \
4588 Lisp_String)) \ 4585 Lisp_String)) \
4589 : make_unibyte_string (str, len)) 4586 : make_unibyte_string (str, len))
4590 4587
diff --git a/src/lread.c b/src/lread.c
index 17806922a8c..094aa628eec 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -910,7 +910,7 @@ safe_to_load_version (int fd)
910 910
911 /* Read the first few bytes from the file, and look for a line 911 /* Read the first few bytes from the file, and look for a line
912 specifying the byte compiler version used. */ 912 specifying the byte compiler version used. */
913 nbytes = emacs_read (fd, buf, sizeof buf); 913 nbytes = emacs_read_quit (fd, buf, sizeof buf);
914 if (nbytes > 0) 914 if (nbytes > 0)
915 { 915 {
916 /* Skip to the next newline, skipping over the initial `ELC' 916 /* Skip to the next newline, skipping over the initial `ELC'
diff --git a/src/process.c b/src/process.c
index dbd4358dd1a..434a3955b2c 100644
--- a/src/process.c
+++ b/src/process.c
@@ -3431,7 +3431,6 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
3431 break; 3431 break;
3432 } 3432 }
3433 3433
3434 immediate_quit = true;
3435 maybe_quit (); 3434 maybe_quit ();
3436 3435
3437 ret = connect (s, sa, addrlen); 3436 ret = connect (s, sa, addrlen);
@@ -3439,8 +3438,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
3439 3438
3440 if (ret == 0 || xerrno == EISCONN) 3439 if (ret == 0 || xerrno == EISCONN)
3441 { 3440 {
3442 /* The unwind-protect will be discarded afterwards. 3441 /* The unwind-protect will be discarded afterwards. */
3443 Likewise for immediate_quit. */
3444 break; 3442 break;
3445 } 3443 }
3446 3444
@@ -3481,8 +3479,6 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
3481 } 3479 }
3482#endif /* !WINDOWSNT */ 3480#endif /* !WINDOWSNT */
3483 3481
3484 immediate_quit = false;
3485
3486 /* Discard the unwind protect closing S. */ 3482 /* Discard the unwind protect closing S. */
3487 specpdl_ptr = specpdl + count; 3483 specpdl_ptr = specpdl + count;
3488 emacs_close (s); 3484 emacs_close (s);
@@ -3539,8 +3535,6 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
3539#endif 3535#endif
3540 } 3536 }
3541 3537
3542 immediate_quit = false;
3543
3544 if (s < 0) 3538 if (s < 0)
3545 { 3539 {
3546 /* If non-blocking got this far - and failed - assume non-blocking is 3540 /* If non-blocking got this far - and failed - assume non-blocking is
@@ -4012,7 +4006,6 @@ usage: (make-network-process &rest ARGS) */)
4012 struct addrinfo *res, *lres; 4006 struct addrinfo *res, *lres;
4013 int ret; 4007 int ret;
4014 4008
4015 immediate_quit = true;
4016 maybe_quit (); 4009 maybe_quit ();
4017 4010
4018 struct addrinfo hints; 4011 struct addrinfo hints;
@@ -4034,7 +4027,6 @@ usage: (make-network-process &rest ARGS) */)
4034#else 4027#else
4035 error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret); 4028 error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret);
4036#endif 4029#endif
4037 immediate_quit = false;
4038 4030
4039 for (lres = res; lres; lres = lres->ai_next) 4031 for (lres = res; lres; lres = lres->ai_next)
4040 addrinfos = Fcons (conv_addrinfo_to_lisp (lres), addrinfos); 4032 addrinfos = Fcons (conv_addrinfo_to_lisp (lres), addrinfos);
diff --git a/src/regex.c b/src/regex.c
index f6e67afef4c..796f868d1c2 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -1728,10 +1728,8 @@ typedef struct
1728 1728
1729/* Explicit quit checking is needed for Emacs, which uses polling to 1729/* Explicit quit checking is needed for Emacs, which uses polling to
1730 process input events. */ 1730 process input events. */
1731#ifdef emacs 1731#ifndef emacs
1732# define IMMEDIATE_QUIT_CHECK (immediate_quit ? maybe_quit () : (void) 0) 1732static void maybe_quit (void) {}
1733#else
1734# define IMMEDIATE_QUIT_CHECK ((void) 0)
1735#endif 1733#endif
1736 1734
1737/* Structure to manage work area for range table. */ 1735/* Structure to manage work area for range table. */
@@ -5820,7 +5818,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
5820 /* Unconditionally jump (without popping any failure points). */ 5818 /* Unconditionally jump (without popping any failure points). */
5821 case jump: 5819 case jump:
5822 unconditional_jump: 5820 unconditional_jump:
5823 IMMEDIATE_QUIT_CHECK; 5821 maybe_quit ();
5824 EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */ 5822 EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */
5825 DEBUG_PRINT ("EXECUTING jump %d ", mcnt); 5823 DEBUG_PRINT ("EXECUTING jump %d ", mcnt);
5826 p += mcnt; /* Do the jump. */ 5824 p += mcnt; /* Do the jump. */
@@ -6168,7 +6166,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
6168 6166
6169 /* We goto here if a matching operation fails. */ 6167 /* We goto here if a matching operation fails. */
6170 fail: 6168 fail:
6171 IMMEDIATE_QUIT_CHECK; 6169 maybe_quit ();
6172 if (!FAIL_STACK_EMPTY ()) 6170 if (!FAIL_STACK_EMPTY ())
6173 { 6171 {
6174 re_char *str, *pat; 6172 re_char *str, *pat;
diff --git a/src/search.c b/src/search.c
index f54f44c8818..33cb02aa7af 100644
--- a/src/search.c
+++ b/src/search.c
@@ -99,6 +99,25 @@ matcher_overflow (void)
99 error ("Stack overflow in regexp matcher"); 99 error ("Stack overflow in regexp matcher");
100} 100}
101 101
102static void
103freeze_buffer_relocation (void)
104{
105#ifdef REL_ALLOC
106 /* Prevent ralloc.c from relocating the current buffer while
107 searching it. */
108 r_alloc_inhibit_buffer_relocation (1);
109 record_unwind_protect_int (r_alloc_inhibit_buffer_relocation, 0);
110#endif
111}
112
113static void
114thaw_buffer_relocation (void)
115{
116#ifdef REL_ALLOC
117 unbind_to (SPECPDL_INDEX () - 1, Qnil);
118#endif
119}
120
102/* Compile a regexp and signal a Lisp error if anything goes wrong. 121/* Compile a regexp and signal a Lisp error if anything goes wrong.
103 PATTERN is the pattern to compile. 122 PATTERN is the pattern to compile.
104 CP is the place to put the result. 123 CP is the place to put the result.
@@ -277,7 +296,6 @@ looking_at_1 (Lisp_Object string, bool posix)
277 !NILP (BVAR (current_buffer, enable_multibyte_characters))); 296 !NILP (BVAR (current_buffer, enable_multibyte_characters)));
278 297
279 /* Do a pending quit right away, to avoid paradoxical behavior */ 298 /* Do a pending quit right away, to avoid paradoxical behavior */
280 immediate_quit = true;
281 maybe_quit (); 299 maybe_quit ();
282 300
283 /* Get pointers and sizes of the two strings 301 /* Get pointers and sizes of the two strings
@@ -301,20 +319,13 @@ looking_at_1 (Lisp_Object string, bool posix)
301 319
302 re_match_object = Qnil; 320 re_match_object = Qnil;
303 321
304#ifdef REL_ALLOC 322 freeze_buffer_relocation ();
305 /* Prevent ralloc.c from relocating the current buffer while
306 searching it. */
307 r_alloc_inhibit_buffer_relocation (1);
308#endif
309 i = re_match_2 (bufp, (char *) p1, s1, (char *) p2, s2, 323 i = re_match_2 (bufp, (char *) p1, s1, (char *) p2, s2,
310 PT_BYTE - BEGV_BYTE, 324 PT_BYTE - BEGV_BYTE,
311 (NILP (Vinhibit_changing_match_data) 325 (NILP (Vinhibit_changing_match_data)
312 ? &search_regs : NULL), 326 ? &search_regs : NULL),
313 ZV_BYTE - BEGV_BYTE); 327 ZV_BYTE - BEGV_BYTE);
314 immediate_quit = false; 328 thaw_buffer_relocation ();
315#ifdef REL_ALLOC
316 r_alloc_inhibit_buffer_relocation (0);
317#endif
318 329
319 if (i == -2) 330 if (i == -2)
320 matcher_overflow (); 331 matcher_overflow ();
@@ -399,7 +410,6 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
399 ? BVAR (current_buffer, case_canon_table) : Qnil), 410 ? BVAR (current_buffer, case_canon_table) : Qnil),
400 posix, 411 posix,
401 STRING_MULTIBYTE (string)); 412 STRING_MULTIBYTE (string));
402 immediate_quit = true;
403 re_match_object = string; 413 re_match_object = string;
404 414
405 val = re_search (bufp, SSDATA (string), 415 val = re_search (bufp, SSDATA (string),
@@ -407,7 +417,6 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
407 SBYTES (string) - pos_byte, 417 SBYTES (string) - pos_byte,
408 (NILP (Vinhibit_changing_match_data) 418 (NILP (Vinhibit_changing_match_data)
409 ? &search_regs : NULL)); 419 ? &search_regs : NULL));
410 immediate_quit = false;
411 420
412 /* Set last_thing_searched only when match data is changed. */ 421 /* Set last_thing_searched only when match data is changed. */
413 if (NILP (Vinhibit_changing_match_data)) 422 if (NILP (Vinhibit_changing_match_data))
@@ -471,13 +480,11 @@ fast_string_match_internal (Lisp_Object regexp, Lisp_Object string,
471 480
472 bufp = compile_pattern (regexp, 0, table, 481 bufp = compile_pattern (regexp, 0, table,
473 0, STRING_MULTIBYTE (string)); 482 0, STRING_MULTIBYTE (string));
474 immediate_quit = true;
475 re_match_object = string; 483 re_match_object = string;
476 484
477 val = re_search (bufp, SSDATA (string), 485 val = re_search (bufp, SSDATA (string),
478 SBYTES (string), 0, 486 SBYTES (string), 0,
479 SBYTES (string), 0); 487 SBYTES (string), 0);
480 immediate_quit = false;
481 return val; 488 return val;
482} 489}
483 490
@@ -498,9 +505,7 @@ fast_c_string_match_ignore_case (Lisp_Object regexp,
498 bufp = compile_pattern (regexp, 0, 505 bufp = compile_pattern (regexp, 0,
499 Vascii_canon_table, 0, 506 Vascii_canon_table, 0,
500 0); 507 0);
501 immediate_quit = true;
502 val = re_search (bufp, string, len, 0, len, 0); 508 val = re_search (bufp, string, len, 0, len, 0);
503 immediate_quit = false;
504 return val; 509 return val;
505} 510}
506 511
@@ -561,18 +566,10 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte,
561 } 566 }
562 567
563 buf = compile_pattern (regexp, 0, Qnil, 0, multibyte); 568 buf = compile_pattern (regexp, 0, Qnil, 0, multibyte);
564 immediate_quit = true; 569 freeze_buffer_relocation ();
565#ifdef REL_ALLOC
566 /* Prevent ralloc.c from relocating the current buffer while
567 searching it. */
568 r_alloc_inhibit_buffer_relocation (1);
569#endif
570 len = re_match_2 (buf, (char *) p1, s1, (char *) p2, s2, 570 len = re_match_2 (buf, (char *) p1, s1, (char *) p2, s2,
571 pos_byte, NULL, limit_byte); 571 pos_byte, NULL, limit_byte);
572#ifdef REL_ALLOC 572 thaw_buffer_relocation ();
573 r_alloc_inhibit_buffer_relocation (0);
574#endif
575 immediate_quit = false;
576 573
577 return len; 574 return len;
578} 575}
@@ -649,7 +646,7 @@ newline_cache_on_off (struct buffer *buf)
649 If BYTEPOS is not NULL, set *BYTEPOS to the byte position corresponding 646 If BYTEPOS is not NULL, set *BYTEPOS to the byte position corresponding
650 to the returned character position. 647 to the returned character position.
651 648
652 If ALLOW_QUIT, set immediate_quit. That's good to do 649 If ALLOW_QUIT, check for quitting. That's good to do
653 except when inside redisplay. */ 650 except when inside redisplay. */
654 651
655ptrdiff_t 652ptrdiff_t
@@ -685,8 +682,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
685 if (shortage != 0) 682 if (shortage != 0)
686 *shortage = 0; 683 *shortage = 0;
687 684
688 immediate_quit = allow_quit;
689
690 if (count > 0) 685 if (count > 0)
691 while (start != end) 686 while (start != end)
692 { 687 {
@@ -704,7 +699,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
704 ptrdiff_t next_change; 699 ptrdiff_t next_change;
705 int result = 1; 700 int result = 1;
706 701
707 immediate_quit = false;
708 while (start < end && result) 702 while (start < end && result)
709 { 703 {
710 ptrdiff_t lim1; 704 ptrdiff_t lim1;
@@ -757,7 +751,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
757 start_byte = end_byte; 751 start_byte = end_byte;
758 break; 752 break;
759 } 753 }
760 immediate_quit = allow_quit;
761 754
762 /* START should never be after END. */ 755 /* START should never be after END. */
763 if (start_byte > ceiling_byte) 756 if (start_byte > ceiling_byte)
@@ -810,11 +803,12 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
810 803
811 if (--count == 0) 804 if (--count == 0)
812 { 805 {
813 immediate_quit = false;
814 if (bytepos) 806 if (bytepos)
815 *bytepos = lim_byte + next; 807 *bytepos = lim_byte + next;
816 return BYTE_TO_CHAR (lim_byte + next); 808 return BYTE_TO_CHAR (lim_byte + next);
817 } 809 }
810 if (allow_quit)
811 maybe_quit ();
818 } 812 }
819 813
820 start_byte = lim_byte; 814 start_byte = lim_byte;
@@ -833,7 +827,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
833 ptrdiff_t next_change; 827 ptrdiff_t next_change;
834 int result = 1; 828 int result = 1;
835 829
836 immediate_quit = false;
837 while (start > end && result) 830 while (start > end && result)
838 { 831 {
839 ptrdiff_t lim1; 832 ptrdiff_t lim1;
@@ -870,7 +863,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
870 start_byte = end_byte; 863 start_byte = end_byte;
871 break; 864 break;
872 } 865 }
873 immediate_quit = allow_quit;
874 866
875 /* Start should never be at or before end. */ 867 /* Start should never be at or before end. */
876 if (start_byte <= ceiling_byte) 868 if (start_byte <= ceiling_byte)
@@ -918,11 +910,12 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
918 910
919 if (++count >= 0) 911 if (++count >= 0)
920 { 912 {
921 immediate_quit = false;
922 if (bytepos) 913 if (bytepos)
923 *bytepos = ceiling_byte + prev + 1; 914 *bytepos = ceiling_byte + prev + 1;
924 return BYTE_TO_CHAR (ceiling_byte + prev + 1); 915 return BYTE_TO_CHAR (ceiling_byte + prev + 1);
925 } 916 }
917 if (allow_quit)
918 maybe_quit ();
926 } 919 }
927 920
928 start_byte = ceiling_byte; 921 start_byte = ceiling_byte;
@@ -930,7 +923,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
930 } 923 }
931 } 924 }
932 925
933 immediate_quit = false;
934 if (shortage) 926 if (shortage)
935 *shortage = count * direction; 927 *shortage = count * direction;
936 if (bytepos) 928 if (bytepos)
@@ -954,7 +946,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
954 the number of line boundaries left unfound, and position at 946 the number of line boundaries left unfound, and position at
955 the limit we bumped up against. 947 the limit we bumped up against.
956 948
957 If ALLOW_QUIT, set immediate_quit. That's good to do 949 If ALLOW_QUIT, check for quitting. That's good to do
958 except in special cases. */ 950 except in special cases. */
959 951
960ptrdiff_t 952ptrdiff_t
@@ -1197,9 +1189,6 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
1197 trt, posix, 1189 trt, posix,
1198 !NILP (BVAR (current_buffer, enable_multibyte_characters))); 1190 !NILP (BVAR (current_buffer, enable_multibyte_characters)));
1199 1191
1200 immediate_quit = true; /* Quit immediately if user types ^G,
1201 because letting this function finish
1202 can take too long. */
1203 maybe_quit (); /* Do a pending quit right away, 1192 maybe_quit (); /* Do a pending quit right away,
1204 to avoid paradoxical behavior */ 1193 to avoid paradoxical behavior */
1205 /* Get pointers and sizes of the two strings 1194 /* Get pointers and sizes of the two strings
@@ -1222,11 +1211,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
1222 } 1211 }
1223 re_match_object = Qnil; 1212 re_match_object = Qnil;
1224 1213
1225#ifdef REL_ALLOC 1214 freeze_buffer_relocation ();
1226 /* Prevent ralloc.c from relocating the current buffer while
1227 searching it. */
1228 r_alloc_inhibit_buffer_relocation (1);
1229#endif
1230 1215
1231 while (n < 0) 1216 while (n < 0)
1232 { 1217 {
@@ -1268,13 +1253,11 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
1268 } 1253 }
1269 else 1254 else
1270 { 1255 {
1271 immediate_quit = false; 1256 thaw_buffer_relocation ();
1272#ifdef REL_ALLOC
1273 r_alloc_inhibit_buffer_relocation (0);
1274#endif
1275 return (n); 1257 return (n);
1276 } 1258 }
1277 n++; 1259 n++;
1260 maybe_quit ();
1278 } 1261 }
1279 while (n > 0) 1262 while (n > 0)
1280 { 1263 {
@@ -1313,18 +1296,13 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
1313 } 1296 }
1314 else 1297 else
1315 { 1298 {
1316 immediate_quit = false; 1299 thaw_buffer_relocation ();
1317#ifdef REL_ALLOC
1318 r_alloc_inhibit_buffer_relocation (0);
1319#endif
1320 return (0 - n); 1300 return (0 - n);
1321 } 1301 }
1322 n--; 1302 n--;
1303 maybe_quit ();
1323 } 1304 }
1324 immediate_quit = false; 1305 thaw_buffer_relocation ();
1325#ifdef REL_ALLOC
1326 r_alloc_inhibit_buffer_relocation (0);
1327#endif
1328 return (pos); 1306 return (pos);
1329 } 1307 }
1330 else /* non-RE case */ 1308 else /* non-RE case */
@@ -3231,8 +3209,6 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
3231 if (shortage != 0) 3209 if (shortage != 0)
3232 *shortage = 0; 3210 *shortage = 0;
3233 3211
3234 immediate_quit = allow_quit;
3235
3236 if (count > 0) 3212 if (count > 0)
3237 while (start != end) 3213 while (start != end)
3238 { 3214 {
@@ -3275,11 +3251,12 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
3275 3251
3276 if (--count == 0) 3252 if (--count == 0)
3277 { 3253 {
3278 immediate_quit = false;
3279 if (bytepos) 3254 if (bytepos)
3280 *bytepos = lim_byte + next; 3255 *bytepos = lim_byte + next;
3281 return BYTE_TO_CHAR (lim_byte + next); 3256 return BYTE_TO_CHAR (lim_byte + next);
3282 } 3257 }
3258 if (allow_quit)
3259 maybe_quit ();
3283 } 3260 }
3284 3261
3285 start_byte = lim_byte; 3262 start_byte = lim_byte;
@@ -3287,7 +3264,6 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
3287 } 3264 }
3288 } 3265 }
3289 3266
3290 immediate_quit = false;
3291 if (shortage) 3267 if (shortage)
3292 *shortage = count; 3268 *shortage = count;
3293 if (bytepos) 3269 if (bytepos)
diff --git a/src/syntax.c b/src/syntax.c
index f9e4093765c..7aa43e6e5c7 100644
--- a/src/syntax.c
+++ b/src/syntax.c
@@ -621,11 +621,9 @@ find_defun_start (ptrdiff_t pos, ptrdiff_t pos_byte)
621 SETUP_BUFFER_SYNTAX_TABLE (); 621 SETUP_BUFFER_SYNTAX_TABLE ();
622 while (PT > BEGV) 622 while (PT > BEGV)
623 { 623 {
624 int c;
625
626 /* Open-paren at start of line means we may have found our 624 /* Open-paren at start of line means we may have found our
627 defun-start. */ 625 defun-start. */
628 c = FETCH_CHAR_AS_MULTIBYTE (PT_BYTE); 626 int c = FETCH_CHAR_AS_MULTIBYTE (PT_BYTE);
629 if (SYNTAX (c) == Sopen) 627 if (SYNTAX (c) == Sopen)
630 { 628 {
631 SETUP_SYNTAX_TABLE (PT + 1, -1); /* Try again... */ 629 SETUP_SYNTAX_TABLE (PT + 1, -1); /* Try again... */
@@ -715,6 +713,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
715 ptrdiff_t nesting = 1; /* Current comment nesting. */ 713 ptrdiff_t nesting = 1; /* Current comment nesting. */
716 int c; 714 int c;
717 int syntax = 0; 715 int syntax = 0;
716 unsigned short int quit_count = 0;
718 717
719 /* FIXME: A }} comment-ender style leads to incorrect behavior 718 /* FIXME: A }} comment-ender style leads to incorrect behavior
720 in the case of {{ c }}} because we ignore the last two chars which are 719 in the case of {{ c }}} because we ignore the last two chars which are
@@ -724,6 +723,8 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
724 that determines quote parity to the comment-end. */ 723 that determines quote parity to the comment-end. */
725 while (from != stop) 724 while (from != stop)
726 { 725 {
726 rarely_quit (++quit_count);
727
727 ptrdiff_t temp_byte; 728 ptrdiff_t temp_byte;
728 int prev_syntax; 729 int prev_syntax;
729 bool com2start, com2end, comstart; 730 bool com2start, com2end, comstart;
@@ -951,7 +952,9 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
951 defun_start_byte = CHAR_TO_BYTE (defun_start); 952 defun_start_byte = CHAR_TO_BYTE (defun_start);
952 } 953 }
953 } 954 }
954 } while (defun_start < comment_end); 955 rarely_quit (++quit_count);
956 }
957 while (defun_start < comment_end);
955 958
956 from_byte = CHAR_TO_BYTE (from); 959 from_byte = CHAR_TO_BYTE (from);
957 UPDATE_SYNTAX_TABLE_FORWARD (from - 1); 960 UPDATE_SYNTAX_TABLE_FORWARD (from - 1);
@@ -1417,29 +1420,23 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value,
1417 COUNT negative means scan backward and stop at word beginning. */ 1420 COUNT negative means scan backward and stop at word beginning. */
1418 1421
1419ptrdiff_t 1422ptrdiff_t
1420scan_words (register ptrdiff_t from, register EMACS_INT count) 1423scan_words (ptrdiff_t from, EMACS_INT count)
1421{ 1424{
1422 register ptrdiff_t beg = BEGV; 1425 ptrdiff_t beg = BEGV;
1423 register ptrdiff_t end = ZV; 1426 ptrdiff_t end = ZV;
1424 register ptrdiff_t from_byte = CHAR_TO_BYTE (from); 1427 ptrdiff_t from_byte = CHAR_TO_BYTE (from);
1425 register enum syntaxcode code; 1428 enum syntaxcode code;
1426 int ch0, ch1; 1429 int ch0, ch1;
1427 Lisp_Object func, pos; 1430 Lisp_Object func, pos;
1428 1431
1429 immediate_quit = true;
1430 maybe_quit ();
1431
1432 SETUP_SYNTAX_TABLE (from, count); 1432 SETUP_SYNTAX_TABLE (from, count);
1433 1433
1434 while (count > 0) 1434 while (count > 0)
1435 { 1435 {
1436 while (1) 1436 while (true)
1437 { 1437 {
1438 if (from == end) 1438 if (from == end)
1439 { 1439 return 0;
1440 immediate_quit = false;
1441 return 0;
1442 }
1443 UPDATE_SYNTAX_TABLE_FORWARD (from); 1440 UPDATE_SYNTAX_TABLE_FORWARD (from);
1444 ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte); 1441 ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte);
1445 code = SYNTAX (ch0); 1442 code = SYNTAX (ch0);
@@ -1449,6 +1446,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
1449 break; 1446 break;
1450 if (code == Sword) 1447 if (code == Sword)
1451 break; 1448 break;
1449 rarely_quit (from);
1452 } 1450 }
1453 /* Now CH0 is a character which begins a word and FROM is the 1451 /* Now CH0 is a character which begins a word and FROM is the
1454 position of the next character. */ 1452 position of the next character. */
@@ -1477,19 +1475,17 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
1477 break; 1475 break;
1478 INC_BOTH (from, from_byte); 1476 INC_BOTH (from, from_byte);
1479 ch0 = ch1; 1477 ch0 = ch1;
1478 rarely_quit (from);
1480 } 1479 }
1481 } 1480 }
1482 count--; 1481 count--;
1483 } 1482 }
1484 while (count < 0) 1483 while (count < 0)
1485 { 1484 {
1486 while (1) 1485 while (true)
1487 { 1486 {
1488 if (from == beg) 1487 if (from == beg)
1489 { 1488 return 0;
1490 immediate_quit = false;
1491 return 0;
1492 }
1493 DEC_BOTH (from, from_byte); 1489 DEC_BOTH (from, from_byte);
1494 UPDATE_SYNTAX_TABLE_BACKWARD (from); 1490 UPDATE_SYNTAX_TABLE_BACKWARD (from);
1495 ch1 = FETCH_CHAR_AS_MULTIBYTE (from_byte); 1491 ch1 = FETCH_CHAR_AS_MULTIBYTE (from_byte);
@@ -1499,6 +1495,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
1499 break; 1495 break;
1500 if (code == Sword) 1496 if (code == Sword)
1501 break; 1497 break;
1498 rarely_quit (from);
1502 } 1499 }
1503 /* Now CH1 is a character which ends a word and FROM is the 1500 /* Now CH1 is a character which ends a word and FROM is the
1504 position of it. */ 1501 position of it. */
@@ -1531,13 +1528,12 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
1531 break; 1528 break;
1532 } 1529 }
1533 ch1 = ch0; 1530 ch1 = ch0;
1531 rarely_quit (from);
1534 } 1532 }
1535 } 1533 }
1536 count++; 1534 count++;
1537 } 1535 }
1538 1536
1539 immediate_quit = false;
1540
1541 return from; 1537 return from;
1542} 1538}
1543 1539
@@ -1921,7 +1917,6 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
1921 stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp; 1917 stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp;
1922 } 1918 }
1923 1919
1924 immediate_quit = true;
1925 /* This code may look up syntax tables using functions that rely on the 1920 /* This code may look up syntax tables using functions that rely on the
1926 gl_state object. To make sure this object is not out of date, 1921 gl_state object. To make sure this object is not out of date,
1927 let's initialize it manually. 1922 let's initialize it manually.
@@ -1971,9 +1966,10 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
1971 } 1966 }
1972 fwd_ok: 1967 fwd_ok:
1973 p += nbytes, pos++, pos_byte += nbytes; 1968 p += nbytes, pos++, pos_byte += nbytes;
1969 rarely_quit (pos);
1974 } 1970 }
1975 else 1971 else
1976 while (1) 1972 while (true)
1977 { 1973 {
1978 if (p >= stop) 1974 if (p >= stop)
1979 { 1975 {
@@ -1995,15 +1991,14 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
1995 break; 1991 break;
1996 fwd_unibyte_ok: 1992 fwd_unibyte_ok:
1997 p++, pos++, pos_byte++; 1993 p++, pos++, pos_byte++;
1994 rarely_quit (pos);
1998 } 1995 }
1999 } 1996 }
2000 else 1997 else
2001 { 1998 {
2002 if (multibyte) 1999 if (multibyte)
2003 while (1) 2000 while (true)
2004 { 2001 {
2005 unsigned char *prev_p;
2006
2007 if (p <= stop) 2002 if (p <= stop)
2008 { 2003 {
2009 if (p <= endp) 2004 if (p <= endp)
@@ -2011,8 +2006,11 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2011 p = GPT_ADDR; 2006 p = GPT_ADDR;
2012 stop = endp; 2007 stop = endp;
2013 } 2008 }
2014 prev_p = p; 2009 unsigned char *prev_p = p;
2015 while (--p >= stop && ! CHAR_HEAD_P (*p)); 2010 do
2011 p--;
2012 while (stop <= p && ! CHAR_HEAD_P (*p));
2013
2016 c = STRING_CHAR (p); 2014 c = STRING_CHAR (p);
2017 2015
2018 if (! NILP (iso_classes) && in_classes (c, iso_classes)) 2016 if (! NILP (iso_classes) && in_classes (c, iso_classes))
@@ -2036,9 +2034,10 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2036 } 2034 }
2037 back_ok: 2035 back_ok:
2038 pos--, pos_byte -= prev_p - p; 2036 pos--, pos_byte -= prev_p - p;
2037 rarely_quit (pos);
2039 } 2038 }
2040 else 2039 else
2041 while (1) 2040 while (true)
2042 { 2041 {
2043 if (p <= stop) 2042 if (p <= stop)
2044 { 2043 {
@@ -2060,11 +2059,11 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2060 break; 2059 break;
2061 back_unibyte_ok: 2060 back_unibyte_ok:
2062 p--, pos--, pos_byte--; 2061 p--, pos--, pos_byte--;
2062 rarely_quit (pos);
2063 } 2063 }
2064 } 2064 }
2065 2065
2066 SET_PT_BOTH (pos, pos_byte); 2066 SET_PT_BOTH (pos, pos_byte);
2067 immediate_quit = false;
2068 2067
2069 SAFE_FREE (); 2068 SAFE_FREE ();
2070 return make_number (PT - start_point); 2069 return make_number (PT - start_point);
@@ -2138,7 +2137,6 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2138 ptrdiff_t pos_byte = PT_BYTE; 2137 ptrdiff_t pos_byte = PT_BYTE;
2139 unsigned char *p, *endp, *stop; 2138 unsigned char *p, *endp, *stop;
2140 2139
2141 immediate_quit = true;
2142 SETUP_SYNTAX_TABLE (pos, forwardp ? 1 : -1); 2140 SETUP_SYNTAX_TABLE (pos, forwardp ? 1 : -1);
2143 2141
2144 if (forwardp) 2142 if (forwardp)
@@ -2167,6 +2165,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2167 if (! fastmap[SYNTAX (c)]) 2165 if (! fastmap[SYNTAX (c)])
2168 goto done; 2166 goto done;
2169 p += nbytes, pos++, pos_byte += nbytes; 2167 p += nbytes, pos++, pos_byte += nbytes;
2168 rarely_quit (pos);
2170 } 2169 }
2171 while (!parse_sexp_lookup_properties 2170 while (!parse_sexp_lookup_properties
2172 || pos < gl_state.e_property); 2171 || pos < gl_state.e_property);
@@ -2183,10 +2182,8 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2183 2182
2184 if (multibyte) 2183 if (multibyte)
2185 { 2184 {
2186 while (1) 2185 while (true)
2187 { 2186 {
2188 unsigned char *prev_p;
2189
2190 if (p <= stop) 2187 if (p <= stop)
2191 { 2188 {
2192 if (p <= endp) 2189 if (p <= endp)
@@ -2195,17 +2192,22 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2195 stop = endp; 2192 stop = endp;
2196 } 2193 }
2197 UPDATE_SYNTAX_TABLE_BACKWARD (pos - 1); 2194 UPDATE_SYNTAX_TABLE_BACKWARD (pos - 1);
2198 prev_p = p; 2195
2199 while (--p >= stop && ! CHAR_HEAD_P (*p)); 2196 unsigned char *prev_p = p;
2197 do
2198 p--;
2199 while (stop <= p && ! CHAR_HEAD_P (*p));
2200
2200 c = STRING_CHAR (p); 2201 c = STRING_CHAR (p);
2201 if (! fastmap[SYNTAX (c)]) 2202 if (! fastmap[SYNTAX (c)])
2202 break; 2203 break;
2203 pos--, pos_byte -= prev_p - p; 2204 pos--, pos_byte -= prev_p - p;
2205 rarely_quit (pos);
2204 } 2206 }
2205 } 2207 }
2206 else 2208 else
2207 { 2209 {
2208 while (1) 2210 while (true)
2209 { 2211 {
2210 if (p <= stop) 2212 if (p <= stop)
2211 { 2213 {
@@ -2218,13 +2220,13 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2218 if (! fastmap[SYNTAX (p[-1])]) 2220 if (! fastmap[SYNTAX (p[-1])])
2219 break; 2221 break;
2220 p--, pos--, pos_byte--; 2222 p--, pos--, pos_byte--;
2223 rarely_quit (pos);
2221 } 2224 }
2222 } 2225 }
2223 } 2226 }
2224 2227
2225 done: 2228 done:
2226 SET_PT_BOTH (pos, pos_byte); 2229 SET_PT_BOTH (pos, pos_byte);
2227 immediate_quit = false;
2228 2230
2229 return make_number (PT - start_point); 2231 return make_number (PT - start_point);
2230 } 2232 }
@@ -2286,9 +2288,10 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
2286 ptrdiff_t *charpos_ptr, ptrdiff_t *bytepos_ptr, 2288 ptrdiff_t *charpos_ptr, ptrdiff_t *bytepos_ptr,
2287 EMACS_INT *incomment_ptr, int *last_syntax_ptr) 2289 EMACS_INT *incomment_ptr, int *last_syntax_ptr)
2288{ 2290{
2289 register int c, c1; 2291 unsigned short int quit_count = 0;
2290 register enum syntaxcode code; 2292 int c, c1;
2291 register int syntax, other_syntax; 2293 enum syntaxcode code;
2294 int syntax, other_syntax;
2292 2295
2293 if (nesting <= 0) nesting = -1; 2296 if (nesting <= 0) nesting = -1;
2294 2297
@@ -2380,6 +2383,8 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
2380 UPDATE_SYNTAX_TABLE_FORWARD (from); 2383 UPDATE_SYNTAX_TABLE_FORWARD (from);
2381 nesting++; 2384 nesting++;
2382 } 2385 }
2386
2387 rarely_quit (++quit_count);
2383 } 2388 }
2384 *charpos_ptr = from; 2389 *charpos_ptr = from;
2385 *bytepos_ptr = from_byte; 2390 *bytepos_ptr = from_byte;
@@ -2407,14 +2412,12 @@ between them, return t; otherwise return nil. */)
2407 ptrdiff_t out_charpos, out_bytepos; 2412 ptrdiff_t out_charpos, out_bytepos;
2408 EMACS_INT dummy; 2413 EMACS_INT dummy;
2409 int dummy2; 2414 int dummy2;
2415 unsigned short int quit_count = 0;
2410 2416
2411 CHECK_NUMBER (count); 2417 CHECK_NUMBER (count);
2412 count1 = XINT (count); 2418 count1 = XINT (count);
2413 stop = count1 > 0 ? ZV : BEGV; 2419 stop = count1 > 0 ? ZV : BEGV;
2414 2420
2415 immediate_quit = true;
2416 maybe_quit ();
2417
2418 from = PT; 2421 from = PT;
2419 from_byte = PT_BYTE; 2422 from_byte = PT_BYTE;
2420 2423
@@ -2429,7 +2432,6 @@ between them, return t; otherwise return nil. */)
2429 if (from == stop) 2432 if (from == stop)
2430 { 2433 {
2431 SET_PT_BOTH (from, from_byte); 2434 SET_PT_BOTH (from, from_byte);
2432 immediate_quit = false;
2433 return Qnil; 2435 return Qnil;
2434 } 2436 }
2435 c = FETCH_CHAR_AS_MULTIBYTE (from_byte); 2437 c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
@@ -2456,6 +2458,7 @@ between them, return t; otherwise return nil. */)
2456 INC_BOTH (from, from_byte); 2458 INC_BOTH (from, from_byte);
2457 UPDATE_SYNTAX_TABLE_FORWARD (from); 2459 UPDATE_SYNTAX_TABLE_FORWARD (from);
2458 } 2460 }
2461 rarely_quit (++quit_count);
2459 } 2462 }
2460 while (code == Swhitespace || (code == Sendcomment && c == '\n')); 2463 while (code == Swhitespace || (code == Sendcomment && c == '\n'));
2461 2464
@@ -2463,7 +2466,6 @@ between them, return t; otherwise return nil. */)
2463 comstyle = ST_COMMENT_STYLE; 2466 comstyle = ST_COMMENT_STYLE;
2464 else if (code != Scomment) 2467 else if (code != Scomment)
2465 { 2468 {
2466 immediate_quit = false;
2467 DEC_BOTH (from, from_byte); 2469 DEC_BOTH (from, from_byte);
2468 SET_PT_BOTH (from, from_byte); 2470 SET_PT_BOTH (from, from_byte);
2469 return Qnil; 2471 return Qnil;
@@ -2474,7 +2476,6 @@ between them, return t; otherwise return nil. */)
2474 from = out_charpos; from_byte = out_bytepos; 2476 from = out_charpos; from_byte = out_bytepos;
2475 if (!found) 2477 if (!found)
2476 { 2478 {
2477 immediate_quit = false;
2478 SET_PT_BOTH (from, from_byte); 2479 SET_PT_BOTH (from, from_byte);
2479 return Qnil; 2480 return Qnil;
2480 } 2481 }
@@ -2486,23 +2487,19 @@ between them, return t; otherwise return nil. */)
2486 2487
2487 while (count1 < 0) 2488 while (count1 < 0)
2488 { 2489 {
2489 while (1) 2490 while (true)
2490 { 2491 {
2491 bool quoted;
2492 int syntax;
2493
2494 if (from <= stop) 2492 if (from <= stop)
2495 { 2493 {
2496 SET_PT_BOTH (BEGV, BEGV_BYTE); 2494 SET_PT_BOTH (BEGV, BEGV_BYTE);
2497 immediate_quit = false;
2498 return Qnil; 2495 return Qnil;
2499 } 2496 }
2500 2497
2501 DEC_BOTH (from, from_byte); 2498 DEC_BOTH (from, from_byte);
2502 /* char_quoted does UPDATE_SYNTAX_TABLE_BACKWARD (from). */ 2499 /* char_quoted does UPDATE_SYNTAX_TABLE_BACKWARD (from). */
2503 quoted = char_quoted (from, from_byte); 2500 bool quoted = char_quoted (from, from_byte);
2504 c = FETCH_CHAR_AS_MULTIBYTE (from_byte); 2501 c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
2505 syntax = SYNTAX_WITH_FLAGS (c); 2502 int syntax = SYNTAX_WITH_FLAGS (c);
2506 code = SYNTAX (c); 2503 code = SYNTAX (c);
2507 comstyle = 0; 2504 comstyle = 0;
2508 comnested = SYNTAX_FLAGS_COMMENT_NESTED (syntax); 2505 comnested = SYNTAX_FLAGS_COMMENT_NESTED (syntax);
@@ -2545,6 +2542,7 @@ between them, return t; otherwise return nil. */)
2545 } 2542 }
2546 else if (from == stop) 2543 else if (from == stop)
2547 break; 2544 break;
2545 rarely_quit (++quit_count);
2548 } 2546 }
2549 if (fence_found == 0) 2547 if (fence_found == 0)
2550 { 2548 {
@@ -2587,18 +2585,18 @@ between them, return t; otherwise return nil. */)
2587 else if (code != Swhitespace || quoted) 2585 else if (code != Swhitespace || quoted)
2588 { 2586 {
2589 leave: 2587 leave:
2590 immediate_quit = false;
2591 INC_BOTH (from, from_byte); 2588 INC_BOTH (from, from_byte);
2592 SET_PT_BOTH (from, from_byte); 2589 SET_PT_BOTH (from, from_byte);
2593 return Qnil; 2590 return Qnil;
2594 } 2591 }
2592
2593 rarely_quit (++quit_count);
2595 } 2594 }
2596 2595
2597 count1++; 2596 count1++;
2598 } 2597 }
2599 2598
2600 SET_PT_BOTH (from, from_byte); 2599 SET_PT_BOTH (from, from_byte);
2601 immediate_quit = false;
2602 return Qt; 2600 return Qt;
2603} 2601}
2604 2602
@@ -2632,6 +2630,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2632 EMACS_INT dummy; 2630 EMACS_INT dummy;
2633 int dummy2; 2631 int dummy2;
2634 bool multibyte_symbol_p = sexpflag && multibyte_syntax_as_symbol; 2632 bool multibyte_symbol_p = sexpflag && multibyte_syntax_as_symbol;
2633 unsigned short int quit_count = 0;
2635 2634
2636 if (depth > 0) min_depth = 0; 2635 if (depth > 0) min_depth = 0;
2637 2636
@@ -2640,7 +2639,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2640 2639
2641 from_byte = CHAR_TO_BYTE (from); 2640 from_byte = CHAR_TO_BYTE (from);
2642 2641
2643 immediate_quit = true;
2644 maybe_quit (); 2642 maybe_quit ();
2645 2643
2646 SETUP_SYNTAX_TABLE (from, count); 2644 SETUP_SYNTAX_TABLE (from, count);
@@ -2648,6 +2646,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2648 { 2646 {
2649 while (from < stop) 2647 while (from < stop)
2650 { 2648 {
2649 rarely_quit (++quit_count);
2651 bool comstart_first, prefix; 2650 bool comstart_first, prefix;
2652 int syntax, other_syntax; 2651 int syntax, other_syntax;
2653 UPDATE_SYNTAX_TABLE_FORWARD (from); 2652 UPDATE_SYNTAX_TABLE_FORWARD (from);
@@ -2716,6 +2715,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2716 goto done; 2715 goto done;
2717 } 2716 }
2718 INC_BOTH (from, from_byte); 2717 INC_BOTH (from, from_byte);
2718 rarely_quit (++quit_count);
2719 } 2719 }
2720 goto done; 2720 goto done;
2721 2721
@@ -2787,6 +2787,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2787 if (c_code == Scharquote || c_code == Sescape) 2787 if (c_code == Scharquote || c_code == Sescape)
2788 INC_BOTH (from, from_byte); 2788 INC_BOTH (from, from_byte);
2789 INC_BOTH (from, from_byte); 2789 INC_BOTH (from, from_byte);
2790 rarely_quit (++quit_count);
2790 } 2791 }
2791 INC_BOTH (from, from_byte); 2792 INC_BOTH (from, from_byte);
2792 if (!depth && sexpflag) goto done; 2793 if (!depth && sexpflag) goto done;
@@ -2801,7 +2802,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2801 if (depth) 2802 if (depth)
2802 goto lose; 2803 goto lose;
2803 2804
2804 immediate_quit = false;
2805 return Qnil; 2805 return Qnil;
2806 2806
2807 /* End of object reached */ 2807 /* End of object reached */
@@ -2813,11 +2813,11 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2813 { 2813 {
2814 while (from > stop) 2814 while (from > stop)
2815 { 2815 {
2816 int syntax; 2816 rarely_quit (++quit_count);
2817 DEC_BOTH (from, from_byte); 2817 DEC_BOTH (from, from_byte);
2818 UPDATE_SYNTAX_TABLE_BACKWARD (from); 2818 UPDATE_SYNTAX_TABLE_BACKWARD (from);
2819 c = FETCH_CHAR_AS_MULTIBYTE (from_byte); 2819 c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
2820 syntax= SYNTAX_WITH_FLAGS (c); 2820 int syntax = SYNTAX_WITH_FLAGS (c);
2821 code = syntax_multibyte (c, multibyte_symbol_p); 2821 code = syntax_multibyte (c, multibyte_symbol_p);
2822 if (depth == min_depth) 2822 if (depth == min_depth)
2823 last_good = from; 2823 last_good = from;
@@ -2889,6 +2889,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2889 default: goto done2; 2889 default: goto done2;
2890 } 2890 }
2891 DEC_BOTH (from, from_byte); 2891 DEC_BOTH (from, from_byte);
2892 rarely_quit (++quit_count);
2892 } 2893 }
2893 goto done2; 2894 goto done2;
2894 2895
@@ -2951,13 +2952,14 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2951 if (syntax_multibyte (c, multibyte_symbol_p) == code) 2952 if (syntax_multibyte (c, multibyte_symbol_p) == code)
2952 break; 2953 break;
2953 } 2954 }
2955 rarely_quit (++quit_count);
2954 } 2956 }
2955 if (code == Sstring_fence && !depth && sexpflag) goto done2; 2957 if (code == Sstring_fence && !depth && sexpflag) goto done2;
2956 break; 2958 break;
2957 2959
2958 case Sstring: 2960 case Sstring:
2959 stringterm = FETCH_CHAR_AS_MULTIBYTE (from_byte); 2961 stringterm = FETCH_CHAR_AS_MULTIBYTE (from_byte);
2960 while (1) 2962 while (true)
2961 { 2963 {
2962 if (from == stop) 2964 if (from == stop)
2963 goto lose; 2965 goto lose;
@@ -2971,6 +2973,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2971 == Sstring)) 2973 == Sstring))
2972 break; 2974 break;
2973 } 2975 }
2976 rarely_quit (++quit_count);
2974 } 2977 }
2975 if (!depth && sexpflag) goto done2; 2978 if (!depth && sexpflag) goto done2;
2976 break; 2979 break;
@@ -2984,7 +2987,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2984 if (depth) 2987 if (depth)
2985 goto lose; 2988 goto lose;
2986 2989
2987 immediate_quit = false;
2988 return Qnil; 2990 return Qnil;
2989 2991
2990 done2: 2992 done2:
@@ -2992,7 +2994,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2992 } 2994 }
2993 2995
2994 2996
2995 immediate_quit = false;
2996 XSETFASTINT (val, from); 2997 XSETFASTINT (val, from);
2997 return val; 2998 return val;
2998 2999
@@ -3085,6 +3086,7 @@ the prefix syntax flag (p). */)
3085 if (pos <= beg) 3086 if (pos <= beg)
3086 break; 3087 break;
3087 DEC_BOTH (pos, pos_byte); 3088 DEC_BOTH (pos, pos_byte);
3089 rarely_quit (pos);
3088 } 3090 }
3089 3091
3090 SET_PT_BOTH (opoint, opoint_byte); 3092 SET_PT_BOTH (opoint, opoint_byte);
@@ -3155,6 +3157,7 @@ scan_sexps_forward (struct lisp_parse_state *state,
3155 bool found; 3157 bool found;
3156 ptrdiff_t out_bytepos, out_charpos; 3158 ptrdiff_t out_bytepos, out_charpos;
3157 int temp; 3159 int temp;
3160 unsigned short int quit_count = 0;
3158 3161
3159 prev_from = from; 3162 prev_from = from;
3160 prev_from_byte = from_byte; 3163 prev_from_byte = from_byte;
@@ -3173,7 +3176,6 @@ do { prev_from = from; \
3173 UPDATE_SYNTAX_TABLE_FORWARD (from); \ 3176 UPDATE_SYNTAX_TABLE_FORWARD (from); \
3174 } while (0) 3177 } while (0)
3175 3178
3176 immediate_quit = true;
3177 maybe_quit (); 3179 maybe_quit ();
3178 3180
3179 depth = state->depth; 3181 depth = state->depth;
@@ -3225,6 +3227,7 @@ do { prev_from = from; \
3225 3227
3226 while (from < end) 3228 while (from < end)
3227 { 3229 {
3230 rarely_quit (++quit_count);
3228 INC_FROM; 3231 INC_FROM;
3229 3232
3230 if ((from < end) 3233 if ((from < end)
@@ -3281,6 +3284,7 @@ do { prev_from = from; \
3281 goto symdone; 3284 goto symdone;
3282 } 3285 }
3283 INC_FROM; 3286 INC_FROM;
3287 rarely_quit (++quit_count);
3284 } 3288 }
3285 symdone: 3289 symdone:
3286 curlevel->prev = curlevel->last; 3290 curlevel->prev = curlevel->last;
@@ -3391,6 +3395,7 @@ do { prev_from = from; \
3391 break; 3395 break;
3392 } 3396 }
3393 INC_FROM; 3397 INC_FROM;
3398 rarely_quit (++quit_count);
3394 } 3399 }
3395 } 3400 }
3396 string_end: 3401 string_end:
@@ -3432,7 +3437,6 @@ do { prev_from = from; \
3432 state->levelstarts); 3437 state->levelstarts);
3433 state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax) 3438 state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax)
3434 || state->quoted) ? prev_from_syntax : Smax; 3439 || state->quoted) ? prev_from_syntax : Smax;
3435 immediate_quit = false;
3436} 3440}
3437 3441
3438/* Convert a (lisp) parse state to the internal form used in 3442/* Convert a (lisp) parse state to the internal form used in
diff --git a/src/sysdep.c b/src/sysdep.c
index e172dc0aed4..91b2a5cb943 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)
382 so that another thread running glib won't find them. */ 382 so that another thread running glib won't find them. */
383 eassert (child > 0); 383 eassert (child > 0);
384 384
385 while ((pid = waitpid (child, status, options)) < 0) 385 while (true)
386 { 386 {
387 /* Note: the MS-Windows emulation of waitpid calls maybe_quit
388 internally. */
389 if (interruptible)
390 maybe_quit ();
391
392 pid = waitpid (child, status, options);
393 if (0 <= pid)
394 break;
395
387 /* Check that CHILD is a child process that has not been reaped, 396 /* Check that CHILD is a child process that has not been reaped,
388 and that STATUS and OPTIONS are valid. Otherwise abort, 397 and that STATUS and OPTIONS are valid. Otherwise abort,
389 as continuing after this internal error could cause Emacs to 398 as continuing after this internal error could cause Emacs to
390 become confused and kill innocent-victim processes. */ 399 become confused and kill innocent-victim processes. */
391 if (errno != EINTR) 400 if (errno != EINTR)
392 emacs_abort (); 401 emacs_abort ();
393
394 /* Note: the MS-Windows emulation of waitpid calls maybe_quit
395 internally. */
396 if (interruptible)
397 maybe_quit ();
398 } 402 }
399 403
400 /* If successful and status is requested, tell wait_reading_process_output 404 /* If successful and status is requested, tell wait_reading_process_output
@@ -2503,78 +2507,113 @@ emacs_close (int fd)
2503#define MAX_RW_COUNT (INT_MAX >> 18 << 18) 2507#define MAX_RW_COUNT (INT_MAX >> 18 << 18)
2504#endif 2508#endif
2505 2509
2506/* Read from FILEDESC to a buffer BUF with size NBYTE, retrying if interrupted. 2510/* Read from FD to a buffer BUF with size NBYTE.
2511 If interrupted, process any quits and pending signals immediately
2512 if INTERRUPTIBLE, and then retry the read unless quitting.
2507 Return the number of bytes read, which might be less than NBYTE. 2513 Return the number of bytes read, which might be less than NBYTE.
2508 On error, set errno and return -1. */ 2514 On error, set errno to a value other than EINTR, and return -1. */
2509ptrdiff_t 2515static ptrdiff_t
2510emacs_read (int fildes, void *buf, ptrdiff_t nbyte) 2516emacs_intr_read (int fd, void *buf, ptrdiff_t nbyte, bool interruptible)
2511{ 2517{
2512 ssize_t rtnval; 2518 ssize_t result;
2513 2519
2514 /* There is no need to check against MAX_RW_COUNT, since no caller ever 2520 /* There is no need to check against MAX_RW_COUNT, since no caller ever
2515 passes a size that large to emacs_read. */ 2521 passes a size that large to emacs_read. */
2522 do
2523 {
2524 if (interruptible)
2525 maybe_quit ();
2526 result = read (fd, buf, nbyte);
2527 }
2528 while (result < 0 && errno == EINTR);
2516 2529
2517 while ((rtnval = read (fildes, buf, nbyte)) == -1 2530 return result;
2518 && (errno == EINTR))
2519 maybe_quit ();
2520 return (rtnval);
2521} 2531}
2522 2532
2523/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if interrupted 2533/* Read from FD to a buffer BUF with size NBYTE.
2524 or if a partial write occurs. If interrupted, process pending 2534 If interrupted, retry the read. Return the number of bytes read,
2525 signals if PROCESS SIGNALS. Return the number of bytes written, setting 2535 which might be less than NBYTE. On error, set errno to a value
2526 errno if this is less than NBYTE. */ 2536 other than EINTR, and return -1. */
2537ptrdiff_t
2538emacs_read (int fd, void *buf, ptrdiff_t nbyte)
2539{
2540 return emacs_intr_read (fd, buf, nbyte, false);
2541}
2542
2543/* Like emacs_read, but also process quits and pending signals. */
2544ptrdiff_t
2545emacs_read_quit (int fd, void *buf, ptrdiff_t nbyte)
2546{
2547 return emacs_intr_read (fd, buf, nbyte, true);
2548}
2549
2550/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if
2551 interrupted or if a partial write occurs. Process any quits
2552 immediately if INTERRUPTIBLE is positive, and process any pending
2553 signals immediately if INTERRUPTIBLE is nonzero. Return the number
2554 of bytes written; if this is less than NBYTE, set errno to a value
2555 other than EINTR. */
2527static ptrdiff_t 2556static ptrdiff_t
2528emacs_full_write (int fildes, char const *buf, ptrdiff_t nbyte, 2557emacs_full_write (int fd, char const *buf, ptrdiff_t nbyte,
2529 bool process_signals) 2558 int interruptible)
2530{ 2559{
2531 ptrdiff_t bytes_written = 0; 2560 ptrdiff_t bytes_written = 0;
2532 2561
2533 while (nbyte > 0) 2562 while (nbyte > 0)
2534 { 2563 {
2535 ssize_t n = write (fildes, buf, min (nbyte, MAX_RW_COUNT)); 2564 ssize_t n = write (fd, buf, min (nbyte, MAX_RW_COUNT));
2536 2565
2537 if (n < 0) 2566 if (n < 0)
2538 { 2567 {
2539 if (errno == EINTR) 2568 if (errno != EINTR)
2569 break;
2570
2571 if (interruptible)
2540 { 2572 {
2541 /* I originally used maybe_quit but that might cause files to 2573 if (0 < interruptible)
2542 be truncated if you hit C-g in the middle of it. --Stef */ 2574 maybe_quit ();
2543 if (process_signals && pending_signals) 2575 if (pending_signals)
2544 process_pending_signals (); 2576 process_pending_signals ();
2545 continue;
2546 } 2577 }
2547 else
2548 break;
2549 } 2578 }
2550 2579 else
2551 buf += n; 2580 {
2552 nbyte -= n; 2581 buf += n;
2553 bytes_written += n; 2582 nbyte -= n;
2583 bytes_written += n;
2584 }
2554 } 2585 }
2555 2586
2556 return bytes_written; 2587 return bytes_written;
2557} 2588}
2558 2589
2559/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if 2590/* Write to FD from a buffer BUF with size NBYTE, retrying if
2560 interrupted or if a partial write occurs. Return the number of 2591 interrupted or if a partial write occurs. Do not process quits or
2561 bytes written, setting errno if this is less than NBYTE. */ 2592 pending signals. Return the number of bytes written, setting errno
2593 if this is less than NBYTE. */
2594ptrdiff_t
2595emacs_write (int fd, void const *buf, ptrdiff_t nbyte)
2596{
2597 return emacs_full_write (fd, buf, nbyte, 0);
2598}
2599
2600/* Like emacs_write, but also process pending signals. */
2562ptrdiff_t 2601ptrdiff_t
2563emacs_write (int fildes, void const *buf, ptrdiff_t nbyte) 2602emacs_write_sig (int fd, void const *buf, ptrdiff_t nbyte)
2564{ 2603{
2565 return emacs_full_write (fildes, buf, nbyte, 0); 2604 return emacs_full_write (fd, buf, nbyte, -1);
2566} 2605}
2567 2606
2568/* Like emacs_write, but also process pending signals if interrupted. */ 2607/* Like emacs_write, but also process quits and pending signals. */
2569ptrdiff_t 2608ptrdiff_t
2570emacs_write_sig (int fildes, void const *buf, ptrdiff_t nbyte) 2609emacs_write_quit (int fd, void const *buf, ptrdiff_t nbyte)
2571{ 2610{
2572 return emacs_full_write (fildes, buf, nbyte, 1); 2611 return emacs_full_write (fd, buf, nbyte, 1);
2573} 2612}
2574 2613
2575/* Write a diagnostic to standard error that contains MESSAGE and a 2614/* Write a diagnostic to standard error that contains MESSAGE and a
2576 string derived from errno. Preserve errno. Do not buffer stderr. 2615 string derived from errno. Preserve errno. Do not buffer stderr.
2577 Do not process pending signals if interrupted. */ 2616 Do not process quits or pending signals if interrupted. */
2578void 2617void
2579emacs_perror (char const *message) 2618emacs_perror (char const *message)
2580{ 2619{
@@ -3168,7 +3207,7 @@ system_process_attributes (Lisp_Object pid)
3168 else 3207 else
3169 { 3208 {
3170 record_unwind_protect_int (close_file_unwind, fd); 3209 record_unwind_protect_int (close_file_unwind, fd);
3171 nread = emacs_read (fd, procbuf, sizeof procbuf - 1); 3210 nread = emacs_read_quit (fd, procbuf, sizeof procbuf - 1);
3172 } 3211 }
3173 if (0 < nread) 3212 if (0 < nread)
3174 { 3213 {
@@ -3289,7 +3328,7 @@ system_process_attributes (Lisp_Object pid)
3289 /* Leave room even if every byte needs escaping below. */ 3328 /* Leave room even if every byte needs escaping below. */
3290 readsize = (cmdline_size >> 1) - nread; 3329 readsize = (cmdline_size >> 1) - nread;
3291 3330
3292 nread_incr = emacs_read (fd, cmdline + nread, readsize); 3331 nread_incr = emacs_read_quit (fd, cmdline + nread, readsize);
3293 nread += max (0, nread_incr); 3332 nread += max (0, nread_incr);
3294 } 3333 }
3295 while (nread_incr == readsize); 3334 while (nread_incr == readsize);
@@ -3402,7 +3441,7 @@ system_process_attributes (Lisp_Object pid)
3402 else 3441 else
3403 { 3442 {
3404 record_unwind_protect_int (close_file_unwind, fd); 3443 record_unwind_protect_int (close_file_unwind, fd);
3405 nread = emacs_read (fd, &pinfo, sizeof pinfo); 3444 nread = emacs_read_quit (fd, &pinfo, sizeof pinfo);
3406 } 3445 }
3407 3446
3408 if (nread == sizeof pinfo) 3447 if (nread == sizeof pinfo)
diff --git a/src/w32fns.c b/src/w32fns.c
index 6a576fcec27..1b628b0b42e 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -3168,16 +3168,7 @@ signal_user_input (void)
3168 Vquit_flag = Vthrow_on_input; 3168 Vquit_flag = Vthrow_on_input;
3169 /* Calling maybe_quit from this thread is a bad idea, since this 3169 /* Calling maybe_quit from this thread is a bad idea, since this
3170 unwinds the stack of the Lisp thread, and the Windows runtime 3170 unwinds the stack of the Lisp thread, and the Windows runtime
3171 rightfully barfs. Disabled. */ 3171 rightfully barfs. */
3172#if 0
3173 /* If we're inside a function that wants immediate quits,
3174 do it now. */
3175 if (immediate_quit && NILP (Vinhibit_quit))
3176 {
3177 immediate_quit = false;
3178 maybe_quit ();
3179 }
3180#endif
3181 } 3172 }
3182} 3173}
3183 3174
diff --git a/src/window.c b/src/window.c
index 71a82b522c4..95690443f8e 100644
--- a/src/window.c
+++ b/src/window.c
@@ -4770,7 +4770,6 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool whole, bool noerror)
4770{ 4770{
4771 ptrdiff_t count = SPECPDL_INDEX (); 4771 ptrdiff_t count = SPECPDL_INDEX ();
4772 4772
4773 immediate_quit = true;
4774 n = clip_to_bounds (INT_MIN, n, INT_MAX); 4773 n = clip_to_bounds (INT_MIN, n, INT_MAX);
4775 4774
4776 wset_redisplay (XWINDOW (window)); 4775 wset_redisplay (XWINDOW (window));
@@ -4789,7 +4788,36 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool whole, bool noerror)
4789 4788
4790 /* Bug#15957. */ 4789 /* Bug#15957. */
4791 XWINDOW (window)->window_end_valid = false; 4790 XWINDOW (window)->window_end_valid = false;
4792 immediate_quit = false; 4791}
4792
4793/* Compute scroll margin for WINDOW.
4794 We scroll when point is within this distance from the top or bottom
4795 of the window. The result is measured in lines or in pixels
4796 depending on the second parameter. */
4797int
4798window_scroll_margin (struct window *window, enum margin_unit unit)
4799{
4800 if (scroll_margin > 0)
4801 {
4802 int frame_line_height = default_line_pixel_height (window);
4803 int window_lines = window_box_height (window) / frame_line_height;
4804
4805 double ratio = 0.25;
4806 if (FLOATP (Vmaximum_scroll_margin))
4807 {
4808 ratio = XFLOAT_DATA (Vmaximum_scroll_margin);
4809 ratio = max (0.0, ratio);
4810 ratio = min (ratio, 0.5);
4811 }
4812 int max_margin = min ((window_lines - 1)/2,
4813 (int) (window_lines * ratio));
4814 int margin = clip_to_bounds (0, scroll_margin, max_margin);
4815 return (unit == MARGIN_IN_PIXELS)
4816 ? margin * frame_line_height
4817 : margin;
4818 }
4819 else
4820 return 0;
4793} 4821}
4794 4822
4795 4823
@@ -4808,7 +4836,6 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
4808 bool vscrolled = false; 4836 bool vscrolled = false;
4809 int x, y, rtop, rbot, rowh, vpos; 4837 int x, y, rtop, rbot, rowh, vpos;
4810 void *itdata = NULL; 4838 void *itdata = NULL;
4811 int window_total_lines;
4812 int frame_line_height = default_line_pixel_height (w); 4839 int frame_line_height = default_line_pixel_height (w);
4813 bool adjust_old_pointm = !NILP (Fequal (Fwindow_point (window), 4840 bool adjust_old_pointm = !NILP (Fequal (Fwindow_point (window),
4814 Fwindow_old_point (window))); 4841 Fwindow_old_point (window)));
@@ -5064,12 +5091,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
5064 /* Move PT out of scroll margins. 5091 /* Move PT out of scroll margins.
5065 This code wants current_y to be zero at the window start position 5092 This code wants current_y to be zero at the window start position
5066 even if there is a header line. */ 5093 even if there is a header line. */
5067 window_total_lines 5094 this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
5068 = w->total_lines * WINDOW_FRAME_LINE_HEIGHT (w) / frame_line_height;
5069 this_scroll_margin = max (0, scroll_margin);
5070 this_scroll_margin
5071 = min (this_scroll_margin, window_total_lines / 4);
5072 this_scroll_margin *= frame_line_height;
5073 5095
5074 if (n > 0) 5096 if (n > 0)
5075 { 5097 {
@@ -5125,7 +5147,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
5125 in the scroll margin at the bottom. */ 5147 in the scroll margin at the bottom. */
5126 move_it_to (&it, PT, -1, 5148 move_it_to (&it, PT, -1,
5127 (it.last_visible_y - WINDOW_HEADER_LINE_HEIGHT (w) 5149 (it.last_visible_y - WINDOW_HEADER_LINE_HEIGHT (w)
5128 - this_scroll_margin - 1), 5150 - partial_line_height (&it) - this_scroll_margin - 1),
5129 -1, 5151 -1,
5130 MOVE_TO_POS | MOVE_TO_Y); 5152 MOVE_TO_POS | MOVE_TO_Y);
5131 5153
@@ -5292,9 +5314,7 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
5292 5314
5293 if (pos < ZV) 5315 if (pos < ZV)
5294 { 5316 {
5295 /* Don't use a scroll margin that is negative or too large. */ 5317 int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
5296 int this_scroll_margin =
5297 max (0, min (scroll_margin, w->total_lines / 4));
5298 5318
5299 set_marker_restricted_both (w->start, w->contents, pos, pos_byte); 5319 set_marker_restricted_both (w->start, w->contents, pos, pos_byte);
5300 w->start_at_line_beg = !NILP (bolp); 5320 w->start_at_line_beg = !NILP (bolp);
@@ -5724,8 +5744,7 @@ and redisplay normally--don't erase and redraw the frame. */)
5724 5744
5725 /* Do this after making BUF current 5745 /* Do this after making BUF current
5726 in case scroll_margin is buffer-local. */ 5746 in case scroll_margin is buffer-local. */
5727 this_scroll_margin 5747 this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
5728 = max (0, min (scroll_margin, w->total_lines / 4));
5729 5748
5730 /* Don't use redisplay code for initial frames, as the necessary 5749 /* Don't use redisplay code for initial frames, as the necessary
5731 data structures might not be set up yet then. */ 5750 data structures might not be set up yet then. */
@@ -5964,10 +5983,6 @@ from the top of the window. */)
5964 5983
5965 lines = displayed_window_lines (w); 5984 lines = displayed_window_lines (w);
5966 5985
5967#if false
5968 this_scroll_margin = max (0, min (scroll_margin, lines / 4));
5969#endif
5970
5971 if (NILP (arg)) 5986 if (NILP (arg))
5972 XSETFASTINT (arg, lines / 2); 5987 XSETFASTINT (arg, lines / 2);
5973 else 5988 else
@@ -5983,6 +5998,8 @@ from the top of the window. */)
5983 it is probably better not to install it. However, it is here 5998 it is probably better not to install it. However, it is here
5984 inside #if false so as not to lose it. -- rms. */ 5999 inside #if false so as not to lose it. -- rms. */
5985 6000
6001 this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
6002
5986 /* Don't let it get into the margin at either top or bottom. */ 6003 /* Don't let it get into the margin at either top or bottom. */
5987 iarg = max (iarg, this_scroll_margin); 6004 iarg = max (iarg, this_scroll_margin);
5988 iarg = min (iarg, lines - this_scroll_margin - 1); 6005 iarg = min (iarg, lines - this_scroll_margin - 1);
diff --git a/src/window.h b/src/window.h
index 061cf244943..acb8a5cabfa 100644
--- a/src/window.h
+++ b/src/window.h
@@ -1120,6 +1120,8 @@ extern bool compare_window_configurations (Lisp_Object, Lisp_Object, bool);
1120extern void mark_window_cursors_off (struct window *); 1120extern void mark_window_cursors_off (struct window *);
1121extern int window_internal_height (struct window *); 1121extern int window_internal_height (struct window *);
1122extern int window_body_width (struct window *w, bool); 1122extern int window_body_width (struct window *w, bool);
1123enum margin_unit { MARGIN_IN_LINES, MARGIN_IN_PIXELS };
1124extern int window_scroll_margin (struct window *, enum margin_unit);
1123extern void temp_output_buffer_show (Lisp_Object); 1125extern void temp_output_buffer_show (Lisp_Object);
1124extern void replace_buffer_in_windows (Lisp_Object); 1126extern void replace_buffer_in_windows (Lisp_Object);
1125extern void replace_buffer_in_windows_safely (Lisp_Object); 1127extern void replace_buffer_in_windows_safely (Lisp_Object);
diff --git a/src/xdisp.c b/src/xdisp.c
index 33661c882cd..0e329dfe6e9 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -9859,6 +9859,32 @@ move_it_by_lines (struct it *it, ptrdiff_t dvpos)
9859 } 9859 }
9860} 9860}
9861 9861
9862int
9863partial_line_height (struct it *it_origin)
9864{
9865 int partial_height;
9866 void *it_data = NULL;
9867 struct it it;
9868 SAVE_IT (it, *it_origin, it_data);
9869 move_it_to (&it, ZV, -1, it.last_visible_y, -1,
9870 MOVE_TO_POS | MOVE_TO_Y);
9871 if (it.what == IT_EOB)
9872 {
9873 int vis_height = it.last_visible_y - it.current_y;
9874 int height = it.ascent + it.descent;
9875 partial_height = (vis_height < height) ? vis_height : 0;
9876 }
9877 else
9878 {
9879 int last_line_y = it.current_y;
9880 move_it_by_lines (&it, 1);
9881 partial_height = (it.current_y > it.last_visible_y)
9882 ? it.last_visible_y - last_line_y : 0;
9883 }
9884 RESTORE_IT (&it, &it, it_data);
9885 return partial_height;
9886}
9887
9862/* Return true if IT points into the middle of a display vector. */ 9888/* Return true if IT points into the middle of a display vector. */
9863 9889
9864bool 9890bool
@@ -15316,7 +15342,6 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
15316 bool temp_scroll_step, bool last_line_misfit) 15342 bool temp_scroll_step, bool last_line_misfit)
15317{ 15343{
15318 struct window *w = XWINDOW (window); 15344 struct window *w = XWINDOW (window);
15319 struct frame *f = XFRAME (w->frame);
15320 struct text_pos pos, startp; 15345 struct text_pos pos, startp;
15321 struct it it; 15346 struct it it;
15322 int this_scroll_margin, scroll_max, rc, height; 15347 int this_scroll_margin, scroll_max, rc, height;
@@ -15327,8 +15352,6 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
15327 /* We will never try scrolling more than this number of lines. */ 15352 /* We will never try scrolling more than this number of lines. */
15328 int scroll_limit = SCROLL_LIMIT; 15353 int scroll_limit = SCROLL_LIMIT;
15329 int frame_line_height = default_line_pixel_height (w); 15354 int frame_line_height = default_line_pixel_height (w);
15330 int window_total_lines
15331 = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
15332 15355
15333#ifdef GLYPH_DEBUG 15356#ifdef GLYPH_DEBUG
15334 debug_method_add (w, "try_scrolling"); 15357 debug_method_add (w, "try_scrolling");
@@ -15336,13 +15359,7 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
15336 15359
15337 SET_TEXT_POS_FROM_MARKER (startp, w->start); 15360 SET_TEXT_POS_FROM_MARKER (startp, w->start);
15338 15361
15339 /* Compute scroll margin height in pixels. We scroll when point is 15362 this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
15340 within this distance from the top or bottom of the window. */
15341 if (scroll_margin > 0)
15342 this_scroll_margin = min (scroll_margin, window_total_lines / 4)
15343 * frame_line_height;
15344 else
15345 this_scroll_margin = 0;
15346 15363
15347 /* Force arg_scroll_conservatively to have a reasonable value, to 15364 /* Force arg_scroll_conservatively to have a reasonable value, to
15348 avoid scrolling too far away with slow move_it_* functions. Note 15365 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,
15377 /* Compute the pixel ypos of the scroll margin, then move IT to 15394 /* Compute the pixel ypos of the scroll margin, then move IT to
15378 either that ypos or PT, whichever comes first. */ 15395 either that ypos or PT, whichever comes first. */
15379 start_display (&it, w, startp); 15396 start_display (&it, w, startp);
15380 scroll_margin_y = it.last_visible_y - this_scroll_margin 15397 scroll_margin_y = it.last_visible_y - partial_line_height (&it)
15398 - this_scroll_margin
15381 - frame_line_height * extra_scroll_margin_lines; 15399 - frame_line_height * extra_scroll_margin_lines;
15382 move_it_to (&it, PT, -1, scroll_margin_y - 1, -1, 15400 move_it_to (&it, PT, -1, scroll_margin_y - 1, -1,
15383 (MOVE_TO_POS | MOVE_TO_Y)); 15401 (MOVE_TO_POS | MOVE_TO_Y));
@@ -15816,23 +15834,12 @@ try_cursor_movement (Lisp_Object window, struct text_pos startp,
15816 { 15834 {
15817 int this_scroll_margin, top_scroll_margin; 15835 int this_scroll_margin, top_scroll_margin;
15818 struct glyph_row *row = NULL; 15836 struct glyph_row *row = NULL;
15819 int frame_line_height = default_line_pixel_height (w);
15820 int window_total_lines
15821 = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
15822 15837
15823#ifdef GLYPH_DEBUG 15838#ifdef GLYPH_DEBUG
15824 debug_method_add (w, "cursor movement"); 15839 debug_method_add (w, "cursor movement");
15825#endif 15840#endif
15826 15841
15827 /* Scroll if point within this distance from the top or bottom 15842 this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
15828 of the window. This is a pixel value. */
15829 if (scroll_margin > 0)
15830 {
15831 this_scroll_margin = min (scroll_margin, window_total_lines / 4);
15832 this_scroll_margin *= frame_line_height;
15833 }
15834 else
15835 this_scroll_margin = 0;
15836 15843
15837 top_scroll_margin = this_scroll_margin; 15844 top_scroll_margin = this_scroll_margin;
15838 if (WINDOW_WANTS_HEADER_LINE_P (w)) 15845 if (WINDOW_WANTS_HEADER_LINE_P (w))
@@ -16280,7 +16287,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
16280 int centering_position = -1; 16287 int centering_position = -1;
16281 bool last_line_misfit = false; 16288 bool last_line_misfit = false;
16282 ptrdiff_t beg_unchanged, end_unchanged; 16289 ptrdiff_t beg_unchanged, end_unchanged;
16283 int frame_line_height; 16290 int frame_line_height, margin;
16284 bool use_desired_matrix; 16291 bool use_desired_matrix;
16285 void *itdata = NULL; 16292 void *itdata = NULL;
16286 16293
@@ -16310,6 +16317,8 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
16310 restart: 16317 restart:
16311 reconsider_clip_changes (w); 16318 reconsider_clip_changes (w);
16312 frame_line_height = default_line_pixel_height (w); 16319 frame_line_height = default_line_pixel_height (w);
16320 margin = window_scroll_margin (w, MARGIN_IN_LINES);
16321
16313 16322
16314 /* Has the mode line to be updated? */ 16323 /* Has the mode line to be updated? */
16315 update_mode_line = (w->update_mode_line 16324 update_mode_line = (w->update_mode_line
@@ -16614,10 +16623,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
16614 /* Some people insist on not letting point enter the scroll 16623 /* Some people insist on not letting point enter the scroll
16615 margin, even though this part handles windows that didn't 16624 margin, even though this part handles windows that didn't
16616 scroll at all. */ 16625 scroll at all. */
16617 int window_total_lines 16626 int pixel_margin = margin * frame_line_height;
16618 = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
16619 int margin = min (scroll_margin, window_total_lines / 4);
16620 int pixel_margin = margin * frame_line_height;
16621 bool header_line = WINDOW_WANTS_HEADER_LINE_P (w); 16627 bool header_line = WINDOW_WANTS_HEADER_LINE_P (w);
16622 16628
16623 /* Note: We add an extra FRAME_LINE_HEIGHT, because the loop 16629 /* 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)
16901 it.current_y = it.last_visible_y; 16907 it.current_y = it.last_visible_y;
16902 if (centering_position < 0) 16908 if (centering_position < 0)
16903 { 16909 {
16904 int window_total_lines
16905 = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
16906 int margin
16907 = scroll_margin > 0
16908 ? min (scroll_margin, window_total_lines / 4)
16909 : 0;
16910 ptrdiff_t margin_pos = CHARPOS (startp); 16910 ptrdiff_t margin_pos = CHARPOS (startp);
16911 Lisp_Object aggressive; 16911 Lisp_Object aggressive;
16912 bool scrolling_up; 16912 bool scrolling_up;
@@ -17150,10 +17150,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
17150 { 17150 {
17151 int window_total_lines 17151 int window_total_lines
17152 = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height; 17152 = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
17153 int margin =
17154 scroll_margin > 0
17155 ? min (scroll_margin, window_total_lines / 4)
17156 : 0;
17157 bool move_down = w->cursor.vpos >= window_total_lines / 2; 17153 bool move_down = w->cursor.vpos >= window_total_lines / 2;
17158 17154
17159 move_it_by_lines (&it, move_down ? margin + 1 : -(margin + 1)); 17155 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)
17359 struct it it; 17355 struct it it;
17360 struct glyph_row *last_text_row = NULL; 17356 struct glyph_row *last_text_row = NULL;
17361 struct frame *f = XFRAME (w->frame); 17357 struct frame *f = XFRAME (w->frame);
17362 int frame_line_height = default_line_pixel_height (w);
17363 17358
17364 /* Make POS the new window start. */ 17359 /* Make POS the new window start. */
17365 set_marker_both (w->start, Qnil, CHARPOS (pos), BYTEPOS (pos)); 17360 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)
17385 if ((flags & TRY_WINDOW_CHECK_MARGINS) 17380 if ((flags & TRY_WINDOW_CHECK_MARGINS)
17386 && !MINI_WINDOW_P (w)) 17381 && !MINI_WINDOW_P (w))
17387 { 17382 {
17388 int this_scroll_margin; 17383 int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
17389 int window_total_lines
17390 = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height;
17391
17392 if (scroll_margin > 0)
17393 {
17394 this_scroll_margin = min (scroll_margin, window_total_lines / 4);
17395 this_scroll_margin *= frame_line_height;
17396 }
17397 else
17398 this_scroll_margin = 0;
17399 17384
17400 if ((w->cursor.y >= 0 /* not vscrolled */ 17385 if ((w->cursor.y >= 0 /* not vscrolled */
17401 && w->cursor.y < this_scroll_margin 17386 && w->cursor.y < this_scroll_margin
@@ -18679,15 +18664,8 @@ try_window_id (struct window *w)
18679 18664
18680 /* Don't let the cursor end in the scroll margins. */ 18665 /* Don't let the cursor end in the scroll margins. */
18681 { 18666 {
18682 int this_scroll_margin, cursor_height; 18667 int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
18683 int frame_line_height = default_line_pixel_height (w); 18668 int cursor_height = MATRIX_ROW (w->desired_matrix, w->cursor.vpos)->height;
18684 int window_total_lines
18685 = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (it.f) / frame_line_height;
18686
18687 this_scroll_margin =
18688 max (0, min (scroll_margin, window_total_lines / 4));
18689 this_scroll_margin *= frame_line_height;
18690 cursor_height = MATRIX_ROW (w->desired_matrix, w->cursor.vpos)->height;
18691 18669
18692 if ((w->cursor.y < this_scroll_margin 18670 if ((w->cursor.y < this_scroll_margin
18693 && CHARPOS (start) > BEGV) 18671 && CHARPOS (start) > BEGV)
@@ -31569,6 +31547,14 @@ Recenter the window whenever point gets within this many lines
31569of the top or bottom of the window. */); 31547of the top or bottom of the window. */);
31570 scroll_margin = 0; 31548 scroll_margin = 0;
31571 31549
31550 DEFVAR_LISP ("maximum-scroll-margin", Vmaximum_scroll_margin,
31551 doc: /* Maximum effective value of `scroll-margin'.
31552Given as a fraction of the current window's lines. The value should
31553be a floating point number between 0.0 and 0.5. The effective maximum
31554is limited to (/ (1- window-lines) 2). Non-float values for this
31555variable are ignored and the default 0.25 is used instead. */);
31556 Vmaximum_scroll_margin = make_float (0.25);
31557
31572 DEFVAR_LISP ("display-pixels-per-inch", Vdisplay_pixels_per_inch, 31558 DEFVAR_LISP ("display-pixels-per-inch", Vdisplay_pixels_per_inch,
31573 doc: /* Pixels per inch value for non-window system displays. 31559 doc: /* Pixels per inch value for non-window system displays.
31574Value is a number or a cons (WIDTH-DPI . HEIGHT-DPI). */); 31560Value is a number or a cons (WIDTH-DPI . HEIGHT-DPI). */);
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el
index aea855ae02f..c6f103321c6 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -24,24 +24,29 @@
24;;; Code: 24;;; Code:
25 25
26(require 'ert) 26(require 'ert)
27(require 'ert-x)
27(require 'autorevert) 28(require 'autorevert)
28(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" 29(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded"
29 auto-revert-stop-on-user-input nil) 30 auto-revert-stop-on-user-input nil)
30 31
31(defconst auto-revert--timeout 10 32(defconst auto-revert--timeout 10
32 "Time to wait until a message appears in the *Messages* buffer.") 33 "Time to wait for a message.")
34
35(defvar auto-revert--messages nil
36 "Used to collect messages issued during a section of a test.")
33 37
34(defun auto-revert--wait-for-revert (buffer) 38(defun auto-revert--wait-for-revert (buffer)
35 "Wait until the *Messages* buffer reports reversion of BUFFER." 39 "Wait until a message reports reversion of BUFFER.
40This expects `auto-revert--messages' to be bound by
41`ert-with-message-capture' before calling."
36 (with-timeout (auto-revert--timeout nil) 42 (with-timeout (auto-revert--timeout nil)
37 (with-current-buffer "*Messages*" 43 (while
38 (while 44 (null (string-match
39 (null (string-match 45 (format-message "Reverting buffer `%s'." (buffer-name buffer))
40 (format-message "Reverting buffer `%s'." (buffer-name buffer)) 46 auto-revert--messages))
41 (buffer-string))) 47 (if (with-current-buffer buffer auto-revert-use-notify)
42 (if (with-current-buffer buffer auto-revert-use-notify) 48 (read-event nil nil 0.1)
43 (read-event nil nil 0.1) 49 (sleep-for 0.1)))))
44 (sleep-for 0.1))))))
45 50
46(ert-deftest auto-revert-test00-auto-revert-mode () 51(ert-deftest auto-revert-test00-auto-revert-mode ()
47 "Check autorevert for a file." 52 "Check autorevert for a file."
@@ -51,41 +56,38 @@
51 buf) 56 buf)
52 (unwind-protect 57 (unwind-protect
53 (progn 58 (progn
54 (with-current-buffer (get-buffer-create "*Messages*") 59 (write-region "any text" nil tmpfile nil 'no-message)
55 (narrow-to-region (point-max) (point-max)))
56 (write-region "any text" nil tmpfile nil 'no-message)
57 (setq buf (find-file-noselect tmpfile)) 60 (setq buf (find-file-noselect tmpfile))
58 (with-current-buffer buf 61 (with-current-buffer buf
59 (should (string-equal (buffer-string) "any text")) 62 (ert-with-message-capture auto-revert--messages
60 ;; `buffer-stale--default-function' checks for 63 (should (string-equal (buffer-string) "any text"))
61 ;; `verify-visited-file-modtime'. We must ensure that it 64 ;; `buffer-stale--default-function' checks for
62 ;; returns nil. 65 ;; `verify-visited-file-modtime'. We must ensure that it
63 (sleep-for 1) 66 ;; returns nil.
64 (auto-revert-mode 1) 67 (sleep-for 1)
65 (should auto-revert-mode) 68 (auto-revert-mode 1)
69 (should auto-revert-mode)
66 70
67 ;; Modify file. We wait for a second, in order to have 71 ;; Modify file. We wait for a second, in order to have
68 ;; another timestamp. 72 ;; another timestamp.
69 (sleep-for 1) 73 (sleep-for 1)
70 (write-region "another text" nil tmpfile nil 'no-message) 74 (write-region "another text" nil tmpfile nil 'no-message)
71 75
72 ;; Check, that the buffer has been reverted. 76 ;; Check, that the buffer has been reverted.
73 (auto-revert--wait-for-revert buf) 77 (auto-revert--wait-for-revert buf))
74 (should (string-match "another text" (buffer-string))) 78 (should (string-match "another text" (buffer-string)))
75 79
76 ;; When the buffer is modified, it shall not be reverted. 80 ;; When the buffer is modified, it shall not be reverted.
77 (with-current-buffer (get-buffer-create "*Messages*") 81 (ert-with-message-capture auto-revert--messages
78 (narrow-to-region (point-max) (point-max))) 82 (set-buffer-modified-p t)
79 (set-buffer-modified-p t) 83 (sleep-for 1)
80 (sleep-for 1) 84 (write-region "any text" nil tmpfile nil 'no-message)
81 (write-region "any text" nil tmpfile nil 'no-message)
82 85
83 ;; Check, that the buffer hasn't been reverted. 86 ;; Check, that the buffer hasn't been reverted.
84 (auto-revert--wait-for-revert buf) 87 (auto-revert--wait-for-revert buf))
85 (should-not (string-match "any text" (buffer-string))))) 88 (should-not (string-match "any text" (buffer-string)))))
86 89
87 ;; Exit. 90 ;; Exit.
88 (with-current-buffer "*Messages*" (widen))
89 (ignore-errors 91 (ignore-errors
90 (with-current-buffer buf (set-buffer-modified-p nil)) 92 (with-current-buffer buf (set-buffer-modified-p nil))
91 (kill-buffer buf)) 93 (kill-buffer buf))
@@ -106,13 +108,11 @@
106 (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) 108 (make-temp-file (expand-file-name "auto-revert-test" tmpdir1)))
107 buf1 buf2) 109 buf1 buf2)
108 (unwind-protect 110 (unwind-protect
109 (progn 111 (ert-with-message-capture auto-revert--messages
110 (with-current-buffer (get-buffer-create "*Messages*") 112 (write-region "any text" nil tmpfile1 nil 'no-message)
111 (narrow-to-region (point-max) (point-max))) 113 (setq buf1 (find-file-noselect tmpfile1))
112 (write-region "any text" nil tmpfile1 nil 'no-message) 114 (write-region "any text" nil tmpfile2 nil 'no-message)
113 (setq buf1 (find-file-noselect tmpfile1)) 115 (setq buf2 (find-file-noselect tmpfile2))
114 (write-region "any text" nil tmpfile2 nil 'no-message)
115 (setq buf2 (find-file-noselect tmpfile2))
116 116
117 (dolist (buf (list buf1 buf2)) 117 (dolist (buf (list buf1 buf2))
118 (with-current-buffer buf 118 (with-current-buffer buf
@@ -148,7 +148,6 @@
148 (should (string-match "another text" (buffer-string)))))) 148 (should (string-match "another text" (buffer-string))))))
149 149
150 ;; Exit. 150 ;; Exit.
151 (with-current-buffer "*Messages*" (widen))
152 (ignore-errors 151 (ignore-errors
153 (dolist (buf (list buf1 buf2)) 152 (dolist (buf (list buf1 buf2))
154 (with-current-buffer buf (set-buffer-modified-p nil)) 153 (with-current-buffer buf (set-buffer-modified-p nil))
@@ -165,8 +164,6 @@
165 buf) 164 buf)
166 (unwind-protect 165 (unwind-protect
167 (progn 166 (progn
168 (with-current-buffer (get-buffer-create "*Messages*")
169 (narrow-to-region (point-max) (point-max)))
170 (write-region "any text" nil tmpfile nil 'no-message) 167 (write-region "any text" nil tmpfile nil 'no-message)
171 (setq buf (find-file-noselect tmpfile)) 168 (setq buf (find-file-noselect tmpfile))
172 (with-current-buffer buf 169 (with-current-buffer buf
@@ -184,42 +181,38 @@
184 'before-revert-hook 181 'before-revert-hook
185 (lambda () (delete-file buffer-file-name)) 182 (lambda () (delete-file buffer-file-name))
186 nil t) 183 nil t)
187 (with-current-buffer (get-buffer-create "*Messages*")
188 (narrow-to-region (point-max) (point-max)))
189 (sleep-for 1)
190 (write-region "another text" nil tmpfile nil 'no-message)
191 184
192 ;; Check, that the buffer hasn't been reverted. File 185 (ert-with-message-capture auto-revert--messages
193 ;; notification should be disabled, falling back to 186 (sleep-for 1)
194 ;; polling. 187 (write-region "another text" nil tmpfile nil 'no-message)
195 (auto-revert--wait-for-revert buf) 188 (auto-revert--wait-for-revert buf))
189 ;; Check, that the buffer hasn't been reverted. File
190 ;; notification should be disabled, falling back to
191 ;; polling.
196 (should (string-match "any text" (buffer-string))) 192 (should (string-match "any text" (buffer-string)))
197 (should-not auto-revert-use-notify) 193 ;; With w32notify, the 'stopped' events are not sent.
194 (or (eq file-notify--library 'w32notify)
195 (should-not auto-revert-use-notify))
198 196
199 ;; Once the file has been recreated, the buffer shall be 197 ;; Once the file has been recreated, the buffer shall be
200 ;; reverted. 198 ;; reverted.
201 (kill-local-variable 'before-revert-hook) 199 (kill-local-variable 'before-revert-hook)
202 (with-current-buffer (get-buffer-create "*Messages*") 200 (ert-with-message-capture auto-revert--messages
203 (narrow-to-region (point-max) (point-max))) 201 (sleep-for 1)
204 (sleep-for 1) 202 (write-region "another text" nil tmpfile nil 'no-message)
205 (write-region "another text" nil tmpfile nil 'no-message) 203 (auto-revert--wait-for-revert buf))
206 204 ;; Check, that the buffer has been reverted.
207 ;; Check, that the buffer has been reverted.
208 (auto-revert--wait-for-revert buf)
209 (should (string-match "another text" (buffer-string))) 205 (should (string-match "another text" (buffer-string)))
210 206
211 ;; An empty file shall still be reverted. 207 ;; An empty file shall still be reverted.
212 (with-current-buffer (get-buffer-create "*Messages*") 208 (ert-with-message-capture auto-revert--messages
213 (narrow-to-region (point-max) (point-max))) 209 (sleep-for 1)
214 (sleep-for 1) 210 (write-region "" nil tmpfile nil 'no-message)
215 (write-region "" nil tmpfile nil 'no-message) 211 (auto-revert--wait-for-revert buf))
216 212 ;; Check, that the buffer has been reverted.
217 ;; Check, that the buffer has been reverted.
218 (auto-revert--wait-for-revert buf)
219 (should (string-equal "" (buffer-string))))) 213 (should (string-equal "" (buffer-string)))))
220 214
221 ;; Exit. 215 ;; Exit.
222 (with-current-buffer "*Messages*" (widen))
223 (ignore-errors 216 (ignore-errors
224 (with-current-buffer buf (set-buffer-modified-p nil)) 217 (with-current-buffer buf (set-buffer-modified-p nil))
225 (kill-buffer buf)) 218 (kill-buffer buf))
@@ -232,9 +225,7 @@
232 (let ((tmpfile (make-temp-file "auto-revert-test")) 225 (let ((tmpfile (make-temp-file "auto-revert-test"))
233 buf) 226 buf)
234 (unwind-protect 227 (unwind-protect
235 (progn 228 (ert-with-message-capture auto-revert--messages
236 (with-current-buffer (get-buffer-create "*Messages*")
237 (narrow-to-region (point-max) (point-max)))
238 (write-region "any text" nil tmpfile nil 'no-message) 229 (write-region "any text" nil tmpfile nil 'no-message)
239 (setq buf (find-file-noselect tmpfile)) 230 (setq buf (find-file-noselect tmpfile))
240 (with-current-buffer buf 231 (with-current-buffer buf
@@ -259,7 +250,6 @@
259 (string-match "modified text\nanother text" (buffer-string))))) 250 (string-match "modified text\nanother text" (buffer-string)))))
260 251
261 ;; Exit. 252 ;; Exit.
262 (with-current-buffer "*Messages*" (widen))
263 (ignore-errors (kill-buffer buf)) 253 (ignore-errors (kill-buffer buf))
264 (ignore-errors (delete-file tmpfile))))) 254 (ignore-errors (delete-file tmpfile)))))
265 255
@@ -283,33 +273,29 @@
283 (should 273 (should
284 (string-match name (substring-no-properties (buffer-string)))) 274 (string-match name (substring-no-properties (buffer-string))))
285 275
286 ;; Delete file. We wait for a second, in order to have 276 (ert-with-message-capture auto-revert--messages
287 ;; another timestamp. 277 ;; Delete file. We wait for a second, in order to have
288 (with-current-buffer (get-buffer-create "*Messages*") 278 ;; another timestamp.
289 (narrow-to-region (point-max) (point-max))) 279 (sleep-for 1)
290 (sleep-for 1) 280 (delete-file tmpfile)
291 (delete-file tmpfile) 281 (auto-revert--wait-for-revert buf))
292 282 ;; Check, that the buffer has been reverted.
293 ;; Check, that the buffer has been reverted.
294 (auto-revert--wait-for-revert buf)
295 (should-not 283 (should-not
296 (string-match name (substring-no-properties (buffer-string)))) 284 (string-match name (substring-no-properties (buffer-string))))
297 285
298 ;; Make dired buffer modified. Check, that the buffer has 286 (ert-with-message-capture auto-revert--messages
299 ;; been still reverted. 287 ;; Make dired buffer modified. Check, that the buffer has
300 (with-current-buffer (get-buffer-create "*Messages*") 288 ;; been still reverted.
301 (narrow-to-region (point-max) (point-max))) 289 (set-buffer-modified-p t)
302 (set-buffer-modified-p t) 290 (sleep-for 1)
303 (sleep-for 1) 291 (write-region "any text" nil tmpfile nil 'no-message)
304 (write-region "any text" nil tmpfile nil 'no-message)
305 292
306 ;; Check, that the buffer has been reverted. 293 (auto-revert--wait-for-revert buf))
307 (auto-revert--wait-for-revert buf) 294 ;; Check, that the buffer has been reverted.
308 (should 295 (should
309 (string-match name (substring-no-properties (buffer-string)))))) 296 (string-match name (substring-no-properties (buffer-string))))))
310 297
311 ;; Exit. 298 ;; Exit.
312 (with-current-buffer "*Messages*" (widen))
313 (ignore-errors 299 (ignore-errors
314 (with-current-buffer buf (set-buffer-modified-p nil)) 300 (with-current-buffer buf (set-buffer-modified-p nil))
315 (kill-buffer buf)) 301 (kill-buffer buf))
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 00000000000..1eb791a993c
--- /dev/null
+++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el
@@ -0,0 +1,493 @@
1;;;; testcases.el -- Test cases for testcover-tests.el
2
3;; Copyright (C) 2017 Free Software Foundation, Inc.
4
5;; Author: Gemini Lasswell
6
7;; This file is part of GNU Emacs.
8
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17;; General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with this program. If not, see `http://www.gnu.org/licenses/'.
21
22;;; Commentary:
23
24;; * This file should not be loaded directly. It is meant to be read
25;; by `testcover-tests-build-test-cases'.
26;;
27;; * Test cases begin with ;; ==== name ====. The symbol name between
28;; the ===='s is used to create the name of the test.
29;;
30;; * Following the beginning comment place the test docstring and
31;; any tags or keywords for ERT. These will be spliced into the
32;; ert-deftest for the test.
33;;
34;; * To separate the above from the test case code, use another
35;; comment: ;; ====
36;;
37;; * These special comments should start at the beginning of a line.
38;;
39;; * `testcover-tests-skeleton' will prompt you for a test name and
40;; insert the special comments.
41;;
42;; * The test case code should be annotated with %%% at the end of
43;; each form where a tan splotch is expected, and !!! at the end
44;; of each form where a red mark is expected.
45;;
46;; * If Testcover is working correctly on your code sample, using
47;; `testcover-tests-markup-region' and
48;; `testcover-tests-unmarkup-region' can make creating test cases
49;; easier.
50
51;;; Code:
52;;; Test Cases:
53
54;; ==== constants-bug-25316 ====
55"Testcover doesn't splotch constants."
56:expected-result :failed
57;; ====
58(defconst testcover-testcase-const "apples")
59(defun testcover-testcase-zero () 0)
60(defun testcover-testcase-list-consts ()
61 (list
62 emacs-version 10
63 "hello"
64 `(a b c ,testcover-testcase-const)
65 '(1 2 3)
66 testcover-testcase-const
67 (testcover-testcase-zero)
68 nil))
69
70(defun testcover-testcase-add-to-const-list (arg)
71 (cons arg%%% (testcover-testcase-list-consts))%%%)
72
73(should (equal (testcover-testcase-add-to-const-list 'a)
74 `(a ,emacs-version 10 "hello" (a b c "apples") (1 2 3)
75 "apples" 0 nil)))
76
77;; ==== customize-defcustom-bug-25326 ====
78"Testcover doesn't prevent testing of defcustom values."
79:expected-result :failed
80;; ====
81(defgroup testcover-testcase nil
82 "Test case for testcover"
83 :group 'lisp
84 :prefix "testcover-testcase-"
85 :version "26.0")
86(defcustom testcover-testcase-flag t
87 "Test value used by testcover-tests.el"
88 :type 'boolean
89 :group 'testcover-testcase)
90(defun testcover-testcase-get-flag ()
91 testcover-testcase-flag)
92
93(testcover-testcase-get-flag)
94(setq testcover-testcase-flag (not testcover-testcase-flag))
95(testcover-testcase-get-flag)
96
97;; ==== no-returns ====
98"Testcover doesn't splotch functions which don't return."
99;; ====
100(defun testcover-testcase-play-ball (retval)
101 (catch 'ball
102 (throw 'ball retval%%%))%%%) ; catch gets marked but not throw
103
104(defun testcover-testcase-not-my-favorite-error-message ()
105 (signal 'wrong-type-argument (list 'consp nil)))
106
107(should (testcover-testcase-play-ball t))
108(condition-case nil
109 (testcover-testcase-not-my-favorite-error-message)
110 (error nil))
111
112;; ==== noreturn-symbol ====
113"Wrapping a form with noreturn prevents splotching."
114;; ====
115(defun testcover-testcase-cancel (spacecraft)
116 (error "no destination for %s" spacecraft))
117(defun testcover-testcase-launch (spacecraft planet)
118 (if (null planet)
119 (noreturn (testcover-testcase-cancel spacecraft%%%))
120 (list spacecraft%%% planet%%%)%%%)%%%)
121(defun testcover-testcase-launch-2 (spacecraft planet)
122 (if (null planet%%%)%%%
123 (testcover-testcase-cancel spacecraft%%%)!!!
124 (list spacecraft!!! planet!!!)!!!)!!!)
125(should (equal (testcover-testcase-launch "Curiosity" "Mars") '("Curiosity" "Mars")))
126(condition-case err
127 (testcover-testcase-launch "Voyager" nil)
128 (error err))
129(condition-case err
130 (testcover-testcase-launch-2 "Voyager II" nil)
131 (error err))
132
133(should-error (testcover-testcase-launch "Voyager" nil))
134(should-error (testcover-testcase-launch-2 "Voyager II" nil))
135
136;; ==== 1-value-symbol-bug-25316 ====
137"Wrapping a form with 1value prevents splotching."
138:expected-result :failed
139;; ====
140(defun testcover-testcase-always-zero (num)
141 (- num%%% num%%%)%%%)
142(defun testcover-testcase-still-always-zero (num)
143 (1value (- num%%% num%%% (- num%%% num%%%)%%%)))
144(defun testcover-testcase-never-called (num)
145 (1value (/ num!!! num!!!)!!!)!!!)
146(should (eql 0 (testcover-testcase-always-zero 3)))
147(should (eql 0 (testcover-testcase-still-always-zero 5)))
148
149;; ==== dotimes-dolist ====
150"Dolist and dotimes with a 1valued return value are 1valued."
151;; ====
152(defun testcover-testcase-do-over (things)
153 (dolist (thing things%%%)
154 (list thing))
155 (dolist (thing things%%% 42)
156 (list thing))
157 (dolist (thing things%%% things%%%)
158 (list thing))%%%)
159(defun testcover-testcase-do-more (count)
160 (dotimes (num count%%%)
161 (+ num num))
162 (dotimes (num count%%% count%%%)
163 (+ num num))%%%
164 (dotimes (num count%%% 0)
165 (+ num num)))
166(should (equal '(a b c) (testcover-testcase-do-over '(a b c))))
167(should (eql 0 (testcover-testcase-do-more 2)))
168
169;; ==== let-last-form ====
170"A let form is 1valued if its last form is 1valued."
171;; ====
172(defun testcover-testcase-double (num)
173 (let ((double (* num%%% 2)%%%))
174 double%%%)%%%)
175(defun testcover-testcase-nullbody-let (num)
176 (let* ((square (* num%%% num%%%)%%%)
177 (double (* 2 num%%%)%%%))))
178(defun testcover-testcase-answer ()
179 (let ((num 100))
180 42))
181(should-not (testcover-testcase-nullbody-let 3))
182(should (eql (testcover-testcase-answer) 42))
183(should (eql (testcover-testcase-double 10) 20))
184
185;; ==== if-with-1value-clauses ====
186"An if is 1valued if both then and else are 1valued."
187;; ====
188(defun testcover-testcase-describe (val)
189 (if (zerop val%%%)%%%
190 "a number"
191 "a different number"))
192(defun testcover-testcase-describe-2 (val)
193 (if (zerop val)
194 "zero"
195 "not zero"))
196(defun testcover-testcase-describe-3 (val)
197 (if (zerop val%%%)%%%
198 "zero"
199 (format "%d" val%%%)%%%)%%%)
200(should (equal (testcover-testcase-describe 0) "a number"))
201(should (equal (testcover-testcase-describe-2 0) "zero"))
202(should (equal (testcover-testcase-describe-2 1) "not zero"))
203(should (equal (testcover-testcase-describe-3 1) "1"))
204
205;; ==== cond-with-1value-clauses ====
206"A cond form is marked 1valued if all clauses are 1valued."
207;; ====
208(defun testcover-testcase-cond (num)
209 (cond
210 ((eql num%%% 0)%%% 'a)
211 ((eql num%%% 1)%%% 'b)
212 ((eql num!!! 2)!!! 'c)))
213(defun testcover-testcase-cond-2 (num)
214 (cond
215 ((eql num%%% 0)%%% (cons 'a 0)!!!)
216 ((eql num%%% 1)%%% 'b))%%%)
217(should (eql (testcover-testcase-cond 1) 'b))
218(should (eql (testcover-testcase-cond-2 1) 'b))
219
220;; ==== condition-case-with-1value-components ====
221"A condition-case is marked 1valued if its body and handlers are."
222;; ====
223(defun testcover-testcase-cc (arg)
224 (condition-case nil
225 (if (null arg%%%)%%%
226 (error "foo")
227 "0")!!!
228 (error nil)))
229(should-not (testcover-testcase-cc nil))
230
231;; ==== quotes-within-backquotes-bug-25316 ====
232"Forms to instrument are found within quotes within backquotes."
233:expected-result :failed
234;; ====
235(defun testcover-testcase-make-list ()
236 (list 'defun 'defvar))
237(defmacro testcover-testcase-bq-macro (arg)
238 (declare (debug t))
239 `(memq ,arg%%% '(defconst ,@(testcover-testcase-make-list)))%%%)
240(defun testcover-testcase-use-bq-macro (arg)
241 (testcover-testcase-bq-macro arg%%%)%%%)
242(should (equal '(defun defvar) (testcover-testcase-use-bq-macro 'defun)))
243
244;; ==== progn-functions ====
245"Some forms are 1value if their last argument is 1value."
246;; ====
247(defun testcover-testcase-one (arg)
248 (progn
249 (setq arg (1- arg%%%)%%%)%%%)%%%
250 (progn
251 (setq arg (1+ arg%%%)%%%)%%%
252 1))
253
254(should (eql 1 (testcover-testcase-one 0)))
255;; ==== prog1-functions ====
256"Some forms are 1value if their first argument is 1value."
257;; ====
258(defun testcover-testcase-unwinder (arg)
259 (unwind-protect
260 (if ( > arg%%% 0)%%%
261 1
262 0)
263 (format "unwinding %s!" arg%%%)%%%))
264(defun testcover-testcase-divider (arg)
265 (unwind-protect
266 (/ 100 arg%%%)%%%
267 (format "unwinding! %s" arg%%%)%%%)%%%)
268
269(should (eq 0 (testcover-testcase-unwinder 0)))
270(should (eq 1 (testcover-testcase-divider 100)))
271
272;; ==== compose-functions ====
273"Some functions are 1value if all their arguments are 1value."
274;; ====
275(defconst testcover-testcase-count 3)
276(defun testcover-testcase-number ()
277 (+ 1 testcover-testcase-count))
278(defun testcover-testcase-more ()
279 (+ 1 (testcover-testcase-number) testcover-testcase-count))
280
281(should (equal (testcover-testcase-more) 8))
282
283;; ==== apply-quoted-symbol ====
284"Apply with a quoted function symbol treated as 1value if function is."
285;; ====
286(defun testcover-testcase-numlist (flag)
287 (if flag%%%
288 '(1 2 3)
289 '(4 5 6)))
290(defun testcover-testcase-sum (flag)
291 (apply '+ (testcover-testcase-numlist flag%%%)))
292(defun testcover-testcase-label ()
293 (apply 'message "edebug uses: %s %s" (list 1 2)!!!)!!!)
294
295(should (equal 6 (testcover-testcase-sum t)))
296
297;; ==== backquote-1value-bug-24509 ====
298"Commas within backquotes are recognized as non-1value."
299:expected-result :failed
300;; ====
301(defmacro testcover-testcase-lambda (&rest body)
302 `(lambda () ,@body))
303
304(defun testcover-testcase-example ()
305 (let ((lambda-1 (testcover-testcase-lambda (format "lambda-%d" 1))%%%)
306 (lambda-2 (testcover-testcase-lambda (format "lambda-%d" 2))%%%))
307 (concat (funcall lambda-1%%%)%%% " "
308 (funcall lambda-2%%%)%%%)%%%)%%%)
309
310(defmacro testcover-testcase-message-symbol (name)
311 `(message "%s" ',name))
312
313(defun testcover-testcase-example-2 ()
314 (concat
315 (testcover-testcase-message-symbol foo)%%%
316 (testcover-testcase-message-symbol bar)%%%)%%%)
317
318(should (equal "lambda-1 lambda-2" (testcover-testcase-example)))
319(should (equal "foobar" (testcover-testcase-example-2)))
320
321;; ==== pcase-bug-24688 ====
322"Testcover copes with condition-case within backquoted list."
323:expected-result :failed
324;; ====
325(defun testcover-testcase-pcase (form)
326 (pcase form%%%
327 (`(condition-case ,var ,protected-form . ,handlers)
328 (list var%%% protected-form%%% handlers%%%)%%%)
329 (_ nil))%%%)
330
331(should (equal (testcover-testcase-pcase '(condition-case a
332 (/ 5 a)
333 (error 0)))
334 '(a (/ 5 a) ((error 0)))))
335
336;; ==== defun-in-backquote-bug-11307-and-24743 ====
337"Testcover handles defun forms within backquoted list."
338:expected-result :failed
339;; ====
340(defmacro testcover-testcase-defun (name &rest body)
341 (declare (debug (symbolp def-body)))
342 `(defun ,name () ,@body))
343
344(testcover-testcase-defun foo (+ 1 2))
345(testcover-testcase-defun bar (+ 3 4))
346(should (eql (foo) 3))
347(should (eql (bar) 7))
348
349;; ==== closure-1value-bug ====
350"Testcover does not mark closures as 1value."
351:expected-result :failed
352;; ====
353;; -*- lexical-binding:t -*-
354(setq testcover-testcase-foo nil)
355(setq testcover-testcase-bar 0)
356
357(defun testcover-testcase-baz (arg)
358 (setq testcover-testcase-foo
359 (lambda () (+ arg testcover-testcase-bar%%%))))
360
361(testcover-testcase-baz 2)
362(should (equal 2 (funcall testcover-testcase-foo)))
363(testcover-testcase-baz 3)
364(should (equal 3 (funcall testcover-testcase-foo)))
365
366;; ==== by-value-vs-by-reference-bug-25351 ====
367"An object created by a 1value expression may be modified by other code."
368:expected-result :failed
369;; ====
370(defun testcover-testcase-ab ()
371 (list 'a 'b))
372(defun testcover-testcase-change-it (arg)
373 (setf (cadr arg%%%)%%% 'c)%%%
374 arg%%%)
375
376(should (equal (testcover-testcase-change-it (testcover-testcase-ab)) '(a c)))
377(should (equal (testcover-testcase-ab) '(a b)))
378
379;; ==== 1value-error-test ====
380"Forms wrapped by `1value' should always return the same value."
381;; ====
382(defun testcover-testcase-thing (arg)
383 (1value (list 1 arg 3)))
384
385(should (equal '(1 2 3) (testcover-testcase-thing 2)))
386(should-error (testcover-testcase-thing 3))
387
388;; ==== dotted-backquote ====
389"Testcover correctly instruments dotted backquoted lists."
390;; ====
391(defun testcover-testcase-dotted-bq (flag extras)
392 (let* ((bq
393 `(a b c . ,(and flag extras%%%))))
394 bq))
395
396(should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e))))
397(should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e))))
398
399;; ==== backquoted-vector-bug-25316 ====
400"Testcover reinstruments within backquoted vectors."
401:expected-result :failed
402;; ====
403(defun testcover-testcase-vec (a b c)
404 `[,a%%% ,(list b%%% c%%%)%%%]%%%)
405
406(defun testcover-testcase-vec-in-list (d e f)
407 `([[,d%%% ,e%%%] ,f%%%])%%%)
408
409(defun testcover-testcase-vec-arg (num)
410 (list `[,num%%%]%%%)%%%)
411
412(should (equal [1 (2 3)] (testcover-testcase-vec 1 2 3)))
413(should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6)))
414(should (equal '([100]) (testcover-testcase-vec-arg 100)))
415
416;; ==== vector-in-macro-spec-bug-25316 ====
417"Testcover reinstruments within vectors."
418:expected-result :failed
419;; ====
420(defmacro testcover-testcase-nth-case (arg vec)
421 (declare (indent 1)
422 (debug (form (vector &rest form))))
423 `(eval (aref ,vec%%% ,arg%%%))%%%)
424
425(defun testcover-testcase-use-nth-case (choice val)
426 (testcover-testcase-nth-case choice
427 [(+ 1 val!!!)!!!
428 (- 1 val%%%)%%%
429 (* 7 val)
430 (/ 4 val!!!)!!!]))
431
432(should (eql 42 (testcover-testcase-use-nth-case 2 6)))
433(should (eql 49 (testcover-testcase-use-nth-case 2 7)))
434(should (eql 0 (testcover-testcase-use-nth-case 1 1 )))
435
436;; ==== mapcar-is-not-compose ====
437"Mapcar with 1value arguments is not 1value."
438:expected-result :failed
439;; ====
440(defvar testcover-testcase-num 0)
441(defun testcover-testcase-add-num (n)
442 (+ testcover-testcase-num n))
443(defun testcover-testcase-mapcar-sides ()
444 (mapcar 'testcover-testcase-add-num '(1 2 3)))
445
446(setq testcover-testcase-num 1)
447(should (equal (testcover-testcase-mapcar-sides) '(2 3 4)))
448(setq testcover-testcase-num 2)
449(should (equal (testcover-testcase-mapcar-sides) '(3 4 5)))
450
451;; ==== function-with-edebug-spec-bug-25316 ====
452"Functions can have edebug specs too.
453See c-make-font-lock-search-function for an example in the Emacs
454sources. The other issue is that it's ok to use quote in an
455edebug spec, so testcover needs to cope with that."
456:expected-result :failed
457;; ====
458(defun testcover-testcase-make-function (forms)
459 `(lambda (flag) (if flag 0 ,@forms%%%))%%%)
460
461(def-edebug-spec testcover-testcase-make-function
462 (("quote" (&rest def-form))))
463
464(defun testcover-testcase-thing ()
465 (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%)
466
467(defun testcover-testcase-use-thing ()
468 (funcall (testcover-testcase-thing)%%% nil)%%%)
469
470(should (equal (testcover-testcase-use-thing) 15))
471
472;; ==== backquoted-dotted-alist ====
473"Testcover can instrument a dotted alist constructed with backquote."
474;; ====
475(defun testcover-testcase-make-alist (expr entries)
476 `((0 . ,expr%%%) . ,entries%%%)%%%)
477
478(should (equal (testcover-testcase-make-alist "foo" '((1 . "bar") (2 . "baz")))
479 '((0 . "foo") (1 . "bar") (2 . "baz"))))
480
481;; ==== coverage-of-the-unknown-symbol-bug-25471 ====
482"Testcover correctly records coverage of code which uses `unknown'"
483:expected-result :failed
484;; ====
485(defun testcover-testcase-how-do-i-know-you (name)
486 (let ((val 'unknown))
487 (when (equal name%%% "Bob")%%%
488 (setq val 'known)!!!)
489 val%%%)%%%)
490
491(should (eq (testcover-testcase-how-do-i-know-you "Liz") 'unknown))
492
493;; 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 00000000000..d31379c3aa2
--- /dev/null
+++ b/test/lisp/emacs-lisp/testcover-tests.el
@@ -0,0 +1,186 @@
1;;; testcover-tests.el --- Testcover test suite -*- lexical-binding:t -*-
2
3;; Copyright (C) 2017 Free Software Foundation, Inc.
4
5;; Author: Gemini Lasswell
6
7;; This file is part of GNU Emacs.
8
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17;; General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with this program. If not, see `http://www.gnu.org/licenses/'.
21
22;;; Commentary:
23
24;; Testcover test suite.
25;; * All the test cases are in testcover-resources/testcover-cases.el.
26;; See that file for an explanation of the test case format.
27;; * `testcover-tests-define-tests', which is run when this file is
28;; loaded, reads testcover-resources/testcover-cases.el and defines
29;; ERT tests for each test case.
30
31;;; Code:
32
33(require 'ert)
34(require 'testcover)
35(require 'skeleton)
36
37;; Use `eval-and-compile' around all these definitions because they're
38;; used by the macro `testcover-tests-define-tests'.
39
40(eval-and-compile
41 (defvar testcover-tests-file-dir
42 (expand-file-name
43 "testcover-resources/"
44 (file-name-directory (or (bound-and-true-p byte-compile-current-file)
45 load-file-name
46 buffer-file-name)))
47 "Directory of the \"testcover-tests.el\" file."))
48
49(eval-and-compile
50 (defvar testcover-tests-test-cases
51 (expand-file-name "testcases.el" testcover-tests-file-dir)
52 "File containing marked up code to instrument and check."))
53
54;; Convert Testcover's overlays to plain text.
55
56(eval-and-compile
57 (defun testcover-tests-markup-region (beg end &rest optargs)
58 "Mark up test code within region between BEG and END.
59Convert Testcover's tan and red splotches to %%% and !!! for
60testcases.el. This can be used to create test cases if Testcover
61is working correctly on a code sample. OPTARGS are optional
62arguments for `testcover-start'."
63 (interactive "r")
64 (let ((tempfile (make-temp-file "testcover-tests-" nil ".el"))
65 (code (buffer-substring beg end))
66 (marked-up-code))
67 (unwind-protect
68 (progn
69 (with-temp-file tempfile
70 (insert code))
71 (save-current-buffer
72 (let ((buf (find-file-noselect tempfile)))
73 (set-buffer buf)
74 (apply 'testcover-start (cons tempfile optargs))
75 (testcover-mark-all buf)
76 (dolist (overlay (overlays-in (point-min) (point-max)))
77 (let ((ov-face (overlay-get overlay 'face)))
78 (goto-char (overlay-end overlay))
79 (cond
80 ((eq ov-face 'testcover-nohits) (insert "!!!"))
81 ((eq ov-face 'testcover-1value) (insert "%%%"))
82 (t nil))))
83 (setq marked-up-code (buffer-string)))
84 (set-buffer-modified-p nil)))
85 (ignore-errors (kill-buffer (find-file-noselect tempfile)))
86 (ignore-errors (delete-file tempfile)))
87
88 ;; Now replace the original code with the marked up code.
89 (delete-region beg end)
90 (insert marked-up-code))))
91
92(eval-and-compile
93 (defun testcover-tests-unmarkup-region (beg end)
94 "Remove the markup used in testcases.el between BEG and END."
95 (interactive "r")
96 (save-excursion
97 (save-restriction
98 (narrow-to-region beg end)
99 (goto-char (point-min))
100 (while (re-search-forward "!!!\\|%%%" nil t)
101 (replace-match ""))))))
102
103(define-skeleton testcover-tests-skeleton
104 "Write a testcase for testcover-tests.el."
105 "Enter name of test: "
106 ";; ==== " str " ====\n"
107 "\"docstring\"\n"
108 ";; Directives for ERT should go here, if any.\n"
109 ";; ====\n"
110 ";; Replace this line with annotated test code.\n")
111
112;; Check a test case.
113
114(eval-and-compile
115 (defun testcover-tests-run-test-case (marked-up-code)
116 "Test the operation of Testcover on the string MARKED-UP-CODE."
117 (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")))
118 (unwind-protect
119 (progn
120 (with-temp-file tempfile
121 (insert marked-up-code))
122 ;; Remove the marks and mark the code up again. The original
123 ;; and recreated versions should match.
124 (save-current-buffer
125 (set-buffer (find-file-noselect tempfile))
126 ;; Fail the test if the debugger tries to become active,
127 ;; which will happen if Testcover's reinstrumentation
128 ;; leaves an edebug-enter in the code. This will also
129 ;; prevent debugging these tests using Edebug.
130 (cl-letf (((symbol-function #'edebug-enter)
131 (lambda (&rest _args)
132 (ert-fail
133 (concat "Debugger invoked during test run "
134 "(possible edebug-enter not replaced)")))))
135 (dolist (byte-compile '(t nil))
136 (testcover-tests-unmarkup-region (point-min) (point-max))
137 (unwind-protect
138 (testcover-tests-markup-region (point-min) (point-max) byte-compile)
139 (set-buffer-modified-p nil))
140 (should (string= marked-up-code
141 (buffer-string)))))))
142 (ignore-errors (kill-buffer (find-file-noselect tempfile)))
143 (ignore-errors (delete-file tempfile))))))
144
145;; Convert test case file to ert-defmethod.
146
147(eval-and-compile
148 (defun testcover-tests-build-test-cases ()
149 "Parse the test case file and return a list of ERT test definitions.
150Construct and return a list of `ert-deftest' forms. See testcases.el
151for documentation of the test definition format."
152 (let (results)
153 (with-temp-buffer
154 (insert-file-contents testcover-tests-test-cases)
155 (goto-char (point-min))
156 (while (re-search-forward
157 (concat "^;; ==== \\([^ ]+?\\) ====\n"
158 "\\(\\(?:.*\n\\)*?\\)"
159 ";; ====\n"
160 "\\(\\(?:.*\n\\)*?\\)"
161 "\\(\\'\\|;; ====\\)")
162 nil t)
163 (let ((name (match-string 1))
164 (splice (car (read-from-string
165 (format "(%s)" (match-string 2)))))
166 (code (match-string 3)))
167 (push
168 `(ert-deftest ,(intern (concat "testcover-tests-" name)) ()
169 ,@splice
170 (testcover-tests-run-test-case ,code))
171 results))
172 (beginning-of-line)))
173 results)))
174
175;; Define all the tests.
176
177(defmacro testcover-tests-define-tests ()
178 "Construct and define ERT test methods using the test case file."
179 (let* ((test-cases (testcover-tests-build-test-cases)))
180 `(progn ,@test-cases)))
181
182(testcover-tests-define-tests)
183
184(provide 'testcover-tests)
185
186;;; testcover-tests.el ends here
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index db7f55e8fc5..27434bcef20 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -36,6 +36,7 @@
36;;; Code: 36;;; Code:
37 37
38(require 'ert) 38(require 'ert)
39(require 'ert-x)
39(require 'filenotify) 40(require 'filenotify)
40(require 'tramp) 41(require 'tramp)
41 42
@@ -703,21 +704,19 @@ delivered."
703 (should auto-revert-notify-watch-descriptor) 704 (should auto-revert-notify-watch-descriptor)
704 705
705 ;; Modify file. We wait for a second, in order to have 706 ;; Modify file. We wait for a second, in order to have
706 ;; another timestamp. 707 ;; another timestamp.
707 (with-current-buffer (get-buffer-create "*Messages*") 708 (ert-with-message-capture captured-messages
708 (narrow-to-region (point-max) (point-max))) 709 (sleep-for 1)
709 (sleep-for 1) 710 (write-region
710 (write-region 711 "another text" nil file-notify--test-tmpfile nil 'no-message)
711 "another text" nil file-notify--test-tmpfile nil 'no-message) 712
712 713 ;; Check, that the buffer has been reverted.
713 ;; Check, that the buffer has been reverted. 714 (file-notify--wait-for-events
714 (with-current-buffer (get-buffer-create "*Messages*") 715 timeout
715 (file-notify--wait-for-events 716 (string-match
716 timeout
717 (string-match
718 (format-message "Reverting buffer `%s'." (buffer-name buf)) 717 (format-message "Reverting buffer `%s'." (buffer-name buf))
719 (buffer-string)))) 718 captured-messages))
720 (should (string-match "another text" (buffer-string))) 719 (should (string-match "another text" (buffer-string))))
721 720
722 ;; Stop file notification. Autorevert shall still work via polling. 721 ;; Stop file notification. Autorevert shall still work via polling.
723 (file-notify-rm-watch auto-revert-notify-watch-descriptor) 722 (file-notify-rm-watch auto-revert-notify-watch-descriptor)
@@ -728,27 +727,24 @@ delivered."
728 727
729 ;; Modify file. We wait for two seconds, in order to 728 ;; Modify file. We wait for two seconds, in order to
730 ;; have another timestamp. One second seems to be too 729 ;; have another timestamp. One second seems to be too
731 ;; short. 730 ;; short.
732 (with-current-buffer (get-buffer-create "*Messages*") 731 (ert-with-message-capture captured-messages
733 (narrow-to-region (point-max) (point-max))) 732 (sleep-for 2)
734 (sleep-for 2) 733 (write-region
735 (write-region 734 "foo bla" nil file-notify--test-tmpfile nil 'no-message)
736 "foo bla" nil file-notify--test-tmpfile nil 'no-message) 735
737 736 ;; Check, that the buffer has been reverted.
738 ;; Check, that the buffer has been reverted. 737 (file-notify--wait-for-events
739 (with-current-buffer (get-buffer-create "*Messages*") 738 timeout
740 (file-notify--wait-for-events 739 (string-match
741 timeout 740 (format-message "Reverting buffer `%s'." (buffer-name buf))
742 (string-match 741 captured-messages))
743 (format-message "Reverting buffer `%s'." (buffer-name buf)) 742 (should (string-match "foo bla" (buffer-string)))))
744 (buffer-string))))
745 (should (string-match "foo bla" (buffer-string))))
746 743
747 ;; The environment shall be cleaned up. 744 ;; The environment shall be cleaned up.
748 (file-notify--test-cleanup-p)) 745 (file-notify--test-cleanup-p))
749 746
750 ;; Cleanup. 747 ;; Cleanup.
751 (with-current-buffer "*Messages*" (widen))
752 (ignore-errors (kill-buffer buf)) 748 (ignore-errors (kill-buffer buf))
753 (file-notify--test-cleanup)))) 749 (file-notify--test-cleanup))))
754 750
diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el
new file mode 100644
index 00000000000..5124cbbf962
--- /dev/null
+++ b/test/lisp/kmacro-tests.el
@@ -0,0 +1,890 @@
1;;; kmacro-tests.el --- Tests for kmacro.el -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2017 Free Software Foundation, Inc.
4
5;; Author: Gemini Lasswell <gazally@runbox.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23
24;;; Code:
25
26(require 'kmacro)
27(require 'ert)
28(require 'ert-x)
29
30;;; Test fixtures:
31
32(defmacro kmacro-tests-with-kmacro-clean-slate (&rest body)
33 "Create a clean environment for a kmacro test BODY to run in."
34 (declare (debug (body)))
35 `(cl-letf* ((kmacro-execute-before-append t)
36 (kmacro-ring-max 8)
37 (kmacro-repeat-no-prefix t)
38 (kmacro-call-repeat-key nil)
39 (kmacro-call-repeat-with-arg nil)
40
41 (kbd-macro-termination-hook nil)
42 (defining-kbd-macro nil)
43 (executing-kbd-macro nil)
44 (executing-kbd-macro-index 0)
45 (last-kbd-macro nil)
46
47 (kmacro-ring nil)
48
49 (kmacro-counter 0)
50 (kmacro-default-counter-format "%d")
51 (kmacro-counter-format "%d")
52 (kmacro-counter-format-start "%d")
53 (kmacro-counter-value-start 0)
54 (kmacro-last-counter 0)
55 (kmacro-initial-counter-value nil)
56
57 (kmacro-tests-macros nil)
58 (kmacro-tests-events nil)
59 (kmacro-tests-sequences nil))
60 (advice-add 'end-kbd-macro :after #'kmacro-tests-end-macro-advice)
61 (advice-add 'read-event :around #'kmacro-tests-read-event-advice )
62 (advice-add 'read-key-sequence :around #'kmacro-tests-read-key-sequence-advice)
63 (unwind-protect
64 (ert-with-test-buffer (:name "")
65 (switch-to-buffer (current-buffer))
66 ,@body)
67 (advice-remove 'read-key-sequence #'kmacro-tests-read-key-sequence-advice)
68 (advice-remove 'read-event #'kmacro-tests-read-event-advice)
69 (advice-remove 'end-kbd-macro #'kmacro-tests-end-macro-advice))))
70
71(defmacro kmacro-tests-deftest (name _args docstring &rest keys-and-body)
72 "Define a kmacro unit test.
73NAME is the name of the test, _ARGS should be nil, and DOCSTRING
74is required. To avoid having to duplicate ert's keyword parsing
75here, its keywords and values (if any) must be inside a list
76after the docstring, preceding the body, here combined with the
77body in KEYS-AND-BODY."
78 (declare (debug (&define name sexp stringp
79 [&optional (&rest &or [keywordp sexp])]
80 def-body))
81 (doc-string 3)
82 (indent 2))
83
84 (let* ((keys (when (and (listp (car keys-and-body))
85 (keywordp (caar keys-and-body)))
86 (car keys-and-body)))
87 (body (if keys (cdr keys-and-body)
88 keys-and-body)))
89 `(ert-deftest ,name ()
90 ,docstring ,@keys
91 (kmacro-tests-with-kmacro-clean-slate ,@body))))
92
93(defvar kmacro-tests-keymap
94 (let ((map (make-sparse-keymap)))
95 (dotimes (i 26)
96 (define-key map (string (+ ?a i)) 'self-insert-command))
97 (dotimes (i 10)
98 (define-key map (string (+ ?0 i)) 'self-insert-command))
99 ;; Define a few key sequences of different lengths.
100 (dolist (item '(("\C-a" . beginning-of-line)
101 ("\C-b" . backward-char)
102 ("\C-e" . end-of-line)
103 ("\C-f" . forward-char)
104 ("\C-r" . isearch-backward)
105 ("\C-u" . universal-argument)
106 ("\C-w" . kill-region)
107 ("\C-SPC" . set-mark-command)
108 ("\M-w" . kill-ring-save)
109 ("\M-x" . execute-extended-command)
110 ("\C-cd" . downcase-word)
111 ("\C-cxu" . upcase-word)
112 ("\C-cxq" . quoted-insert)
113 ("\C-cxi" . kmacro-insert-counter)
114 ("\C-x\C-k" . kmacro-keymap)))
115 (define-key map (car item) (cdr item)))
116 map)
117 "Keymap to use for testing keyboard macros.
118This is used to obtain consistent results even if tests are run
119in an environment with rebound keys.")
120
121(defvar kmacro-tests-events nil
122 "Input events used by the kmacro test in progress.")
123
124(defun kmacro-tests-read-event-advice (orig-func &rest args)
125 "Pop and return an event from `kmacro-tests-events'.
126Return the result of calling ORIG-FUNC with ARGS if
127`kmacro-tests-events' is empty, or if a keyboard macro is
128running."
129 (if (or executing-kbd-macro (null kmacro-tests-events))
130 (apply orig-func args)
131 (pop kmacro-tests-events)))
132
133(defvar kmacro-tests-sequences nil
134 "Input sequences used by the kmacro test in progress.")
135
136(defun kmacro-tests-read-key-sequence-advice (orig-func &rest args)
137 "Pop and return a string from `kmacro-tests-sequences'.
138Return the result of calling ORIG-FUNC with ARGS if
139`kmacro-tests-sequences' is empty, or if a keyboard macro is
140running."
141 (if (or executing-kbd-macro (null kmacro-tests-sequences))
142 (apply orig-func args)
143 (pop kmacro-tests-sequences)))
144
145(defvar kmacro-tests-macros nil
146 "Keyboard macros (in vector form) used by the kmacro test in progress.")
147
148(defun kmacro-tests-end-macro-advice (&rest _args)
149 "Pop a macro from `kmacro-tests-macros' and assign it to `last-kbd-macro'.
150If `kmacro-tests-macros' is empty, do nothing."
151 (when kmacro-tests-macros
152 (setq last-kbd-macro (pop kmacro-tests-macros))))
153
154;;; Some more powerful expectations:
155
156(defmacro kmacro-tests-should-insert (value &rest body)
157 "Verify that VALUE is inserted by the execution of BODY.
158Execute BODY, then check that the string VALUE was inserted
159into the current buffer at point."
160 (declare (debug (stringp body))
161 (indent 1))
162 (let ((g-p (cl-gensym))
163 (g-bsize (cl-gensym)))
164 `(let ((,g-p (point))
165 (,g-bsize (buffer-size)))
166 ,@body
167 (should (equal (buffer-substring ,g-p (point)) ,value))
168 (should (equal (- (buffer-size) ,g-bsize) (length ,value))))))
169
170(defmacro kmacro-tests-should-match-message (value &rest body)
171 "Verify that a message matching VALUE is issued while executing BODY.
172Execute BODY, and then if there is not a regexp match between
173VALUE and any text written to *Messages* during the execution,
174cause the current test to fail."
175 (declare (debug (form body))
176 (indent 1))
177 (let ((g-captured-messages (cl-gensym)))
178 `(ert-with-message-capture ,g-captured-messages
179 ,@body
180 (should (string-match-p ,value ,g-captured-messages)))))
181
182;;; Tests:
183
184(kmacro-tests-deftest kmacro-tests-test-insert-counter-01-nil ()
185 "`kmacro-insert-counter' adds one to macro counter with nil arg."
186 (kmacro-tests-should-insert "0"
187 (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
188 (kmacro-tests-should-insert "1"
189 (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
190
191(kmacro-tests-deftest kmacro-tests-test-insert-counter-02-int ()
192 "`kmacro-insert-counter' increments by value of list argument."
193 (kmacro-tests-should-insert "0"
194 (kmacro-tests-simulate-command '(kmacro-insert-counter 2)))
195 (kmacro-tests-should-insert "2"
196 (kmacro-tests-simulate-command '(kmacro-insert-counter 3)))
197 (kmacro-tests-should-insert "5"
198 (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
199
200(kmacro-tests-deftest kmacro-tests-test-insert-counter-03-list ()
201 "`kmacro-insert-counter' doesn't increment when given universal argument."
202 (kmacro-tests-should-insert "0"
203 (kmacro-tests-simulate-command '(kmacro-insert-counter (16))))
204 (kmacro-tests-should-insert "0"
205 (kmacro-tests-simulate-command '(kmacro-insert-counter (4)))))
206
207(kmacro-tests-deftest kmacro-tests-test-insert-counter-04-neg ()
208 "`kmacro-insert-counter' decrements with '- prefix argument"
209 (kmacro-tests-should-insert "0"
210 (kmacro-tests-simulate-command '(kmacro-insert-counter -)))
211 (kmacro-tests-should-insert "-1"
212 (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
213
214(kmacro-tests-deftest kmacro-tests-test-start-format-counter ()
215 "`kmacro-insert-counter' uses start value and format."
216 (kmacro-tests-simulate-command '(kmacro-set-counter 10))
217 (kmacro-tests-should-insert "10"
218 (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
219 (kmacro-tests-should-insert "11"
220 (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
221 (kmacro-set-format "c=%s")
222 (kmacro-tests-simulate-command '(kmacro-set-counter 50))
223 (kmacro-tests-should-insert "c=50"
224 (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
225
226(kmacro-tests-deftest kmacro-tests-test-start-macro-when-defining-macro ()
227 "Starting a macro while defining a macro does not start a second macro."
228 (kmacro-tests-simulate-command '(kmacro-start-macro nil))
229 ;; We should now be in the macro-recording state.
230 (should defining-kbd-macro)
231 (should-not last-kbd-macro)
232 ;; Calling it again should leave us in the same state.
233 (kmacro-tests-simulate-command '(kmacro-start-macro nil))
234 (should defining-kbd-macro)
235 (should-not last-kbd-macro))
236
237
238(kmacro-tests-deftest kmacro-tests-set-macro-counter-while-defining ()
239 "Use of the prefix arg with kmacro-start sets kmacro-counter."
240 ;; Give kmacro-start-macro an argument.
241 (kmacro-tests-simulate-command '(kmacro-start-macro 5))
242 (should defining-kbd-macro)
243 ;; Verify that the counter is set to that value.
244 (kmacro-tests-should-insert "5"
245 (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
246 ;; Change it while defining a macro.
247 (kmacro-tests-simulate-command '(kmacro-set-counter 1))
248 (kmacro-tests-should-insert "1"
249 (kmacro-tests-simulate-command '(kmacro-insert-counter nil)))
250 ;; Using universal arg to to set counter should reset to starting value.
251 (kmacro-tests-simulate-command '(kmacro-set-counter (4)) '(4))
252 (kmacro-tests-should-insert "5"
253 (kmacro-tests-simulate-command '(kmacro-insert-counter nil))))
254
255
256(kmacro-tests-deftest kmacro-tests-start-insert-counter-appends-to-macro ()
257 "Use of the universal arg appends to the previous macro."
258 (let ((kmacro-tests-macros (list (string-to-vector "hello"))))
259 ;; Start recording a macro.
260 (kmacro-tests-simulate-command '(kmacro-start-macro-or-insert-counter nil))
261 ;; Make sure we are recording.
262 (should defining-kbd-macro)
263 ;; Call it again and it should insert the counter.
264 (kmacro-tests-should-insert "0"
265 (kmacro-tests-simulate-command '(kmacro-start-macro-or-insert-counter nil)))
266 ;; We should still be in the recording state.
267 (should defining-kbd-macro)
268 ;; End recording with repeat count.
269 (kmacro-tests-simulate-command '(kmacro-end-or-call-macro 3))
270 ;; Recording should be finished.
271 (should-not defining-kbd-macro)
272 ;; Now use prefix arg to append to the previous macro.
273 ;; This should run the previous macro first.
274 (kmacro-tests-should-insert "hello"
275 (kmacro-tests-simulate-command
276 '(kmacro-start-macro-or-insert-counter (4))))
277 ;; Verify that the recording state has changed.
278 (should (equal defining-kbd-macro 'append))))
279
280(kmacro-tests-deftest kmacro-tests-end-call-macro-prefix-args ()
281 "kmacro-end-call-macro changes behavior based on prefix arg."
282 ;; "Record" two macros.
283 (dotimes (i 2)
284 (kmacro-tests-define-macro (vconcat (format "macro #%d" (1+ i)))))
285 ;; With no prefix arg, it should call the second macro.
286 (kmacro-tests-should-insert "macro #2"
287 (kmacro-tests-simulate-command '(kmacro-end-or-call-macro nil)))
288 ;; With universal arg, it should call the first one.
289 (kmacro-tests-should-insert "macro #1"
290 (kmacro-tests-simulate-command '(kmacro-end-or-call-macro (4)))))
291
292(kmacro-tests-deftest kmacro-tests-end-and-call-macro ()
293 "Keyboard command to end and call macro works under various conditions."
294 ;; First, try it with no macro to record.
295 (setq kmacro-tests-macros '(""))
296 (kmacro-tests-simulate-command '(kmacro-start-macro nil))
297 (condition-case err
298 (kmacro-tests-simulate-command '(kmacro-end-and-call-macro 2) 2)
299 (error (should (string= (cadr err)
300 "No kbd macro has been defined"))))
301
302 ;; Check that it stopped defining and that no macro was recorded.
303 (should-not defining-kbd-macro)
304 (should-not last-kbd-macro)
305
306 ;; Now try it while not recording, but first record a non-nil macro.
307 (kmacro-tests-define-macro "macro")
308 (kmacro-tests-should-insert "macro"
309 (kmacro-tests-simulate-command '(kmacro-end-and-call-macro nil))))
310
311(kmacro-tests-deftest kmacro-tests-end-and-call-macro-mouse ()
312 "Commands to end and call macro work under various conditions.
313This is a regression test for Bug#24992."
314 (:expected-result :failed)
315 (cl-letf (((symbol-function #'mouse-set-point) #'ignore))
316 ;; First, try it with no macro to record.
317 (setq kmacro-tests-macros '(""))
318 (kmacro-tests-simulate-command '(kmacro-start-macro nil))
319 (condition-case err
320 (kmacro-tests-simulate-command '(kmacro-end-call-mouse 2) 2)
321 (error (should (string= (cadr err)
322 "No kbd macro has been defined"))))
323
324 ;; Check that it stopped defining and that no macro was recorded.
325 (should-not defining-kbd-macro)
326 (should-not last-kbd-macro)
327
328 ;; Now try it while not recording, but first record a non-nil macro.
329 (kmacro-tests-define-macro "macro")
330 (kmacro-tests-should-insert "macro"
331 (kmacro-tests-simulate-command '(kmacro-end-call-mouse nil)))))
332
333(kmacro-tests-deftest kmacro-tests-call-macro-hint-and-repeat ()
334 "`kmacro-call-macro' gives hint in Messages and sets up repeat keymap.
335This is a regression test for: Bug#3412, Bug#11817."
336 (kmacro-tests-define-macro [?m])
337 (let ((kmacro-call-repeat-key t)
338 (kmacro-call-repeat-with-arg t)
339 (overriding-terminal-local-map overriding-terminal-local-map)
340 (last-input-event ?e))
341 (message "") ; Clear the echo area. (Bug#3412)
342 (kmacro-tests-should-match-message "Type e to repeat macro"
343 (kmacro-tests-should-insert "mmmmmm"
344 (cl-letf (((symbol-function #'this-single-command-keys) (lambda ()
345 [?\C-x ?e])))
346 (kmacro-call-macro 3))
347 ;; Check that it set up for repeat, and run the repeat.
348 (funcall (lookup-key overriding-terminal-local-map "e"))))))
349
350(kmacro-tests-deftest
351 kmacro-tests-run-macro-command-recorded-in-macro ()
352 "No infinite loop if `kmacro-end-and-call-macro' is recorded in the macro.
353\(Bug#15126)"
354 (:expected-result :failed)
355 (ert-skip "Skipping due to Bug#24921 (an ERT bug)")
356 (kmacro-tests-define-macro (vconcat "foo" [return] "\M-x"
357 "kmacro-end-and-call-macro"))
358 (use-local-map kmacro-tests-keymap)
359 (kmacro-tests-simulate-command '(kmacro-end-and-call-macro nil)))
360
361
362(kmacro-tests-deftest kmacro-tests-test-ring-2nd-commands ()
363 "2nd macro in ring is displayed and executed normally and on repeat."
364 (use-local-map kmacro-tests-keymap)
365 ;; Record one macro, with count.
366 (push (vconcat "\C-cxi" "\C-u\C-cxi") kmacro-tests-macros)
367 (kmacro-tests-simulate-command '(kmacro-start-macro 1))
368 (kmacro-tests-simulate-command '(kmacro-end-macro nil))
369 ;; Check that execute and display do nothing with no 2nd macro.
370 (kmacro-tests-should-insert ""
371 (kmacro-tests-simulate-command '(kmacro-call-ring-2nd nil)))
372 (kmacro-tests-should-match-message "Only one keyboard macro defined"
373 (kmacro-tests-simulate-command '(kmacro-view-ring-2nd)))
374 ;; Record another one, with format.
375 (kmacro-set-format "=%d=")
376 (kmacro-tests-define-macro (vconcat "bar"))
377 ;; Execute the first one, mocked up to insert counter.
378 ;; Should get default format.
379 (kmacro-tests-should-insert "11"
380 (kmacro-tests-simulate-command '(kmacro-call-ring-2nd nil)))
381 ;; Now display the 2nd ring macro and check result.
382 (kmacro-tests-should-match-message "C-c x i C-u C-c x i"
383 (kmacro-view-ring-2nd)))
384
385(kmacro-tests-deftest kmacro-tests-fill-ring-and-rotate ()
386 "Macro ring can shift one way, shift the other way, swap and pop."
387 (cl-letf ((kmacro-ring-max 4))
388 ;; Record enough macros that the first one drops off the history.
389 (dotimes (n (1+ kmacro-ring-max))
390 (kmacro-tests-define-macro (make-vector (1+ n) (+ ?a n))))
391 ;; Cycle the ring and check that #2 comes up.
392 (kmacro-tests-should-match-message "2*b"
393 (kmacro-tests-simulate-command '(kmacro-cycle-ring-next nil)))
394 ;; Execute the current macro and check arguments.
395 (kmacro-tests-should-insert "bbbb"
396 (kmacro-call-macro 2 t))
397 ;; Cycle the ring the other way; #5 expected.
398 (kmacro-tests-should-match-message "5*e" (kmacro-cycle-ring-previous nil))
399 ;; Swapping the top two should give #4.
400 (kmacro-tests-should-match-message "4*d" (kmacro-swap-ring))
401 ;; Delete the top and expect #5.
402 (kmacro-tests-should-match-message "5*e" (kmacro-delete-ring-head))))
403
404
405(kmacro-tests-deftest kmacro-tests-test-ring-commands-when-no-macros ()
406 "Ring commands give appropriate message when no macros exist."
407 (dolist (cmd '((kmacro-cycle-ring-next nil)
408 (kmacro-cycle-ring-previous nil)
409 (kmacro-swap-ring)
410 (kmacro-delete-ring-head)
411 (kmacro-view-ring-2nd)
412 (kmacro-call-ring-2nd nil)
413 (kmacro-view-macro)))
414 (kmacro-tests-should-match-message "No keyboard macro defined"
415 (kmacro-tests-simulate-command cmd))))
416
417(kmacro-tests-deftest kmacro-tests-repeat-on-last-key ()
418 "Kmacro commands can be run in sequence without prefix keys."
419 (let* ((prefix (where-is-internal 'kmacro-keymap nil t))
420 ;; Make a sequence of events to run.
421 ;; Comments are expected output of mock macros
422 ;; on the first and second run of the sequence (see below).
423 (events (mapcar #'kmacro-tests-get-kmacro-key
424 '(kmacro-end-or-call-macro-repeat ;c / b
425 kmacro-end-or-call-macro-repeat ;c / b
426 kmacro-call-ring-2nd-repeat ;b / a
427 kmacro-cycle-ring-next
428 kmacro-end-or-call-macro-repeat ;a / a
429 kmacro-cycle-ring-previous
430 kmacro-end-or-call-macro-repeat ;c / b
431 kmacro-delete-ring-head
432 kmacro-end-or-call-macro-repeat ;b / a
433 )))
434 (kmacro-tests-macros (list [?a] [?b] [?c]))
435 ;; What we want kmacro to see as keyboard command sequence
436 (first-event (seq-concatenate
437 'vector
438 prefix
439 (vector (kmacro-tests-get-kmacro-key
440 'kmacro-end-or-call-macro-repeat)))))
441 (cl-letf
442 ;; standardize repeat options
443 ((kmacro-repeat-no-prefix t)
444 (kmacro-call-repeat-key t)
445 (kmacro-call-repeat-with-arg nil))
446 ;; "Record" two macros
447 (dotimes (_n 2)
448 (kmacro-tests-simulate-command '(kmacro-start-macro nil))
449 (kmacro-tests-simulate-command '(kmacro-end-macro nil)))
450 ;; Start recording #3
451 (kmacro-tests-simulate-command '(kmacro-start-macro nil))
452
453 ;; Set up pending keyboard events and a fresh buffer
454 ;; kmacro-set-counter is not one of the repeating kmacro
455 ;; commands so it should end the sequence.
456 (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-set-counter))
457 (kmacro-tests-events (append events (list end-key))))
458 (cl-letf (((symbol-function #'this-single-command-keys)
459 (lambda () first-event)))
460 (use-local-map kmacro-tests-keymap)
461 (kmacro-tests-should-insert "ccbacb"
462 ;; End #3 and launch loop to read events.
463 (kmacro-end-or-call-macro-repeat nil))))
464
465 ;; `kmacro-edit-macro-repeat' should also stop the sequence,
466 ;; so run it again with that at the end.
467 (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-edit-macro-repeat))
468 (kmacro-tests-events (append events (list end-key))))
469 (cl-letf (((symbol-function #'edit-kbd-macro) #'ignore)
470 ((symbol-function #'this-single-command-keys)
471 (lambda () first-event)))
472 (use-local-map kmacro-tests-keymap)
473 (kmacro-tests-should-insert "bbbbbaaba"
474 (kmacro-end-or-call-macro-repeat 3)))))))
475
476(kmacro-tests-deftest kmacro-tests-repeat-view-and-run ()
477 "Kmacro view cycles through ring and executes macro just viewed."
478 (let* ((prefix (where-is-internal 'kmacro-keymap nil t))
479 (kmacro-tests-events
480 (mapcar #'kmacro-tests-get-kmacro-key
481 (append (make-list 5 'kmacro-view-macro-repeat)
482 '(kmacro-end-or-call-macro-repeat
483 kmacro-set-counter))))
484 ;; Make kmacro see this as keyboard command sequence.
485 (first-event (seq-concatenate
486 'vector
487 prefix
488 (vector (kmacro-tests-get-kmacro-key
489 'kmacro-view-macro-repeat))))
490 ;; Construct a regexp to match the messages which should be
491 ;; produced by repeated view-repeats.
492 (macros-regexp (apply #'concat
493 (mapcar (lambda (c) (format ".+%s\n" c))
494 '("d" "c" "b" "a" "d" "c")))))
495 (cl-letf ((kmacro-repeat-no-prefix t)
496 (kmacro-call-repeat-key t)
497 (kmacro-call-repeat-with-arg nil)
498 ((symbol-function #'this-single-command-keys) (lambda ()
499 first-event)))
500 ;; "Record" some macros.
501 (dotimes (n 4)
502 (kmacro-tests-define-macro (make-vector 1 (+ ?a n))))
503
504 (use-local-map kmacro-tests-keymap)
505 ;; 6 views (the direct call plus the 5 in events) should
506 ;; cycle through the ring and get to the second-to-last
507 ;; macro defined.
508 (kmacro-tests-should-insert "c"
509 (kmacro-tests-should-match-message macros-regexp
510 (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil)))))))
511
512(kmacro-tests-deftest kmacro-tests-bind-to-key-when-recording ()
513 "Bind to key doesn't bind a key during macro recording."
514 (cl-letf ((global-map global-map)
515 (saved-binding (key-binding "\C-a"))
516 (kmacro-tests-sequences (list "\C-a")))
517 (kmacro-tests-simulate-command '(kmacro-start-macro 1))
518 (kmacro-bind-to-key nil)
519 (should (eq saved-binding (key-binding "\C-a")))))
520
521(kmacro-tests-deftest kmacro-tests-name-or-bind-to-key-when-no-macro ()
522 "Bind to key, symbol or register fails when when no macro exists."
523 (should-error (kmacro-bind-to-key nil))
524 (should-error (kmacro-name-last-macro 'kmacro-tests-symbol-for-test))
525 (should-error (kmacro-to-register)))
526
527(kmacro-tests-deftest kmacro-tests-bind-to-key-bad-key-sequence ()
528 "Bind to key fails to bind to ^G."
529 (let ((global-map global-map)
530 (saved-binding (key-binding "\C-g"))
531 (kmacro-tests-sequences (list "\C-g")))
532 (kmacro-tests-define-macro [1])
533 (kmacro-bind-to-key nil)
534 (should (eq saved-binding (key-binding "\C-g")))))
535
536(kmacro-tests-deftest kmacro-tests-bind-to-key-with-key-sequence-in-use ()
537 "Bind to key respects yes-or-no-p when given already bound key sequence."
538 (kmacro-tests-define-macro (vconcat "abaab"))
539 (let ((global-map global-map)
540 (map (make-sparse-keymap))
541 (kmacro-tests-sequences (make-list 2 "\C-hi")))
542 (define-key map "\C-hi" 'info)
543 (use-local-map map)
544 ;; Try the command with yes-or-no-p set up to say no.
545 (cl-letf (((symbol-function #'yes-or-no-p)
546 (lambda (prompt)
547 (should (string-match-p "info" prompt))
548 (should (string-match-p "C-h i" prompt))
549 nil)))
550 (kmacro-bind-to-key nil))
551
552 (should (equal (where-is-internal 'info nil t)
553 (vconcat "\C-hi")))
554 ;; Try it again with yes.
555 (cl-letf (((symbol-function #' yes-or-no-p)
556 (lambda (_prompt) t)))
557 (kmacro-bind-to-key nil))
558
559 (should-not (equal (where-is-internal 'info global-map t)
560 (vconcat "\C-hi")))
561 (use-local-map nil)
562 (kmacro-tests-should-insert "abaab"
563 (funcall (key-binding "\C-hi")))))
564
565(kmacro-tests-deftest kmacro-tests-kmacro-bind-to-single-key ()
566 "Bind to key uses C-x C-k A when asked to bind to A."
567 (let ((global-map global-map)
568 (kmacro-tests-macros (list (string-to-vector "\C-cxi"))))
569 (use-local-map kmacro-tests-keymap)
570
571 ;; Record a macro with counter and format set.
572 (kmacro-set-format "<%d>")
573 (kmacro-tests-simulate-command '(kmacro-start-macro-or-insert-counter 5))
574 (kmacro-tests-simulate-command '(kmacro-end-macro nil))
575
576 (let ((kmacro-tests-sequences (list "A")))
577 (kmacro-bind-to-key nil))
578
579 ;; Record a second macro with different counter and format.
580 (kmacro-set-format "%d")
581 (kmacro-tests-define-macro [2])
582
583 ;; Check the bound key and run it and verify correct counter
584 ;; and format.
585 (should (equal (string-to-vector "\C-cxi")
586 (car (kmacro-extract-lambda
587 (key-binding "\C-x\C-kA")))))
588 (kmacro-tests-should-insert "<5>"
589 (funcall (key-binding "\C-x\C-kA")))))
590
591(kmacro-tests-deftest kmacro-tests-name-last-macro-unable-to-bind ()
592 "Name last macro won't bind to symbol which is already bound."
593 (kmacro-tests-define-macro [1])
594 ;; Set up a test symbol which looks like a function.
595 (setplist 'kmacro-tests-symbol-for-test nil)
596 (fset 'kmacro-tests-symbol-for-test #'ignore)
597 (should-error (kmacro-name-last-macro 'kmacro-tests-symbol-for-test))
598 ;; The empty string symbol also can't be bound.
599 (should-error (kmacro-name-last-macro (make-symbol ""))))
600
601(kmacro-tests-deftest kmacro-tests-name-last-macro-bind-and-rebind ()
602 "Name last macro can rebind a symbol it binds."
603 ;; Make sure our symbol is unbound.
604 (when (fboundp 'kmacro-tests-symbol-for-test)
605 (fmakunbound 'kmacro-tests-symbol-for-test))
606 (setplist 'kmacro-tests-symbol-for-test nil)
607 ;; Make two macros and bind them to the same symbol.
608 (dotimes (i 2)
609 (kmacro-tests-define-macro (make-vector (1+ i) (+ ?a i)))
610 (kmacro-name-last-macro 'kmacro-tests-symbol-for-test)
611 (should (fboundp 'kmacro-tests-symbol-for-test)))
612
613 ;; Now run the function bound to the symbol. Result should be the
614 ;; second macro.
615 (kmacro-tests-should-insert "bb"
616 (kmacro-tests-simulate-command '(kmacro-tests-symbol-for-test))))
617
618(kmacro-tests-deftest kmacro-tests-store-in-register ()
619 "Macro can be stored in and retrieved from a register."
620 (use-local-map kmacro-tests-keymap)
621 ;; Save and restore register 200 so we can use it for the test.
622 (let ((saved-reg-contents (get-register 200)))
623 (unwind-protect
624 (progn
625 ;; Define a macro, and save it to a register.
626 (kmacro-tests-define-macro (vconcat "a\C-a\C-cxu"))
627 (kmacro-to-register 200)
628 ;; Then make a new different macro.
629 (kmacro-tests-define-macro (vconcat "bb\C-a\C-cxu"))
630 ;; When called from the register, result should be first macro.
631 (kmacro-tests-should-insert "AAA"
632 (kmacro-tests-simulate-command '(jump-to-register 200 3) 3))
633 (kmacro-tests-should-insert "a C-a C-c x u"
634 (kmacro-tests-simulate-command '(insert-register 200 t) '(4))))
635 (set-register 200 saved-reg-contents))))
636
637(kmacro-tests-deftest kmacro-tests-step-edit-act ()
638 "Step-edit steps-through a macro with act and act-repeat."
639 (kmacro-tests-run-step-edit "he\C-u2lo"
640 :events (make-list 6 'act)
641 :result "hello"
642 :macro-result "he\C-u2lo")
643
644 (kmacro-tests-run-step-edit "f\C-aoo\C-abar"
645 :events (make-list 5 'act-repeat)
646 :result "baroof"
647 :macro-result "f\C-aoo\C-abar"))
648
649(kmacro-tests-deftest kmacro-tests-step-edit-skip ()
650 "Step-editing can skip parts of macro."
651 (kmacro-tests-run-step-edit "ofoofff"
652 :events '(skip skip-keep skip-keep skip-keep
653 skip-rest)
654 :result ""
655 :macro-result "foo"))
656
657(kmacro-tests-deftest kmacro-tests-step-edit-quit ()
658 "Quit while step-editing leaves macro unchanged."
659 (kmacro-tests-run-step-edit "bar"
660 :events '(help insert skip help quit)
661 :sequences '("f" "o" "o" "\C-j")
662 :result "foo"
663 :macro-result "bar"))
664
665(kmacro-tests-deftest kmacro-tests-step-insert ()
666 "Step edit can insert in macro."
667 (kmacro-tests-run-step-edit "fbazbop"
668 :events '(insert act insert-1 act-repeat)
669 :sequences '("o" "o" "\C-a" "\C-j" "\C-e")
670 :result "foobazbop"
671 :macro-result "oo\C-af\C-ebazbop"))
672
673(kmacro-tests-deftest kmacro-tests-step-edit-replace-digit-argument ()
674 "Step-edit replace can replace a numeric argument in a macro.
675This is a regression for item 1 in Bug#24991."
676 (:expected-result :failed)
677 (kmacro-tests-run-step-edit "\C-u3b\C-a\C-cxu"
678 :events '(act replace automatic)
679 :sequences '("8" "x" "\C-j")
680 :result "XXXXXXXX"
681 :macro-result "\C-u8x\C-a\C-cxu"))
682
683(kmacro-tests-deftest kmacro-tests-step-edit-replace ()
684 "Step-edit replace and replace-1 can replace parts of a macro."
685 (kmacro-tests-run-step-edit "a\C-a\C-cxu"
686 :events '(act act replace)
687 :sequences '("b" "c" "\C-j")
688 :result "bca"
689 :macro-result "a\C-abc")
690 (kmacro-tests-run-step-edit "a\C-a\C-cxucd"
691 :events '(act replace-1 automatic)
692 :sequences '("b")
693 :result "abcd"
694 :macro-result "ab\C-cxucd")
695 (kmacro-tests-run-step-edit "by"
696 :events '(act replace)
697 :sequences '("a" "r" "\C-j")
698 :result "bar"
699 :macro-result "bar"))
700
701(kmacro-tests-deftest kmacro-tests-step-edit-append ()
702 "Step edit append inserts after point, and append-end inserts at end."
703 (kmacro-tests-run-step-edit "f-b"
704 :events '(append append-end)
705 :sequences '("o" "o" "\C-j" "a" "r" "\C-j")
706 :result "foo-bar"
707 :macro-result "foo-bar")
708 (kmacro-tests-run-step-edit "x"
709 :events '(append)
710 :sequences '("\C-a" "\C-cxu" "\C-e" "y" "\C-j")
711 :result "Xy"
712 :macro-result "x\C-a\C-cxu\C-ey"))
713
714(kmacro-tests-deftest kmacro-tests-append-end-at-end-appends ()
715 "Append-end when already at end of macro appends to end of macro.
716This is a regression for item 2 in Bug#24991."
717 (:expected-result :failed)
718 (kmacro-tests-run-step-edit "x"
719 :events '(append-end)
720 :sequences '("\C-a" "\C-cxu" "\C-e" "y" "\C-j")
721 :result "Xy"
722 :macro-result "x\C-a\C-cxu\C-ey"))
723
724
725(kmacro-tests-deftest kmacro-tests-step-edit-skip-entire ()
726 "Skipping a whole macro in step-edit leaves macro unchanged.
727This is a regression for item 3 in Bug#24991."
728 (:expected-result :failed)
729 (kmacro-tests-run-step-edit "xyzzy"
730 :events '(skip-rest)
731 :result ""
732 :macro-result "xyzzy"))
733
734(kmacro-tests-deftest kmacro-tests-step-edit-step-through-negative-argument ()
735 "Step edit works on macros using negative universal argument.
736This is a regression for item 4 in Bug#24991."
737 (:expected-result :failed)
738 (kmacro-tests-run-step-edit "boo\C-u-\C-cu"
739 :events '(act-repeat automatic)
740 :result "BOO"
741 :macro-result "boo\C-u-\C-cd"))
742
743(kmacro-tests-deftest kmacro-tests-step-edit-with-quoted-insert ()
744 "Stepping through a macro that uses quoted insert leaves macro unchanged.
745This is a regression for item 5 in Bug#24991."
746 (:expected-result :failed)
747 (let ((read-quoted-char-radix 8))
748 (kmacro-tests-run-step-edit "\C-cxq17051i there"
749 :events '(act automatic)
750 :result "ḩi there"
751 :macro-result "\C-cxq17051i there")
752 (kmacro-tests-run-step-edit "g\C-cxq17051i"
753 :events '(act insert-1 automatic)
754 :sequences '("-")
755 :result "g-ḩi"
756 :macro-result "g-\C-cxq17051i")))
757
758(kmacro-tests-deftest kmacro-tests-step-edit-can-replace-meta-keys ()
759 "Replacing C-w with M-w produces the expected result.
760This is a regression for item 7 in Bug#24991."
761 (:expected-result :failed)
762 (kmacro-tests-run-step-edit "abc\C-b\C-b\C-SPC\C-f\C-w\C-e\C-y"
763 :events '(act-repeat act-repeat
764 act-repeat act-repeat
765 replace automatic)
766 :sequences '("\M-w" "\C-j")
767 :result "abcb"
768 :macro-result "abc\C-b\C-b\C-SPC\C-f\M-w\C-e\C-y")
769 (kmacro-tests-should-insert "abcb" (kmacro-call-macro nil)))
770
771(kmacro-tests-deftest kmacro-tests-step-edit-ignores-qr-map-commands ()
772 "Unimplemented commands from `query-replace-map' are ignored."
773 (kmacro-tests-run-step-edit "yep"
774 :events '(edit-replacement
775 act-and-show act-and-exit
776 delete-and-edit
777 recenter backup
778 scroll-up scroll-down
779 scroll-other-window
780 scroll-other-window-down
781 exit-prefix
782 act act act)
783 :result "yep"
784 :macro-result "yep"))
785
786(kmacro-tests-deftest
787 kmacro-tests-step-edit-edits-macro-with-extended-command ()
788 "Step-editing a macro which uses the minibuffer can change the macro."
789 (let ((mac (vconcat [?\M-x] "eval-expression" '[return]
790 "(insert-char (+ ?a \C-e" [?1] "))" '[return]))
791 (mac-after (vconcat [?\M-x] "eval-expression" '[return]
792 "(insert-char (+ ?a \C-e" [?2] "))" '[return])))
793
794 (kmacro-tests-run-step-edit mac
795 :events '(act act-repeat
796 act act-repeat act
797 replace-1 act-repeat act)
798 :sequences '("2")
799 :result "c"
800 :macro-result mac-after)))
801
802(kmacro-tests-deftest kmacro-tests-step-edit-step-through-isearch ()
803 "Step-editing can edit a macro which uses `isearch-backward' (Bug#22488)."
804 (:expected-result :failed)
805 (let ((mac (vconcat "test Input" '[return]
806 [?\C-r] "inp" '[return] "\C-cxu"))
807 (mac-after (vconcat "test input" '[return]
808 [?\C-r] "inp" '[return] "\C-cd")))
809
810 (kmacro-tests-run-step-edit mac
811 :events '(act-repeat act act
812 act-repeat act
813 replace-1)
814 :sequences '("\C-cd")
815 :result "test input\n"
816 :macro-result mac-after)))
817
818(kmacro-tests-deftest kmacro-tests-step-edit-cleans-up-hook ()
819 "Step-editing properly cleans up `post-command-hook.' (Bug #18708)"
820 (:expected-result :failed)
821 (let (post-command-hook)
822 (setq-local post-command-hook '(t))
823 (kmacro-tests-run-step-edit "x"
824 :events '(act)
825 :result "x"
826 :macro-result "x")
827 (kmacro-tests-simulate-command '(beginning-of-line))))
828
829(cl-defun kmacro-tests-run-step-edit
830 (macro &key events sequences result macro-result)
831 "Set up and run a test of `kmacro-step-edit-macro'.
832
833Run `kmacro-step-edit-macro' with MACRO defined as a keyboard macro
834and `read-event' and `read-key-sequence' set up to return items from
835EVENTS and SEQUENCES respectively. SEQUENCES may be nil, but
836EVENTS should not be. EVENTS should be a list of symbols bound
837in `kmacro-step-edit-map' or `query-replace' map, and this function
838will do the keymap lookup for you. SEQUENCES should contain
839return values for `read-key-sequence'.
840
841Before running the macro, the current buffer will be erased.
842RESULT is the string that should be inserted during the
843step-editing process, and MACRO-RESULT is the expected value of
844`last-kbd-macro' after the editing is complete."
845
846 (let* ((kmacro-tests-events (mapcar #'kmacro-tests-get-kmacro-step-edit-key events))
847 (kmacro-tests-sequences sequences))
848
849 (kmacro-tests-define-macro (string-to-vector macro))
850 (use-local-map kmacro-tests-keymap)
851 (erase-buffer)
852 (kmacro-step-edit-macro)
853 (when result
854 (should (equal result (buffer-string))))
855 (when macro-result
856 (should (equal last-kbd-macro (string-to-vector macro-result))))))
857
858;;; Utilities:
859
860(defun kmacro-tests-simulate-command (command &optional arg)
861 "Call `ert-simulate-command' after setting `current-prefix-arg'.
862Sets `current-prefix-arg' to ARG if it is non-nil, otherwise to
863the second element of COMMAND, before executing COMMAND using
864`ert-simulate-command'."
865 (let ((current-prefix-arg (or arg (cadr command))))
866 (ert-simulate-command command)))
867
868(defun kmacro-tests-define-macro (mac)
869 "Define MAC as a keyboard macro using kmacro commands."
870 (push mac kmacro-tests-macros)
871 (kmacro-tests-simulate-command '(kmacro-start-macro nil))
872 (should defining-kbd-macro)
873 (kmacro-tests-simulate-command '(kmacro-end-macro nil))
874 (should (equal mac last-kbd-macro)))
875
876(defun kmacro-tests-get-kmacro-key (sym)
877 "Look up kmacro command SYM in kmacro's keymap.
878Return the integer key value found."
879 (aref (where-is-internal sym kmacro-keymap t) 0))
880
881(defun kmacro-tests-get-kmacro-step-edit-key (sym)
882 "Return the first key bound to SYM in `kmacro-step-edit-map'."
883 (let ((where (aref (where-is-internal sym kmacro-step-edit-map t) 0)))
884 (if (consp where)
885 (car where)
886 where)))
887
888(provide 'kmacro-tests)
889
890;;; kmacro-tests.el ends here
diff --git a/test/lisp/progmodes/js-tests.el b/test/lisp/progmodes/js-tests.el
index 84749efa45b..7cb737c30e2 100644
--- a/test/lisp/progmodes/js-tests.el
+++ b/test/lisp/progmodes/js-tests.el
@@ -85,6 +85,20 @@ if (!/[ (:,='\"]/.test(value)) {
85 (should (= (current-column) x)) 85 (should (= (current-column) x))
86 (forward-line)))) 86 (forward-line))))
87 87
88(ert-deftest js-mode-auto-fill ()
89 (with-temp-buffer
90 (js-mode)
91 (setq fill-column 70)
92 (insert "/* ")
93 (dotimes (_ 16)
94 (insert "test "))
95 (do-auto-fill)
96 ;; The bug is that, after auto-fill, the second line starts with
97 ;; "/*", whereas it should start with " * ".
98 (goto-char (point-min))
99 (forward-line)
100 (should (looking-at " \\* test"))))
101
88(provide 'js-tests) 102(provide 'js-tests)
89 103
90;;; js-tests.el ends here 104;;; js-tests.el ends here
diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el
index 6eb32ea7fc4..5372c37a179 100644
--- a/test/lisp/textmodes/css-mode-tests.el
+++ b/test/lisp/textmodes/css-mode-tests.el
@@ -218,5 +218,20 @@
218 (should (member "body" completions)) 218 (should (member "body" completions))
219 (should-not (member "article" completions))))) 219 (should-not (member "article" completions)))))
220 220
221(ert-deftest css-mdn-symbol-guessing ()
222 (dolist (item '(("@med" "ia" "@media")
223 ("@keyframes " "{" "@keyframes")
224 ("p::after" "" "::after")
225 ("p:before" "" ":before")
226 ("a:v" "isited" ":visited")
227 ("border-" "color: red" "border-color")
228 ("border-color: red" ";" "border-color")
229 ("border-color: red; color: green" ";" "color")))
230 (with-temp-buffer
231 (css-mode)
232 (insert (nth 0 item))
233 (save-excursion (insert (nth 1 item)))
234 (should (equal (nth 2 item) (css--mdn-find-symbol))))))
235
221(provide 'css-mode-tests) 236(provide 'css-mode-tests)
222;;; css-mode-tests.el ends here 237;;; css-mode-tests.el ends here
diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el
new file mode 100644
index 00000000000..807a411fa5d
--- /dev/null
+++ b/test/lisp/vc/diff-mode-tests.el
@@ -0,0 +1,203 @@
1;; Copyright (C) 2017 Free Software Foundation, Inc
2
3;; Author: Dima Kogan <dima@secretsauce.net>
4;; Maintainer: emacs-devel@gnu.org
5
6;; This file is part of GNU Emacs.
7
8;; GNU Emacs is free software: you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation, either version 3 of the License, or
11;; (at your option) any later version.
12
13;; GNU Emacs is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
19;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
20
21;;; Code:
22
23(require 'diff-mode)
24
25
26(ert-deftest diff-mode-test-ignore-trailing-dashes ()
27 "Check to make sure we successfully ignore trailing -- made by
28'git format-patch'. This is bug #9597"
29
30 ;; I made a test repo, put some files in it, made arbitrary changes
31 ;; and invoked 'git format-patch' to get a patch out of it. The
32 ;; patch and the before and after versions of the files appear here.
33 ;; The test simply tries to apply the patch. The patch contains
34 ;; trailing --, which confused diff-mode previously
35 (let ((patch "From 18ed35640be496647e0a02fc155b4ee4a0490eca Mon Sep 17 00:00:00 2001
36From: Dima Kogan <dima@secretsauce.net>
37Date: Mon, 30 Jan 2017 22:24:13 -0800
38Subject: [PATCH] test commit
39
40---
41 fil | 3 ---
42 fil2 | 4 ----
43 2 files changed, 7 deletions(-)
44
45diff --git a/fil b/fil
46index 10344f1..2a56245 100644
47--- a/fil
48+++ b/fil
49@@ -2,10 +2,8 @@ Afrocentrism
50 Americanisms
51 Americanization
52 Americanizations
53-Americanized
54 Americanizes
55 Americanizing
56-Andrianampoinimerina
57 Anglicanisms
58 Antananarivo
59 Apalachicola
60@@ -15,6 +13,5 @@ Aristophanes
61 Aristotelian
62 Ashurbanipal
63 Australopithecus
64-Austronesian
65 Bangladeshis
66 Barquisimeto
67diff --git a/fil2 b/fil2
68index 8858f0d..86e8ea5 100644
69--- a/fil2
70+++ b/fil2
71@@ -1,20 +1,16 @@
72 whippoorwills
73 whitewashing
74 wholehearted
75-wholeheartedly
76 wholesomeness
77 wildernesses
78 windbreakers
79 wisecracking
80 withstanding
81-woodcarvings
82 woolgathering
83 workstations
84 worthlessness
85 wretchedness
86 wristwatches
87-wrongfulness
88 wrongheadedly
89 wrongheadedness
90-xylophonists
91 youthfulness
92--
932.11.0
94
95")
96 (fil_before "Afrocentrism
97Americanisms
98Americanization
99Americanizations
100Americanized
101Americanizes
102Americanizing
103Andrianampoinimerina
104Anglicanisms
105Antananarivo
106Apalachicola
107Appalachians
108Argentinians
109Aristophanes
110Aristotelian
111Ashurbanipal
112Australopithecus
113Austronesian
114Bangladeshis
115Barquisimeto
116")
117 (fil_after "Afrocentrism
118Americanisms
119Americanization
120Americanizations
121Americanizes
122Americanizing
123Anglicanisms
124Antananarivo
125Apalachicola
126Appalachians
127Argentinians
128Aristophanes
129Aristotelian
130Ashurbanipal
131Australopithecus
132Bangladeshis
133Barquisimeto
134")
135 (fil2_before "whippoorwills
136whitewashing
137wholehearted
138wholeheartedly
139wholesomeness
140wildernesses
141windbreakers
142wisecracking
143withstanding
144woodcarvings
145woolgathering
146workstations
147worthlessness
148wretchedness
149wristwatches
150wrongfulness
151wrongheadedly
152wrongheadedness
153xylophonists
154youthfulness
155")
156 (fil2_after "whippoorwills
157whitewashing
158wholehearted
159wholesomeness
160wildernesses
161windbreakers
162wisecracking
163withstanding
164woolgathering
165workstations
166worthlessness
167wretchedness
168wristwatches
169wrongheadedly
170wrongheadedness
171youthfulness
172")
173 (temp-dir (make-temp-file "diff-mode-test" 'dir)))
174
175 (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" )))
176 (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2"))))
177 (unwind-protect
178 (progn
179 (with-current-buffer buf (insert fil_before) (save-buffer))
180 (with-current-buffer buf2 (insert fil2_before) (save-buffer))
181
182 (with-temp-buffer
183 (cd temp-dir)
184 (insert patch)
185 (beginning-of-buffer)
186 (diff-apply-hunk)
187 (diff-apply-hunk)
188 (diff-apply-hunk))
189
190 (should (equal (with-current-buffer buf (buffer-string))
191 fil_after))
192 (should (equal (with-current-buffer buf2 (buffer-string))
193 fil2_after)))
194
195 (ignore-errors
196 (with-current-buffer buf (set-buffer-modified-p nil))
197 (kill-buffer buf)
198 (with-current-buffer buf2 (set-buffer-modified-p nil))
199 (kill-buffer buf2)
200 (delete-directory temp-dir 'recursive))))))
201
202
203(provide 'diff-mode-tests)
diff --git a/test/manual/indent/css-mode.css b/test/manual/indent/css-mode.css
index 3a00739bfc4..0845c02c299 100644
--- a/test/manual/indent/css-mode.css
+++ b/test/manual/indent/css-mode.css
@@ -43,3 +43,30 @@ article:hover
43{ 43{
44 color: black; 44 color: black;
45} 45}
46
47/* bug:13425 */
48div:first-child,
49div:last-child,
50div[disabled],
51div::before {
52 font: 15px "Helvetica Neue",
53 Helvetica,
54 Arial,
55 "Nimbus Sans L",
56 sans-serif;
57 font: 15px "Helvetica Neue", Helvetica, Arial,
58 "Nimbus Sans L", sans-serif;
59 transform: matrix(1.0, 2.0,
60 3.0, 4.0,
61 5.0, 6.0);
62 transform: matrix(
63 1.0, 2.0,
64 3.0, 4.0,
65 5.0, 6.0
66 );
67}
68@font-face {
69 src: url("Sans-Regular.eot") format("eot"),
70 url("Sans-Regular.woff") format("woff"),
71 url("Sans-Regular.ttf") format("truetype");
72}
diff --git a/test/manual/indent/scss-mode.scss b/test/manual/indent/scss-mode.scss
index e1ec90a5299..f9911ad11b7 100644
--- a/test/manual/indent/scss-mode.scss
+++ b/test/manual/indent/scss-mode.scss
@@ -16,20 +16,20 @@ nav {
16 } 16 }
17} 17}
18nav ul { 18nav ul {
19 margin: 0; 19 margin: 0;
20 padding: 0; 20 padding: 0;
21 list-style: none; 21 list-style: none;
22} 22}
23 23
24nav li { 24nav li {
25 display: inline-block; 25 display: inline-block;
26} 26}
27 27
28nav a var 28nav a var
29{ 29{
30 display: block; 30 display: block;
31 padding: 6px 12px; 31 padding: 6px 12px;
32 text-decoration: none; 32 text-decoration: none;
33} 33}
34 34
35$name: foo; 35$name: foo;
@@ -67,10 +67,28 @@ button {
67 67
68// bug:21230 68// bug:21230
69$list: ( 69$list: (
70 ('a', #000000, #fff) 70 ('a', #000000, #fff)
71 ('b', #000000, #fff) 71 ('b', #000000, #fff)
72 ('c', #000000, #fff) 72 ('c', #000000, #fff)
73 ('d', #000000, #fff) 73 ('d', #000000, #fff)
74 ('e', #000000, #fff) 74 ('e', #000000, #fff)
75 ('f', #000000, #fff) 75 ('f', #000000, #fff)
76); 76);
77
78// bug:13425
79div:first-child,
80div:last-child {
81 @include foo-mixin(
82 $foo: 'foo',
83 $bar: 'bar',
84 );
85
86 font: 15px "Helvetica Neue", Helvetica, Arial,
87 "Nimbus Sans L", sans-serif;
88
89 div:first-child,
90 div:last-child {
91 font: 15px "Helvetica Neue", Helvetica, Arial,
92 "Nimbus Sans L", sans-serif;
93 }
94}
diff --git a/test/manual/scroll-tests.el b/test/manual/scroll-tests.el
new file mode 100644
index 00000000000..1167efd6a66
--- /dev/null
+++ b/test/manual/scroll-tests.el
@@ -0,0 +1,130 @@
1;;; scroll-tests.el -- tests for scrolling -*- lexical-binding: t -*-
2
3;; Copyright (C) 2017 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; This program is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;; These are mostly automated ert tests, but they don't work in batch
23;; mode which is why they are under test/manual.
24
25;;; Code:
26
27(require 'ert)
28(eval-when-compile (require 'cl-lib))
29
30(defun scroll-tests-up-and-down (margin &optional effective-margin)
31 (unless effective-margin
32 (setq effective-margin margin))
33 (erase-buffer)
34 (insert (mapconcat #'number-to-string
35 (number-sequence 1 200) "\n"))
36 (goto-char 1)
37 (sit-for 0)
38 (let ((scroll-margin margin)
39 (wstart (window-start)))
40 ;; Stopping before `scroll-margin' so we shouldn't have
41 ;; scrolled.
42 (let ((current-prefix-arg (- (window-text-height) 1 effective-margin)))
43 (call-interactively 'next-line))
44 (sit-for 0)
45 (should (= wstart (window-start)))
46 ;; Passing `scroll-margin' should trigger scrolling.
47 (call-interactively 'next-line)
48 (sit-for 0)
49 (should (/= wstart (window-start)))
50 ;; Scroll back to top.
51 (let ((current-prefix-arg (window-start)))
52 (call-interactively 'scroll-down-command))
53 (sit-for 0)
54 (should (= 1 (window-start)))))
55
56(defmacro scroll-tests-with-buffer-window (&rest body)
57 (declare (debug t))
58 `(with-temp-buffer
59 (with-selected-window (display-buffer (current-buffer))
60 ,@body)))
61
62(ert-deftest scroll-tests-scroll-margin-0 ()
63 (skip-unless (not noninteractive))
64 (scroll-tests-with-buffer-window
65 (scroll-tests-up-and-down 0)))
66
67(ert-deftest scroll-tests-scroll-margin-negative ()
68 "A negative `scroll-margin' should be the same as 0."
69 (skip-unless (not noninteractive))
70 (scroll-tests-with-buffer-window
71 (scroll-tests-up-and-down -10 0)))
72
73(ert-deftest scroll-tests-scroll-margin-max ()
74 (skip-unless (not noninteractive))
75 (scroll-tests-with-buffer-window
76 (let ((max-margin (/ (window-text-height) 4)))
77 (scroll-tests-up-and-down max-margin))))
78
79(ert-deftest scroll-tests-scroll-margin-over-max ()
80 "A `scroll-margin' more than max should be the same as max."
81 (skip-unless (not noninteractive))
82 (scroll-tests-with-buffer-window
83 (set-window-text-height nil 7)
84 (let ((max-margin (/ (window-text-height) 4)))
85 (scroll-tests-up-and-down (+ max-margin 1) max-margin)
86 (scroll-tests-up-and-down (+ max-margin 2) max-margin))))
87
88(defun scroll-tests--point-in-middle-of-window-p ()
89 (= (count-lines (window-start) (window-point))
90 (/ (1- (window-text-height)) 2)))
91
92(cl-defun scroll-tests--scroll-margin-whole-window (&key with-line-spacing)
93 "Test `maximum-scroll-margin' at 0.5.
94With a high `scroll-margin', this should keep cursor in the
95middle of the window."
96 (let ((maximum-scroll-margin 0.5)
97 (scroll-margin 100))
98 (scroll-tests-with-buffer-window
99 (setq-local line-spacing with-line-spacing)
100 ;; Choose an odd number, so there is one line in the middle.
101 (set-window-text-height nil 7)
102 ;; `set-window-text-height' doesn't count `line-spacing'.
103 (when with-line-spacing
104 (window-resize nil (* line-spacing 7) nil nil 'pixels))
105 (erase-buffer)
106 (insert (mapconcat #'number-to-string
107 (number-sequence 1 200) "\n"))
108 (goto-char 1)
109 (sit-for 0)
110 (call-interactively 'scroll-up-command)
111 (sit-for 0)
112 (should (scroll-tests--point-in-middle-of-window-p))
113 (call-interactively 'scroll-up-command)
114 (sit-for 0)
115 (should (scroll-tests--point-in-middle-of-window-p))
116 (call-interactively 'scroll-down-command)
117 (sit-for 0)
118 (should (scroll-tests--point-in-middle-of-window-p)))))
119
120(ert-deftest scroll-tests-scroll-margin-whole-window ()
121 (skip-unless (not noninteractive))
122 (scroll-tests--scroll-margin-whole-window))
123
124(ert-deftest scroll-tests-scroll-margin-whole-window-line-spacing ()
125 ;; `line-spacing' has no effect on tty displays.
126 (skip-unless (display-graphic-p))
127 (scroll-tests--scroll-margin-whole-window :with-line-spacing 3))
128
129
130;;; scroll-tests.el ends here