aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorAlan Mackenzie2017-02-12 10:59:03 +0000
committerAlan Mackenzie2017-02-12 10:59:03 +0000
commitf4d5b687150810129b7a1d5b006e31ccf82b691b (patch)
tree4229b13800349032697daae3904dc3773e6b7a80
parentd5514332d4a6092673ce1f78fadcae0c57f7be64 (diff)
parent148100d98319499f0ac6f57b8be08cbd14884a5c (diff)
downloademacs-comment-cache.tar.gz
emacs-comment-cache.zip
Merge branch 'master' into comment-cachecomment-cache
-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/internals.texi6
-rw-r--r--doc/lispref/lists.texi33
-rw-r--r--doc/lispref/processes.texi8
-rw-r--r--doc/lispref/windows.texi15
-rw-r--r--doc/misc/cc-mode.texi31
-rw-r--r--doc/misc/cl.texi2
-rw-r--r--doc/misc/emacs-mime.texi4
-rw-r--r--doc/misc/gnus.texi34
-rw-r--r--doc/misc/texinfo.tex33
-rw-r--r--etc/DEBUG2
-rw-r--r--etc/NEWS65
-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/battery.el3
-rw-r--r--lisp/buff-menu.el19
-rw-r--r--lisp/calc/calc-misc.el2
-rw-r--r--lisp/calendar/parse-time.el12
-rw-r--r--lisp/cus-start.el1
-rw-r--r--lisp/dired-aux.el2
-rw-r--r--lisp/dired.el4
-rw-r--r--lisp/doc-view.el5
-rw-r--r--lisp/emacs-lisp/backquote.el10
-rw-r--r--lisp/emacs-lisp/cl-generic.el15
-rw-r--r--lisp/emacs-lisp/cl-lib.el143
-rw-r--r--lisp/emacs-lisp/cl.el24
-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/emacs-lisp/tabulated-list.el9
-rw-r--r--lisp/emulation/edt-mapper.el525
-rw-r--r--lisp/emulation/edt.el8
-rw-r--r--lisp/files.el18
-rw-r--r--lisp/gnus/gnus-art.el22
-rw-r--r--lisp/gnus/gnus-msg.el9
-rw-r--r--lisp/gnus/gnus-salt.el4
-rw-r--r--lisp/gnus/gnus-start.el9
-rw-r--r--lisp/gnus/gnus-sum.el28
-rw-r--r--lisp/gnus/gnus-topic.el2
-rw-r--r--lisp/gnus/gnus.el4
-rw-r--r--lisp/gnus/message.el132
-rw-r--r--lisp/gnus/mml.el98
-rw-r--r--lisp/gnus/nndoc.el20
-rw-r--r--lisp/gnus/nnimap.el6
-rw-r--r--lisp/help-fns.el40
-rw-r--r--lisp/help-mode.el2
-rw-r--r--lisp/hl-line.el3
-rw-r--r--lisp/htmlfontify.el12
-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/mail/ietf-drums.el11
-rw-r--r--lisp/mail/rfc2047.el12
-rw-r--r--lisp/mh-e/mh-compat.el10
-rw-r--r--lisp/net/eww.el71
-rw-r--r--lisp/net/network-stream.el4
-rw-r--r--lisp/net/shr.el32
-rw-r--r--lisp/net/tramp.el30
-rw-r--r--lisp/net/zeroconf.el6
-rw-r--r--lisp/play/dunnet.el2
-rw-r--r--lisp/progmodes/cc-align.el12
-rw-r--r--lisp/progmodes/cc-engine.el99
-rw-r--r--lisp/progmodes/cc-styles.el1
-rw-r--r--lisp/progmodes/cc-vars.el2
-rw-r--r--lisp/progmodes/hideshow.el2
-rw-r--r--lisp/progmodes/js.el24
-rw-r--r--lisp/progmodes/python.el20
-rw-r--r--lisp/progmodes/sql.el2
-rw-r--r--lisp/progmodes/vhdl-mode.el43
-rw-r--r--lisp/progmodes/xref.el2
-rw-r--r--lisp/recentf.el2
-rw-r--r--lisp/replace.el115
-rw-r--r--lisp/shell.el13
-rw-r--r--lisp/simple.el8
-rw-r--r--lisp/subr.el122
-rw-r--r--lisp/term.el15
-rw-r--r--lisp/textmodes/css-mode.el156
-rw-r--r--lisp/textmodes/reftex-vars.el2
-rw-r--r--lisp/vc/diff-mode.el190
-rw-r--r--lisp/vc/ediff-init.el46
-rw-r--r--lisp/xml.el6
-rw-r--r--src/alloc.c299
-rw-r--r--src/atimer.c1
-rw-r--r--src/buffer.c13
-rw-r--r--src/bytecode.c22
-rw-r--r--src/callint.c2
-rw-r--r--src/callproc.c18
-rw-r--r--src/category.c2
-rw-r--r--src/ccl.c2
-rw-r--r--src/decompress.c2
-rw-r--r--src/dired.c9
-rw-r--r--src/dispextern.h1
-rw-r--r--src/doc.c9
-rw-r--r--src/editfns.c12
-rw-r--r--src/emacs-module.c2
-rw-r--r--src/emacs.c2
-rw-r--r--src/eval.c51
-rw-r--r--src/fileio.c94
-rw-r--r--src/filelock.c9
-rw-r--r--src/fns.c377
-rw-r--r--src/fontset.c8
-rw-r--r--src/frame.c5
-rw-r--r--src/gfilenotify.c8
-rw-r--r--src/gnutls.c13
-rw-r--r--src/image.c2
-rw-r--r--src/indent.c13
-rw-r--r--src/insdel.c12
-rw-r--r--src/keyboard.c109
-rw-r--r--src/keyboard.h2
-rw-r--r--src/keymap.c12
-rw-r--r--src/lisp.h64
-rw-r--r--src/lread.c16
-rw-r--r--src/macros.c2
-rw-r--r--src/minibuf.c2
-rw-r--r--src/print.c16
-rw-r--r--src/process.c22
-rw-r--r--src/profiler.c6
-rw-r--r--src/regex.c13
-rw-r--r--src/search.c105
-rw-r--r--src/syntax.c250
-rw-r--r--src/sysdep.c131
-rw-r--r--src/textprop.c2
-rw-r--r--src/w32fns.c15
-rw-r--r--src/w32notify.c2
-rw-r--r--src/w32proc.c2
-rw-r--r--src/window.c62
-rw-r--r--src/window.h2
-rw-r--r--src/xdisp.c106
-rw-r--r--src/xselect.c4
-rw-r--r--src/xterm.c4
-rw-r--r--test/lisp/abbrev-tests.el3
-rw-r--r--test/lisp/autorevert-tests.el170
-rw-r--r--test/lisp/emacs-lisp/cl-seq-tests.el6
-rw-r--r--test/lisp/emacs-lisp/let-alist-tests.el5
-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/faces-tests.el9
-rw-r--r--test/lisp/ffap-tests.el2
-rw-r--r--test/lisp/filenotify-tests.el70
-rw-r--r--test/lisp/htmlfontify-tests.el12
-rw-r--r--test/lisp/ibuffer-tests.el9
-rw-r--r--test/lisp/kmacro-tests.el890
-rw-r--r--test/lisp/minibuffer-tests.el2
-rw-r--r--test/lisp/net/dbus-tests.el3
-rw-r--r--test/lisp/progmodes/js-tests.el14
-rw-r--r--test/lisp/progmodes/python-tests.el23
-rw-r--r--test/lisp/simple-tests.el6
-rw-r--r--test/lisp/textmodes/css-mode-tests.el15
-rw-r--r--test/lisp/textmodes/tildify-tests.el2
-rw-r--r--test/lisp/vc/diff-mode-tests.el203
-rw-r--r--test/lisp/xml-tests.el15
-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
-rw-r--r--test/src/syntax-tests.el85
167 files changed, 4939 insertions, 2189 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/internals.texi b/doc/lispref/internals.texi
index 69d21bedaa4..663d0fd92b9 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -672,7 +672,7 @@ usage: (or CONDITIONS...) */)
672 if (!NILP (val)) 672 if (!NILP (val))
673 break; 673 break;
674 args = XCDR (args); 674 args = XCDR (args);
675 QUIT; 675 maybe_quit ();
676 @} 676 @}
677@end group 677@end group
678 678
@@ -792,8 +792,8 @@ their addresses after performing Lisp evaluation. Lisp evaluation can
792occur via calls to @code{eval_sub} or @code{Feval}, either directly or 792occur via calls to @code{eval_sub} or @code{Feval}, either directly or
793indirectly. 793indirectly.
794 794
795@cindex @code{QUIT}, use in Lisp primitives 795@cindex @code{maybe_quit}, use in Lisp primitives
796 Note the call to the @code{QUIT} macro inside the loop: this macro 796 Note the call to @code{maybe_quit} inside the loop: this function
797checks whether the user pressed @kbd{C-g}, and if so, aborts the 797checks whether the user pressed @kbd{C-g}, and if so, aborts the
798processing. You should do that in any loop that can potentially 798processing. You should do that in any loop that can potentially
799require a large number of iterations; in this case, the list of 799require a large number of iterations; in this case, the list of
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index bd7d85aa189..8eab2818f97 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -362,6 +362,39 @@ This is the same as @code{(cdr (cdr @var{cons-cell}))}
362or @code{(nthcdr 2 @var{cons-cell})}. 362or @code{(nthcdr 2 @var{cons-cell})}.
363@end defun 363@end defun
364 364
365@findex caaar
366@findex caadr
367@findex cadar
368@findex caddr
369@findex cdaar
370@findex cdadr
371@findex cddar
372@findex cdddr
373@findex caaaar
374@findex caaadr
375@findex caadar
376@findex caaddr
377@findex cadaar
378@findex cadadr
379@findex caddar
380@findex cadddr
381@findex cdaaar
382@findex cdaadr
383@findex cdadar
384@findex cdaddr
385@findex cddaar
386@findex cddadr
387@findex cdddar
388@findex cddddr
389In addition to the above, 24 additional compositions of @code{car} and
390@code{cdr} are defined as @code{c@var{xxx}r} and @code{c@var{xxxx}r},
391where each @code{@var{x}} is either @code{a} or @code{d}. @code{cadr},
392@code{caddr}, and @code{cadddr} pick out the second, third or fourth
393elements of a list, respectively. @file{cl-lib} provides the same
394under the names @code{cl-second}, @code{cl-third}, and
395@code{cl-fourth}. @xref{List Functions,,, cl, Common Lisp
396Extensions}.
397
365@defun butlast x &optional n 398@defun butlast x &optional n
366This function returns the list @var{x} with the last element, 399This function returns the list @var{x} with the last element,
367or the last @var{n} elements, removed. If @var{n} is greater 400or the last @var{n} elements, removed. If @var{n} is greater
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 014a0aed913..58e04a311a1 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -2414,6 +2414,14 @@ If non-@code{nil}, the host's capability string.
2414The connection type: @samp{plain} or @samp{tls}. 2414The connection type: @samp{plain} or @samp{tls}.
2415@end table 2415@end table
2416 2416
2417@item :shell-command @var{string-or-nil}
2418If the connection @code{type} is @code{shell}, this parameter will be
2419interpreted as a format-spec string that will be executed to make the
2420connection. The specs available are @samp{%s} for the host name and
2421@samp{%p} for the port number. For instance, if you want to first ssh
2422to @samp{gateway} before making a plain connection, then this
2423parameter could be something like @samp{ssh gateway nc %s %p}.
2424
2417@end table 2425@end table
2418 2426
2419@end defun 2427@end defun
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/cl.texi b/doc/misc/cl.texi
index 9e56a54ed74..8baa0bd88c6 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -3694,7 +3694,7 @@ i.e., chains of cons cells.
3694 3694
3695@defun cl-caddr x 3695@defun cl-caddr x
3696This function is equivalent to @code{(car (cdr (cdr @var{x})))}. 3696This function is equivalent to @code{(car (cdr (cdr @var{x})))}.
3697Likewise, this package defines all 24 @code{c@var{xxx}r} functions 3697Likewise, this package aliases all 24 @code{c@var{xxx}r} functions
3698where @var{xxx} is up to four @samp{a}s and/or @samp{d}s. 3698where @var{xxx} is up to four @samp{a}s and/or @samp{d}s.
3699All of these functions are @code{setf}-able, and calls to them 3699All of these functions are @code{setf}-able, and calls to them
3700are expanded inline by the byte-compiler for maximum efficiency. 3700are expanded inline by the byte-compiler for maximum efficiency.
diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi
index 771c078be75..b0cfbc9d3c0 100644
--- a/doc/misc/emacs-mime.texi
+++ b/doc/misc/emacs-mime.texi
@@ -654,6 +654,10 @@ Each tag can contain zero or more parameters on the form
654but that's not necessary unless the value contains white space. So 654but that's not necessary unless the value contains white space. So
655@samp{filename=/home/user/#hello$^yes} is perfectly valid. 655@samp{filename=/home/user/#hello$^yes} is perfectly valid.
656 656
657If you want to talk about MML in a message, you need a way to
658``quote'' these tags. The way to do that is to include an exclamation
659point after the opening two characters; i. e. @samp{<#!part ...>}.
660
657The following parameters have meaning in @acronym{MML}; parameters that have no 661The following parameters have meaning in @acronym{MML}; parameters that have no
658meaning are ignored. The @acronym{MML} parameter names are the same as the 662meaning are ignored. The @acronym{MML} parameter names are the same as the
659@acronym{MIME} parameter names; the things in the parentheses say which 663@acronym{MIME} parameter names; the things in the parentheses say which
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 05159d4b2f7..ceeb42b9182 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -10197,6 +10197,11 @@ Sort by lines (@code{gnus-summary-sort-by-lines}).
10197@findex gnus-summary-sort-by-chars 10197@findex gnus-summary-sort-by-chars
10198Sort by article length (@code{gnus-summary-sort-by-chars}). 10198Sort by article length (@code{gnus-summary-sort-by-chars}).
10199 10199
10200@item C-c C-s C-m C-m
10201@kindex C-c C-s C-m C-m (Summary)
10202@findex gnus-summary-sort-by-marks
10203Sort by article ``readedness'' marks (@code{gnus-summary-sort-by-marks}).
10204
10200@item C-c C-s C-i 10205@item C-c C-s C-i
10201@kindex C-c C-s C-i (Summary) 10206@kindex C-c C-s C-i (Summary)
10202@findex gnus-summary-sort-by-score 10207@findex gnus-summary-sort-by-score
@@ -13515,7 +13520,8 @@ Close the connection (if any) to the server
13515@kindex D (Server) 13520@kindex D (Server)
13516@findex gnus-server-deny-server 13521@findex gnus-server-deny-server
13517Mark the current server as unreachable 13522Mark the current server as unreachable
13518(@code{gnus-server-deny-server}). 13523(@code{gnus-server-deny-server}). This will effectively disable the
13524server.
13519 13525
13520@item M-o 13526@item M-o
13521@kindex M-o (Server) 13527@kindex M-o (Server)
@@ -21857,37 +21863,37 @@ In summary mode:
21857 21863
21858@table @kbd 21864@table @kbd
21859 21865
21860@item $ m 21866@item G G m
21861@kindex $ m (Summary) 21867@kindex G G m (Summary)
21862@findex nnmairix-widget-search-from-this-article 21868@findex nnmairix-widget-search-from-this-article
21863Allows you to create a mairix query or group based on the current 21869Allows you to create a mairix query or group based on the current
21864message using graphical widgets (same as @code{nnmairix-widget-search}) 21870message using graphical widgets (same as @code{nnmairix-widget-search})
21865(@code{nnmairix-widget-search-from-this-article}). 21871(@code{nnmairix-widget-search-from-this-article}).
21866 21872
21867@item $ g 21873@item G G g
21868@kindex $ g (Summary) 21874@kindex G G g (Summary)
21869@findex nnmairix-create-search-group-from-message 21875@findex nnmairix-create-search-group-from-message
21870Interactively creates a new search group with query based on the current 21876Interactively creates a new search group with query based on the current
21871message, but uses the minibuffer instead of graphical widgets 21877message, but uses the minibuffer instead of graphical widgets
21872(@code{nnmairix-create-search-group-from-message}). 21878(@code{nnmairix-create-search-group-from-message}).
21873 21879
21874@item $ t 21880@item G G t
21875@kindex $ t (Summary) 21881@kindex G G t (Summary)
21876@findex nnmairix-search-thread-this-article 21882@findex nnmairix-search-thread-this-article
21877Searches thread for the current article 21883Searches thread for the current article
21878(@code{nnmairix-search-thread-this-article}). This is effectively a 21884(@code{nnmairix-search-thread-this-article}). This is effectively a
21879shortcut for calling @code{nnmairix-search} with @samp{m:msgid} of the 21885shortcut for calling @code{nnmairix-search} with @samp{m:msgid} of the
21880current article and enabled threads. 21886current article and enabled threads.
21881 21887
21882@item $ f 21888@item G G f
21883@kindex $ f (Summary) 21889@kindex G G f (Summary)
21884@findex nnmairix-search-from-this-article 21890@findex nnmairix-search-from-this-article
21885Searches all messages from sender of the current article 21891Searches all messages from sender of the current article
21886(@code{nnmairix-search-from-this-article}). This is a shortcut for 21892(@code{nnmairix-search-from-this-article}). This is a shortcut for
21887calling @code{nnmairix-search} with @samp{f:From}. 21893calling @code{nnmairix-search} with @samp{f:From}.
21888 21894
21889@item $ o 21895@item G G o
21890@kindex $ o (Summary) 21896@kindex G G o (Summary)
21891@findex nnmairix-goto-original-article 21897@findex nnmairix-goto-original-article
21892(Only in @code{nnmairix} groups!) Tries determine the group this article 21898(Only in @code{nnmairix} groups!) Tries determine the group this article
21893originally came from and displays the article in this group, so that, 21899originally came from and displays the article in this group, so that,
@@ -21896,8 +21902,8 @@ parameters are applied (@code{nnmairix-goto-original-article}). This
21896function will use the registry if available, but can also parse the 21902function will use the registry if available, but can also parse the
21897article file name as a fallback method. 21903article file name as a fallback method.
21898 21904
21899@item $ u 21905@item G G u
21900@kindex $ u (Summary) 21906@kindex G G u (Summary)
21901@findex nnmairix-remove-tick-mark-original-article 21907@findex nnmairix-remove-tick-mark-original-article
21902Remove possibly existing tick mark from original article 21908Remove possibly existing tick mark from original article
21903(@code{nnmairix-remove-tick-mark-original-article}). (@pxref{nnmairix 21909(@code{nnmairix-remove-tick-mark-original-article}). (@pxref{nnmairix
@@ -22051,7 +22057,7 @@ activate the always-unread feature by using @kbd{G b r} twice.
22051 22057
22052So far so good---but how do you remove the tick marks in the @code{nnmairix} 22058So far so good---but how do you remove the tick marks in the @code{nnmairix}
22053group? There are two options: You may simply use 22059group? There are two options: You may simply use
22054@code{nnmairix-remove-tick-mark-original-article} (bound to @kbd{$ u}) to remove 22060@code{nnmairix-remove-tick-mark-original-article} (bound to @kbd{G G u}) to remove
22055tick marks from the original article. The other possibility is to set 22061tick marks from the original article. The other possibility is to set
22056@code{nnmairix-propagate-marks-to-nnmairix-groups} to @code{t}, but see the above 22062@code{nnmairix-propagate-marks-to-nnmairix-groups} to @code{t}, but see the above
22057comments about this option. If it works for you, the tick marks should 22063comments about this option. If it works for you, the tick marks should
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex
index 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/DEBUG b/etc/DEBUG
index acb08c660e0..3719c3e6f66 100644
--- a/etc/DEBUG
+++ b/etc/DEBUG
@@ -225,7 +225,7 @@ this command:
225 handle SIGINT stop nopass 225 handle SIGINT stop nopass
226 226
227After this 'handle' command, SIGINT will return control to GDB. If 227After this 'handle' command, SIGINT will return control to GDB. If
228you want the C-g to cause a QUIT within Emacs as well, omit the 'nopass'. 228you want the C-g to cause a quit within Emacs as well, omit the 'nopass'.
229See the GDB manual for more details about signal handling and the 229See the GDB manual for more details about signal handling and the
230'handle' command. 230'handle' command.
231 231
diff --git a/etc/NEWS b/etc/NEWS
index 051b97e146a..cbf2b70c821 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -116,7 +116,16 @@ dired buffer.
116** Emacs now uses double buffering to reduce flicker when editing and 116** Emacs now uses double buffering to reduce flicker when editing and
117resizing graphical Emacs frames on the X Window System. This support 117resizing graphical Emacs frames on the X Window System. This support
118requires the DOUBLE-BUFFER extension, which major X servers have 118requires the DOUBLE-BUFFER extension, which major X servers have
119supported for many years. 119supported for many years. If your system has this extension, but an
120Emacs built with double buffering misbehaves on some displays you use,
121you can disable the feature by adding
122
123 '(inhibit-double-buffering . t)
124
125to default-frame-parameters. Or inject this parameter into the
126selected frame by evaluating this form:
127
128 (modify-frame-parameters nil '((inhibit-double-buffering . t)))
120 129
121--- 130---
122The group 'wp', whose label was "text", is now deprecated. 131The group 'wp', whose label was "text", is now deprecated.
@@ -298,10 +307,23 @@ local part of a remote file name. Thus, if you have a directory named
298"/~" on the remote host "foo", you can prevent it from being 307"/~" on the remote host "foo", you can prevent it from being
299substituted by a home directory by writing it as "/foo:/:/~/file". 308substituted by a home directory by writing it as "/foo:/:/~/file".
300 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
301 315
302* Editing Changes in Emacs 26.1 316* Editing Changes in Emacs 26.1
303 317
304+++ 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+++
305** New bindings for 'query-replace-map'. 327** New bindings for 'query-replace-map'.
306'undo', undo the last replacement; bound to 'u'. 328'undo', undo the last replacement; bound to 'u'.
307'undo-all', undo all replacements; bound to 'U'. 329'undo-all', undo all replacements; bound to 'U'.
@@ -339,6 +361,16 @@ bound to 'Buffer-menu-unmark-all-buffers'.
339*** Two new commands 'Buffer-menu-unmark-all', bound to 'U' and 361*** Two new commands 'Buffer-menu-unmark-all', bound to 'U' and
340'Buffer-menu-unmark-all-buffers', bound to 'M-DEL'. 362'Buffer-menu-unmark-all-buffers', bound to 'M-DEL'.
341 363
364** Gnus
365
366---
367*** The .newsrc file will now only be saved if the native select
368method is an NNTP select method.
369
370+++
371*** A new command for sorting articles by readedness marks has been
372added: `C-c C-s C-m C-m'.
373
342** Ibuffer 374** Ibuffer
343 375
344--- 376---
@@ -432,6 +464,11 @@ viewing HTML files and the like.
432breakpoint (e.g. with "f" and "o") by customizing the new option 464breakpoint (e.g. with "f" and "o") by customizing the new option
433'edebug-sit-on-break'. 465'edebug-sit-on-break'.
434 466
467+++
468*** New customizable option 'edebug-max-depth'
469This allows to enlarge the maximum recursion depth when instrumenting
470code.
471
435** Eshell 472** Eshell
436 473
437*** 'eshell-input-filter's value is now a named function 474*** 'eshell-input-filter's value is now a named function
@@ -594,6 +631,13 @@ HTML tags, classes and IDs using the 'completion-at-point' command.
594Completion candidates for HTML classes and IDs are retrieved from open 631Completion candidates for HTML classes and IDs are retrieved from open
595HTML mode buffers. 632HTML mode buffers.
596 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
597+++ 641+++
598** Emacs now supports character name escape sequences in character and 642** Emacs now supports character name escape sequences in character and
599string literals. The syntax variants \N{character name} and 643string literals. The syntax variants \N{character name} and
@@ -719,6 +763,13 @@ instead.
719 763
720* Lisp Changes in Emacs 26.1 764* Lisp Changes in Emacs 26.1
721 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.
722** New variable 'while-no-input-ignore-events' which allow 773** New variable 'while-no-input-ignore-events' which allow
723setting which special events 'while-no-input' should ignore. 774setting which special events 'while-no-input' should ignore.
724It is a list of symbols. 775It is a list of symbols.
@@ -778,6 +829,11 @@ of an arbitrary function. This generalizes 'subr-arity' for functions
778that are not built-in primitives. We recommend using this new 829that are not built-in primitives. We recommend using this new
779function instead of 'subr-arity'. 830function instead of 'subr-arity'.
780 831
832** New function 'region-bounds' can be used in the interactive spec
833to provide region boundaries (for rectangular regions more than one)
834to an interactively callable function as a single argument instead of
835two separate arguments region-beginning and region-end.
836
781+++ 837+++
782** 'parse-partial-sexp' state has a new element. Element 10 is 838** 'parse-partial-sexp' state has a new element. Element 10 is
783non-nil when the last character scanned might be the first character 839non-nil when the last character scanned might be the first character
@@ -838,6 +894,13 @@ ABBR is a time zone abbreviation. The affected functions are
838collection). 894collection).
839 895
840+++ 896+++
897** 'car' and 'cdr' compositions 'cXXXr' and 'cXXXXr' are now part of Elisp.
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
903+++
841** The new functions 'make-nearby-temp-file' and 'temporary-file-directory' 904** The new functions 'make-nearby-temp-file' and 'temporary-file-directory'
842can 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.
843 906
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/battery.el b/lisp/battery.el
index 71268e59ecd..b1834f06ff8 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -542,6 +542,9 @@ The following %-sequences are provided:
542 (t "N/A")))))) 542 (t "N/A"))))))
543 543
544 544
545(declare-function dbus-get-property "dbus.el"
546 (bus service path interface property))
547
545;;; `upowerd' interface. 548;;; `upowerd' interface.
546(defsubst battery-upower-prop (pname &optional device) 549(defsubst battery-upower-prop (pname &optional device)
547 (dbus-get-property 550 (dbus-get-property
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/calc/calc-misc.el b/lisp/calc/calc-misc.el
index 7b7a7208aaa..e6af0920639 100644
--- a/lisp/calc/calc-misc.el
+++ b/lisp/calc/calc-misc.el
@@ -623,7 +623,7 @@ loaded and the keystroke automatically re-typed."
623 (unwind-protect 623 (unwind-protect
624 (progn 624 (progn
625 (sit-for 2) 625 (sit-for 2)
626 (identity 1) ; this forces a call to QUIT; in bytecode.c. 626 (identity 1) ; This forces a call to maybe_quit in bytecode.c.
627 (setq okay t)) 627 (setq okay t))
628 (progn 628 (progn
629 (delete-region savemax (point-max)) 629 (delete-region savemax (point-max))
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-aux.el b/lisp/dired-aux.el
index cabcfcdbd3f..caa3b45705b 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -987,6 +987,8 @@ corresponding command.
987Within CMD, %i denotes the input file(s), and %o denotes the 987Within CMD, %i denotes the input file(s), and %o denotes the
988output file. %i path(s) are relative, while %o is absolute.") 988output file. %i path(s) are relative, while %o is absolute.")
989 989
990(declare-function format-spec "format-spec.el" (format specification))
991
990;;;###autoload 992;;;###autoload
991(defun dired-do-compress-to () 993(defun dired-do-compress-to ()
992 "Compress selected files and directories to an archive. 994 "Compress selected files and directories to an archive.
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/backquote.el b/lisp/emacs-lisp/backquote.el
index 94c561cba0a..bb877dd2c97 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/emacs-lisp/backquote.el
@@ -247,4 +247,14 @@ LEVEL is only used internally and indicates the nesting level:
247 tail)) 247 tail))
248 (t (cons 'list heads))))) 248 (t (cons 'list heads)))))
249 249
250
251;; Give `,' and `,@' documentation strings which can be examined by C-h f.
252(put '\, 'function-documentation
253 "See `\\=`' (also `pcase') for the usage of `,'.")
254(put '\, 'reader-construct t)
255
256(put '\,@ 'function-documentation
257 "See `\\=`' for the usage of `,@'.")
258(put '\,@ 'reader-construct t)
259
250;;; backquote.el ends here 260;;; backquote.el ends here
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 8d141d7a646..6cc70c4c2f5 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -226,7 +226,13 @@ DEFAULT-BODY, if present, is used as the body of a default method.
226 (when (eq 'setf (car-safe name)) 226 (when (eq 'setf (car-safe name))
227 (require 'gv) 227 (require 'gv)
228 (setq name (gv-setter (cadr name)))) 228 (setq name (gv-setter (cadr name))))
229 `(progn 229 `(prog1
230 (progn
231 (defalias ',name
232 (cl-generic-define ',name ',args ',(nreverse options))
233 ,(help-add-fundoc-usage doc args))
234 ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
235 (nreverse methods)))
230 ,@(mapcar (lambda (declaration) 236 ,@(mapcar (lambda (declaration)
231 (let ((f (cdr (assq (car declaration) 237 (let ((f (cdr (assq (car declaration)
232 defun-declarations-alist)))) 238 defun-declarations-alist))))
@@ -235,12 +241,7 @@ DEFAULT-BODY, if present, is used as the body of a default method.
235 (t (message "Warning: Unknown defun property `%S' in %S" 241 (t (message "Warning: Unknown defun property `%S' in %S"
236 (car declaration) name) 242 (car declaration) name)
237 nil)))) 243 nil))))
238 (cdr declarations)) 244 (cdr declarations)))))
239 (defalias ',name
240 (cl-generic-define ',name ',args ',(nreverse options))
241 ,(help-add-fundoc-usage doc args))
242 ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
243 (nreverse methods)))))
244 245
245;;;###autoload 246;;;###autoload
246(defun cl-generic-define (name args options) 247(defun cl-generic-define (name args options)
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index b1db07fe165..5aa8f1bf652 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -413,125 +413,30 @@ Signal an error if X is not a list."
413 (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store)))) 413 (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store))))
414 (nth 9 x)) 414 (nth 9 x))
415 415
416(defun cl-caaar (x) 416(defalias 'cl-caaar 'caaar)
417 "Return the `car' of the `car' of the `car' of X." 417(defalias 'cl-caadr 'caadr)
418 (declare (compiler-macro internal--compiler-macro-cXXr)) 418(defalias 'cl-cadar 'cadar)
419 (car (car (car x)))) 419(defalias 'cl-caddr 'caddr)
420 420(defalias 'cl-cdaar 'cdaar)
421(defun cl-caadr (x) 421(defalias 'cl-cdadr 'cdadr)
422 "Return the `car' of the `car' of the `cdr' of X." 422(defalias 'cl-cddar 'cddar)
423 (declare (compiler-macro internal--compiler-macro-cXXr)) 423(defalias 'cl-cdddr 'cdddr)
424 (car (car (cdr x)))) 424(defalias 'cl-caaaar 'caaaar)
425 425(defalias 'cl-caaadr 'caaadr)
426(defun cl-cadar (x) 426(defalias 'cl-caadar 'caadar)
427 "Return the `car' of the `cdr' of the `car' of X." 427(defalias 'cl-caaddr 'caaddr)
428 (declare (compiler-macro internal--compiler-macro-cXXr)) 428(defalias 'cl-cadaar 'cadaar)
429 (car (cdr (car x)))) 429(defalias 'cl-cadadr 'cadadr)
430 430(defalias 'cl-caddar 'caddar)
431(defun cl-caddr (x) 431(defalias 'cl-cadddr 'cadddr)
432 "Return the `car' of the `cdr' of the `cdr' of X." 432(defalias 'cl-cdaaar 'cdaaar)
433 (declare (compiler-macro internal--compiler-macro-cXXr)) 433(defalias 'cl-cdaadr 'cdaadr)
434 (car (cdr (cdr x)))) 434(defalias 'cl-cdadar 'cdadar)
435 435(defalias 'cl-cdaddr 'cdaddr)
436(defun cl-cdaar (x) 436(defalias 'cl-cddaar 'cddaar)
437 "Return the `cdr' of the `car' of the `car' of X." 437(defalias 'cl-cddadr 'cddadr)
438 (declare (compiler-macro internal--compiler-macro-cXXr)) 438(defalias 'cl-cdddar 'cdddar)
439 (cdr (car (car x)))) 439(defalias 'cl-cddddr 'cddddr)
440
441(defun cl-cdadr (x)
442 "Return the `cdr' of the `car' of the `cdr' of X."
443 (declare (compiler-macro internal--compiler-macro-cXXr))
444 (cdr (car (cdr x))))
445
446(defun cl-cddar (x)
447 "Return the `cdr' of the `cdr' of the `car' of X."
448 (declare (compiler-macro internal--compiler-macro-cXXr))
449 (cdr (cdr (car x))))
450
451(defun cl-cdddr (x)
452 "Return the `cdr' of the `cdr' of the `cdr' of X."
453 (declare (compiler-macro internal--compiler-macro-cXXr))
454 (cdr (cdr (cdr x))))
455
456(defun cl-caaaar (x)
457 "Return the `car' of the `car' of the `car' of the `car' of X."
458 (declare (compiler-macro internal--compiler-macro-cXXr))
459 (car (car (car (car x)))))
460
461(defun cl-caaadr (x)
462 "Return the `car' of the `car' of the `car' of the `cdr' of X."
463 (declare (compiler-macro internal--compiler-macro-cXXr))
464 (car (car (car (cdr x)))))
465
466(defun cl-caadar (x)
467 "Return the `car' of the `car' of the `cdr' of the `car' of X."
468 (declare (compiler-macro internal--compiler-macro-cXXr))
469 (car (car (cdr (car x)))))
470
471(defun cl-caaddr (x)
472 "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
473 (declare (compiler-macro internal--compiler-macro-cXXr))
474 (car (car (cdr (cdr x)))))
475
476(defun cl-cadaar (x)
477 "Return the `car' of the `cdr' of the `car' of the `car' of X."
478 (declare (compiler-macro internal--compiler-macro-cXXr))
479 (car (cdr (car (car x)))))
480
481(defun cl-cadadr (x)
482 "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
483 (declare (compiler-macro internal--compiler-macro-cXXr))
484 (car (cdr (car (cdr x)))))
485
486(defun cl-caddar (x)
487 "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
488 (declare (compiler-macro internal--compiler-macro-cXXr))
489 (car (cdr (cdr (car x)))))
490
491(defun cl-cadddr (x)
492 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
493 (declare (compiler-macro internal--compiler-macro-cXXr))
494 (car (cdr (cdr (cdr x)))))
495
496(defun cl-cdaaar (x)
497 "Return the `cdr' of the `car' of the `car' of the `car' of X."
498 (declare (compiler-macro internal--compiler-macro-cXXr))
499 (cdr (car (car (car x)))))
500
501(defun cl-cdaadr (x)
502 "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
503 (declare (compiler-macro internal--compiler-macro-cXXr))
504 (cdr (car (car (cdr x)))))
505
506(defun cl-cdadar (x)
507 "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
508 (declare (compiler-macro internal--compiler-macro-cXXr))
509 (cdr (car (cdr (car x)))))
510
511(defun cl-cdaddr (x)
512 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
513 (declare (compiler-macro internal--compiler-macro-cXXr))
514 (cdr (car (cdr (cdr x)))))
515
516(defun cl-cddaar (x)
517 "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
518 (declare (compiler-macro internal--compiler-macro-cXXr))
519 (cdr (cdr (car (car x)))))
520
521(defun cl-cddadr (x)
522 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
523 (declare (compiler-macro internal--compiler-macro-cXXr))
524 (cdr (cdr (car (cdr x)))))
525
526(defun cl-cdddar (x)
527 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
528 (declare (compiler-macro internal--compiler-macro-cXXr))
529 (cdr (cdr (cdr (car x)))))
530
531(defun cl-cddddr (x)
532 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
533 (declare (compiler-macro internal--compiler-macro-cXXr))
534 (cdr (cdr (cdr (cdr x)))))
535 440
536;;(defun last* (x &optional n) 441;;(defun last* (x &optional n)
537;; "Returns the last link in the list LIST. 442;; "Returns the last link in the list LIST.
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el
index e33a603d1b0..73eb9a4e866 100644
--- a/lisp/emacs-lisp/cl.el
+++ b/lisp/emacs-lisp/cl.el
@@ -258,30 +258,6 @@
258 copy-list 258 copy-list
259 ldiff 259 ldiff
260 list* 260 list*
261 cddddr
262 cdddar
263 cddadr
264 cddaar
265 cdaddr
266 cdadar
267 cdaadr
268 cdaaar
269 cadddr
270 caddar
271 cadadr
272 cadaar
273 caaddr
274 caadar
275 caaadr
276 caaaar
277 cdddr
278 cddar
279 cdadr
280 cdaar
281 caddr
282 cadar
283 caadr
284 caaar
285 tenth 261 tenth
286 ninth 262 ninth
287 eighth 263 eighth
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/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index eadf79ffd4f..b6b49b1bfa2 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -412,8 +412,13 @@ of column descriptors."
412 (inhibit-read-only t)) 412 (inhibit-read-only t))
413 (if (> tabulated-list-padding 0) 413 (if (> tabulated-list-padding 0)
414 (insert (make-string x ?\s))) 414 (insert (make-string x ?\s)))
415 (dotimes (n ncols) 415 (let ((tabulated-list--near-rows ; Bind it if not bound yet (Bug#25506).
416 (setq x (tabulated-list-print-col n (aref cols n) x))) 416 (or (bound-and-true-p tabulated-list--near-rows)
417 (list (or (tabulated-list-get-entry (point-at-bol 0))
418 cols)
419 cols))))
420 (dotimes (n ncols)
421 (setq x (tabulated-list-print-col n (aref cols n) x))))
417 (insert ?\n) 422 (insert ?\n)
418 ;; Ever so slightly faster than calling `put-text-property' twice. 423 ;; Ever so slightly faster than calling `put-text-property' twice.
419 (add-text-properties 424 (add-text-properties
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 f60282b775a..b7d104853c3 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -3723,7 +3723,8 @@ Return the new variables list."
3723 (let* ((file-name (or (buffer-file-name) 3723 (let* ((file-name (or (buffer-file-name)
3724 ;; Handle non-file buffers, too. 3724 ;; Handle non-file buffers, too.
3725 (expand-file-name default-directory))) 3725 (expand-file-name default-directory)))
3726 (sub-file-name (if file-name 3726 (sub-file-name (if (and file-name
3727 (file-name-absolute-p file-name))
3727 ;; FIXME: Why not use file-relative-name? 3728 ;; FIXME: Why not use file-relative-name?
3728 (substring file-name (length root))))) 3729 (substring file-name (length root)))))
3729 (condition-case err 3730 (condition-case err
@@ -5133,6 +5134,14 @@ Before and after saving the buffer, this function runs
5133 "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.")
5134(make-variable-buffer-local 'buffer-save-without-query) 5135(make-variable-buffer-local 'buffer-save-without-query)
5135 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
5136(defun save-some-buffers (&optional arg pred) 5145(defun save-some-buffers (&optional arg pred)
5137 "Save some modified file-visiting buffers. Asks user about each one. 5146 "Save some modified file-visiting buffers. Asks user about each one.
5138You 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
@@ -5148,10 +5157,13 @@ If PRED is nil, all the file-visiting buffers are considered.
5148If 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.
5149If 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
5150to 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'.
5151 5161
5152See `save-some-buffers-action-alist' if you want to 5162See `save-some-buffers-action-alist' if you want to
5153change the additional actions you can take on files." 5163change the additional actions you can take on files."
5154 (interactive "P") 5164 (interactive "P")
5165 (unless pred
5166 (setq pred save-some-buffers-default-predicate))
5155 (save-window-excursion 5167 (save-window-excursion
5156 (let* (queried autosaved-buffers 5168 (let* (queried autosaved-buffers
5157 files-done abbrevs-done) 5169 files-done abbrevs-done)
@@ -6571,7 +6583,7 @@ normally equivalent short `-D' option is just passed on to
6571 (unless (equal switches "") 6583 (unless (equal switches "")
6572 ;; Split the switches at any spaces so we can 6584 ;; Split the switches at any spaces so we can
6573 ;; pass separate options as separate args. 6585 ;; pass separate options as separate args.
6574 (split-string switches))) 6586 (split-string-and-unquote switches)))
6575 ;; Avoid lossage if FILE starts with `-'. 6587 ;; Avoid lossage if FILE starts with `-'.
6576 '("--") 6588 '("--")
6577 (progn 6589 (progn
@@ -6811,6 +6823,8 @@ asks whether processes should be killed.
6811Runs the members of `kill-emacs-query-functions' in turn and stops 6823Runs the members of `kill-emacs-query-functions' in turn and stops
6812if 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."
6813 (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.
6814 (save-some-buffers arg t) 6828 (save-some-buffers arg t)
6815 (let ((confirm confirm-kill-emacs)) 6829 (let ((confirm confirm-kill-emacs))
6816 (and 6830 (and
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index e1af859516c..a4ff840f755 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -251,7 +251,12 @@ This can also be a list of the above values."
251 (integer :value 200) 251 (integer :value 200)
252 (number :value 4.0) 252 (number :value 4.0)
253 function 253 function
254 (regexp :value ".*")) 254 (regexp :value ".*")
255 (repeat (choice (const nil)
256 (integer :value 200)
257 (number :value 4.0)
258 function
259 (regexp :value ".*"))))
255 :group 'gnus-article-signature) 260 :group 'gnus-article-signature)
256 261
257(defcustom gnus-hidden-properties 262(defcustom gnus-hidden-properties
@@ -1708,9 +1713,10 @@ regexp."
1708 ;; (modify-syntax-entry ?- "w" table) 1713 ;; (modify-syntax-entry ?- "w" table)
1709 (modify-syntax-entry ?> ")<" table) 1714 (modify-syntax-entry ?> ")<" table)
1710 (modify-syntax-entry ?< "(>" table) 1715 (modify-syntax-entry ?< "(>" table)
1711 ;; make M-. in article buffers work for `foo' strings 1716 ;; make M-. in article buffers work for `foo' strings,
1712 (modify-syntax-entry ?' " " table) 1717 ;; and still allow C-s C-w to yank ' to the search ring
1713 (modify-syntax-entry ?` " " table) 1718 (modify-syntax-entry ?' "'" table)
1719 (modify-syntax-entry ?` "'" table)
1714 table) 1720 table)
1715 "Syntax table used in article mode buffers. 1721 "Syntax table used in article mode buffers.
1716Initialized from `text-mode-syntax-table'.") 1722Initialized from `text-mode-syntax-table'.")
@@ -6841,17 +6847,21 @@ then we display only bindings that start with that prefix."
6841 (let ((keymap (copy-keymap gnus-article-mode-map)) 6847 (let ((keymap (copy-keymap gnus-article-mode-map))
6842 (map (copy-keymap gnus-article-send-map)) 6848 (map (copy-keymap gnus-article-send-map))
6843 (sumkeys (where-is-internal 'gnus-article-read-summary-keys)) 6849 (sumkeys (where-is-internal 'gnus-article-read-summary-keys))
6850 (summap (make-sparse-keymap))
6844 parent agent draft) 6851 parent agent draft)
6845 (define-key keymap "S" map) 6852 (define-key keymap "S" map)
6846 (define-key map [t] nil) 6853 (define-key map [t] nil)
6854 (define-key summap [t] 'undefined)
6847 (with-current-buffer gnus-article-current-summary 6855 (with-current-buffer gnus-article-current-summary
6856 (dolist (key sumkeys)
6857 (define-key summap key (key-binding key (current-local-map))))
6848 (set-keymap-parent 6858 (set-keymap-parent
6849 keymap 6859 keymap
6850 (if (setq parent (keymap-parent gnus-article-mode-map)) 6860 (if (setq parent (keymap-parent gnus-article-mode-map))
6851 (prog1 6861 (prog1
6852 (setq parent (copy-keymap parent)) 6862 (setq parent (copy-keymap parent))
6853 (set-keymap-parent parent (current-local-map))) 6863 (set-keymap-parent parent summap))
6854 (current-local-map))) 6864 summap))
6855 (set-keymap-parent map (key-binding "S")) 6865 (set-keymap-parent map (key-binding "S"))
6856 (let (key def gnus-pick-mode) 6866 (let (key def gnus-pick-mode)
6857 (while sumkeys 6867 (while sumkeys
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index 19111171198..a193ab41348 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -546,7 +546,8 @@ instead."
546 (gnus-setup-message 'message 546 (gnus-setup-message 'message
547 (message-mail to subject other-headers continue 547 (message-mail to subject other-headers continue
548 nil yank-action send-actions return-action))) 548 nil yank-action send-actions return-action)))
549 (setq gnus-newsgroup-name group-name)) 549 (with-current-buffer buf
550 (setq gnus-newsgroup-name group-name)))
550 (when switch-action 551 (when switch-action
551 (setq mail-buf (current-buffer)) 552 (setq mail-buf (current-buffer))
552 (switch-to-buffer buf) 553 (switch-to-buffer buf)
@@ -1534,11 +1535,7 @@ If YANK is non-nil, include the original article."
1534 (message-pop-to-buffer "*Gnus Bug*")) 1535 (message-pop-to-buffer "*Gnus Bug*"))
1535 (let ((message-this-is-mail t)) 1536 (let ((message-this-is-mail t))
1536 (message-setup `((To . ,gnus-maintainer) 1537 (message-setup `((To . ,gnus-maintainer)
1537 (Subject . "") 1538 (Subject . ""))))
1538 (X-Debbugs-Package
1539 . ,(format "%s" gnus-bug-package))
1540 (X-Debbugs-Version
1541 . ,(format "%s" (gnus-continuum-version))))))
1542 (when gnus-bug-create-help-buffer 1539 (when gnus-bug-create-help-buffer
1543 (push `(gnus-bug-kill-buffer) message-send-actions)) 1540 (push `(gnus-bug-kill-buffer) message-send-actions))
1544 (goto-char (point-min)) 1541 (goto-char (point-min))
diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el
index 5361c2b86fc..7037328b7a4 100644
--- a/lisp/gnus/gnus-salt.el
+++ b/lisp/gnus/gnus-salt.el
@@ -131,9 +131,7 @@ It accepts the same format specs that `gnus-summary-line-format' does."
131(defvar gnus-pick-line-number 1) 131(defvar gnus-pick-line-number 1)
132(defun gnus-pick-line-number () 132(defun gnus-pick-line-number ()
133 "Return the current line number." 133 "Return the current line number."
134 (if (bobp) 134 (incf gnus-pick-line-number))
135 (setq gnus-pick-line-number 1)
136 (incf gnus-pick-line-number)))
137 135
138(defun gnus-pick-start-reading (&optional catch-up) 136(defun gnus-pick-start-reading (&optional catch-up)
139 "Start reading the picked articles. 137 "Start reading the picked articles.
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index 47e33af96e8..be46339cd38 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -2801,8 +2801,13 @@ If FORCE is non-nil, the .newsrc file is read."
2801 (gnus-run-hooks 'gnus-save-newsrc-hook) 2801 (gnus-run-hooks 'gnus-save-newsrc-hook)
2802 (if gnus-slave 2802 (if gnus-slave
2803 (gnus-slave-save-newsrc) 2803 (gnus-slave-save-newsrc)
2804 ;; Save .newsrc. 2804 ;; Save .newsrc only if the select method is an NNTP method.
2805 (when gnus-save-newsrc-file 2805 ;; The .newsrc file is for interoperability with other
2806 ;; newsreaders, so saving non-NNTP groups there doesn't make
2807 ;; much sense.
2808 (when (and gnus-save-newsrc-file
2809 (eq (car (gnus-server-to-method gnus-select-method))
2810 'nntp))
2806 (gnus-message 8 "Saving %s..." gnus-current-startup-file) 2811 (gnus-message 8 "Saving %s..." gnus-current-startup-file)
2807 (gnus-gnus-to-newsrc-format) 2812 (gnus-gnus-to-newsrc-format)
2808 (gnus-message 8 "Saving %s...done" gnus-current-startup-file)) 2813 (gnus-message 8 "Saving %s...done" gnus-current-startup-file))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 72e902a11f8..2631514e425 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -1895,6 +1895,7 @@ increase the score of each group you read."
1895 "\C-c\C-s\C-m\C-n" gnus-summary-sort-by-most-recent-number 1895 "\C-c\C-s\C-m\C-n" gnus-summary-sort-by-most-recent-number
1896 "\C-c\C-s\C-l" gnus-summary-sort-by-lines 1896 "\C-c\C-s\C-l" gnus-summary-sort-by-lines
1897 "\C-c\C-s\C-c" gnus-summary-sort-by-chars 1897 "\C-c\C-s\C-c" gnus-summary-sort-by-chars
1898 "\C-c\C-s\C-m\C-m" gnus-summary-sort-by-marks
1898 "\C-c\C-s\C-a" gnus-summary-sort-by-author 1899 "\C-c\C-s\C-a" gnus-summary-sort-by-author
1899 "\C-c\C-s\C-t" gnus-summary-sort-by-recipient 1900 "\C-c\C-s\C-t" gnus-summary-sort-by-recipient
1900 "\C-c\C-s\C-s" gnus-summary-sort-by-subject 1901 "\C-c\C-s\C-s" gnus-summary-sort-by-subject
@@ -2748,6 +2749,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
2748 ["Sort by score" gnus-summary-sort-by-score t] 2749 ["Sort by score" gnus-summary-sort-by-score t]
2749 ["Sort by lines" gnus-summary-sort-by-lines t] 2750 ["Sort by lines" gnus-summary-sort-by-lines t]
2750 ["Sort by characters" gnus-summary-sort-by-chars t] 2751 ["Sort by characters" gnus-summary-sort-by-chars t]
2752 ["Sort by marks" gnus-summary-sort-by-marks t]
2751 ["Randomize" gnus-summary-sort-by-random t] 2753 ["Randomize" gnus-summary-sort-by-random t]
2752 ["Original sort" gnus-summary-sort-by-original t]) 2754 ["Original sort" gnus-summary-sort-by-original t])
2753 ("Help" 2755 ("Help"
@@ -3976,6 +3978,8 @@ If SELECT-ARTICLES, only select those articles from GROUP."
3976 ;; The group was successfully selected. 3978 ;; The group was successfully selected.
3977 (t 3979 (t
3978 (gnus-set-global-variables) 3980 (gnus-set-global-variables)
3981 (when (boundp 'gnus-pick-line-number)
3982 (setq gnus-pick-line-number 0))
3979 (when (boundp 'spam-install-hooks) 3983 (when (boundp 'spam-install-hooks)
3980 (spam-initialize)) 3984 (spam-initialize))
3981 ;; Save the active value in effect when the group was entered. 3985 ;; Save the active value in effect when the group was entered.
@@ -4037,6 +4041,9 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4037 (when kill-buffer 4041 (when kill-buffer
4038 (gnus-kill-or-deaden-summary kill-buffer)) 4042 (gnus-kill-or-deaden-summary kill-buffer))
4039 (gnus-summary-auto-select-subject) 4043 (gnus-summary-auto-select-subject)
4044 ;; Don't mark any articles as selected if we haven't done that.
4045 (when no-article
4046 (setq overlay-arrow-position nil))
4040 ;; Show first unread article if requested. 4047 ;; Show first unread article if requested.
4041 (if (and (not no-article) 4048 (if (and (not no-article)
4042 (not no-display) 4049 (not no-display)
@@ -4941,6 +4948,16 @@ using some other form will lead to serious barfage."
4941 (gnus-article-sort-by-chars 4948 (gnus-article-sort-by-chars
4942 (gnus-thread-header h1) (gnus-thread-header h2))) 4949 (gnus-thread-header h1) (gnus-thread-header h2)))
4943 4950
4951(defsubst gnus-article-sort-by-marks (h1 h2)
4952 "Sort articles by octet length."
4953 (< (gnus-article-mark (mail-header-number h1))
4954 (gnus-article-mark (mail-header-number h2))))
4955
4956(defun gnus-thread-sort-by-marks (h1 h2)
4957 "Sort threads by root article octet length."
4958 (gnus-article-sort-by-marks
4959 (gnus-thread-header h1) (gnus-thread-header h2)))
4960
4944(defsubst gnus-article-sort-by-author (h1 h2) 4961(defsubst gnus-article-sort-by-author (h1 h2)
4945 "Sort articles by root author." 4962 "Sort articles by root author."
4946 (gnus-string< 4963 (gnus-string<
@@ -11925,6 +11942,12 @@ Argument REVERSE means reverse order."
11925 (interactive "P") 11942 (interactive "P")
11926 (gnus-summary-sort 'chars reverse)) 11943 (gnus-summary-sort 'chars reverse))
11927 11944
11945(defun gnus-summary-sort-by-mark (&optional reverse)
11946 "Sort the summary buffer by article marks.
11947Argument REVERSE means reverse order."
11948 (interactive "P")
11949 (gnus-summary-sort 'marks reverse))
11950
11928(defun gnus-summary-sort-by-original (&optional reverse) 11951(defun gnus-summary-sort-by-original (&optional reverse)
11929 "Sort the summary buffer using the default sorting method. 11952 "Sort the summary buffer using the default sorting method.
11930Argument REVERSE means reverse order." 11953Argument REVERSE means reverse order."
@@ -11970,7 +11993,10 @@ save those articles instead.
11970The variable `gnus-default-article-saver' specifies the saver function. 11993The variable `gnus-default-article-saver' specifies the saver function.
11971 11994
11972If the optional second argument NOT-SAVED is non-nil, articles saved 11995If the optional second argument NOT-SAVED is non-nil, articles saved
11973will not be marked as saved." 11996will not be marked as saved.
11997
11998The `gnus-prompt-before-saving' variable says how prompting is
11999performed."
11974 (interactive "P") 12000 (interactive "P")
11975 (require 'gnus-art) 12001 (require 'gnus-art)
11976 (let* ((articles (gnus-summary-work-articles n)) 12002 (let* ((articles (gnus-summary-work-articles n))
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index 8ab8f462885..6d6e20dc129 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -1564,7 +1564,7 @@ If UNINDENT, remove an indentation."
1564 (parent (gnus-topic-parent-topic topic)) 1564 (parent (gnus-topic-parent-topic topic))
1565 (grandparent (gnus-topic-parent-topic parent))) 1565 (grandparent (gnus-topic-parent-topic parent)))
1566 (unless grandparent 1566 (unless grandparent
1567 (error "Nothing to indent %s into" topic)) 1567 (error "Can't unindent %s further" topic))
1568 (when topic 1568 (when topic
1569 (gnus-topic-goto-topic topic) 1569 (gnus-topic-goto-topic topic)
1570 (gnus-topic-kill-group) 1570 (gnus-topic-kill-group)
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index ef6bd89c36e..bbf85fe584a 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -2654,10 +2654,6 @@ such as a mark that says whether an article is stored in the cache
2654 "submit@debbugs.gnu.org (The Gnus Bugfixing Girls + Boys)" 2654 "submit@debbugs.gnu.org (The Gnus Bugfixing Girls + Boys)"
2655 "The mail address of the Gnus maintainers.") 2655 "The mail address of the Gnus maintainers.")
2656 2656
2657(defconst gnus-bug-package
2658 "gnus"
2659 "The package to use in the bug submission.")
2660
2661(defvar gnus-info-nodes 2657(defvar gnus-info-nodes
2662 '((gnus-group-mode "(gnus)Group Buffer") 2658 '((gnus-group-mode "(gnus)Group Buffer")
2663 (gnus-summary-mode "(gnus)Summary Buffer") 2659 (gnus-summary-mode "(gnus)Summary Buffer")
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 4d4ba089434..ce0dad9cb05 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -2286,13 +2286,15 @@ body, set `message-archive-note' to nil."
2286 "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP. 2286 "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
2287With prefix-argument just set Follow-Up, don't cross-post." 2287With prefix-argument just set Follow-Up, don't cross-post."
2288 (interactive 2288 (interactive
2289 (list ; Completion based on Gnus 2289 (list ; Completion based on Gnus
2290 (completing-read "Followup To: " 2290 (replace-regexp-in-string
2291 (if (boundp 'gnus-newsrc-alist) 2291 "\\`.*:" ""
2292 gnus-newsrc-alist) 2292 (completing-read "Followup To: "
2293 nil nil '("poster" . 0) 2293 (if (boundp 'gnus-newsrc-alist)
2294 (if (boundp 'gnus-group-history) 2294 gnus-newsrc-alist)
2295 'gnus-group-history)))) 2295 nil nil '("poster" . 0)
2296 (if (boundp 'gnus-group-history)
2297 'gnus-group-history)))))
2296 (message-remove-header "Follow[Uu]p-[Tt]o" t) 2298 (message-remove-header "Follow[Uu]p-[Tt]o" t)
2297 (message-goto-newsgroups) 2299 (message-goto-newsgroups)
2298 (beginning-of-line) 2300 (beginning-of-line)
@@ -2361,13 +2363,15 @@ been made to before the user asked for a Crosspost."
2361 "Crossposts message and set Followup-To to TARGET-GROUP. 2363 "Crossposts message and set Followup-To to TARGET-GROUP.
2362With prefix-argument just set Follow-Up, don't cross-post." 2364With prefix-argument just set Follow-Up, don't cross-post."
2363 (interactive 2365 (interactive
2364 (list ; Completion based on Gnus 2366 (list ; Completion based on Gnus
2365 (completing-read "Followup To: " 2367 (replace-regexp-in-string
2366 (if (boundp 'gnus-newsrc-alist) 2368 "\\`.*:" ""
2367 gnus-newsrc-alist) 2369 (completing-read "Followup To: "
2368 nil nil '("poster" . 0) 2370 (if (boundp 'gnus-newsrc-alist)
2369 (if (boundp 'gnus-group-history) 2371 gnus-newsrc-alist)
2370 'gnus-group-history)))) 2372 nil nil '("poster" . 0)
2373 (if (boundp 'gnus-group-history)
2374 'gnus-group-history)))))
2371 (when (fboundp 'gnus-group-real-name) 2375 (when (fboundp 'gnus-group-real-name)
2372 (setq target-group (gnus-group-real-name target-group))) 2376 (setq target-group (gnus-group-real-name target-group)))
2373 (cond ((not (or (null target-group) ; new subject not empty 2377 (cond ((not (or (null target-group) ; new subject not empty
@@ -3108,18 +3112,29 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
3108 (looking-at "[ \t]*\n")) 3112 (looking-at "[ \t]*\n"))
3109 (expand-abbrev)) 3113 (expand-abbrev))
3110 (push-mark) 3114 (push-mark)
3115 (message-goto-body-1))
3116
3117(defun message-goto-body-1 ()
3118 "Go to the body and return point."
3111 (goto-char (point-min)) 3119 (goto-char (point-min))
3112 (or (search-forward (concat "\n" mail-header-separator "\n") nil t) 3120 (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
3113 (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) 3121 ;; If the message is mangled, find the end of the headers the
3122 ;; hard way.
3123 (progn
3124 ;; Skip past all headers and continuation lines.
3125 (while (looking-at "[^:]+:\\|[\t ]+[^\t ]")
3126 (forward-line 1))
3127 ;; We're now at the first empty line, so perhaps move past it.
3128 (when (and (eolp)
3129 (not (eobp)))
3130 (forward-line 1))
3131 (point))))
3114 3132
3115(defun message-in-body-p () 3133(defun message-in-body-p ()
3116 "Return t if point is in the message body." 3134 "Return t if point is in the message body."
3117 (>= (point) 3135 (>= (point)
3118 (save-excursion 3136 (save-excursion
3119 (goto-char (point-min)) 3137 (message-goto-body-1))))
3120 (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
3121 (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))
3122 (point))))
3123 3138
3124(defun message-goto-eoh () 3139(defun message-goto-eoh ()
3125 "Move point to the end of the headers." 3140 "Move point to the end of the headers."
@@ -3330,6 +3345,8 @@ of lines before the signature intact."
3330 "Insert four newlines, and then reformat if inside quoted text. 3345 "Insert four newlines, and then reformat if inside quoted text.
3331Prefix arg means justify as well." 3346Prefix arg means justify as well."
3332 (interactive (list (if current-prefix-arg 'full))) 3347 (interactive (list (if current-prefix-arg 'full)))
3348 (unless (message-in-body-p)
3349 (error "This command only works in the body of the message"))
3333 (let (quoted point beg end leading-space bolp fill-paragraph-function) 3350 (let (quoted point beg end leading-space bolp fill-paragraph-function)
3334 (setq point (point)) 3351 (setq point (point))
3335 (beginning-of-line) 3352 (beginning-of-line)
@@ -4102,8 +4119,8 @@ It should typically alter the sending method in some way or other."
4102 (let ((inhibit-read-only t)) 4119 (let ((inhibit-read-only t))
4103 (put-text-property (point-min) (point-max) 'read-only nil)) 4120 (put-text-property (point-min) (point-max) 'read-only nil))
4104 (message-fix-before-sending) 4121 (message-fix-before-sending)
4105 (mml-secure-bcc-is-safe)
4106 (run-hooks 'message-send-hook) 4122 (run-hooks 'message-send-hook)
4123 (mml-secure-bcc-is-safe)
4107 (when message-confirm-send 4124 (when message-confirm-send
4108 (or (y-or-n-p "Send message? ") 4125 (or (y-or-n-p "Send message? ")
4109 (keyboard-quit))) 4126 (keyboard-quit)))
@@ -4539,6 +4556,9 @@ This function could be useful in `message-setup-hook'."
4539 (forward-line 1) 4556 (forward-line 1)
4540 (unless (y-or-n-p "Send anyway? ") 4557 (unless (y-or-n-p "Send anyway? ")
4541 (error "Failed to send the message"))))) 4558 (error "Failed to send the message")))))
4559 ;; Fold too-long header lines. They should be no longer than
4560 ;; 998 octets long.
4561 (message--fold-long-headers)
4542 ;; Let the user do all of the above. 4562 ;; Let the user do all of the above.
4543 (run-hooks 'message-header-hook)) 4563 (run-hooks 'message-header-hook))
4544 (setq options message-options) 4564 (setq options message-options)
@@ -4635,6 +4655,14 @@ If you always want Gnus to send messages in one piece, set
4635 (setq message-options options) 4655 (setq message-options options)
4636 (push 'mail message-sent-message-via))) 4656 (push 'mail message-sent-message-via)))
4637 4657
4658(defun message--fold-long-headers ()
4659 (goto-char (point-min))
4660 (while (not (eobp))
4661 (when (and (looking-at "[^:]+:")
4662 (> (- (line-end-position) (point)) 998))
4663 (mail-header-fold-field))
4664 (forward-line 1)))
4665
4638(defvar sendmail-program) 4666(defvar sendmail-program)
4639(defvar smtpmail-smtp-server) 4667(defvar smtpmail-smtp-server)
4640(defvar smtpmail-smtp-service) 4668(defvar smtpmail-smtp-service)
@@ -5380,16 +5408,13 @@ Otherwise, generate and save a value for `canlock-password' first."
5380 "Process Fcc headers in the current buffer." 5408 "Process Fcc headers in the current buffer."
5381 (let ((case-fold-search t) 5409 (let ((case-fold-search t)
5382 (buf (current-buffer)) 5410 (buf (current-buffer))
5383 list file 5411 (mml-externalize-attachments message-fcc-externalize-attachments)
5384 (mml-externalize-attachments message-fcc-externalize-attachments)) 5412 (file (message-field-value "fcc" t))
5385 (save-excursion 5413 list)
5386 (save-restriction 5414 (when file
5387 (message-narrow-to-headers) 5415 (with-temp-buffer
5388 (setq file (message-fetch-field "fcc" t)))
5389 (when file
5390 (set-buffer (get-buffer-create " *message temp*"))
5391 (erase-buffer)
5392 (insert-buffer-substring buf) 5416 (insert-buffer-substring buf)
5417 (message-clone-locals buf)
5393 (message-encode-message-body) 5418 (message-encode-message-body)
5394 (save-restriction 5419 (save-restriction
5395 (message-narrow-to-headers) 5420 (message-narrow-to-headers)
@@ -5429,8 +5454,7 @@ Otherwise, generate and save a value for `canlock-password' first."
5429 (if (and (file-readable-p file) (mail-file-babyl-p file)) 5454 (if (and (file-readable-p file) (mail-file-babyl-p file))
5430 (rmail-output file 1 nil t) 5455 (rmail-output file 1 nil t)
5431 (let ((mail-use-rfc822 t)) 5456 (let ((mail-use-rfc822 t))
5432 (rmail-output file 1 t t)))))) 5457 (rmail-output file 1 t t))))))))))
5433 (kill-buffer (current-buffer))))))
5434 5458
5435(defun message-output (filename) 5459(defun message-output (filename)
5436 "Append this article to Unix/babyl mail file FILENAME." 5460 "Append this article to Unix/babyl mail file FILENAME."
@@ -5761,7 +5785,7 @@ give as trustworthy answer as possible."
5761 (not (string-match message-bogus-system-names message-user-fqdn))) 5785 (not (string-match message-bogus-system-names message-user-fqdn)))
5762 ;; `message-user-fqdn' seems to be valid 5786 ;; `message-user-fqdn' seems to be valid
5763 message-user-fqdn) 5787 message-user-fqdn)
5764 ((and (string-match message-bogus-system-names sysname)) 5788 ((not (string-match message-bogus-system-names sysname))
5765 ;; `system-name' returned the right result. 5789 ;; `system-name' returned the right result.
5766 sysname) 5790 sysname)
5767 ;; Try `mail-host-address'. 5791 ;; Try `mail-host-address'.
@@ -6644,29 +6668,27 @@ OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether
6644to continue editing a message already being composed. SWITCH-FUNCTION 6668to continue editing a message already being composed. SWITCH-FUNCTION
6645is a function used to switch to and display the mail buffer." 6669is a function used to switch to and display the mail buffer."
6646 (interactive) 6670 (interactive)
6647 (let ((message-this-is-mail t)) 6671 (let ((message-this-is-mail t)
6648 (unless (message-mail-user-agent) 6672 message-buffers)
6649 (message-pop-to-buffer 6673 ;; Search for the existing message buffer if `continue' is non-nil.
6650 ;; Search for the existing message buffer if `continue' is non-nil. 6674 (if (and continue
6651 (let ((message-generate-new-buffers 6675 (setq message-buffers (message-buffers)))
6652 (when (or (not continue) 6676 (pop-to-buffer (car message-buffers))
6653 (eq message-generate-new-buffers 'standard) 6677 ;; Start a new buffer.
6654 (functionp message-generate-new-buffers)) 6678 (unless (message-mail-user-agent)
6655 message-generate-new-buffers))) 6679 (message-pop-to-buffer (message-buffer-name "mail" to) switch-function))
6656 (message-buffer-name "mail" to)) 6680 (message-setup
6657 switch-function)) 6681 (nconc
6658 (message-setup 6682 `((To . ,(or to "")) (Subject . ,(or subject "")))
6659 (nconc 6683 ;; C-h f compose-mail says that headers should be specified as
6660 `((To . ,(or to "")) (Subject . ,(or subject ""))) 6684 ;; (string . value); however all the rest of message expects
6661 ;; C-h f compose-mail says that headers should be specified as 6685 ;; headers to be symbols, not strings (eg message-header-format-alist).
6662 ;; (string . value); however all the rest of message expects 6686 ;; http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg00337.html
6663 ;; headers to be symbols, not strings (eg message-header-format-alist). 6687 ;; We need to convert any string input, eg from rmail-start-mail.
6664 ;; http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg00337.html 6688 (dolist (h other-headers other-headers)
6665 ;; We need to convert any string input, eg from rmail-start-mail. 6689 (if (stringp (car h)) (setcar h (intern (capitalize (car h)))))))
6666 (dolist (h other-headers other-headers) 6690 yank-action send-actions continue switch-function
6667 (if (stringp (car h)) (setcar h (intern (capitalize (car h))))))) 6691 return-action))))
6668 yank-action send-actions continue switch-function
6669 return-action)))
6670 6692
6671;;;###autoload 6693;;;###autoload
6672(defun message-news (&optional newsgroups subject) 6694(defun message-news (&optional newsgroups subject)
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 6d13d892b5a..3a31349d378 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -486,7 +486,8 @@ be \"related\" or \"alternate\"."
486 (equal (cdr (assq 'type (car cont))) "text/html")) 486 (equal (cdr (assq 'type (car cont))) "text/html"))
487 (setq cont (mml-expand-html-into-multipart-related (car cont)))) 487 (setq cont (mml-expand-html-into-multipart-related (car cont))))
488 (prog1 488 (prog1
489 (mm-with-multibyte-buffer 489 (with-temp-buffer
490 (set-buffer-multibyte nil)
490 (setq message-options options) 491 (setq message-options options)
491 (cond 492 (cond
492 ((and (consp (car cont)) 493 ((and (consp (car cont))
@@ -605,28 +606,38 @@ be \"related\" or \"alternate\"."
605 (intern (downcase charset)))))) 606 (intern (downcase charset))))))
606 (if (and (not raw) 607 (if (and (not raw)
607 (member (car (split-string type "/")) '("text" "message"))) 608 (member (car (split-string type "/")) '("text" "message")))
609 ;; We have a text-like MIME part, so we need to do
610 ;; charset encoding.
608 (progn 611 (progn
609 (with-temp-buffer 612 (with-temp-buffer
610 (cond 613 (set-buffer-multibyte nil)
611 ((cdr (assq 'buffer cont)) 614 ;; First insert the data into the buffer.
612 (insert-buffer-substring (cdr (assq 'buffer cont)))) 615 (if (and filename
613 ((and filename 616 (not (equal (cdr (assq 'nofile cont)) "yes")))
614 (not (equal (cdr (assq 'nofile cont)) "yes"))) 617 (mm-insert-file-contents filename)
615 (let ((coding-system-for-read coding)) 618 (insert
616 (mm-insert-file-contents filename))) 619 (with-temp-buffer
617 ((eq 'mml (car cont)) 620 (cond
618 (insert (cdr (assq 'contents cont)))) 621 ((cdr (assq 'buffer cont))
619 (t 622 (insert-buffer-substring (cdr (assq 'buffer cont))))
620 (save-restriction 623 ((eq 'mml (car cont))
621 (narrow-to-region (point) (point)) 624 (insert (cdr (assq 'contents cont))))
622 (insert (cdr (assq 'contents cont))) 625 (t
623 ;; Remove quotes from quoted tags. 626 (insert (cdr (assq 'contents cont)))
624 (goto-char (point-min)) 627 ;; Remove quotes from quoted tags.
625 (while (re-search-forward 628 (goto-char (point-min))
626 "<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)" 629 (while (re-search-forward
627 nil t) 630 "<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)"
628 (delete-region (+ (match-beginning 0) 2) 631 nil t)
629 (+ (match-beginning 0) 3)))))) 632 (delete-region (+ (match-beginning 0) 2)
633 (+ (match-beginning 0) 3)))))
634 (setq charset
635 (mm-coding-system-to-mime-charset
636 (detect-coding-region
637 (point-min) (point-max) t)))
638 (encode-coding-region (point-min) (point-max)
639 charset)
640 (buffer-string))))
630 (cond 641 (cond
631 ((eq (car cont) 'mml) 642 ((eq (car cont) 'mml)
632 (let ((mml-boundary (mml-compute-boundary cont)) 643 (let ((mml-boundary (mml-compute-boundary cont))
@@ -667,21 +678,22 @@ be \"related\" or \"alternate\"."
667 ;; insert a "; format=flowed" string unless the 678 ;; insert a "; format=flowed" string unless the
668 ;; user has already specified it. 679 ;; user has already specified it.
669 (setq flowed (null (assq 'format cont))))) 680 (setq flowed (null (assq 'format cont)))))
670 ;; Prefer `utf-8' for text/calendar parts. 681 (unless charset
671 (if (or charset 682 (setq charset
672 (not (string= type "text/calendar"))) 683 ;; Prefer `utf-8' for text/calendar parts.
673 (setq charset (mm-encode-body charset)) 684 (if (string= type "text/calendar")
674 (let ((mm-coding-system-priorities 685 'utf-8
675 (cons 'utf-8 mm-coding-system-priorities))) 686 (mm-coding-system-to-mime-charset
676 (setq charset (mm-encode-body)))) 687 (detect-coding-region
677 (mm-disable-multibyte) 688 (point-min) (point-max) t)))))
678 (setq encoding (mm-body-encoding 689 (setq encoding (mm-body-encoding
679 charset (cdr (assq 'encoding cont)))))) 690 charset (cdr (assq 'encoding cont))))))
680 (setq coded (buffer-string))) 691 (setq coded (buffer-string)))
681 (mml-insert-mime-headers cont type charset encoding flowed) 692 (mml-insert-mime-headers cont type charset encoding flowed)
682 (insert "\n") 693 (insert "\n")
683 (insert coded)) 694 (insert coded))
684 (mm-with-unibyte-buffer 695 (with-temp-buffer
696 (set-buffer-multibyte nil)
685 (cond 697 (cond
686 ((cdr (assq 'buffer cont)) 698 ((cdr (assq 'buffer cont))
687 (insert (string-as-unibyte 699 (insert (string-as-unibyte
@@ -690,11 +702,7 @@ be \"related\" or \"alternate\"."
690 ((and filename 702 ((and filename
691 (not (equal (cdr (assq 'nofile cont)) "yes"))) 703 (not (equal (cdr (assq 'nofile cont)) "yes")))
692 (let ((coding-system-for-read mm-binary-coding-system)) 704 (let ((coding-system-for-read mm-binary-coding-system))
693 (mm-insert-file-contents filename nil nil nil nil t)) 705 (mm-insert-file-contents filename nil nil nil nil t)))
694 (unless charset
695 (setq charset (mm-coding-system-to-mime-charset
696 (mm-find-buffer-file-coding-system
697 filename)))))
698 (t 706 (t
699 (let ((contents (cdr (assq 'contents cont)))) 707 (let ((contents (cdr (assq 'contents cont))))
700 (if (multibyte-string-p contents) 708 (if (multibyte-string-p contents)
@@ -1244,6 +1252,7 @@ If not set, `default-directory' will be used."
1244 1252
1245(defun mml-minibuffer-read-file (prompt) 1253(defun mml-minibuffer-read-file (prompt)
1246 (let* ((completion-ignored-extensions nil) 1254 (let* ((completion-ignored-extensions nil)
1255 (buffer-file-name nil)
1247 (file (read-file-name prompt 1256 (file (read-file-name prompt
1248 (or mml-default-directory default-directory) 1257 (or mml-default-directory default-directory)
1249 nil t))) 1258 nil t)))
@@ -1378,12 +1387,23 @@ content-type, a string of the form \"type/subtype\". DESCRIPTION
1378is a one-line description of the attachment. The DISPOSITION 1387is a one-line description of the attachment. The DISPOSITION
1379specifies how the attachment is intended to be displayed. It can 1388specifies how the attachment is intended to be displayed. It can
1380be either \"inline\" (displayed automatically within the message 1389be either \"inline\" (displayed automatically within the message
1381body) or \"attachment\" (separate from the body)." 1390body) or \"attachment\" (separate from the body).
1391
1392If given a prefix interactively, no prompting will be done for
1393the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults
1394will be computed and used."
1382 (interactive 1395 (interactive
1383 (let* ((file (mml-minibuffer-read-file "Attach file: ")) 1396 (let* ((file (mml-minibuffer-read-file "Attach file: "))
1384 (type (mml-minibuffer-read-type file)) 1397 (type (if current-prefix-arg
1385 (description (mml-minibuffer-read-description)) 1398 (or (mm-default-file-encoding file)
1386 (disposition (mml-minibuffer-read-disposition type nil file))) 1399 "application/octet-stream")
1400 (mml-minibuffer-read-type file)))
1401 (description (if current-prefix-arg
1402 nil
1403 (mml-minibuffer-read-description)))
1404 (disposition (if current-prefix-arg
1405 (mml-content-disposition type file)
1406 (mml-minibuffer-read-disposition type nil file))))
1387 (list file type description disposition))) 1407 (list file type description disposition)))
1388 ;; If in the message header, attach at the end and leave point unchanged. 1408 ;; If in the message header, attach at the end and leave point unchanged.
1389 (let ((head (unless (message-in-body-p) (point)))) 1409 (let ((head (unless (message-in-body-p) (point))))
diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el
index ede118d6eb6..7f7db8721db 100644
--- a/lisp/gnus/nndoc.el
+++ b/lisp/gnus/nndoc.el
@@ -356,14 +356,18 @@ from the document.")
356 (setq nndoc-dissection-alist nil) 356 (setq nndoc-dissection-alist nil)
357 (with-current-buffer nndoc-current-buffer 357 (with-current-buffer nndoc-current-buffer
358 (erase-buffer) 358 (erase-buffer)
359 (if (and (stringp nndoc-address) 359 (condition-case error
360 (string-match nndoc-binary-file-names nndoc-address)) 360 (if (and (stringp nndoc-address)
361 (let ((coding-system-for-read 'binary)) 361 (string-match nndoc-binary-file-names nndoc-address))
362 (mm-insert-file-contents nndoc-address)) 362 (let ((coding-system-for-read 'binary))
363 (if (stringp nndoc-address) 363 (mm-insert-file-contents nndoc-address))
364 (nnheader-insert-file-contents nndoc-address) 364 (if (stringp nndoc-address)
365 (insert-buffer-substring nndoc-address)) 365 (nnheader-insert-file-contents nndoc-address)
366 (run-hooks 'nndoc-open-document-hook))))) 366 (insert-buffer-substring nndoc-address))
367 (run-hooks 'nndoc-open-document-hook))
368 (file-error
369 (nnheader-report 'nndoc "Couldn't open %s: %s"
370 group error))))))
367 ;; Initialize the nndoc structures according to this new document. 371 ;; Initialize the nndoc structures according to this new document.
368 (when (and nndoc-current-buffer 372 (when (and nndoc-current-buffer
369 (not nndoc-dissection-alist)) 373 (not nndoc-dissection-alist))
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 700e86a0c57..2943c8dc7d2 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -67,7 +67,11 @@ back on `network'.")
67 (if (listp imap-shell-program) 67 (if (listp imap-shell-program)
68 (car imap-shell-program) 68 (car imap-shell-program)
69 imap-shell-program) 69 imap-shell-program)
70 "ssh %s imapd")) 70 "ssh %s imapd")
71 "What command to execute to connect to an IMAP server.
72This will only be used if the connection type is `shell'. See
73the `open-network-stream' documentation for an explanation of
74the format.")
71 75
72(defvoo nnimap-inbox nil 76(defvoo nnimap-inbox nil
73 "The mail box where incoming mail arrives and should be split out of. 77 "The mail box where incoming mail arrives and should be split out of.
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index fa16fa0bb67..742c66919af 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -115,13 +115,15 @@ When called from lisp, FUNCTION may also be a function object."
115 (if fn 115 (if fn
116 (format "Describe function (default %s): " fn) 116 (format "Describe function (default %s): " fn)
117 "Describe function: ") 117 "Describe function: ")
118 #'help--symbol-completion-table #'fboundp t nil nil 118 #'help--symbol-completion-table
119 (lambda (f) (or (fboundp f) (get f 'function-documentation)))
120 t nil nil
119 (and fn (symbol-name fn))))) 121 (and fn (symbol-name fn)))))
120 (unless (equal val "") 122 (unless (equal val "")
121 (setq fn (intern val))) 123 (setq fn (intern val)))
122 (unless (and fn (symbolp fn)) 124 (unless (and fn (symbolp fn))
123 (user-error "You didn't specify a function symbol")) 125 (user-error "You didn't specify a function symbol"))
124 (unless (fboundp fn) 126 (unless (or (fboundp fn) (get fn 'function-documentation))
125 (user-error "Symbol's function definition is void: %s" fn)) 127 (user-error "Symbol's function definition is void: %s" fn))
126 (list fn))) 128 (list fn)))
127 129
@@ -144,7 +146,9 @@ When called from lisp, FUNCTION may also be a function object."
144 146
145 (save-excursion 147 (save-excursion
146 (with-help-window (help-buffer) 148 (with-help-window (help-buffer)
147 (prin1 function) 149 (if (get function 'reader-construct)
150 (princ function)
151 (prin1 function))
148 ;; Use " is " instead of a colon so that 152 ;; Use " is " instead of a colon so that
149 ;; it is easier to get out the function name using forward-sexp. 153 ;; it is easier to get out the function name using forward-sexp.
150 (princ " is ") 154 (princ " is ")
@@ -469,7 +473,8 @@ suitable file is found, return nil."
469 (let ((fill-begin (point)) 473 (let ((fill-begin (point))
470 (high-usage (car high)) 474 (high-usage (car high))
471 (high-doc (cdr high))) 475 (high-doc (cdr high)))
472 (insert high-usage "\n") 476 (unless (get function 'reader-construct)
477 (insert high-usage "\n"))
473 (fill-region fill-begin (point)) 478 (fill-region fill-begin (point))
474 high-doc))))) 479 high-doc)))))
475 480
@@ -565,18 +570,21 @@ FILE is the file where FUNCTION was probably defined."
565 (or (and advised 570 (or (and advised
566 (advice--cd*r (advice--symbol-function function))) 571 (advice--cd*r (advice--symbol-function function)))
567 function)) 572 function))
568 ;; Get the real definition. 573 ;; Get the real definition, if any.
569 (def (if (symbolp real-function) 574 (def (if (symbolp real-function)
570 (or (symbol-function real-function) 575 (cond ((symbol-function real-function))
571 (signal 'void-function (list real-function))) 576 ((get real-function 'function-documentation)
577 nil)
578 (t (signal 'void-function (list real-function))))
572 real-function)) 579 real-function))
573 (aliased (or (symbolp def) 580 (aliased (and def
574 ;; Advised & aliased function. 581 (or (symbolp def)
575 (and advised (symbolp real-function) 582 ;; Advised & aliased function.
576 (not (eq 'autoload (car-safe def)))) 583 (and advised (symbolp real-function)
577 (and (subrp def) 584 (not (eq 'autoload (car-safe def))))
578 (not (string= (subr-name def) 585 (and (subrp def)
579 (symbol-name function)))))) 586 (not (string= (subr-name def)
587 (symbol-name function)))))))
580 (real-def (cond 588 (real-def (cond
581 ((and aliased (not (subrp def))) 589 ((and aliased (not (subrp def)))
582 (let ((f real-function)) 590 (let ((f real-function))
@@ -605,6 +613,8 @@ FILE is the file where FUNCTION was probably defined."
605 ;; Print what kind of function-like object FUNCTION is. 613 ;; Print what kind of function-like object FUNCTION is.
606 (princ (cond ((or (stringp def) (vectorp def)) 614 (princ (cond ((or (stringp def) (vectorp def))
607 "a keyboard macro") 615 "a keyboard macro")
616 ((get function 'reader-construct)
617 "a reader construct")
608 ;; Aliases are Lisp functions, so we need to check 618 ;; Aliases are Lisp functions, so we need to check
609 ;; aliases before functions. 619 ;; aliases before functions.
610 (aliased 620 (aliased
@@ -842,7 +852,7 @@ it is displayed along with the global value."
842 (terpri) 852 (terpri)
843 (pp val) 853 (pp val)
844 ;; Remove trailing newline. 854 ;; Remove trailing newline.
845 (delete-char -1)) 855 (and (= (char-before) ?\n) (delete-char -1)))
846 (let* ((sv (get variable 'standard-value)) 856 (let* ((sv (get variable 'standard-value))
847 (origval (and (consp sv) 857 (origval (and (consp sv)
848 (condition-case nil 858 (condition-case nil
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index a8d7294a5cc..3fb793e7aa5 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -328,7 +328,7 @@ Commands:
328 "\\(source \\(?:code \\)?\\(?:of\\|for\\)\\)\\)" 328 "\\(source \\(?:code \\)?\\(?:of\\|for\\)\\)\\)"
329 "[ \t\n]+\\)?" 329 "[ \t\n]+\\)?"
330 ;; Note starting with word-syntax character: 330 ;; Note starting with word-syntax character:
331 "['`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\)['’]")) 331 "['`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\|`\\)['’]"))
332 "Regexp matching doc string references to symbols. 332 "Regexp matching doc string references to symbols.
333 333
334The words preceding the quoted symbol can be used in doc strings to 334The words preceding the quoted symbol can be used in doc strings to
diff --git a/lisp/hl-line.el b/lisp/hl-line.el
index 4cf0573089f..38fe683785a 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -189,7 +189,8 @@ Specifically, when `hl-line-sticky-flag' is nil deactivate all
189such overlays in all buffers except the current one." 189such overlays in all buffers except the current one."
190 (let ((hlob hl-line-overlay-buffer) 190 (let ((hlob hl-line-overlay-buffer)
191 (curbuf (current-buffer))) 191 (curbuf (current-buffer)))
192 (when (and (not hl-line-sticky-flag) 192 (when (and (buffer-live-p hlob)
193 (not hl-line-sticky-flag)
193 (not (eq curbuf hlob)) 194 (not (eq curbuf hlob))
194 (not (minibufferp))) 195 (not (minibufferp)))
195 (with-current-buffer hlob 196 (with-current-buffer hlob
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index 21aac1ab216..74393ffbaeb 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -365,9 +365,15 @@ commands in `hfy-etags-cmd-alist'."
365 365
366(defun hfy-which-etags () 366(defun hfy-which-etags ()
367 "Return a string indicating which flavor of etags we are using." 367 "Return a string indicating which flavor of etags we are using."
368 (let ((v (shell-command-to-string (concat hfy-etags-bin " --version")))) 368 (with-temp-buffer
369 (cond ((string-match "exube" v) "exuberant ctags") 369 (condition-case nil
370 ((string-match "GNU E" v) "emacs etags" )) )) 370 (when (eq (call-process hfy-etags-bin nil t nil "--version") 0)
371 (goto-char (point-min))
372 (cond
373 ((looking-at-p "exube") "exuberant ctags")
374 ((looking-at-p "GNU E") "emacs etags")))
375 ;; Return nil if the etags binary isn't executable (Bug#25468).
376 (file-error nil))))
371 377
372(defcustom hfy-etags-cmd 378(defcustom hfy-etags-cmd
373 ;; We used to wrap this in a `eval-and-compile', but: 379 ;; We used to wrap this in a `eval-and-compile', but:
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/mail/ietf-drums.el b/lisp/mail/ietf-drums.el
index a3e53cfe793..fd793a28309 100644
--- a/lisp/mail/ietf-drums.el
+++ b/lisp/mail/ietf-drums.el
@@ -192,6 +192,17 @@ the Content-Transfer-Encoding header of a mail."
192 (ietf-drums-init string) 192 (ietf-drums-init string)
193 (while (not (eobp)) 193 (while (not (eobp))
194 (setq c (char-after)) 194 (setq c (char-after))
195 ;; If we have an uneven number of quote characters,
196 ;; `forward-sexp' will fail. In these cases, just delete the
197 ;; final of these quote characters.
198 (when (and (eq c ?\")
199 (not
200 (save-excursion
201 (ignore-errors
202 (forward-sexp 1)
203 t))))
204 (delete-char 1)
205 (setq c (char-after)))
195 (cond 206 (cond
196 ((or (eq c ? ) 207 ((or (eq c ? )
197 (eq c ?\t)) 208 (eq c ?\t))
diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el
index 2a8160921a6..bcbdc17631d 100644
--- a/lisp/mail/rfc2047.el
+++ b/lisp/mail/rfc2047.el
@@ -281,17 +281,7 @@ Should be called narrowed to the head of the message."
281 (encode-coding-region 281 (encode-coding-region
282 (point-min) (point-max) 282 (point-min) (point-max)
283 (mm-charset-to-coding-system 283 (mm-charset-to-coding-system
284 (car message-posting-charset)))) 284 (car message-posting-charset)))))
285 ;; No encoding necessary, but folding is nice
286 (when nil
287 (rfc2047-fold-region
288 (save-excursion
289 (goto-char (point-min))
290 (skip-chars-forward "^:")
291 (when (looking-at ": ")
292 (forward-char 2))
293 (point))
294 (point-max))))
295 ;; We found something that may perhaps be encoded. 285 ;; We found something that may perhaps be encoded.
296 (re-search-forward "^[^:]+: *" nil t) 286 (re-search-forward "^[^:]+: *" nil t)
297 (cond 287 (cond
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/eww.el b/lisp/net/eww.el
index d42180719dc..f7e06341443 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -59,7 +59,7 @@
59 "Directory where files will downloaded." 59 "Directory where files will downloaded."
60 :version "24.4" 60 :version "24.4"
61 :group 'eww 61 :group 'eww
62 :type 'string) 62 :type 'directory)
63 63
64;;;###autoload 64;;;###autoload
65(defcustom eww-suggest-uris 65(defcustom eww-suggest-uris
@@ -81,7 +81,7 @@ duplicate entries (if any) removed."
81 "Directory where bookmark files will be stored." 81 "Directory where bookmark files will be stored."
82 :version "25.1" 82 :version "25.1"
83 :group 'eww 83 :group 'eww
84 :type 'string) 84 :type 'directory)
85 85
86(defcustom eww-desktop-remove-duplicates t 86(defcustom eww-desktop-remove-duplicates t
87 "Whether to remove duplicates from the history when saving desktop data. 87 "Whether to remove duplicates from the history when saving desktop data.
@@ -251,6 +251,29 @@ word(s) will be searched for via `eww-search-prefix'."
251 (if uris (format " (default %s)" (car uris)) "") 251 (if uris (format " (default %s)" (car uris)) "")
252 ": "))) 252 ": ")))
253 (list (read-string prompt nil nil uris)))) 253 (list (read-string prompt nil nil uris))))
254 (setq url (eww--dwim-expand-url url))
255 (pop-to-buffer-same-window
256 (if (eq major-mode 'eww-mode)
257 (current-buffer)
258 (get-buffer-create "*eww*")))
259 (eww-setup-buffer)
260 ;; Check whether the domain only uses "Highly Restricted" Unicode
261 ;; IDNA characters. If not, transform to punycode to indicate that
262 ;; there may be funny business going on.
263 (let ((parsed (url-generic-parse-url url)))
264 (unless (puny-highly-restrictive-domain-p (url-host parsed))
265 (setf (url-host parsed) (puny-encode-domain (url-host parsed)))
266 (setq url (url-recreate-url parsed))))
267 (plist-put eww-data :url url)
268 (plist-put eww-data :title "")
269 (eww-update-header-line-format)
270 (let ((inhibit-read-only t))
271 (insert (format "Loading %s..." url))
272 (goto-char (point-min)))
273 (url-retrieve url 'eww-render
274 (list url nil (current-buffer))))
275
276(defun eww--dwim-expand-url (url)
254 (setq url (string-trim url)) 277 (setq url (string-trim url))
255 (cond ((string-match-p "\\`file:/" url)) 278 (cond ((string-match-p "\\`file:/" url))
256 ;; Don't mangle file: URLs at all. 279 ;; Don't mangle file: URLs at all.
@@ -275,26 +298,7 @@ word(s) will be searched for via `eww-search-prefix'."
275 (setq url (concat url "/")))) 298 (setq url (concat url "/"))))
276 (setq url (concat eww-search-prefix 299 (setq url (concat eww-search-prefix
277 (replace-regexp-in-string " " "+" url)))))) 300 (replace-regexp-in-string " " "+" url))))))
278 (pop-to-buffer-same-window 301 url)
279 (if (eq major-mode 'eww-mode)
280 (current-buffer)
281 (get-buffer-create "*eww*")))
282 (eww-setup-buffer)
283 ;; Check whether the domain only uses "Highly Restricted" Unicode
284 ;; IDNA characters. If not, transform to punycode to indicate that
285 ;; there may be funny business going on.
286 (let ((parsed (url-generic-parse-url url)))
287 (unless (puny-highly-restrictive-domain-p (url-host parsed))
288 (setf (url-host parsed) (puny-encode-domain (url-host parsed)))
289 (setq url (url-recreate-url parsed))))
290 (plist-put eww-data :url url)
291 (plist-put eww-data :title "")
292 (eww-update-header-line-format)
293 (let ((inhibit-read-only t))
294 (insert (format "Loading %s..." url))
295 (goto-char (point-min)))
296 (url-retrieve url 'eww-render
297 (list url nil (current-buffer))))
298 302
299;;;###autoload (defalias 'browse-web 'eww) 303;;;###autoload (defalias 'browse-web 'eww)
300 304
@@ -351,16 +355,25 @@ Currently this means either text/html or application/xhtml+xml."
351 "utf-8")))) 355 "utf-8"))))
352 (data-buffer (current-buffer)) 356 (data-buffer (current-buffer))
353 last-coding-system-used) 357 last-coding-system-used)
354 ;; Save the https peer status.
355 (with-current-buffer buffer 358 (with-current-buffer buffer
356 (plist-put eww-data :peer (plist-get status :peer))) 359 ;; Save the https peer status.
360 (plist-put eww-data :peer (plist-get status :peer))
361 ;; Make buffer listings more informative.
362 (setq list-buffers-directory url))
357 (unwind-protect 363 (unwind-protect
358 (progn 364 (progn
359 (cond 365 (cond
360 ((and eww-use-external-browser-for-content-type 366 ((and eww-use-external-browser-for-content-type
361 (string-match-p eww-use-external-browser-for-content-type 367 (string-match-p eww-use-external-browser-for-content-type
362 (car content-type))) 368 (car content-type)))
363 (eww-browse-with-external-browser url)) 369 (erase-buffer)
370 (insert "<title>Unsupported content type</title>")
371 (insert (format "<h1>Content-type %s is unsupported</h1>"
372 (car content-type)))
373 (insert (format "<a href=%S>Direct link to the document</a>"
374 url))
375 (goto-char (point-min))
376 (eww-display-html charset url nil point buffer encode))
364 ((eww-html-p (car content-type)) 377 ((eww-html-p (car content-type))
365 (eww-display-html charset url nil point buffer encode)) 378 (eww-display-html charset url nil point buffer encode))
366 ((equal (car content-type) "application/pdf") 379 ((equal (car content-type) "application/pdf")
@@ -804,7 +817,10 @@ the like."
804;;;###autoload 817;;;###autoload
805(defun eww-browse-url (url &optional new-window) 818(defun eww-browse-url (url &optional new-window)
806 (when new-window 819 (when new-window
807 (pop-to-buffer-same-window (generate-new-buffer "*eww*")) 820 (pop-to-buffer-same-window
821 (generate-new-buffer
822 (format "*eww-%s*" (url-host (url-generic-parse-url
823 (eww--dwim-expand-url url))))))
808 (eww-mode)) 824 (eww-mode))
809 (eww url)) 825 (eww url))
810 826
@@ -835,6 +851,8 @@ the like."
835 (erase-buffer) 851 (erase-buffer)
836 (insert text) 852 (insert text)
837 (goto-char (plist-get elem :point)) 853 (goto-char (plist-get elem :point))
854 ;; Make buffer listings more informative.
855 (setq list-buffers-directory (plist-get elem :url))
838 (eww-update-header-line-format)))) 856 (eww-update-header-line-format))))
839 857
840(defun eww-next-url () 858(defun eww-next-url ()
@@ -1483,6 +1501,7 @@ Differences in #targets are ignored."
1483(defun eww-download () 1501(defun eww-download ()
1484 "Download URL under point to `eww-download-directory'." 1502 "Download URL under point to `eww-download-directory'."
1485 (interactive) 1503 (interactive)
1504 (access-file eww-download-directory "Download failed")
1486 (let ((url (get-text-property (point) 'shr-url))) 1505 (let ((url (get-text-property (point) 'shr-url)))
1487 (if (not url) 1506 (if (not url)
1488 (message "No URL under point") 1507 (message "No URL under point")
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 93e1bae5fc2..bf60eee673c 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -139,6 +139,10 @@ a greeting from the server.
139:nowait, if non-nil, says the connection should be made 139:nowait, if non-nil, says the connection should be made
140asynchronously, if possible. 140asynchronously, if possible.
141 141
142:shell-command is a format-spec string that can be used if :type
143is `shell'. It has two specs, %s for host and %p for port
144number. Example: \"ssh gateway nc %s %p\".
145
142:tls-parameters is a list that should be supplied if you're 146:tls-parameters is a list that should be supplied if you're
143opening a TLS connection. The first element is the TLS 147opening a TLS connection. The first element is the TLS
144type (either `gnutls-x509pki' or `gnutls-anon'), and the 148type (either `gnutls-x509pki' or `gnutls-anon'), and the
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index e0bb3dbb2b7..b7c48288494 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -96,8 +96,9 @@ If nil, don't draw horizontal table lines."
96(defcustom shr-width nil 96(defcustom shr-width nil
97 "Frame width to use for rendering. 97 "Frame width to use for rendering.
98May either be an integer specifying a fixed width in characters, 98May either be an integer specifying a fixed width in characters,
99or nil, meaning that the full width of the window should be 99or nil, meaning that the full width of the window should be used.
100used." 100If `shr-use-fonts' is set, the mean character width is used to
101compute the pixel width, which is used instead."
101 :version "25.1" 102 :version "25.1"
102 :type '(choice (integer :tag "Fixed width in characters") 103 :type '(choice (integer :tag "Fixed width in characters")
103 (const :tag "Use the width of the window" nil)) 104 (const :tag "Use the width of the window" nil))
@@ -978,7 +979,7 @@ element is the data blob and the second element is the content-type."
978 (create-image data nil t :ascent 100 979 (create-image data nil t :ascent 100
979 :format content-type)) 980 :format content-type))
980 ((eq content-type 'image/svg+xml) 981 ((eq content-type 'image/svg+xml)
981 (create-image data 'svg t :ascent 100)) 982 (create-image data 'imagemagick t :ascent 100))
982 ((eq size 'full) 983 ((eq size 'full)
983 (ignore-errors 984 (ignore-errors
984 (shr-rescale-image data content-type 985 (shr-rescale-image data content-type
@@ -1011,18 +1012,25 @@ element is the data blob and the second element is the content-type."
1011 image) 1012 image)
1012 (insert (or alt "")))) 1013 (insert (or alt ""))))
1013 1014
1014(defun shr-rescale-image (data content-type width height) 1015(defun shr-rescale-image (data content-type width height
1016 &optional max-width max-height)
1015 "Rescale DATA, if too big, to fit the current buffer. 1017 "Rescale DATA, if too big, to fit the current buffer.
1016WIDTH and HEIGHT are the sizes given in the HTML data, if any." 1018WIDTH and HEIGHT are the sizes given in the HTML data, if any.
1019
1020The size of the displayed image will not exceed
1021MAX-WIDTH/MAX-HEIGHT. If not given, use the current window
1022width/height instead."
1017 (if (or (not (fboundp 'imagemagick-types)) 1023 (if (or (not (fboundp 'imagemagick-types))
1018 (not (get-buffer-window (current-buffer)))) 1024 (not (get-buffer-window (current-buffer))))
1019 (create-image data nil t :ascent 100) 1025 (create-image data nil t :ascent 100)
1020 (let* ((edges (window-inside-pixel-edges 1026 (let* ((edges (window-inside-pixel-edges
1021 (get-buffer-window (current-buffer)))) 1027 (get-buffer-window (current-buffer))))
1022 (max-width (truncate (* shr-max-image-proportion 1028 (max-width (truncate (* shr-max-image-proportion
1023 (- (nth 2 edges) (nth 0 edges))))) 1029 (or max-width
1030 (- (nth 2 edges) (nth 0 edges))))))
1024 (max-height (truncate (* shr-max-image-proportion 1031 (max-height (truncate (* shr-max-image-proportion
1025 (- (nth 3 edges) (nth 1 edges))))) 1032 (or max-height
1033 (- (nth 3 edges) (nth 1 edges))))))
1026 (scaling (image-compute-scaling-factor image-scaling-factor))) 1034 (scaling (image-compute-scaling-factor image-scaling-factor)))
1027 (when (or (and width 1035 (when (or (and width
1028 (> width max-width)) 1036 (> width max-width))
@@ -1059,8 +1067,7 @@ Return a string with image data."
1059 (when (ignore-errors 1067 (when (ignore-errors
1060 (url-cache-extract (url-cache-create-filename (shr-encode-url url))) 1068 (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
1061 t) 1069 t)
1062 (when (or (search-forward "\n\n" nil t) 1070 (when (re-search-forward "\r?\n\r?\n" nil t)
1063 (search-forward "\r\n\r\n" nil t))
1064 (shr-parse-image-data))))) 1071 (shr-parse-image-data)))))
1065 1072
1066(declare-function libxml-parse-xml-region "xml.c" 1073(declare-function libxml-parse-xml-region "xml.c"
@@ -1079,9 +1086,12 @@ Return a string with image data."
1079 obarray))))))) 1086 obarray)))))))
1080 ;; SVG images may contain references to further images that we may 1087 ;; SVG images may contain references to further images that we may
1081 ;; want to block. So special-case these by parsing the XML data 1088 ;; want to block. So special-case these by parsing the XML data
1082 ;; and remove the blocked bits. 1089 ;; and remove anything that looks like a blocked bit.
1083 (when (eq content-type 'image/svg+xml) 1090 (when (and shr-blocked-images
1091 (eq content-type 'image/svg+xml))
1084 (setq data 1092 (setq data
1093 ;; Note that libxml2 doesn't parse everything perfectly,
1094 ;; so glitches may occur during this transformation.
1085 (shr-dom-to-xml 1095 (shr-dom-to-xml
1086 (libxml-parse-xml-region (point) (point-max))))) 1096 (libxml-parse-xml-region (point) (point-max)))))
1087 (list data content-type))) 1097 (list data content-type)))
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/net/zeroconf.el b/lisp/net/zeroconf.el
index 37816bb8881..393f3a549f9 100644
--- a/lisp/net/zeroconf.el
+++ b/lisp/net/zeroconf.el
@@ -256,7 +256,7 @@ supported keys depend on the service type.")
256 "Returns all discovered Avahi service names as list." 256 "Returns all discovered Avahi service names as list."
257 (let (result) 257 (let (result)
258 (maphash 258 (maphash
259 (lambda (key value) (add-to-list 'result (zeroconf-service-name value))) 259 (lambda (_key value) (add-to-list 'result (zeroconf-service-name value)))
260 zeroconf-services-hash) 260 zeroconf-services-hash)
261 result)) 261 result))
262 262
@@ -264,7 +264,7 @@ supported keys depend on the service type.")
264 "Returns all discovered Avahi service types as list." 264 "Returns all discovered Avahi service types as list."
265 (let (result) 265 (let (result)
266 (maphash 266 (maphash
267 (lambda (key value) (add-to-list 'result (zeroconf-service-type value))) 267 (lambda (_key value) (add-to-list 'result (zeroconf-service-type value)))
268 zeroconf-services-hash) 268 zeroconf-services-hash)
269 result)) 269 result))
270 270
@@ -276,7 +276,7 @@ The service type is one of the returned values of
276format of SERVICE." 276format of SERVICE."
277 (let (result) 277 (let (result)
278 (maphash 278 (maphash
279 (lambda (key value) 279 (lambda (_key value)
280 (when (equal type (zeroconf-service-type value)) 280 (when (equal type (zeroconf-service-type value))
281 (add-to-list 'result value))) 281 (add-to-list 'result value)))
282 zeroconf-services-hash) 282 zeroconf-services-hash)
diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el
index 981b8464aaa..ed5b4c65068 100644
--- a/lisp/play/dunnet.el
+++ b/lisp/play/dunnet.el
@@ -267,7 +267,7 @@ on your head.")
267 (dun-mprincl "You can't drop anything while on the bus.") 267 (dun-mprincl "You can't drop anything while on the bus.")
268 (let (objnum) 268 (let (objnum)
269 (when (setq objnum (dun-objnum-from-args-std obj)) 269 (when (setq objnum (dun-objnum-from-args-std obj))
270 (if (not (setq ptr (member objnum dun-inventory))) 270 (if (not (member objnum dun-inventory))
271 (dun-mprincl "You don't have that.") 271 (dun-mprincl "You don't have that.")
272 (progn 272 (progn
273 (dun-remove-obj-from-inven objnum) 273 (dun-remove-obj-from-inven objnum)
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 f214242bdd9..7f49557c7a6 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 (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))
10269 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/hideshow.el b/lisp/progmodes/hideshow.el
index 0e4e67018ed..5328526abd9 100644
--- a/lisp/progmodes/hideshow.el
+++ b/lisp/progmodes/hideshow.el
@@ -582,7 +582,7 @@ and then further adjusted to be at the end of the line."
582 (setq p (line-end-position))) 582 (setq p (line-end-position)))
583 ;; `q' is the point at the end of the block 583 ;; `q' is the point at the end of the block
584 (hs-forward-sexp mdata 1) 584 (hs-forward-sexp mdata 1)
585 (setq q (if (looking-back hs-block-end-regexp) 585 (setq q (if (looking-back hs-block-end-regexp nil)
586 (match-beginning 0) 586 (match-beginning 0)
587 (point))) 587 (point)))
588 (when (and (< p q) (> (count-lines p q) 1)) 588 (when (and (< p q) (> (count-lines p q) 1))
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 2e5c6ae119b..e42e01481b6 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -574,8 +574,8 @@ then the \".\"s will be lined up:
574 (define-key keymap [(control ?c) (control ?j)] #'js-set-js-context) 574 (define-key keymap [(control ?c) (control ?j)] #'js-set-js-context)
575 (define-key keymap [(control meta ?x)] #'js-eval-defun) 575 (define-key keymap [(control meta ?x)] #'js-eval-defun)
576 (define-key keymap [(meta ?.)] #'js-find-symbol) 576 (define-key keymap [(meta ?.)] #'js-find-symbol)
577 (easy-menu-define nil keymap "Javascript Menu" 577 (easy-menu-define nil keymap "JavaScript Menu"
578 '("Javascript" 578 '("JavaScript"
579 ["Select New Mozilla Context..." js-set-js-context 579 ["Select New Mozilla Context..." js-set-js-context
580 (fboundp #'inferior-moz-process)] 580 (fboundp #'inferior-moz-process)]
581 ["Evaluate Expression in Mozilla Context..." js-eval 581 ["Evaluate Expression in Mozilla Context..." js-eval
@@ -1712,7 +1712,7 @@ This performs fontification according to `js--class-styles'."
1712 nil)))))) 1712 nil))))))
1713 1713
1714(defun js-syntax-propertize (start end) 1714(defun js-syntax-propertize (start end)
1715 ;; Javascript allows immediate regular expression objects, written /.../. 1715 ;; JavaScript allows immediate regular expression objects, written /.../.
1716 (goto-char start) 1716 (goto-char start)
1717 (js-syntax-propertize-regexp end) 1717 (js-syntax-propertize-regexp end)
1718 (funcall 1718 (funcall
@@ -2710,7 +2710,7 @@ current buffer. Pushes a mark onto the tag ring just like
2710;;; MozRepl integration 2710;;; MozRepl integration
2711 2711
2712(define-error 'js-moz-bad-rpc "Mozilla RPC Error") ;; '(timeout error)) 2712(define-error 'js-moz-bad-rpc "Mozilla RPC Error") ;; '(timeout error))
2713(define-error 'js-js-error "Javascript Error") ;; '(js-error error)) 2713(define-error 'js-js-error "JavaScript Error") ;; '(js-error error))
2714 2714
2715(defun js--wait-for-matching-output 2715(defun js--wait-for-matching-output
2716 (process regexp timeout &optional start) 2716 (process regexp timeout &optional start)
@@ -3214,7 +3214,7 @@ with `js--js-encode-value'."
3214Inside the lexical scope of `with-js', `js?', `js!', 3214Inside the lexical scope of `with-js', `js?', `js!',
3215`js-new', `js-eval', `js-list', `js<', `js>', `js-get-service', 3215`js-new', `js-eval', `js-list', `js<', `js>', `js-get-service',
3216`js-create-instance', and `js-qi' are defined." 3216`js-create-instance', and `js-qi' are defined."
3217 3217 (declare (indent 0) (debug t))
3218 `(progn 3218 `(progn
3219 (js--js-enter-repl) 3219 (js--js-enter-repl)
3220 (unwind-protect 3220 (unwind-protect
@@ -3391,7 +3391,7 @@ With argument, run even if no intervening GC has happened."
3391 3391
3392(defun js-eval (js) 3392(defun js-eval (js)
3393 "Evaluate the JavaScript in JS and return JSON-decoded result." 3393 "Evaluate the JavaScript in JS and return JSON-decoded result."
3394 (interactive "MJavascript to evaluate: ") 3394 (interactive "MJavaScript to evaluate: ")
3395 (with-js 3395 (with-js
3396 (let* ((content-window (js--js-content-window 3396 (let* ((content-window (js--js-content-window
3397 (js--get-js-context))) 3397 (js--get-js-context)))
@@ -3431,11 +3431,8 @@ left-to-right."
3431 (eq (cl-fifth window-info) 2)) 3431 (eq (cl-fifth window-info) 2))
3432 do (push window-info windows)) 3432 do (push window-info windows))
3433 3433
3434 (cl-loop for window-info in windows 3434 (cl-loop for (window title location) in windows
3435 for window = (cl-first window-info) 3435 collect (list title location window)
3436 collect (list (cl-second window-info)
3437 (cl-third window-info)
3438 window)
3439 3436
3440 for gbrowser = (js< window "gBrowser") 3437 for gbrowser = (js< window "gBrowser")
3441 if (js-handle? gbrowser) 3438 if (js-handle? gbrowser)
@@ -3668,7 +3665,7 @@ Change with `js-set-js-context'.")
3668(defun js-set-js-context (context) 3665(defun js-set-js-context (context)
3669 "Set the JavaScript context to CONTEXT. 3666 "Set the JavaScript context to CONTEXT.
3670When called interactively, prompt for CONTEXT." 3667When called interactively, prompt for CONTEXT."
3671 (interactive (list (js--read-tab "Javascript Context: "))) 3668 (interactive (list (js--read-tab "JavaScript Context: ")))
3672 (setq js--js-context context)) 3669 (setq js--js-context context))
3673 3670
3674(defun js--get-js-context () 3671(defun js--get-js-context ()
@@ -3682,7 +3679,7 @@ If one hasn't been set, or if it's stale, prompt for a new one."
3682 (`browser (not (js? (js< (cdr js--js-context) 3679 (`browser (not (js? (js< (cdr js--js-context)
3683 "contentDocument")))) 3680 "contentDocument"))))
3684 (x (error "Unmatched case in js--get-js-context: %S" x)))) 3681 (x (error "Unmatched case in js--get-js-context: %S" x))))
3685 (setq js--js-context (js--read-tab "Javascript Context: "))) 3682 (setq js--js-context (js--read-tab "JavaScript Context: ")))
3686 js--js-context)) 3683 js--js-context))
3687 3684
3688(defun js--js-content-window (context) 3685(defun js--js-content-window (context)
@@ -3852,6 +3849,7 @@ If one hasn't been set, or if it's stale, prompt for a new one."
3852 comment-start-skip "\\(//+\\|/\\*+\\)\\s *") 3849 comment-start-skip "\\(//+\\|/\\*+\\)\\s *")
3853 (setq-local comment-line-break-function #'c-indent-new-comment-line) 3850 (setq-local comment-line-break-function #'c-indent-new-comment-line)
3854 (setq-local c-block-comment-start-regexp "/\\*") 3851 (setq-local c-block-comment-start-regexp "/\\*")
3852 (setq-local comment-multi-line t)
3855 3853
3856 (setq-local electric-indent-chars 3854 (setq-local electric-indent-chars
3857 (append "{}():;," electric-indent-chars)) ;FIXME: js2-mode adds "[]*". 3855 (append "{}():;," electric-indent-chars)) ;FIXME: js2-mode adds "[]*".
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index d8262dd0a75..90b5e4e0dc6 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -4693,7 +4693,8 @@ likely an invalid python file."
4693 (let ((dedenter-pos (python-info-dedenter-statement-p))) 4693 (let ((dedenter-pos (python-info-dedenter-statement-p)))
4694 (when dedenter-pos 4694 (when dedenter-pos
4695 (goto-char dedenter-pos) 4695 (goto-char dedenter-pos)
4696 (let* ((pairs '(("elif" "elif" "if") 4696 (let* ((cur-line (line-beginning-position))
4697 (pairs '(("elif" "elif" "if")
4697 ("else" "if" "elif" "except" "for" "while") 4698 ("else" "if" "elif" "except" "for" "while")
4698 ("except" "except" "try") 4699 ("except" "except" "try")
4699 ("finally" "else" "except" "try"))) 4700 ("finally" "else" "except" "try")))
@@ -4709,7 +4710,22 @@ likely an invalid python file."
4709 (let ((indentation (current-indentation))) 4710 (let ((indentation (current-indentation)))
4710 (when (and (not (memq indentation collected-indentations)) 4711 (when (and (not (memq indentation collected-indentations))
4711 (or (not collected-indentations) 4712 (or (not collected-indentations)
4712 (< indentation (apply #'min collected-indentations)))) 4713 (< indentation (apply #'min collected-indentations)))
4714 ;; There must be no line with indentation
4715 ;; smaller than `indentation' (except for
4716 ;; blank lines) between the found opening
4717 ;; block and the current line, otherwise it
4718 ;; is not an opening block.
4719 (save-excursion
4720 (forward-line)
4721 (let ((no-back-indent t))
4722 (save-match-data
4723 (while (and (< (point) cur-line)
4724 (setq no-back-indent
4725 (or (> (current-indentation) indentation)
4726 (python-info-current-line-empty-p))))
4727 (forward-line)))
4728 no-back-indent)))
4713 (setq collected-indentations 4729 (setq collected-indentations
4714 (cons indentation collected-indentations)) 4730 (cons indentation collected-indentations))
4715 (when (member (match-string-no-properties 0) 4731 (when (member (match-string-no-properties 0)
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 71563486ecd..88683431290 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -2790,7 +2790,7 @@ local variable."
2790 ;; Iterate until we've moved the desired number of stmt ends 2790 ;; Iterate until we've moved the desired number of stmt ends
2791 (while (not (= (cl-signum arg) 0)) 2791 (while (not (= (cl-signum arg) 0))
2792 ;; if we're looking at the terminator, jump by 2 2792 ;; if we're looking at the terminator, jump by 2
2793 (if (or (and (> 0 arg) (looking-back term)) 2793 (if (or (and (> 0 arg) (looking-back term nil))
2794 (and (< 0 arg) (looking-at term))) 2794 (and (< 0 arg) (looking-at term)))
2795 (setq n 2) 2795 (setq n 2)
2796 (setq n 1)) 2796 (setq n 1))
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index 0e8ff525e62..6c76d7e4ad2 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -126,6 +126,14 @@
126 126
127;;; Code: 127;;; Code:
128 128
129(eval-when-compile (require 'cl))
130(eval-and-compile
131 ;; Before Emacs-24.4, `pushnew' expands to runtime calls to `cl-adjoin'
132 ;; even for relatively simple cases such as used here. We only test <25
133 ;; because it's easier and sufficient.
134 (when (or (featurep 'xemacs) (< emacs-major-version 25))
135 (require 'cl)))
136
129;; Emacs 21+ handling 137;; Emacs 21+ handling
130(defconst vhdl-emacs-21 (and (<= 21 emacs-major-version) (not (featurep 'xemacs))) 138(defconst vhdl-emacs-21 (and (<= 21 emacs-major-version) (not (featurep 'xemacs)))
131 "Non-nil if GNU Emacs 21, 22, ... is used.") 139 "Non-nil if GNU Emacs 21, 22, ... is used.")
@@ -14314,7 +14322,7 @@ of PROJECT."
14314 (vhdl-scan-directory-contents dir-name project nil 14322 (vhdl-scan-directory-contents dir-name project nil
14315 (format "(%s/%s) " act-dir num-dir) 14323 (format "(%s/%s) " act-dir num-dir)
14316 (cdr dir-list)) 14324 (cdr dir-list))
14317 (add-to-list 'dir-list-tmp (file-name-directory dir-name)) 14325 (pushnew (file-name-directory dir-name) dir-list-tmp :test #'equal)
14318 (setq dir-list (cdr dir-list) 14326 (setq dir-list (cdr dir-list)
14319 act-dir (1+ act-dir))) 14327 act-dir (1+ act-dir)))
14320 (vhdl-aput 'vhdl-directory-alist project (list (nreverse dir-list-tmp))) 14328 (vhdl-aput 'vhdl-directory-alist project (list (nreverse dir-list-tmp)))
@@ -16406,8 +16414,8 @@ component instantiation."
16406 (if (or (member constant-name single-list) 16414 (if (or (member constant-name single-list)
16407 (member constant-name multi-list)) 16415 (member constant-name multi-list))
16408 (progn (setq single-list (delete constant-name single-list)) 16416 (progn (setq single-list (delete constant-name single-list))
16409 (add-to-list 'multi-list constant-name)) 16417 (pushnew constant-name multi-list :test #'equal))
16410 (add-to-list 'single-list constant-name)) 16418 (pushnew constant-name single-list :test #'equal))
16411 (unless (match-string 1) 16419 (unless (match-string 1)
16412 (setq generic-alist (cdr generic-alist))) 16420 (setq generic-alist (cdr generic-alist)))
16413 (vhdl-forward-syntactic-ws)) 16421 (vhdl-forward-syntactic-ws))
@@ -16433,12 +16441,12 @@ component instantiation."
16433 (member signal-name multi-out-list)) 16441 (member signal-name multi-out-list))
16434 (setq single-out-list (delete signal-name single-out-list)) 16442 (setq single-out-list (delete signal-name single-out-list))
16435 (setq multi-out-list (delete signal-name multi-out-list)) 16443 (setq multi-out-list (delete signal-name multi-out-list))
16436 (add-to-list 'local-list signal-name)) 16444 (pushnew signal-name local-list :test #'equal))
16437 ((member signal-name single-in-list) 16445 ((member signal-name single-in-list)
16438 (setq single-in-list (delete signal-name single-in-list)) 16446 (setq single-in-list (delete signal-name single-in-list))
16439 (add-to-list 'multi-in-list signal-name)) 16447 (pushnew signal-name multi-in-list :test #'equal))
16440 ((not (member signal-name multi-in-list)) 16448 ((not (member signal-name multi-in-list))
16441 (add-to-list 'single-in-list signal-name))) 16449 (pushnew signal-name single-in-list :test #'equal)))
16442 ;; output signal 16450 ;; output signal
16443 (cond 16451 (cond
16444 ((member signal-name local-list) 16452 ((member signal-name local-list)
@@ -16447,17 +16455,18 @@ component instantiation."
16447 (member signal-name multi-in-list)) 16455 (member signal-name multi-in-list))
16448 (setq single-in-list (delete signal-name single-in-list)) 16456 (setq single-in-list (delete signal-name single-in-list))
16449 (setq multi-in-list (delete signal-name multi-in-list)) 16457 (setq multi-in-list (delete signal-name multi-in-list))
16450 (add-to-list 'local-list signal-name)) 16458 (pushnew signal-name local-list :test #'equal))
16451 ((member signal-name single-out-list) 16459 ((member signal-name single-out-list)
16452 (setq single-out-list (delete signal-name single-out-list)) 16460 (setq single-out-list (delete signal-name single-out-list))
16453 (add-to-list 'multi-out-list signal-name)) 16461 (pushnew signal-name multi-out-list :test #'equal))
16454 ((not (member signal-name multi-out-list)) 16462 ((not (member signal-name multi-out-list))
16455 (add-to-list 'single-out-list signal-name)))) 16463 (pushnew signal-name single-out-list :test #'equal))))
16456 (unless (match-string 1) 16464 (unless (match-string 1)
16457 (setq port-alist (cdr port-alist))) 16465 (setq port-alist (cdr port-alist)))
16458 (vhdl-forward-syntactic-ws)) 16466 (vhdl-forward-syntactic-ws))
16459 (push (list inst-name (nreverse constant-alist) 16467 (push (list inst-name (nreverse constant-alist)
16460 (nreverse signal-alist)) inst-alist)) 16468 (nreverse signal-alist))
16469 inst-alist))
16461 ;; prepare signal insertion 16470 ;; prepare signal insertion
16462 (vhdl-goto-marker arch-decl-pos) 16471 (vhdl-goto-marker arch-decl-pos)
16463 (forward-line 1) 16472 (forward-line 1)
@@ -16534,14 +16543,14 @@ component instantiation."
16534 generic-end-pos 16543 generic-end-pos
16535 (vhdl-compose-insert-generic constant-entry))) 16544 (vhdl-compose-insert-generic constant-entry)))
16536 (setq generic-pos (point-marker)) 16545 (setq generic-pos (point-marker))
16537 (add-to-list 'written-list constant-name)) 16546 (pushnew constant-name written-list :test #'equal))
16538 (t 16547 (t
16539 (vhdl-goto-marker 16548 (vhdl-goto-marker
16540 (vhdl-max-marker generic-inst-pos generic-pos)) 16549 (vhdl-max-marker generic-inst-pos generic-pos))
16541 (setq generic-end-pos 16550 (setq generic-end-pos
16542 (vhdl-compose-insert-generic constant-entry)) 16551 (vhdl-compose-insert-generic constant-entry))
16543 (setq generic-inst-pos (point-marker)) 16552 (setq generic-inst-pos (point-marker))
16544 (add-to-list 'written-list constant-name)))) 16553 (pushnew constant-name written-list :test #'equal))))
16545 (setq constant-alist (cdr constant-alist))) 16554 (setq constant-alist (cdr constant-alist)))
16546 (when (/= constant-temp-pos generic-inst-pos) 16555 (when (/= constant-temp-pos generic-inst-pos)
16547 (vhdl-goto-marker (vhdl-max-marker constant-temp-pos generic-pos)) 16556 (vhdl-goto-marker (vhdl-max-marker constant-temp-pos generic-pos))
@@ -16560,14 +16569,14 @@ component instantiation."
16560 (vhdl-max-marker 16569 (vhdl-max-marker
16561 port-end-pos (vhdl-compose-insert-port signal-entry))) 16570 port-end-pos (vhdl-compose-insert-port signal-entry)))
16562 (setq port-in-pos (point-marker)) 16571 (setq port-in-pos (point-marker))
16563 (add-to-list 'written-list signal-name)) 16572 (pushnew signal-name written-list :test #'equal))
16564 ((member signal-name multi-out-list) 16573 ((member signal-name multi-out-list)
16565 (vhdl-goto-marker (vhdl-max-marker port-out-pos port-in-pos)) 16574 (vhdl-goto-marker (vhdl-max-marker port-out-pos port-in-pos))
16566 (setq port-end-pos 16575 (setq port-end-pos
16567 (vhdl-max-marker 16576 (vhdl-max-marker
16568 port-end-pos (vhdl-compose-insert-port signal-entry))) 16577 port-end-pos (vhdl-compose-insert-port signal-entry)))
16569 (setq port-out-pos (point-marker)) 16578 (setq port-out-pos (point-marker))
16570 (add-to-list 'written-list signal-name)) 16579 (pushnew signal-name written-list :test #'equal))
16571 ((or (member signal-name single-in-list) 16580 ((or (member signal-name single-in-list)
16572 (member signal-name single-out-list)) 16581 (member signal-name single-out-list))
16573 (vhdl-goto-marker 16582 (vhdl-goto-marker
@@ -16576,12 +16585,12 @@ component instantiation."
16576 (vhdl-max-marker port-out-pos port-in-pos))) 16585 (vhdl-max-marker port-out-pos port-in-pos)))
16577 (setq port-end-pos (vhdl-compose-insert-port signal-entry)) 16586 (setq port-end-pos (vhdl-compose-insert-port signal-entry))
16578 (setq port-inst-pos (point-marker)) 16587 (setq port-inst-pos (point-marker))
16579 (add-to-list 'written-list signal-name)) 16588 (pushnew signal-name written-list :test #'equal))
16580 ((equal (upcase (nth 2 signal-entry)) "OUT") 16589 ((equal (upcase (nth 2 signal-entry)) "OUT")
16581 (vhdl-goto-marker signal-pos) 16590 (vhdl-goto-marker signal-pos)
16582 (vhdl-compose-insert-signal signal-entry) 16591 (vhdl-compose-insert-signal signal-entry)
16583 (setq signal-pos (point-marker)) 16592 (setq signal-pos (point-marker))
16584 (add-to-list 'written-list signal-name))) 16593 (pushnew signal-name written-list :test #'equal)))
16585 (setq signal-alist (cdr signal-alist))) 16594 (setq signal-alist (cdr signal-alist)))
16586 (when (/= port-temp-pos port-inst-pos) 16595 (when (/= port-temp-pos port-inst-pos)
16587 (vhdl-goto-marker 16596 (vhdl-goto-marker
@@ -16932,7 +16941,7 @@ no project is defined."
16932 "Remove duplicate elements from IN-LIST." 16941 "Remove duplicate elements from IN-LIST."
16933 (let (out-list) 16942 (let (out-list)
16934 (while in-list 16943 (while in-list
16935 (add-to-list 'out-list (car in-list)) 16944 (pushnew (car in-list) out-list :test #'equal)
16936 (setq in-list (cdr in-list))) 16945 (setq in-list (cdr in-list)))
16937 out-list)) 16946 out-list))
16938 16947
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index d8098c5a54a..a8933b0103e 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -918,7 +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 (let* ((grep-find-template (replace-regexp-in-string "-e " "-E " 921 (let* ((grep-find-template (replace-regexp-in-string "<C>" "<C> -E"
922 grep-find-template t t)) 922 grep-find-template t t))
923 (grep-highlight-matches nil) 923 (grep-highlight-matches nil)
924 (command (xref--rgrep-command (xref--regexp-to-extended regexp) 924 (command (xref--rgrep-command (xref--regexp-to-extended regexp)
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 2b1d22bb907..4f0573911b9 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -82,7 +82,7 @@ See the command `recentf-save-list'."
82 recentf-mode 82 recentf-mode
83 (recentf-load-list))))) 83 (recentf-load-list)))))
84 84
85(defcustom recentf-save-file-modes 384 ;; 0600 85(defcustom recentf-save-file-modes #o600
86 "Mode bits of recentf save file, as an integer, or nil. 86 "Mode bits of recentf save file, as an integer, or nil.
87If non-nil, after writing `recentf-save-file', set its mode bits to 87If non-nil, after writing `recentf-save-file', set its mode bits to
88this value. By default give R/W access only to the user who owns that 88this value. By default give R/W access only to the user who owns that
diff --git a/lisp/replace.el b/lisp/replace.el
index 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/shell.el b/lisp/shell.el
index 133771aeb32..c8a8555d632 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -544,11 +544,14 @@ control whether input and output cause the window to scroll to the end of the
544buffer." 544buffer."
545 (setq comint-prompt-regexp shell-prompt-pattern) 545 (setq comint-prompt-regexp shell-prompt-pattern)
546 (shell-completion-vars) 546 (shell-completion-vars)
547 (set (make-local-variable 'paragraph-separate) "\\'") 547 (setq-local paragraph-separate "\\'")
548 (set (make-local-variable 'paragraph-start) comint-prompt-regexp) 548 (setq-local paragraph-start comint-prompt-regexp)
549 (set (make-local-variable 'font-lock-defaults) '(shell-font-lock-keywords t)) 549 (setq-local font-lock-defaults '(shell-font-lock-keywords t))
550 (set (make-local-variable 'shell-dirstack) nil) 550 (setq-local shell-dirstack nil)
551 (set (make-local-variable 'shell-last-dir) nil) 551 (setq-local shell-last-dir nil)
552 ;; People expect Shell mode to keep the last line of output at
553 ;; window bottom.
554 (setq-local scroll-conservatively 101)
552 (shell-dirtrack-mode 1) 555 (shell-dirtrack-mode 1)
553 556
554 ;; By default, ansi-color applies faces using overlays. This is 557 ;; By default, ansi-color applies faces using overlays. This is
diff --git a/lisp/simple.el b/lisp/simple.el
index f798cd43847..441713a18b8 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -5410,11 +5410,15 @@ also checks the value of `use-empty-active-region'."
5410 ;; region is active when there's no mark. 5410 ;; region is active when there's no mark.
5411 (progn (cl-assert (mark)) t))) 5411 (progn (cl-assert (mark)) t)))
5412 5412
5413(defun region-bounds ()
5414 "Return the boundaries of the region as a list of (START . END) positions."
5415 (funcall region-extract-function 'bounds))
5416
5413(defun region-noncontiguous-p () 5417(defun region-noncontiguous-p ()
5414 "Return non-nil if the region contains several pieces. 5418 "Return non-nil if the region contains several pieces.
5415An example is a rectangular region handled as a list of 5419An example is a rectangular region handled as a list of
5416separate contiguous regions for each line." 5420separate contiguous regions for each line."
5417 (> (length (funcall region-extract-function 'bounds)) 1)) 5421 (> (length (region-bounds)) 1))
5418 5422
5419(defvar redisplay-unhighlight-region-function 5423(defvar redisplay-unhighlight-region-function
5420 (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) 5424 (lambda (rol) (when (overlayp rol) (delete-overlay rol))))
@@ -7568,7 +7572,7 @@ More precisely, a char with closeparen syntax is self-inserted.")
7568 7572
7569;; This executes C-g typed while Emacs is waiting for a command. 7573;; This executes C-g typed while Emacs is waiting for a command.
7570;; Quitting out of a program does not go through here; 7574;; Quitting out of a program does not go through here;
7571;; that happens in the QUIT macro at the C code level. 7575;; that happens in the maybe_quit function at the C code level.
7572(defun keyboard-quit () 7576(defun keyboard-quit ()
7573 "Signal a `quit' condition. 7577 "Signal a `quit' condition.
7574During execution of Lisp code, this character causes a quit directly. 7578During execution of Lisp code, this character causes a quit directly.
diff --git a/lisp/subr.el b/lisp/subr.el
index 53774169b42..a204577ddf9 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -384,6 +384,126 @@ configuration."
384 (declare (compiler-macro internal--compiler-macro-cXXr)) 384 (declare (compiler-macro internal--compiler-macro-cXXr))
385 (cdr (cdr x))) 385 (cdr (cdr x)))
386 386
387(defun caaar (x)
388 "Return the `car' of the `car' of the `car' of X."
389 (declare (compiler-macro internal--compiler-macro-cXXr))
390 (car (car (car x))))
391
392(defun caadr (x)
393 "Return the `car' of the `car' of the `cdr' of X."
394 (declare (compiler-macro internal--compiler-macro-cXXr))
395 (car (car (cdr x))))
396
397(defun cadar (x)
398 "Return the `car' of the `cdr' of the `car' of X."
399 (declare (compiler-macro internal--compiler-macro-cXXr))
400 (car (cdr (car x))))
401
402(defun caddr (x)
403 "Return the `car' of the `cdr' of the `cdr' of X."
404 (declare (compiler-macro internal--compiler-macro-cXXr))
405 (car (cdr (cdr x))))
406
407(defun cdaar (x)
408 "Return the `cdr' of the `car' of the `car' of X."
409 (declare (compiler-macro internal--compiler-macro-cXXr))
410 (cdr (car (car x))))
411
412(defun cdadr (x)
413 "Return the `cdr' of the `car' of the `cdr' of X."
414 (declare (compiler-macro internal--compiler-macro-cXXr))
415 (cdr (car (cdr x))))
416
417(defun cddar (x)
418 "Return the `cdr' of the `cdr' of the `car' of X."
419 (declare (compiler-macro internal--compiler-macro-cXXr))
420 (cdr (cdr (car x))))
421
422(defun cdddr (x)
423 "Return the `cdr' of the `cdr' of the `cdr' of X."
424 (declare (compiler-macro internal--compiler-macro-cXXr))
425 (cdr (cdr (cdr x))))
426
427(defun caaaar (x)
428 "Return the `car' of the `car' of the `car' of the `car' of X."
429 (declare (compiler-macro internal--compiler-macro-cXXr))
430 (car (car (car (car x)))))
431
432(defun caaadr (x)
433 "Return the `car' of the `car' of the `car' of the `cdr' of X."
434 (declare (compiler-macro internal--compiler-macro-cXXr))
435 (car (car (car (cdr x)))))
436
437(defun caadar (x)
438 "Return the `car' of the `car' of the `cdr' of the `car' of X."
439 (declare (compiler-macro internal--compiler-macro-cXXr))
440 (car (car (cdr (car x)))))
441
442(defun caaddr (x)
443 "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
444 (declare (compiler-macro internal--compiler-macro-cXXr))
445 (car (car (cdr (cdr x)))))
446
447(defun cadaar (x)
448 "Return the `car' of the `cdr' of the `car' of the `car' of X."
449 (declare (compiler-macro internal--compiler-macro-cXXr))
450 (car (cdr (car (car x)))))
451
452(defun cadadr (x)
453 "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
454 (declare (compiler-macro internal--compiler-macro-cXXr))
455 (car (cdr (car (cdr x)))))
456
457(defun caddar (x)
458 "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
459 (declare (compiler-macro internal--compiler-macro-cXXr))
460 (car (cdr (cdr (car x)))))
461
462(defun cadddr (x)
463 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
464 (declare (compiler-macro internal--compiler-macro-cXXr))
465 (car (cdr (cdr (cdr x)))))
466
467(defun cdaaar (x)
468 "Return the `cdr' of the `car' of the `car' of the `car' of X."
469 (declare (compiler-macro internal--compiler-macro-cXXr))
470 (cdr (car (car (car x)))))
471
472(defun cdaadr (x)
473 "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
474 (declare (compiler-macro internal--compiler-macro-cXXr))
475 (cdr (car (car (cdr x)))))
476
477(defun cdadar (x)
478 "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
479 (declare (compiler-macro internal--compiler-macro-cXXr))
480 (cdr (car (cdr (car x)))))
481
482(defun cdaddr (x)
483 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
484 (declare (compiler-macro internal--compiler-macro-cXXr))
485 (cdr (car (cdr (cdr x)))))
486
487(defun cddaar (x)
488 "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
489 (declare (compiler-macro internal--compiler-macro-cXXr))
490 (cdr (cdr (car (car x)))))
491
492(defun cddadr (x)
493 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
494 (declare (compiler-macro internal--compiler-macro-cXXr))
495 (cdr (cdr (car (cdr x)))))
496
497(defun cdddar (x)
498 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
499 (declare (compiler-macro internal--compiler-macro-cXXr))
500 (cdr (cdr (cdr (car x)))))
501
502(defun cddddr (x)
503 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
504 (declare (compiler-macro internal--compiler-macro-cXXr))
505 (cdr (cdr (cdr (cdr x)))))
506
387(defun last (list &optional n) 507(defun last (list &optional n)
388 "Return the last link of LIST. Its car is the last element. 508 "Return the last link of LIST. Its car is the last element.
389If LIST is nil, return nil. 509If LIST is nil, return nil.
@@ -1297,8 +1417,10 @@ be a list of the form returned by `event-start' and `event-end'."
1297;; bug#23850 1417;; bug#23850
1298(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") 1418(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1")
1299(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")
1300(make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1") 1421(make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1")
1301(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")
1302 1424
1303(defun log10 (x) 1425(defun log10 (x)
1304 "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/term.el b/lisp/term.el
index 5259571eb6d..063a6ea592f 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -2901,15 +2901,16 @@ See `term-prompt-regexp'."
2901 ((eq char ?\017)) ; Shift In - ignored 2901 ((eq char ?\017)) ; Shift In - ignored
2902 ((eq char ?\^G) ;; (terminfo: bel) 2902 ((eq char ?\^G) ;; (terminfo: bel)
2903 (beep t)) 2903 (beep t))
2904 ((and (eq char ?\032) 2904 ((eq char ?\032)
2905 (not handled-ansi-message))
2906 (let ((end (string-match "\r?\n" str i))) 2905 (let ((end (string-match "\r?\n" str i)))
2907 (if end 2906 (if end
2908 (funcall term-command-hook 2907 (progn
2909 (decode-coding-string 2908 (unless handled-ansi-message
2910 (prog1 (substring str (1+ i) end) 2909 (funcall term-command-hook
2911 (setq i (1- (match-end 0)))) 2910 (decode-coding-string
2912 locale-coding-system)) 2911 (substring str (1+ i) end)
2912 locale-coding-system)))
2913 (setq i (1- (match-end 0))))
2913 (setq term-terminal-parameter (substring str i)) 2914 (setq term-terminal-parameter (substring str i))
2914 (setq term-terminal-state 4) 2915 (setq term-terminal-state 4)
2915 (setq i str-length)))) 2916 (setq i str-length))))
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/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index 63abd048e9d..03da584e96f 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -164,6 +164,8 @@ distribution. Mixed-case symbols are convenience aliases.")
164 (?U . "\\autocite*[][]{%l}") 164 (?U . "\\autocite*[][]{%l}")
165 (?a . "\\citeauthor{%l}") 165 (?a . "\\citeauthor{%l}")
166 (?A . "\\citeauthor*{%l}") 166 (?A . "\\citeauthor*{%l}")
167 (?i . "\\citetitle{%l}")
168 (?I . "\\citetitle*{%l}")
167 (?y . "\\citeyear{%l}") 169 (?y . "\\citeyear{%l}")
168 (?Y . "\\citeyear*{%l}") 170 (?Y . "\\citeyear*{%l}")
169 (?n . "\\nocite{%l}"))) 171 (?n . "\\nocite{%l}")))
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index b7ad8e8ebd8..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)
@@ -501,7 +504,8 @@ See http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01990.html")
501;; "index ", "old mode", "new mode", "new file mode" and 504;; "index ", "old mode", "new mode", "new file mode" and
502;; "deleted file mode" are output by git-diff. 505;; "deleted file mode" are output by git-diff.
503(defconst diff-file-junk-re 506(defconst diff-file-junk-re
504 "diff \\|index \\|\\(?:deleted file\\|new\\(?: file\\)?\\|old\\) mode\\|=== modified file") 507 (concat "Index: \\|=\\{20,\\}\\|" ; SVN
508 "diff \\|index \\|\\(?:deleted file\\|new\\(?: file\\)?\\|old\\) mode\\|=== modified file"))
505 509
506;; If point is in a diff header, then return beginning 510;; If point is in a diff header, then return beginning
507;; of hunk position otherwise return nil. 511;; of hunk position otherwise return nil.
@@ -545,7 +549,8 @@ next hunk if TRY-HARDER is non-nil; otherwise signal an error."
545 (error "Can't find the beginning of the hunk"))) 549 (error "Can't find the beginning of the hunk")))
546 ((re-search-backward regexp nil t)) ; In the middle of a hunk. 550 ((re-search-backward regexp nil t)) ; In the middle of a hunk.
547 ((re-search-forward regexp nil t) ; At first hunk header. 551 ((re-search-forward regexp nil t) ; At first hunk header.
548 (forward-line 0)) 552 (forward-line 0)
553 (point))
549 (t (error "Can't find the beginning of the hunk")))))) 554 (t (error "Can't find the beginning of the hunk"))))))
550 555
551(defun diff-unified-hunk-p () 556(defun diff-unified-hunk-p ()
@@ -645,28 +650,36 @@ If the prefix ARG is given, restrict the view to the current file instead."
645 (if arg (diff-bounds-of-file) (diff-bounds-of-hunk))) 650 (if arg (diff-bounds-of-file) (diff-bounds-of-hunk)))
646 (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk))) 651 (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk)))
647 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
648(defun diff-hunk-kill () 658(defun diff-hunk-kill ()
649 "Kill the hunk at point." 659 "Kill the hunk at point."
650 (interactive) 660 (interactive)
651 (let* ((hunk-bounds (diff-bounds-of-hunk)) 661 (if (not (diff--some-hunks-p))
652 (file-bounds (ignore-errors (diff-bounds-of-file))) 662 (error "No hunks")
653 ;; If the current hunk is the only one for its file, kill the 663 (diff-beginning-of-hunk t)
654 ;; file header too. 664 (let* ((hunk-bounds (diff-bounds-of-hunk))
655 (bounds (if (and file-bounds 665 (file-bounds (ignore-errors (diff-bounds-of-file)))
656 (progn (goto-char (car file-bounds)) 666 ;; If the current hunk is the only one for its file, kill the
657 (= (progn (diff-hunk-next) (point)) 667 ;; file header too.
658 (car hunk-bounds))) 668 (bounds (if (and file-bounds
659 (progn (goto-char (cadr hunk-bounds)) 669 (progn (goto-char (car file-bounds))
660 ;; bzr puts a newline after the last hunk. 670 (= (progn (diff-hunk-next) (point))
661 (while (looking-at "^\n") 671 (car hunk-bounds)))
662 (forward-char 1)) 672 (progn (goto-char (cadr hunk-bounds))
663 (= (point) (cadr file-bounds)))) 673 ;; bzr puts a newline after the last hunk.
664 file-bounds 674 (while (looking-at "^\n")
665 hunk-bounds)) 675 (forward-char 1))
666 (inhibit-read-only t)) 676 (= (point) (cadr file-bounds))))
667 (apply 'kill-region bounds) 677 file-bounds
668 (goto-char (car bounds)) 678 hunk-bounds))
669 (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)))))
670 683
671(defun diff-beginning-of-file-and-junk () 684(defun diff-beginning-of-file-and-junk ()
672 "Go to the beginning of file-related diff-info. 685 "Go to the beginning of file-related diff-info.
@@ -718,9 +731,12 @@ data such as \"Index: ...\" and such."
718(defun diff-file-kill () 731(defun diff-file-kill ()
719 "Kill current file's hunks." 732 "Kill current file's hunks."
720 (interactive) 733 (interactive)
721 (let ((inhibit-read-only t)) 734 (if (not (diff--some-hunks-p))
722 (apply 'kill-region (diff-bounds-of-file))) 735 (error "No hunks")
723 (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))))
724 740
725(defun diff-kill-junk () 741(defun diff-kill-junk ()
726 "Kill spurious empty diffs." 742 "Kill spurious empty diffs."
@@ -1535,15 +1551,20 @@ Only works for unified diffs."
1535 (pcase (char-after) 1551 (pcase (char-after)
1536 (?\s (cl-decf before) (cl-decf after) t) 1552 (?\s (cl-decf before) (cl-decf after) t)
1537 (?- 1553 (?-
1538 (if (and (looking-at diff-file-header-re) 1554 (cond
1539 (zerop before) (zerop after)) 1555 ((and (looking-at diff-separator-re)
1540 ;; No need to query: this is a case where two patches 1556 (zerop before) (zerop after))
1541 ;; are concatenated and only counting the lines will 1557 nil)
1542 ;; give the right result. Let's just add an empty 1558 ((and (looking-at diff-file-header-re)
1543 ;; line so that our code which doesn't count lines 1559 (zerop before) (zerop after))
1544 ;; will not get confused. 1560 ;; No need to query: this is a case where two patches
1545 (progn (save-excursion (insert "\n")) nil) 1561 ;; are concatenated and only counting the lines will
1546 (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)))
1547 (?+ (cl-decf after) t) 1568 (?+ (cl-decf after) t)
1548 (_ 1569 (_
1549 (cond 1570 (cond
@@ -1998,57 +2019,58 @@ Return new point, if it was moved."
1998 "Highlight changes of hunk at point at a finer granularity." 2019 "Highlight changes of hunk at point at a finer granularity."
1999 (interactive) 2020 (interactive)
2000 (require 'smerge-mode) 2021 (require 'smerge-mode)
2001 (save-excursion 2022 (when (diff--some-hunks-p)
2002 (diff-beginning-of-hunk t) 2023 (save-excursion
2003 (let* ((start (point)) 2024 (diff-beginning-of-hunk t)
2004 (style (diff-hunk-style)) ;Skips the hunk header as well. 2025 (let* ((start (point))
2005 (beg (point)) 2026 (style (diff-hunk-style)) ;Skips the hunk header as well.
2006 (props-c '((diff-mode . fine) (face diff-refine-changed))) 2027 (beg (point))
2007 (props-r '((diff-mode . fine) (face diff-refine-removed))) 2028 (props-c '((diff-mode . fine) (face diff-refine-changed)))
2008 (props-a '((diff-mode . fine) (face diff-refine-added))) 2029 (props-r '((diff-mode . fine) (face diff-refine-removed)))
2009 ;; Be careful to go back to `start' so diff-end-of-hunk gets 2030 (props-a '((diff-mode . fine) (face diff-refine-added)))
2010 ;; to read the hunk header's line info. 2031 ;; Be careful to go back to `start' so diff-end-of-hunk gets
2011 (end (progn (goto-char start) (diff-end-of-hunk) (point)))) 2032 ;; to read the hunk header's line info.
2012 2033 (end (progn (goto-char start) (diff-end-of-hunk) (point))))
2013 (remove-overlays beg end 'diff-mode 'fine) 2034
2014 2035 (remove-overlays beg end 'diff-mode 'fine)
2015 (goto-char beg) 2036
2016 (pcase style 2037 (goto-char beg)
2017 (`unified 2038 (pcase style
2018 (while (re-search-forward "^-" end t) 2039 (`unified
2019 (let ((beg-del (progn (beginning-of-line) (point))) 2040 (while (re-search-forward "^-" end t)
2020 beg-add end-add) 2041 (let ((beg-del (progn (beginning-of-line) (point)))
2021 (when (and (diff--forward-while-leading-char ?- end) 2042 beg-add end-add)
2022 ;; Allow for "\ No newline at end of file". 2043 (when (and (diff--forward-while-leading-char ?- end)
2023 (progn (diff--forward-while-leading-char ?\\ end) 2044 ;; Allow for "\ No newline at end of file".
2024 (setq beg-add (point))) 2045 (progn (diff--forward-while-leading-char ?\\ end)
2025 (diff--forward-while-leading-char ?+ end) 2046 (setq beg-add (point)))
2026 (progn (diff--forward-while-leading-char ?\\ end) 2047 (diff--forward-while-leading-char ?+ end)
2027 (setq end-add (point)))) 2048 (progn (diff--forward-while-leading-char ?\\ end)
2028 (smerge-refine-subst beg-del beg-add beg-add end-add 2049 (setq end-add (point))))
2029 nil 'diff-refine-preproc props-r props-a))))) 2050 (smerge-refine-subst beg-del beg-add beg-add end-add
2030 (`context 2051 nil 'diff-refine-preproc props-r props-a)))))
2031 (let* ((middle (save-excursion (re-search-forward "^---"))) 2052 (`context
2032 (other middle)) 2053 (let* ((middle (save-excursion (re-search-forward "^---")))
2033 (while (re-search-forward "^\\(?:!.*\n\\)+" middle t) 2054 (other middle))
2034 (smerge-refine-subst (match-beginning 0) (match-end 0) 2055 (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
2035 (save-excursion 2056 (smerge-refine-subst (match-beginning 0) (match-end 0)
2036 (goto-char other) 2057 (save-excursion
2037 (re-search-forward "^\\(?:!.*\n\\)+" end) 2058 (goto-char other)
2038 (setq other (match-end 0)) 2059 (re-search-forward "^\\(?:!.*\n\\)+" end)
2039 (match-beginning 0)) 2060 (setq other (match-end 0))
2040 other 2061 (match-beginning 0))
2041 (if diff-use-changed-face props-c) 2062 other
2042 'diff-refine-preproc 2063 (if diff-use-changed-face props-c)
2043 (unless diff-use-changed-face props-r) 2064 'diff-refine-preproc
2044 (unless diff-use-changed-face props-a))))) 2065 (unless diff-use-changed-face props-r)
2045 (_ ;; Normal diffs. 2066 (unless diff-use-changed-face props-a)))))
2046 (let ((beg1 (1+ (point)))) 2067 (_ ;; Normal diffs.
2047 (when (re-search-forward "^---.*\n" end t) 2068 (let ((beg1 (1+ (point))))
2048 ;; It's a combined add&remove, so there's something to do. 2069 (when (re-search-forward "^---.*\n" end t)
2049 (smerge-refine-subst beg1 (match-beginning 0) 2070 ;; It's a combined add&remove, so there's something to do.
2050 (match-end 0) end 2071 (smerge-refine-subst beg1 (match-beginning 0)
2051 nil 'diff-refine-preproc props-r props-a)))))))) 2072 (match-end 0) end
2073 nil 'diff-refine-preproc props-r props-a)))))))))
2052 2074
2053(defun diff-undo (&optional arg) 2075(defun diff-undo (&optional arg)
2054 "Perform `undo', ignoring the buffer's read-only status." 2076 "Perform `undo', ignoring the buffer's read-only status."
diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el
index 95568b29c7c..0235926fbe4 100644
--- a/lisp/vc/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -150,6 +150,26 @@ It needs to be killed when we quit the session.")
150(defsubst ediff-get-symbol-from-alist (buf-type alist) 150(defsubst ediff-get-symbol-from-alist (buf-type alist)
151 (cdr (assoc buf-type alist))) 151 (cdr (assoc buf-type alist)))
152 152
153;; Vector of differences between the variants. Each difference is
154;; represented by a vector of two overlays plus a vector of fine diffs,
155;; plus a no-fine-diffs flag. The first overlay spans the
156;; difference region in the A buffer and the second overlays the diff in
157;; the B buffer. If a difference section is empty, the corresponding
158;; overlay's endpoints coincide.
159;;
160;; The precise form of a Difference Vector for one buffer is:
161;; [diff diff diff ...]
162;; where each diff has the form:
163;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-diff]
164;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...]
165;; no-fine-diffs-flag says if there are fine differences.
166;; state-of-difference is A, B, C, or nil, indicating which buffer is
167;; different from the other two (used only in 3-way jobs.
168(ediff-defvar-local ediff-difference-vector-A nil "")
169(ediff-defvar-local ediff-difference-vector-B nil "")
170(ediff-defvar-local ediff-difference-vector-C nil "")
171(ediff-defvar-local ediff-difference-vector-Ancestor nil "")
172;; A-list of diff vector types associated with buffer types
153(defconst ediff-difference-vector-alist 173(defconst ediff-difference-vector-alist
154 '((A . ediff-difference-vector-A) 174 '((A . ediff-difference-vector-A)
155 (B . ediff-difference-vector-B) 175 (B . ediff-difference-vector-B)
@@ -642,32 +662,6 @@ shown in brighter colors."
642 ;;buffer-read-only 662 ;;buffer-read-only
643 mode-line-format)) 663 mode-line-format))
644 664
645;; Vector of differences between the variants. Each difference is
646;; represented by a vector of two overlays plus a vector of fine diffs,
647;; plus a no-fine-diffs flag. The first overlay spans the
648;; difference region in the A buffer and the second overlays the diff in
649;; the B buffer. If a difference section is empty, the corresponding
650;; overlay's endpoints coincide.
651;;
652;; The precise form of a Difference Vector for one buffer is:
653;; [diff diff diff ...]
654;; where each diff has the form:
655;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-diff]
656;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...]
657;; no-fine-diffs-flag says if there are fine differences.
658;; state-of-difference is A, B, C, or nil, indicating which buffer is
659;; different from the other two (used only in 3-way jobs.
660(ediff-defvar-local ediff-difference-vector-A nil "")
661(ediff-defvar-local ediff-difference-vector-B nil "")
662(ediff-defvar-local ediff-difference-vector-C nil "")
663(ediff-defvar-local ediff-difference-vector-Ancestor nil "")
664;; A-list of diff vector types associated with buffer types
665(defconst ediff-difference-vector-alist
666 '((A . ediff-difference-vector-A)
667 (B . ediff-difference-vector-B)
668 (C . ediff-difference-vector-C)
669 (Ancestor . ediff-difference-vector-Ancestor)))
670
671;; [ status status status ...] 665;; [ status status status ...]
672;; Each status: [state-of-merge state-of-ancestor] 666;; Each status: [state-of-merge state-of-ancestor]
673;; state-of-merge is default-A, default-B, prefer-A, or prefer-B. It 667;; state-of-merge is default-A, default-B, prefer-A, or prefer-B. It
diff --git a/lisp/xml.el b/lisp/xml.el
index cd801be3083..be2ac96f264 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -646,8 +646,10 @@ surpassed `xml-entity-expansion-limit'"))))
646(defun xml-parse-attlist (&optional xml-ns) 646(defun xml-parse-attlist (&optional xml-ns)
647 "Return the attribute-list after point. 647 "Return the attribute-list after point.
648Leave point at the first non-blank character after the tag." 648Leave point at the first non-blank character after the tag."
649 (let ((attlist ()) 649 (let* ((attlist ())
650 end-pos name) 650 (symbol-qnames (eq (car-safe xml-ns) 'symbol-qnames))
651 (xml-ns (if symbol-qnames (cdr xml-ns) xml-ns))
652 end-pos name)
651 (skip-syntax-forward " ") 653 (skip-syntax-forward " ")
652 (while (looking-at (eval-when-compile 654 (while (looking-at (eval-when-compile
653 (concat "\\(" xml-name-re "\\)\\s-*=\\s-*"))) 655 (concat "\\(" xml-name-re "\\)\\s-*=\\s-*")))
diff --git a/src/alloc.c b/src/alloc.c
index 1a6d4e2d565..62f43669f2a 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -2872,45 +2872,15 @@ usage: (list &rest OBJECTS) */)
2872 2872
2873DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, 2873DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2874 doc: /* Return a newly created list of length LENGTH, with each element being INIT. */) 2874 doc: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2875 (register Lisp_Object length, Lisp_Object init) 2875 (Lisp_Object length, Lisp_Object init)
2876{ 2876{
2877 register Lisp_Object val; 2877 Lisp_Object val = Qnil;
2878 register EMACS_INT size;
2879
2880 CHECK_NATNUM (length); 2878 CHECK_NATNUM (length);
2881 size = XFASTINT (length);
2882 2879
2883 val = Qnil; 2880 for (EMACS_INT size = XFASTINT (length); 0 < size; size--)
2884 while (size > 0)
2885 { 2881 {
2886 val = Fcons (init, val); 2882 val = Fcons (init, val);
2887 --size; 2883 rarely_quit (size);
2888
2889 if (size > 0)
2890 {
2891 val = Fcons (init, val);
2892 --size;
2893
2894 if (size > 0)
2895 {
2896 val = Fcons (init, val);
2897 --size;
2898
2899 if (size > 0)
2900 {
2901 val = Fcons (init, val);
2902 --size;
2903
2904 if (size > 0)
2905 {
2906 val = Fcons (init, val);
2907 --size;
2908 }
2909 }
2910 }
2911 }
2912
2913 QUIT;
2914 } 2884 }
2915 2885
2916 return val; 2886 return val;
@@ -4917,12 +4887,19 @@ mark_memory (void *start, void *end)
4917 } 4887 }
4918} 4888}
4919 4889
4920#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
4921 4898
4922static bool setjmp_tested_p; 4899static bool setjmp_tested_p;
4923static int longjmps_done; 4900static int longjmps_done;
4924 4901
4925#define SETJMP_WILL_LIKELY_WORK "\ 4902# define SETJMP_WILL_LIKELY_WORK "\
4926\n\ 4903\n\
4927Emacs garbage collector has been changed to use conservative stack\n\ 4904Emacs garbage collector has been changed to use conservative stack\n\
4928marking. 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\
@@ -4935,7 +4912,7 @@ verify that the methods used are appropriate for your system.\n\
4935Please mail the result to <emacs-devel@gnu.org>.\n\ 4912Please mail the result to <emacs-devel@gnu.org>.\n\
4936" 4913"
4937 4914
4938#define SETJMP_WILL_NOT_WORK "\ 4915# define SETJMP_WILL_NOT_WORK "\
4939\n\ 4916\n\
4940Emacs garbage collector has been changed to use conservative stack\n\ 4917Emacs garbage collector has been changed to use conservative stack\n\
4941marking. 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\
@@ -4961,6 +4938,9 @@ Please mail the result to <emacs-devel@gnu.org>.\n\
4961static void 4938static void
4962test_setjmp (void) 4939test_setjmp (void)
4963{ 4940{
4941 if (setjmp_tested_p)
4942 return;
4943 setjmp_tested_p = true;
4964 char buf[10]; 4944 char buf[10];
4965 register int x; 4945 register int x;
4966 sys_jmp_buf jbuf; 4946 sys_jmp_buf jbuf;
@@ -4997,9 +4977,60 @@ test_setjmp (void)
4997 if (longjmps_done == 1) 4977 if (longjmps_done == 1)
4998 sys_longjmp (jbuf, 1); 4978 sys_longjmp (jbuf, 1);
4999} 4979}
4980# endif /* ! GC_SETJMP_WORKS */
4981#endif /* ! HAVE___BUILTIN_UNWIND_INIT */
5000 4982
5001#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
5002 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
5003 5034
5004/* Mark live Lisp objects on the C stack. 5035/* Mark live Lisp objects on the C stack.
5005 5036
@@ -5011,12 +5042,7 @@ test_setjmp (void)
5011 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
5012 variables or are used to pass parameters. 5043 variables or are used to pass parameters.
5013 5044
5014 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to 5045 This code assumes that calling setjmp saves registers we need
5015 something that either saves relevant registers on the stack, or
5016 calls mark_maybe_object passing it each register's contents.
5017
5018 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
5019 implementation assumes that calling setjmp saves registers we need
5020 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
5021 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
5022 by taking a look at the source code of setjmp. 5048 by taking a look at the source code of setjmp.
@@ -5080,62 +5106,9 @@ flush_stack_call_func (void (*func) (void *arg), void *arg)
5080{ 5106{
5081 void *end; 5107 void *end;
5082 struct thread_state *self = current_thread; 5108 struct thread_state *self = current_thread;
5083 5109 SET_STACK_TOP_ADDRESS (&end);
5084#ifdef HAVE___BUILTIN_UNWIND_INIT
5085 /* Force callee-saved registers and register windows onto the stack.
5086 This is the preferred method if available, obviating the need for
5087 machine dependent methods. */
5088 __builtin_unwind_init ();
5089 end = &end;
5090#else /* not HAVE___BUILTIN_UNWIND_INIT */
5091#ifndef GC_SAVE_REGISTERS_ON_STACK
5092 /* jmp_buf may not be aligned enough on darwin-ppc64 */
5093 union aligned_jmpbuf {
5094 Lisp_Object o;
5095 sys_jmp_buf j;
5096 } j;
5097 volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom;
5098#endif
5099 /* This trick flushes the register windows so that all the state of
5100 the process is contained in the stack. */
5101 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
5102 needed on ia64 too. See mach_dep.c, where it also says inline
5103 assembler doesn't work with relevant proprietary compilers. */
5104#ifdef __sparc__
5105#if defined (__sparc64__) && defined (__FreeBSD__)
5106 /* FreeBSD does not have a ta 3 handler. */
5107 asm ("flushw");
5108#else
5109 asm ("ta 3");
5110#endif
5111#endif
5112
5113 /* Save registers that we need to see on the stack. We need to see
5114 registers used to hold register variables and registers used to
5115 pass parameters. */
5116#ifdef GC_SAVE_REGISTERS_ON_STACK
5117 GC_SAVE_REGISTERS_ON_STACK (end);
5118#else /* not GC_SAVE_REGISTERS_ON_STACK */
5119
5120#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
5121 setjmp will definitely work, test it
5122 and print a message with the result
5123 of the test. */
5124 if (!setjmp_tested_p)
5125 {
5126 setjmp_tested_p = 1;
5127 test_setjmp ();
5128 }
5129#endif /* GC_SETJMP_WORKS */
5130
5131 sys_setjmp (j.j);
5132 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
5133#endif /* not GC_SAVE_REGISTERS_ON_STACK */
5134#endif /* not HAVE___BUILTIN_UNWIND_INIT */
5135
5136 self->stack_top = end; 5110 self->stack_top = end;
5137 (*func) (arg); 5111 func (arg);
5138
5139 eassert (current_thread == self); 5112 eassert (current_thread == self);
5140} 5113}
5141 5114
@@ -5464,6 +5437,38 @@ make_pure_vector (ptrdiff_t len)
5464 return new; 5437 return new;
5465} 5438}
5466 5439
5440/* Copy all contents and parameters of TABLE to a new table allocated
5441 from pure space, return the purified table. */
5442static struct Lisp_Hash_Table *
5443purecopy_hash_table (struct Lisp_Hash_Table *table)
5444{
5445 eassert (NILP (table->weak));
5446 eassert (!NILP (table->pure));
5447
5448 struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
5449 struct hash_table_test pure_test = table->test;
5450
5451 /* Purecopy the hash table test. */
5452 pure_test.name = purecopy (table->test.name);
5453 pure_test.user_hash_function = purecopy (table->test.user_hash_function);
5454 pure_test.user_cmp_function = purecopy (table->test.user_cmp_function);
5455
5456 pure->test = pure_test;
5457 pure->header = table->header;
5458 pure->weak = purecopy (Qnil);
5459 pure->rehash_size = purecopy (table->rehash_size);
5460 pure->rehash_threshold = purecopy (table->rehash_threshold);
5461 pure->hash = purecopy (table->hash);
5462 pure->next = purecopy (table->next);
5463 pure->next_free = purecopy (table->next_free);
5464 pure->index = purecopy (table->index);
5465 pure->count = table->count;
5466 pure->key_and_value = purecopy (table->key_and_value);
5467 pure->pure = purecopy (table->pure);
5468
5469 return pure;
5470}
5471
5467DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, 5472DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
5468 doc: /* Make a copy of object OBJ in pure storage. 5473 doc: /* Make a copy of object OBJ in pure storage.
5469Recursively copies contents of vectors and cons cells. 5474Recursively copies contents of vectors and cons cells.
@@ -5472,14 +5477,20 @@ Does not copy symbols. Copies strings without text properties. */)
5472{ 5477{
5473 if (NILP (Vpurify_flag)) 5478 if (NILP (Vpurify_flag))
5474 return obj; 5479 return obj;
5475 else if (MARKERP (obj) || OVERLAYP (obj) 5480 else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj))
5476 || HASH_TABLE_P (obj) || SYMBOLP (obj))
5477 /* Can't purify those. */ 5481 /* Can't purify those. */
5478 return obj; 5482 return obj;
5479 else 5483 else
5480 return purecopy (obj); 5484 return purecopy (obj);
5481} 5485}
5482 5486
5487/* Pinned objects are marked before every GC cycle. */
5488static struct pinned_object
5489{
5490 Lisp_Object object;
5491 struct pinned_object *next;
5492} *pinned_objects;
5493
5483static Lisp_Object 5494static Lisp_Object
5484purecopy (Lisp_Object obj) 5495purecopy (Lisp_Object obj)
5485{ 5496{
@@ -5507,7 +5518,27 @@ purecopy (Lisp_Object obj)
5507 obj = make_pure_string (SSDATA (obj), SCHARS (obj), 5518 obj = make_pure_string (SSDATA (obj), SCHARS (obj),
5508 SBYTES (obj), 5519 SBYTES (obj),
5509 STRING_MULTIBYTE (obj)); 5520 STRING_MULTIBYTE (obj));
5510 else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj)) 5521 else if (HASH_TABLE_P (obj))
5522 {
5523 struct Lisp_Hash_Table *table = XHASH_TABLE (obj);
5524 /* Do not purify hash tables which haven't been defined with
5525 :purecopy as non-nil or are weak - they aren't guaranteed to
5526 not change. */
5527 if (!NILP (table->weak) || NILP (table->pure))
5528 {
5529 /* Instead, add the hash table to the list of pinned objects,
5530 so that it will be marked during GC. */
5531 struct pinned_object *o = xmalloc (sizeof *o);
5532 o->object = obj;
5533 o->next = pinned_objects;
5534 pinned_objects = o;
5535 return obj; /* Don't hash cons it. */
5536 }
5537
5538 struct Lisp_Hash_Table *h = purecopy_hash_table (table);
5539 XSET_HASH_TABLE (obj, h);
5540 }
5541 else if (COMPILEDP (obj) || VECTORP (obj))
5511 { 5542 {
5512 struct Lisp_Vector *objp = XVECTOR (obj); 5543 struct Lisp_Vector *objp = XVECTOR (obj);
5513 ptrdiff_t nbytes = vector_nbytes (objp); 5544 ptrdiff_t nbytes = vector_nbytes (objp);
@@ -5724,6 +5755,13 @@ compact_undo_list (Lisp_Object list)
5724} 5755}
5725 5756
5726static void 5757static void
5758mark_pinned_objects (void)
5759{
5760 for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next)
5761 mark_object (pobj->object);
5762}
5763
5764static void
5727mark_pinned_symbols (void) 5765mark_pinned_symbols (void)
5728{ 5766{
5729 struct symbol_block *sblk; 5767 struct symbol_block *sblk;
@@ -5843,6 +5881,7 @@ garbage_collect_1 (void *end)
5843 for (i = 0; i < staticidx; i++) 5881 for (i = 0; i < staticidx; i++)
5844 mark_object (*staticvec[i]); 5882 mark_object (*staticvec[i]);
5845 5883
5884 mark_pinned_objects ();
5846 mark_pinned_symbols (); 5885 mark_pinned_symbols ();
5847 mark_terminals (); 5886 mark_terminals ();
5848 mark_kboards (); 5887 mark_kboards ();
@@ -6011,58 +6050,7 @@ See Info node `(elisp)Garbage Collection'. */)
6011 (void) 6050 (void)
6012{ 6051{
6013 void *end; 6052 void *end;
6014 6053 SET_STACK_TOP_ADDRESS (&end);
6015#ifdef HAVE___BUILTIN_UNWIND_INIT
6016 /* Force callee-saved registers and register windows onto the stack.
6017 This is the preferred method if available, obviating the need for
6018 machine dependent methods. */
6019 __builtin_unwind_init ();
6020 end = &end;
6021#else /* not HAVE___BUILTIN_UNWIND_INIT */
6022#ifndef GC_SAVE_REGISTERS_ON_STACK
6023 /* jmp_buf may not be aligned enough on darwin-ppc64 */
6024 union aligned_jmpbuf {
6025 Lisp_Object o;
6026 sys_jmp_buf j;
6027 } j;
6028 volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
6029#endif
6030 /* This trick flushes the register windows so that all the state of
6031 the process is contained in the stack. */
6032 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
6033 needed on ia64 too. See mach_dep.c, where it also says inline
6034 assembler doesn't work with relevant proprietary compilers. */
6035#ifdef __sparc__
6036#if defined (__sparc64__) && defined (__FreeBSD__)
6037 /* FreeBSD does not have a ta 3 handler. */
6038 asm ("flushw");
6039#else
6040 asm ("ta 3");
6041#endif
6042#endif
6043
6044 /* Save registers that we need to see on the stack. We need to see
6045 registers used to hold register variables and registers used to
6046 pass parameters. */
6047#ifdef GC_SAVE_REGISTERS_ON_STACK
6048 GC_SAVE_REGISTERS_ON_STACK (end);
6049#else /* not GC_SAVE_REGISTERS_ON_STACK */
6050
6051#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
6052 setjmp will definitely work, test it
6053 and print a message with the result
6054 of the test. */
6055 if (!setjmp_tested_p)
6056 {
6057 setjmp_tested_p = 1;
6058 test_setjmp ();
6059 }
6060#endif /* GC_SETJMP_WORKS */
6061
6062 sys_setjmp (j.j);
6063 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
6064#endif /* not GC_SAVE_REGISTERS_ON_STACK */
6065#endif /* not HAVE___BUILTIN_UNWIND_INIT */
6066 return garbage_collect_1 (end); 6054 return garbage_collect_1 (end);
6067} 6055}
6068 6056
@@ -7372,9 +7360,6 @@ init_alloc_once (void)
7372void 7360void
7373init_alloc (void) 7361init_alloc (void)
7374{ 7362{
7375#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
7376 setjmp_tested_p = longjmps_done = 0;
7377#endif
7378 Vgc_elapsed = make_float (0.0); 7363 Vgc_elapsed = make_float (0.0);
7379 gcs_done = 0; 7364 gcs_done = 0;
7380 7365
diff --git a/src/atimer.c b/src/atimer.c
index 7f099809d3c..5feb1f6777d 100644
--- a/src/atimer.c
+++ b/src/atimer.c
@@ -20,6 +20,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
20#include <stdio.h> 20#include <stdio.h>
21 21
22#include "lisp.h" 22#include "lisp.h"
23#include "keyboard.h"
23#include "syssignal.h" 24#include "syssignal.h"
24#include "systime.h" 25#include "systime.h"
25#include "atimer.h" 26#include "atimer.h"
diff --git a/src/buffer.c b/src/buffer.c
index 0a317ad7d98..713c1e5b944 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -420,19 +420,16 @@ followed by the rest of the buffers. */)
420} 420}
421 421
422/* Like Fassoc, but use Fstring_equal to compare 422/* Like Fassoc, but use Fstring_equal to compare
423 (which ignores text properties), 423 (which ignores text properties), and don't ever quit. */
424 and don't ever QUIT. */
425 424
426static Lisp_Object 425static Lisp_Object
427assoc_ignore_text_properties (register Lisp_Object key, Lisp_Object list) 426assoc_ignore_text_properties (Lisp_Object key, Lisp_Object list)
428{ 427{
429 register Lisp_Object tail; 428 Lisp_Object tail;
430 for (tail = list; CONSP (tail); tail = XCDR (tail)) 429 for (tail = list; CONSP (tail); tail = XCDR (tail))
431 { 430 {
432 register Lisp_Object elt, tem; 431 Lisp_Object elt = XCAR (tail);
433 elt = XCAR (tail); 432 if (!NILP (Fstring_equal (Fcar (elt), key)))
434 tem = Fstring_equal (Fcar (elt), key);
435 if (!NILP (tem))
436 return elt; 433 return elt;
437 } 434 }
438 return Qnil; 435 return Qnil;
diff --git a/src/bytecode.c b/src/bytecode.c
index a64bc171d14..0f7420c19ee 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -679,7 +679,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
679 { 679 {
680 quitcounter = 1; 680 quitcounter = 1;
681 maybe_gc (); 681 maybe_gc ();
682 QUIT; 682 maybe_quit ();
683 } 683 }
684 pc += op; 684 pc += op;
685 NEXT; 685 NEXT;
@@ -841,11 +841,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
841 { 841 {
842 Lisp_Object v2 = POP, v1 = TOP; 842 Lisp_Object v2 = POP, v1 = TOP;
843 CHECK_NUMBER (v1); 843 CHECK_NUMBER (v1);
844 EMACS_INT n = XINT (v1); 844 for (EMACS_INT n = XINT (v1); 0 < n && CONSP (v2); n--)
845 immediate_quit = true; 845 {
846 while (--n >= 0 && CONSP (v2)) 846 v2 = XCDR (v2);
847 v2 = XCDR (v2); 847 rarely_quit (n);
848 immediate_quit = false; 848 }
849 TOP = CAR (v2); 849 TOP = CAR (v2);
850 NEXT; 850 NEXT;
851 } 851 }
@@ -1275,11 +1275,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
1275 /* Exchange args and then do nth. */ 1275 /* Exchange args and then do nth. */
1276 Lisp_Object v2 = POP, v1 = TOP; 1276 Lisp_Object v2 = POP, v1 = TOP;
1277 CHECK_NUMBER (v2); 1277 CHECK_NUMBER (v2);
1278 EMACS_INT n = XINT (v2); 1278 for (EMACS_INT n = XINT (v2); 0 < n && CONSP (v1); n--)
1279 immediate_quit = true; 1279 {
1280 while (--n >= 0 && CONSP (v1)) 1280 v1 = XCDR (v1);
1281 v1 = XCDR (v1); 1281 rarely_quit (n);
1282 immediate_quit = false; 1282 }
1283 TOP = CAR (v1); 1283 TOP = CAR (v1);
1284 } 1284 }
1285 else 1285 else
diff --git a/src/callint.c b/src/callint.c
index 565fac8a451..d96454883cf 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -794,7 +794,7 @@ invoke it. If KEYS is omitted or nil, the return value of
794 } 794 }
795 unbind_to (speccount, Qnil); 795 unbind_to (speccount, Qnil);
796 796
797 QUIT; 797 maybe_quit ();
798 798
799 args[0] = Qfuncall_interactively; 799 args[0] = Qfuncall_interactively;
800 args[1] = function; 800 args[1] = function;
diff --git a/src/callproc.c b/src/callproc.c
index 90c15de2913..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 = 1; 201
202 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 = 0;
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 = 1;
730 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 = 0;
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 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 = 0;
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/category.c b/src/category.c
index e5d261c1cff..ff287a4af3d 100644
--- a/src/category.c
+++ b/src/category.c
@@ -67,7 +67,7 @@ hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
67 make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE), 67 make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
68 make_float (DEFAULT_REHASH_SIZE), 68 make_float (DEFAULT_REHASH_SIZE),
69 make_float (DEFAULT_REHASH_THRESHOLD), 69 make_float (DEFAULT_REHASH_THRESHOLD),
70 Qnil)); 70 Qnil, Qnil));
71 h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]); 71 h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
72 i = hash_lookup (h, category_set, &hash); 72 i = hash_lookup (h, category_set, &hash);
73 if (i >= 0) 73 if (i >= 0)
diff --git a/src/ccl.c b/src/ccl.c
index c172fc66811..90bd2f46794 100644
--- a/src/ccl.c
+++ b/src/ccl.c
@@ -1993,7 +1993,7 @@ programs. */)
1993 : 0); 1993 : 0);
1994 1994
1995 ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil); 1995 ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil);
1996 QUIT; 1996 maybe_quit ();
1997 if (ccl.status != CCL_STAT_SUCCESS) 1997 if (ccl.status != CCL_STAT_SUCCESS)
1998 error ("Error in CCL program at %dth code", ccl.ic); 1998 error ("Error in CCL program at %dth code", ccl.ic);
1999 1999
diff --git a/src/decompress.c b/src/decompress.c
index f6628d5ddd9..a53a66df187 100644
--- a/src/decompress.c
+++ b/src/decompress.c
@@ -186,7 +186,7 @@ This function can be called only in unibyte buffers. */)
186 decompressed = avail_out - stream.avail_out; 186 decompressed = avail_out - stream.avail_out;
187 insert_from_gap (decompressed, decompressed, 0); 187 insert_from_gap (decompressed, decompressed, 0);
188 unwind_data.nbytes += decompressed; 188 unwind_data.nbytes += decompressed;
189 QUIT; 189 maybe_quit ();
190 } 190 }
191 while (inflate_status == Z_OK); 191 while (inflate_status == Z_OK);
192 192
diff --git a/src/dired.c b/src/dired.c
index bf10f1710ff..5ea00fb8db4 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -139,7 +139,7 @@ read_dirent (DIR *dir, Lisp_Object dirname)
139#endif 139#endif
140 report_file_error ("Reading directory", dirname); 140 report_file_error ("Reading directory", dirname);
141 } 141 }
142 QUIT; 142 maybe_quit ();
143 } 143 }
144} 144}
145 145
@@ -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 = 1; 251 maybe_quit ();
252 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 = 0;
258
259 if (wanted) 256 if (wanted)
260 { 257 {
261 if (!NILP (full)) 258 if (!NILP (full))
@@ -508,7 +505,7 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
508 ptrdiff_t len = dirent_namelen (dp); 505 ptrdiff_t len = dirent_namelen (dp);
509 bool canexclude = 0; 506 bool canexclude = 0;
510 507
511 QUIT; 508 maybe_quit ();
512 if (len < SCHARS (encoded_file) 509 if (len < SCHARS (encoded_file)
513 || (scmp (dp->d_name, SSDATA (encoded_file), 510 || (scmp (dp->d_name, SSDATA (encoded_file),
514 SCHARS (encoded_file)) 511 SCHARS (encoded_file))
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 bee3bbc2cdd..4618164d008 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -2695,7 +2695,7 @@ called interactively, INHERIT is t. */)
2695 string[i] = str[i % len]; 2695 string[i] = str[i % len];
2696 while (n > stringlen) 2696 while (n > stringlen)
2697 { 2697 {
2698 QUIT; 2698 maybe_quit ();
2699 if (!NILP (inherit)) 2699 if (!NILP (inherit))
2700 insert_and_inherit (string, stringlen); 2700 insert_and_inherit (string, stringlen);
2701 else 2701 else
@@ -3060,8 +3060,6 @@ determines whether case is significant or ignored. */)
3060 characters, not just the bytes. */ 3060 characters, not just the bytes. */
3061 int c1, c2; 3061 int c1, c2;
3062 3062
3063 QUIT;
3064
3065 if (! NILP (BVAR (bp1, enable_multibyte_characters))) 3063 if (! NILP (BVAR (bp1, enable_multibyte_characters)))
3066 { 3064 {
3067 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte); 3065 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
@@ -3093,12 +3091,12 @@ determines whether case is significant or ignored. */)
3093 c1 = char_table_translate (trt, c1); 3091 c1 = char_table_translate (trt, c1);
3094 c2 = char_table_translate (trt, c2); 3092 c2 = char_table_translate (trt, c2);
3095 } 3093 }
3096 if (c1 < c2) 3094
3097 return make_number (- 1 - chars); 3095 if (c1 != c2)
3098 if (c1 > c2) 3096 return make_number (c1 < c2 ? -1 - chars : chars + 1);
3099 return make_number (chars + 1);
3100 3097
3101 chars++; 3098 chars++;
3099 rarely_quit (chars);
3102 } 3100 }
3103 3101
3104 /* The strings match as far as they go. 3102 /* The strings match as far as they go.
diff --git a/src/emacs-module.c b/src/emacs-module.c
index e22c7dc5b72..69fa5c8e64c 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -1016,7 +1016,7 @@ syms_of_module (void)
1016 = make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE), 1016 = make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE),
1017 make_float (DEFAULT_REHASH_SIZE), 1017 make_float (DEFAULT_REHASH_SIZE),
1018 make_float (DEFAULT_REHASH_THRESHOLD), 1018 make_float (DEFAULT_REHASH_THRESHOLD),
1019 Qnil); 1019 Qnil, Qnil);
1020 Funintern (Qmodule_refs_hash, Qnil); 1020 Funintern (Qmodule_refs_hash, Qnil);
1021 1021
1022 DEFSYM (Qmodule_environments, "module-environments"); 1022 DEFSYM (Qmodule_environments, "module-environments");
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 c05c8d8f8de..22b02b49521 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -856,11 +856,9 @@ usage: (let* VARLIST BODY...) */)
856 856
857 lexenv = Vinternal_interpreter_environment; 857 lexenv = Vinternal_interpreter_environment;
858 858
859 varlist = XCAR (args); 859 for (varlist = XCAR (args); CONSP (varlist); varlist = XCDR (varlist))
860 CHECK_LIST (varlist);
861 while (CONSP (varlist))
862 { 860 {
863 QUIT; 861 maybe_quit ();
864 862
865 elt = XCAR (varlist); 863 elt = XCAR (varlist);
866 if (SYMBOLP (elt)) 864 if (SYMBOLP (elt))
@@ -894,9 +892,8 @@ usage: (let* VARLIST BODY...) */)
894 } 892 }
895 else 893 else
896 specbind (var, val); 894 specbind (var, val);
897
898 varlist = XCDR (varlist);
899 } 895 }
896 CHECK_LIST_END (varlist, XCAR (args));
900 897
901 val = Fprogn (XCDR (args)); 898 val = Fprogn (XCDR (args));
902 return unbind_to (count, val); 899 return unbind_to (count, val);
@@ -928,7 +925,7 @@ usage: (let VARLIST BODY...) */)
928 925
929 for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) 926 for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
930 { 927 {
931 QUIT; 928 maybe_quit ();
932 elt = XCAR (varlist); 929 elt = XCAR (varlist);
933 if (SYMBOLP (elt)) 930 if (SYMBOLP (elt))
934 temps [argnum++] = Qnil; 931 temps [argnum++] = Qnil;
@@ -981,7 +978,7 @@ usage: (while TEST BODY...) */)
981 body = XCDR (args); 978 body = XCDR (args);
982 while (!NILP (eval_sub (test))) 979 while (!NILP (eval_sub (test)))
983 { 980 {
984 QUIT; 981 maybe_quit ();
985 prog_ignore (body); 982 prog_ignore (body);
986 } 983 }
987 984
@@ -1014,7 +1011,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */)
1014 until we get a symbol that is not an alias. */ 1011 until we get a symbol that is not an alias. */
1015 while (SYMBOLP (def)) 1012 while (SYMBOLP (def))
1016 { 1013 {
1017 QUIT; 1014 maybe_quit ();
1018 sym = def; 1015 sym = def;
1019 tem = Fassq (sym, environment); 1016 tem = Fassq (sym, environment);
1020 if (NILP (tem)) 1017 if (NILP (tem))
@@ -1134,7 +1131,6 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
1134 /* Restore certain special C variables. */ 1131 /* Restore certain special C variables. */
1135 set_poll_suppress_count (catch->poll_suppress_count); 1132 set_poll_suppress_count (catch->poll_suppress_count);
1136 unblock_input_to (catch->interrupt_input_blocked); 1133 unblock_input_to (catch->interrupt_input_blocked);
1137 immediate_quit = 0;
1138 1134
1139 do 1135 do
1140 { 1136 {
@@ -1453,7 +1449,7 @@ static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object);
1453static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, 1449static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig,
1454 Lisp_Object data); 1450 Lisp_Object data);
1455 1451
1456void 1452static void
1457process_quit_flag (void) 1453process_quit_flag (void)
1458{ 1454{
1459 Lisp_Object flag = Vquit_flag; 1455 Lisp_Object flag = Vquit_flag;
@@ -1465,6 +1461,28 @@ process_quit_flag (void)
1465 quit (); 1461 quit ();
1466} 1462}
1467 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
1477void
1478maybe_quit (void)
1479{
1480 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
1481 process_quit_flag ();
1482 else if (pending_signals)
1483 process_pending_signals ();
1484}
1485
1468DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0, 1486DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
1469 doc: /* Signal an error. Args are ERROR-SYMBOL and associated DATA. 1487 doc: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1470This function does not return. 1488This function does not return.
@@ -1508,10 +1526,9 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
1508 Lisp_Object string; 1526 Lisp_Object string;
1509 Lisp_Object real_error_symbol 1527 Lisp_Object real_error_symbol
1510 = (NILP (error_symbol) ? Fcar (data) : error_symbol); 1528 = (NILP (error_symbol) ? Fcar (data) : error_symbol);
1511 register Lisp_Object clause = Qnil; 1529 Lisp_Object clause = Qnil;
1512 struct handler *h; 1530 struct handler *h;
1513 1531
1514 immediate_quit = 0;
1515 if (gc_in_progress || waiting_for_input) 1532 if (gc_in_progress || waiting_for_input)
1516 emacs_abort (); 1533 emacs_abort ();
1517 1534
@@ -2129,7 +2146,7 @@ eval_sub (Lisp_Object form)
2129 if (!CONSP (form)) 2146 if (!CONSP (form))
2130 return form; 2147 return form;
2131 2148
2132 QUIT; 2149 maybe_quit ();
2133 2150
2134 maybe_gc (); 2151 maybe_gc ();
2135 2152
@@ -2715,7 +2732,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2715 Lisp_Object val; 2732 Lisp_Object val;
2716 ptrdiff_t count; 2733 ptrdiff_t count;
2717 2734
2718 QUIT; 2735 maybe_quit ();
2719 2736
2720 if (++lisp_eval_depth > max_lisp_eval_depth) 2737 if (++lisp_eval_depth > max_lisp_eval_depth)
2721 { 2738 {
@@ -2960,7 +2977,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
2960 bool previous_optional_or_rest = false; 2977 bool previous_optional_or_rest = false;
2961 for (; CONSP (syms_left); syms_left = XCDR (syms_left)) 2978 for (; CONSP (syms_left); syms_left = XCDR (syms_left))
2962 { 2979 {
2963 QUIT; 2980 maybe_quit ();
2964 2981
2965 next = XCAR (syms_left); 2982 next = XCAR (syms_left);
2966 if (!SYMBOLP (next)) 2983 if (!SYMBOLP (next))
@@ -3098,7 +3115,7 @@ lambda_arity (Lisp_Object fun)
3098 if (EQ (XCAR (fun), Qclosure)) 3115 if (EQ (XCAR (fun), Qclosure))
3099 { 3116 {
3100 fun = XCDR (fun); /* Drop `closure'. */ 3117 fun = XCDR (fun); /* Drop `closure'. */
3101 CHECK_LIST_CONS (fun, fun); 3118 CHECK_CONS (fun);
3102 } 3119 }
3103 syms_left = XCDR (fun); 3120 syms_left = XCDR (fun);
3104 if (CONSP (syms_left)) 3121 if (CONSP (syms_left))
diff --git a/src/fileio.c b/src/fileio.c
index 8c8cba9e49c..38400623793 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -316,7 +316,7 @@ use the standard functions without calling themselves recursively. */)
316 } 316 }
317 } 317 }
318 318
319 QUIT; 319 maybe_quit ();
320 } 320 }
321 return result; 321 return result;
322} 322}
@@ -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 = 1;
1964 ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0); 1963 ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0);
1965 immediate_quit = 0;
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,8 +2022,7 @@ permissions. */)
2024 oldsize = out_st.st_size; 2022 oldsize = out_st.st_size;
2025 } 2023 }
2026 2024
2027 immediate_quit = 1; 2025 maybe_quit ();
2028 QUIT;
2029 2026
2030 if (clone_file (ofd, ifd)) 2027 if (clone_file (ofd, ifd))
2031 newsize = st.st_size; 2028 newsize = st.st_size;
@@ -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 = 0;
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. */
@@ -2682,7 +2677,7 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
2682 2677
2683DEFUN ("access-file", Faccess_file, Saccess_file, 2, 2, 0, 2678DEFUN ("access-file", Faccess_file, Saccess_file, 2, 2, 0,
2684 doc: /* Access file FILENAME, and get an error if that does not work. 2679 doc: /* Access file FILENAME, and get an error if that does not work.
2685The second argument STRING is used in the error message. 2680The second argument STRING is prepended to the error message.
2686If there is no error, returns nil. */) 2681If there is no error, returns nil. */)
2687 (Lisp_Object filename, Lisp_Object string) 2682 (Lisp_Object filename, Lisp_Object string)
2688{ 2683{
@@ -2815,7 +2810,17 @@ really is a readable and searchable directory. */)
2815 if (!NILP (handler)) 2810 if (!NILP (handler))
2816 { 2811 {
2817 Lisp_Object r = call2 (handler, Qfile_accessible_directory_p, absname); 2812 Lisp_Object r = call2 (handler, Qfile_accessible_directory_p, absname);
2818 errno = 0; 2813
2814 /* Set errno in case the handler failed. EACCES might be a lie
2815 (e.g., the directory might not exist, or be a regular file),
2816 but at least it does TRT in the "usual" case of an existing
2817 directory that is not accessible by the current user, and
2818 avoids reporting "Success" for a failed operation. Perhaps
2819 someday we can fix this in a better way, by improving
2820 file-accessible-directory-p's API; see Bug#25419. */
2821 if (!EQ (r, Qt))
2822 errno = EACCES;
2823
2819 return r; 2824 return r;
2820 } 2825 }
2821 2826
@@ -3391,15 +3396,10 @@ decide_coding_unwind (Lisp_Object unwind_data)
3391static Lisp_Object 3396static Lisp_Object
3392read_non_regular (Lisp_Object state) 3397read_non_regular (Lisp_Object state)
3393{ 3398{
3394 int nbytes; 3399 int nbytes = emacs_read_quit (XSAVE_INTEGER (state, 0),
3395 3400 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
3396 immediate_quit = 1; 3401 + XSAVE_INTEGER (state, 1)),
3397 QUIT; 3402 XSAVE_INTEGER (state, 2));
3398 nbytes = emacs_read (XSAVE_INTEGER (state, 0),
3399 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
3400 + XSAVE_INTEGER (state, 1)),
3401 XSAVE_INTEGER (state, 2));
3402 immediate_quit = 0;
3403 /* Fast recycle this object for the likely next call. */ 3403 /* Fast recycle this object for the likely next call. */
3404 free_misc (state); 3404 free_misc (state);
3405 return make_number (nbytes); 3405 return make_number (nbytes);
@@ -3743,17 +3743,17 @@ by calling `format-decode', which see. */)
3743 int nread; 3743 int nread;
3744 3744
3745 if (st.st_size <= (1024 * 4)) 3745 if (st.st_size <= (1024 * 4))
3746 nread = emacs_read (fd, read_buf, 1024 * 4); 3746 nread = emacs_read_quit (fd, read_buf, 1024 * 4);
3747 else 3747 else
3748 { 3748 {
3749 nread = emacs_read (fd, read_buf, 1024); 3749 nread = emacs_read_quit (fd, read_buf, 1024);
3750 if (nread == 1024) 3750 if (nread == 1024)
3751 { 3751 {
3752 int ntail; 3752 int ntail;
3753 if (lseek (fd, - (1024 * 3), SEEK_END) < 0) 3753 if (lseek (fd, - (1024 * 3), SEEK_END) < 0)
3754 report_file_error ("Setting file position", 3754 report_file_error ("Setting file position",
3755 orig_filename); 3755 orig_filename);
3756 ntail = emacs_read (fd, read_buf + nread, 1024 * 3); 3756 ntail = emacs_read_quit (fd, read_buf + nread, 1024 * 3);
3757 nread = ntail < 0 ? ntail : nread + ntail; 3757 nread = ntail < 0 ? ntail : nread + ntail;
3758 } 3758 }
3759 } 3759 }
@@ -3858,15 +3858,11 @@ by calling `format-decode', which see. */)
3858 report_file_error ("Setting file position", orig_filename); 3858 report_file_error ("Setting file position", orig_filename);
3859 } 3859 }
3860 3860
3861 immediate_quit = 1;
3862 QUIT;
3863 /* Count how many chars at the start of the file 3861 /* Count how many chars at the start of the file
3864 match the text at the beginning of the buffer. */ 3862 match the text at the beginning of the buffer. */
3865 while (1) 3863 while (true)
3866 { 3864 {
3867 int nread, bufpos; 3865 int nread = emacs_read_quit (fd, read_buf, sizeof read_buf);
3868
3869 nread = emacs_read (fd, read_buf, sizeof read_buf);
3870 if (nread < 0) 3866 if (nread < 0)
3871 report_file_error ("Read error", orig_filename); 3867 report_file_error ("Read error", orig_filename);
3872 else if (nread == 0) 3868 else if (nread == 0)
@@ -3888,7 +3884,7 @@ by calling `format-decode', which see. */)
3888 break; 3884 break;
3889 } 3885 }
3890 3886
3891 bufpos = 0; 3887 int bufpos = 0;
3892 while (bufpos < nread && same_at_start < ZV_BYTE 3888 while (bufpos < nread && same_at_start < ZV_BYTE
3893 && FETCH_BYTE (same_at_start) == read_buf[bufpos]) 3889 && FETCH_BYTE (same_at_start) == read_buf[bufpos])
3894 same_at_start++, bufpos++; 3890 same_at_start++, bufpos++;
@@ -3897,7 +3893,6 @@ by calling `format-decode', which see. */)
3897 if (bufpos != nread) 3893 if (bufpos != nread)
3898 break; 3894 break;
3899 } 3895 }
3900 immediate_quit = false;
3901 /* If the file matches the buffer completely, 3896 /* If the file matches the buffer completely,
3902 there's no need to replace anything. */ 3897 there's no need to replace anything. */
3903 if (same_at_start - BEGV_BYTE == end_offset - beg_offset) 3898 if (same_at_start - BEGV_BYTE == end_offset - beg_offset)
@@ -3909,8 +3904,7 @@ by calling `format-decode', which see. */)
3909 del_range_1 (same_at_start, same_at_end, 0, 0); 3904 del_range_1 (same_at_start, same_at_end, 0, 0);
3910 goto handled; 3905 goto handled;
3911 } 3906 }
3912 immediate_quit = true; 3907
3913 QUIT;
3914 /* Count how many chars at the end of the file 3908 /* Count how many chars at the end of the file
3915 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
3916 already found that decoding is necessary, don't waste time. */ 3910 already found that decoding is necessary, don't waste time. */
@@ -3932,7 +3926,8 @@ by calling `format-decode', which see. */)
3932 total_read = nread = 0; 3926 total_read = nread = 0;
3933 while (total_read < trial) 3927 while (total_read < trial)
3934 { 3928 {
3935 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);
3936 if (nread < 0) 3931 if (nread < 0)
3937 report_file_error ("Read error", orig_filename); 3932 report_file_error ("Read error", orig_filename);
3938 else if (nread == 0) 3933 else if (nread == 0)
@@ -3967,7 +3962,6 @@ by calling `format-decode', which see. */)
3967 if (nread == 0) 3962 if (nread == 0)
3968 break; 3963 break;
3969 } 3964 }
3970 immediate_quit = 0;
3971 3965
3972 if (! giveup_match_end) 3966 if (! giveup_match_end)
3973 { 3967 {
@@ -4059,18 +4053,13 @@ by calling `format-decode', which see. */)
4059 inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */ 4053 inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */
4060 unprocessed = 0; /* Bytes not processed in previous loop. */ 4054 unprocessed = 0; /* Bytes not processed in previous loop. */
4061 4055
4062 while (1) 4056 while (true)
4063 { 4057 {
4064 /* 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
4065 quitting while reading a huge file. */ 4059 quitting while reading a huge file. */
4066 4060
4067 /* Allow quitting out of the actual I/O. */ 4061 this = emacs_read_quit (fd, read_buf + unprocessed,
4068 immediate_quit = 1; 4062 READ_BUF_SIZE - unprocessed);
4069 QUIT;
4070 this = emacs_read (fd, read_buf + unprocessed,
4071 READ_BUF_SIZE - unprocessed);
4072 immediate_quit = 0;
4073
4074 if (this <= 0) 4063 if (this <= 0)
4075 break; 4064 break;
4076 4065
@@ -4284,13 +4273,10 @@ by calling `format-decode', which see. */)
4284 /* 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
4285 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
4286 here doesn't do any harm. */ 4275 here doesn't do any harm. */
4287 immediate_quit = 1; 4276 this = emacs_read_quit (fd,
4288 QUIT; 4277 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
4289 this = emacs_read (fd, 4278 + inserted),
4290 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE 4279 trytry);
4291 + inserted),
4292 trytry);
4293 immediate_quit = 0;
4294 } 4280 }
4295 4281
4296 if (this <= 0) 4282 if (this <= 0)
@@ -4602,7 +4588,7 @@ by calling `format-decode', which see. */)
4602 } 4588 }
4603 } 4589 }
4604 4590
4605 QUIT; 4591 maybe_quit ();
4606 p = XCDR (p); 4592 p = XCDR (p);
4607 } 4593 }
4608 4594
@@ -4992,8 +4978,6 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
4992 } 4978 }
4993 } 4979 }
4994 4980
4995 immediate_quit = 1;
4996
4997 if (STRINGP (start)) 4981 if (STRINGP (start))
4998 ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding); 4982 ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding);
4999 else if (XINT (start) != XINT (end)) 4983 else if (XINT (start) != XINT (end))
@@ -5016,8 +5000,6 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
5016 save_errno = errno; 5000 save_errno = errno;
5017 } 5001 }
5018 5002
5019 immediate_quit = 0;
5020
5021 /* fsync is not crucial for temporary files. Nor for auto-save 5003 /* fsync is not crucial for temporary files. Nor for auto-save
5022 files, since they might lose some work anyway. */ 5004 files, since they might lose some work anyway. */
5023 if (open_and_close_file && !auto_saving && !write_region_inhibit_fsync) 5005 if (open_and_close_file && !auto_saving && !write_region_inhibit_fsync)
@@ -5407,7 +5389,7 @@ e_write (int desc, Lisp_Object string, ptrdiff_t start, ptrdiff_t end,
5407 : (STRINGP (coding->dst_object) 5389 : (STRINGP (coding->dst_object)
5408 ? SSDATA (coding->dst_object) 5390 ? SSDATA (coding->dst_object)
5409 : (char *) BYTE_POS_ADDR (coding->dst_pos_byte))); 5391 : (char *) BYTE_POS_ADDR (coding->dst_pos_byte)));
5410 coding->produced -= emacs_write_sig (desc, buf, coding->produced); 5392 coding->produced -= emacs_write_quit (desc, buf, coding->produced);
5411 5393
5412 if (coding->raw_destination) 5394 if (coding->raw_destination)
5413 { 5395 {
diff --git a/src/filelock.c b/src/filelock.c
index 886ab61c7aa..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;
@@ -505,7 +502,7 @@ read_lock_data (char *lfname, char lfinfo[MAX_LFINFO + 1])
505 /* readlinkat saw a non-symlink, but emacs_open saw a symlink. 502 /* readlinkat saw a non-symlink, but emacs_open saw a symlink.
506 The former must have been removed and replaced by the latter. 503 The former must have been removed and replaced by the latter.
507 Try again. */ 504 Try again. */
508 QUIT; 505 maybe_quit ();
509 } 506 }
510 507
511 return nbytes; 508 return nbytes;
diff --git a/src/fns.c b/src/fns.c
index 00fa65886f0..ac7c1f265a4 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -34,6 +34,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
34#include "buffer.h" 34#include "buffer.h"
35#include "intervals.h" 35#include "intervals.h"
36#include "window.h" 36#include "window.h"
37#include "puresize.h"
37 38
38static void sort_vector_copy (Lisp_Object, ptrdiff_t, 39static void sort_vector_copy (Lisp_Object, ptrdiff_t,
39 Lisp_Object *restrict, Lisp_Object *restrict); 40 Lisp_Object *restrict, Lisp_Object *restrict);
@@ -83,18 +84,8 @@ See Info node `(elisp)Random Numbers' for more details. */)
83 return make_number (val); 84 return make_number (val);
84} 85}
85 86
86/* Heuristic on how many iterations of a tight loop can be safely done
87 before it's time to do a QUIT. This must be a power of 2. */
88enum { QUIT_COUNT_HEURISTIC = 1 << 16 };
89
90/* Random data-structure functions. */ 87/* Random data-structure functions. */
91 88
92static void
93CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
94{
95 CHECK_TYPE (NILP (x), Qlistp, y);
96}
97
98DEFUN ("length", Flength, Slength, 1, 1, 0, 89DEFUN ("length", Flength, Slength, 1, 1, 0,
99 doc: /* Return the length of vector, list or string SEQUENCE. 90 doc: /* Return the length of vector, list or string SEQUENCE.
100A byte-code function object is also allowed. 91A byte-code function object is also allowed.
@@ -126,7 +117,7 @@ To get the number of bytes, use `string-bytes'. */)
126 { 117 {
127 if (MOST_POSITIVE_FIXNUM < i) 118 if (MOST_POSITIVE_FIXNUM < i)
128 error ("List too long"); 119 error ("List too long");
129 QUIT; 120 maybe_quit ();
130 } 121 }
131 sequence = XCDR (sequence); 122 sequence = XCDR (sequence);
132 } 123 }
@@ -172,7 +163,7 @@ which is at least the number of distinct elements. */)
172 halftail = XCDR (halftail); 163 halftail = XCDR (halftail);
173 if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0) 164 if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0)
174 { 165 {
175 QUIT; 166 maybe_quit ();
176 if (lolen == 0) 167 if (lolen == 0)
177 hilen += UINTMAX_MAX + 1.0; 168 hilen += UINTMAX_MAX + 1.0;
178 } 169 }
@@ -1202,17 +1193,12 @@ are shared, however.
1202Elements of ALIST that are not conses are also shared. */) 1193Elements of ALIST that are not conses are also shared. */)
1203 (Lisp_Object alist) 1194 (Lisp_Object alist)
1204{ 1195{
1205 register Lisp_Object tem;
1206
1207 CHECK_LIST (alist);
1208 if (NILP (alist)) 1196 if (NILP (alist))
1209 return alist; 1197 return alist;
1210 alist = concat (1, &alist, Lisp_Cons, 0); 1198 alist = concat (1, &alist, Lisp_Cons, false);
1211 for (tem = alist; CONSP (tem); tem = XCDR (tem)) 1199 for (Lisp_Object tem = alist; !NILP (tem); tem = XCDR (tem))
1212 { 1200 {
1213 register Lisp_Object car; 1201 Lisp_Object car = XCAR (tem);
1214 car = XCAR (tem);
1215
1216 if (CONSP (car)) 1202 if (CONSP (car))
1217 XSETCAR (tem, Fcons (XCAR (car), XCDR (car))); 1203 XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
1218 } 1204 }
@@ -1356,16 +1342,19 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1356 doc: /* Take cdr N times on LIST, return the result. */) 1342 doc: /* Take cdr N times on LIST, return the result. */)
1357 (Lisp_Object n, Lisp_Object list) 1343 (Lisp_Object n, Lisp_Object list)
1358{ 1344{
1359 EMACS_INT i, num;
1360 CHECK_NUMBER (n); 1345 CHECK_NUMBER (n);
1361 num = XINT (n); 1346 Lisp_Object tail = list;
1362 for (i = 0; i < num && !NILP (list); i++) 1347 for (EMACS_INT num = XINT (n); 0 < num; num--)
1363 { 1348 {
1364 QUIT; 1349 if (! CONSP (tail))
1365 CHECK_LIST_CONS (list, list); 1350 {
1366 list = XCDR (list); 1351 CHECK_LIST_END (tail, list);
1352 return Qnil;
1353 }
1354 tail = XCDR (tail);
1355 rarely_quit (num);
1367 } 1356 }
1368 return list; 1357 return tail;
1369} 1358}
1370 1359
1371DEFUN ("nth", Fnth, Snth, 2, 2, 0, 1360DEFUN ("nth", Fnth, Snth, 2, 2, 0,
@@ -1392,66 +1381,55 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0,
1392DEFUN ("member", Fmember, Smember, 2, 2, 0, 1381DEFUN ("member", Fmember, Smember, 2, 2, 0,
1393 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. 1382 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1394The value is actually the tail of LIST whose car is ELT. */) 1383The value is actually the tail of LIST whose car is ELT. */)
1395 (register Lisp_Object elt, Lisp_Object list) 1384 (Lisp_Object elt, Lisp_Object list)
1396{ 1385{
1397 register Lisp_Object tail; 1386 unsigned short int quit_count = 0;
1398 for (tail = list; !NILP (tail); tail = XCDR (tail)) 1387 Lisp_Object tail;
1388 for (tail = list; CONSP (tail); tail = XCDR (tail))
1399 { 1389 {
1400 register Lisp_Object tem; 1390 if (! NILP (Fequal (elt, XCAR (tail))))
1401 CHECK_LIST_CONS (tail, list);
1402 tem = XCAR (tail);
1403 if (! NILP (Fequal (elt, tem)))
1404 return tail; 1391 return tail;
1405 QUIT; 1392 rarely_quit (++quit_count);
1406 } 1393 }
1394 CHECK_LIST_END (tail, list);
1407 return Qnil; 1395 return Qnil;
1408} 1396}
1409 1397
1410DEFUN ("memq", Fmemq, Smemq, 2, 2, 0, 1398DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1411 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'. 1399 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1412The value is actually the tail of LIST whose car is ELT. */) 1400The value is actually the tail of LIST whose car is ELT. */)
1413 (register Lisp_Object elt, Lisp_Object list) 1401 (Lisp_Object elt, Lisp_Object list)
1414{ 1402{
1415 while (1) 1403 unsigned short int quit_count = 0;
1404 Lisp_Object tail;
1405 for (tail = list; CONSP (tail); tail = XCDR (tail))
1416 { 1406 {
1417 if (!CONSP (list) || EQ (XCAR (list), elt)) 1407 if (EQ (XCAR (tail), elt))
1418 break; 1408 return tail;
1419 1409 rarely_quit (++quit_count);
1420 list = XCDR (list);
1421 if (!CONSP (list) || EQ (XCAR (list), elt))
1422 break;
1423
1424 list = XCDR (list);
1425 if (!CONSP (list) || EQ (XCAR (list), elt))
1426 break;
1427
1428 list = XCDR (list);
1429 QUIT;
1430 } 1410 }
1431 1411 CHECK_LIST_END (tail, list);
1432 CHECK_LIST (list); 1412 return Qnil;
1433 return list;
1434} 1413}
1435 1414
1436DEFUN ("memql", Fmemql, Smemql, 2, 2, 0, 1415DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
1437 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'. 1416 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1438The value is actually the tail of LIST whose car is ELT. */) 1417The value is actually the tail of LIST whose car is ELT. */)
1439 (register Lisp_Object elt, Lisp_Object list) 1418 (Lisp_Object elt, Lisp_Object list)
1440{ 1419{
1441 register Lisp_Object tail;
1442
1443 if (!FLOATP (elt)) 1420 if (!FLOATP (elt))
1444 return Fmemq (elt, list); 1421 return Fmemq (elt, list);
1445 1422
1446 for (tail = list; !NILP (tail); tail = XCDR (tail)) 1423 unsigned short int quit_count = 0;
1424 Lisp_Object tail;
1425 for (tail = list; CONSP (tail); tail = XCDR (tail))
1447 { 1426 {
1448 register Lisp_Object tem; 1427 Lisp_Object tem = XCAR (tail);
1449 CHECK_LIST_CONS (tail, list);
1450 tem = XCAR (tail);
1451 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil)) 1428 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil))
1452 return tail; 1429 return tail;
1453 QUIT; 1430 rarely_quit (++quit_count);
1454 } 1431 }
1432 CHECK_LIST_END (tail, list);
1455 return Qnil; 1433 return Qnil;
1456} 1434}
1457 1435
@@ -1461,44 +1439,28 @@ The value is actually the first element of LIST whose car is KEY.
1461Elements of LIST that are not conses are ignored. */) 1439Elements of LIST that are not conses are ignored. */)
1462 (Lisp_Object key, Lisp_Object list) 1440 (Lisp_Object key, Lisp_Object list)
1463{ 1441{
1464 while (1) 1442 unsigned short int quit_count = 0;
1443 Lisp_Object tail;
1444 for (tail = list; CONSP (tail); tail = XCDR (tail))
1465 { 1445 {
1466 if (!CONSP (list) 1446 if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
1467 || (CONSP (XCAR (list)) 1447 return XCAR (tail);
1468 && EQ (XCAR (XCAR (list)), key))) 1448 rarely_quit (++quit_count);
1469 break;
1470
1471 list = XCDR (list);
1472 if (!CONSP (list)
1473 || (CONSP (XCAR (list))
1474 && EQ (XCAR (XCAR (list)), key)))
1475 break;
1476
1477 list = XCDR (list);
1478 if (!CONSP (list)
1479 || (CONSP (XCAR (list))
1480 && EQ (XCAR (XCAR (list)), key)))
1481 break;
1482
1483 list = XCDR (list);
1484 QUIT;
1485 } 1449 }
1486 1450 CHECK_LIST_END (tail, list);
1487 return CAR (list); 1451 return Qnil;
1488} 1452}
1489 1453
1490/* Like Fassq but never report an error and do not allow quits. 1454/* Like Fassq but never report an error and do not allow quits.
1491 Use only on lists known never to be circular. */ 1455 Use only on objects known to be non-circular lists. */
1492 1456
1493Lisp_Object 1457Lisp_Object
1494assq_no_quit (Lisp_Object key, Lisp_Object list) 1458assq_no_quit (Lisp_Object key, Lisp_Object list)
1495{ 1459{
1496 while (CONSP (list) 1460 for (; ! NILP (list); list = XCDR (list))
1497 && (!CONSP (XCAR (list)) 1461 if (CONSP (XCAR (list)) && EQ (XCAR (XCAR (list)), key))
1498 || !EQ (XCAR (XCAR (list)), key))) 1462 return XCAR (list);
1499 list = XCDR (list); 1463 return Qnil;
1500
1501 return CAR_SAFE (list);
1502} 1464}
1503 1465
1504DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0, 1466DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
@@ -1506,81 +1468,51 @@ DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1506The value is actually the first element of LIST whose car equals KEY. */) 1468The value is actually the first element of LIST whose car equals KEY. */)
1507 (Lisp_Object key, Lisp_Object list) 1469 (Lisp_Object key, Lisp_Object list)
1508{ 1470{
1509 Lisp_Object car; 1471 unsigned short int quit_count = 0;
1510 1472 Lisp_Object tail;
1511 while (1) 1473 for (tail = list; CONSP (tail); tail = XCDR (tail))
1512 { 1474 {
1513 if (!CONSP (list) 1475 Lisp_Object car = XCAR (tail);
1514 || (CONSP (XCAR (list)) 1476 if (CONSP (car)
1515 && (car = XCAR (XCAR (list)), 1477 && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key))))
1516 EQ (car, key) || !NILP (Fequal (car, key))))) 1478 return car;
1517 break; 1479 rarely_quit (++quit_count);
1518
1519 list = XCDR (list);
1520 if (!CONSP (list)
1521 || (CONSP (XCAR (list))
1522 && (car = XCAR (XCAR (list)),
1523 EQ (car, key) || !NILP (Fequal (car, key)))))
1524 break;
1525
1526 list = XCDR (list);
1527 if (!CONSP (list)
1528 || (CONSP (XCAR (list))
1529 && (car = XCAR (XCAR (list)),
1530 EQ (car, key) || !NILP (Fequal (car, key)))))
1531 break;
1532
1533 list = XCDR (list);
1534 QUIT;
1535 } 1480 }
1536 1481 CHECK_LIST_END (tail, list);
1537 return CAR (list); 1482 return Qnil;
1538} 1483}
1539 1484
1540/* Like Fassoc but never report an error and do not allow quits. 1485/* Like Fassoc but never report an error and do not allow quits.
1541 Use only on lists known never to be circular. */ 1486 Use only on objects known to be non-circular lists. */
1542 1487
1543Lisp_Object 1488Lisp_Object
1544assoc_no_quit (Lisp_Object key, Lisp_Object list) 1489assoc_no_quit (Lisp_Object key, Lisp_Object list)
1545{ 1490{
1546 while (CONSP (list) 1491 for (; ! NILP (list); list = XCDR (list))
1547 && (!CONSP (XCAR (list)) 1492 {
1548 || (!EQ (XCAR (XCAR (list)), key) 1493 Lisp_Object car = XCAR (list);
1549 && NILP (Fequal (XCAR (XCAR (list)), key))))) 1494 if (CONSP (car)
1550 list = XCDR (list); 1495 && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key))))
1551 1496 return car;
1552 return CONSP (list) ? XCAR (list) : Qnil; 1497 }
1498 return Qnil;
1553} 1499}
1554 1500
1555DEFUN ("rassq", Frassq, Srassq, 2, 2, 0, 1501DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1556 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST. 1502 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1557The 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. */)
1558 (register Lisp_Object key, Lisp_Object list) 1504 (Lisp_Object key, Lisp_Object list)
1559{ 1505{
1560 while (1) 1506 unsigned short int quit_count = 0;
1507 Lisp_Object tail;
1508 for (tail = list; CONSP (tail); tail = XCDR (tail))
1561 { 1509 {
1562 if (!CONSP (list) 1510 if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key))
1563 || (CONSP (XCAR (list)) 1511 return XCAR (tail);
1564 && EQ (XCDR (XCAR (list)), key))) 1512 rarely_quit (++quit_count);
1565 break;
1566
1567 list = XCDR (list);
1568 if (!CONSP (list)
1569 || (CONSP (XCAR (list))
1570 && EQ (XCDR (XCAR (list)), key)))
1571 break;
1572
1573 list = XCDR (list);
1574 if (!CONSP (list)
1575 || (CONSP (XCAR (list))
1576 && EQ (XCDR (XCAR (list)), key)))
1577 break;
1578
1579 list = XCDR (list);
1580 QUIT;
1581 } 1513 }
1582 1514 CHECK_LIST_END (tail, list);
1583 return CAR (list); 1515 return Qnil;
1584} 1516}
1585 1517
1586DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, 1518DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
@@ -1588,35 +1520,18 @@ DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1588The value is actually the first element of LIST whose cdr equals KEY. */) 1520The value is actually the first element of LIST whose cdr equals KEY. */)
1589 (Lisp_Object key, Lisp_Object list) 1521 (Lisp_Object key, Lisp_Object list)
1590{ 1522{
1591 Lisp_Object cdr; 1523 unsigned short int quit_count = 0;
1592 1524 Lisp_Object tail;
1593 while (1) 1525 for (tail = list; CONSP (tail); tail = XCDR (tail))
1594 { 1526 {
1595 if (!CONSP (list) 1527 Lisp_Object car = XCAR (tail);
1596 || (CONSP (XCAR (list)) 1528 if (CONSP (car)
1597 && (cdr = XCDR (XCAR (list)), 1529 && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key))))
1598 EQ (cdr, key) || !NILP (Fequal (cdr, key))))) 1530 return car;
1599 break; 1531 rarely_quit (++quit_count);
1600
1601 list = XCDR (list);
1602 if (!CONSP (list)
1603 || (CONSP (XCAR (list))
1604 && (cdr = XCDR (XCAR (list)),
1605 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1606 break;
1607
1608 list = XCDR (list);
1609 if (!CONSP (list)
1610 || (CONSP (XCAR (list))
1611 && (cdr = XCDR (XCAR (list)),
1612 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1613 break;
1614
1615 list = XCDR (list);
1616 QUIT;
1617 } 1532 }
1618 1533 CHECK_LIST_END (tail, list);
1619 return CAR (list); 1534 return Qnil;
1620} 1535}
1621 1536
1622DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0, 1537DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
@@ -1647,6 +1562,7 @@ argument. */)
1647 else 1562 else
1648 prev = tail; 1563 prev = tail;
1649 } 1564 }
1565 CHECK_LIST_END (tail, list);
1650 return list; 1566 return list;
1651} 1567}
1652 1568
@@ -1754,12 +1670,11 @@ changing the value of a sequence `foo'. */)
1754 } 1670 }
1755 else 1671 else
1756 { 1672 {
1673 unsigned short int quit_count = 0;
1757 Lisp_Object tail, prev; 1674 Lisp_Object tail, prev;
1758 1675
1759 for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail)) 1676 for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
1760 { 1677 {
1761 CHECK_LIST_CONS (tail, seq);
1762
1763 if (!NILP (Fequal (elt, XCAR (tail)))) 1678 if (!NILP (Fequal (elt, XCAR (tail))))
1764 { 1679 {
1765 if (NILP (prev)) 1680 if (NILP (prev))
@@ -1769,8 +1684,9 @@ changing the value of a sequence `foo'. */)
1769 } 1684 }
1770 else 1685 else
1771 prev = tail; 1686 prev = tail;
1772 QUIT; 1687 rarely_quit (++quit_count);
1773 } 1688 }
1689 CHECK_LIST_END (tail, seq);
1774 } 1690 }
1775 1691
1776 return seq; 1692 return seq;
@@ -1788,16 +1704,17 @@ This function may destructively modify SEQ to produce the value. */)
1788 return Freverse (seq); 1704 return Freverse (seq);
1789 else if (CONSP (seq)) 1705 else if (CONSP (seq))
1790 { 1706 {
1707 unsigned short int quit_count = 0;
1791 Lisp_Object prev, tail, next; 1708 Lisp_Object prev, tail, next;
1792 1709
1793 for (prev = Qnil, tail = seq; !NILP (tail); tail = next) 1710 for (prev = Qnil, tail = seq; CONSP (tail); tail = next)
1794 { 1711 {
1795 QUIT;
1796 CHECK_LIST_CONS (tail, tail);
1797 next = XCDR (tail); 1712 next = XCDR (tail);
1798 Fsetcdr (tail, prev); 1713 Fsetcdr (tail, prev);
1799 prev = tail; 1714 prev = tail;
1715 rarely_quit (++quit_count);
1800 } 1716 }
1717 CHECK_LIST_END (tail, seq);
1801 seq = prev; 1718 seq = prev;
1802 } 1719 }
1803 else if (VECTORP (seq)) 1720 else if (VECTORP (seq))
@@ -1838,10 +1755,11 @@ See also the function `nreverse', which is used more often. */)
1838 return Qnil; 1755 return Qnil;
1839 else if (CONSP (seq)) 1756 else if (CONSP (seq))
1840 { 1757 {
1758 unsigned short int quit_count = 0;
1841 for (new = Qnil; CONSP (seq); seq = XCDR (seq)) 1759 for (new = Qnil; CONSP (seq); seq = XCDR (seq))
1842 { 1760 {
1843 QUIT;
1844 new = Fcons (XCAR (seq), new); 1761 new = Fcons (XCAR (seq), new);
1762 rarely_quit (++quit_count);
1845 } 1763 }
1846 CHECK_LIST_END (seq, seq); 1764 CHECK_LIST_END (seq, seq);
1847 } 1765 }
@@ -2130,12 +2048,11 @@ If PROP is already a property on the list, its value is set to VAL,
2130otherwise the new PROP VAL pair is added. The new plist is returned; 2048otherwise the new PROP VAL pair is added. The new plist is returned;
2131use `(setq x (plist-put x prop val))' to be sure to use the new value. 2049use `(setq x (plist-put x prop val))' to be sure to use the new value.
2132The PLIST is modified by side effects. */) 2050The PLIST is modified by side effects. */)
2133 (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val) 2051 (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
2134{ 2052{
2135 register Lisp_Object tail, prev; 2053 unsigned short int quit_count = 0;
2136 Lisp_Object newcell; 2054 Lisp_Object prev = Qnil;
2137 prev = Qnil; 2055 for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2138 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2139 tail = XCDR (XCDR (tail))) 2056 tail = XCDR (XCDR (tail)))
2140 { 2057 {
2141 if (EQ (prop, XCAR (tail))) 2058 if (EQ (prop, XCAR (tail)))
@@ -2145,13 +2062,13 @@ The PLIST is modified by side effects. */)
2145 } 2062 }
2146 2063
2147 prev = tail; 2064 prev = tail;
2148 QUIT; 2065 rarely_quit (++quit_count);
2149 } 2066 }
2150 newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev)))); 2067 Lisp_Object newcell
2068 = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
2151 if (NILP (prev)) 2069 if (NILP (prev))
2152 return newcell; 2070 return newcell;
2153 else 2071 Fsetcdr (XCDR (prev), newcell);
2154 Fsetcdr (XCDR (prev), newcell);
2155 return plist; 2072 return plist;
2156} 2073}
2157 2074
@@ -2174,6 +2091,7 @@ corresponding to the given PROP, or nil if PROP is not
2174one of the properties on the list. */) 2091one of the properties on the list. */)
2175 (Lisp_Object plist, Lisp_Object prop) 2092 (Lisp_Object plist, Lisp_Object prop)
2176{ 2093{
2094 unsigned short int quit_count = 0;
2177 Lisp_Object tail; 2095 Lisp_Object tail;
2178 2096
2179 for (tail = plist; 2097 for (tail = plist;
@@ -2182,8 +2100,7 @@ one of the properties on the list. */)
2182 { 2100 {
2183 if (! NILP (Fequal (prop, XCAR (tail)))) 2101 if (! NILP (Fequal (prop, XCAR (tail))))
2184 return XCAR (XCDR (tail)); 2102 return XCAR (XCDR (tail));
2185 2103 rarely_quit (++quit_count);
2186 QUIT;
2187 } 2104 }
2188 2105
2189 CHECK_LIST_END (tail, prop); 2106 CHECK_LIST_END (tail, prop);
@@ -2199,12 +2116,11 @@ If PROP is already a property on the list, its value is set to VAL,
2199otherwise the new PROP VAL pair is added. The new plist is returned; 2116otherwise the new PROP VAL pair is added. The new plist is returned;
2200use `(setq x (lax-plist-put x prop val))' to be sure to use the new value. 2117use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2201The PLIST is modified by side effects. */) 2118The PLIST is modified by side effects. */)
2202 (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val) 2119 (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
2203{ 2120{
2204 register Lisp_Object tail, prev; 2121 unsigned short int quit_count = 0;
2205 Lisp_Object newcell; 2122 Lisp_Object prev = Qnil;
2206 prev = Qnil; 2123 for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2207 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2208 tail = XCDR (XCDR (tail))) 2124 tail = XCDR (XCDR (tail)))
2209 { 2125 {
2210 if (! NILP (Fequal (prop, XCAR (tail)))) 2126 if (! NILP (Fequal (prop, XCAR (tail))))
@@ -2214,13 +2130,12 @@ The PLIST is modified by side effects. */)
2214 } 2130 }
2215 2131
2216 prev = tail; 2132 prev = tail;
2217 QUIT; 2133 rarely_quit (++quit_count);
2218 } 2134 }
2219 newcell = list2 (prop, val); 2135 Lisp_Object newcell = list2 (prop, val);
2220 if (NILP (prev)) 2136 if (NILP (prev))
2221 return newcell; 2137 return newcell;
2222 else 2138 Fsetcdr (XCDR (prev), newcell);
2223 Fsetcdr (XCDR (prev), newcell);
2224 return plist; 2139 return plist;
2225} 2140}
2226 2141
@@ -2293,8 +2208,9 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props,
2293 } 2208 }
2294 } 2209 }
2295 2210
2211 unsigned short int quit_count = 0;
2296 tail_recurse: 2212 tail_recurse:
2297 QUIT; 2213 rarely_quit (++quit_count);
2298 if (EQ (o1, o2)) 2214 if (EQ (o1, o2))
2299 return 1; 2215 return 1;
2300 if (XTYPE (o1) != XTYPE (o2)) 2216 if (XTYPE (o1) != XTYPE (o2))
@@ -2483,14 +2399,12 @@ Only the last argument is not altered, and need not be a list.
2483usage: (nconc &rest LISTS) */) 2399usage: (nconc &rest LISTS) */)
2484 (ptrdiff_t nargs, Lisp_Object *args) 2400 (ptrdiff_t nargs, Lisp_Object *args)
2485{ 2401{
2486 ptrdiff_t argnum; 2402 unsigned short int quit_count = 0;
2487 register Lisp_Object tail, tem, val; 2403 Lisp_Object val = Qnil;
2488
2489 val = tail = Qnil;
2490 2404
2491 for (argnum = 0; argnum < nargs; argnum++) 2405 for (ptrdiff_t argnum = 0; argnum < nargs; argnum++)
2492 { 2406 {
2493 tem = args[argnum]; 2407 Lisp_Object tem = args[argnum];
2494 if (NILP (tem)) continue; 2408 if (NILP (tem)) continue;
2495 2409
2496 if (NILP (val)) 2410 if (NILP (val))
@@ -2498,14 +2412,16 @@ usage: (nconc &rest LISTS) */)
2498 2412
2499 if (argnum + 1 == nargs) break; 2413 if (argnum + 1 == nargs) break;
2500 2414
2501 CHECK_LIST_CONS (tem, tem); 2415 CHECK_CONS (tem);
2502 2416
2503 while (CONSP (tem)) 2417 Lisp_Object tail;
2418 do
2504 { 2419 {
2505 tail = tem; 2420 tail = tem;
2506 tem = XCDR (tail); 2421 tem = XCDR (tail);
2507 QUIT; 2422 rarely_quit (++quit_count);
2508 } 2423 }
2424 while (CONSP (tem));
2509 2425
2510 tem = args[argnum + 1]; 2426 tem = args[argnum + 1];
2511 Fsetcdr (tail, tem); 2427 Fsetcdr (tail, tem);
@@ -2927,11 +2843,12 @@ property and a property with the value nil.
2927The value is actually the tail of PLIST whose car is PROP. */) 2843The value is actually the tail of PLIST whose car is PROP. */)
2928 (Lisp_Object plist, Lisp_Object prop) 2844 (Lisp_Object plist, Lisp_Object prop)
2929{ 2845{
2846 unsigned short int quit_count = 0;
2930 while (CONSP (plist) && !EQ (XCAR (plist), prop)) 2847 while (CONSP (plist) && !EQ (XCAR (plist), prop))
2931 { 2848 {
2932 plist = XCDR (plist); 2849 plist = XCDR (plist);
2933 plist = CDR (plist); 2850 plist = CDR (plist);
2934 QUIT; 2851 rarely_quit (++quit_count);
2935 } 2852 }
2936 return plist; 2853 return plist;
2937} 2854}
@@ -3804,12 +3721,17 @@ allocate_hash_table (void)
3804 (table size) is >= REHASH_THRESHOLD. 3721 (table size) is >= REHASH_THRESHOLD.
3805 3722
3806 WEAK specifies the weakness of the table. If non-nil, it must be 3723 WEAK specifies the weakness of the table. If non-nil, it must be
3807 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */ 3724 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3725
3726 If PURECOPY is non-nil, the table can be copied to pure storage via
3727 `purecopy' when Emacs is being dumped. Such tables can no longer be
3728 changed after purecopy. */
3808 3729
3809Lisp_Object 3730Lisp_Object
3810make_hash_table (struct hash_table_test test, 3731make_hash_table (struct hash_table_test test,
3811 Lisp_Object size, Lisp_Object rehash_size, 3732 Lisp_Object size, Lisp_Object rehash_size,
3812 Lisp_Object rehash_threshold, Lisp_Object weak) 3733 Lisp_Object rehash_threshold, Lisp_Object weak,
3734 Lisp_Object pure)
3813{ 3735{
3814 struct Lisp_Hash_Table *h; 3736 struct Lisp_Hash_Table *h;
3815 Lisp_Object table; 3737 Lisp_Object table;
@@ -3850,6 +3772,7 @@ make_hash_table (struct hash_table_test test,
3850 h->hash = Fmake_vector (size, Qnil); 3772 h->hash = Fmake_vector (size, Qnil);
3851 h->next = Fmake_vector (size, Qnil); 3773 h->next = Fmake_vector (size, Qnil);
3852 h->index = Fmake_vector (make_number (index_size), Qnil); 3774 h->index = Fmake_vector (make_number (index_size), Qnil);
3775 h->pure = pure;
3853 3776
3854 /* Set up the free list. */ 3777 /* Set up the free list. */
3855 for (i = 0; i < sz - 1; ++i) 3778 for (i = 0; i < sz - 1; ++i)
@@ -4514,10 +4437,15 @@ key, value, one of key or value, or both key and value, depending on
4514WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK 4437WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4515is nil. 4438is nil.
4516 4439
4440:purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4441to pure storage when Emacs is being dumped, making the contents of the
4442table read only. Any further changes to purified tables will result
4443in an error.
4444
4517usage: (make-hash-table &rest KEYWORD-ARGS) */) 4445usage: (make-hash-table &rest KEYWORD-ARGS) */)
4518 (ptrdiff_t nargs, Lisp_Object *args) 4446 (ptrdiff_t nargs, Lisp_Object *args)
4519{ 4447{
4520 Lisp_Object test, size, rehash_size, rehash_threshold, weak; 4448 Lisp_Object test, size, rehash_size, rehash_threshold, weak, pure;
4521 struct hash_table_test testdesc; 4449 struct hash_table_test testdesc;
4522 ptrdiff_t i; 4450 ptrdiff_t i;
4523 USE_SAFE_ALLOCA; 4451 USE_SAFE_ALLOCA;
@@ -4551,6 +4479,9 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
4551 testdesc.cmpfn = cmpfn_user_defined; 4479 testdesc.cmpfn = cmpfn_user_defined;
4552 } 4480 }
4553 4481
4482 /* See if there's a `:purecopy PURECOPY' argument. */
4483 i = get_key_arg (QCpurecopy, nargs, args, used);
4484 pure = i ? args[i] : Qnil;
4554 /* See if there's a `:size SIZE' argument. */ 4485 /* See if there's a `:size SIZE' argument. */
4555 i = get_key_arg (QCsize, nargs, args, used); 4486 i = get_key_arg (QCsize, nargs, args, used);
4556 size = i ? args[i] : Qnil; 4487 size = i ? args[i] : Qnil;
@@ -4592,7 +4523,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
4592 signal_error ("Invalid argument list", args[i]); 4523 signal_error ("Invalid argument list", args[i]);
4593 4524
4594 SAFE_FREE (); 4525 SAFE_FREE ();
4595 return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak); 4526 return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak,
4527 pure);
4596} 4528}
4597 4529
4598 4530
@@ -4671,7 +4603,9 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
4671 doc: /* Clear hash table TABLE and return it. */) 4603 doc: /* Clear hash table TABLE and return it. */)
4672 (Lisp_Object table) 4604 (Lisp_Object table)
4673{ 4605{
4674 hash_clear (check_hash_table (table)); 4606 struct Lisp_Hash_Table *h = check_hash_table (table);
4607 CHECK_IMPURE (table, h);
4608 hash_clear (h);
4675 /* Be compatible with XEmacs. */ 4609 /* Be compatible with XEmacs. */
4676 return table; 4610 return table;
4677} 4611}
@@ -4695,9 +4629,10 @@ VALUE. In any case, return VALUE. */)
4695 (Lisp_Object key, Lisp_Object value, Lisp_Object table) 4629 (Lisp_Object key, Lisp_Object value, Lisp_Object table)
4696{ 4630{
4697 struct Lisp_Hash_Table *h = check_hash_table (table); 4631 struct Lisp_Hash_Table *h = check_hash_table (table);
4632 CHECK_IMPURE (table, h);
4633
4698 ptrdiff_t i; 4634 ptrdiff_t i;
4699 EMACS_UINT hash; 4635 EMACS_UINT hash;
4700
4701 i = hash_lookup (h, key, &hash); 4636 i = hash_lookup (h, key, &hash);
4702 if (i >= 0) 4637 if (i >= 0)
4703 set_hash_value_slot (h, i, value); 4638 set_hash_value_slot (h, i, value);
@@ -4713,6 +4648,7 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
4713 (Lisp_Object key, Lisp_Object table) 4648 (Lisp_Object key, Lisp_Object table)
4714{ 4649{
4715 struct Lisp_Hash_Table *h = check_hash_table (table); 4650 struct Lisp_Hash_Table *h = check_hash_table (table);
4651 CHECK_IMPURE (table, h);
4716 hash_remove_from_table (h, key); 4652 hash_remove_from_table (h, key);
4717 return Qnil; 4653 return Qnil;
4718} 4654}
@@ -5083,6 +5019,7 @@ syms_of_fns (void)
5083 DEFSYM (Qequal, "equal"); 5019 DEFSYM (Qequal, "equal");
5084 DEFSYM (QCtest, ":test"); 5020 DEFSYM (QCtest, ":test");
5085 DEFSYM (QCsize, ":size"); 5021 DEFSYM (QCsize, ":size");
5022 DEFSYM (QCpurecopy, ":purecopy");
5086 DEFSYM (QCrehash_size, ":rehash-size"); 5023 DEFSYM (QCrehash_size, ":rehash-size");
5087 DEFSYM (QCrehash_threshold, ":rehash-threshold"); 5024 DEFSYM (QCrehash_threshold, ":rehash-threshold");
5088 DEFSYM (QCweakness, ":weakness"); 5025 DEFSYM (QCweakness, ":weakness");
diff --git a/src/fontset.c b/src/fontset.c
index 33d1d24e5b3..850558b08a0 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -1677,11 +1677,10 @@ FONT-SPEC is a vector, a cons, or a string. See the documentation of
1677`set-fontset-font' for the meaning. */) 1677`set-fontset-font' for the meaning. */)
1678 (Lisp_Object name, Lisp_Object fontlist) 1678 (Lisp_Object name, Lisp_Object fontlist)
1679{ 1679{
1680 Lisp_Object fontset; 1680 Lisp_Object fontset, tail;
1681 int id; 1681 int id;
1682 1682
1683 CHECK_STRING (name); 1683 CHECK_STRING (name);
1684 CHECK_LIST (fontlist);
1685 1684
1686 name = Fdowncase (name); 1685 name = Fdowncase (name);
1687 id = fs_query_fontset (name, 0); 1686 id = fs_query_fontset (name, 0);
@@ -1714,11 +1713,11 @@ FONT-SPEC is a vector, a cons, or a string. See the documentation of
1714 Fset_char_table_range (fontset, Qt, Qnil); 1713 Fset_char_table_range (fontset, Qt, Qnil);
1715 } 1714 }
1716 1715
1717 for (; CONSP (fontlist); fontlist = XCDR (fontlist)) 1716 for (tail = fontlist; CONSP (tail); tail = XCDR (tail))
1718 { 1717 {
1719 Lisp_Object elt, script; 1718 Lisp_Object elt, script;
1720 1719
1721 elt = XCAR (fontlist); 1720 elt = XCAR (tail);
1722 script = Fcar (elt); 1721 script = Fcar (elt);
1723 elt = Fcdr (elt); 1722 elt = Fcdr (elt);
1724 if (CONSP (elt) && (NILP (XCDR (elt)) || CONSP (XCDR (elt)))) 1723 if (CONSP (elt) && (NILP (XCDR (elt)) || CONSP (XCDR (elt))))
@@ -1727,6 +1726,7 @@ FONT-SPEC is a vector, a cons, or a string. See the documentation of
1727 else 1726 else
1728 Fset_fontset_font (name, script, elt, Qnil, Qappend); 1727 Fset_fontset_font (name, script, elt, Qnil, Qappend);
1729 } 1728 }
1729 CHECK_LIST_END (tail, fontlist);
1730 return name; 1730 return name;
1731} 1731}
1732 1732
diff --git a/src/frame.c b/src/frame.c
index 2c2c1e150d4..d0f653fc762 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -2691,9 +2691,7 @@ list, but are otherwise ignored. */)
2691 (Lisp_Object frame, Lisp_Object alist) 2691 (Lisp_Object frame, Lisp_Object alist)
2692{ 2692{
2693 struct frame *f = decode_live_frame (frame); 2693 struct frame *f = decode_live_frame (frame);
2694 register Lisp_Object prop, val; 2694 Lisp_Object prop, val;
2695
2696 CHECK_LIST (alist);
2697 2695
2698 /* I think this should be done with a hook. */ 2696 /* I think this should be done with a hook. */
2699#ifdef HAVE_WINDOW_SYSTEM 2697#ifdef HAVE_WINDOW_SYSTEM
@@ -3142,6 +3140,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
3142 3140
3143 for (size = 0, tail = alist; CONSP (tail); tail = XCDR (tail)) 3141 for (size = 0, tail = alist; CONSP (tail); tail = XCDR (tail))
3144 size++; 3142 size++;
3143 CHECK_LIST_END (tail, alist);
3145 3144
3146 USE_SAFE_ALLOCA; 3145 USE_SAFE_ALLOCA;
3147 SAFE_ALLOCA_LISP (parms, 2 * size); 3146 SAFE_ALLOCA_LISP (parms, 2 * size);
diff --git a/src/gfilenotify.c b/src/gfilenotify.c
index 6ec5c642825..285a253733d 100644
--- a/src/gfilenotify.c
+++ b/src/gfilenotify.c
@@ -178,20 +178,18 @@ will be reported only in case of the `moved' event. */)
178 if (NILP (Ffile_exists_p (file))) 178 if (NILP (Ffile_exists_p (file)))
179 report_file_error ("File does not exist", file); 179 report_file_error ("File does not exist", file);
180 180
181 CHECK_LIST (flags);
182
183 if (!FUNCTIONP (callback)) 181 if (!FUNCTIONP (callback))
184 wrong_type_argument (Qinvalid_function, callback); 182 wrong_type_argument (Qinvalid_function, callback);
185 183
186 /* Create GFile name. */
187 gfile = g_file_new_for_path (SSDATA (ENCODE_FILE (file)));
188
189 /* Assemble flags. */ 184 /* Assemble flags. */
190 if (!NILP (Fmember (Qwatch_mounts, flags))) 185 if (!NILP (Fmember (Qwatch_mounts, flags)))
191 gflags |= G_FILE_MONITOR_WATCH_MOUNTS; 186 gflags |= G_FILE_MONITOR_WATCH_MOUNTS;
192 if (!NILP (Fmember (Qsend_moved, flags))) 187 if (!NILP (Fmember (Qsend_moved, flags)))
193 gflags |= G_FILE_MONITOR_SEND_MOVED; 188 gflags |= G_FILE_MONITOR_SEND_MOVED;
194 189
190 /* Create GFile name. */
191 gfile = g_file_new_for_path (SSDATA (ENCODE_FILE (file)));
192
195 /* Enable watch. */ 193 /* Enable watch. */
196 monitor = g_file_monitor (gfile, gflags, NULL, &gerror); 194 monitor = g_file_monitor (gfile, gflags, NULL, &gerror);
197 g_object_unref (gfile); 195 g_object_unref (gfile);
diff --git a/src/gnutls.c b/src/gnutls.c
index 735d2e35810..d0d7f2dfc84 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -390,7 +390,7 @@ gnutls_try_handshake (struct Lisp_Process *proc)
390 { 390 {
391 ret = gnutls_handshake (state); 391 ret = gnutls_handshake (state);
392 emacs_gnutls_handle_error (state, ret); 392 emacs_gnutls_handle_error (state, ret);
393 QUIT; 393 maybe_quit ();
394 } 394 }
395 while (ret < 0 395 while (ret < 0
396 && gnutls_error_is_fatal (ret) == 0 396 && gnutls_error_is_fatal (ret) == 0
@@ -582,8 +582,17 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err)
582 582
583 if (gnutls_error_is_fatal (err)) 583 if (gnutls_error_is_fatal (err))
584 { 584 {
585 int level = 1;
586 /* Mostly ignore "The TLS connection was non-properly
587 terminated" message which just means that the peer closed the
588 connection. */
589#ifdef HAVE_GNUTLS3
590 if (err == GNUTLS_E_PREMATURE_TERMINATION)
591 level = 3;
592#endif
593
594 GNUTLS_LOG2 (level, max_log_level, "fatal error:", str);
585 ret = 0; 595 ret = 0;
586 GNUTLS_LOG2 (1, max_log_level, "fatal error:", str);
587 } 596 }
588 else 597 else
589 { 598 {
diff --git a/src/image.c b/src/image.c
index 39677d2add9..ad0143be48b 100644
--- a/src/image.c
+++ b/src/image.c
@@ -4020,7 +4020,7 @@ xpm_make_color_table_h (void (**put_func) (Lisp_Object, const char *, int,
4020 return make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE), 4020 return make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
4021 make_float (DEFAULT_REHASH_SIZE), 4021 make_float (DEFAULT_REHASH_SIZE),
4022 make_float (DEFAULT_REHASH_THRESHOLD), 4022 make_float (DEFAULT_REHASH_THRESHOLD),
4023 Qnil); 4023 Qnil, Qnil);
4024} 4024}
4025 4025
4026static void 4026static void
diff --git a/src/indent.c b/src/indent.c
index 34449955a6c..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 = 1;
1204 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 = 0;
1698 return &val_compute_motion; 1701 return &val_compute_motion;
1699} 1702}
1700 1703
diff --git a/src/insdel.c b/src/insdel.c
index ce4960447f2..4627bd54b0b 100644
--- a/src/insdel.c
+++ b/src/insdel.c
@@ -129,7 +129,7 @@ gap_left (ptrdiff_t charpos, ptrdiff_t bytepos, bool newgap)
129 Change BYTEPOS to be where we have actually moved the gap to. 129 Change BYTEPOS to be where we have actually moved the gap to.
130 Note that this cannot happen when we are called to make the 130 Note that this cannot happen when we are called to make the
131 gap larger or smaller, since make_gap_larger and 131 gap larger or smaller, since make_gap_larger and
132 make_gap_smaller prevent QUIT by setting inhibit-quit. */ 132 make_gap_smaller set inhibit-quit. */
133 if (QUITP) 133 if (QUITP)
134 { 134 {
135 bytepos = new_s1; 135 bytepos = new_s1;
@@ -151,7 +151,7 @@ gap_left (ptrdiff_t charpos, ptrdiff_t bytepos, bool newgap)
151 GPT = charpos; 151 GPT = charpos;
152 eassert (charpos <= bytepos); 152 eassert (charpos <= bytepos);
153 if (GAP_SIZE > 0) *(GPT_ADDR) = 0; /* Put an anchor. */ 153 if (GAP_SIZE > 0) *(GPT_ADDR) = 0; /* Put an anchor. */
154 QUIT; 154 maybe_quit ();
155} 155}
156 156
157/* Move the gap to a position greater than the current GPT. 157/* Move the gap to a position greater than the current GPT.
@@ -185,7 +185,7 @@ gap_right (ptrdiff_t charpos, ptrdiff_t bytepos)
185 Change BYTEPOS to be where we have actually moved the gap to. 185 Change BYTEPOS to be where we have actually moved the gap to.
186 Note that this cannot happen when we are called to make the 186 Note that this cannot happen when we are called to make the
187 gap larger or smaller, since make_gap_larger and 187 gap larger or smaller, since make_gap_larger and
188 make_gap_smaller prevent QUIT by setting inhibit-quit. */ 188 make_gap_smaller set inhibit-quit. */
189 if (QUITP) 189 if (QUITP)
190 { 190 {
191 bytepos = new_s1; 191 bytepos = new_s1;
@@ -204,7 +204,7 @@ gap_right (ptrdiff_t charpos, ptrdiff_t bytepos)
204 GPT_BYTE = bytepos; 204 GPT_BYTE = bytepos;
205 eassert (charpos <= bytepos); 205 eassert (charpos <= bytepos);
206 if (GAP_SIZE > 0) *(GPT_ADDR) = 0; /* Put an anchor. */ 206 if (GAP_SIZE > 0) *(GPT_ADDR) = 0; /* Put an anchor. */
207 QUIT; 207 maybe_quit ();
208} 208}
209 209
210/* If the selected window's old pointm is adjacent or covered by the 210/* If the selected window's old pointm is adjacent or covered by the
@@ -464,7 +464,7 @@ make_gap_larger (ptrdiff_t nbytes_added)
464 464
465 enlarge_buffer_text (current_buffer, nbytes_added); 465 enlarge_buffer_text (current_buffer, nbytes_added);
466 466
467 /* Prevent quitting in gap_left. We cannot allow a QUIT there, 467 /* Prevent quitting in gap_left. We cannot allow a quit there,
468 because that would leave the buffer text in an inconsistent 468 because that would leave the buffer text in an inconsistent
469 state, with 2 gap holes instead of just one. */ 469 state, with 2 gap holes instead of just one. */
470 tem = Vinhibit_quit; 470 tem = Vinhibit_quit;
@@ -512,7 +512,7 @@ make_gap_smaller (ptrdiff_t nbytes_removed)
512 if (GAP_SIZE - nbytes_removed < GAP_BYTES_MIN) 512 if (GAP_SIZE - nbytes_removed < GAP_BYTES_MIN)
513 nbytes_removed = GAP_SIZE - GAP_BYTES_MIN; 513 nbytes_removed = GAP_SIZE - GAP_BYTES_MIN;
514 514
515 /* Prevent quitting in gap_right. We cannot allow a QUIT there, 515 /* Prevent quitting in gap_right. We cannot allow a quit there,
516 because that would leave the buffer text in an inconsistent 516 because that would leave the buffer text in an inconsistent
517 state, with 2 gap holes instead of just one. */ 517 state, with 2 gap holes instead of just one. */
518 tem = Vinhibit_quit; 518 tem = Vinhibit_quit;
diff --git a/src/keyboard.c b/src/keyboard.c
index 6aad0acc656..a86e7c5f8e4 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -87,7 +87,7 @@ char const DEV_TTY[] = "/dev/tty";
87volatile int interrupt_input_blocked; 87volatile int interrupt_input_blocked;
88 88
89/* True means an input interrupt or alarm signal has arrived. 89/* True means an input interrupt or alarm signal has arrived.
90 The QUIT macro checks this. */ 90 The maybe_quit function checks this. */
91volatile bool pending_signals; 91volatile bool pending_signals;
92 92
93#define KBD_BUFFER_SIZE 4096 93#define KBD_BUFFER_SIZE 4096
@@ -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
@@ -1416,7 +1413,7 @@ command_loop_1 (void)
1416 if (!NILP (Vquit_flag)) 1413 if (!NILP (Vquit_flag))
1417 { 1414 {
1418 Vexecuting_kbd_macro = Qt; 1415 Vexecuting_kbd_macro = Qt;
1419 QUIT; /* Make some noise. */ 1416 maybe_quit (); /* Make some noise. */
1420 /* Will return since macro now empty. */ 1417 /* Will return since macro now empty. */
1421 } 1418 }
1422 } 1419 }
@@ -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 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)
@@ -7426,7 +7396,7 @@ menu_bar_items (Lisp_Object old)
7426 USE_SAFE_ALLOCA; 7396 USE_SAFE_ALLOCA;
7427 7397
7428 /* In order to build the menus, we need to call the keymap 7398 /* In order to build the menus, we need to call the keymap
7429 accessors. They all call QUIT. But this function is called 7399 accessors. They all call maybe_quit. But this function is called
7430 during redisplay, during which a quit is fatal. So inhibit 7400 during redisplay, during which a quit is fatal. So inhibit
7431 quitting while building the menus. 7401 quitting while building the menus.
7432 We do this instead of specbind because (1) errors will clear it anyway 7402 We do this instead of specbind because (1) errors will clear it anyway
@@ -7987,7 +7957,7 @@ tool_bar_items (Lisp_Object reuse, int *nitems)
7987 *nitems = 0; 7957 *nitems = 0;
7988 7958
7989 /* In order to build the menus, we need to call the keymap 7959 /* In order to build the menus, we need to call the keymap
7990 accessors. They all call QUIT. But this function is called 7960 accessors. They all call maybe_quit. But this function is called
7991 during redisplay, during which a quit is fatal. So inhibit 7961 during redisplay, during which a quit is fatal. So inhibit
7992 quitting while building the menus. We do this instead of 7962 quitting while building the menus. We do this instead of
7993 specbind because (1) errors will clear it anyway and (2) this 7963 specbind because (1) errors will clear it anyway and (2) this
@@ -9806,7 +9776,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
9806 9776
9807 if (!NILP (prompt)) 9777 if (!NILP (prompt))
9808 CHECK_STRING (prompt); 9778 CHECK_STRING (prompt);
9809 QUIT; 9779 maybe_quit ();
9810 9780
9811 specbind (Qinput_method_exit_on_first_char, 9781 specbind (Qinput_method_exit_on_first_char,
9812 (NILP (cmd_loop) ? Qt : Qnil)); 9782 (NILP (cmd_loop) ? Qt : Qnil));
@@ -9840,7 +9810,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
9840 if (i == -1) 9810 if (i == -1)
9841 { 9811 {
9842 Vquit_flag = Qt; 9812 Vquit_flag = Qt;
9843 QUIT; 9813 maybe_quit ();
9844 } 9814 }
9845 9815
9846 return unbind_to (count, 9816 return unbind_to (count,
@@ -10278,7 +10248,7 @@ clear_waiting_for_input (void)
10278 10248
10279 If we have a frame on the controlling tty, we assume that the 10249 If we have a frame on the controlling tty, we assume that the
10280 SIGINT was generated by C-g, so we call handle_interrupt. 10250 SIGINT was generated by C-g, so we call handle_interrupt.
10281 Otherwise, tell QUIT to kill Emacs. */ 10251 Otherwise, tell maybe_quit to kill Emacs. */
10282 10252
10283static void 10253static void
10284handle_interrupt_signal (int sig) 10254handle_interrupt_signal (int sig)
@@ -10289,7 +10259,7 @@ handle_interrupt_signal (int sig)
10289 { 10259 {
10290 /* If there are no frames there, let's pretend that we are a 10260 /* If there are no frames there, let's pretend that we are a
10291 well-behaving UN*X program and quit. We must not call Lisp 10261 well-behaving UN*X program and quit. We must not call Lisp
10292 in a signal handler, so tell QUIT to exit when it is 10262 in a signal handler, so tell maybe_quit to exit when it is
10293 safe. */ 10263 safe. */
10294 Vquit_flag = Qkill_emacs; 10264 Vquit_flag = Qkill_emacs;
10295 } 10265 }
@@ -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/keyboard.h b/src/keyboard.h
index 7cd41ae55b6..2219c011352 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -486,6 +486,8 @@ extern bool kbd_buffer_events_waiting (void);
486extern void add_user_signal (int, const char *); 486extern void add_user_signal (int, const char *);
487 487
488extern int tty_read_avail_input (struct terminal *, struct input_event *); 488extern int tty_read_avail_input (struct terminal *, struct input_event *);
489extern bool volatile pending_signals;
490extern void process_pending_signals (void);
489extern struct timespec timer_check (void); 491extern struct timespec timer_check (void);
490extern void mark_kboards (void); 492extern void mark_kboards (void);
491 493
diff --git a/src/keymap.c b/src/keymap.c
index 9e759478518..9caf55f98fb 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -523,7 +523,7 @@ access_keymap_1 (Lisp_Object map, Lisp_Object idx,
523 retval = Fcons (Qkeymap, Fcons (retval, retval_tail)); 523 retval = Fcons (Qkeymap, Fcons (retval, retval_tail));
524 } 524 }
525 } 525 }
526 QUIT; 526 maybe_quit ();
527 } 527 }
528 528
529 return EQ (Qunbound, retval) ? get_keyelt (t_binding, autoload) : retval; 529 return EQ (Qunbound, retval) ? get_keyelt (t_binding, autoload) : retval;
@@ -877,7 +877,7 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
877 should be inserted before it. */ 877 should be inserted before it. */
878 goto keymap_end; 878 goto keymap_end;
879 879
880 QUIT; 880 maybe_quit ();
881 } 881 }
882 882
883 keymap_end: 883 keymap_end:
@@ -1250,7 +1250,7 @@ recognize the default bindings, just as `read-key-sequence' does. */)
1250 if (!CONSP (keymap)) 1250 if (!CONSP (keymap))
1251 return make_number (idx); 1251 return make_number (idx);
1252 1252
1253 QUIT; 1253 maybe_quit ();
1254 } 1254 }
1255} 1255}
1256 1256
@@ -2466,7 +2466,7 @@ where_is_internal (Lisp_Object definition, Lisp_Object keymaps,
2466 non-ascii prefixes like `C-down-mouse-2'. */ 2466 non-ascii prefixes like `C-down-mouse-2'. */
2467 continue; 2467 continue;
2468 2468
2469 QUIT; 2469 maybe_quit ();
2470 2470
2471 data.definition = definition; 2471 data.definition = definition;
2472 data.noindirect = noindirect; 2472 data.noindirect = noindirect;
@@ -3173,7 +3173,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix,
3173 3173
3174 for (tail = map; CONSP (tail); tail = XCDR (tail)) 3174 for (tail = map; CONSP (tail); tail = XCDR (tail))
3175 { 3175 {
3176 QUIT; 3176 maybe_quit ();
3177 3177
3178 if (VECTORP (XCAR (tail)) 3178 if (VECTORP (XCAR (tail))
3179 || CHAR_TABLE_P (XCAR (tail))) 3179 || CHAR_TABLE_P (XCAR (tail)))
@@ -3426,7 +3426,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args,
3426 int range_beg, range_end; 3426 int range_beg, range_end;
3427 Lisp_Object val; 3427 Lisp_Object val;
3428 3428
3429 QUIT; 3429 maybe_quit ();
3430 3430
3431 if (i == stop) 3431 if (i == stop)
3432 { 3432 {
diff --git a/src/lisp.h b/src/lisp.h
index 005d1e7c746..2a32db62326 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -310,7 +310,6 @@ error !;
310# define lisp_h_XLI(o) (o) 310# define lisp_h_XLI(o) (o)
311# define lisp_h_XIL(i) (i) 311# define lisp_h_XIL(i) (i)
312#endif 312#endif
313#define lisp_h_CHECK_LIST_CONS(x, y) CHECK_TYPE (CONSP (x), Qlistp, y)
314#define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x) 313#define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x)
315#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) 314#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
316#define lisp_h_CHECK_TYPE(ok, predicate, x) \ 315#define lisp_h_CHECK_TYPE(ok, predicate, x) \
@@ -367,7 +366,6 @@ error !;
367#if DEFINE_KEY_OPS_AS_MACROS 366#if DEFINE_KEY_OPS_AS_MACROS
368# define XLI(o) lisp_h_XLI (o) 367# define XLI(o) lisp_h_XLI (o)
369# define XIL(i) lisp_h_XIL (i) 368# define XIL(i) lisp_h_XIL (i)
370# define CHECK_LIST_CONS(x, y) lisp_h_CHECK_LIST_CONS (x, y)
371# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x) 369# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x)
372# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) 370# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
373# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) 371# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
@@ -1997,6 +1995,10 @@ struct Lisp_Hash_Table
1997 hash table size to reduce collisions. */ 1995 hash table size to reduce collisions. */
1998 Lisp_Object index; 1996 Lisp_Object index;
1999 1997
1998 /* Non-nil if the table can be purecopied. The table cannot be
1999 changed afterwards. */
2000 Lisp_Object pure;
2001
2000 /* 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
2001 `count' are special and are either ignored by the GC or traced in 2003 `count' are special and are either ignored by the GC or traced in
2002 a special way (e.g. because of weakness). */ 2004 a special way (e.g. because of weakness). */
@@ -2751,9 +2753,9 @@ CHECK_LIST (Lisp_Object x)
2751} 2753}
2752 2754
2753INLINE void 2755INLINE void
2754(CHECK_LIST_CONS) (Lisp_Object x, Lisp_Object y) 2756CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
2755{ 2757{
2756 lisp_h_CHECK_LIST_CONS (x, y); 2758 CHECK_TYPE (NILP (x), Qlistp, y);
2757} 2759}
2758 2760
2759INLINE void 2761INLINE void
@@ -3121,38 +3123,28 @@ struct handler
3121 3123
3122extern Lisp_Object memory_signal_data; 3124extern Lisp_Object memory_signal_data;
3123 3125
3124/* Check quit-flag and quit if it is non-nil. 3126extern void maybe_quit (void);
3125 Typing C-g does not directly cause a quit; it only sets Vquit_flag.
3126 So the program needs to do QUIT at times when it is safe to quit.
3127 Every loop that might run for a long time or might not exit
3128 ought to do QUIT at least once, at a safe place.
3129 Unless that is impossible, of course.
3130 But it is very desirable to avoid creating loops where QUIT is impossible.
3131
3132 Exception: if you set immediate_quit to true,
3133 then the handler that responds to the C-g does the quit itself.
3134 This is a good thing to do around a loop that has no side effects
3135 and (in particular) cannot call arbitrary Lisp code.
3136 3127
3137 If quit-flag is set to `kill-emacs' the SIGINT handler has received 3128/* True if ought to quit now. */
3138 a request to exit Emacs when it is safe to do. */
3139 3129
3140extern void process_pending_signals (void); 3130#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
3141extern bool volatile pending_signals;
3142 3131
3143extern void process_quit_flag (void); 3132/* Heuristic on how many iterations of a tight loop can be safely done
3144#define QUIT \ 3133 before it's time to do a quit. This must be a power of 2. It
3145 do { \ 3134 is nice but not necessary for it to equal USHRT_MAX + 1. */
3146 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
3147 process_quit_flag (); \
3148 else if (pending_signals) \
3149 process_pending_signals (); \
3150 } while (false)
3151 3135
3136enum { QUIT_COUNT_HEURISTIC = 1 << 16 };
3152 3137
3153/* 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). */
3154 3141
3155#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}
3156 3148
3157extern Lisp_Object Vascii_downcase_table; 3149extern Lisp_Object Vascii_downcase_table;
3158extern Lisp_Object Vascii_canon_table; 3150extern Lisp_Object Vascii_canon_table;
@@ -3375,7 +3367,7 @@ extern void sweep_weak_hash_tables (void);
3375EMACS_UINT hash_string (char const *, ptrdiff_t); 3367EMACS_UINT hash_string (char const *, ptrdiff_t);
3376EMACS_UINT sxhash (Lisp_Object, int); 3368EMACS_UINT sxhash (Lisp_Object, int);
3377Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object, 3369Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object,
3378 Lisp_Object, Lisp_Object); 3370 Lisp_Object, Lisp_Object, Lisp_Object);
3379ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *); 3371ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
3380ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object, 3372ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
3381 EMACS_UINT); 3373 EMACS_UINT);
@@ -4233,8 +4225,10 @@ extern int emacs_open (const char *, int, int);
4233extern int emacs_pipe (int[2]); 4225extern int emacs_pipe (int[2]);
4234extern int emacs_close (int); 4226extern int emacs_close (int);
4235extern ptrdiff_t emacs_read (int, void *, ptrdiff_t); 4227extern ptrdiff_t emacs_read (int, void *, ptrdiff_t);
4228extern ptrdiff_t emacs_read_quit (int, void *, ptrdiff_t);
4236extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t); 4229extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t);
4237extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t); 4230extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t);
4231extern ptrdiff_t emacs_write_quit (int, void const *, ptrdiff_t);
4238extern void emacs_perror (char const *); 4232extern void emacs_perror (char const *);
4239 4233
4240extern void unlock_all_files (void); 4234extern void unlock_all_files (void);
@@ -4360,9 +4354,6 @@ extern char my_edata[];
4360extern char my_endbss[]; 4354extern char my_endbss[];
4361extern char *my_endbss_static; 4355extern char *my_endbss_static;
4362 4356
4363/* True means ^G can quit instantly. */
4364extern bool immediate_quit;
4365
4366extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); 4357extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
4367extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); 4358extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
4368extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); 4359extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2));
@@ -4549,7 +4540,7 @@ enum
4549 use these only in macros like AUTO_CONS that declare a local 4540 use these only in macros like AUTO_CONS that declare a local
4550 variable whose lifetime will be clear to the programmer. */ 4541 variable whose lifetime will be clear to the programmer. */
4551#define STACK_CONS(a, b) \ 4542#define STACK_CONS(a, b) \
4552 make_lisp_ptr (&(union Aligned_Cons) { { a, { b } } }.s, Lisp_Cons) 4543 make_lisp_ptr (&((union Aligned_Cons) { { a, { b } } }).s, Lisp_Cons)
4553#define AUTO_CONS_EXPR(a, b) \ 4544#define AUTO_CONS_EXPR(a, b) \
4554 (USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b)) 4545 (USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b))
4555 4546
@@ -4595,8 +4586,7 @@ enum
4595 Lisp_Object name = \ 4586 Lisp_Object name = \
4596 (USE_STACK_STRING \ 4587 (USE_STACK_STRING \
4597 ? (make_lisp_ptr \ 4588 ? (make_lisp_ptr \
4598 ((&(union Aligned_String) \ 4589 ((&((union Aligned_String) {{len, -1, 0, (unsigned char *) (str)}}).s), \
4599 {{len, -1, 0, (unsigned char *) (str)}}.s), \
4600 Lisp_String)) \ 4590 Lisp_String)) \
4601 : make_unibyte_string (str, len)) 4591 : make_unibyte_string (str, len))
4602 4592
diff --git a/src/lread.c b/src/lread.c
index 284fd1aafbc..094aa628eec 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -451,7 +451,7 @@ readbyte_from_file (int c, Lisp_Object readcharfun)
451 while (c == EOF && ferror (instream) && errno == EINTR) 451 while (c == EOF && ferror (instream) && errno == EINTR)
452 { 452 {
453 unblock_input (); 453 unblock_input ();
454 QUIT; 454 maybe_quit ();
455 block_input (); 455 block_input ();
456 clearerr (instream); 456 clearerr (instream);
457 c = getc (instream); 457 c = getc (instream);
@@ -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'
@@ -1702,14 +1702,14 @@ build_load_history (Lisp_Object filename, bool entire)
1702 Fcons (newelt, XCDR (tem)))); 1702 Fcons (newelt, XCDR (tem))));
1703 1703
1704 tem2 = XCDR (tem2); 1704 tem2 = XCDR (tem2);
1705 QUIT; 1705 maybe_quit ();
1706 } 1706 }
1707 } 1707 }
1708 } 1708 }
1709 else 1709 else
1710 prev = tail; 1710 prev = tail;
1711 tail = XCDR (tail); 1711 tail = XCDR (tail);
1712 QUIT; 1712 maybe_quit ();
1713 } 1713 }
1714 1714
1715 /* If we're loading an entire file, cons the new assoc onto the 1715 /* If we're loading an entire file, cons the new assoc onto the
@@ -2599,7 +2599,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
2599 Lisp_Object val = Qnil; 2599 Lisp_Object val = Qnil;
2600 /* The size is 2 * number of allowed keywords to 2600 /* The size is 2 * number of allowed keywords to
2601 make-hash-table. */ 2601 make-hash-table. */
2602 Lisp_Object params[10]; 2602 Lisp_Object params[12];
2603 Lisp_Object ht; 2603 Lisp_Object ht;
2604 Lisp_Object key = Qnil; 2604 Lisp_Object key = Qnil;
2605 int param_count = 0; 2605 int param_count = 0;
@@ -2636,6 +2636,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
2636 if (!NILP (params[param_count + 1])) 2636 if (!NILP (params[param_count + 1]))
2637 param_count += 2; 2637 param_count += 2;
2638 2638
2639 params[param_count] = QCpurecopy;
2640 params[param_count + 1] = Fplist_get (tmp, Qpurecopy);
2641 if (!NILP (params[param_count + 1]))
2642 param_count += 2;
2643
2639 /* This is the hash table data. */ 2644 /* This is the hash table data. */
2640 data = Fplist_get (tmp, Qdata); 2645 data = Fplist_get (tmp, Qdata);
2641 2646
@@ -4849,6 +4854,7 @@ that are loaded before your customizations are read! */);
4849 DEFSYM (Qdata, "data"); 4854 DEFSYM (Qdata, "data");
4850 DEFSYM (Qtest, "test"); 4855 DEFSYM (Qtest, "test");
4851 DEFSYM (Qsize, "size"); 4856 DEFSYM (Qsize, "size");
4857 DEFSYM (Qpurecopy, "purecopy");
4852 DEFSYM (Qweakness, "weakness"); 4858 DEFSYM (Qweakness, "weakness");
4853 DEFSYM (Qrehash_size, "rehash-size"); 4859 DEFSYM (Qrehash_size, "rehash-size");
4854 DEFSYM (Qrehash_threshold, "rehash-threshold"); 4860 DEFSYM (Qrehash_threshold, "rehash-threshold");
diff --git a/src/macros.c b/src/macros.c
index 3b29cc67cf8..f0ffda3f441 100644
--- a/src/macros.c
+++ b/src/macros.c
@@ -325,7 +325,7 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */)
325 325
326 executing_kbd_macro_iterations = ++success_count; 326 executing_kbd_macro_iterations = ++success_count;
327 327
328 QUIT; 328 maybe_quit ();
329 } 329 }
330 while (--repeat 330 while (--repeat
331 && (STRINGP (Vexecuting_kbd_macro) || VECTORP (Vexecuting_kbd_macro))); 331 && (STRINGP (Vexecuting_kbd_macro) || VECTORP (Vexecuting_kbd_macro)));
diff --git a/src/minibuf.c b/src/minibuf.c
index d44bb44baee..1bbe276776e 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -1865,7 +1865,7 @@ single string, rather than a cons cell whose car is a string. */)
1865 case_fold); 1865 case_fold);
1866 if (EQ (tem, Qt)) 1866 if (EQ (tem, Qt))
1867 return elt; 1867 return elt;
1868 QUIT; 1868 maybe_quit ();
1869 } 1869 }
1870 return Qnil; 1870 return Qnil;
1871} 1871}
diff --git a/src/print.c b/src/print.c
index dfaa489a98d..db3d00f51f2 100644
--- a/src/print.c
+++ b/src/print.c
@@ -279,7 +279,7 @@ printchar (unsigned int ch, Lisp_Object fun)
279 unsigned char str[MAX_MULTIBYTE_LENGTH]; 279 unsigned char str[MAX_MULTIBYTE_LENGTH];
280 int len = CHAR_STRING (ch, str); 280 int len = CHAR_STRING (ch, str);
281 281
282 QUIT; 282 maybe_quit ();
283 283
284 if (NILP (fun)) 284 if (NILP (fun))
285 { 285 {
@@ -1352,7 +1352,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
1352 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t), 1352 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t),
1353 40))]; 1353 40))];
1354 1354
1355 QUIT; 1355 maybe_quit ();
1356 1356
1357 /* Detect circularities and truncate them. */ 1357 /* Detect circularities and truncate them. */
1358 if (NILP (Vprint_circle)) 1358 if (NILP (Vprint_circle))
@@ -1446,7 +1446,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
1446 1446
1447 FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte); 1447 FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte);
1448 1448
1449 QUIT; 1449 maybe_quit ();
1450 1450
1451 if (multibyte 1451 if (multibyte
1452 ? (CHAR_BYTE8_P (c) && (c = CHAR_TO_BYTE8 (c), true)) 1452 ? (CHAR_BYTE8_P (c) && (c = CHAR_TO_BYTE8 (c), true))
@@ -1550,7 +1550,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
1550 /* Here, we must convert each multi-byte form to the 1550 /* Here, we must convert each multi-byte form to the
1551 corresponding character code before handing it to PRINTCHAR. */ 1551 corresponding character code before handing it to PRINTCHAR. */
1552 FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte); 1552 FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte);
1553 QUIT; 1553 maybe_quit ();
1554 1554
1555 if (escapeflag) 1555 if (escapeflag)
1556 { 1556 {
@@ -1707,7 +1707,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
1707 1707
1708 for (i = 0; i < size_in_chars; i++) 1708 for (i = 0; i < size_in_chars; i++)
1709 { 1709 {
1710 QUIT; 1710 maybe_quit ();
1711 c = bool_vector_uchar_data (obj)[i]; 1711 c = bool_vector_uchar_data (obj)[i];
1712 if (c == '\n' && print_escape_newlines) 1712 if (c == '\n' && print_escape_newlines)
1713 print_c_string ("\\n", printcharfun); 1713 print_c_string ("\\n", printcharfun);
@@ -1818,6 +1818,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
1818 print_object (h->rehash_threshold, printcharfun, escapeflag); 1818 print_object (h->rehash_threshold, printcharfun, escapeflag);
1819 } 1819 }
1820 1820
1821 if (!NILP (h->pure))
1822 {
1823 print_c_string (" purecopy ", printcharfun);
1824 print_object (h->pure, printcharfun, escapeflag);
1825 }
1826
1821 print_c_string (" data ", printcharfun); 1827 print_c_string (" data ", printcharfun);
1822 1828
1823 /* Print the data here as a plist. */ 1829 /* Print the data here as a plist. */
diff --git a/src/process.c b/src/process.c
index ab9657b15a4..434a3955b2c 100644
--- a/src/process.c
+++ b/src/process.c
@@ -3431,16 +3431,14 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
3431 break; 3431 break;
3432 } 3432 }
3433 3433
3434 immediate_quit = 1; 3434 maybe_quit ();
3435 QUIT;
3436 3435
3437 ret = connect (s, sa, addrlen); 3436 ret = connect (s, sa, addrlen);
3438 xerrno = errno; 3437 xerrno = errno;
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
@@ -3459,7 +3457,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
3459 retry_select: 3457 retry_select:
3460 FD_ZERO (&fdset); 3458 FD_ZERO (&fdset);
3461 FD_SET (s, &fdset); 3459 FD_SET (s, &fdset);
3462 QUIT; 3460 maybe_quit ();
3463 sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL); 3461 sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL);
3464 if (sc == -1) 3462 if (sc == -1)
3465 { 3463 {
@@ -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 = 0;
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 = 0;
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,8 +4006,7 @@ 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 = 1; 4009 maybe_quit ();
4016 QUIT;
4017 4010
4018 struct addrinfo hints; 4011 struct addrinfo hints;
4019 memset (&hints, 0, sizeof hints); 4012 memset (&hints, 0, sizeof 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 = 0;
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);
@@ -5020,7 +5012,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5020 since we want to return C-g as an input character. 5012 since we want to return C-g as an input character.
5021 Otherwise, do pending quit if requested. */ 5013 Otherwise, do pending quit if requested. */
5022 if (read_kbd >= 0) 5014 if (read_kbd >= 0)
5023 QUIT; 5015 maybe_quit ();
5024 else if (pending_signals) 5016 else if (pending_signals)
5025 process_pending_signals (); 5017 process_pending_signals ();
5026 5018
@@ -5748,7 +5740,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5748 { 5740 {
5749 /* Prevent input_pending from remaining set if we quit. */ 5741 /* Prevent input_pending from remaining set if we quit. */
5750 clear_input_pending (); 5742 clear_input_pending ();
5751 QUIT; 5743 maybe_quit ();
5752 } 5744 }
5753 5745
5754 return got_some_output; 5746 return got_some_output;
@@ -7486,7 +7478,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
7486 since we want to return C-g as an input character. 7478 since we want to return C-g as an input character.
7487 Otherwise, do pending quit if requested. */ 7479 Otherwise, do pending quit if requested. */
7488 if (read_kbd >= 0) 7480 if (read_kbd >= 0)
7489 QUIT; 7481 maybe_quit ();
7490 7482
7491 /* Exit now if the cell we're waiting for became non-nil. */ 7483 /* Exit now if the cell we're waiting for became non-nil. */
7492 if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) 7484 if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
diff --git a/src/profiler.c b/src/profiler.c
index efc0cb316fc..a223a7e7c07 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -48,7 +48,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth)
48 make_number (heap_size), 48 make_number (heap_size),
49 make_float (DEFAULT_REHASH_SIZE), 49 make_float (DEFAULT_REHASH_SIZE),
50 make_float (DEFAULT_REHASH_THRESHOLD), 50 make_float (DEFAULT_REHASH_THRESHOLD),
51 Qnil); 51 Qnil, Qnil);
52 struct Lisp_Hash_Table *h = XHASH_TABLE (log); 52 struct Lisp_Hash_Table *h = XHASH_TABLE (log);
53 53
54 /* What is special about our hash-tables is that the keys are pre-filled 54 /* What is special about our hash-tables is that the keys are pre-filled
@@ -174,8 +174,8 @@ record_backtrace (log_t *log, EMACS_INT count)
174 some global flag so that some Elisp code can offload its 174 some global flag so that some Elisp code can offload its
175 data elsewhere, so as to avoid the eviction code. 175 data elsewhere, so as to avoid the eviction code.
176 There are 2 ways to do that, AFAICT: 176 There are 2 ways to do that, AFAICT:
177 - Set a flag checked in QUIT, such that QUIT can then call 177 - Set a flag checked in maybe_quit, such that maybe_quit can then
178 Fprofiler_cpu_log and stash the full log for later use. 178 call Fprofiler_cpu_log and stash the full log for later use.
179 - Set a flag check in post-gc-hook, so that Elisp code can call 179 - Set a flag check in post-gc-hook, so that Elisp code can call
180 profiler-cpu-log. That gives us more flexibility since that 180 profiler-cpu-log. That gives us more flexibility since that
181 Elisp code can then do all kinds of fun stuff like write 181 Elisp code can then do all kinds of fun stuff like write
diff --git a/src/regex.c b/src/regex.c
index db3f0c16a2d..796f868d1c2 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -1728,13 +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 \ 1732static void maybe_quit (void) {}
1733 do { \
1734 if (immediate_quit) QUIT; \
1735 } while (0)
1736#else
1737# define IMMEDIATE_QUIT_CHECK ((void)0)
1738#endif 1733#endif
1739 1734
1740/* Structure to manage work area for range table. */ 1735/* Structure to manage work area for range table. */
@@ -5823,7 +5818,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
5823 /* Unconditionally jump (without popping any failure points). */ 5818 /* Unconditionally jump (without popping any failure points). */
5824 case jump: 5819 case jump:
5825 unconditional_jump: 5820 unconditional_jump:
5826 IMMEDIATE_QUIT_CHECK; 5821 maybe_quit ();
5827 EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */ 5822 EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */
5828 DEBUG_PRINT ("EXECUTING jump %d ", mcnt); 5823 DEBUG_PRINT ("EXECUTING jump %d ", mcnt);
5829 p += mcnt; /* Do the jump. */ 5824 p += mcnt; /* Do the jump. */
@@ -6171,7 +6166,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
6171 6166
6172 /* We goto here if a matching operation fails. */ 6167 /* We goto here if a matching operation fails. */
6173 fail: 6168 fail:
6174 IMMEDIATE_QUIT_CHECK; 6169 maybe_quit ();
6175 if (!FAIL_STACK_EMPTY ()) 6170 if (!FAIL_STACK_EMPTY ())
6176 { 6171 {
6177 re_char *str, *pat; 6172 re_char *str, *pat;
diff --git a/src/search.c b/src/search.c
index d3045108705..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.
@@ -276,8 +295,8 @@ looking_at_1 (Lisp_Object string, bool posix)
276 posix, 295 posix,
277 !NILP (BVAR (current_buffer, enable_multibyte_characters))); 296 !NILP (BVAR (current_buffer, enable_multibyte_characters)));
278 297
279 immediate_quit = 1; 298 /* Do a pending quit right away, to avoid paradoxical behavior */
280 QUIT; /* Do a pending quit right away, to avoid paradoxical behavior */ 299 maybe_quit ();
281 300
282 /* Get pointers and sizes of the two strings 301 /* Get pointers and sizes of the two strings
283 that make up the visible portion of the buffer. */ 302 that make up the visible portion of the buffer. */
@@ -300,20 +319,13 @@ looking_at_1 (Lisp_Object string, bool posix)
300 319
301 re_match_object = Qnil; 320 re_match_object = Qnil;
302 321
303#ifdef REL_ALLOC 322 freeze_buffer_relocation ();
304 /* Prevent ralloc.c from relocating the current buffer while
305 searching it. */
306 r_alloc_inhibit_buffer_relocation (1);
307#endif
308 i = re_match_2 (bufp, (char *) p1, s1, (char *) p2, s2, 323 i = re_match_2 (bufp, (char *) p1, s1, (char *) p2, s2,
309 PT_BYTE - BEGV_BYTE, 324 PT_BYTE - BEGV_BYTE,
310 (NILP (Vinhibit_changing_match_data) 325 (NILP (Vinhibit_changing_match_data)
311 ? &search_regs : NULL), 326 ? &search_regs : NULL),
312 ZV_BYTE - BEGV_BYTE); 327 ZV_BYTE - BEGV_BYTE);
313 immediate_quit = 0; 328 thaw_buffer_relocation ();
314#ifdef REL_ALLOC
315 r_alloc_inhibit_buffer_relocation (0);
316#endif
317 329
318 if (i == -2) 330 if (i == -2)
319 matcher_overflow (); 331 matcher_overflow ();
@@ -398,7 +410,6 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
398 ? BVAR (current_buffer, case_canon_table) : Qnil), 410 ? BVAR (current_buffer, case_canon_table) : Qnil),
399 posix, 411 posix,
400 STRING_MULTIBYTE (string)); 412 STRING_MULTIBYTE (string));
401 immediate_quit = 1;
402 re_match_object = string; 413 re_match_object = string;
403 414
404 val = re_search (bufp, SSDATA (string), 415 val = re_search (bufp, SSDATA (string),
@@ -406,7 +417,6 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
406 SBYTES (string) - pos_byte, 417 SBYTES (string) - pos_byte,
407 (NILP (Vinhibit_changing_match_data) 418 (NILP (Vinhibit_changing_match_data)
408 ? &search_regs : NULL)); 419 ? &search_regs : NULL));
409 immediate_quit = 0;
410 420
411 /* Set last_thing_searched only when match data is changed. */ 421 /* Set last_thing_searched only when match data is changed. */
412 if (NILP (Vinhibit_changing_match_data)) 422 if (NILP (Vinhibit_changing_match_data))
@@ -470,13 +480,11 @@ fast_string_match_internal (Lisp_Object regexp, Lisp_Object string,
470 480
471 bufp = compile_pattern (regexp, 0, table, 481 bufp = compile_pattern (regexp, 0, table,
472 0, STRING_MULTIBYTE (string)); 482 0, STRING_MULTIBYTE (string));
473 immediate_quit = 1;
474 re_match_object = string; 483 re_match_object = string;
475 484
476 val = re_search (bufp, SSDATA (string), 485 val = re_search (bufp, SSDATA (string),
477 SBYTES (string), 0, 486 SBYTES (string), 0,
478 SBYTES (string), 0); 487 SBYTES (string), 0);
479 immediate_quit = 0;
480 return val; 488 return val;
481} 489}
482 490
@@ -497,9 +505,7 @@ fast_c_string_match_ignore_case (Lisp_Object regexp,
497 bufp = compile_pattern (regexp, 0, 505 bufp = compile_pattern (regexp, 0,
498 Vascii_canon_table, 0, 506 Vascii_canon_table, 0,
499 0); 507 0);
500 immediate_quit = 1;
501 val = re_search (bufp, string, len, 0, len, 0); 508 val = re_search (bufp, string, len, 0, len, 0);
502 immediate_quit = 0;
503 return val; 509 return val;
504} 510}
505 511
@@ -560,18 +566,10 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte,
560 } 566 }
561 567
562 buf = compile_pattern (regexp, 0, Qnil, 0, multibyte); 568 buf = compile_pattern (regexp, 0, Qnil, 0, multibyte);
563 immediate_quit = 1; 569 freeze_buffer_relocation ();
564#ifdef REL_ALLOC
565 /* Prevent ralloc.c from relocating the current buffer while
566 searching it. */
567 r_alloc_inhibit_buffer_relocation (1);
568#endif
569 len = re_match_2 (buf, (char *) p1, s1, (char *) p2, s2, 570 len = re_match_2 (buf, (char *) p1, s1, (char *) p2, s2,
570 pos_byte, NULL, limit_byte); 571 pos_byte, NULL, limit_byte);
571#ifdef REL_ALLOC 572 thaw_buffer_relocation ();
572 r_alloc_inhibit_buffer_relocation (0);
573#endif
574 immediate_quit = 0;
575 573
576 return len; 574 return len;
577} 575}
@@ -648,7 +646,7 @@ newline_cache_on_off (struct buffer *buf)
648 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
649 to the returned character position. 647 to the returned character position.
650 648
651 If ALLOW_QUIT, set immediate_quit. That's good to do 649 If ALLOW_QUIT, check for quitting. That's good to do
652 except when inside redisplay. */ 650 except when inside redisplay. */
653 651
654ptrdiff_t 652ptrdiff_t
@@ -684,8 +682,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
684 if (shortage != 0) 682 if (shortage != 0)
685 *shortage = 0; 683 *shortage = 0;
686 684
687 immediate_quit = allow_quit;
688
689 if (count > 0) 685 if (count > 0)
690 while (start != end) 686 while (start != end)
691 { 687 {
@@ -703,7 +699,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
703 ptrdiff_t next_change; 699 ptrdiff_t next_change;
704 int result = 1; 700 int result = 1;
705 701
706 immediate_quit = 0;
707 while (start < end && result) 702 while (start < end && result)
708 { 703 {
709 ptrdiff_t lim1; 704 ptrdiff_t lim1;
@@ -756,7 +751,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
756 start_byte = end_byte; 751 start_byte = end_byte;
757 break; 752 break;
758 } 753 }
759 immediate_quit = allow_quit;
760 754
761 /* START should never be after END. */ 755 /* START should never be after END. */
762 if (start_byte > ceiling_byte) 756 if (start_byte > ceiling_byte)
@@ -809,11 +803,12 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
809 803
810 if (--count == 0) 804 if (--count == 0)
811 { 805 {
812 immediate_quit = 0;
813 if (bytepos) 806 if (bytepos)
814 *bytepos = lim_byte + next; 807 *bytepos = lim_byte + next;
815 return BYTE_TO_CHAR (lim_byte + next); 808 return BYTE_TO_CHAR (lim_byte + next);
816 } 809 }
810 if (allow_quit)
811 maybe_quit ();
817 } 812 }
818 813
819 start_byte = lim_byte; 814 start_byte = lim_byte;
@@ -832,7 +827,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
832 ptrdiff_t next_change; 827 ptrdiff_t next_change;
833 int result = 1; 828 int result = 1;
834 829
835 immediate_quit = 0;
836 while (start > end && result) 830 while (start > end && result)
837 { 831 {
838 ptrdiff_t lim1; 832 ptrdiff_t lim1;
@@ -869,7 +863,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
869 start_byte = end_byte; 863 start_byte = end_byte;
870 break; 864 break;
871 } 865 }
872 immediate_quit = allow_quit;
873 866
874 /* Start should never be at or before end. */ 867 /* Start should never be at or before end. */
875 if (start_byte <= ceiling_byte) 868 if (start_byte <= ceiling_byte)
@@ -917,11 +910,12 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
917 910
918 if (++count >= 0) 911 if (++count >= 0)
919 { 912 {
920 immediate_quit = 0;
921 if (bytepos) 913 if (bytepos)
922 *bytepos = ceiling_byte + prev + 1; 914 *bytepos = ceiling_byte + prev + 1;
923 return BYTE_TO_CHAR (ceiling_byte + prev + 1); 915 return BYTE_TO_CHAR (ceiling_byte + prev + 1);
924 } 916 }
917 if (allow_quit)
918 maybe_quit ();
925 } 919 }
926 920
927 start_byte = ceiling_byte; 921 start_byte = ceiling_byte;
@@ -929,7 +923,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
929 } 923 }
930 } 924 }
931 925
932 immediate_quit = 0;
933 if (shortage) 926 if (shortage)
934 *shortage = count * direction; 927 *shortage = count * direction;
935 if (bytepos) 928 if (bytepos)
@@ -953,7 +946,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
953 the number of line boundaries left unfound, and position at 946 the number of line boundaries left unfound, and position at
954 the limit we bumped up against. 947 the limit we bumped up against.
955 948
956 If ALLOW_QUIT, set immediate_quit. That's good to do 949 If ALLOW_QUIT, check for quitting. That's good to do
957 except in special cases. */ 950 except in special cases. */
958 951
959ptrdiff_t 952ptrdiff_t
@@ -1196,10 +1189,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
1196 trt, posix, 1189 trt, posix,
1197 !NILP (BVAR (current_buffer, enable_multibyte_characters))); 1190 !NILP (BVAR (current_buffer, enable_multibyte_characters)));
1198 1191
1199 immediate_quit = 1; /* Quit immediately if user types ^G, 1192 maybe_quit (); /* Do a pending quit right away,
1200 because letting this function finish
1201 can take too long. */
1202 QUIT; /* Do a pending quit right away,
1203 to avoid paradoxical behavior */ 1193 to avoid paradoxical behavior */
1204 /* Get pointers and sizes of the two strings 1194 /* Get pointers and sizes of the two strings
1205 that make up the visible portion of the buffer. */ 1195 that make up the visible portion of the buffer. */
@@ -1221,11 +1211,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
1221 } 1211 }
1222 re_match_object = Qnil; 1212 re_match_object = Qnil;
1223 1213
1224#ifdef REL_ALLOC 1214 freeze_buffer_relocation ();
1225 /* Prevent ralloc.c from relocating the current buffer while
1226 searching it. */
1227 r_alloc_inhibit_buffer_relocation (1);
1228#endif
1229 1215
1230 while (n < 0) 1216 while (n < 0)
1231 { 1217 {
@@ -1267,13 +1253,11 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
1267 } 1253 }
1268 else 1254 else
1269 { 1255 {
1270 immediate_quit = 0; 1256 thaw_buffer_relocation ();
1271#ifdef REL_ALLOC
1272 r_alloc_inhibit_buffer_relocation (0);
1273#endif
1274 return (n); 1257 return (n);
1275 } 1258 }
1276 n++; 1259 n++;
1260 maybe_quit ();
1277 } 1261 }
1278 while (n > 0) 1262 while (n > 0)
1279 { 1263 {
@@ -1312,18 +1296,13 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
1312 } 1296 }
1313 else 1297 else
1314 { 1298 {
1315 immediate_quit = 0; 1299 thaw_buffer_relocation ();
1316#ifdef REL_ALLOC
1317 r_alloc_inhibit_buffer_relocation (0);
1318#endif
1319 return (0 - n); 1300 return (0 - n);
1320 } 1301 }
1321 n--; 1302 n--;
1303 maybe_quit ();
1322 } 1304 }
1323 immediate_quit = 0; 1305 thaw_buffer_relocation ();
1324#ifdef REL_ALLOC
1325 r_alloc_inhibit_buffer_relocation (0);
1326#endif
1327 return (pos); 1306 return (pos);
1328 } 1307 }
1329 else /* non-RE case */ 1308 else /* non-RE case */
@@ -1927,7 +1906,7 @@ boyer_moore (EMACS_INT n, unsigned char *base_pat,
1927 < 0) 1906 < 0)
1928 return (n * (0 - direction)); 1907 return (n * (0 - direction));
1929 /* First we do the part we can by pointers (maybe nothing) */ 1908 /* First we do the part we can by pointers (maybe nothing) */
1930 QUIT; 1909 maybe_quit ();
1931 pat = base_pat; 1910 pat = base_pat;
1932 limit = pos_byte - dirlen + direction; 1911 limit = pos_byte - dirlen + direction;
1933 if (direction > 0) 1912 if (direction > 0)
@@ -3230,8 +3209,6 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
3230 if (shortage != 0) 3209 if (shortage != 0)
3231 *shortage = 0; 3210 *shortage = 0;
3232 3211
3233 immediate_quit = allow_quit;
3234
3235 if (count > 0) 3212 if (count > 0)
3236 while (start != end) 3213 while (start != end)
3237 { 3214 {
@@ -3274,11 +3251,12 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
3274 3251
3275 if (--count == 0) 3252 if (--count == 0)
3276 { 3253 {
3277 immediate_quit = 0;
3278 if (bytepos) 3254 if (bytepos)
3279 *bytepos = lim_byte + next; 3255 *bytepos = lim_byte + next;
3280 return BYTE_TO_CHAR (lim_byte + next); 3256 return BYTE_TO_CHAR (lim_byte + next);
3281 } 3257 }
3258 if (allow_quit)
3259 maybe_quit ();
3282 } 3260 }
3283 3261
3284 start_byte = lim_byte; 3262 start_byte = lim_byte;
@@ -3286,7 +3264,6 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
3286 } 3264 }
3287 } 3265 }
3288 3266
3289 immediate_quit = 0;
3290 if (shortage) 3267 if (shortage)
3291 *shortage = count; 3268 *shortage = count;
3292 if (bytepos) 3269 if (bytepos)
diff --git a/src/syntax.c b/src/syntax.c
index 5bc0efa8a41..34a9e632b3c 100644
--- a/src/syntax.c
+++ b/src/syntax.c
@@ -1672,29 +1672,23 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value,
1672 COUNT negative means scan backward and stop at word beginning. */ 1672 COUNT negative means scan backward and stop at word beginning. */
1673 1673
1674ptrdiff_t 1674ptrdiff_t
1675scan_words (register ptrdiff_t from, register EMACS_INT count) 1675scan_words (ptrdiff_t from, EMACS_INT count)
1676{ 1676{
1677 register ptrdiff_t beg = BEGV; 1677 ptrdiff_t beg = BEGV;
1678 register ptrdiff_t end = ZV; 1678 ptrdiff_t end = ZV;
1679 register ptrdiff_t from_byte = CHAR_TO_BYTE (from); 1679 ptrdiff_t from_byte = CHAR_TO_BYTE (from);
1680 register enum syntaxcode code; 1680 enum syntaxcode code;
1681 int ch0, ch1; 1681 int ch0, ch1;
1682 Lisp_Object func, pos; 1682 Lisp_Object func, pos;
1683 1683
1684 immediate_quit = 1;
1685 QUIT;
1686
1687 SETUP_SYNTAX_TABLE (from, count); 1684 SETUP_SYNTAX_TABLE (from, count);
1688 1685
1689 while (count > 0) 1686 while (count > 0)
1690 { 1687 {
1691 while (1) 1688 while (true)
1692 { 1689 {
1693 if (from == end) 1690 if (from == end)
1694 { 1691 return 0;
1695 immediate_quit = 0;
1696 return 0;
1697 }
1698 UPDATE_SYNTAX_TABLE_FORWARD (from); 1692 UPDATE_SYNTAX_TABLE_FORWARD (from);
1699 ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte); 1693 ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte);
1700 code = SYNTAX (ch0); 1694 code = SYNTAX (ch0);
@@ -1704,6 +1698,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
1704 break; 1698 break;
1705 if (code == Sword) 1699 if (code == Sword)
1706 break; 1700 break;
1701 rarely_quit (from);
1707 } 1702 }
1708 /* Now CH0 is a character which begins a word and FROM is the 1703 /* Now CH0 is a character which begins a word and FROM is the
1709 position of the next character. */ 1704 position of the next character. */
@@ -1732,19 +1727,17 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
1732 break; 1727 break;
1733 INC_BOTH (from, from_byte); 1728 INC_BOTH (from, from_byte);
1734 ch0 = ch1; 1729 ch0 = ch1;
1730 rarely_quit (from);
1735 } 1731 }
1736 } 1732 }
1737 count--; 1733 count--;
1738 } 1734 }
1739 while (count < 0) 1735 while (count < 0)
1740 { 1736 {
1741 while (1) 1737 while (true)
1742 { 1738 {
1743 if (from == beg) 1739 if (from == beg)
1744 { 1740 return 0;
1745 immediate_quit = 0;
1746 return 0;
1747 }
1748 DEC_BOTH (from, from_byte); 1741 DEC_BOTH (from, from_byte);
1749 UPDATE_SYNTAX_TABLE_BACKWARD (from); 1742 UPDATE_SYNTAX_TABLE_BACKWARD (from);
1750 ch1 = FETCH_CHAR_AS_MULTIBYTE (from_byte); 1743 ch1 = FETCH_CHAR_AS_MULTIBYTE (from_byte);
@@ -1754,6 +1747,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
1754 break; 1747 break;
1755 if (code == Sword) 1748 if (code == Sword)
1756 break; 1749 break;
1750 rarely_quit (from);
1757 } 1751 }
1758 /* Now CH1 is a character which ends a word and FROM is the 1752 /* Now CH1 is a character which ends a word and FROM is the
1759 position of it. */ 1753 position of it. */
@@ -1786,13 +1780,12 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
1786 break; 1780 break;
1787 } 1781 }
1788 ch1 = ch0; 1782 ch1 = ch0;
1783 rarely_quit (from);
1789 } 1784 }
1790 } 1785 }
1791 count++; 1786 count++;
1792 } 1787 }
1793 1788
1794 immediate_quit = 0;
1795
1796 return from; 1789 return from;
1797} 1790}
1798 1791
@@ -2176,7 +2169,6 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2176 stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp; 2169 stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp;
2177 } 2170 }
2178 2171
2179 immediate_quit = 1;
2180 /* This code may look up syntax tables using functions that rely on the 2172 /* This code may look up syntax tables using functions that rely on the
2181 gl_state object. To make sure this object is not out of date, 2173 gl_state object. To make sure this object is not out of date,
2182 let's initialize it manually. 2174 let's initialize it manually.
@@ -2226,9 +2218,10 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2226 } 2218 }
2227 fwd_ok: 2219 fwd_ok:
2228 p += nbytes, pos++, pos_byte += nbytes; 2220 p += nbytes, pos++, pos_byte += nbytes;
2221 rarely_quit (pos);
2229 } 2222 }
2230 else 2223 else
2231 while (1) 2224 while (true)
2232 { 2225 {
2233 if (p >= stop) 2226 if (p >= stop)
2234 { 2227 {
@@ -2250,15 +2243,14 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2250 break; 2243 break;
2251 fwd_unibyte_ok: 2244 fwd_unibyte_ok:
2252 p++, pos++, pos_byte++; 2245 p++, pos++, pos_byte++;
2246 rarely_quit (pos);
2253 } 2247 }
2254 } 2248 }
2255 else 2249 else
2256 { 2250 {
2257 if (multibyte) 2251 if (multibyte)
2258 while (1) 2252 while (true)
2259 { 2253 {
2260 unsigned char *prev_p;
2261
2262 if (p <= stop) 2254 if (p <= stop)
2263 { 2255 {
2264 if (p <= endp) 2256 if (p <= endp)
@@ -2266,8 +2258,11 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2266 p = GPT_ADDR; 2258 p = GPT_ADDR;
2267 stop = endp; 2259 stop = endp;
2268 } 2260 }
2269 prev_p = p; 2261 unsigned char *prev_p = p;
2270 while (--p >= stop && ! CHAR_HEAD_P (*p)); 2262 do
2263 p--;
2264 while (stop <= p && ! CHAR_HEAD_P (*p));
2265
2271 c = STRING_CHAR (p); 2266 c = STRING_CHAR (p);
2272 2267
2273 if (! NILP (iso_classes) && in_classes (c, iso_classes)) 2268 if (! NILP (iso_classes) && in_classes (c, iso_classes))
@@ -2291,9 +2286,10 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2291 } 2286 }
2292 back_ok: 2287 back_ok:
2293 pos--, pos_byte -= prev_p - p; 2288 pos--, pos_byte -= prev_p - p;
2289 rarely_quit (pos);
2294 } 2290 }
2295 else 2291 else
2296 while (1) 2292 while (true)
2297 { 2293 {
2298 if (p <= stop) 2294 if (p <= stop)
2299 { 2295 {
@@ -2315,11 +2311,11 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
2315 break; 2311 break;
2316 back_unibyte_ok: 2312 back_unibyte_ok:
2317 p--, pos--, pos_byte--; 2313 p--, pos--, pos_byte--;
2314 rarely_quit (pos);
2318 } 2315 }
2319 } 2316 }
2320 2317
2321 SET_PT_BOTH (pos, pos_byte); 2318 SET_PT_BOTH (pos, pos_byte);
2322 immediate_quit = 0;
2323 2319
2324 SAFE_FREE (); 2320 SAFE_FREE ();
2325 return make_number (PT - start_point); 2321 return make_number (PT - start_point);
@@ -2393,7 +2389,6 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2393 ptrdiff_t pos_byte = PT_BYTE; 2389 ptrdiff_t pos_byte = PT_BYTE;
2394 unsigned char *p, *endp, *stop; 2390 unsigned char *p, *endp, *stop;
2395 2391
2396 immediate_quit = 1;
2397 SETUP_SYNTAX_TABLE (pos, forwardp ? 1 : -1); 2392 SETUP_SYNTAX_TABLE (pos, forwardp ? 1 : -1);
2398 2393
2399 if (forwardp) 2394 if (forwardp)
@@ -2422,6 +2417,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2422 if (! fastmap[SYNTAX (c)]) 2417 if (! fastmap[SYNTAX (c)])
2423 goto done; 2418 goto done;
2424 p += nbytes, pos++, pos_byte += nbytes; 2419 p += nbytes, pos++, pos_byte += nbytes;
2420 rarely_quit (pos);
2425 } 2421 }
2426 while (!parse_sexp_lookup_properties 2422 while (!parse_sexp_lookup_properties
2427 || pos < gl_state.e_property); 2423 || pos < gl_state.e_property);
@@ -2438,10 +2434,8 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2438 2434
2439 if (multibyte) 2435 if (multibyte)
2440 { 2436 {
2441 while (1) 2437 while (true)
2442 { 2438 {
2443 unsigned char *prev_p;
2444
2445 if (p <= stop) 2439 if (p <= stop)
2446 { 2440 {
2447 if (p <= endp) 2441 if (p <= endp)
@@ -2450,17 +2444,22 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2450 stop = endp; 2444 stop = endp;
2451 } 2445 }
2452 UPDATE_SYNTAX_TABLE_BACKWARD (pos - 1); 2446 UPDATE_SYNTAX_TABLE_BACKWARD (pos - 1);
2453 prev_p = p; 2447
2454 while (--p >= stop && ! CHAR_HEAD_P (*p)); 2448 unsigned char *prev_p = p;
2449 do
2450 p--;
2451 while (stop <= p && ! CHAR_HEAD_P (*p));
2452
2455 c = STRING_CHAR (p); 2453 c = STRING_CHAR (p);
2456 if (! fastmap[SYNTAX (c)]) 2454 if (! fastmap[SYNTAX (c)])
2457 break; 2455 break;
2458 pos--, pos_byte -= prev_p - p; 2456 pos--, pos_byte -= prev_p - p;
2457 rarely_quit (pos);
2459 } 2458 }
2460 } 2459 }
2461 else 2460 else
2462 { 2461 {
2463 while (1) 2462 while (true)
2464 { 2463 {
2465 if (p <= stop) 2464 if (p <= stop)
2466 { 2465 {
@@ -2473,13 +2472,13 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
2473 if (! fastmap[SYNTAX (p[-1])]) 2472 if (! fastmap[SYNTAX (p[-1])])
2474 break; 2473 break;
2475 p--, pos--, pos_byte--; 2474 p--, pos--, pos_byte--;
2475 rarely_quit (pos);
2476 } 2476 }
2477 } 2477 }
2478 } 2478 }
2479 2479
2480 done: 2480 done:
2481 SET_PT_BOTH (pos, pos_byte); 2481 SET_PT_BOTH (pos, pos_byte);
2482 immediate_quit = 0;
2483 2482
2484 return make_number (PT - start_point); 2483 return make_number (PT - start_point);
2485 } 2484 }
@@ -2541,9 +2540,10 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
2541 ptrdiff_t *charpos_ptr, ptrdiff_t *bytepos_ptr, 2540 ptrdiff_t *charpos_ptr, ptrdiff_t *bytepos_ptr,
2542 EMACS_INT *incomment_ptr, int *last_syntax_ptr) 2541 EMACS_INT *incomment_ptr, int *last_syntax_ptr)
2543{ 2542{
2544 register int c, c1; 2543 unsigned short int quit_count = 0;
2545 register enum syntaxcode code; 2544 int c, c1;
2546 register int syntax, other_syntax; 2545 enum syntaxcode code;
2546 int syntax, other_syntax;
2547 2547
2548 if (nesting <= 0) nesting = -1; 2548 if (nesting <= 0) nesting = -1;
2549 2549
@@ -2635,6 +2635,8 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
2635 UPDATE_SYNTAX_TABLE_FORWARD (from); 2635 UPDATE_SYNTAX_TABLE_FORWARD (from);
2636 nesting++; 2636 nesting++;
2637 } 2637 }
2638
2639 rarely_quit (++quit_count);
2638 } 2640 }
2639 *charpos_ptr = from; 2641 *charpos_ptr = from;
2640 *bytepos_ptr = from_byte; 2642 *bytepos_ptr = from_byte;
@@ -2662,14 +2664,12 @@ between them, return t; otherwise return nil. */)
2662 ptrdiff_t out_charpos, out_bytepos; 2664 ptrdiff_t out_charpos, out_bytepos;
2663 EMACS_INT dummy; 2665 EMACS_INT dummy;
2664 int dummy2; 2666 int dummy2;
2667 unsigned short int quit_count = 0;
2665 2668
2666 CHECK_NUMBER (count); 2669 CHECK_NUMBER (count);
2667 count1 = XINT (count); 2670 count1 = XINT (count);
2668 stop = count1 > 0 ? ZV : BEGV; 2671 stop = count1 > 0 ? ZV : BEGV;
2669 2672
2670 immediate_quit = 1;
2671 QUIT;
2672
2673 from = PT; 2673 from = PT;
2674 from_byte = PT_BYTE; 2674 from_byte = PT_BYTE;
2675 2675
@@ -2684,7 +2684,6 @@ between them, return t; otherwise return nil. */)
2684 if (from == stop) 2684 if (from == stop)
2685 { 2685 {
2686 SET_PT_BOTH (from, from_byte); 2686 SET_PT_BOTH (from, from_byte);
2687 immediate_quit = 0;
2688 return Qnil; 2687 return Qnil;
2689 } 2688 }
2690 c = FETCH_CHAR_AS_MULTIBYTE (from_byte); 2689 c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
@@ -2711,6 +2710,7 @@ between them, return t; otherwise return nil. */)
2711 INC_BOTH (from, from_byte); 2710 INC_BOTH (from, from_byte);
2712 UPDATE_SYNTAX_TABLE_FORWARD (from); 2711 UPDATE_SYNTAX_TABLE_FORWARD (from);
2713 } 2712 }
2713 rarely_quit (++quit_count);
2714 } 2714 }
2715 while (code == Swhitespace || (code == Sendcomment && c == '\n')); 2715 while (code == Swhitespace || (code == Sendcomment && c == '\n'));
2716 2716
@@ -2718,7 +2718,6 @@ between them, return t; otherwise return nil. */)
2718 comstyle = ST_COMMENT_STYLE; 2718 comstyle = ST_COMMENT_STYLE;
2719 else if (code != Scomment) 2719 else if (code != Scomment)
2720 { 2720 {
2721 immediate_quit = 0;
2722 DEC_BOTH (from, from_byte); 2721 DEC_BOTH (from, from_byte);
2723 SET_PT_BOTH (from, from_byte); 2722 SET_PT_BOTH (from, from_byte);
2724 return Qnil; 2723 return Qnil;
@@ -2729,7 +2728,6 @@ between them, return t; otherwise return nil. */)
2729 from = out_charpos; from_byte = out_bytepos; 2728 from = out_charpos; from_byte = out_bytepos;
2730 if (!found) 2729 if (!found)
2731 { 2730 {
2732 immediate_quit = 0;
2733 SET_PT_BOTH (from, from_byte); 2731 SET_PT_BOTH (from, from_byte);
2734 return Qnil; 2732 return Qnil;
2735 } 2733 }
@@ -2741,23 +2739,19 @@ between them, return t; otherwise return nil. */)
2741 2739
2742 while (count1 < 0) 2740 while (count1 < 0)
2743 { 2741 {
2744 while (1) 2742 while (true)
2745 { 2743 {
2746 bool quoted;
2747 int syntax;
2748
2749 if (from <= stop) 2744 if (from <= stop)
2750 { 2745 {
2751 SET_PT_BOTH (BEGV, BEGV_BYTE); 2746 SET_PT_BOTH (BEGV, BEGV_BYTE);
2752 immediate_quit = 0;
2753 return Qnil; 2747 return Qnil;
2754 } 2748 }
2755 2749
2756 DEC_BOTH (from, from_byte); 2750 DEC_BOTH (from, from_byte);
2757 /* char_quoted does UPDATE_SYNTAX_TABLE_BACKWARD (from). */ 2751 /* char_quoted does UPDATE_SYNTAX_TABLE_BACKWARD (from). */
2758 quoted = char_quoted (from, from_byte); 2752 bool quoted = char_quoted (from, from_byte);
2759 c = FETCH_CHAR_AS_MULTIBYTE (from_byte); 2753 c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
2760 syntax = SYNTAX_WITH_FLAGS (c); 2754 int syntax = SYNTAX_WITH_FLAGS (c);
2761 code = SYNTAX (c); 2755 code = SYNTAX (c);
2762 comstyle = 0; 2756 comstyle = 0;
2763 comnested = SYNTAX_FLAGS_COMMENT_NESTED (syntax); 2757 comnested = SYNTAX_FLAGS_COMMENT_NESTED (syntax);
@@ -2800,6 +2794,7 @@ between them, return t; otherwise return nil. */)
2800 } 2794 }
2801 else if (from == stop) 2795 else if (from == stop)
2802 break; 2796 break;
2797 rarely_quit (++quit_count);
2803 } 2798 }
2804 if (fence_found == 0) 2799 if (fence_found == 0)
2805 { 2800 {
@@ -2842,18 +2837,18 @@ between them, return t; otherwise return nil. */)
2842 else if (code != Swhitespace || quoted) 2837 else if (code != Swhitespace || quoted)
2843 { 2838 {
2844 leave: 2839 leave:
2845 immediate_quit = 0;
2846 INC_BOTH (from, from_byte); 2840 INC_BOTH (from, from_byte);
2847 SET_PT_BOTH (from, from_byte); 2841 SET_PT_BOTH (from, from_byte);
2848 return Qnil; 2842 return Qnil;
2849 } 2843 }
2844
2845 rarely_quit (++quit_count);
2850 } 2846 }
2851 2847
2852 count1++; 2848 count1++;
2853 } 2849 }
2854 2850
2855 SET_PT_BOTH (from, from_byte); 2851 SET_PT_BOTH (from, from_byte);
2856 immediate_quit = 0;
2857 return Qt; 2852 return Qt;
2858} 2853}
2859 2854
@@ -2887,6 +2882,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2887 EMACS_INT dummy; 2882 EMACS_INT dummy;
2888 int dummy2; 2883 int dummy2;
2889 bool multibyte_symbol_p = sexpflag && multibyte_syntax_as_symbol; 2884 bool multibyte_symbol_p = sexpflag && multibyte_syntax_as_symbol;
2885 unsigned short int quit_count = 0;
2890 2886
2891 if (depth > 0) min_depth = 0; 2887 if (depth > 0) min_depth = 0;
2892 2888
@@ -2895,14 +2891,14 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2895 2891
2896 from_byte = CHAR_TO_BYTE (from); 2892 from_byte = CHAR_TO_BYTE (from);
2897 2893
2898 immediate_quit = 1; 2894 maybe_quit ();
2899 QUIT;
2900 2895
2901 SETUP_SYNTAX_TABLE (from, count); 2896 SETUP_SYNTAX_TABLE (from, count);
2902 while (count > 0) 2897 while (count > 0)
2903 { 2898 {
2904 while (from < stop) 2899 while (from < stop)
2905 { 2900 {
2901 rarely_quit (++quit_count);
2906 bool comstart_first, prefix; 2902 bool comstart_first, prefix;
2907 int syntax, other_syntax; 2903 int syntax, other_syntax;
2908 UPDATE_SYNTAX_TABLE_FORWARD (from); 2904 UPDATE_SYNTAX_TABLE_FORWARD (from);
@@ -2971,6 +2967,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
2971 goto done; 2967 goto done;
2972 } 2968 }
2973 INC_BOTH (from, from_byte); 2969 INC_BOTH (from, from_byte);
2970 rarely_quit (++quit_count);
2974 } 2971 }
2975 goto done; 2972 goto done;
2976 2973
@@ -3042,6 +3039,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
3042 if (c_code == Scharquote || c_code == Sescape) 3039 if (c_code == Scharquote || c_code == Sescape)
3043 INC_BOTH (from, from_byte); 3040 INC_BOTH (from, from_byte);
3044 INC_BOTH (from, from_byte); 3041 INC_BOTH (from, from_byte);
3042 rarely_quit (++quit_count);
3045 } 3043 }
3046 INC_BOTH (from, from_byte); 3044 INC_BOTH (from, from_byte);
3047 if (!depth && sexpflag) goto done; 3045 if (!depth && sexpflag) goto done;
@@ -3056,7 +3054,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
3056 if (depth) 3054 if (depth)
3057 goto lose; 3055 goto lose;
3058 3056
3059 immediate_quit = 0;
3060 return Qnil; 3057 return Qnil;
3061 3058
3062 /* End of object reached */ 3059 /* End of object reached */
@@ -3068,11 +3065,11 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
3068 { 3065 {
3069 while (from > stop) 3066 while (from > stop)
3070 { 3067 {
3071 int syntax; 3068 rarely_quit (++quit_count);
3072 DEC_BOTH (from, from_byte); 3069 DEC_BOTH (from, from_byte);
3073 UPDATE_SYNTAX_TABLE_BACKWARD (from); 3070 UPDATE_SYNTAX_TABLE_BACKWARD (from);
3074 c = FETCH_CHAR_AS_MULTIBYTE (from_byte); 3071 c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
3075 syntax= SYNTAX_WITH_FLAGS (c); 3072 int syntax = SYNTAX_WITH_FLAGS (c);
3076 code = syntax_multibyte (c, multibyte_symbol_p); 3073 code = syntax_multibyte (c, multibyte_symbol_p);
3077 if (depth == min_depth) 3074 if (depth == min_depth)
3078 last_good = from; 3075 last_good = from;
@@ -3144,6 +3141,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
3144 default: goto done2; 3141 default: goto done2;
3145 } 3142 }
3146 DEC_BOTH (from, from_byte); 3143 DEC_BOTH (from, from_byte);
3144 rarely_quit (++quit_count);
3147 } 3145 }
3148 goto done2; 3146 goto done2;
3149 3147
@@ -3206,13 +3204,14 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
3206 if (syntax_multibyte (c, multibyte_symbol_p) == code) 3204 if (syntax_multibyte (c, multibyte_symbol_p) == code)
3207 break; 3205 break;
3208 } 3206 }
3207 rarely_quit (++quit_count);
3209 } 3208 }
3210 if (code == Sstring_fence && !depth && sexpflag) goto done2; 3209 if (code == Sstring_fence && !depth && sexpflag) goto done2;
3211 break; 3210 break;
3212 3211
3213 case Sstring: 3212 case Sstring:
3214 stringterm = FETCH_CHAR_AS_MULTIBYTE (from_byte); 3213 stringterm = FETCH_CHAR_AS_MULTIBYTE (from_byte);
3215 while (1) 3214 while (true)
3216 { 3215 {
3217 if (from == stop) 3216 if (from == stop)
3218 goto lose; 3217 goto lose;
@@ -3226,6 +3225,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
3226 == Sstring)) 3225 == Sstring))
3227 break; 3226 break;
3228 } 3227 }
3228 rarely_quit (++quit_count);
3229 } 3229 }
3230 if (!depth && sexpflag) goto done2; 3230 if (!depth && sexpflag) goto done2;
3231 break; 3231 break;
@@ -3239,7 +3239,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
3239 if (depth) 3239 if (depth)
3240 goto lose; 3240 goto lose;
3241 3241
3242 immediate_quit = 0;
3243 return Qnil; 3242 return Qnil;
3244 3243
3245 done2: 3244 done2:
@@ -3247,7 +3246,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
3247 } 3246 }
3248 3247
3249 3248
3250 immediate_quit = 0;
3251 XSETFASTINT (val, from); 3249 XSETFASTINT (val, from);
3252 return val; 3250 return val;
3253 3251
@@ -3340,6 +3338,7 @@ the prefix syntax flag (p). */)
3340 if (pos <= beg) 3338 if (pos <= beg)
3341 break; 3339 break;
3342 DEC_BOTH (pos, pos_byte); 3340 DEC_BOTH (pos, pos_byte);
3341 rarely_quit (pos);
3343 } 3342 }
3344 3343
3345 SET_PT_BOTH (opoint, opoint_byte); 3344 SET_PT_BOTH (opoint, opoint_byte);
@@ -3347,6 +3346,36 @@ the prefix syntax flag (p). */)
3347 return Qnil; 3346 return Qnil;
3348} 3347}
3349 3348
3349
3350/* If the character at FROM_BYTE is the second part of a 2-character
3351 comment opener based on PREV_FROM_SYNTAX, update STATE and return
3352 true. */
3353static bool
3354in_2char_comment_start (struct lisp_parse_state *state,
3355 int prev_from_syntax,
3356 ptrdiff_t prev_from,
3357 ptrdiff_t from_byte)
3358{
3359 int c1, syntax;
3360 if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax)
3361 && (c1 = FETCH_CHAR_AS_MULTIBYTE (from_byte),
3362 syntax = SYNTAX_WITH_FLAGS (c1),
3363 SYNTAX_FLAGS_COMSTART_SECOND (syntax)))
3364 {
3365 /* Record the comment style we have entered so that only
3366 the comment-end sequence of the same style actually
3367 terminates the comment section. */
3368 state->comstyle
3369 = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax);
3370 bool comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax)
3371 | SYNTAX_FLAGS_COMMENT_NESTED (syntax));
3372 state->incomment = comnested ? 1 : -1;
3373 state->comstr_start = prev_from;
3374 return true;
3375 }
3376 return false;
3377}
3378
3350/* Parse forward from FROM / FROM_BYTE to END, 3379/* Parse forward from FROM / FROM_BYTE to END,
3351 assuming that FROM has state STATE, 3380 assuming that FROM has state STATE,
3352 and return a description of the state of the parse at END. 3381 and return a description of the state of the parse at END.
@@ -3362,8 +3391,6 @@ scan_sexps_forward (struct lisp_parse_state *state,
3362 int commentstop) 3391 int commentstop)
3363{ 3392{
3364 enum syntaxcode code; 3393 enum syntaxcode code;
3365 int c1;
3366 bool comnested;
3367 struct level { ptrdiff_t last, prev; }; 3394 struct level { ptrdiff_t last, prev; };
3368 struct level levelstart[100]; 3395 struct level levelstart[100];
3369 struct level *curlevel = levelstart; 3396 struct level *curlevel = levelstart;
@@ -3377,12 +3404,12 @@ scan_sexps_forward (struct lisp_parse_state *state,
3377 ptrdiff_t prev_from; /* Keep one character before FROM. */ 3404 ptrdiff_t prev_from; /* Keep one character before FROM. */
3378 ptrdiff_t prev_from_byte; 3405 ptrdiff_t prev_from_byte;
3379 int prev_from_syntax, prev_prev_from_syntax; 3406 int prev_from_syntax, prev_prev_from_syntax;
3380 int syntax;
3381 bool boundary_stop = commentstop == -1; 3407 bool boundary_stop = commentstop == -1;
3382 bool nofence; 3408 bool nofence;
3383 bool found; 3409 bool found;
3384 ptrdiff_t out_bytepos, out_charpos; 3410 ptrdiff_t out_bytepos, out_charpos;
3385 int temp; 3411 int temp;
3412 unsigned short int quit_count = 0;
3386 3413
3387 prev_from = from; 3414 prev_from = from;
3388 prev_from_byte = from_byte; 3415 prev_from_byte = from_byte;
@@ -3401,8 +3428,7 @@ do { prev_from = from; \
3401 UPDATE_SYNTAX_TABLE_FORWARD (from); \ 3428 UPDATE_SYNTAX_TABLE_FORWARD (from); \
3402 } while (0) 3429 } while (0)
3403 3430
3404 immediate_quit = 1; 3431 maybe_quit ();
3405 QUIT;
3406 3432
3407 depth = state->depth; 3433 depth = state->depth;
3408 start_quoted = state->quoted; 3434 start_quoted = state->quoted;
@@ -3442,53 +3468,32 @@ do { prev_from = from; \
3442 } 3468 }
3443 else if (start_quoted) 3469 else if (start_quoted)
3444 goto startquoted; 3470 goto startquoted;
3471 else if ((from < end)
3472 && (in_2char_comment_start (state, prev_from_syntax,
3473 prev_from, from_byte)))
3474 {
3475 INC_FROM;
3476 prev_from_syntax = Smax; /* the syntax has already been "used up". */
3477 goto atcomment;
3478 }
3445 3479
3446 while (from < end) 3480 while (from < end)
3447 { 3481 {
3448 if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax) 3482 rarely_quit (++quit_count);
3449 && (c1 = FETCH_CHAR (from_byte), 3483 INC_FROM;
3450 syntax = SYNTAX_WITH_FLAGS (c1), 3484
3451 SYNTAX_FLAGS_COMSTART_SECOND (syntax))) 3485 if ((from < end)
3452 { 3486 && (in_2char_comment_start (state, prev_from_syntax,
3453 /* Record the comment style we have entered so that only 3487 prev_from, from_byte)))
3454 the comment-end sequence of the same style actually
3455 terminates the comment section. */
3456 state->comstyle
3457 = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax);
3458 comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax)
3459 | SYNTAX_FLAGS_COMMENT_NESTED (syntax));
3460 state->incomment = comnested ? 1 : -1;
3461 state->comstr_start = prev_from;
3462 INC_FROM;
3463 prev_from_syntax = Smax; /* the syntax has already been
3464 "used up". */
3465 code = Scomment;
3466 }
3467 else
3468 { 3488 {
3469 INC_FROM; 3489 INC_FROM;
3470 code = prev_from_syntax & 0xff; 3490 prev_from_syntax = Smax; /* the syntax has already been "used up". */
3471 if (code == Scomment_fence) 3491 goto atcomment;
3472 {
3473 /* Record the comment style we have entered so that only
3474 the comment-end sequence of the same style actually
3475 terminates the comment section. */
3476 state->comstyle = ST_COMMENT_STYLE;
3477 state->incomment = -1;
3478 state->comstr_start = prev_from;
3479 code = Scomment;
3480 }
3481 else if (code == Scomment)
3482 {
3483 state->comstyle = SYNTAX_FLAGS_COMMENT_STYLE (prev_from_syntax, 0);
3484 state->incomment = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) ?
3485 1 : -1);
3486 state->comstr_start = prev_from;
3487 }
3488 } 3492 }
3489 3493
3490 if (SYNTAX_FLAGS_PREFIX (prev_from_syntax)) 3494 if (SYNTAX_FLAGS_PREFIX (prev_from_syntax))
3491 continue; 3495 continue;
3496 code = prev_from_syntax & 0xff;
3492 switch (code) 3497 switch (code)
3493 { 3498 {
3494 case Sescape: 3499 case Sescape:
@@ -3507,24 +3512,15 @@ do { prev_from = from; \
3507 symstarted: 3512 symstarted:
3508 while (from < end) 3513 while (from < end)
3509 { 3514 {
3510 int symchar = FETCH_CHAR_AS_MULTIBYTE (from_byte); 3515 if (in_2char_comment_start (state, prev_from_syntax,
3511 3516 prev_from, from_byte))
3512 if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax)
3513 && (syntax = SYNTAX_WITH_FLAGS (symchar),
3514 SYNTAX_FLAGS_COMSTART_SECOND (syntax)))
3515 { 3517 {
3516 state->comstyle
3517 = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax);
3518 comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax)
3519 | SYNTAX_FLAGS_COMMENT_NESTED (syntax));
3520 state->incomment = comnested ? 1 : -1;
3521 state->comstr_start = prev_from;
3522 INC_FROM; 3518 INC_FROM;
3523 prev_from_syntax = Smax; 3519 prev_from_syntax = Smax; /* the syntax has already been "used up". */
3524 code = Scomment;
3525 goto atcomment; 3520 goto atcomment;
3526 } 3521 }
3527 3522
3523 int symchar = FETCH_CHAR_AS_MULTIBYTE (from_byte);
3528 switch (SYNTAX (symchar)) 3524 switch (SYNTAX (symchar))
3529 { 3525 {
3530 case Scharquote: 3526 case Scharquote:
@@ -3540,13 +3536,25 @@ do { prev_from = from; \
3540 goto symdone; 3536 goto symdone;
3541 } 3537 }
3542 INC_FROM; 3538 INC_FROM;
3539 rarely_quit (++quit_count);
3543 } 3540 }
3544 symdone: 3541 symdone:
3545 curlevel->prev = curlevel->last; 3542 curlevel->prev = curlevel->last;
3546 break; 3543 break;
3547 3544
3548 case Scomment_fence: /* Can't happen because it's handled above. */ 3545 case Scomment_fence:
3546 /* Record the comment style we have entered so that only
3547 the comment-end sequence of the same style actually
3548 terminates the comment section. */
3549 state->comstyle = ST_COMMENT_STYLE;
3550 state->incomment = -1;
3551 state->comstr_start = prev_from;
3552 goto atcomment;
3549 case Scomment: 3553 case Scomment:
3554 state->comstyle = SYNTAX_FLAGS_COMMENT_STYLE (prev_from_syntax, 0);
3555 state->incomment = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) ?
3556 1 : -1);
3557 state->comstr_start = prev_from;
3550 atcomment: 3558 atcomment:
3551 if (commentstop || boundary_stop) goto done; 3559 if (commentstop || boundary_stop) goto done;
3552 startincomment: 3560 startincomment:
@@ -3639,6 +3647,7 @@ do { prev_from = from; \
3639 break; 3647 break;
3640 } 3648 }
3641 INC_FROM; 3649 INC_FROM;
3650 rarely_quit (++quit_count);
3642 } 3651 }
3643 } 3652 }
3644 string_end: 3653 string_end:
@@ -3680,7 +3689,6 @@ do { prev_from = from; \
3680 state->levelstarts); 3689 state->levelstarts);
3681 state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax) 3690 state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax)
3682 || state->quoted) ? prev_from_syntax : Smax; 3691 || state->quoted) ? prev_from_syntax : Smax;
3683 immediate_quit = 0;
3684} 3692}
3685 3693
3686/* Convert a (lisp) parse state to the internal form used in 3694/* Convert a (lisp) parse state to the internal form used in
diff --git a/src/sysdep.c b/src/sysdep.c
index 4316c21a1c7..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 QUIT
395 internally. */
396 if (interruptible)
397 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
@@ -2383,7 +2387,7 @@ emacs_open (const char *file, int oflags, int mode)
2383 oflags |= O_BINARY; 2387 oflags |= O_BINARY;
2384 oflags |= O_CLOEXEC; 2388 oflags |= O_CLOEXEC;
2385 while ((fd = open (file, oflags, mode)) < 0 && errno == EINTR) 2389 while ((fd = open (file, oflags, mode)) < 0 && errno == EINTR)
2386 QUIT; 2390 maybe_quit ();
2387 if (! O_CLOEXEC && 0 <= fd) 2391 if (! O_CLOEXEC && 0 <= fd)
2388 fcntl (fd, F_SETFD, FD_CLOEXEC); 2392 fcntl (fd, F_SETFD, FD_CLOEXEC);
2389 return fd; 2393 return fd;
@@ -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 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 `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/textprop.c b/src/textprop.c
index bf77f84ab79..116bf3f2c93 100644
--- a/src/textprop.c
+++ b/src/textprop.c
@@ -212,7 +212,7 @@ validate_plist (Lisp_Object list)
212 if (! CONSP (tail)) 212 if (! CONSP (tail))
213 error ("Odd length text property list"); 213 error ("Odd length text property list");
214 tail = XCDR (tail); 214 tail = XCDR (tail);
215 QUIT; 215 maybe_quit ();
216 } 216 }
217 while (CONSP (tail)); 217 while (CONSP (tail));
218 218
diff --git a/src/w32fns.c b/src/w32fns.c
index c24fce11fc8..1b628b0b42e 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -778,7 +778,7 @@ w32_color_map_lookup (const char *colorname)
778 break; 778 break;
779 } 779 }
780 780
781 QUIT; 781 maybe_quit ();
782 } 782 }
783 783
784 unblock_input (); 784 unblock_input ();
@@ -3166,18 +3166,9 @@ signal_user_input (void)
3166 if (!NILP (Vthrow_on_input)) 3166 if (!NILP (Vthrow_on_input))
3167 { 3167 {
3168 Vquit_flag = Vthrow_on_input; 3168 Vquit_flag = Vthrow_on_input;
3169 /* Doing a 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 = 0;
3178 QUIT;
3179 }
3180#endif
3181 } 3172 }
3182} 3173}
3183 3174
diff --git a/src/w32notify.c b/src/w32notify.c
index 1f4cbe2df47..25205816bae 100644
--- a/src/w32notify.c
+++ b/src/w32notify.c
@@ -664,7 +664,7 @@ w32_get_watch_object (void *desc)
664 Lisp_Object descriptor = make_pointer_integer (desc); 664 Lisp_Object descriptor = make_pointer_integer (desc);
665 665
666 /* This is called from the input queue handling code, inside a 666 /* This is called from the input queue handling code, inside a
667 critical section, so we cannot possibly QUIT if watch_list is not 667 critical section, so we cannot possibly quit if watch_list is not
668 in the right condition. */ 668 in the right condition. */
669 return NILP (watch_list) ? Qnil : assoc_no_quit (descriptor, watch_list); 669 return NILP (watch_list) ? Qnil : assoc_no_quit (descriptor, watch_list);
670} 670}
diff --git a/src/w32proc.c b/src/w32proc.c
index a7f2b4a9950..0aa248a6f7b 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -1449,7 +1449,7 @@ waitpid (pid_t pid, int *status, int options)
1449 1449
1450 do 1450 do
1451 { 1451 {
1452 QUIT; 1452 maybe_quit ();
1453 active = WaitForMultipleObjects (nh, wait_hnd, FALSE, timeout_ms); 1453 active = WaitForMultipleObjects (nh, wait_hnd, FALSE, timeout_ms);
1454 } while (active == WAIT_TIMEOUT && !dont_wait); 1454 } while (active == WAIT_TIMEOUT && !dont_wait);
1455 1455
diff --git a/src/window.c b/src/window.c
index 0a6b94d4d1d..95690443f8e 100644
--- a/src/window.c
+++ b/src/window.c
@@ -521,9 +521,10 @@ select_window (Lisp_Object window, Lisp_Object norecord,
521 bset_last_selected_window (XBUFFER (w->contents), window); 521 bset_last_selected_window (XBUFFER (w->contents), window);
522 522
523 record_and_return: 523 record_and_return:
524 /* record_buffer can run QUIT, so make sure it is run only after we have 524 /* record_buffer can call maybe_quit, so make sure it is run only
525 re-established the invariant between selected_window and selected_frame, 525 after we have re-established the invariant between
526 otherwise the temporary broken invariant might "escape" (bug#14161). */ 526 selected_window and selected_frame, otherwise the temporary
527 broken invariant might "escape" (Bug#14161). */
527 if (NILP (norecord)) 528 if (NILP (norecord))
528 { 529 {
529 w->use_time = ++window_select_count; 530 w->use_time = ++window_select_count;
@@ -4769,7 +4770,6 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool whole, bool noerror)
4769{ 4770{
4770 ptrdiff_t count = SPECPDL_INDEX (); 4771 ptrdiff_t count = SPECPDL_INDEX ();
4771 4772
4772 immediate_quit = true;
4773 n = clip_to_bounds (INT_MIN, n, INT_MAX); 4773 n = clip_to_bounds (INT_MIN, n, INT_MAX);
4774 4774
4775 wset_redisplay (XWINDOW (window)); 4775 wset_redisplay (XWINDOW (window));
@@ -4788,7 +4788,36 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool whole, bool noerror)
4788 4788
4789 /* Bug#15957. */ 4789 /* Bug#15957. */
4790 XWINDOW (window)->window_end_valid = false; 4790 XWINDOW (window)->window_end_valid = false;
4791 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;
4792} 4821}
4793 4822
4794 4823
@@ -4807,7 +4836,6 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
4807 bool vscrolled = false; 4836 bool vscrolled = false;
4808 int x, y, rtop, rbot, rowh, vpos; 4837 int x, y, rtop, rbot, rowh, vpos;
4809 void *itdata = NULL; 4838 void *itdata = NULL;
4810 int window_total_lines;
4811 int frame_line_height = default_line_pixel_height (w); 4839 int frame_line_height = default_line_pixel_height (w);
4812 bool adjust_old_pointm = !NILP (Fequal (Fwindow_point (window), 4840 bool adjust_old_pointm = !NILP (Fequal (Fwindow_point (window),
4813 Fwindow_old_point (window))); 4841 Fwindow_old_point (window)));
@@ -5063,12 +5091,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
5063 /* Move PT out of scroll margins. 5091 /* Move PT out of scroll margins.
5064 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
5065 even if there is a header line. */ 5093 even if there is a header line. */
5066 window_total_lines 5094 this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
5067 = w->total_lines * WINDOW_FRAME_LINE_HEIGHT (w) / frame_line_height;
5068 this_scroll_margin = max (0, scroll_margin);
5069 this_scroll_margin
5070 = min (this_scroll_margin, window_total_lines / 4);
5071 this_scroll_margin *= frame_line_height;
5072 5095
5073 if (n > 0) 5096 if (n > 0)
5074 { 5097 {
@@ -5124,7 +5147,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
5124 in the scroll margin at the bottom. */ 5147 in the scroll margin at the bottom. */
5125 move_it_to (&it, PT, -1, 5148 move_it_to (&it, PT, -1,
5126 (it.last_visible_y - WINDOW_HEADER_LINE_HEIGHT (w) 5149 (it.last_visible_y - WINDOW_HEADER_LINE_HEIGHT (w)
5127 - this_scroll_margin - 1), 5150 - partial_line_height (&it) - this_scroll_margin - 1),
5128 -1, 5151 -1,
5129 MOVE_TO_POS | MOVE_TO_Y); 5152 MOVE_TO_POS | MOVE_TO_Y);
5130 5153
@@ -5291,9 +5314,7 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
5291 5314
5292 if (pos < ZV) 5315 if (pos < ZV)
5293 { 5316 {
5294 /* Don't use a scroll margin that is negative or too large. */ 5317 int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
5295 int this_scroll_margin =
5296 max (0, min (scroll_margin, w->total_lines / 4));
5297 5318
5298 set_marker_restricted_both (w->start, w->contents, pos, pos_byte); 5319 set_marker_restricted_both (w->start, w->contents, pos, pos_byte);
5299 w->start_at_line_beg = !NILP (bolp); 5320 w->start_at_line_beg = !NILP (bolp);
@@ -5723,8 +5744,7 @@ and redisplay normally--don't erase and redraw the frame. */)
5723 5744
5724 /* Do this after making BUF current 5745 /* Do this after making BUF current
5725 in case scroll_margin is buffer-local. */ 5746 in case scroll_margin is buffer-local. */
5726 this_scroll_margin 5747 this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
5727 = max (0, min (scroll_margin, w->total_lines / 4));
5728 5748
5729 /* Don't use redisplay code for initial frames, as the necessary 5749 /* Don't use redisplay code for initial frames, as the necessary
5730 data structures might not be set up yet then. */ 5750 data structures might not be set up yet then. */
@@ -5963,10 +5983,6 @@ from the top of the window. */)
5963 5983
5964 lines = displayed_window_lines (w); 5984 lines = displayed_window_lines (w);
5965 5985
5966#if false
5967 this_scroll_margin = max (0, min (scroll_margin, lines / 4));
5968#endif
5969
5970 if (NILP (arg)) 5986 if (NILP (arg))
5971 XSETFASTINT (arg, lines / 2); 5987 XSETFASTINT (arg, lines / 2);
5972 else 5988 else
@@ -5982,6 +5998,8 @@ from the top of the window. */)
5982 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
5983 inside #if false so as not to lose it. -- rms. */ 5999 inside #if false so as not to lose it. -- rms. */
5984 6000
6001 this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES);
6002
5985 /* 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. */
5986 iarg = max (iarg, this_scroll_margin); 6004 iarg = max (iarg, this_scroll_margin);
5987 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 168922ef06b..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)
@@ -22635,7 +22613,7 @@ move_elt_to_front (Lisp_Object elt, Lisp_Object list)
22635 else 22613 else
22636 prev = tail; 22614 prev = tail;
22637 tail = XCDR (tail); 22615 tail = XCDR (tail);
22638 QUIT; 22616 maybe_quit ();
22639 } 22617 }
22640 22618
22641 /* Not found--return unchanged LIST. */ 22619 /* Not found--return unchanged LIST. */
@@ -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/src/xselect.c b/src/xselect.c
index 47ccf6886bf..2249828fb4e 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -329,7 +329,7 @@ x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
329 Fcons (selection_data, dpyinfo->terminal->Vselection_alist)); 329 Fcons (selection_data, dpyinfo->terminal->Vselection_alist));
330 330
331 /* If we already owned the selection, remove the old selection 331 /* If we already owned the selection, remove the old selection
332 data. Don't use Fdelq as that may QUIT. */ 332 data. Don't use Fdelq as that may quit. */
333 if (!NILP (prev_value)) 333 if (!NILP (prev_value))
334 { 334 {
335 /* We know it's not the CAR, so it's easy. */ 335 /* We know it's not the CAR, so it's easy. */
@@ -929,7 +929,7 @@ x_handle_selection_clear (struct selection_input_event *event)
929 && local_selection_time > changed_owner_time) 929 && local_selection_time > changed_owner_time)
930 return; 930 return;
931 931
932 /* Otherwise, really clear. Don't use Fdelq as that may QUIT;. */ 932 /* Otherwise, really clear. Don't use Fdelq as that may quit. */
933 Vselection_alist = dpyinfo->terminal->Vselection_alist; 933 Vselection_alist = dpyinfo->terminal->Vselection_alist;
934 if (EQ (local_selection_data, CAR (Vselection_alist))) 934 if (EQ (local_selection_data, CAR (Vselection_alist)))
935 Vselection_alist = XCDR (Vselection_alist); 935 Vselection_alist = XCDR (Vselection_alist);
diff --git a/src/xterm.c b/src/xterm.c
index db561c902a6..38229a5f31f 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -635,7 +635,7 @@ x_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type)
635 (*surface_set_size_func) (surface, width, height); 635 (*surface_set_size_func) (surface, width, height);
636 636
637 unblock_input (); 637 unblock_input ();
638 QUIT; 638 maybe_quit ();
639 block_input (); 639 block_input ();
640 } 640 }
641 641
@@ -12877,7 +12877,7 @@ keysyms. The default is nil, which is the same as `super'. */);
12877 Vx_keysym_table = make_hash_table (hashtest_eql, make_number (900), 12877 Vx_keysym_table = make_hash_table (hashtest_eql, make_number (900),
12878 make_float (DEFAULT_REHASH_SIZE), 12878 make_float (DEFAULT_REHASH_SIZE),
12879 make_float (DEFAULT_REHASH_THRESHOLD), 12879 make_float (DEFAULT_REHASH_THRESHOLD),
12880 Qnil); 12880 Qnil, Qnil);
12881 12881
12882 DEFVAR_BOOL ("x-frame-normalize-before-maximize", 12882 DEFVAR_BOOL ("x-frame-normalize-before-maximize",
12883 x_frame_normalize_before_maximize, 12883 x_frame_normalize_before_maximize,
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el
index a454471ae3b..1ffcd6ac0d0 100644
--- a/test/lisp/abbrev-tests.el
+++ b/test/lisp/abbrev-tests.el
@@ -45,8 +45,7 @@
45 (should-not (abbrev-table-p [])) 45 (should-not (abbrev-table-p []))
46 ;; Missing :abbrev-table-modiff counter: 46 ;; Missing :abbrev-table-modiff counter:
47 (should-not (abbrev-table-p (obarray-make))) 47 (should-not (abbrev-table-p (obarray-make)))
48 (let* ((table (obarray-make))) 48 (should (abbrev-table-empty-p (make-abbrev-table))))
49 (should (abbrev-table-empty-p (make-abbrev-table)))))
50 49
51(ert-deftest abbrev-make-abbrev-table-test () 50(ert-deftest abbrev-make-abbrev-table-test ()
52 ;; Table without properties: 51 ;; Table without properties:
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/cl-seq-tests.el b/test/lisp/emacs-lisp/cl-seq-tests.el
index 3740b5c1836..61e3d720331 100644
--- a/test/lisp/emacs-lisp/cl-seq-tests.el
+++ b/test/lisp/emacs-lisp/cl-seq-tests.el
@@ -250,9 +250,9 @@ Body are forms defining the test."
250 (should (= 0 (cl-count -5 list))) 250 (should (= 0 (cl-count -5 list)))
251 (should (= 0 (cl-count 2 list :start 2 :end 4))) 251 (should (= 0 (cl-count 2 list :start 2 :end 4)))
252 (should (= 4 (cl-count 'foo list :key (lambda (x) (and (cl-evenp x) 'foo))))) 252 (should (= 4 (cl-count 'foo list :key (lambda (x) (and (cl-evenp x) 'foo)))))
253 (should (= 4 (cl-count 'foo list :test (lambda (a b) (cl-evenp b))))) 253 (should (= 4 (cl-count 'foo list :test (lambda (_a b) (cl-evenp b)))))
254 (should (equal (cl-count 'foo list :test (lambda (a b) (cl-oddp b))) 254 (should (equal (cl-count 'foo list :test (lambda (_a b) (cl-oddp b)))
255 (cl-count 'foo list :test-not (lambda (a b) (cl-evenp b))))))) 255 (cl-count 'foo list :test-not (lambda (_a b) (cl-evenp b)))))))
256 256
257;; keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end 257;; keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
258(ert-deftest cl-seq-mismatch-test () 258(ert-deftest cl-seq-mismatch-test ()
diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el
index fbcde4e3cbf..d04645709e4 100644
--- a/test/lisp/emacs-lisp/let-alist-tests.el
+++ b/test/lisp/emacs-lisp/let-alist-tests.el
@@ -31,7 +31,7 @@
31 (.test-two (cdr (assq 'test-two symbol)))) 31 (.test-two (cdr (assq 'test-two symbol))))
32 (list .test-one .test-two 32 (list .test-one .test-two
33 .test-two .test-two))) 33 .test-two .test-two)))
34 (cl-letf (((symbol-function #'make-symbol) (lambda (x) 'symbol))) 34 (cl-letf (((symbol-function #'make-symbol) (lambda (_x) 'symbol)))
35 (macroexpand 35 (macroexpand
36 '(let-alist data (list .test-one .test-two 36 '(let-alist data (list .test-one .test-two
37 .test-two .test-two)))))) 37 .test-two .test-two))))))
@@ -51,8 +51,7 @@
51(ert-deftest let-alist-cons () 51(ert-deftest let-alist-cons ()
52 (should 52 (should
53 (equal 53 (equal
54 (let ((.external "ext") 54 (let ((.external "ext"))
55 (.external.too "et"))
56 (let-alist '((test-two . 0) 55 (let-alist '((test-two . 0)
57 (test-three . 1) 56 (test-three . 1)
58 (sublist . ((foo . 2) 57 (sublist . ((foo . 2)
diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el
new file mode 100644
index 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/faces-tests.el b/test/lisp/faces-tests.el
index a30ba25f8f0..2b3456d47f6 100644
--- a/test/lisp/faces-tests.el
+++ b/test/lisp/faces-tests.el
@@ -23,13 +23,18 @@
23(require 'ert) 23(require 'ert)
24(require 'faces) 24(require 'faces)
25 25
26(defgroup faces--test nil ""
27 :group 'faces--test)
28
26(defface faces--test1 29(defface faces--test1
27 '((t :background "black" :foreground "black")) 30 '((t :background "black" :foreground "black"))
28 "") 31 ""
32 :group 'faces--test)
29 33
30(defface faces--test2 34(defface faces--test2
31 '((t :box 1)) 35 '((t :box 1))
32 "") 36 ""
37 :group 'faces--test)
33 38
34(ert-deftest faces--test-color-at-point () 39(ert-deftest faces--test-color-at-point ()
35 (with-temp-buffer 40 (with-temp-buffer
diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el
index a3fe3502461..827d751be69 100644
--- a/test/lisp/ffap-tests.el
+++ b/test/lisp/ffap-tests.el
@@ -44,7 +44,7 @@ index 3d7cebadcf..ad4b70d737 100644
44 str 44 str
45 (make-string ffap-max-region-length #xa) 45 (make-string ffap-max-region-length #xa)
46 (format "%s ENDS HERE" file))) 46 (format "%s ENDS HERE" file)))
47 (mark-whole-buffer) 47 (call-interactively 'mark-whole-buffer)
48 (should (equal "" (ffap-string-at-point))) 48 (should (equal "" (ffap-string-at-point)))
49 (should (equal '(1 1) ffap-string-at-point-region))))) 49 (should (equal '(1 1) ffap-string-at-point-region)))))
50 (and (file-exists-p file) (delete-file file))))) 50 (and (file-exists-p file) (delete-file file)))))
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index d237d0cc06e..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
@@ -850,6 +846,13 @@ delivered."
850 ;; After deleting the parent directory, the descriptor must 846 ;; After deleting the parent directory, the descriptor must
851 ;; not be valid anymore. 847 ;; not be valid anymore.
852 (should-not (file-notify-valid-p file-notify--test-desc)) 848 (should-not (file-notify-valid-p file-notify--test-desc))
849 ;; w32notify doesn't generate 'stopped' events when the parent
850 ;; directory is deleted, which doesn't provide a chance for
851 ;; filenotify.el to remove the descriptor from the internal
852 ;; hash table it maintains. So we must remove the descriptor
853 ;; manually.
854 (if (string-equal (file-notify--test-library) "w32notify")
855 (file-notify--rm-descriptor file-notify--test-desc))
853 856
854 ;; The environment shall be cleaned up. 857 ;; The environment shall be cleaned up.
855 (file-notify--test-cleanup-p)) 858 (file-notify--test-cleanup-p))
@@ -906,6 +909,8 @@ delivered."
906 (file-notify--test-timeout) 909 (file-notify--test-timeout)
907 (not (file-notify-valid-p file-notify--test-desc))) 910 (not (file-notify-valid-p file-notify--test-desc)))
908 (should-not (file-notify-valid-p file-notify--test-desc)) 911 (should-not (file-notify-valid-p file-notify--test-desc))
912 (if (string-equal (file-notify--test-library) "w32notify")
913 (file-notify--rm-descriptor file-notify--test-desc))
909 914
910 ;; The environment shall be cleaned up. 915 ;; The environment shall be cleaned up.
911 (file-notify--test-cleanup-p)) 916 (file-notify--test-cleanup-p))
@@ -975,6 +980,8 @@ delivered."
975 (file-notify--test-read-event) 980 (file-notify--test-read-event)
976 (delete-file file))) 981 (delete-file file)))
977 (delete-directory file-notify--test-tmpfile) 982 (delete-directory file-notify--test-tmpfile)
983 (if (string-equal (file-notify--test-library) "w32notify")
984 (file-notify--rm-descriptor file-notify--test-desc))
978 985
979 ;; The environment shall be cleaned up. 986 ;; The environment shall be cleaned up.
980 (file-notify--test-cleanup-p)) 987 (file-notify--test-cleanup-p))
@@ -1184,6 +1191,9 @@ the file watch."
1184 (delete-directory file-notify--test-tmpfile 'recursive)) 1191 (delete-directory file-notify--test-tmpfile 'recursive))
1185 (should-not (file-notify-valid-p file-notify--test-desc1)) 1192 (should-not (file-notify-valid-p file-notify--test-desc1))
1186 (should-not (file-notify-valid-p file-notify--test-desc2)) 1193 (should-not (file-notify-valid-p file-notify--test-desc2))
1194 (when (string-equal (file-notify--test-library) "w32notify")
1195 (file-notify--rm-descriptor file-notify--test-desc1)
1196 (file-notify--rm-descriptor file-notify--test-desc2))
1187 1197
1188 ;; The environment shall be cleaned up. 1198 ;; The environment shall be cleaned up.
1189 (file-notify--test-cleanup-p)) 1199 (file-notify--test-cleanup-p))
diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el
index 15eb7c170c9..4a1d566e96c 100644
--- a/test/lisp/htmlfontify-tests.el
+++ b/test/lisp/htmlfontify-tests.el
@@ -30,5 +30,17 @@
30 (symbol-function 30 (symbol-function
31 'htmlfontify-load-rgb-file)))) 31 'htmlfontify-load-rgb-file))))
32 32
33(ert-deftest htmlfontify-bug25468 ()
34 "Tests that htmlfontify can be loaded even if no shell is
35available (Bug#25468)."
36 (should (equal (let ((process-environment
37 (cons "SHELL=/does/not/exist" process-environment)))
38 (call-process
39 (expand-file-name (invocation-name) (invocation-directory))
40 nil nil nil
41 "--quick" "--batch"
42 (concat "--load=" (locate-library "htmlfontify"))))
43 0)))
44
33(provide 'htmlfontify-tests) 45(provide 'htmlfontify-tests)
34;; htmlfontify-tests.el ends here 46;; htmlfontify-tests.el ends here
diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el
index fb632e2073d..b9f7fe7cde8 100644
--- a/test/lisp/ibuffer-tests.el
+++ b/test/lisp/ibuffer-tests.el
@@ -23,6 +23,15 @@
23(eval-when-compile 23(eval-when-compile
24 (require 'ibuf-macs)) 24 (require 'ibuf-macs))
25 25
26(defvar ibuffer-filter-groups)
27(defvar ibuffer-filtering-alist)
28(defvar ibuffer-filtering-qualifiers)
29(defvar ibuffer-save-with-custom)
30(defvar ibuffer-saved-filter-groups)
31(defvar ibuffer-saved-filters)
32(declare-function ibuffer-format-qualifier "ibuf-ext" (qualifier))
33(declare-function ibuffer-unary-operand "ibuf-ext" (filter))
34
26(ert-deftest ibuffer-autoload () 35(ert-deftest ibuffer-autoload ()
27 "Tests to see whether ibuffer has been autoloaded" 36 "Tests to see whether ibuffer has been autoloaded"
28 (skip-unless (not (featurep 'ibuf-ext))) 37 (skip-unless (not (featurep 'ibuf-ext)))
diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el
new file mode 100644
index 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/minibuffer-tests.el b/test/lisp/minibuffer-tests.el
index efed8f8bed4..7c5fcb4838f 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -28,7 +28,7 @@
28 28
29(ert-deftest completion-test1 () 29(ert-deftest completion-test1 ()
30 (with-temp-buffer 30 (with-temp-buffer
31 (cl-flet* ((test/completion-table (string pred action) 31 (cl-flet* ((test/completion-table (_string _pred action)
32 (if (eq action 'lambda) 32 (if (eq action 'lambda)
33 nil 33 nil
34 "test: ")) 34 "test: "))
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 525709b92e7..0a59e3b42d1 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -22,7 +22,8 @@
22(require 'ert) 22(require 'ert)
23(require 'dbus) 23(require 'dbus)
24 24
25(setq dbus-debug nil) 25(defvar dbus-debug nil)
26(declare-function dbus-get-unique-name "dbusbind.c" (bus))
26 27
27(defvar dbus--test-enabled-session-bus 28(defvar dbus--test-enabled-session-bus
28 (and (featurep 'dbusbind) 29 (and (featurep 'dbusbind)
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/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el
index 2df1bbf50d8..1e6b867d30b 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -1156,6 +1156,27 @@ if do:
1156 (python-tests-look-at "that)") 1156 (python-tests-look-at "that)")
1157 (should (= (current-indentation) 6)))) 1157 (should (= (current-indentation) 6))))
1158 1158
1159(ert-deftest python-indent-electric-colon-4 ()
1160 "Test indentation case where there is one more-indented previous open block."
1161 (python-tests-with-temp-buffer
1162 "
1163def f():
1164 if True:
1165 a = 5
1166
1167 if True:
1168 a = 10
1169
1170 b = 3
1171
1172else
1173"
1174 (python-tests-look-at "else")
1175 (goto-char (line-end-position))
1176 (python-tests-self-insert ":")
1177 (python-tests-look-at "else" -1)
1178 (should (= (current-indentation) 4))))
1179
1159(ert-deftest python-indent-region-1 () 1180(ert-deftest python-indent-region-1 ()
1160 "Test indentation case from Bug#18843." 1181 "Test indentation case from Bug#18843."
1161 (let ((contents " 1182 (let ((contents "
@@ -2457,7 +2478,7 @@ if x:
2457 (python-tests-with-temp-buffer 2478 (python-tests-with-temp-buffer
2458 " \"\n" 2479 " \"\n"
2459 (goto-char (point-min)) 2480 (goto-char (point-min))
2460 (font-lock-fontify-buffer))) 2481 (call-interactively 'font-lock-fontify-buffer)))
2461 2482
2462 2483
2463;;; Shell integration 2484;;; Shell integration
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 6194cada1c6..f4849c4b21d 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -30,8 +30,9 @@
30 (insert "(a b") 30 (insert "(a b")
31 (save-excursion (insert " c d)")) 31 (save-excursion (insert " c d)"))
32 ,@body 32 ,@body
33 (cons (buffer-substring (point-min) (point)) 33 (with-no-warnings
34 (buffer-substring (point) (point-max))))) 34 (cons (buffer-substring (point-min) (point))
35 (buffer-substring (point) (point-max))))))
35 36
36 37
37(defmacro simple-test--transpositions (&rest body) 38(defmacro simple-test--transpositions (&rest body)
@@ -266,7 +267,6 @@
266 (with-temp-buffer 267 (with-temp-buffer
267 (setq buffer-undo-list nil) 268 (setq buffer-undo-list nil)
268 (insert "hello") 269 (insert "hello")
269 (car buffer-undo-list)
270 (undo-auto--boundaries 'test)))) 270 (undo-auto--boundaries 'test))))
271 271
272;;; Transposition with negative args (bug#20698, bug#21885) 272;;; Transposition with negative args (bug#20698, bug#21885)
diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el
index 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/textmodes/tildify-tests.el b/test/lisp/textmodes/tildify-tests.el
index 0a82b2521fb..f958fbc547a 100644
--- a/test/lisp/textmodes/tildify-tests.el
+++ b/test/lisp/textmodes/tildify-tests.el
@@ -226,7 +226,7 @@ The function must terminate as soon as callback returns nil."
226 226
227 227
228(defun tildify-space-undo-test--test 228(defun tildify-space-undo-test--test
229 (modes nbsp env-open &optional set-space-string) 229 (modes nbsp _env-open &optional set-space-string)
230 (with-temp-buffer 230 (with-temp-buffer
231 (setq-local buffer-file-coding-system 'utf-8) 231 (setq-local buffer-file-coding-system 'utf-8)
232 (dolist (mode modes) 232 (dolist (mode modes)
diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el
new file mode 100644
index 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/lisp/xml-tests.el b/test/lisp/xml-tests.el
index 0f2182a6a75..d0da2094db7 100644
--- a/test/lisp/xml-tests.el
+++ b/test/lisp/xml-tests.el
@@ -134,6 +134,21 @@ Parser is called with and without 'symbol-qnames argument.")
134 (append xml-default-ns 134 (append xml-default-ns
135 '(("F" . "FOOBAR:")))))))))) 135 '(("F" . "FOOBAR:"))))))))))
136 136
137;; Test bug #23440 (proper expansion of default namespace)
138; Test data for default namespace
139(defvar xml-parse-test--default-namespace-qnames
140 (cons "<something xmlns=\"myns:\"><whatever></whatever></something>"
141 '((myns:something
142 ((("http://www.w3.org/2000/xmlns/" . "")
143 . "myns:"))
144 (myns:whatever nil)))))
145
146(ert-deftest xml-parse-test-default-namespace-qnames ()
147 (with-temp-buffer
148 (insert (car xml-parse-test--default-namespace-qnames))
149 (should (equal (cdr xml-parse-test--default-namespace-qnames)
150 (xml-parse-region nil nil nil nil 'symbol-qnames)))))
151
137;; Local Variables: 152;; Local Variables:
138;; no-byte-compile: t 153;; no-byte-compile: t
139;; End: 154;; End:
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
diff --git a/test/src/syntax-tests.el b/test/src/syntax-tests.el
new file mode 100644
index 00000000000..6edde0b137b
--- /dev/null
+++ b/test/src/syntax-tests.el
@@ -0,0 +1,85 @@
1;;; syntax-tests.el --- tests for syntax.c functions -*- lexical-binding: t -*-
2
3;; Copyright (C) 2017 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs 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;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Code:
21
22(require 'ert)
23
24(ert-deftest parse-partial-sexp-continue-over-comment-marker ()
25 "Continue a parse that stopped in the middle of a comment marker."
26 (with-temp-buffer
27 (let ((table (make-syntax-table)))
28 (modify-syntax-entry ?/ ". 124")
29 (modify-syntax-entry ?* ". 23b")
30 (set-syntax-table table))
31 (insert "/*C*/\nX")
32 (goto-char (point-min))
33 (let* ((pointC (progn (search-forward "C") (1- (point))))
34 (preC (1- pointC))
35 (pointX (progn (search-forward "X") (1- (point))))
36 (aftC (+ 2 pointC))
37 (ppsC (parse-partial-sexp (point-min) pointC))
38 (pps-preC (parse-partial-sexp (point-min) preC))
39 (pps-aftC (parse-partial-sexp (point-min) aftC))
40 (ppsX (parse-partial-sexp (point-min) pointX)))
41 ;; C should be inside comment.
42 (should (= (nth 0 ppsC) 0))
43 (should (eq (nth 4 ppsC) t))
44 (should (= (nth 8 ppsC) (- pointC 2)))
45 ;; X should not be in comment or list.
46 (should (= (nth 0 ppsX) 0))
47 (should-not (nth 4 ppsX))
48 ;; Try using OLDSTATE.
49 (should (equal (parse-partial-sexp preC pointC nil nil pps-preC)
50 ppsC))
51 (should (equal (parse-partial-sexp pointC aftC nil nil ppsC)
52 pps-aftC))
53 (should (equal (parse-partial-sexp preC aftC nil nil pps-preC)
54 pps-aftC))
55 (should (equal (parse-partial-sexp aftC pointX nil nil pps-aftC)
56 ppsX)))))
57
58(ert-deftest parse-partial-sexp-paren-comments ()
59 "Test syntax parsing with paren comment markers.
60Specifically, where the first character of the comment marker is
61also has open paren syntax (see Bug#24870)."
62 (with-temp-buffer
63 (let ((table (make-syntax-table)))
64 (modify-syntax-entry ?\{ "(}1nb" table)
65 (modify-syntax-entry ?\} "){4nb" table)
66 (modify-syntax-entry ?- ". 123" table)
67 (set-syntax-table table))
68 (insert "{-C-}\nX")
69 (goto-char (point-min))
70 (let* ((pointC (progn (search-forward "C") (1- (point))))
71 (pointX (progn (search-forward "X") (1- (point))))
72 (ppsC (parse-partial-sexp (point-min) pointC))
73 (ppsX (parse-partial-sexp (point-min) pointX)))
74 ;; C should be inside nestable comment, not list.
75 (should (= (nth 0 ppsC) 0))
76 (should (= (nth 4 ppsC) 1))
77 (should (= (nth 8 ppsC) (- pointC 2)))
78 ;; X should not be in comment or list.
79 (should (= (nth 0 ppsX) 0))
80 (should-not (nth 4 ppsX))
81 ;; Try using OLDSTATE.
82 (should (equal (parse-partial-sexp pointC pointX nil nil ppsC)
83 ppsX)))))
84
85;;; syntax-tests.el ends here