diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/alloc.c | 299 | ||||
| -rw-r--r-- | src/atimer.c | 1 | ||||
| -rw-r--r-- | src/buffer.c | 13 | ||||
| -rw-r--r-- | src/bytecode.c | 22 | ||||
| -rw-r--r-- | src/callint.c | 2 | ||||
| -rw-r--r-- | src/callproc.c | 18 | ||||
| -rw-r--r-- | src/category.c | 2 | ||||
| -rw-r--r-- | src/ccl.c | 2 | ||||
| -rw-r--r-- | src/decompress.c | 2 | ||||
| -rw-r--r-- | src/dired.c | 9 | ||||
| -rw-r--r-- | src/dispextern.h | 1 | ||||
| -rw-r--r-- | src/doc.c | 9 | ||||
| -rw-r--r-- | src/editfns.c | 12 | ||||
| -rw-r--r-- | src/emacs-module.c | 2 | ||||
| -rw-r--r-- | src/emacs.c | 2 | ||||
| -rw-r--r-- | src/eval.c | 51 | ||||
| -rw-r--r-- | src/fileio.c | 94 | ||||
| -rw-r--r-- | src/filelock.c | 9 | ||||
| -rw-r--r-- | src/fns.c | 377 | ||||
| -rw-r--r-- | src/fontset.c | 8 | ||||
| -rw-r--r-- | src/frame.c | 5 | ||||
| -rw-r--r-- | src/gfilenotify.c | 8 | ||||
| -rw-r--r-- | src/gnutls.c | 13 | ||||
| -rw-r--r-- | src/image.c | 2 | ||||
| -rw-r--r-- | src/indent.c | 13 | ||||
| -rw-r--r-- | src/insdel.c | 12 | ||||
| -rw-r--r-- | src/keyboard.c | 109 | ||||
| -rw-r--r-- | src/keyboard.h | 2 | ||||
| -rw-r--r-- | src/keymap.c | 12 | ||||
| -rw-r--r-- | src/lisp.h | 64 | ||||
| -rw-r--r-- | src/lread.c | 16 | ||||
| -rw-r--r-- | src/macros.c | 2 | ||||
| -rw-r--r-- | src/minibuf.c | 2 | ||||
| -rw-r--r-- | src/print.c | 16 | ||||
| -rw-r--r-- | src/process.c | 22 | ||||
| -rw-r--r-- | src/profiler.c | 6 | ||||
| -rw-r--r-- | src/regex.c | 13 | ||||
| -rw-r--r-- | src/search.c | 105 | ||||
| -rw-r--r-- | src/syntax.c | 250 | ||||
| -rw-r--r-- | src/sysdep.c | 131 | ||||
| -rw-r--r-- | src/textprop.c | 2 | ||||
| -rw-r--r-- | src/w32fns.c | 15 | ||||
| -rw-r--r-- | src/w32notify.c | 2 | ||||
| -rw-r--r-- | src/w32proc.c | 2 | ||||
| -rw-r--r-- | src/window.c | 62 | ||||
| -rw-r--r-- | src/window.h | 2 | ||||
| -rw-r--r-- | src/xdisp.c | 106 | ||||
| -rw-r--r-- | src/xselect.c | 4 | ||||
| -rw-r--r-- | src/xterm.c | 4 |
49 files changed, 906 insertions, 1031 deletions
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) */) DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, doc: /* Return a newly created list of length LENGTH, with each element being INIT. */) - (register Lisp_Object length, Lisp_Object init) + (Lisp_Object length, Lisp_Object init) { - register Lisp_Object val; - register EMACS_INT size; - + Lisp_Object val = Qnil; CHECK_NATNUM (length); - size = XFASTINT (length); - val = Qnil; - while (size > 0) + for (EMACS_INT size = XFASTINT (length); 0 < size; size--) { val = Fcons (init, val); - --size; - - if (size > 0) - { - val = Fcons (init, val); - --size; - - if (size > 0) - { - val = Fcons (init, val); - --size; - - if (size > 0) - { - val = Fcons (init, val); - --size; - - if (size > 0) - { - val = Fcons (init, val); - --size; - } - } - } - } - - QUIT; + rarely_quit (size); } return val; @@ -4917,12 +4887,19 @@ mark_memory (void *start, void *end) } } -#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS +#ifndef HAVE___BUILTIN_UNWIND_INIT + +# ifdef GC_SETJMP_WORKS +static void +test_setjmp (void) +{ +} +# else static bool setjmp_tested_p; static int longjmps_done; -#define SETJMP_WILL_LIKELY_WORK "\ +# define SETJMP_WILL_LIKELY_WORK "\ \n\ Emacs garbage collector has been changed to use conservative stack\n\ marking. Emacs has determined that the method it uses to do the\n\ @@ -4935,7 +4912,7 @@ verify that the methods used are appropriate for your system.\n\ Please mail the result to <emacs-devel@gnu.org>.\n\ " -#define SETJMP_WILL_NOT_WORK "\ +# define SETJMP_WILL_NOT_WORK "\ \n\ Emacs garbage collector has been changed to use conservative stack\n\ marking. Emacs has determined that the default method it uses to do the\n\ @@ -4961,6 +4938,9 @@ Please mail the result to <emacs-devel@gnu.org>.\n\ static void test_setjmp (void) { + if (setjmp_tested_p) + return; + setjmp_tested_p = true; char buf[10]; register int x; sys_jmp_buf jbuf; @@ -4997,9 +4977,60 @@ test_setjmp (void) if (longjmps_done == 1) sys_longjmp (jbuf, 1); } +# endif /* ! GC_SETJMP_WORKS */ +#endif /* ! HAVE___BUILTIN_UNWIND_INIT */ -#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */ +/* The type of an object near the stack top, whose address can be used + as a stack scan limit. */ +typedef union +{ + /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT, + jmp_buf may not be aligned enough on darwin-ppc64. */ + max_align_t o; +#ifndef HAVE___BUILTIN_UNWIND_INIT + sys_jmp_buf j; + char c; +#endif +} stacktop_sentry; + +/* Force callee-saved registers and register windows onto the stack. + Use the platform-defined __builtin_unwind_init if available, + obviating the need for machine dependent methods. */ +#ifndef HAVE___BUILTIN_UNWIND_INIT +# ifdef __sparc__ + /* This trick flushes the register windows so that all the state of + the process is contained in the stack. + FreeBSD does not have a ta 3 handler, so handle it specially. + FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is + needed on ia64 too. See mach_dep.c, where it also says inline + assembler doesn't work with relevant proprietary compilers. */ +# if defined __sparc64__ && defined __FreeBSD__ +# define __builtin_unwind_init() asm ("flushw") +# else +# define __builtin_unwind_init() asm ("ta 3") +# endif +# else +# define __builtin_unwind_init() ((void) 0) +# endif +#endif +/* Set *P to the address of the top of the stack. This must be a + macro, not a function, so that it is executed in the caller’s + environment. It is not inside a do-while so that its storage + survives the macro. */ +#ifdef HAVE___BUILTIN_UNWIND_INIT +# define SET_STACK_TOP_ADDRESS(p) \ + stacktop_sentry sentry; \ + __builtin_unwind_init (); \ + *(p) = &sentry +#else +# define SET_STACK_TOP_ADDRESS(p) \ + stacktop_sentry sentry; \ + __builtin_unwind_init (); \ + test_setjmp (); \ + sys_setjmp (sentry.j); \ + *(p) = &sentry + (stack_bottom < &sentry.c) +#endif /* Mark live Lisp objects on the C stack. @@ -5011,12 +5042,7 @@ test_setjmp (void) We have to mark Lisp objects in CPU registers that can hold local variables or are used to pass parameters. - If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to - something that either saves relevant registers on the stack, or - calls mark_maybe_object passing it each register's contents. - - If GC_SAVE_REGISTERS_ON_STACK is not defined, the current - implementation assumes that calling setjmp saves registers we need + This code assumes that calling setjmp saves registers we need to see in a jmp_buf which itself lies on the stack. This doesn't have to be true! It must be verified for each system, possibly by taking a look at the source code of setjmp. @@ -5080,62 +5106,9 @@ flush_stack_call_func (void (*func) (void *arg), void *arg) { void *end; struct thread_state *self = current_thread; - -#ifdef HAVE___BUILTIN_UNWIND_INIT - /* Force callee-saved registers and register windows onto the stack. - This is the preferred method if available, obviating the need for - machine dependent methods. */ - __builtin_unwind_init (); - end = &end; -#else /* not HAVE___BUILTIN_UNWIND_INIT */ -#ifndef GC_SAVE_REGISTERS_ON_STACK - /* jmp_buf may not be aligned enough on darwin-ppc64 */ - union aligned_jmpbuf { - Lisp_Object o; - sys_jmp_buf j; - } j; - volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom; -#endif - /* This trick flushes the register windows so that all the state of - the process is contained in the stack. */ - /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is - needed on ia64 too. See mach_dep.c, where it also says inline - assembler doesn't work with relevant proprietary compilers. */ -#ifdef __sparc__ -#if defined (__sparc64__) && defined (__FreeBSD__) - /* FreeBSD does not have a ta 3 handler. */ - asm ("flushw"); -#else - asm ("ta 3"); -#endif -#endif - - /* Save registers that we need to see on the stack. We need to see - registers used to hold register variables and registers used to - pass parameters. */ -#ifdef GC_SAVE_REGISTERS_ON_STACK - GC_SAVE_REGISTERS_ON_STACK (end); -#else /* not GC_SAVE_REGISTERS_ON_STACK */ - -#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that - setjmp will definitely work, test it - and print a message with the result - of the test. */ - if (!setjmp_tested_p) - { - setjmp_tested_p = 1; - test_setjmp (); - } -#endif /* GC_SETJMP_WORKS */ - - sys_setjmp (j.j); - end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; -#endif /* not GC_SAVE_REGISTERS_ON_STACK */ -#endif /* not HAVE___BUILTIN_UNWIND_INIT */ - + SET_STACK_TOP_ADDRESS (&end); self->stack_top = end; - (*func) (arg); - + func (arg); eassert (current_thread == self); } @@ -5464,6 +5437,38 @@ make_pure_vector (ptrdiff_t len) return new; } +/* Copy all contents and parameters of TABLE to a new table allocated + from pure space, return the purified table. */ +static struct Lisp_Hash_Table * +purecopy_hash_table (struct Lisp_Hash_Table *table) +{ + eassert (NILP (table->weak)); + eassert (!NILP (table->pure)); + + struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike); + struct hash_table_test pure_test = table->test; + + /* Purecopy the hash table test. */ + pure_test.name = purecopy (table->test.name); + pure_test.user_hash_function = purecopy (table->test.user_hash_function); + pure_test.user_cmp_function = purecopy (table->test.user_cmp_function); + + pure->test = pure_test; + pure->header = table->header; + pure->weak = purecopy (Qnil); + pure->rehash_size = purecopy (table->rehash_size); + pure->rehash_threshold = purecopy (table->rehash_threshold); + pure->hash = purecopy (table->hash); + pure->next = purecopy (table->next); + pure->next_free = purecopy (table->next_free); + pure->index = purecopy (table->index); + pure->count = table->count; + pure->key_and_value = purecopy (table->key_and_value); + pure->pure = purecopy (table->pure); + + return pure; +} + DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, doc: /* Make a copy of object OBJ in pure storage. Recursively copies contents of vectors and cons cells. @@ -5472,14 +5477,20 @@ Does not copy symbols. Copies strings without text properties. */) { if (NILP (Vpurify_flag)) return obj; - else if (MARKERP (obj) || OVERLAYP (obj) - || HASH_TABLE_P (obj) || SYMBOLP (obj)) + else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj)) /* Can't purify those. */ return obj; else return purecopy (obj); } +/* Pinned objects are marked before every GC cycle. */ +static struct pinned_object +{ + Lisp_Object object; + struct pinned_object *next; +} *pinned_objects; + static Lisp_Object purecopy (Lisp_Object obj) { @@ -5507,7 +5518,27 @@ purecopy (Lisp_Object obj) obj = make_pure_string (SSDATA (obj), SCHARS (obj), SBYTES (obj), STRING_MULTIBYTE (obj)); - else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj)) + else if (HASH_TABLE_P (obj)) + { + struct Lisp_Hash_Table *table = XHASH_TABLE (obj); + /* Do not purify hash tables which haven't been defined with + :purecopy as non-nil or are weak - they aren't guaranteed to + not change. */ + if (!NILP (table->weak) || NILP (table->pure)) + { + /* Instead, add the hash table to the list of pinned objects, + so that it will be marked during GC. */ + struct pinned_object *o = xmalloc (sizeof *o); + o->object = obj; + o->next = pinned_objects; + pinned_objects = o; + return obj; /* Don't hash cons it. */ + } + + struct Lisp_Hash_Table *h = purecopy_hash_table (table); + XSET_HASH_TABLE (obj, h); + } + else if (COMPILEDP (obj) || VECTORP (obj)) { struct Lisp_Vector *objp = XVECTOR (obj); ptrdiff_t nbytes = vector_nbytes (objp); @@ -5724,6 +5755,13 @@ compact_undo_list (Lisp_Object list) } static void +mark_pinned_objects (void) +{ + for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next) + mark_object (pobj->object); +} + +static void mark_pinned_symbols (void) { struct symbol_block *sblk; @@ -5843,6 +5881,7 @@ garbage_collect_1 (void *end) for (i = 0; i < staticidx; i++) mark_object (*staticvec[i]); + mark_pinned_objects (); mark_pinned_symbols (); mark_terminals (); mark_kboards (); @@ -6011,58 +6050,7 @@ See Info node `(elisp)Garbage Collection'. */) (void) { void *end; - -#ifdef HAVE___BUILTIN_UNWIND_INIT - /* Force callee-saved registers and register windows onto the stack. - This is the preferred method if available, obviating the need for - machine dependent methods. */ - __builtin_unwind_init (); - end = &end; -#else /* not HAVE___BUILTIN_UNWIND_INIT */ -#ifndef GC_SAVE_REGISTERS_ON_STACK - /* jmp_buf may not be aligned enough on darwin-ppc64 */ - union aligned_jmpbuf { - Lisp_Object o; - sys_jmp_buf j; - } j; - volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base; -#endif - /* This trick flushes the register windows so that all the state of - the process is contained in the stack. */ - /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is - needed on ia64 too. See mach_dep.c, where it also says inline - assembler doesn't work with relevant proprietary compilers. */ -#ifdef __sparc__ -#if defined (__sparc64__) && defined (__FreeBSD__) - /* FreeBSD does not have a ta 3 handler. */ - asm ("flushw"); -#else - asm ("ta 3"); -#endif -#endif - - /* Save registers that we need to see on the stack. We need to see - registers used to hold register variables and registers used to - pass parameters. */ -#ifdef GC_SAVE_REGISTERS_ON_STACK - GC_SAVE_REGISTERS_ON_STACK (end); -#else /* not GC_SAVE_REGISTERS_ON_STACK */ - -#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that - setjmp will definitely work, test it - and print a message with the result - of the test. */ - if (!setjmp_tested_p) - { - setjmp_tested_p = 1; - test_setjmp (); - } -#endif /* GC_SETJMP_WORKS */ - - sys_setjmp (j.j); - end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; -#endif /* not GC_SAVE_REGISTERS_ON_STACK */ -#endif /* not HAVE___BUILTIN_UNWIND_INIT */ + SET_STACK_TOP_ADDRESS (&end); return garbage_collect_1 (end); } @@ -7372,9 +7360,6 @@ init_alloc_once (void) void init_alloc (void) { -#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS - setjmp_tested_p = longjmps_done = 0; -#endif Vgc_elapsed = make_float (0.0); gcs_done = 0; diff --git a/src/atimer.c b/src/atimer.c index 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/>. */ #include <stdio.h> #include "lisp.h" +#include "keyboard.h" #include "syssignal.h" #include "systime.h" #include "atimer.h" diff --git a/src/buffer.c b/src/buffer.c index 0a317ad7d98..713c1e5b944 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -420,19 +420,16 @@ followed by the rest of the buffers. */) } /* Like Fassoc, but use Fstring_equal to compare - (which ignores text properties), - and don't ever QUIT. */ + (which ignores text properties), and don't ever quit. */ static Lisp_Object -assoc_ignore_text_properties (register Lisp_Object key, Lisp_Object list) +assoc_ignore_text_properties (Lisp_Object key, Lisp_Object list) { - register Lisp_Object tail; + Lisp_Object tail; for (tail = list; CONSP (tail); tail = XCDR (tail)) { - register Lisp_Object elt, tem; - elt = XCAR (tail); - tem = Fstring_equal (Fcar (elt), key); - if (!NILP (tem)) + Lisp_Object elt = XCAR (tail); + if (!NILP (Fstring_equal (Fcar (elt), key))) return elt; } return Qnil; diff --git a/src/bytecode.c b/src/bytecode.c index 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, { quitcounter = 1; maybe_gc (); - QUIT; + maybe_quit (); } pc += op; NEXT; @@ -841,11 +841,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { Lisp_Object v2 = POP, v1 = TOP; CHECK_NUMBER (v1); - EMACS_INT n = XINT (v1); - immediate_quit = true; - while (--n >= 0 && CONSP (v2)) - v2 = XCDR (v2); - immediate_quit = false; + for (EMACS_INT n = XINT (v1); 0 < n && CONSP (v2); n--) + { + v2 = XCDR (v2); + rarely_quit (n); + } TOP = CAR (v2); NEXT; } @@ -1275,11 +1275,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* Exchange args and then do nth. */ Lisp_Object v2 = POP, v1 = TOP; CHECK_NUMBER (v2); - EMACS_INT n = XINT (v2); - immediate_quit = true; - while (--n >= 0 && CONSP (v1)) - v1 = XCDR (v1); - immediate_quit = false; + for (EMACS_INT n = XINT (v2); 0 < n && CONSP (v1); n--) + { + v1 = XCDR (v1); + rarely_quit (n); + } TOP = CAR (v1); } else diff --git a/src/callint.c b/src/callint.c index 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 } unbind_to (speccount, Qnil); - QUIT; + maybe_quit (); args[0] = Qfuncall_interactively; args[1] = function; diff --git a/src/callproc.c b/src/callproc.c index 90c15de2913..84324c48dcf 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -198,11 +198,11 @@ call_process_cleanup (Lisp_Object buffer) { kill (-synch_process_pid, SIGINT); message1 ("Waiting for process to die...(type C-g again to kill it instantly)"); - immediate_quit = 1; - QUIT; + + /* This will quit on C-g. */ wait_for_termination (synch_process_pid, 0, 1); + synch_process_pid = 0; - immediate_quit = 0; message1 ("Waiting for process to die...done"); } #endif /* !MSDOS */ @@ -726,9 +726,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, process_coding.src_multibyte = 0; } - immediate_quit = 1; - QUIT; - if (0 <= fd0) { enum { CALLPROC_BUFFER_SIZE_MIN = 16 * 1024 }; @@ -749,8 +746,8 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, nread = carryover; while (nread < bufsize - 1024) { - int this_read = emacs_read (fd0, buf + nread, - bufsize - nread); + int this_read = emacs_read_quit (fd0, buf + nread, + bufsize - nread); if (this_read < 0) goto give_up; @@ -769,7 +766,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, } /* Now NREAD is the total amount of data in the buffer. */ - immediate_quit = 0; if (!nread) ; @@ -842,8 +838,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, we should have already detected a coding system. */ display_on_the_fly = true; } - immediate_quit = true; - QUIT; } give_up: ; @@ -860,8 +854,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, wait_for_termination (pid, &status, fd0 < 0); #endif - immediate_quit = 0; - /* Don't kill any children that the subprocess may have left behind when exiting. */ synch_process_pid = 0; diff --git a/src/category.c b/src/category.c index 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) make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil)); + Qnil, Qnil)); h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]); i = hash_lookup (h, category_set, &hash); if (i >= 0) diff --git a/src/ccl.c b/src/ccl.c index c172fc66811..90bd2f46794 100644 --- a/src/ccl.c +++ b/src/ccl.c @@ -1993,7 +1993,7 @@ programs. */) : 0); ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil); - QUIT; + maybe_quit (); if (ccl.status != CCL_STAT_SUCCESS) error ("Error in CCL program at %dth code", ccl.ic); diff --git a/src/decompress.c b/src/decompress.c index f6628d5ddd9..a53a66df187 100644 --- a/src/decompress.c +++ b/src/decompress.c @@ -186,7 +186,7 @@ This function can be called only in unibyte buffers. */) decompressed = avail_out - stream.avail_out; insert_from_gap (decompressed, decompressed, 0); unwind_data.nbytes += decompressed; - QUIT; + maybe_quit (); } while (inflate_status == Z_OK); diff --git a/src/dired.c b/src/dired.c index bf10f1710ff..5ea00fb8db4 100644 --- a/src/dired.c +++ b/src/dired.c @@ -139,7 +139,7 @@ read_dirent (DIR *dir, Lisp_Object dirname) #endif report_file_error ("Reading directory", dirname); } - QUIT; + maybe_quit (); } } @@ -248,14 +248,11 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, /* Now that we have unwind_protect in place, we might as well allow matching to be interrupted. */ - immediate_quit = 1; - QUIT; + maybe_quit (); bool wanted = (NILP (match) || re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0); - immediate_quit = 0; - if (wanted) { if (!NILP (full)) @@ -508,7 +505,7 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, ptrdiff_t len = dirent_namelen (dp); bool canexclude = 0; - QUIT; + maybe_quit (); if (len < SCHARS (encoded_file) || (scmp (dp->d_name, SSDATA (encoded_file), SCHARS (encoded_file)) diff --git a/src/dispextern.h b/src/dispextern.h index 51222e636be..eb71a82311c 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3263,6 +3263,7 @@ void move_it_past_eol (struct it *); void move_it_in_display_line (struct it *it, ptrdiff_t to_charpos, int to_x, enum move_operation_enum op); +int partial_line_height (struct it *it_origin); bool in_display_vector_p (struct it *); int frame_mode_line_height (struct frame *); extern bool redisplaying_p; diff --git a/src/doc.c b/src/doc.c index 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) If we read the same block last time, maybe skip this? */ if (space_left > 1024 * 8) space_left = 1024 * 8; - nread = emacs_read (fd, p, space_left); + nread = emacs_read_quit (fd, p, space_left); if (nread < 0) report_file_error ("Read error on documentation file", file); p[nread] = 0; @@ -590,16 +590,15 @@ the same file name is found in the `doc-directory'. */) Vdoc_file_name = filename; filled = 0; pos = 0; - while (1) + while (true) { - register char *end; if (filled < 512) - filled += emacs_read (fd, &buf[filled], sizeof buf - 1 - filled); + filled += emacs_read_quit (fd, &buf[filled], sizeof buf - 1 - filled); if (!filled) break; buf[filled] = 0; - end = buf + (filled < 512 ? filled : filled - 128); + char *end = buf + (filled < 512 ? filled : filled - 128); p = memchr (buf, '\037', end - buf); /* p points to ^_Ffunctionname\n or ^_Vvarname\n or ^_Sfilename\n. */ if (p) diff --git a/src/editfns.c b/src/editfns.c index bee3bbc2cdd..4618164d008 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -2695,7 +2695,7 @@ called interactively, INHERIT is t. */) string[i] = str[i % len]; while (n > stringlen) { - QUIT; + maybe_quit (); if (!NILP (inherit)) insert_and_inherit (string, stringlen); else @@ -3060,8 +3060,6 @@ determines whether case is significant or ignored. */) characters, not just the bytes. */ int c1, c2; - QUIT; - if (! NILP (BVAR (bp1, enable_multibyte_characters))) { c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte); @@ -3093,12 +3091,12 @@ determines whether case is significant or ignored. */) c1 = char_table_translate (trt, c1); c2 = char_table_translate (trt, c2); } - if (c1 < c2) - return make_number (- 1 - chars); - if (c1 > c2) - return make_number (chars + 1); + + if (c1 != c2) + return make_number (c1 < c2 ? -1 - chars : chars + 1); chars++; + rarely_quit (chars); } /* The strings match as far as they go. diff --git a/src/emacs-module.c b/src/emacs-module.c index e22c7dc5b72..69fa5c8e64c 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -1016,7 +1016,7 @@ syms_of_module (void) = make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil); + Qnil, Qnil); Funintern (Qmodule_refs_hash, Qnil); DEFSYM (Qmodule_environments, "module-environments"); diff --git a/src/emacs.c b/src/emacs.c index 28b395c4fb4..3083d0df302 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -688,7 +688,7 @@ main (int argc, char **argv) dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0 || strcmp (argv[argc - 1], "bootstrap") == 0 ); - generating_ldefs_boot = getenv ("GENERATE_LDEFS_BOOT"); + generating_ldefs_boot = !!getenv ("GENERATE_LDEFS_BOOT"); /* True if address randomization interferes with memory allocation. */ diff --git a/src/eval.c b/src/eval.c index c05c8d8f8de..22b02b49521 100644 --- a/src/eval.c +++ b/src/eval.c @@ -856,11 +856,9 @@ usage: (let* VARLIST BODY...) */) lexenv = Vinternal_interpreter_environment; - varlist = XCAR (args); - CHECK_LIST (varlist); - while (CONSP (varlist)) + for (varlist = XCAR (args); CONSP (varlist); varlist = XCDR (varlist)) { - QUIT; + maybe_quit (); elt = XCAR (varlist); if (SYMBOLP (elt)) @@ -894,9 +892,8 @@ usage: (let* VARLIST BODY...) */) } else specbind (var, val); - - varlist = XCDR (varlist); } + CHECK_LIST_END (varlist, XCAR (args)); val = Fprogn (XCDR (args)); return unbind_to (count, val); @@ -928,7 +925,7 @@ usage: (let VARLIST BODY...) */) for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) { - QUIT; + maybe_quit (); elt = XCAR (varlist); if (SYMBOLP (elt)) temps [argnum++] = Qnil; @@ -981,7 +978,7 @@ usage: (while TEST BODY...) */) body = XCDR (args); while (!NILP (eval_sub (test))) { - QUIT; + maybe_quit (); prog_ignore (body); } @@ -1014,7 +1011,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */) until we get a symbol that is not an alias. */ while (SYMBOLP (def)) { - QUIT; + maybe_quit (); sym = def; tem = Fassq (sym, environment); if (NILP (tem)) @@ -1134,7 +1131,6 @@ unwind_to_catch (struct handler *catch, Lisp_Object value) /* Restore certain special C variables. */ set_poll_suppress_count (catch->poll_suppress_count); unblock_input_to (catch->interrupt_input_blocked); - immediate_quit = 0; do { @@ -1453,7 +1449,7 @@ static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object); static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data); -void +static void process_quit_flag (void) { Lisp_Object flag = Vquit_flag; @@ -1465,6 +1461,28 @@ process_quit_flag (void) quit (); } +/* Check quit-flag and quit if it is non-nil. Typing C-g does not + directly cause a quit; it only sets Vquit_flag. So the program + needs to call maybe_quit at times when it is safe to quit. Every + loop that might run for a long time or might not exit ought to call + maybe_quit at least once, at a safe place. Unless that is + impossible, of course. But it is very desirable to avoid creating + loops where maybe_quit is impossible. + + If quit-flag is set to `kill-emacs' the SIGINT handler has received + a request to exit Emacs when it is safe to do. + + When not quitting, process any pending signals. */ + +void +maybe_quit (void) +{ + if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) + process_quit_flag (); + else if (pending_signals) + process_pending_signals (); +} + DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0, doc: /* Signal an error. Args are ERROR-SYMBOL and associated DATA. This function does not return. @@ -1508,10 +1526,9 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit) Lisp_Object string; Lisp_Object real_error_symbol = (NILP (error_symbol) ? Fcar (data) : error_symbol); - register Lisp_Object clause = Qnil; + Lisp_Object clause = Qnil; struct handler *h; - immediate_quit = 0; if (gc_in_progress || waiting_for_input) emacs_abort (); @@ -2129,7 +2146,7 @@ eval_sub (Lisp_Object form) if (!CONSP (form)) return form; - QUIT; + maybe_quit (); maybe_gc (); @@ -2715,7 +2732,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) Lisp_Object val; ptrdiff_t count; - QUIT; + maybe_quit (); if (++lisp_eval_depth > max_lisp_eval_depth) { @@ -2960,7 +2977,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, bool previous_optional_or_rest = false; for (; CONSP (syms_left); syms_left = XCDR (syms_left)) { - QUIT; + maybe_quit (); next = XCAR (syms_left); if (!SYMBOLP (next)) @@ -3098,7 +3115,7 @@ lambda_arity (Lisp_Object fun) if (EQ (XCAR (fun), Qclosure)) { fun = XCDR (fun); /* Drop `closure'. */ - CHECK_LIST_CONS (fun, fun); + CHECK_CONS (fun); } syms_left = XCDR (fun); if (CONSP (syms_left)) diff --git a/src/fileio.c b/src/fileio.c index 8c8cba9e49c..38400623793 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -316,7 +316,7 @@ use the standard functions without calling themselves recursively. */) } } - QUIT; + maybe_quit (); } return result; } @@ -1960,9 +1960,7 @@ permissions. */) report_file_error ("Copying permissions to", newname); } #else /* not WINDOWSNT */ - immediate_quit = 1; ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0); - immediate_quit = 0; if (ifd < 0) report_file_error ("Opening input file", file); @@ -2024,8 +2022,7 @@ permissions. */) oldsize = out_st.st_size; } - immediate_quit = 1; - QUIT; + maybe_quit (); if (clone_file (ofd, ifd)) newsize = st.st_size; @@ -2033,9 +2030,9 @@ permissions. */) { char buf[MAX_ALLOCA]; ptrdiff_t n; - for (newsize = 0; 0 < (n = emacs_read (ifd, buf, sizeof buf)); + for (newsize = 0; 0 < (n = emacs_read_quit (ifd, buf, sizeof buf)); newsize += n) - if (emacs_write_sig (ofd, buf, n) != n) + if (emacs_write_quit (ofd, buf, n) != n) report_file_error ("Write error", newname); if (n < 0) report_file_error ("Read error", file); @@ -2047,8 +2044,6 @@ permissions. */) if (newsize < oldsize && ftruncate (ofd, newsize) != 0) report_file_error ("Truncating output file", newname); - immediate_quit = 0; - #ifndef MSDOS /* Preserve the original file permissions, and if requested, also its owner and group. */ @@ -2682,7 +2677,7 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0, DEFUN ("access-file", Faccess_file, Saccess_file, 2, 2, 0, doc: /* Access file FILENAME, and get an error if that does not work. -The second argument STRING is used in the error message. +The second argument STRING is prepended to the error message. If there is no error, returns nil. */) (Lisp_Object filename, Lisp_Object string) { @@ -2815,7 +2810,17 @@ really is a readable and searchable directory. */) if (!NILP (handler)) { Lisp_Object r = call2 (handler, Qfile_accessible_directory_p, absname); - errno = 0; + + /* Set errno in case the handler failed. EACCES might be a lie + (e.g., the directory might not exist, or be a regular file), + but at least it does TRT in the "usual" case of an existing + directory that is not accessible by the current user, and + avoids reporting "Success" for a failed operation. Perhaps + someday we can fix this in a better way, by improving + file-accessible-directory-p's API; see Bug#25419. */ + if (!EQ (r, Qt)) + errno = EACCES; + return r; } @@ -3391,15 +3396,10 @@ decide_coding_unwind (Lisp_Object unwind_data) static Lisp_Object read_non_regular (Lisp_Object state) { - int nbytes; - - immediate_quit = 1; - QUIT; - nbytes = emacs_read (XSAVE_INTEGER (state, 0), - ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE - + XSAVE_INTEGER (state, 1)), - XSAVE_INTEGER (state, 2)); - immediate_quit = 0; + int nbytes = emacs_read_quit (XSAVE_INTEGER (state, 0), + ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + + XSAVE_INTEGER (state, 1)), + XSAVE_INTEGER (state, 2)); /* Fast recycle this object for the likely next call. */ free_misc (state); return make_number (nbytes); @@ -3743,17 +3743,17 @@ by calling `format-decode', which see. */) int nread; if (st.st_size <= (1024 * 4)) - nread = emacs_read (fd, read_buf, 1024 * 4); + nread = emacs_read_quit (fd, read_buf, 1024 * 4); else { - nread = emacs_read (fd, read_buf, 1024); + nread = emacs_read_quit (fd, read_buf, 1024); if (nread == 1024) { int ntail; if (lseek (fd, - (1024 * 3), SEEK_END) < 0) report_file_error ("Setting file position", orig_filename); - ntail = emacs_read (fd, read_buf + nread, 1024 * 3); + ntail = emacs_read_quit (fd, read_buf + nread, 1024 * 3); nread = ntail < 0 ? ntail : nread + ntail; } } @@ -3858,15 +3858,11 @@ by calling `format-decode', which see. */) report_file_error ("Setting file position", orig_filename); } - immediate_quit = 1; - QUIT; /* Count how many chars at the start of the file match the text at the beginning of the buffer. */ - while (1) + while (true) { - int nread, bufpos; - - nread = emacs_read (fd, read_buf, sizeof read_buf); + int nread = emacs_read_quit (fd, read_buf, sizeof read_buf); if (nread < 0) report_file_error ("Read error", orig_filename); else if (nread == 0) @@ -3888,7 +3884,7 @@ by calling `format-decode', which see. */) break; } - bufpos = 0; + int bufpos = 0; while (bufpos < nread && same_at_start < ZV_BYTE && FETCH_BYTE (same_at_start) == read_buf[bufpos]) same_at_start++, bufpos++; @@ -3897,7 +3893,6 @@ by calling `format-decode', which see. */) if (bufpos != nread) break; } - immediate_quit = false; /* If the file matches the buffer completely, there's no need to replace anything. */ if (same_at_start - BEGV_BYTE == end_offset - beg_offset) @@ -3909,8 +3904,7 @@ by calling `format-decode', which see. */) del_range_1 (same_at_start, same_at_end, 0, 0); goto handled; } - immediate_quit = true; - QUIT; + /* Count how many chars at the end of the file match the text at the end of the buffer. But, if we have already found that decoding is necessary, don't waste time. */ @@ -3932,7 +3926,8 @@ by calling `format-decode', which see. */) total_read = nread = 0; while (total_read < trial) { - nread = emacs_read (fd, read_buf + total_read, trial - total_read); + nread = emacs_read_quit (fd, read_buf + total_read, + trial - total_read); if (nread < 0) report_file_error ("Read error", orig_filename); else if (nread == 0) @@ -3967,7 +3962,6 @@ by calling `format-decode', which see. */) if (nread == 0) break; } - immediate_quit = 0; if (! giveup_match_end) { @@ -4059,18 +4053,13 @@ by calling `format-decode', which see. */) inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */ unprocessed = 0; /* Bytes not processed in previous loop. */ - while (1) + while (true) { /* Read at most READ_BUF_SIZE bytes at a time, to allow quitting while reading a huge file. */ - /* Allow quitting out of the actual I/O. */ - immediate_quit = 1; - QUIT; - this = emacs_read (fd, read_buf + unprocessed, - READ_BUF_SIZE - unprocessed); - immediate_quit = 0; - + this = emacs_read_quit (fd, read_buf + unprocessed, + READ_BUF_SIZE - unprocessed); if (this <= 0) break; @@ -4284,13 +4273,10 @@ by calling `format-decode', which see. */) /* Allow quitting out of the actual I/O. We don't make text part of the buffer until all the reading is done, so a C-g here doesn't do any harm. */ - immediate_quit = 1; - QUIT; - this = emacs_read (fd, - ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE - + inserted), - trytry); - immediate_quit = 0; + this = emacs_read_quit (fd, + ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + + inserted), + trytry); } if (this <= 0) @@ -4602,7 +4588,7 @@ by calling `format-decode', which see. */) } } - QUIT; + maybe_quit (); p = XCDR (p); } @@ -4992,8 +4978,6 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, } } - immediate_quit = 1; - if (STRINGP (start)) ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding); else if (XINT (start) != XINT (end)) @@ -5016,8 +5000,6 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, save_errno = errno; } - immediate_quit = 0; - /* fsync is not crucial for temporary files. Nor for auto-save files, since they might lose some work anyway. */ if (open_and_close_file && !auto_saving && !write_region_inhibit_fsync) @@ -5407,7 +5389,7 @@ e_write (int desc, Lisp_Object string, ptrdiff_t start, ptrdiff_t end, : (STRINGP (coding->dst_object) ? SSDATA (coding->dst_object) : (char *) BYTE_POS_ADDR (coding->dst_pos_byte))); - coding->produced -= emacs_write_sig (desc, buf, coding->produced); + coding->produced -= emacs_write_quit (desc, buf, coding->produced); if (coding->raw_destination) { diff --git a/src/filelock.c b/src/filelock.c index 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) fcntl (fd, F_SETFD, FD_CLOEXEC); lock_info_len = strlen (lock_info_str); err = 0; - /* Use 'write', not 'emacs_write', as garbage collection - might signal an error, which would leak FD. */ - if (write (fd, lock_info_str, lock_info_len) != lock_info_len + if (emacs_write (fd, lock_info_str, lock_info_len) != lock_info_len || fchmod (fd, S_IRUSR | S_IRGRP | S_IROTH) != 0) err = errno; /* There is no need to call fsync here, as the contents of @@ -490,8 +488,7 @@ read_lock_data (char *lfname, char lfinfo[MAX_LFINFO + 1]) int fd = emacs_open (lfname, O_RDONLY | O_NOFOLLOW, 0); if (0 <= fd) { - /* Use read, not emacs_read, since FD isn't unwind-protected. */ - ptrdiff_t read_bytes = read (fd, lfinfo, MAX_LFINFO + 1); + ptrdiff_t read_bytes = emacs_read (fd, lfinfo, MAX_LFINFO + 1); int read_errno = errno; if (emacs_close (fd) != 0) return -1; @@ -505,7 +502,7 @@ read_lock_data (char *lfname, char lfinfo[MAX_LFINFO + 1]) /* readlinkat saw a non-symlink, but emacs_open saw a symlink. The former must have been removed and replaced by the latter. Try again. */ - QUIT; + maybe_quit (); } return nbytes; diff --git a/src/fns.c b/src/fns.c index 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/>. */ #include "buffer.h" #include "intervals.h" #include "window.h" +#include "puresize.h" static void sort_vector_copy (Lisp_Object, ptrdiff_t, Lisp_Object *restrict, Lisp_Object *restrict); @@ -83,18 +84,8 @@ See Info node `(elisp)Random Numbers' for more details. */) return make_number (val); } -/* Heuristic on how many iterations of a tight loop can be safely done - before it's time to do a QUIT. This must be a power of 2. */ -enum { QUIT_COUNT_HEURISTIC = 1 << 16 }; - /* Random data-structure functions. */ -static void -CHECK_LIST_END (Lisp_Object x, Lisp_Object y) -{ - CHECK_TYPE (NILP (x), Qlistp, y); -} - DEFUN ("length", Flength, Slength, 1, 1, 0, doc: /* Return the length of vector, list or string SEQUENCE. A byte-code function object is also allowed. @@ -126,7 +117,7 @@ To get the number of bytes, use `string-bytes'. */) { if (MOST_POSITIVE_FIXNUM < i) error ("List too long"); - QUIT; + maybe_quit (); } sequence = XCDR (sequence); } @@ -172,7 +163,7 @@ which is at least the number of distinct elements. */) halftail = XCDR (halftail); if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0) { - QUIT; + maybe_quit (); if (lolen == 0) hilen += UINTMAX_MAX + 1.0; } @@ -1202,17 +1193,12 @@ are shared, however. Elements of ALIST that are not conses are also shared. */) (Lisp_Object alist) { - register Lisp_Object tem; - - CHECK_LIST (alist); if (NILP (alist)) return alist; - alist = concat (1, &alist, Lisp_Cons, 0); - for (tem = alist; CONSP (tem); tem = XCDR (tem)) + alist = concat (1, &alist, Lisp_Cons, false); + for (Lisp_Object tem = alist; !NILP (tem); tem = XCDR (tem)) { - register Lisp_Object car; - car = XCAR (tem); - + Lisp_Object car = XCAR (tem); if (CONSP (car)) XSETCAR (tem, Fcons (XCAR (car), XCDR (car))); } @@ -1356,16 +1342,19 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0, doc: /* Take cdr N times on LIST, return the result. */) (Lisp_Object n, Lisp_Object list) { - EMACS_INT i, num; CHECK_NUMBER (n); - num = XINT (n); - for (i = 0; i < num && !NILP (list); i++) + Lisp_Object tail = list; + for (EMACS_INT num = XINT (n); 0 < num; num--) { - QUIT; - CHECK_LIST_CONS (list, list); - list = XCDR (list); + if (! CONSP (tail)) + { + CHECK_LIST_END (tail, list); + return Qnil; + } + tail = XCDR (tail); + rarely_quit (num); } - return list; + return tail; } DEFUN ("nth", Fnth, Snth, 2, 2, 0, @@ -1392,66 +1381,55 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, DEFUN ("member", Fmember, Smember, 2, 2, 0, doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. The value is actually the tail of LIST whose car is ELT. */) - (register Lisp_Object elt, Lisp_Object list) + (Lisp_Object elt, Lisp_Object list) { - register Lisp_Object tail; - for (tail = list; !NILP (tail); tail = XCDR (tail)) + unsigned short int quit_count = 0; + Lisp_Object tail; + for (tail = list; CONSP (tail); tail = XCDR (tail)) { - register Lisp_Object tem; - CHECK_LIST_CONS (tail, list); - tem = XCAR (tail); - if (! NILP (Fequal (elt, tem))) + if (! NILP (Fequal (elt, XCAR (tail)))) return tail; - QUIT; + rarely_quit (++quit_count); } + CHECK_LIST_END (tail, list); return Qnil; } DEFUN ("memq", Fmemq, Smemq, 2, 2, 0, doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'. The value is actually the tail of LIST whose car is ELT. */) - (register Lisp_Object elt, Lisp_Object list) + (Lisp_Object elt, Lisp_Object list) { - while (1) + unsigned short int quit_count = 0; + Lisp_Object tail; + for (tail = list; CONSP (tail); tail = XCDR (tail)) { - if (!CONSP (list) || EQ (XCAR (list), elt)) - break; - - list = XCDR (list); - if (!CONSP (list) || EQ (XCAR (list), elt)) - break; - - list = XCDR (list); - if (!CONSP (list) || EQ (XCAR (list), elt)) - break; - - list = XCDR (list); - QUIT; + if (EQ (XCAR (tail), elt)) + return tail; + rarely_quit (++quit_count); } - - CHECK_LIST (list); - return list; + CHECK_LIST_END (tail, list); + return Qnil; } DEFUN ("memql", Fmemql, Smemql, 2, 2, 0, doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'. The value is actually the tail of LIST whose car is ELT. */) - (register Lisp_Object elt, Lisp_Object list) + (Lisp_Object elt, Lisp_Object list) { - register Lisp_Object tail; - if (!FLOATP (elt)) return Fmemq (elt, list); - for (tail = list; !NILP (tail); tail = XCDR (tail)) + unsigned short int quit_count = 0; + Lisp_Object tail; + for (tail = list; CONSP (tail); tail = XCDR (tail)) { - register Lisp_Object tem; - CHECK_LIST_CONS (tail, list); - tem = XCAR (tail); + Lisp_Object tem = XCAR (tail); if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil)) return tail; - QUIT; + rarely_quit (++quit_count); } + CHECK_LIST_END (tail, list); return Qnil; } @@ -1461,44 +1439,28 @@ The value is actually the first element of LIST whose car is KEY. Elements of LIST that are not conses are ignored. */) (Lisp_Object key, Lisp_Object list) { - while (1) + unsigned short int quit_count = 0; + Lisp_Object tail; + for (tail = list; CONSP (tail); tail = XCDR (tail)) { - if (!CONSP (list) - || (CONSP (XCAR (list)) - && EQ (XCAR (XCAR (list)), key))) - break; - - list = XCDR (list); - if (!CONSP (list) - || (CONSP (XCAR (list)) - && EQ (XCAR (XCAR (list)), key))) - break; - - list = XCDR (list); - if (!CONSP (list) - || (CONSP (XCAR (list)) - && EQ (XCAR (XCAR (list)), key))) - break; - - list = XCDR (list); - QUIT; + if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key)) + return XCAR (tail); + rarely_quit (++quit_count); } - - return CAR (list); + CHECK_LIST_END (tail, list); + return Qnil; } /* Like Fassq but never report an error and do not allow quits. - Use only on lists known never to be circular. */ + Use only on objects known to be non-circular lists. */ Lisp_Object assq_no_quit (Lisp_Object key, Lisp_Object list) { - while (CONSP (list) - && (!CONSP (XCAR (list)) - || !EQ (XCAR (XCAR (list)), key))) - list = XCDR (list); - - return CAR_SAFE (list); + for (; ! NILP (list); list = XCDR (list)) + if (CONSP (XCAR (list)) && EQ (XCAR (XCAR (list)), key)) + return XCAR (list); + return Qnil; } DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0, @@ -1506,81 +1468,51 @@ DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0, The value is actually the first element of LIST whose car equals KEY. */) (Lisp_Object key, Lisp_Object list) { - Lisp_Object car; - - while (1) + unsigned short int quit_count = 0; + Lisp_Object tail; + for (tail = list; CONSP (tail); tail = XCDR (tail)) { - if (!CONSP (list) - || (CONSP (XCAR (list)) - && (car = XCAR (XCAR (list)), - EQ (car, key) || !NILP (Fequal (car, key))))) - break; - - list = XCDR (list); - if (!CONSP (list) - || (CONSP (XCAR (list)) - && (car = XCAR (XCAR (list)), - EQ (car, key) || !NILP (Fequal (car, key))))) - break; - - list = XCDR (list); - if (!CONSP (list) - || (CONSP (XCAR (list)) - && (car = XCAR (XCAR (list)), - EQ (car, key) || !NILP (Fequal (car, key))))) - break; - - list = XCDR (list); - QUIT; + Lisp_Object car = XCAR (tail); + if (CONSP (car) + && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))) + return car; + rarely_quit (++quit_count); } - - return CAR (list); + CHECK_LIST_END (tail, list); + return Qnil; } /* Like Fassoc but never report an error and do not allow quits. - Use only on lists known never to be circular. */ + Use only on objects known to be non-circular lists. */ Lisp_Object assoc_no_quit (Lisp_Object key, Lisp_Object list) { - while (CONSP (list) - && (!CONSP (XCAR (list)) - || (!EQ (XCAR (XCAR (list)), key) - && NILP (Fequal (XCAR (XCAR (list)), key))))) - list = XCDR (list); - - return CONSP (list) ? XCAR (list) : Qnil; + for (; ! NILP (list); list = XCDR (list)) + { + Lisp_Object car = XCAR (list); + if (CONSP (car) + && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))) + return car; + } + return Qnil; } DEFUN ("rassq", Frassq, Srassq, 2, 2, 0, doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST. The value is actually the first element of LIST whose cdr is KEY. */) - (register Lisp_Object key, Lisp_Object list) + (Lisp_Object key, Lisp_Object list) { - while (1) + unsigned short int quit_count = 0; + Lisp_Object tail; + for (tail = list; CONSP (tail); tail = XCDR (tail)) { - if (!CONSP (list) - || (CONSP (XCAR (list)) - && EQ (XCDR (XCAR (list)), key))) - break; - - list = XCDR (list); - if (!CONSP (list) - || (CONSP (XCAR (list)) - && EQ (XCDR (XCAR (list)), key))) - break; - - list = XCDR (list); - if (!CONSP (list) - || (CONSP (XCAR (list)) - && EQ (XCDR (XCAR (list)), key))) - break; - - list = XCDR (list); - QUIT; + if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key)) + return XCAR (tail); + rarely_quit (++quit_count); } - - return CAR (list); + CHECK_LIST_END (tail, list); + return Qnil; } DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, @@ -1588,35 +1520,18 @@ DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, The value is actually the first element of LIST whose cdr equals KEY. */) (Lisp_Object key, Lisp_Object list) { - Lisp_Object cdr; - - while (1) + unsigned short int quit_count = 0; + Lisp_Object tail; + for (tail = list; CONSP (tail); tail = XCDR (tail)) { - if (!CONSP (list) - || (CONSP (XCAR (list)) - && (cdr = XCDR (XCAR (list)), - EQ (cdr, key) || !NILP (Fequal (cdr, key))))) - break; - - list = XCDR (list); - if (!CONSP (list) - || (CONSP (XCAR (list)) - && (cdr = XCDR (XCAR (list)), - EQ (cdr, key) || !NILP (Fequal (cdr, key))))) - break; - - list = XCDR (list); - if (!CONSP (list) - || (CONSP (XCAR (list)) - && (cdr = XCDR (XCAR (list)), - EQ (cdr, key) || !NILP (Fequal (cdr, key))))) - break; - - list = XCDR (list); - QUIT; + Lisp_Object car = XCAR (tail); + if (CONSP (car) + && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key)))) + return car; + rarely_quit (++quit_count); } - - return CAR (list); + CHECK_LIST_END (tail, list); + return Qnil; } DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0, @@ -1647,6 +1562,7 @@ argument. */) else prev = tail; } + CHECK_LIST_END (tail, list); return list; } @@ -1754,12 +1670,11 @@ changing the value of a sequence `foo'. */) } else { + unsigned short int quit_count = 0; Lisp_Object tail, prev; - for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail)) + for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail)) { - CHECK_LIST_CONS (tail, seq); - if (!NILP (Fequal (elt, XCAR (tail)))) { if (NILP (prev)) @@ -1769,8 +1684,9 @@ changing the value of a sequence `foo'. */) } else prev = tail; - QUIT; + rarely_quit (++quit_count); } + CHECK_LIST_END (tail, seq); } return seq; @@ -1788,16 +1704,17 @@ This function may destructively modify SEQ to produce the value. */) return Freverse (seq); else if (CONSP (seq)) { + unsigned short int quit_count = 0; Lisp_Object prev, tail, next; - for (prev = Qnil, tail = seq; !NILP (tail); tail = next) + for (prev = Qnil, tail = seq; CONSP (tail); tail = next) { - QUIT; - CHECK_LIST_CONS (tail, tail); next = XCDR (tail); Fsetcdr (tail, prev); prev = tail; + rarely_quit (++quit_count); } + CHECK_LIST_END (tail, seq); seq = prev; } else if (VECTORP (seq)) @@ -1838,10 +1755,11 @@ See also the function `nreverse', which is used more often. */) return Qnil; else if (CONSP (seq)) { + unsigned short int quit_count = 0; for (new = Qnil; CONSP (seq); seq = XCDR (seq)) { - QUIT; new = Fcons (XCAR (seq), new); + rarely_quit (++quit_count); } CHECK_LIST_END (seq, seq); } @@ -2130,12 +2048,11 @@ If PROP is already a property on the list, its value is set to VAL, otherwise the new PROP VAL pair is added. The new plist is returned; use `(setq x (plist-put x prop val))' to be sure to use the new value. The PLIST is modified by side effects. */) - (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val) + (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) { - register Lisp_Object tail, prev; - Lisp_Object newcell; - prev = Qnil; - for (tail = plist; CONSP (tail) && CONSP (XCDR (tail)); + unsigned short int quit_count = 0; + Lisp_Object prev = Qnil; + for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail)); tail = XCDR (XCDR (tail))) { if (EQ (prop, XCAR (tail))) @@ -2145,13 +2062,13 @@ The PLIST is modified by side effects. */) } prev = tail; - QUIT; + rarely_quit (++quit_count); } - newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev)))); + Lisp_Object newcell + = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev)))); if (NILP (prev)) return newcell; - else - Fsetcdr (XCDR (prev), newcell); + Fsetcdr (XCDR (prev), newcell); return plist; } @@ -2174,6 +2091,7 @@ corresponding to the given PROP, or nil if PROP is not one of the properties on the list. */) (Lisp_Object plist, Lisp_Object prop) { + unsigned short int quit_count = 0; Lisp_Object tail; for (tail = plist; @@ -2182,8 +2100,7 @@ one of the properties on the list. */) { if (! NILP (Fequal (prop, XCAR (tail)))) return XCAR (XCDR (tail)); - - QUIT; + rarely_quit (++quit_count); } CHECK_LIST_END (tail, prop); @@ -2199,12 +2116,11 @@ If PROP is already a property on the list, its value is set to VAL, otherwise the new PROP VAL pair is added. The new plist is returned; use `(setq x (lax-plist-put x prop val))' to be sure to use the new value. The PLIST is modified by side effects. */) - (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val) + (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) { - register Lisp_Object tail, prev; - Lisp_Object newcell; - prev = Qnil; - for (tail = plist; CONSP (tail) && CONSP (XCDR (tail)); + unsigned short int quit_count = 0; + Lisp_Object prev = Qnil; + for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail)); tail = XCDR (XCDR (tail))) { if (! NILP (Fequal (prop, XCAR (tail)))) @@ -2214,13 +2130,12 @@ The PLIST is modified by side effects. */) } prev = tail; - QUIT; + rarely_quit (++quit_count); } - newcell = list2 (prop, val); + Lisp_Object newcell = list2 (prop, val); if (NILP (prev)) return newcell; - else - Fsetcdr (XCDR (prev), newcell); + Fsetcdr (XCDR (prev), newcell); return plist; } @@ -2293,8 +2208,9 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props, } } + unsigned short int quit_count = 0; tail_recurse: - QUIT; + rarely_quit (++quit_count); if (EQ (o1, o2)) return 1; if (XTYPE (o1) != XTYPE (o2)) @@ -2483,14 +2399,12 @@ Only the last argument is not altered, and need not be a list. usage: (nconc &rest LISTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - ptrdiff_t argnum; - register Lisp_Object tail, tem, val; - - val = tail = Qnil; + unsigned short int quit_count = 0; + Lisp_Object val = Qnil; - for (argnum = 0; argnum < nargs; argnum++) + for (ptrdiff_t argnum = 0; argnum < nargs; argnum++) { - tem = args[argnum]; + Lisp_Object tem = args[argnum]; if (NILP (tem)) continue; if (NILP (val)) @@ -2498,14 +2412,16 @@ usage: (nconc &rest LISTS) */) if (argnum + 1 == nargs) break; - CHECK_LIST_CONS (tem, tem); + CHECK_CONS (tem); - while (CONSP (tem)) + Lisp_Object tail; + do { tail = tem; tem = XCDR (tail); - QUIT; + rarely_quit (++quit_count); } + while (CONSP (tem)); tem = args[argnum + 1]; Fsetcdr (tail, tem); @@ -2927,11 +2843,12 @@ property and a property with the value nil. The value is actually the tail of PLIST whose car is PROP. */) (Lisp_Object plist, Lisp_Object prop) { + unsigned short int quit_count = 0; while (CONSP (plist) && !EQ (XCAR (plist), prop)) { plist = XCDR (plist); plist = CDR (plist); - QUIT; + rarely_quit (++quit_count); } return plist; } @@ -3804,12 +3721,17 @@ allocate_hash_table (void) (table size) is >= REHASH_THRESHOLD. WEAK specifies the weakness of the table. If non-nil, it must be - one of the symbols `key', `value', `key-or-value', or `key-and-value'. */ + one of the symbols `key', `value', `key-or-value', or `key-and-value'. + + If PURECOPY is non-nil, the table can be copied to pure storage via + `purecopy' when Emacs is being dumped. Such tables can no longer be + changed after purecopy. */ Lisp_Object make_hash_table (struct hash_table_test test, Lisp_Object size, Lisp_Object rehash_size, - Lisp_Object rehash_threshold, Lisp_Object weak) + Lisp_Object rehash_threshold, Lisp_Object weak, + Lisp_Object pure) { struct Lisp_Hash_Table *h; Lisp_Object table; @@ -3850,6 +3772,7 @@ make_hash_table (struct hash_table_test test, h->hash = Fmake_vector (size, Qnil); h->next = Fmake_vector (size, Qnil); h->index = Fmake_vector (make_number (index_size), Qnil); + h->pure = pure; /* Set up the free list. */ for (i = 0; i < sz - 1; ++i) @@ -4514,10 +4437,15 @@ key, value, one of key or value, or both key and value, depending on WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK is nil. +:purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied +to pure storage when Emacs is being dumped, making the contents of the +table read only. Any further changes to purified tables will result +in an error. + usage: (make-hash-table &rest KEYWORD-ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object test, size, rehash_size, rehash_threshold, weak; + Lisp_Object test, size, rehash_size, rehash_threshold, weak, pure; struct hash_table_test testdesc; ptrdiff_t i; USE_SAFE_ALLOCA; @@ -4551,6 +4479,9 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */) testdesc.cmpfn = cmpfn_user_defined; } + /* See if there's a `:purecopy PURECOPY' argument. */ + i = get_key_arg (QCpurecopy, nargs, args, used); + pure = i ? args[i] : Qnil; /* See if there's a `:size SIZE' argument. */ i = get_key_arg (QCsize, nargs, args, used); size = i ? args[i] : Qnil; @@ -4592,7 +4523,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */) signal_error ("Invalid argument list", args[i]); SAFE_FREE (); - return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak); + return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak, + pure); } @@ -4671,7 +4603,9 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0, doc: /* Clear hash table TABLE and return it. */) (Lisp_Object table) { - hash_clear (check_hash_table (table)); + struct Lisp_Hash_Table *h = check_hash_table (table); + CHECK_IMPURE (table, h); + hash_clear (h); /* Be compatible with XEmacs. */ return table; } @@ -4695,9 +4629,10 @@ VALUE. In any case, return VALUE. */) (Lisp_Object key, Lisp_Object value, Lisp_Object table) { struct Lisp_Hash_Table *h = check_hash_table (table); + CHECK_IMPURE (table, h); + ptrdiff_t i; EMACS_UINT hash; - i = hash_lookup (h, key, &hash); if (i >= 0) set_hash_value_slot (h, i, value); @@ -4713,6 +4648,7 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0, (Lisp_Object key, Lisp_Object table) { struct Lisp_Hash_Table *h = check_hash_table (table); + CHECK_IMPURE (table, h); hash_remove_from_table (h, key); return Qnil; } @@ -5083,6 +5019,7 @@ syms_of_fns (void) DEFSYM (Qequal, "equal"); DEFSYM (QCtest, ":test"); DEFSYM (QCsize, ":size"); + DEFSYM (QCpurecopy, ":purecopy"); DEFSYM (QCrehash_size, ":rehash-size"); DEFSYM (QCrehash_threshold, ":rehash-threshold"); DEFSYM (QCweakness, ":weakness"); diff --git a/src/fontset.c b/src/fontset.c index 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 `set-fontset-font' for the meaning. */) (Lisp_Object name, Lisp_Object fontlist) { - Lisp_Object fontset; + Lisp_Object fontset, tail; int id; CHECK_STRING (name); - CHECK_LIST (fontlist); name = Fdowncase (name); id = fs_query_fontset (name, 0); @@ -1714,11 +1713,11 @@ FONT-SPEC is a vector, a cons, or a string. See the documentation of Fset_char_table_range (fontset, Qt, Qnil); } - for (; CONSP (fontlist); fontlist = XCDR (fontlist)) + for (tail = fontlist; CONSP (tail); tail = XCDR (tail)) { Lisp_Object elt, script; - elt = XCAR (fontlist); + elt = XCAR (tail); script = Fcar (elt); elt = Fcdr (elt); if (CONSP (elt) && (NILP (XCDR (elt)) || CONSP (XCDR (elt)))) @@ -1727,6 +1726,7 @@ FONT-SPEC is a vector, a cons, or a string. See the documentation of else Fset_fontset_font (name, script, elt, Qnil, Qappend); } + CHECK_LIST_END (tail, fontlist); return name; } diff --git a/src/frame.c b/src/frame.c index 2c2c1e150d4..d0f653fc762 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2691,9 +2691,7 @@ list, but are otherwise ignored. */) (Lisp_Object frame, Lisp_Object alist) { struct frame *f = decode_live_frame (frame); - register Lisp_Object prop, val; - - CHECK_LIST (alist); + Lisp_Object prop, val; /* I think this should be done with a hook. */ #ifdef HAVE_WINDOW_SYSTEM @@ -3142,6 +3140,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) for (size = 0, tail = alist; CONSP (tail); tail = XCDR (tail)) size++; + CHECK_LIST_END (tail, alist); USE_SAFE_ALLOCA; SAFE_ALLOCA_LISP (parms, 2 * size); diff --git a/src/gfilenotify.c b/src/gfilenotify.c index 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. */) if (NILP (Ffile_exists_p (file))) report_file_error ("File does not exist", file); - CHECK_LIST (flags); - if (!FUNCTIONP (callback)) wrong_type_argument (Qinvalid_function, callback); - /* Create GFile name. */ - gfile = g_file_new_for_path (SSDATA (ENCODE_FILE (file))); - /* Assemble flags. */ if (!NILP (Fmember (Qwatch_mounts, flags))) gflags |= G_FILE_MONITOR_WATCH_MOUNTS; if (!NILP (Fmember (Qsend_moved, flags))) gflags |= G_FILE_MONITOR_SEND_MOVED; + /* Create GFile name. */ + gfile = g_file_new_for_path (SSDATA (ENCODE_FILE (file))); + /* Enable watch. */ monitor = g_file_monitor (gfile, gflags, NULL, &gerror); g_object_unref (gfile); diff --git a/src/gnutls.c b/src/gnutls.c index 735d2e35810..d0d7f2dfc84 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -390,7 +390,7 @@ gnutls_try_handshake (struct Lisp_Process *proc) { ret = gnutls_handshake (state); emacs_gnutls_handle_error (state, ret); - QUIT; + maybe_quit (); } while (ret < 0 && gnutls_error_is_fatal (ret) == 0 @@ -582,8 +582,17 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err) if (gnutls_error_is_fatal (err)) { + int level = 1; + /* Mostly ignore "The TLS connection was non-properly + terminated" message which just means that the peer closed the + connection. */ +#ifdef HAVE_GNUTLS3 + if (err == GNUTLS_E_PREMATURE_TERMINATION) + level = 3; +#endif + + GNUTLS_LOG2 (level, max_log_level, "fatal error:", str); ret = 0; - GNUTLS_LOG2 (1, max_log_level, "fatal error:", str); } else { diff --git a/src/image.c b/src/image.c index 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, return make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil); + Qnil, Qnil); } static void diff --git a/src/indent.c b/src/indent.c index 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, continuation_glyph_width = 0; /* In the fringe. */ #endif - immediate_quit = 1; - QUIT; - /* It's just impossible to be too paranoid here. */ eassert (from == BYTE_TO_CHAR (frombyte) && frombyte == CHAR_TO_BYTE (from)); @@ -1214,8 +1211,12 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, cmp_it.id = -1; composition_compute_stop_pos (&cmp_it, pos, pos_byte, to, Qnil); - while (1) + unsigned short int quit_count = 0; + + while (true) { + rarely_quit (++quit_count); + while (pos == next_boundary) { ptrdiff_t pos_here = pos; @@ -1280,6 +1281,8 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, pos = newpos; pos_byte = CHAR_TO_BYTE (pos); } + + rarely_quit (++quit_count); } /* Handle right margin. */ @@ -1602,6 +1605,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, pos = find_before_next_newline (pos, to, 1, &pos_byte); if (pos < to) INC_BOTH (pos, pos_byte); + rarely_quit (++quit_count); } while (pos < to && indented_beyond_p (pos, pos_byte, @@ -1694,7 +1698,6 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, /* Nonzero if have just continued a line */ val_compute_motion.contin = (contin_hpos && prev_hpos == 0); - immediate_quit = 0; return &val_compute_motion; } diff --git a/src/insdel.c b/src/insdel.c index 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) Change BYTEPOS to be where we have actually moved the gap to. Note that this cannot happen when we are called to make the gap larger or smaller, since make_gap_larger and - make_gap_smaller prevent QUIT by setting inhibit-quit. */ + make_gap_smaller set inhibit-quit. */ if (QUITP) { bytepos = new_s1; @@ -151,7 +151,7 @@ gap_left (ptrdiff_t charpos, ptrdiff_t bytepos, bool newgap) GPT = charpos; eassert (charpos <= bytepos); if (GAP_SIZE > 0) *(GPT_ADDR) = 0; /* Put an anchor. */ - QUIT; + maybe_quit (); } /* Move the gap to a position greater than the current GPT. @@ -185,7 +185,7 @@ gap_right (ptrdiff_t charpos, ptrdiff_t bytepos) Change BYTEPOS to be where we have actually moved the gap to. Note that this cannot happen when we are called to make the gap larger or smaller, since make_gap_larger and - make_gap_smaller prevent QUIT by setting inhibit-quit. */ + make_gap_smaller set inhibit-quit. */ if (QUITP) { bytepos = new_s1; @@ -204,7 +204,7 @@ gap_right (ptrdiff_t charpos, ptrdiff_t bytepos) GPT_BYTE = bytepos; eassert (charpos <= bytepos); if (GAP_SIZE > 0) *(GPT_ADDR) = 0; /* Put an anchor. */ - QUIT; + maybe_quit (); } /* If the selected window's old pointm is adjacent or covered by the @@ -464,7 +464,7 @@ make_gap_larger (ptrdiff_t nbytes_added) enlarge_buffer_text (current_buffer, nbytes_added); - /* Prevent quitting in gap_left. We cannot allow a QUIT there, + /* Prevent quitting in gap_left. We cannot allow a quit there, because that would leave the buffer text in an inconsistent state, with 2 gap holes instead of just one. */ tem = Vinhibit_quit; @@ -512,7 +512,7 @@ make_gap_smaller (ptrdiff_t nbytes_removed) if (GAP_SIZE - nbytes_removed < GAP_BYTES_MIN) nbytes_removed = GAP_SIZE - GAP_BYTES_MIN; - /* Prevent quitting in gap_right. We cannot allow a QUIT there, + /* Prevent quitting in gap_right. We cannot allow a quit there, because that would leave the buffer text in an inconsistent state, with 2 gap holes instead of just one. */ tem = Vinhibit_quit; diff --git a/src/keyboard.c b/src/keyboard.c index 6aad0acc656..a86e7c5f8e4 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -87,7 +87,7 @@ char const DEV_TTY[] = "/dev/tty"; volatile int interrupt_input_blocked; /* True means an input interrupt or alarm signal has arrived. - The QUIT macro checks this. */ + The maybe_quit function checks this. */ volatile bool pending_signals; #define KBD_BUFFER_SIZE 4096 @@ -169,9 +169,6 @@ struct kboard *echo_kboard; Lisp_Object echo_message_buffer; -/* True means C-g should cause immediate error-signal. */ -bool immediate_quit; - /* Character that causes a quit. Normally C-g. If we are running on an ordinary terminal, this must be an ordinary @@ -1416,7 +1413,7 @@ command_loop_1 (void) if (!NILP (Vquit_flag)) { Vexecuting_kbd_macro = Qt; - QUIT; /* Make some noise. */ + maybe_quit (); /* Make some noise. */ /* Will return since macro now empty. */ } } @@ -3584,16 +3581,7 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event, as input, set quit-flag to cause an interrupt. */ if (!NILP (Vthrow_on_input) && NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events))) - { - Vquit_flag = Vthrow_on_input; - /* If we're inside a function that wants immediate quits, - do it now. */ - if (immediate_quit && NILP (Vinhibit_quit)) - { - immediate_quit = false; - QUIT; - } - } + Vquit_flag = Vthrow_on_input; } @@ -7053,40 +7041,22 @@ tty_read_avail_input (struct terminal *terminal, /* Now read; for one reason or another, this will not block. NREAD is set to the number of chars read. */ - do - { - nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read); - /* POSIX infers that processes which are not in the session leader's - process group won't get SIGHUPs at logout time. BSDI adheres to - this part standard and returns -1 from read (0) with errno==EIO - when the control tty is taken away. - Jeffrey Honig <jch@bsdi.com> says this is generally safe. */ - if (nread == -1 && errno == EIO) - return -2; /* Close this terminal. */ -#if defined (AIX) && defined (_BSD) - /* The kernel sometimes fails to deliver SIGHUP for ptys. - This looks incorrect, but it isn't, because _BSD causes - O_NDELAY to be defined in fcntl.h as O_NONBLOCK, - and that causes a value other than 0 when there is no input. */ - if (nread == 0) - return -2; /* Close this terminal. */ -#endif - } - while ( - /* We used to retry the read if it was interrupted. - But this does the wrong thing when O_NONBLOCK causes - an EAGAIN error. Does anybody know of a situation - where a retry is actually needed? */ -#if 0 - nread < 0 && (errno == EAGAIN || errno == EFAULT -#ifdef EBADSLT - || errno == EBADSLT -#endif - ) -#else - 0 + nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read); + /* POSIX infers that processes which are not in the session leader's + process group won't get SIGHUPs at logout time. BSDI adheres to + this part standard and returns -1 from read (0) with errno==EIO + when the control tty is taken away. + Jeffrey Honig <jch@bsdi.com> says this is generally safe. */ + if (nread == -1 && errno == EIO) + return -2; /* Close this terminal. */ +#if defined AIX && defined _BSD + /* The kernel sometimes fails to deliver SIGHUP for ptys. + This looks incorrect, but it isn't, because _BSD causes + O_NDELAY to be defined in fcntl.h as O_NONBLOCK, + and that causes a value other than 0 when there is no input. */ + if (nread == 0) + return -2; /* Close this terminal. */ #endif - ); #ifndef USABLE_FIONREAD #if defined (USG) || defined (CYGWIN) @@ -7426,7 +7396,7 @@ menu_bar_items (Lisp_Object old) USE_SAFE_ALLOCA; /* In order to build the menus, we need to call the keymap - accessors. They all call QUIT. But this function is called + accessors. They all call maybe_quit. But this function is called during redisplay, during which a quit is fatal. So inhibit quitting while building the menus. We do this instead of specbind because (1) errors will clear it anyway @@ -7987,7 +7957,7 @@ tool_bar_items (Lisp_Object reuse, int *nitems) *nitems = 0; /* In order to build the menus, we need to call the keymap - accessors. They all call QUIT. But this function is called + accessors. They all call maybe_quit. But this function is called during redisplay, during which a quit is fatal. So inhibit quitting while building the menus. We do this instead of specbind because (1) errors will clear it anyway and (2) this @@ -9806,7 +9776,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo, if (!NILP (prompt)) CHECK_STRING (prompt); - QUIT; + maybe_quit (); specbind (Qinput_method_exit_on_first_char, (NILP (cmd_loop) ? Qt : Qnil)); @@ -9840,7 +9810,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo, if (i == -1) { Vquit_flag = Qt; - QUIT; + maybe_quit (); } return unbind_to (count, @@ -10278,7 +10248,7 @@ clear_waiting_for_input (void) If we have a frame on the controlling tty, we assume that the SIGINT was generated by C-g, so we call handle_interrupt. - Otherwise, tell QUIT to kill Emacs. */ + Otherwise, tell maybe_quit to kill Emacs. */ static void handle_interrupt_signal (int sig) @@ -10289,7 +10259,7 @@ handle_interrupt_signal (int sig) { /* If there are no frames there, let's pretend that we are a well-behaving UN*X program and quit. We must not call Lisp - in a signal handler, so tell QUIT to exit when it is + in a signal handler, so tell maybe_quit to exit when it is safe. */ Vquit_flag = Qkill_emacs; } @@ -10445,30 +10415,12 @@ handle_interrupt (bool in_signal_handler) } else { - /* If executing a function that wants to be interrupted out of - and the user has not deferred quitting by binding `inhibit-quit' - then quit right away. */ - if (immediate_quit && NILP (Vinhibit_quit)) - { - struct gl_state_s saved; - - immediate_quit = false; - pthread_sigmask (SIG_SETMASK, &empty_mask, 0); - saved = gl_state; - quit (); - gl_state = saved; - } - else - { /* Else request quit when it's safe. */ - int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1; - force_quit_count = count; - if (count == 3) - { - immediate_quit = true; - Vinhibit_quit = Qnil; - } - Vquit_flag = Qt; - } + /* Request quit when it's safe. */ + int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1; + force_quit_count = count; + if (count == 3) + Vinhibit_quit = Qnil; + Vquit_flag = Qt; } pthread_sigmask (SIG_SETMASK, &empty_mask, 0); @@ -10907,7 +10859,6 @@ init_keyboard (void) { /* This is correct before outermost invocation of the editor loop. */ command_loop_level = -1; - immediate_quit = false; quit_char = Ctl ('g'); Vunread_command_events = Qnil; timer_idleness_start_time = invalid_timespec (); diff --git a/src/keyboard.h b/src/keyboard.h index 7cd41ae55b6..2219c011352 100644 --- a/src/keyboard.h +++ b/src/keyboard.h @@ -486,6 +486,8 @@ extern bool kbd_buffer_events_waiting (void); extern void add_user_signal (int, const char *); extern int tty_read_avail_input (struct terminal *, struct input_event *); +extern bool volatile pending_signals; +extern void process_pending_signals (void); extern struct timespec timer_check (void); extern void mark_kboards (void); diff --git a/src/keymap.c b/src/keymap.c index 9e759478518..9caf55f98fb 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -523,7 +523,7 @@ access_keymap_1 (Lisp_Object map, Lisp_Object idx, retval = Fcons (Qkeymap, Fcons (retval, retval_tail)); } } - QUIT; + maybe_quit (); } return EQ (Qunbound, retval) ? get_keyelt (t_binding, autoload) : retval; @@ -877,7 +877,7 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) should be inserted before it. */ goto keymap_end; - QUIT; + maybe_quit (); } keymap_end: @@ -1250,7 +1250,7 @@ recognize the default bindings, just as `read-key-sequence' does. */) if (!CONSP (keymap)) return make_number (idx); - QUIT; + maybe_quit (); } } @@ -2466,7 +2466,7 @@ where_is_internal (Lisp_Object definition, Lisp_Object keymaps, non-ascii prefixes like `C-down-mouse-2'. */ continue; - QUIT; + maybe_quit (); data.definition = definition; data.noindirect = noindirect; @@ -3173,7 +3173,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix, for (tail = map; CONSP (tail); tail = XCDR (tail)) { - QUIT; + maybe_quit (); if (VECTORP (XCAR (tail)) || CHAR_TABLE_P (XCAR (tail))) @@ -3426,7 +3426,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, int range_beg, range_end; Lisp_Object val; - QUIT; + maybe_quit (); if (i == stop) { diff --git a/src/lisp.h b/src/lisp.h index 005d1e7c746..2a32db62326 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -310,7 +310,6 @@ error !; # define lisp_h_XLI(o) (o) # define lisp_h_XIL(i) (i) #endif -#define lisp_h_CHECK_LIST_CONS(x, y) CHECK_TYPE (CONSP (x), Qlistp, y) #define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_TYPE(ok, predicate, x) \ @@ -367,7 +366,6 @@ error !; #if DEFINE_KEY_OPS_AS_MACROS # define XLI(o) lisp_h_XLI (o) # define XIL(i) lisp_h_XIL (i) -# define CHECK_LIST_CONS(x, y) lisp_h_CHECK_LIST_CONS (x, y) # define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x) # define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) # define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) @@ -1997,6 +1995,10 @@ struct Lisp_Hash_Table hash table size to reduce collisions. */ Lisp_Object index; + /* Non-nil if the table can be purecopied. The table cannot be + changed afterwards. */ + Lisp_Object pure; + /* Only the fields above are traced normally by the GC. The ones below `count' are special and are either ignored by the GC or traced in a special way (e.g. because of weakness). */ @@ -2751,9 +2753,9 @@ CHECK_LIST (Lisp_Object x) } INLINE void -(CHECK_LIST_CONS) (Lisp_Object x, Lisp_Object y) +CHECK_LIST_END (Lisp_Object x, Lisp_Object y) { - lisp_h_CHECK_LIST_CONS (x, y); + CHECK_TYPE (NILP (x), Qlistp, y); } INLINE void @@ -3121,38 +3123,28 @@ struct handler extern Lisp_Object memory_signal_data; -/* Check quit-flag and quit if it is non-nil. - Typing C-g does not directly cause a quit; it only sets Vquit_flag. - So the program needs to do QUIT at times when it is safe to quit. - Every loop that might run for a long time or might not exit - ought to do QUIT at least once, at a safe place. - Unless that is impossible, of course. - But it is very desirable to avoid creating loops where QUIT is impossible. - - Exception: if you set immediate_quit to true, - then the handler that responds to the C-g does the quit itself. - This is a good thing to do around a loop that has no side effects - and (in particular) cannot call arbitrary Lisp code. +extern void maybe_quit (void); - If quit-flag is set to `kill-emacs' the SIGINT handler has received - a request to exit Emacs when it is safe to do. */ +/* True if ought to quit now. */ -extern void process_pending_signals (void); -extern bool volatile pending_signals; +#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) -extern void process_quit_flag (void); -#define QUIT \ - do { \ - if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \ - process_quit_flag (); \ - else if (pending_signals) \ - process_pending_signals (); \ - } while (false) +/* Heuristic on how many iterations of a tight loop can be safely done + before it's time to do a quit. This must be a power of 2. It + is nice but not necessary for it to equal USHRT_MAX + 1. */ +enum { QUIT_COUNT_HEURISTIC = 1 << 16 }; -/* True if ought to quit now. */ +/* Process a quit rarely, based on a counter COUNT, for efficiency. + "Rarely" means once per QUIT_COUNT_HEURISTIC or per USHRT_MAX + 1 + times, whichever is smaller (somewhat arbitrary, but often faster). */ -#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) +INLINE void +rarely_quit (unsigned short int count) +{ + if (! (count & (QUIT_COUNT_HEURISTIC - 1))) + maybe_quit (); +} extern Lisp_Object Vascii_downcase_table; extern Lisp_Object Vascii_canon_table; @@ -3375,7 +3367,7 @@ extern void sweep_weak_hash_tables (void); EMACS_UINT hash_string (char const *, ptrdiff_t); EMACS_UINT sxhash (Lisp_Object, int); Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object); + Lisp_Object, Lisp_Object, Lisp_Object); ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *); ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object, EMACS_UINT); @@ -4233,8 +4225,10 @@ extern int emacs_open (const char *, int, int); extern int emacs_pipe (int[2]); extern int emacs_close (int); extern ptrdiff_t emacs_read (int, void *, ptrdiff_t); +extern ptrdiff_t emacs_read_quit (int, void *, ptrdiff_t); extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t); extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t); +extern ptrdiff_t emacs_write_quit (int, void const *, ptrdiff_t); extern void emacs_perror (char const *); extern void unlock_all_files (void); @@ -4360,9 +4354,6 @@ extern char my_edata[]; extern char my_endbss[]; extern char *my_endbss_static; -/* True means ^G can quit instantly. */ -extern bool immediate_quit; - extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); @@ -4549,7 +4540,7 @@ enum use these only in macros like AUTO_CONS that declare a local variable whose lifetime will be clear to the programmer. */ #define STACK_CONS(a, b) \ - make_lisp_ptr (&(union Aligned_Cons) { { a, { b } } }.s, Lisp_Cons) + make_lisp_ptr (&((union Aligned_Cons) { { a, { b } } }).s, Lisp_Cons) #define AUTO_CONS_EXPR(a, b) \ (USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b)) @@ -4595,8 +4586,7 @@ enum Lisp_Object name = \ (USE_STACK_STRING \ ? (make_lisp_ptr \ - ((&(union Aligned_String) \ - {{len, -1, 0, (unsigned char *) (str)}}.s), \ + ((&((union Aligned_String) {{len, -1, 0, (unsigned char *) (str)}}).s), \ Lisp_String)) \ : make_unibyte_string (str, len)) diff --git a/src/lread.c b/src/lread.c index 284fd1aafbc..094aa628eec 100644 --- a/src/lread.c +++ b/src/lread.c @@ -451,7 +451,7 @@ readbyte_from_file (int c, Lisp_Object readcharfun) while (c == EOF && ferror (instream) && errno == EINTR) { unblock_input (); - QUIT; + maybe_quit (); block_input (); clearerr (instream); c = getc (instream); @@ -910,7 +910,7 @@ safe_to_load_version (int fd) /* Read the first few bytes from the file, and look for a line specifying the byte compiler version used. */ - nbytes = emacs_read (fd, buf, sizeof buf); + nbytes = emacs_read_quit (fd, buf, sizeof buf); if (nbytes > 0) { /* Skip to the next newline, skipping over the initial `ELC' @@ -1702,14 +1702,14 @@ build_load_history (Lisp_Object filename, bool entire) Fcons (newelt, XCDR (tem)))); tem2 = XCDR (tem2); - QUIT; + maybe_quit (); } } } else prev = tail; tail = XCDR (tail); - QUIT; + maybe_quit (); } /* If we're loading an entire file, cons the new assoc onto the @@ -2599,7 +2599,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) Lisp_Object val = Qnil; /* The size is 2 * number of allowed keywords to make-hash-table. */ - Lisp_Object params[10]; + Lisp_Object params[12]; Lisp_Object ht; Lisp_Object key = Qnil; int param_count = 0; @@ -2636,6 +2636,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (!NILP (params[param_count + 1])) param_count += 2; + params[param_count] = QCpurecopy; + params[param_count + 1] = Fplist_get (tmp, Qpurecopy); + if (!NILP (params[param_count + 1])) + param_count += 2; + /* This is the hash table data. */ data = Fplist_get (tmp, Qdata); @@ -4849,6 +4854,7 @@ that are loaded before your customizations are read! */); DEFSYM (Qdata, "data"); DEFSYM (Qtest, "test"); DEFSYM (Qsize, "size"); + DEFSYM (Qpurecopy, "purecopy"); DEFSYM (Qweakness, "weakness"); DEFSYM (Qrehash_size, "rehash-size"); DEFSYM (Qrehash_threshold, "rehash-threshold"); diff --git a/src/macros.c b/src/macros.c index 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. */) executing_kbd_macro_iterations = ++success_count; - QUIT; + maybe_quit (); } while (--repeat && (STRINGP (Vexecuting_kbd_macro) || VECTORP (Vexecuting_kbd_macro))); diff --git a/src/minibuf.c b/src/minibuf.c index 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. */) case_fold); if (EQ (tem, Qt)) return elt; - QUIT; + maybe_quit (); } return Qnil; } 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) unsigned char str[MAX_MULTIBYTE_LENGTH]; int len = CHAR_STRING (ch, str); - QUIT; + maybe_quit (); if (NILP (fun)) { @@ -1352,7 +1352,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t), 40))]; - QUIT; + maybe_quit (); /* Detect circularities and truncate them. */ if (NILP (Vprint_circle)) @@ -1446,7 +1446,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte); - QUIT; + maybe_quit (); if (multibyte ? (CHAR_BYTE8_P (c) && (c = CHAR_TO_BYTE8 (c), true)) @@ -1550,7 +1550,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) /* Here, we must convert each multi-byte form to the corresponding character code before handing it to PRINTCHAR. */ FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte); - QUIT; + maybe_quit (); if (escapeflag) { @@ -1707,7 +1707,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) for (i = 0; i < size_in_chars; i++) { - QUIT; + maybe_quit (); c = bool_vector_uchar_data (obj)[i]; if (c == '\n' && print_escape_newlines) print_c_string ("\\n", printcharfun); @@ -1818,6 +1818,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) print_object (h->rehash_threshold, printcharfun, escapeflag); } + if (!NILP (h->pure)) + { + print_c_string (" purecopy ", printcharfun); + print_object (h->pure, printcharfun, escapeflag); + } + print_c_string (" data ", printcharfun); /* Print the data here as a plist. */ diff --git a/src/process.c b/src/process.c index ab9657b15a4..434a3955b2c 100644 --- a/src/process.c +++ b/src/process.c @@ -3431,16 +3431,14 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, break; } - immediate_quit = 1; - QUIT; + maybe_quit (); ret = connect (s, sa, addrlen); xerrno = errno; if (ret == 0 || xerrno == EISCONN) { - /* The unwind-protect will be discarded afterwards. - Likewise for immediate_quit. */ + /* The unwind-protect will be discarded afterwards. */ break; } @@ -3459,7 +3457,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, retry_select: FD_ZERO (&fdset); FD_SET (s, &fdset); - QUIT; + maybe_quit (); sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL); if (sc == -1) { @@ -3481,8 +3479,6 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, } #endif /* !WINDOWSNT */ - immediate_quit = 0; - /* Discard the unwind protect closing S. */ specpdl_ptr = specpdl + count; emacs_close (s); @@ -3539,8 +3535,6 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, #endif } - immediate_quit = 0; - if (s < 0) { /* If non-blocking got this far - and failed - assume non-blocking is @@ -4012,8 +4006,7 @@ usage: (make-network-process &rest ARGS) */) struct addrinfo *res, *lres; int ret; - immediate_quit = 1; - QUIT; + maybe_quit (); struct addrinfo hints; memset (&hints, 0, sizeof hints); @@ -4034,7 +4027,6 @@ usage: (make-network-process &rest ARGS) */) #else error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret); #endif - immediate_quit = 0; for (lres = res; lres; lres = lres->ai_next) addrinfos = Fcons (conv_addrinfo_to_lisp (lres), addrinfos); @@ -5020,7 +5012,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, since we want to return C-g as an input character. Otherwise, do pending quit if requested. */ if (read_kbd >= 0) - QUIT; + maybe_quit (); else if (pending_signals) process_pending_signals (); @@ -5748,7 +5740,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, { /* Prevent input_pending from remaining set if we quit. */ clear_input_pending (); - QUIT; + maybe_quit (); } return got_some_output; @@ -7486,7 +7478,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, since we want to return C-g as an input character. Otherwise, do pending quit if requested. */ if (read_kbd >= 0) - QUIT; + maybe_quit (); /* Exit now if the cell we're waiting for became non-nil. */ if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) diff --git a/src/profiler.c b/src/profiler.c index 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) make_number (heap_size), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil); + Qnil, Qnil); struct Lisp_Hash_Table *h = XHASH_TABLE (log); /* What is special about our hash-tables is that the keys are pre-filled @@ -174,8 +174,8 @@ record_backtrace (log_t *log, EMACS_INT count) some global flag so that some Elisp code can offload its data elsewhere, so as to avoid the eviction code. There are 2 ways to do that, AFAICT: - - Set a flag checked in QUIT, such that QUIT can then call - Fprofiler_cpu_log and stash the full log for later use. + - Set a flag checked in maybe_quit, such that maybe_quit can then + call Fprofiler_cpu_log and stash the full log for later use. - Set a flag check in post-gc-hook, so that Elisp code can call profiler-cpu-log. That gives us more flexibility since that Elisp code can then do all kinds of fun stuff like write diff --git a/src/regex.c b/src/regex.c index db3f0c16a2d..796f868d1c2 100644 --- a/src/regex.c +++ b/src/regex.c @@ -1728,13 +1728,8 @@ typedef struct /* Explicit quit checking is needed for Emacs, which uses polling to process input events. */ -#ifdef emacs -# define IMMEDIATE_QUIT_CHECK \ - do { \ - if (immediate_quit) QUIT; \ - } while (0) -#else -# define IMMEDIATE_QUIT_CHECK ((void)0) +#ifndef emacs +static void maybe_quit (void) {} #endif /* Structure to manage work area for range table. */ @@ -5823,7 +5818,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* Unconditionally jump (without popping any failure points). */ case jump: unconditional_jump: - IMMEDIATE_QUIT_CHECK; + maybe_quit (); EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */ DEBUG_PRINT ("EXECUTING jump %d ", mcnt); p += mcnt; /* Do the jump. */ @@ -6171,7 +6166,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* We goto here if a matching operation fails. */ fail: - IMMEDIATE_QUIT_CHECK; + maybe_quit (); if (!FAIL_STACK_EMPTY ()) { re_char *str, *pat; diff --git a/src/search.c b/src/search.c index d3045108705..33cb02aa7af 100644 --- a/src/search.c +++ b/src/search.c @@ -99,6 +99,25 @@ matcher_overflow (void) error ("Stack overflow in regexp matcher"); } +static void +freeze_buffer_relocation (void) +{ +#ifdef REL_ALLOC + /* Prevent ralloc.c from relocating the current buffer while + searching it. */ + r_alloc_inhibit_buffer_relocation (1); + record_unwind_protect_int (r_alloc_inhibit_buffer_relocation, 0); +#endif +} + +static void +thaw_buffer_relocation (void) +{ +#ifdef REL_ALLOC + unbind_to (SPECPDL_INDEX () - 1, Qnil); +#endif +} + /* Compile a regexp and signal a Lisp error if anything goes wrong. PATTERN is the pattern to compile. CP is the place to put the result. @@ -276,8 +295,8 @@ looking_at_1 (Lisp_Object string, bool posix) posix, !NILP (BVAR (current_buffer, enable_multibyte_characters))); - immediate_quit = 1; - QUIT; /* Do a pending quit right away, to avoid paradoxical behavior */ + /* Do a pending quit right away, to avoid paradoxical behavior */ + maybe_quit (); /* Get pointers and sizes of the two strings that make up the visible portion of the buffer. */ @@ -300,20 +319,13 @@ looking_at_1 (Lisp_Object string, bool posix) re_match_object = Qnil; -#ifdef REL_ALLOC - /* Prevent ralloc.c from relocating the current buffer while - searching it. */ - r_alloc_inhibit_buffer_relocation (1); -#endif + freeze_buffer_relocation (); i = re_match_2 (bufp, (char *) p1, s1, (char *) p2, s2, PT_BYTE - BEGV_BYTE, (NILP (Vinhibit_changing_match_data) ? &search_regs : NULL), ZV_BYTE - BEGV_BYTE); - immediate_quit = 0; -#ifdef REL_ALLOC - r_alloc_inhibit_buffer_relocation (0); -#endif + thaw_buffer_relocation (); if (i == -2) matcher_overflow (); @@ -398,7 +410,6 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, ? BVAR (current_buffer, case_canon_table) : Qnil), posix, STRING_MULTIBYTE (string)); - immediate_quit = 1; re_match_object = string; val = re_search (bufp, SSDATA (string), @@ -406,7 +417,6 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, SBYTES (string) - pos_byte, (NILP (Vinhibit_changing_match_data) ? &search_regs : NULL)); - immediate_quit = 0; /* Set last_thing_searched only when match data is changed. */ if (NILP (Vinhibit_changing_match_data)) @@ -470,13 +480,11 @@ fast_string_match_internal (Lisp_Object regexp, Lisp_Object string, bufp = compile_pattern (regexp, 0, table, 0, STRING_MULTIBYTE (string)); - immediate_quit = 1; re_match_object = string; val = re_search (bufp, SSDATA (string), SBYTES (string), 0, SBYTES (string), 0); - immediate_quit = 0; return val; } @@ -497,9 +505,7 @@ fast_c_string_match_ignore_case (Lisp_Object regexp, bufp = compile_pattern (regexp, 0, Vascii_canon_table, 0, 0); - immediate_quit = 1; val = re_search (bufp, string, len, 0, len, 0); - immediate_quit = 0; return val; } @@ -560,18 +566,10 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte, } buf = compile_pattern (regexp, 0, Qnil, 0, multibyte); - immediate_quit = 1; -#ifdef REL_ALLOC - /* Prevent ralloc.c from relocating the current buffer while - searching it. */ - r_alloc_inhibit_buffer_relocation (1); -#endif + freeze_buffer_relocation (); len = re_match_2 (buf, (char *) p1, s1, (char *) p2, s2, pos_byte, NULL, limit_byte); -#ifdef REL_ALLOC - r_alloc_inhibit_buffer_relocation (0); -#endif - immediate_quit = 0; + thaw_buffer_relocation (); return len; } @@ -648,7 +646,7 @@ newline_cache_on_off (struct buffer *buf) If BYTEPOS is not NULL, set *BYTEPOS to the byte position corresponding to the returned character position. - If ALLOW_QUIT, set immediate_quit. That's good to do + If ALLOW_QUIT, check for quitting. That's good to do except when inside redisplay. */ ptrdiff_t @@ -684,8 +682,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, if (shortage != 0) *shortage = 0; - immediate_quit = allow_quit; - if (count > 0) while (start != end) { @@ -703,7 +699,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, ptrdiff_t next_change; int result = 1; - immediate_quit = 0; while (start < end && result) { ptrdiff_t lim1; @@ -756,7 +751,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, start_byte = end_byte; break; } - immediate_quit = allow_quit; /* START should never be after END. */ if (start_byte > ceiling_byte) @@ -809,11 +803,12 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, if (--count == 0) { - immediate_quit = 0; if (bytepos) *bytepos = lim_byte + next; return BYTE_TO_CHAR (lim_byte + next); } + if (allow_quit) + maybe_quit (); } start_byte = lim_byte; @@ -832,7 +827,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, ptrdiff_t next_change; int result = 1; - immediate_quit = 0; while (start > end && result) { ptrdiff_t lim1; @@ -869,7 +863,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, start_byte = end_byte; break; } - immediate_quit = allow_quit; /* Start should never be at or before end. */ if (start_byte <= ceiling_byte) @@ -917,11 +910,12 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, if (++count >= 0) { - immediate_quit = 0; if (bytepos) *bytepos = ceiling_byte + prev + 1; return BYTE_TO_CHAR (ceiling_byte + prev + 1); } + if (allow_quit) + maybe_quit (); } start_byte = ceiling_byte; @@ -929,7 +923,6 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, } } - immediate_quit = 0; if (shortage) *shortage = count * direction; if (bytepos) @@ -953,7 +946,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, the number of line boundaries left unfound, and position at the limit we bumped up against. - If ALLOW_QUIT, set immediate_quit. That's good to do + If ALLOW_QUIT, check for quitting. That's good to do except in special cases. */ ptrdiff_t @@ -1196,10 +1189,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte, trt, posix, !NILP (BVAR (current_buffer, enable_multibyte_characters))); - immediate_quit = 1; /* Quit immediately if user types ^G, - because letting this function finish - can take too long. */ - QUIT; /* Do a pending quit right away, + maybe_quit (); /* Do a pending quit right away, to avoid paradoxical behavior */ /* Get pointers and sizes of the two strings that make up the visible portion of the buffer. */ @@ -1221,11 +1211,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte, } re_match_object = Qnil; -#ifdef REL_ALLOC - /* Prevent ralloc.c from relocating the current buffer while - searching it. */ - r_alloc_inhibit_buffer_relocation (1); -#endif + freeze_buffer_relocation (); while (n < 0) { @@ -1267,13 +1253,11 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte, } else { - immediate_quit = 0; -#ifdef REL_ALLOC - r_alloc_inhibit_buffer_relocation (0); -#endif + thaw_buffer_relocation (); return (n); } n++; + maybe_quit (); } while (n > 0) { @@ -1312,18 +1296,13 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte, } else { - immediate_quit = 0; -#ifdef REL_ALLOC - r_alloc_inhibit_buffer_relocation (0); -#endif + thaw_buffer_relocation (); return (0 - n); } n--; + maybe_quit (); } - immediate_quit = 0; -#ifdef REL_ALLOC - r_alloc_inhibit_buffer_relocation (0); -#endif + thaw_buffer_relocation (); return (pos); } else /* non-RE case */ @@ -1927,7 +1906,7 @@ boyer_moore (EMACS_INT n, unsigned char *base_pat, < 0) return (n * (0 - direction)); /* First we do the part we can by pointers (maybe nothing) */ - QUIT; + maybe_quit (); pat = base_pat; limit = pos_byte - dirlen + direction; if (direction > 0) @@ -3230,8 +3209,6 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, if (shortage != 0) *shortage = 0; - immediate_quit = allow_quit; - if (count > 0) while (start != end) { @@ -3274,11 +3251,12 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, if (--count == 0) { - immediate_quit = 0; if (bytepos) *bytepos = lim_byte + next; return BYTE_TO_CHAR (lim_byte + next); } + if (allow_quit) + maybe_quit (); } start_byte = lim_byte; @@ -3286,7 +3264,6 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end, } } - immediate_quit = 0; if (shortage) *shortage = count; if (bytepos) diff --git a/src/syntax.c b/src/syntax.c index 5bc0efa8a41..34a9e632b3c 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -1672,29 +1672,23 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value, COUNT negative means scan backward and stop at word beginning. */ ptrdiff_t -scan_words (register ptrdiff_t from, register EMACS_INT count) +scan_words (ptrdiff_t from, EMACS_INT count) { - register ptrdiff_t beg = BEGV; - register ptrdiff_t end = ZV; - register ptrdiff_t from_byte = CHAR_TO_BYTE (from); - register enum syntaxcode code; + ptrdiff_t beg = BEGV; + ptrdiff_t end = ZV; + ptrdiff_t from_byte = CHAR_TO_BYTE (from); + enum syntaxcode code; int ch0, ch1; Lisp_Object func, pos; - immediate_quit = 1; - QUIT; - SETUP_SYNTAX_TABLE (from, count); while (count > 0) { - while (1) + while (true) { if (from == end) - { - immediate_quit = 0; - return 0; - } + return 0; UPDATE_SYNTAX_TABLE_FORWARD (from); ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte); code = SYNTAX (ch0); @@ -1704,6 +1698,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count) break; if (code == Sword) break; + rarely_quit (from); } /* Now CH0 is a character which begins a word and FROM is the position of the next character. */ @@ -1732,19 +1727,17 @@ scan_words (register ptrdiff_t from, register EMACS_INT count) break; INC_BOTH (from, from_byte); ch0 = ch1; + rarely_quit (from); } } count--; } while (count < 0) { - while (1) + while (true) { if (from == beg) - { - immediate_quit = 0; - return 0; - } + return 0; DEC_BOTH (from, from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); ch1 = FETCH_CHAR_AS_MULTIBYTE (from_byte); @@ -1754,6 +1747,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count) break; if (code == Sword) break; + rarely_quit (from); } /* Now CH1 is a character which ends a word and FROM is the position of it. */ @@ -1786,13 +1780,12 @@ scan_words (register ptrdiff_t from, register EMACS_INT count) break; } ch1 = ch0; + rarely_quit (from); } } count++; } - immediate_quit = 0; - return from; } @@ -2176,7 +2169,6 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp; } - immediate_quit = 1; /* This code may look up syntax tables using functions that rely on the gl_state object. To make sure this object is not out of date, let's initialize it manually. @@ -2226,9 +2218,10 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, } fwd_ok: p += nbytes, pos++, pos_byte += nbytes; + rarely_quit (pos); } else - while (1) + while (true) { if (p >= stop) { @@ -2250,15 +2243,14 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, break; fwd_unibyte_ok: p++, pos++, pos_byte++; + rarely_quit (pos); } } else { if (multibyte) - while (1) + while (true) { - unsigned char *prev_p; - if (p <= stop) { if (p <= endp) @@ -2266,8 +2258,11 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, p = GPT_ADDR; stop = endp; } - prev_p = p; - while (--p >= stop && ! CHAR_HEAD_P (*p)); + unsigned char *prev_p = p; + do + p--; + while (stop <= p && ! CHAR_HEAD_P (*p)); + c = STRING_CHAR (p); if (! NILP (iso_classes) && in_classes (c, iso_classes)) @@ -2291,9 +2286,10 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, } back_ok: pos--, pos_byte -= prev_p - p; + rarely_quit (pos); } else - while (1) + while (true) { if (p <= stop) { @@ -2315,11 +2311,11 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, break; back_unibyte_ok: p--, pos--, pos_byte--; + rarely_quit (pos); } } SET_PT_BOTH (pos, pos_byte); - immediate_quit = 0; SAFE_FREE (); return make_number (PT - start_point); @@ -2393,7 +2389,6 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) ptrdiff_t pos_byte = PT_BYTE; unsigned char *p, *endp, *stop; - immediate_quit = 1; SETUP_SYNTAX_TABLE (pos, forwardp ? 1 : -1); if (forwardp) @@ -2422,6 +2417,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) if (! fastmap[SYNTAX (c)]) goto done; p += nbytes, pos++, pos_byte += nbytes; + rarely_quit (pos); } while (!parse_sexp_lookup_properties || pos < gl_state.e_property); @@ -2438,10 +2434,8 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) if (multibyte) { - while (1) + while (true) { - unsigned char *prev_p; - if (p <= stop) { if (p <= endp) @@ -2450,17 +2444,22 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) stop = endp; } UPDATE_SYNTAX_TABLE_BACKWARD (pos - 1); - prev_p = p; - while (--p >= stop && ! CHAR_HEAD_P (*p)); + + unsigned char *prev_p = p; + do + p--; + while (stop <= p && ! CHAR_HEAD_P (*p)); + c = STRING_CHAR (p); if (! fastmap[SYNTAX (c)]) break; pos--, pos_byte -= prev_p - p; + rarely_quit (pos); } } else { - while (1) + while (true) { if (p <= stop) { @@ -2473,13 +2472,13 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) if (! fastmap[SYNTAX (p[-1])]) break; p--, pos--, pos_byte--; + rarely_quit (pos); } } } done: SET_PT_BOTH (pos, pos_byte); - immediate_quit = 0; return make_number (PT - start_point); } @@ -2541,9 +2540,10 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, ptrdiff_t *charpos_ptr, ptrdiff_t *bytepos_ptr, EMACS_INT *incomment_ptr, int *last_syntax_ptr) { - register int c, c1; - register enum syntaxcode code; - register int syntax, other_syntax; + unsigned short int quit_count = 0; + int c, c1; + enum syntaxcode code; + int syntax, other_syntax; if (nesting <= 0) nesting = -1; @@ -2635,6 +2635,8 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, UPDATE_SYNTAX_TABLE_FORWARD (from); nesting++; } + + rarely_quit (++quit_count); } *charpos_ptr = from; *bytepos_ptr = from_byte; @@ -2662,14 +2664,12 @@ between them, return t; otherwise return nil. */) ptrdiff_t out_charpos, out_bytepos; EMACS_INT dummy; int dummy2; + unsigned short int quit_count = 0; CHECK_NUMBER (count); count1 = XINT (count); stop = count1 > 0 ? ZV : BEGV; - immediate_quit = 1; - QUIT; - from = PT; from_byte = PT_BYTE; @@ -2684,7 +2684,6 @@ between them, return t; otherwise return nil. */) if (from == stop) { SET_PT_BOTH (from, from_byte); - immediate_quit = 0; return Qnil; } c = FETCH_CHAR_AS_MULTIBYTE (from_byte); @@ -2711,6 +2710,7 @@ between them, return t; otherwise return nil. */) INC_BOTH (from, from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); } + rarely_quit (++quit_count); } while (code == Swhitespace || (code == Sendcomment && c == '\n')); @@ -2718,7 +2718,6 @@ between them, return t; otherwise return nil. */) comstyle = ST_COMMENT_STYLE; else if (code != Scomment) { - immediate_quit = 0; DEC_BOTH (from, from_byte); SET_PT_BOTH (from, from_byte); return Qnil; @@ -2729,7 +2728,6 @@ between them, return t; otherwise return nil. */) from = out_charpos; from_byte = out_bytepos; if (!found) { - immediate_quit = 0; SET_PT_BOTH (from, from_byte); return Qnil; } @@ -2741,23 +2739,19 @@ between them, return t; otherwise return nil. */) while (count1 < 0) { - while (1) + while (true) { - bool quoted; - int syntax; - if (from <= stop) { SET_PT_BOTH (BEGV, BEGV_BYTE); - immediate_quit = 0; return Qnil; } DEC_BOTH (from, from_byte); /* char_quoted does UPDATE_SYNTAX_TABLE_BACKWARD (from). */ - quoted = char_quoted (from, from_byte); + bool quoted = char_quoted (from, from_byte); c = FETCH_CHAR_AS_MULTIBYTE (from_byte); - syntax = SYNTAX_WITH_FLAGS (c); + int syntax = SYNTAX_WITH_FLAGS (c); code = SYNTAX (c); comstyle = 0; comnested = SYNTAX_FLAGS_COMMENT_NESTED (syntax); @@ -2800,6 +2794,7 @@ between them, return t; otherwise return nil. */) } else if (from == stop) break; + rarely_quit (++quit_count); } if (fence_found == 0) { @@ -2842,18 +2837,18 @@ between them, return t; otherwise return nil. */) else if (code != Swhitespace || quoted) { leave: - immediate_quit = 0; INC_BOTH (from, from_byte); SET_PT_BOTH (from, from_byte); return Qnil; } + + rarely_quit (++quit_count); } count1++; } SET_PT_BOTH (from, from_byte); - immediate_quit = 0; return Qt; } @@ -2887,6 +2882,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) EMACS_INT dummy; int dummy2; bool multibyte_symbol_p = sexpflag && multibyte_syntax_as_symbol; + unsigned short int quit_count = 0; if (depth > 0) min_depth = 0; @@ -2895,14 +2891,14 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) from_byte = CHAR_TO_BYTE (from); - immediate_quit = 1; - QUIT; + maybe_quit (); SETUP_SYNTAX_TABLE (from, count); while (count > 0) { while (from < stop) { + rarely_quit (++quit_count); bool comstart_first, prefix; int syntax, other_syntax; UPDATE_SYNTAX_TABLE_FORWARD (from); @@ -2971,6 +2967,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) goto done; } INC_BOTH (from, from_byte); + rarely_quit (++quit_count); } goto done; @@ -3042,6 +3039,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if (c_code == Scharquote || c_code == Sescape) INC_BOTH (from, from_byte); INC_BOTH (from, from_byte); + rarely_quit (++quit_count); } INC_BOTH (from, from_byte); if (!depth && sexpflag) goto done; @@ -3056,7 +3054,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if (depth) goto lose; - immediate_quit = 0; return Qnil; /* End of object reached */ @@ -3068,11 +3065,11 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) { while (from > stop) { - int syntax; + rarely_quit (++quit_count); DEC_BOTH (from, from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); c = FETCH_CHAR_AS_MULTIBYTE (from_byte); - syntax= SYNTAX_WITH_FLAGS (c); + int syntax = SYNTAX_WITH_FLAGS (c); code = syntax_multibyte (c, multibyte_symbol_p); if (depth == min_depth) last_good = from; @@ -3144,6 +3141,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) default: goto done2; } DEC_BOTH (from, from_byte); + rarely_quit (++quit_count); } goto done2; @@ -3206,13 +3204,14 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if (syntax_multibyte (c, multibyte_symbol_p) == code) break; } + rarely_quit (++quit_count); } if (code == Sstring_fence && !depth && sexpflag) goto done2; break; case Sstring: stringterm = FETCH_CHAR_AS_MULTIBYTE (from_byte); - while (1) + while (true) { if (from == stop) goto lose; @@ -3226,6 +3225,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) == Sstring)) break; } + rarely_quit (++quit_count); } if (!depth && sexpflag) goto done2; break; @@ -3239,7 +3239,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if (depth) goto lose; - immediate_quit = 0; return Qnil; done2: @@ -3247,7 +3246,6 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) } - immediate_quit = 0; XSETFASTINT (val, from); return val; @@ -3340,6 +3338,7 @@ the prefix syntax flag (p). */) if (pos <= beg) break; DEC_BOTH (pos, pos_byte); + rarely_quit (pos); } SET_PT_BOTH (opoint, opoint_byte); @@ -3347,6 +3346,36 @@ the prefix syntax flag (p). */) return Qnil; } + +/* If the character at FROM_BYTE is the second part of a 2-character + comment opener based on PREV_FROM_SYNTAX, update STATE and return + true. */ +static bool +in_2char_comment_start (struct lisp_parse_state *state, + int prev_from_syntax, + ptrdiff_t prev_from, + ptrdiff_t from_byte) +{ + int c1, syntax; + if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax) + && (c1 = FETCH_CHAR_AS_MULTIBYTE (from_byte), + syntax = SYNTAX_WITH_FLAGS (c1), + SYNTAX_FLAGS_COMSTART_SECOND (syntax))) + { + /* Record the comment style we have entered so that only + the comment-end sequence of the same style actually + terminates the comment section. */ + state->comstyle + = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax); + bool comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) + | SYNTAX_FLAGS_COMMENT_NESTED (syntax)); + state->incomment = comnested ? 1 : -1; + state->comstr_start = prev_from; + return true; + } + return false; +} + /* Parse forward from FROM / FROM_BYTE to END, assuming that FROM has state STATE, and return a description of the state of the parse at END. @@ -3362,8 +3391,6 @@ scan_sexps_forward (struct lisp_parse_state *state, int commentstop) { enum syntaxcode code; - int c1; - bool comnested; struct level { ptrdiff_t last, prev; }; struct level levelstart[100]; struct level *curlevel = levelstart; @@ -3377,12 +3404,12 @@ scan_sexps_forward (struct lisp_parse_state *state, ptrdiff_t prev_from; /* Keep one character before FROM. */ ptrdiff_t prev_from_byte; int prev_from_syntax, prev_prev_from_syntax; - int syntax; bool boundary_stop = commentstop == -1; bool nofence; bool found; ptrdiff_t out_bytepos, out_charpos; int temp; + unsigned short int quit_count = 0; prev_from = from; prev_from_byte = from_byte; @@ -3401,8 +3428,7 @@ do { prev_from = from; \ UPDATE_SYNTAX_TABLE_FORWARD (from); \ } while (0) - immediate_quit = 1; - QUIT; + maybe_quit (); depth = state->depth; start_quoted = state->quoted; @@ -3442,53 +3468,32 @@ do { prev_from = from; \ } else if (start_quoted) goto startquoted; + else if ((from < end) + && (in_2char_comment_start (state, prev_from_syntax, + prev_from, from_byte))) + { + INC_FROM; + prev_from_syntax = Smax; /* the syntax has already been "used up". */ + goto atcomment; + } while (from < end) { - if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax) - && (c1 = FETCH_CHAR (from_byte), - syntax = SYNTAX_WITH_FLAGS (c1), - SYNTAX_FLAGS_COMSTART_SECOND (syntax))) - { - /* Record the comment style we have entered so that only - the comment-end sequence of the same style actually - terminates the comment section. */ - state->comstyle - = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax); - comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) - | SYNTAX_FLAGS_COMMENT_NESTED (syntax)); - state->incomment = comnested ? 1 : -1; - state->comstr_start = prev_from; - INC_FROM; - prev_from_syntax = Smax; /* the syntax has already been - "used up". */ - code = Scomment; - } - else + rarely_quit (++quit_count); + INC_FROM; + + if ((from < end) + && (in_2char_comment_start (state, prev_from_syntax, + prev_from, from_byte))) { INC_FROM; - code = prev_from_syntax & 0xff; - if (code == Scomment_fence) - { - /* Record the comment style we have entered so that only - the comment-end sequence of the same style actually - terminates the comment section. */ - state->comstyle = ST_COMMENT_STYLE; - state->incomment = -1; - state->comstr_start = prev_from; - code = Scomment; - } - else if (code == Scomment) - { - state->comstyle = SYNTAX_FLAGS_COMMENT_STYLE (prev_from_syntax, 0); - state->incomment = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) ? - 1 : -1); - state->comstr_start = prev_from; - } + prev_from_syntax = Smax; /* the syntax has already been "used up". */ + goto atcomment; } if (SYNTAX_FLAGS_PREFIX (prev_from_syntax)) continue; + code = prev_from_syntax & 0xff; switch (code) { case Sescape: @@ -3507,24 +3512,15 @@ do { prev_from = from; \ symstarted: while (from < end) { - int symchar = FETCH_CHAR_AS_MULTIBYTE (from_byte); - - if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax) - && (syntax = SYNTAX_WITH_FLAGS (symchar), - SYNTAX_FLAGS_COMSTART_SECOND (syntax))) + if (in_2char_comment_start (state, prev_from_syntax, + prev_from, from_byte)) { - state->comstyle - = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax); - comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) - | SYNTAX_FLAGS_COMMENT_NESTED (syntax)); - state->incomment = comnested ? 1 : -1; - state->comstr_start = prev_from; INC_FROM; - prev_from_syntax = Smax; - code = Scomment; + prev_from_syntax = Smax; /* the syntax has already been "used up". */ goto atcomment; } + int symchar = FETCH_CHAR_AS_MULTIBYTE (from_byte); switch (SYNTAX (symchar)) { case Scharquote: @@ -3540,13 +3536,25 @@ do { prev_from = from; \ goto symdone; } INC_FROM; + rarely_quit (++quit_count); } symdone: curlevel->prev = curlevel->last; break; - case Scomment_fence: /* Can't happen because it's handled above. */ + case Scomment_fence: + /* Record the comment style we have entered so that only + the comment-end sequence of the same style actually + terminates the comment section. */ + state->comstyle = ST_COMMENT_STYLE; + state->incomment = -1; + state->comstr_start = prev_from; + goto atcomment; case Scomment: + state->comstyle = SYNTAX_FLAGS_COMMENT_STYLE (prev_from_syntax, 0); + state->incomment = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) ? + 1 : -1); + state->comstr_start = prev_from; atcomment: if (commentstop || boundary_stop) goto done; startincomment: @@ -3639,6 +3647,7 @@ do { prev_from = from; \ break; } INC_FROM; + rarely_quit (++quit_count); } } string_end: @@ -3680,7 +3689,6 @@ do { prev_from = from; \ state->levelstarts); state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax) || state->quoted) ? prev_from_syntax : Smax; - immediate_quit = 0; } /* Convert a (lisp) parse state to the internal form used in diff --git a/src/sysdep.c b/src/sysdep.c index 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) so that another thread running glib won't find them. */ eassert (child > 0); - while ((pid = waitpid (child, status, options)) < 0) + while (true) { + /* Note: the MS-Windows emulation of waitpid calls maybe_quit + internally. */ + if (interruptible) + maybe_quit (); + + pid = waitpid (child, status, options); + if (0 <= pid) + break; + /* Check that CHILD is a child process that has not been reaped, and that STATUS and OPTIONS are valid. Otherwise abort, as continuing after this internal error could cause Emacs to become confused and kill innocent-victim processes. */ if (errno != EINTR) emacs_abort (); - - /* Note: the MS-Windows emulation of waitpid calls QUIT - internally. */ - if (interruptible) - QUIT; } /* If successful and status is requested, tell wait_reading_process_output @@ -2383,7 +2387,7 @@ emacs_open (const char *file, int oflags, int mode) oflags |= O_BINARY; oflags |= O_CLOEXEC; while ((fd = open (file, oflags, mode)) < 0 && errno == EINTR) - QUIT; + maybe_quit (); if (! O_CLOEXEC && 0 <= fd) fcntl (fd, F_SETFD, FD_CLOEXEC); return fd; @@ -2503,78 +2507,113 @@ emacs_close (int fd) #define MAX_RW_COUNT (INT_MAX >> 18 << 18) #endif -/* Read from FILEDESC to a buffer BUF with size NBYTE, retrying if interrupted. +/* Read from FD to a buffer BUF with size NBYTE. + If interrupted, process any quits and pending signals immediately + if INTERRUPTIBLE, and then retry the read unless quitting. Return the number of bytes read, which might be less than NBYTE. - On error, set errno and return -1. */ -ptrdiff_t -emacs_read (int fildes, void *buf, ptrdiff_t nbyte) + On error, set errno to a value other than EINTR, and return -1. */ +static ptrdiff_t +emacs_intr_read (int fd, void *buf, ptrdiff_t nbyte, bool interruptible) { - ssize_t rtnval; + ssize_t result; /* There is no need to check against MAX_RW_COUNT, since no caller ever passes a size that large to emacs_read. */ + do + { + if (interruptible) + maybe_quit (); + result = read (fd, buf, nbyte); + } + while (result < 0 && errno == EINTR); - while ((rtnval = read (fildes, buf, nbyte)) == -1 - && (errno == EINTR)) - QUIT; - return (rtnval); + return result; } -/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if interrupted - or if a partial write occurs. If interrupted, process pending - signals if PROCESS SIGNALS. Return the number of bytes written, setting - errno if this is less than NBYTE. */ +/* Read from FD to a buffer BUF with size NBYTE. + If interrupted, retry the read. Return the number of bytes read, + which might be less than NBYTE. On error, set errno to a value + other than EINTR, and return -1. */ +ptrdiff_t +emacs_read (int fd, void *buf, ptrdiff_t nbyte) +{ + return emacs_intr_read (fd, buf, nbyte, false); +} + +/* Like emacs_read, but also process quits and pending signals. */ +ptrdiff_t +emacs_read_quit (int fd, void *buf, ptrdiff_t nbyte) +{ + return emacs_intr_read (fd, buf, nbyte, true); +} + +/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if + interrupted or if a partial write occurs. Process any quits + immediately if INTERRUPTIBLE is positive, and process any pending + signals immediately if INTERRUPTIBLE is nonzero. Return the number + of bytes written; if this is less than NBYTE, set errno to a value + other than EINTR. */ static ptrdiff_t -emacs_full_write (int fildes, char const *buf, ptrdiff_t nbyte, - bool process_signals) +emacs_full_write (int fd, char const *buf, ptrdiff_t nbyte, + int interruptible) { ptrdiff_t bytes_written = 0; while (nbyte > 0) { - ssize_t n = write (fildes, buf, min (nbyte, MAX_RW_COUNT)); + ssize_t n = write (fd, buf, min (nbyte, MAX_RW_COUNT)); if (n < 0) { - if (errno == EINTR) + if (errno != EINTR) + break; + + if (interruptible) { - /* I originally used `QUIT' but that might cause files to - be truncated if you hit C-g in the middle of it. --Stef */ - if (process_signals && pending_signals) + if (0 < interruptible) + maybe_quit (); + if (pending_signals) process_pending_signals (); - continue; } - else - break; } - - buf += n; - nbyte -= n; - bytes_written += n; + else + { + buf += n; + nbyte -= n; + bytes_written += n; + } } return bytes_written; } -/* Write to FILEDES from a buffer BUF with size NBYTE, retrying if - interrupted or if a partial write occurs. Return the number of - bytes written, setting errno if this is less than NBYTE. */ +/* Write to FD from a buffer BUF with size NBYTE, retrying if + interrupted or if a partial write occurs. Do not process quits or + pending signals. Return the number of bytes written, setting errno + if this is less than NBYTE. */ +ptrdiff_t +emacs_write (int fd, void const *buf, ptrdiff_t nbyte) +{ + return emacs_full_write (fd, buf, nbyte, 0); +} + +/* Like emacs_write, but also process pending signals. */ ptrdiff_t -emacs_write (int fildes, void const *buf, ptrdiff_t nbyte) +emacs_write_sig (int fd, void const *buf, ptrdiff_t nbyte) { - return emacs_full_write (fildes, buf, nbyte, 0); + return emacs_full_write (fd, buf, nbyte, -1); } -/* Like emacs_write, but also process pending signals if interrupted. */ +/* Like emacs_write, but also process quits and pending signals. */ ptrdiff_t -emacs_write_sig (int fildes, void const *buf, ptrdiff_t nbyte) +emacs_write_quit (int fd, void const *buf, ptrdiff_t nbyte) { - return emacs_full_write (fildes, buf, nbyte, 1); + return emacs_full_write (fd, buf, nbyte, 1); } /* Write a diagnostic to standard error that contains MESSAGE and a string derived from errno. Preserve errno. Do not buffer stderr. - Do not process pending signals if interrupted. */ + Do not process quits or pending signals if interrupted. */ void emacs_perror (char const *message) { @@ -3168,7 +3207,7 @@ system_process_attributes (Lisp_Object pid) else { record_unwind_protect_int (close_file_unwind, fd); - nread = emacs_read (fd, procbuf, sizeof procbuf - 1); + nread = emacs_read_quit (fd, procbuf, sizeof procbuf - 1); } if (0 < nread) { @@ -3289,7 +3328,7 @@ system_process_attributes (Lisp_Object pid) /* Leave room even if every byte needs escaping below. */ readsize = (cmdline_size >> 1) - nread; - nread_incr = emacs_read (fd, cmdline + nread, readsize); + nread_incr = emacs_read_quit (fd, cmdline + nread, readsize); nread += max (0, nread_incr); } while (nread_incr == readsize); @@ -3402,7 +3441,7 @@ system_process_attributes (Lisp_Object pid) else { record_unwind_protect_int (close_file_unwind, fd); - nread = emacs_read (fd, &pinfo, sizeof pinfo); + nread = emacs_read_quit (fd, &pinfo, sizeof pinfo); } if (nread == sizeof pinfo) diff --git a/src/textprop.c b/src/textprop.c index bf77f84ab79..116bf3f2c93 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -212,7 +212,7 @@ validate_plist (Lisp_Object list) if (! CONSP (tail)) error ("Odd length text property list"); tail = XCDR (tail); - QUIT; + maybe_quit (); } while (CONSP (tail)); diff --git a/src/w32fns.c b/src/w32fns.c index c24fce11fc8..1b628b0b42e 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -778,7 +778,7 @@ w32_color_map_lookup (const char *colorname) break; } - QUIT; + maybe_quit (); } unblock_input (); @@ -3166,18 +3166,9 @@ signal_user_input (void) if (!NILP (Vthrow_on_input)) { Vquit_flag = Vthrow_on_input; - /* Doing a QUIT from this thread is a bad idea, since this + /* Calling maybe_quit from this thread is a bad idea, since this unwinds the stack of the Lisp thread, and the Windows runtime - rightfully barfs. Disabled. */ -#if 0 - /* If we're inside a function that wants immediate quits, - do it now. */ - if (immediate_quit && NILP (Vinhibit_quit)) - { - immediate_quit = 0; - QUIT; - } -#endif + rightfully barfs. */ } } diff --git a/src/w32notify.c b/src/w32notify.c index 1f4cbe2df47..25205816bae 100644 --- a/src/w32notify.c +++ b/src/w32notify.c @@ -664,7 +664,7 @@ w32_get_watch_object (void *desc) Lisp_Object descriptor = make_pointer_integer (desc); /* This is called from the input queue handling code, inside a - critical section, so we cannot possibly QUIT if watch_list is not + critical section, so we cannot possibly quit if watch_list is not in the right condition. */ return NILP (watch_list) ? Qnil : assoc_no_quit (descriptor, watch_list); } diff --git a/src/w32proc.c b/src/w32proc.c index a7f2b4a9950..0aa248a6f7b 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -1449,7 +1449,7 @@ waitpid (pid_t pid, int *status, int options) do { - QUIT; + maybe_quit (); active = WaitForMultipleObjects (nh, wait_hnd, FALSE, timeout_ms); } while (active == WAIT_TIMEOUT && !dont_wait); diff --git a/src/window.c b/src/window.c index 0a6b94d4d1d..95690443f8e 100644 --- a/src/window.c +++ b/src/window.c @@ -521,9 +521,10 @@ select_window (Lisp_Object window, Lisp_Object norecord, bset_last_selected_window (XBUFFER (w->contents), window); record_and_return: - /* record_buffer can run QUIT, so make sure it is run only after we have - re-established the invariant between selected_window and selected_frame, - otherwise the temporary broken invariant might "escape" (bug#14161). */ + /* record_buffer can call maybe_quit, so make sure it is run only + after we have re-established the invariant between + selected_window and selected_frame, otherwise the temporary + broken invariant might "escape" (Bug#14161). */ if (NILP (norecord)) { w->use_time = ++window_select_count; @@ -4769,7 +4770,6 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool whole, bool noerror) { ptrdiff_t count = SPECPDL_INDEX (); - immediate_quit = true; n = clip_to_bounds (INT_MIN, n, INT_MAX); wset_redisplay (XWINDOW (window)); @@ -4788,7 +4788,36 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool whole, bool noerror) /* Bug#15957. */ XWINDOW (window)->window_end_valid = false; - immediate_quit = false; +} + +/* Compute scroll margin for WINDOW. + We scroll when point is within this distance from the top or bottom + of the window. The result is measured in lines or in pixels + depending on the second parameter. */ +int +window_scroll_margin (struct window *window, enum margin_unit unit) +{ + if (scroll_margin > 0) + { + int frame_line_height = default_line_pixel_height (window); + int window_lines = window_box_height (window) / frame_line_height; + + double ratio = 0.25; + if (FLOATP (Vmaximum_scroll_margin)) + { + ratio = XFLOAT_DATA (Vmaximum_scroll_margin); + ratio = max (0.0, ratio); + ratio = min (ratio, 0.5); + } + int max_margin = min ((window_lines - 1)/2, + (int) (window_lines * ratio)); + int margin = clip_to_bounds (0, scroll_margin, max_margin); + return (unit == MARGIN_IN_PIXELS) + ? margin * frame_line_height + : margin; + } + else + return 0; } @@ -4807,7 +4836,6 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) bool vscrolled = false; int x, y, rtop, rbot, rowh, vpos; void *itdata = NULL; - int window_total_lines; int frame_line_height = default_line_pixel_height (w); bool adjust_old_pointm = !NILP (Fequal (Fwindow_point (window), Fwindow_old_point (window))); @@ -5063,12 +5091,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) /* Move PT out of scroll margins. This code wants current_y to be zero at the window start position even if there is a header line. */ - window_total_lines - = w->total_lines * WINDOW_FRAME_LINE_HEIGHT (w) / frame_line_height; - this_scroll_margin = max (0, scroll_margin); - this_scroll_margin - = min (this_scroll_margin, window_total_lines / 4); - this_scroll_margin *= frame_line_height; + this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS); if (n > 0) { @@ -5124,7 +5147,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) in the scroll margin at the bottom. */ move_it_to (&it, PT, -1, (it.last_visible_y - WINDOW_HEADER_LINE_HEIGHT (w) - - this_scroll_margin - 1), + - partial_line_height (&it) - this_scroll_margin - 1), -1, MOVE_TO_POS | MOVE_TO_Y); @@ -5291,9 +5314,7 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) if (pos < ZV) { - /* Don't use a scroll margin that is negative or too large. */ - int this_scroll_margin = - max (0, min (scroll_margin, w->total_lines / 4)); + int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES); set_marker_restricted_both (w->start, w->contents, pos, pos_byte); w->start_at_line_beg = !NILP (bolp); @@ -5723,8 +5744,7 @@ and redisplay normally--don't erase and redraw the frame. */) /* Do this after making BUF current in case scroll_margin is buffer-local. */ - this_scroll_margin - = max (0, min (scroll_margin, w->total_lines / 4)); + this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES); /* Don't use redisplay code for initial frames, as the necessary data structures might not be set up yet then. */ @@ -5963,10 +5983,6 @@ from the top of the window. */) lines = displayed_window_lines (w); -#if false - this_scroll_margin = max (0, min (scroll_margin, lines / 4)); -#endif - if (NILP (arg)) XSETFASTINT (arg, lines / 2); else @@ -5982,6 +5998,8 @@ from the top of the window. */) it is probably better not to install it. However, it is here inside #if false so as not to lose it. -- rms. */ + this_scroll_margin = window_scroll_margin (w, MARGIN_IN_LINES); + /* Don't let it get into the margin at either top or bottom. */ iarg = max (iarg, this_scroll_margin); iarg = min (iarg, lines - this_scroll_margin - 1); diff --git a/src/window.h b/src/window.h index 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); extern void mark_window_cursors_off (struct window *); extern int window_internal_height (struct window *); extern int window_body_width (struct window *w, bool); +enum margin_unit { MARGIN_IN_LINES, MARGIN_IN_PIXELS }; +extern int window_scroll_margin (struct window *, enum margin_unit); extern void temp_output_buffer_show (Lisp_Object); extern void replace_buffer_in_windows (Lisp_Object); extern void replace_buffer_in_windows_safely (Lisp_Object); diff --git a/src/xdisp.c b/src/xdisp.c index 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) } } +int +partial_line_height (struct it *it_origin) +{ + int partial_height; + void *it_data = NULL; + struct it it; + SAVE_IT (it, *it_origin, it_data); + move_it_to (&it, ZV, -1, it.last_visible_y, -1, + MOVE_TO_POS | MOVE_TO_Y); + if (it.what == IT_EOB) + { + int vis_height = it.last_visible_y - it.current_y; + int height = it.ascent + it.descent; + partial_height = (vis_height < height) ? vis_height : 0; + } + else + { + int last_line_y = it.current_y; + move_it_by_lines (&it, 1); + partial_height = (it.current_y > it.last_visible_y) + ? it.last_visible_y - last_line_y : 0; + } + RESTORE_IT (&it, &it, it_data); + return partial_height; +} + /* Return true if IT points into the middle of a display vector. */ bool @@ -15316,7 +15342,6 @@ try_scrolling (Lisp_Object window, bool just_this_one_p, bool temp_scroll_step, bool last_line_misfit) { struct window *w = XWINDOW (window); - struct frame *f = XFRAME (w->frame); struct text_pos pos, startp; struct it it; int this_scroll_margin, scroll_max, rc, height; @@ -15327,8 +15352,6 @@ try_scrolling (Lisp_Object window, bool just_this_one_p, /* We will never try scrolling more than this number of lines. */ int scroll_limit = SCROLL_LIMIT; int frame_line_height = default_line_pixel_height (w); - int window_total_lines - = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height; #ifdef GLYPH_DEBUG debug_method_add (w, "try_scrolling"); @@ -15336,13 +15359,7 @@ try_scrolling (Lisp_Object window, bool just_this_one_p, SET_TEXT_POS_FROM_MARKER (startp, w->start); - /* Compute scroll margin height in pixels. We scroll when point is - within this distance from the top or bottom of the window. */ - if (scroll_margin > 0) - this_scroll_margin = min (scroll_margin, window_total_lines / 4) - * frame_line_height; - else - this_scroll_margin = 0; + this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS); /* Force arg_scroll_conservatively to have a reasonable value, to avoid scrolling too far away with slow move_it_* functions. Note @@ -15377,7 +15394,8 @@ try_scrolling (Lisp_Object window, bool just_this_one_p, /* Compute the pixel ypos of the scroll margin, then move IT to either that ypos or PT, whichever comes first. */ start_display (&it, w, startp); - scroll_margin_y = it.last_visible_y - this_scroll_margin + scroll_margin_y = it.last_visible_y - partial_line_height (&it) + - this_scroll_margin - frame_line_height * extra_scroll_margin_lines; move_it_to (&it, PT, -1, scroll_margin_y - 1, -1, (MOVE_TO_POS | MOVE_TO_Y)); @@ -15816,23 +15834,12 @@ try_cursor_movement (Lisp_Object window, struct text_pos startp, { int this_scroll_margin, top_scroll_margin; struct glyph_row *row = NULL; - int frame_line_height = default_line_pixel_height (w); - int window_total_lines - = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height; #ifdef GLYPH_DEBUG debug_method_add (w, "cursor movement"); #endif - /* Scroll if point within this distance from the top or bottom - of the window. This is a pixel value. */ - if (scroll_margin > 0) - { - this_scroll_margin = min (scroll_margin, window_total_lines / 4); - this_scroll_margin *= frame_line_height; - } - else - this_scroll_margin = 0; + this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS); top_scroll_margin = this_scroll_margin; if (WINDOW_WANTS_HEADER_LINE_P (w)) @@ -16280,7 +16287,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) int centering_position = -1; bool last_line_misfit = false; ptrdiff_t beg_unchanged, end_unchanged; - int frame_line_height; + int frame_line_height, margin; bool use_desired_matrix; void *itdata = NULL; @@ -16310,6 +16317,8 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) restart: reconsider_clip_changes (w); frame_line_height = default_line_pixel_height (w); + margin = window_scroll_margin (w, MARGIN_IN_LINES); + /* Has the mode line to be updated? */ update_mode_line = (w->update_mode_line @@ -16614,10 +16623,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) /* Some people insist on not letting point enter the scroll margin, even though this part handles windows that didn't scroll at all. */ - int window_total_lines - = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height; - int margin = min (scroll_margin, window_total_lines / 4); - int pixel_margin = margin * frame_line_height; + int pixel_margin = margin * frame_line_height; bool header_line = WINDOW_WANTS_HEADER_LINE_P (w); /* Note: We add an extra FRAME_LINE_HEIGHT, because the loop @@ -16901,12 +16907,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) it.current_y = it.last_visible_y; if (centering_position < 0) { - int window_total_lines - = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height; - int margin - = scroll_margin > 0 - ? min (scroll_margin, window_total_lines / 4) - : 0; ptrdiff_t margin_pos = CHARPOS (startp); Lisp_Object aggressive; bool scrolling_up; @@ -17150,10 +17150,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) { int window_total_lines = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height; - int margin = - scroll_margin > 0 - ? min (scroll_margin, window_total_lines / 4) - : 0; bool move_down = w->cursor.vpos >= window_total_lines / 2; move_it_by_lines (&it, move_down ? margin + 1 : -(margin + 1)); @@ -17359,7 +17355,6 @@ try_window (Lisp_Object window, struct text_pos pos, int flags) struct it it; struct glyph_row *last_text_row = NULL; struct frame *f = XFRAME (w->frame); - int frame_line_height = default_line_pixel_height (w); /* Make POS the new window start. */ set_marker_both (w->start, Qnil, CHARPOS (pos), BYTEPOS (pos)); @@ -17385,17 +17380,7 @@ try_window (Lisp_Object window, struct text_pos pos, int flags) if ((flags & TRY_WINDOW_CHECK_MARGINS) && !MINI_WINDOW_P (w)) { - int this_scroll_margin; - int window_total_lines - = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (f) / frame_line_height; - - if (scroll_margin > 0) - { - this_scroll_margin = min (scroll_margin, window_total_lines / 4); - this_scroll_margin *= frame_line_height; - } - else - this_scroll_margin = 0; + int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS); if ((w->cursor.y >= 0 /* not vscrolled */ && w->cursor.y < this_scroll_margin @@ -18679,15 +18664,8 @@ try_window_id (struct window *w) /* Don't let the cursor end in the scroll margins. */ { - int this_scroll_margin, cursor_height; - int frame_line_height = default_line_pixel_height (w); - int window_total_lines - = WINDOW_TOTAL_LINES (w) * FRAME_LINE_HEIGHT (it.f) / frame_line_height; - - this_scroll_margin = - max (0, min (scroll_margin, window_total_lines / 4)); - this_scroll_margin *= frame_line_height; - cursor_height = MATRIX_ROW (w->desired_matrix, w->cursor.vpos)->height; + int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS); + int cursor_height = MATRIX_ROW (w->desired_matrix, w->cursor.vpos)->height; if ((w->cursor.y < this_scroll_margin && CHARPOS (start) > BEGV) @@ -22635,7 +22613,7 @@ move_elt_to_front (Lisp_Object elt, Lisp_Object list) else prev = tail; tail = XCDR (tail); - QUIT; + maybe_quit (); } /* Not found--return unchanged LIST. */ @@ -31569,6 +31547,14 @@ Recenter the window whenever point gets within this many lines of the top or bottom of the window. */); scroll_margin = 0; + DEFVAR_LISP ("maximum-scroll-margin", Vmaximum_scroll_margin, + doc: /* Maximum effective value of `scroll-margin'. +Given as a fraction of the current window's lines. The value should +be a floating point number between 0.0 and 0.5. The effective maximum +is limited to (/ (1- window-lines) 2). Non-float values for this +variable are ignored and the default 0.25 is used instead. */); + Vmaximum_scroll_margin = make_float (0.25); + DEFVAR_LISP ("display-pixels-per-inch", Vdisplay_pixels_per_inch, doc: /* Pixels per inch value for non-window system displays. Value is a number or a cons (WIDTH-DPI . HEIGHT-DPI). */); diff --git a/src/xselect.c b/src/xselect.c index 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, Fcons (selection_data, dpyinfo->terminal->Vselection_alist)); /* If we already owned the selection, remove the old selection - data. Don't use Fdelq as that may QUIT. */ + data. Don't use Fdelq as that may quit. */ if (!NILP (prev_value)) { /* We know it's not the CAR, so it's easy. */ @@ -929,7 +929,7 @@ x_handle_selection_clear (struct selection_input_event *event) && local_selection_time > changed_owner_time) return; - /* Otherwise, really clear. Don't use Fdelq as that may QUIT;. */ + /* Otherwise, really clear. Don't use Fdelq as that may quit. */ Vselection_alist = dpyinfo->terminal->Vselection_alist; if (EQ (local_selection_data, CAR (Vselection_alist))) Vselection_alist = XCDR (Vselection_alist); diff --git a/src/xterm.c b/src/xterm.c index 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) (*surface_set_size_func) (surface, width, height); unblock_input (); - QUIT; + maybe_quit (); block_input (); } @@ -12877,7 +12877,7 @@ keysyms. The default is nil, which is the same as `super'. */); Vx_keysym_table = make_hash_table (hashtest_eql, make_number (900), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil); + Qnil, Qnil); DEFVAR_BOOL ("x-frame-normalize-before-maximize", x_frame_normalize_before_maximize, |