summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/alloc.c114
-rw-r--r--src/atimer.c1
-rw-r--r--src/buffer.c13
-rw-r--r--src/bytecode.c2
-rw-r--r--src/callint.c2
-rw-r--r--src/callproc.c16
-rw-r--r--src/category.c2
-rw-r--r--src/ccl.c2
-rw-r--r--src/decompress.c2
-rw-r--r--src/dired.c10
-rw-r--r--src/editfns.c16
-rw-r--r--src/emacs-module.c2
-rw-r--r--src/eval.c40
-rw-r--r--src/fileio.c73
-rw-r--r--src/filelock.c2
-rw-r--r--src/fns.c405
-rw-r--r--src/fontset.c8
-rw-r--r--src/frame.c5
-rw-r--r--src/gfilenotify.c8
-rw-r--r--src/gnutls.c13
-rw-r--r--src/image.c2
-rw-r--r--src/indent.c6
-rw-r--r--src/insdel.c12
-rw-r--r--src/keyboard.c18
-rw-r--r--src/keyboard.h2
-rw-r--r--src/keymap.c12
-rw-r--r--src/lisp.h49
-rw-r--r--src/lread.c14
-rw-r--r--src/macros.c2
-rw-r--r--src/minibuf.c2
-rw-r--r--src/print.c16
-rw-r--r--src/process.c22
-rw-r--r--src/profiler.c6
-rw-r--r--src/regex.c7
-rw-r--r--src/search.c49
-rw-r--r--src/syntax.c167
-rw-r--r--src/sysdep.c10
-rw-r--r--src/textprop.c2
-rw-r--r--src/thread.c61
-rw-r--r--src/w32fns.c8
-rw-r--r--src/w32notify.c2
-rw-r--r--src/w32proc.c2
-rw-r--r--src/window.c7
-rw-r--r--src/xdisp.c2
-rw-r--r--src/xselect.c4
-rw-r--r--src/xterm.c62
46 files changed, 652 insertions, 630 deletions
diff --git a/src/alloc.c b/src/alloc.c
index 1a6d4e2d565..dd2b688f91e 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;
+ maybe_quit ();
}
return val;
@@ -5464,6 +5434,37 @@ 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 +5473,22 @@ 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);
}
+struct pinned_object
+{
+ Lisp_Object object;
+ struct pinned_object *next;
+};
+
+/* Pinned objects are marked before every GC cycle. */
+static struct pinned_object *pinned_objects;
+
static Lisp_Object
purecopy (Lisp_Object obj)
{
@@ -5507,7 +5516,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);
+ /* We cannot 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, the hash table is added to the list of pinned objects,
+ and is marked before 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 +5753,16 @@ compact_undo_list (Lisp_Object list)
}
static void
+mark_pinned_objects (void)
+{
+ struct pinned_object *pobj;
+ for (pobj = pinned_objects; pobj; pobj = pobj->next)
+ {
+ mark_object (pobj->object);
+ }
+}
+
+static void
mark_pinned_symbols (void)
{
struct symbol_block *sblk;
@@ -5843,6 +5882,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 ();
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 fde23cace1a..c00cc40d6f2 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -415,19 +415,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 f4540e94c9c..288d78efe41 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -681,7 +681,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
{
quitcounter = 1;
maybe_gc ();
- QUIT;
+ maybe_quit ();
}
pc += op;
NEXT;
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..301ccf383b5 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;
+ immediate_quit = true;
+ maybe_quit ();
wait_for_termination (synch_process_pid, 0, 1);
synch_process_pid = 0;
- immediate_quit = 0;
+ immediate_quit = false;
message1 ("Waiting for process to die...done");
}
#endif /* !MSDOS */
@@ -726,8 +726,8 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
process_coding.src_multibyte = 0;
}
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
if (0 <= fd0)
{
@@ -769,7 +769,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
}
/* Now NREAD is the total amount of data in the buffer. */
- immediate_quit = 0;
+ immediate_quit = false;
if (!nread)
;
@@ -843,7 +843,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
display_on_the_fly = true;
}
immediate_quit = true;
- QUIT;
+ maybe_quit ();
}
give_up: ;
@@ -860,7 +860,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
wait_for_termination (pid, &status, fd0 < 0);
#endif
- immediate_quit = 0;
+ immediate_quit = false;
/* Don't kill any children that the subprocess may have left behind
when exiting. */
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..52e81fb380b 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,13 +248,13 @@ 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;
+ immediate_quit = true;
+ maybe_quit ();
bool wanted = (NILP (match)
|| re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0);
- immediate_quit = 0;
+ immediate_quit = false;
if (wanted)
{
@@ -508,7 +508,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/editfns.c b/src/editfns.c
index bee3bbc2cdd..82c6abb9987 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
@@ -3053,6 +3053,7 @@ determines whether case is significant or ignored. */)
i2 = begp2;
i1_byte = buf_charpos_to_bytepos (bp1, i1);
i2_byte = buf_charpos_to_bytepos (bp2, i2);
+ immediate_quit = true;
while (i1 < endp1 && i2 < endp2)
{
@@ -3060,8 +3061,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,14 +3092,17 @@ 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)
+ {
+ immediate_quit = false;
+ return make_number (c1 < c2 ? -1 - chars : chars + 1);
+ }
chars++;
}
+ immediate_quit = false;
+
/* The strings match as far as they go.
If one is shorter, that one is less. */
if (chars < endp1 - begp1)
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/eval.c b/src/eval.c
index 1f8d4099324..62d4af15e27 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -856,10 +856,9 @@ usage: (let* VARLIST BODY...) */)
lexenv = Vinternal_interpreter_environment;
- varlist = XCAR (args);
- while (CONSP (varlist))
+ for (varlist = XCAR (args); CONSP (varlist); varlist = XCDR (varlist))
{
- QUIT;
+ maybe_quit ();
elt = XCAR (varlist);
if (SYMBOLP (elt))
@@ -893,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);
@@ -917,6 +915,7 @@ usage: (let VARLIST BODY...) */)
USE_SAFE_ALLOCA;
varlist = XCAR (args);
+ CHECK_LIST (varlist);
/* Make space to hold the values to give the bound variables. */
elt = Flength (varlist);
@@ -926,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;
@@ -979,7 +978,7 @@ usage: (while TEST BODY...) */)
body = XCDR (args);
while (!NILP (eval_sub (test)))
{
- QUIT;
+ maybe_quit ();
prog_ignore (body);
}
@@ -1012,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))
@@ -1132,7 +1131,7 @@ 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;
+ immediate_quit = false;
do
{
@@ -1451,7 +1450,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;
@@ -1463,6 +1462,15 @@ process_quit_flag (void)
quit ();
}
+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.
@@ -1506,10 +1514,10 @@ 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;
+ immediate_quit = false;
if (gc_in_progress || waiting_for_input)
emacs_abort ();
@@ -2127,7 +2135,7 @@ eval_sub (Lisp_Object form)
if (!CONSP (form))
return form;
- QUIT;
+ maybe_quit ();
maybe_gc ();
@@ -2713,7 +2721,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
Lisp_Object val;
ptrdiff_t count;
- QUIT;
+ maybe_quit ();
if (++lisp_eval_depth > max_lisp_eval_depth)
{
@@ -2958,7 +2966,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))
@@ -3096,7 +3104,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 be52d0f3d0e..a46cfc7ac69 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,9 @@ permissions. */)
report_file_error ("Copying permissions to", newname);
}
#else /* not WINDOWSNT */
- immediate_quit = 1;
+ immediate_quit = true;
ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0);
- immediate_quit = 0;
+ immediate_quit = false;
if (ifd < 0)
report_file_error ("Opening input file", file);
@@ -2024,8 +2024,8 @@ permissions. */)
oldsize = out_st.st_size;
}
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
if (clone_file (ofd, ifd))
newsize = st.st_size;
@@ -2047,7 +2047,7 @@ permissions. */)
if (newsize < oldsize && ftruncate (ofd, newsize) != 0)
report_file_error ("Truncating output file", newname);
- immediate_quit = 0;
+ immediate_quit = false;
#ifndef MSDOS
/* Preserve the original file permissions, and if requested, also its
@@ -2682,7 +2682,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 +2815,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;
}
@@ -3393,13 +3403,13 @@ read_non_regular (Lisp_Object state)
{
int nbytes;
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_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;
+ immediate_quit = false;
/* Fast recycle this object for the likely next call. */
free_misc (state);
return make_number (nbytes);
@@ -3858,8 +3868,8 @@ by calling `format-decode', which see. */)
report_file_error ("Setting file position", orig_filename);
}
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
/* Count how many chars at the start of the file
match the text at the beginning of the buffer. */
while (1)
@@ -3910,7 +3920,7 @@ by calling `format-decode', which see. */)
goto handled;
}
immediate_quit = true;
- QUIT;
+ maybe_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. */
@@ -3967,7 +3977,7 @@ by calling `format-decode', which see. */)
if (nread == 0)
break;
}
- immediate_quit = 0;
+ immediate_quit = false;
if (! giveup_match_end)
{
@@ -4065,11 +4075,11 @@ by calling `format-decode', which see. */)
quitting while reading a huge file. */
/* Allow quitting out of the actual I/O. */
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
this = emacs_read (fd, read_buf + unprocessed,
READ_BUF_SIZE - unprocessed);
- immediate_quit = 0;
+ immediate_quit = false;
if (this <= 0)
break;
@@ -4284,13 +4294,13 @@ 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;
+ immediate_quit = true;
+ maybe_quit ();
this = emacs_read (fd,
((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
+ inserted),
trytry);
- immediate_quit = 0;
+ immediate_quit = false;
}
if (this <= 0)
@@ -4602,7 +4612,7 @@ by calling `format-decode', which see. */)
}
}
- QUIT;
+ maybe_quit ();
p = XCDR (p);
}
@@ -4992,7 +5002,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
}
}
- immediate_quit = 1;
+ immediate_quit = true;
if (STRINGP (start))
ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding);
@@ -5016,7 +5026,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
save_errno = errno;
}
- immediate_quit = 0;
+ immediate_quit = false;
/* fsync is not crucial for temporary files. Nor for auto-save
files, since they might lose some work anyway. */
@@ -5142,19 +5152,26 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
if (! ok)
report_file_errno ("Write error", filename, save_errno);
+ bool auto_saving_into_visited_file =
+ auto_saving
+ && ! NILP (Fstring_equal (BVAR (current_buffer, filename),
+ BVAR (current_buffer, auto_save_file_name)));
if (visiting)
{
SAVE_MODIFF = MODIFF;
XSETFASTINT (BVAR (current_buffer, save_length), Z - BEG);
bset_filename (current_buffer, visit_file);
update_mode_lines = 14;
+ if (auto_saving_into_visited_file)
+ unlock_file (lockname);
}
else if (quietly)
{
- if (auto_saving
- && ! NILP (Fstring_equal (BVAR (current_buffer, filename),
- BVAR (current_buffer, auto_save_file_name))))
- SAVE_MODIFF = MODIFF;
+ if (auto_saving_into_visited_file)
+ {
+ SAVE_MODIFF = MODIFF;
+ unlock_file (lockname);
+ }
return Qnil;
}
diff --git a/src/filelock.c b/src/filelock.c
index 886ab61c7aa..de65c52efa1 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -505,7 +505,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..5769eac9987 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);
@@ -84,17 +85,23 @@ See Info node `(elisp)Random Numbers' for more details. */)
}
/* 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. */
+ 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 };
-/* Random data-structure functions. */
+/* Process a quit, but do it only rarely, for efficiency. "Rarely"
+ means once per QUIT_COUNT_HEURISTIC or per USHRT_MAX + 1 times,
+ whichever is smaller. Use *QUIT_COUNT to count this. */
static void
-CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
+rarely_quit (unsigned short int *quit_count)
{
- CHECK_TYPE (NILP (x), Qlistp, y);
+ if (! (++*quit_count & (QUIT_COUNT_HEURISTIC - 1)))
+ maybe_quit ();
}
+/* Random data-structure functions. */
+
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 +133,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 +179,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 +1209,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 +1358,22 @@ 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++)
+ EMACS_INT num = XINT (n);
+ Lisp_Object tail = list;
+ immediate_quit = true;
+ for (EMACS_INT i = 0; i < num; i++)
{
- QUIT;
- CHECK_LIST_CONS (list, list);
- list = XCDR (list);
+ if (! CONSP (tail))
+ {
+ immediate_quit = false;
+ CHECK_LIST_END (tail, list);
+ return Qnil;
+ }
+ tail = XCDR (tail);
}
- return list;
+ immediate_quit = false;
+ return tail;
}
DEFUN ("nth", Fnth, Snth, 2, 2, 0,
@@ -1392,66 +1400,61 @@ 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)
+ immediate_quit = true;
+ 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))
+ {
+ immediate_quit = false;
+ return tail;
+ }
}
-
- CHECK_LIST (list);
- return list;
+ immediate_quit = false;
+ 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))
+ immediate_quit = true;
+ 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;
+ {
+ immediate_quit = false;
+ return tail;
+ }
}
+ immediate_quit = false;
+ CHECK_LIST_END (tail, list);
return Qnil;
}
@@ -1461,44 +1464,29 @@ 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)
- {
- 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;
- }
-
- return CAR (list);
+ immediate_quit = true;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
+ if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
+ {
+ immediate_quit = false;
+ return XCAR (tail);
+ }
+ immediate_quit = true;
+ 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 +1494,52 @@ 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)
- {
- 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;
- }
-
- return CAR (list);
+ immediate_quit = true;
+ Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
+ if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key))
+ {
+ immediate_quit = false;
+ return XCAR (tail);
+ }
+ immediate_quit = true;
+ CHECK_LIST_END (tail, list);
+ return Qnil;
}
DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
@@ -1588,35 +1547,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,
@@ -1754,12 +1696,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 +1710,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 +1730,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);
+ rarely_quit (&quit_count);
next = XCDR (tail);
Fsetcdr (tail, prev);
prev = tail;
}
+ CHECK_LIST_END (tail, seq);
seq = prev;
}
else if (VECTORP (seq))
@@ -1838,9 +1781,10 @@ 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;
+ rarely_quit (&quit_count);
new = Fcons (XCAR (seq), new);
}
CHECK_LIST_END (seq, seq);
@@ -2130,28 +2074,28 @@ 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));
+ immediate_quit = true;
+ Lisp_Object prev = Qnil;
+ for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail));
tail = XCDR (XCDR (tail)))
{
if (EQ (prop, XCAR (tail)))
{
+ immediate_quit = false;
Fsetcar (XCDR (tail), val);
return plist;
}
prev = tail;
- QUIT;
}
- newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
+ immediate_quit = true;
+ 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 +2118,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 +2127,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 +2143,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 +2157,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 +2235,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 +2426,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;
+ unsigned short int quit_count = 0;
+ Lisp_Object val = Qnil;
- val = tail = 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 +2439,19 @@ usage: (nconc &rest LISTS) */)
if (argnum + 1 == nargs) break;
- CHECK_LIST_CONS (tem, tem);
+ CHECK_CONS (tem);
- while (CONSP (tem))
+ immediate_quit = true;
+ Lisp_Object tail;
+ do
{
tail = tem;
tem = XCDR (tail);
- QUIT;
}
+ while (CONSP (tem));
+
+ immediate_quit = false;
+ rarely_quit (&quit_count);
tem = args[argnum + 1];
Fsetcdr (tail, tem);
@@ -2927,12 +2873,13 @@ 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)
{
+ immediate_quit = true;
while (CONSP (plist) && !EQ (XCAR (plist), prop))
{
plist = XCDR (plist);
plist = CDR (plist);
- QUIT;
}
+ immediate_quit = false;
return plist;
}
@@ -3804,12 +3751,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 +3802,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 +4467,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 +4509,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 +4553,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 +4633,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 +4659,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 +4678,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 +5049,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..23951a16eb6 100644
--- a/src/indent.c
+++ b/src/indent.c
@@ -1200,8 +1200,8 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
continuation_glyph_width = 0; /* In the fringe. */
#endif
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
/* It's just impossible to be too paranoid here. */
eassert (from == BYTE_TO_CHAR (frombyte) && frombyte == CHAR_TO_BYTE (from));
@@ -1694,7 +1694,7 @@ 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;
+ immediate_quit = false;
return &val_compute_motion;
}
diff --git a/src/insdel.c b/src/insdel.c
index b93606ced85..3f933b0ad85 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..d41603b2e50 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
@@ -1416,7 +1416,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. */
}
}
@@ -3591,7 +3591,7 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event,
if (immediate_quit && NILP (Vinhibit_quit))
{
immediate_quit = false;
- QUIT;
+ maybe_quit ();
}
}
}
@@ -7426,7 +7426,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 +7987,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 +9806,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 +9840,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 +10278,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 +10289,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;
}
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 e7747563085..91c430fe98d 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. Any changes the table after
+ purecopy will result in an error. */
+ 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,34 +3123,25 @@ 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.
+/* 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.
- 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.
+ Exception: if you set immediate_quit, 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.
If quit-flag is set to `kill-emacs' the SIGINT handler has received
- a request to exit Emacs when it is safe to do. */
-
-extern void process_pending_signals (void);
-extern bool volatile pending_signals;
+ a request to exit Emacs when it is safe to do.
-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)
+ When not quitting, process any pending signals. */
+extern void maybe_quit (void);
/* True if ought to quit now. */
@@ -3375,7 +3368,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);
diff --git a/src/lread.c b/src/lread.c
index 284fd1aafbc..17806922a8c 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);
@@ -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..dbd4358dd1a 100644
--- a/src/process.c
+++ b/src/process.c
@@ -3431,8 +3431,8 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
break;
}
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
ret = connect (s, sa, addrlen);
xerrno = errno;
@@ -3459,7 +3459,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,7 +3481,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
}
#endif /* !WINDOWSNT */
- immediate_quit = 0;
+ immediate_quit = false;
/* Discard the unwind protect closing S. */
specpdl_ptr = specpdl + count;
@@ -3539,7 +3539,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
#endif
}
- immediate_quit = 0;
+ immediate_quit = false;
if (s < 0)
{
@@ -4012,8 +4012,8 @@ usage: (make-network-process &rest ARGS) */)
struct addrinfo *res, *lres;
int ret;
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
struct addrinfo hints;
memset (&hints, 0, sizeof hints);
@@ -4034,7 +4034,7 @@ usage: (make-network-process &rest ARGS) */)
#else
error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret);
#endif
- immediate_quit = 0;
+ immediate_quit = false;
for (lres = res; lres; lres = lres->ai_next)
addrinfos = Fcons (conv_addrinfo_to_lisp (lres), addrinfos);
@@ -5020,7 +5020,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 +5748,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 +7486,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..f6e67afef4c 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -1729,12 +1729,9 @@ 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)
+# define IMMEDIATE_QUIT_CHECK (immediate_quit ? maybe_quit () : (void) 0)
#else
-# define IMMEDIATE_QUIT_CHECK ((void)0)
+# define IMMEDIATE_QUIT_CHECK ((void) 0)
#endif
/* Structure to manage work area for range table. */
diff --git a/src/search.c b/src/search.c
index d3045108705..f54f44c8818 100644
--- a/src/search.c
+++ b/src/search.c
@@ -276,8 +276,9 @@ 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 */
+ immediate_quit = true;
+ maybe_quit ();
/* Get pointers and sizes of the two strings
that make up the visible portion of the buffer. */
@@ -310,7 +311,7 @@ looking_at_1 (Lisp_Object string, bool posix)
(NILP (Vinhibit_changing_match_data)
? &search_regs : NULL),
ZV_BYTE - BEGV_BYTE);
- immediate_quit = 0;
+ immediate_quit = false;
#ifdef REL_ALLOC
r_alloc_inhibit_buffer_relocation (0);
#endif
@@ -398,7 +399,7 @@ 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;
+ immediate_quit = true;
re_match_object = string;
val = re_search (bufp, SSDATA (string),
@@ -406,7 +407,7 @@ 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;
+ immediate_quit = false;
/* Set last_thing_searched only when match data is changed. */
if (NILP (Vinhibit_changing_match_data))
@@ -470,13 +471,13 @@ fast_string_match_internal (Lisp_Object regexp, Lisp_Object string,
bufp = compile_pattern (regexp, 0, table,
0, STRING_MULTIBYTE (string));
- immediate_quit = 1;
+ immediate_quit = true;
re_match_object = string;
val = re_search (bufp, SSDATA (string),
SBYTES (string), 0,
SBYTES (string), 0);
- immediate_quit = 0;
+ immediate_quit = false;
return val;
}
@@ -497,9 +498,9 @@ fast_c_string_match_ignore_case (Lisp_Object regexp,
bufp = compile_pattern (regexp, 0,
Vascii_canon_table, 0,
0);
- immediate_quit = 1;
+ immediate_quit = true;
val = re_search (bufp, string, len, 0, len, 0);
- immediate_quit = 0;
+ immediate_quit = false;
return val;
}
@@ -560,7 +561,7 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte,
}
buf = compile_pattern (regexp, 0, Qnil, 0, multibyte);
- immediate_quit = 1;
+ immediate_quit = true;
#ifdef REL_ALLOC
/* Prevent ralloc.c from relocating the current buffer while
searching it. */
@@ -571,7 +572,7 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte,
#ifdef REL_ALLOC
r_alloc_inhibit_buffer_relocation (0);
#endif
- immediate_quit = 0;
+ immediate_quit = false;
return len;
}
@@ -703,7 +704,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
ptrdiff_t next_change;
int result = 1;
- immediate_quit = 0;
+ immediate_quit = false;
while (start < end && result)
{
ptrdiff_t lim1;
@@ -809,7 +810,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
if (--count == 0)
{
- immediate_quit = 0;
+ immediate_quit = false;
if (bytepos)
*bytepos = lim_byte + next;
return BYTE_TO_CHAR (lim_byte + next);
@@ -832,7 +833,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
ptrdiff_t next_change;
int result = 1;
- immediate_quit = 0;
+ immediate_quit = false;
while (start > end && result)
{
ptrdiff_t lim1;
@@ -917,7 +918,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
if (++count >= 0)
{
- immediate_quit = 0;
+ immediate_quit = false;
if (bytepos)
*bytepos = ceiling_byte + prev + 1;
return BYTE_TO_CHAR (ceiling_byte + prev + 1);
@@ -929,7 +930,7 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
}
}
- immediate_quit = 0;
+ immediate_quit = false;
if (shortage)
*shortage = count * direction;
if (bytepos)
@@ -1196,10 +1197,10 @@ 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,
+ immediate_quit = true; /* 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. */
@@ -1267,7 +1268,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
}
else
{
- immediate_quit = 0;
+ immediate_quit = false;
#ifdef REL_ALLOC
r_alloc_inhibit_buffer_relocation (0);
#endif
@@ -1312,7 +1313,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
}
else
{
- immediate_quit = 0;
+ immediate_quit = false;
#ifdef REL_ALLOC
r_alloc_inhibit_buffer_relocation (0);
#endif
@@ -1320,7 +1321,7 @@ search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
}
n--;
}
- immediate_quit = 0;
+ immediate_quit = false;
#ifdef REL_ALLOC
r_alloc_inhibit_buffer_relocation (0);
#endif
@@ -1927,7 +1928,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)
@@ -3274,7 +3275,7 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
if (--count == 0)
{
- immediate_quit = 0;
+ immediate_quit = false;
if (bytepos)
*bytepos = lim_byte + next;
return BYTE_TO_CHAR (lim_byte + next);
@@ -3286,7 +3287,7 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
}
}
- immediate_quit = 0;
+ immediate_quit = false;
if (shortage)
*shortage = count;
if (bytepos)
diff --git a/src/syntax.c b/src/syntax.c
index 84147a2dc15..f9e4093765c 100644
--- a/src/syntax.c
+++ b/src/syntax.c
@@ -1426,8 +1426,8 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
int ch0, ch1;
Lisp_Object func, pos;
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
SETUP_SYNTAX_TABLE (from, count);
@@ -1437,7 +1437,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
{
if (from == end)
{
- immediate_quit = 0;
+ immediate_quit = false;
return 0;
}
UPDATE_SYNTAX_TABLE_FORWARD (from);
@@ -1487,7 +1487,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
{
if (from == beg)
{
- immediate_quit = 0;
+ immediate_quit = false;
return 0;
}
DEC_BOTH (from, from_byte);
@@ -1536,7 +1536,7 @@ scan_words (register ptrdiff_t from, register EMACS_INT count)
count++;
}
- immediate_quit = 0;
+ immediate_quit = false;
return from;
}
@@ -1921,7 +1921,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp;
}
- immediate_quit = 1;
+ immediate_quit = true;
/* 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.
@@ -2064,7 +2064,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
}
SET_PT_BOTH (pos, pos_byte);
- immediate_quit = 0;
+ immediate_quit = false;
SAFE_FREE ();
return make_number (PT - start_point);
@@ -2138,7 +2138,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
ptrdiff_t pos_byte = PT_BYTE;
unsigned char *p, *endp, *stop;
- immediate_quit = 1;
+ immediate_quit = true;
SETUP_SYNTAX_TABLE (pos, forwardp ? 1 : -1);
if (forwardp)
@@ -2224,7 +2224,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
done:
SET_PT_BOTH (pos, pos_byte);
- immediate_quit = 0;
+ immediate_quit = false;
return make_number (PT - start_point);
}
@@ -2412,8 +2412,8 @@ between them, return t; otherwise return nil. */)
count1 = XINT (count);
stop = count1 > 0 ? ZV : BEGV;
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
from = PT;
from_byte = PT_BYTE;
@@ -2429,7 +2429,7 @@ between them, return t; otherwise return nil. */)
if (from == stop)
{
SET_PT_BOTH (from, from_byte);
- immediate_quit = 0;
+ immediate_quit = false;
return Qnil;
}
c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
@@ -2463,7 +2463,7 @@ between them, return t; otherwise return nil. */)
comstyle = ST_COMMENT_STYLE;
else if (code != Scomment)
{
- immediate_quit = 0;
+ immediate_quit = false;
DEC_BOTH (from, from_byte);
SET_PT_BOTH (from, from_byte);
return Qnil;
@@ -2474,7 +2474,7 @@ between them, return t; otherwise return nil. */)
from = out_charpos; from_byte = out_bytepos;
if (!found)
{
- immediate_quit = 0;
+ immediate_quit = false;
SET_PT_BOTH (from, from_byte);
return Qnil;
}
@@ -2494,7 +2494,7 @@ between them, return t; otherwise return nil. */)
if (from <= stop)
{
SET_PT_BOTH (BEGV, BEGV_BYTE);
- immediate_quit = 0;
+ immediate_quit = false;
return Qnil;
}
@@ -2587,7 +2587,7 @@ between them, return t; otherwise return nil. */)
else if (code != Swhitespace || quoted)
{
leave:
- immediate_quit = 0;
+ immediate_quit = false;
INC_BOTH (from, from_byte);
SET_PT_BOTH (from, from_byte);
return Qnil;
@@ -2598,7 +2598,7 @@ between them, return t; otherwise return nil. */)
}
SET_PT_BOTH (from, from_byte);
- immediate_quit = 0;
+ immediate_quit = false;
return Qt;
}
@@ -2640,8 +2640,8 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
from_byte = CHAR_TO_BYTE (from);
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
SETUP_SYNTAX_TABLE (from, count);
while (count > 0)
@@ -2801,7 +2801,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
if (depth)
goto lose;
- immediate_quit = 0;
+ immediate_quit = false;
return Qnil;
/* End of object reached */
@@ -2984,7 +2984,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
if (depth)
goto lose;
- immediate_quit = 0;
+ immediate_quit = false;
return Qnil;
done2:
@@ -2992,7 +2992,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
}
- immediate_quit = 0;
+ immediate_quit = false;
XSETFASTINT (val, from);
return val;
@@ -3092,6 +3092,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.
@@ -3107,8 +3137,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;
@@ -3122,7 +3150,6 @@ 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;
@@ -3146,8 +3173,8 @@ do { prev_from = from; \
UPDATE_SYNTAX_TABLE_FORWARD (from); \
} while (0)
- immediate_quit = 1;
- QUIT;
+ immediate_quit = true;
+ maybe_quit ();
depth = state->depth;
start_quoted = state->quoted;
@@ -3187,53 +3214,31 @@ 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
+ 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:
@@ -3252,24 +3257,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:
@@ -3290,8 +3286,19 @@ do { prev_from = from; \
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:
@@ -3425,7 +3432,7 @@ 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;
+ immediate_quit = false;
}
/* Convert a (lisp) parse state to the internal form used in
diff --git a/src/sysdep.c b/src/sysdep.c
index 4316c21a1c7..e172dc0aed4 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -391,10 +391,10 @@ get_child_status (pid_t child, int *status, int options, bool interruptible)
if (errno != EINTR)
emacs_abort ();
- /* Note: the MS-Windows emulation of waitpid calls QUIT
+ /* Note: the MS-Windows emulation of waitpid calls maybe_quit
internally. */
if (interruptible)
- QUIT;
+ maybe_quit ();
}
/* If successful and status is requested, tell wait_reading_process_output
@@ -2383,7 +2383,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;
@@ -2516,7 +2516,7 @@ emacs_read (int fildes, void *buf, ptrdiff_t nbyte)
while ((rtnval = read (fildes, buf, nbyte)) == -1
&& (errno == EINTR))
- QUIT;
+ maybe_quit ();
return (rtnval);
}
@@ -2538,7 +2538,7 @@ emacs_full_write (int fildes, char const *buf, ptrdiff_t nbyte,
{
if (errno == EINTR)
{
- /* I originally used `QUIT' but that might cause files to
+ /* I originally used maybe_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)
process_pending_signals ();
diff --git a/src/textprop.c b/src/textprop.c
index 7cb3d3c38e6..225ff28e57e 100644
--- a/src/textprop.c
+++ b/src/textprop.c
@@ -211,7 +211,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/thread.c b/src/thread.c
index 5498fe5efcb..9ea7e121a82 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -128,11 +128,11 @@ lisp_mutex_init (lisp_mutex_t *mutex)
sys_cond_init (&mutex->condition);
}
-/* Lock MUTEX setting its count to COUNT, if non-zero, or to 1
- otherwise.
+/* Lock MUTEX for thread LOCKER, setting its lock count to COUNT, if
+ non-zero, or to 1 otherwise.
- If MUTEX is locked by the current thread, COUNT must be zero, and
- the MUTEX's lock count will be incremented.
+ If MUTEX is locked by LOCKER, COUNT must be zero, and the MUTEX's
+ lock count will be incremented.
If MUTEX is locked by another thread, this function will release
the global lock, giving other threads a chance to run, and will
@@ -143,24 +143,25 @@ lisp_mutex_init (lisp_mutex_t *mutex)
unlocked (meaning other threads could have run during the wait),
zero otherwise. */
static int
-lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
+lisp_mutex_lock_for_thread (lisp_mutex_t *mutex, struct thread_state *locker,
+ int new_count)
{
struct thread_state *self;
if (mutex->owner == NULL)
{
- mutex->owner = current_thread;
+ mutex->owner = locker;
mutex->count = new_count == 0 ? 1 : new_count;
return 0;
}
- if (mutex->owner == current_thread)
+ if (mutex->owner == locker)
{
eassert (new_count == 0);
++mutex->count;
return 0;
}
- self = current_thread;
+ self = locker;
self->wait_condvar = &mutex->condition;
while (mutex->owner != NULL && (new_count != 0
|| NILP (self->error_symbol)))
@@ -176,6 +177,12 @@ lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
return 1;
}
+static int
+lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
+{
+ return lisp_mutex_lock_for_thread (mutex, current_thread, new_count);
+}
+
/* Decrement MUTEX's lock count. If the lock count becomes zero after
decrementing it, meaning the mutex is now unlocked, broadcast that
to all the threads that might be waiting to lock the mutex. This
@@ -398,16 +405,16 @@ condition_wait_callback (void *arg)
self->wait_condvar = NULL;
}
self->event_object = Qnil;
- /* Since sys_cond_wait could switch threads, we need to re-establish
- ourselves as the current thread, otherwise lisp_mutex_lock will
- record the wrong thread as the owner of the mutex lock. */
- post_acquire_global_lock (self);
- /* Calling lisp_mutex_lock might yield to other threads while this
- one waits for the mutex to become unlocked, so we need to
- announce us as the current thread by calling
+ /* Since sys_cond_wait could switch threads, we need to lock the
+ mutex for the thread which was the current when we were called,
+ otherwise lisp_mutex_lock will record the wrong thread as the
+ owner of the mutex lock. */
+ lisp_mutex_lock_for_thread (&mutex->mutex, self, saved_count);
+ /* Calling lisp_mutex_lock_for_thread might yield to other threads
+ while this one waits for the mutex to become unlocked, so we need
+ to announce us as the current thread by calling
post_acquire_global_lock. */
- if (lisp_mutex_lock (&mutex->mutex, saved_count))
- post_acquire_global_lock (self);
+ post_acquire_global_lock (self);
}
DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
@@ -663,10 +670,13 @@ invoke_thread_function (void)
return unbind_to (count, Qnil);
}
+static Lisp_Object last_thread_error;
+
static Lisp_Object
-do_nothing (Lisp_Object whatever)
+record_thread_error (Lisp_Object error_form)
{
- return whatever;
+ last_thread_error = error_form;
+ return error_form;
}
static void *
@@ -695,7 +705,7 @@ run_thread (void *state)
handlerlist_sentinel->next = NULL;
/* It might be nice to do something with errors here. */
- internal_condition_case (invoke_thread_function, Qt, do_nothing);
+ internal_condition_case (invoke_thread_function, Qt, record_thread_error);
update_processes_for_thread_death (Fcurrent_thread ());
@@ -944,6 +954,13 @@ DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
return result;
}
+DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 0, 0,
+ doc: /* Return the last error form recorded by a dying thread. */)
+ (void)
+{
+ return last_thread_error;
+}
+
bool
@@ -1028,6 +1045,10 @@ syms_of_threads (void)
defsubr (&Scondition_notify);
defsubr (&Scondition_mutex);
defsubr (&Scondition_name);
+ defsubr (&Sthread_last_error);
+
+ staticpro (&last_thread_error);
+ last_thread_error = Qnil;
}
DEFSYM (Qthreadp, "threadp");
diff --git a/src/w32fns.c b/src/w32fns.c
index c24fce11fc8..6a576fcec27 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,7 +3166,7 @@ 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
@@ -3174,8 +3174,8 @@ signal_user_input (void)
do it now. */
if (immediate_quit && NILP (Vinhibit_quit))
{
- immediate_quit = 0;
- QUIT;
+ immediate_quit = false;
+ maybe_quit ();
}
#endif
}
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..71a82b522c4 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;
diff --git a/src/xdisp.c b/src/xdisp.c
index 168922ef06b..33661c882cd 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -22635,7 +22635,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. */
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 adc02e2768d..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 ();
}
@@ -10993,19 +10993,12 @@ xembed_send_message (struct frame *f, Time t, enum xembed_message msg,
/* Change of visibility. */
-/* This tries to wait until the frame is really visible.
- However, if the window manager asks the user where to position
- the frame, this will return before the user finishes doing that.
- The frame will not actually be visible at that time,
- but it will become visible later when the window manager
- finishes with it. */
+/* This function sends the request to make the frame visible, but may
+ return before it the frame's visibility is changed. */
void
x_make_frame_visible (struct frame *f)
{
- int original_top, original_left;
- int tries = 0;
-
block_input ();
x_set_bitmap_icon (f);
@@ -11052,16 +11045,13 @@ x_make_frame_visible (struct frame *f)
before we do anything else. We do this loop with input not blocked
so that incoming events are handled. */
{
- Lisp_Object frame;
/* This must be before UNBLOCK_INPUT
since events that arrive in response to the actions above
will set it when they are handled. */
bool previously_visible = f->output_data.x->has_been_visible;
- XSETFRAME (frame, f);
-
- original_left = f->left_pos;
- original_top = f->top_pos;
+ int original_left = f->left_pos;
+ int original_top = f->top_pos;
/* This must come after we set COUNT. */
unblock_input ();
@@ -11105,46 +11095,6 @@ x_make_frame_visible (struct frame *f)
unblock_input ();
}
-
- /* Process X events until a MapNotify event has been seen. */
- while (!FRAME_VISIBLE_P (f))
- {
- /* Force processing of queued events. */
- x_sync (f);
-
- /* If on another desktop, the deiconify/map may be ignored and the
- frame never becomes visible. XMonad does this.
- Prevent an endless loop. */
- if (FRAME_ICONIFIED_P (f) && ++tries > 100)
- break;
-
- /* This hack is still in use at least for Cygwin. See
- http://lists.gnu.org/archive/html/emacs-devel/2013-12/msg00351.html.
-
- Machines that do polling rather than SIGIO have been
- observed to go into a busy-wait here. So we'll fake an
- alarm signal to let the handler know that there's something
- to be read. We used to raise a real alarm, but it seems
- that the handler isn't always enabled here. This is
- probably a bug. */
- if (input_polling_used ())
- {
- /* It could be confusing if a real alarm arrives while
- processing the fake one. Turn it off and let the
- handler reset it. */
- int old_poll_suppress_count = poll_suppress_count;
- poll_suppress_count = 1;
- poll_for_input_1 ();
- poll_suppress_count = old_poll_suppress_count;
- }
-
- if (XPending (FRAME_X_DISPLAY (f)))
- {
- XEvent xev;
- XNextEvent (FRAME_X_DISPLAY (f), &xev);
- x_dispatch_event (&xev, FRAME_X_DISPLAY (f));
- }
- }
}
}
@@ -12927,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,
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-07 03:16:22 +0000