summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/.gdbinit16
-rw-r--r--src/Makefile.in11
-rw-r--r--src/alloc.c130
-rw-r--r--src/buffer.c4
-rw-r--r--src/bytecode.c15
-rw-r--r--src/callint.c4
-rw-r--r--src/cmds.c5
-rw-r--r--src/coding.c2
-rw-r--r--src/data.c22
-rw-r--r--src/dispnew.c6
-rw-r--r--src/doprnt.c2
-rw-r--r--src/editfns.c42
-rw-r--r--src/emacs-module.c30
-rw-r--r--src/emacs.c11
-rw-r--r--src/eval.c73
-rw-r--r--src/fileio.c52
-rw-r--r--src/frame.c5
-rw-r--r--src/fringe.c5
-rw-r--r--src/gmalloc.c16
-rw-r--r--src/gtkutil.c25
-rw-r--r--src/json.c757
-rw-r--r--src/keyboard.c22
-rw-r--r--src/keyboard.h1
-rw-r--r--src/lastfile.c3
-rw-r--r--src/lisp.h219
-rw-r--r--src/lread.c34
-rw-r--r--src/menu.c96
-rw-r--r--src/menu.h1
-rw-r--r--src/msdos.c2
-rw-r--r--src/nsimage.m116
-rw-r--r--src/nsterm.h3
-rw-r--r--src/process.c70
-rw-r--r--src/ptr-bounds.h79
-rw-r--r--src/regex.c32
-rw-r--r--src/w32fns.c12
-rw-r--r--src/xdisp.c7
-rw-r--r--src/xfaces.c1
-rw-r--r--src/xfns.c12
-rw-r--r--src/xml.c37
-rw-r--r--src/xwidget.c17
40 files changed, 1637 insertions, 360 deletions
diff --git a/src/.gdbinit b/src/.gdbinit
index e22d03ea476..0eb2c73591f 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -1321,19 +1321,26 @@ if hasattr(gdb, 'printing'):
Lisp_Int0 = 2
Lisp_Int1 = 6 if USE_LSB_TAG else 3
- # Unpack the Lisp value from its containing structure, if necessary.
val = self.val
basic_type = gdb.types.get_basic_type (val.type)
+
+ # Unpack VAL from its containing structure, if necessary.
if (basic_type.code == gdb.TYPE_CODE_STRUCT
and gdb.types.has_field (basic_type, "i")):
val = val["i"]
+ # Convert VAL to a Python integer. Convert by hand, as this is
+ # simpler and works regardless of whether VAL is a pointer or
+ # integer. Also, val.cast (gdb.lookup.type ("EMACS_UINT"))
+ # would have problems with GDB 7.12.1; see
+ # <http://patchwork.sourceware.org/patch/11557/>.
+ ival = int (val)
+
# For nil, yield "XIL(0)", which is easier to read than "XIL(0x0)".
- if not val:
+ if not ival:
return "XIL(0)"
# Extract the integer representation of the value and its Lisp type.
- ival = int(val)
itype = ival >> (0 if USE_LSB_TAG else VALBITS)
itype = itype & ((1 << GCTYPEBITS) - 1)
@@ -1352,8 +1359,7 @@ if hasattr(gdb, 'printing'):
# integers even when Lisp_Object is an integer.
# Perhaps some day the pretty-printing could be fancier.
# Prefer the unsigned representation to negative values, converting
- # by hand as val.cast(gdb.lookup_type("EMACS_UINT") does not work in
- # GDB 7.12.1; see <http://patchwork.sourceware.org/patch/11557/>.
+ # by hand as val.cast does not work in GDB 7.12.1 as noted above.
if ival < 0:
ival = ival + (1 << EMACS_INT_WIDTH)
return "XIL(0x%x)" % ival
diff --git a/src/Makefile.in b/src/Makefile.in
index 9a8c9c85f04..b395627893d 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -312,6 +312,10 @@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@
LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@
LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@
+JSON_LIBS = @JSON_LIBS@
+JSON_CFLAGS = @JSON_CFLAGS@
+JSON_OBJ = @JSON_OBJ@
+
INTERVALS_H = dispextern.h intervals.h composite.h
GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
@@ -363,7 +367,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \
$(WEBKIT_CFLAGS) \
$(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \
$(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \
- $(LIBSYSTEMD_CFLAGS) \
+ $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \
$(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \
$(WERROR_CFLAGS)
ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS)
@@ -397,7 +401,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
thread.o systhread.o \
$(if $(HYBRID_MALLOC),sheap.o) \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
- $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ)
+ $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ)
obj = $(base_obj) $(NS_OBJC_OBJ)
## Object files used on some machine or other.
@@ -493,7 +497,8 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
$(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \
$(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
$(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \
- $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS)
+ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
+ $(JSON_LIBS)
## FORCE it so that admin/unidata can decide whether these files
## are up-to-date. Although since charprop depends on bootstrap-emacs,
diff --git a/src/alloc.c b/src/alloc.c
index 27c5ee2fe42..fb0f948474d 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -33,6 +33,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "dispextern.h"
#include "intervals.h"
+#include "ptr-bounds.h"
#include "puresize.h"
#include "sheap.h"
#include "systime.h"
@@ -502,38 +503,27 @@ pointer_align (void *ptr, int alignment)
return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
}
-/* Extract the pointer hidden within A, if A is not a symbol.
- If A is a symbol, extract the hidden pointer's offset from lispsym,
- converted to void *. */
+/* Extract the pointer hidden within O. Define this as a function, as
+ functions are cleaner and can be used in debuggers. Also, define
+ it as a macro if being compiled with GCC without optimization, for
+ performance in that case. macro_XPNTR is private to this section
+ of code. */
-#define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
- ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
-
-/* Extract the pointer hidden within A. */
-
-#define macro_XPNTR(a) \
- ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
- + (SYMBOLP (a) ? (char *) lispsym : NULL)))
-
-/* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
- functions, as functions are cleaner and can be used in debuggers.
- Also, define them as macros if being compiled with GCC without
- optimization, for performance in that case. The macro_* names are
- private to this section of code. */
+#define macro_XPNTR(o) \
+ ((void *) \
+ (SYMBOLP (o) \
+ ? ((char *) lispsym \
+ - ((EMACS_UINT) Lisp_Symbol << (USE_LSB_TAG ? 0 : VALBITS)) \
+ + XLI (o)) \
+ : (char *) XLP (o) - (XLI (o) & ~VALMASK)))
static ATTRIBUTE_UNUSED void *
-XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a)
-{
- return macro_XPNTR_OR_SYMBOL_OFFSET (a);
-}
-static ATTRIBUTE_UNUSED void *
XPNTR (Lisp_Object a)
{
return macro_XPNTR (a);
}
#if DEFINE_KEY_OPS_AS_MACROS
-# define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
# define XPNTR(a) macro_XPNTR (a)
#endif
@@ -1737,7 +1727,8 @@ static EMACS_INT total_string_bytes;
a pointer to the `u.data' member of its sdata structure; the
structure starts at a constant offset in front of that. */
-#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET))
+#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \
+ - SDATA_DATA_OFFSET))
#ifdef GC_CHECK_STRING_OVERRUN
@@ -1929,7 +1920,7 @@ allocate_string (void)
/* Every string on a free list should have NULL data pointer. */
s->u.s.data = NULL;
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = s;
+ string_free_list = ptr_bounds_clip (s, sizeof *s);
}
total_free_strings += STRING_BLOCK_SIZE;
@@ -2044,7 +2035,7 @@ allocate_string_data (struct Lisp_String *s,
MALLOC_UNBLOCK_INPUT;
- s->u.s.data = SDATA_DATA (data);
+ s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1);
#ifdef GC_CHECK_STRING_BYTES
SDATA_NBYTES (data) = nbytes;
#endif
@@ -2130,7 +2121,7 @@ sweep_strings (void)
/* Put the string on the free-list. */
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = s;
+ string_free_list = ptr_bounds_clip (s, sizeof *s);
++nfree;
}
}
@@ -2138,7 +2129,7 @@ sweep_strings (void)
{
/* S was on the free-list before. Put it there again. */
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = s;
+ string_free_list = ptr_bounds_clip (s, sizeof *s);
++nfree;
}
}
@@ -2234,9 +2225,9 @@ compact_small_strings (void)
nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
eassert (nbytes <= LARGE_STRING_BYTES);
- nbytes = SDATA_SIZE (nbytes);
+ ptrdiff_t size = SDATA_SIZE (nbytes);
sdata *from_end = (sdata *) ((char *) from
- + nbytes + GC_STRING_EXTRA);
+ + size + GC_STRING_EXTRA);
#ifdef GC_CHECK_STRING_OVERRUN
if (memcmp (string_overrun_cookie,
@@ -2250,22 +2241,23 @@ compact_small_strings (void)
{
/* If TB is full, proceed with the next sblock. */
sdata *to_end = (sdata *) ((char *) to
- + nbytes + GC_STRING_EXTRA);
+ + size + GC_STRING_EXTRA);
if (to_end > tb_end)
{
tb->next_free = to;
tb = tb->next;
tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
to = tb->data;
- to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
+ to_end = (sdata *) ((char *) to + size + GC_STRING_EXTRA);
}
/* Copy, and update the string's `data' pointer. */
if (from != to)
{
eassert (tb != b || to < from);
- memmove (to, from, nbytes + GC_STRING_EXTRA);
- to->string->u.s.data = SDATA_DATA (to);
+ memmove (to, from, size + GC_STRING_EXTRA);
+ to->string->u.s.data
+ = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1);
}
/* Advance past the sdata we copied to. */
@@ -2299,11 +2291,13 @@ string_overflow (void)
error ("Maximum string size exceeded");
}
-DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
+DEFUN ("make-string", Fmake_string, Smake_string, 2, 3, 0,
doc: /* Return a newly created string of length LENGTH, with INIT in each element.
LENGTH must be an integer.
-INIT must be an integer that represents a character. */)
- (Lisp_Object length, Lisp_Object init)
+INIT must be an integer that represents a character.
+If optional argument MULTIBYTE is non-nil, the result will be
+a multibyte string even if INIT is an ASCII character. */)
+ (Lisp_Object length, Lisp_Object init, Lisp_Object multibyte)
{
register Lisp_Object val;
int c;
@@ -2313,7 +2307,7 @@ INIT must be an integer that represents a character. */)
CHECK_CHARACTER (init);
c = XFASTINT (init);
- if (ASCII_CHAR_P (c))
+ if (ASCII_CHAR_P (c) && NILP (multibyte))
{
nbytes = XINT (length);
val = make_uninit_string (nbytes);
@@ -3046,6 +3040,7 @@ static EMACS_INT total_vector_slots, total_free_vector_slots;
static void
setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
{
+ v = ptr_bounds_clip (v, nbytes);
eassume (header_size <= nbytes);
ptrdiff_t nwords = (nbytes - header_size) / word_size;
XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords);
@@ -3315,15 +3310,14 @@ sweep_vectors (void)
static struct Lisp_Vector *
allocate_vectorlike (ptrdiff_t len)
{
- struct Lisp_Vector *p;
-
- MALLOC_BLOCK_INPUT;
-
if (len == 0)
- p = XVECTOR (zero_vector);
+ return XVECTOR (zero_vector);
else
{
size_t nbytes = header_size + len * word_size;
+ struct Lisp_Vector *p;
+
+ MALLOC_BLOCK_INPUT;
#ifdef DOUG_LEA_MALLOC
if (!mmap_lisp_allowed_p ())
@@ -3353,11 +3347,11 @@ allocate_vectorlike (ptrdiff_t len)
consing_since_gc += nbytes;
vector_cells_consed += len;
- }
- MALLOC_UNBLOCK_INPUT;
+ MALLOC_UNBLOCK_INPUT;
- return p;
+ return ptr_bounds_clip (p, nbytes);
+ }
}
@@ -3918,7 +3912,7 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args)
{
Lisp_Object result;
- result = Fmake_string (make_number (nargs), make_number (0));
+ result = Fmake_string (make_number (nargs), make_number (0), Qnil);
for (i = 0; i < nargs; i++)
{
SSET (result, i, XINT (args[i]));
@@ -4574,6 +4568,7 @@ live_string_holding (struct mem_node *m, void *p)
must not be on the free-list. */
if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0])
{
+ cp = ptr_bounds_copy (cp, b);
struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0];
if (s->u.s.data)
return make_lisp_ptr (s, Lisp_String);
@@ -4608,6 +4603,7 @@ live_cons_holding (struct mem_node *m, void *p)
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index))
{
+ cp = ptr_bounds_copy (cp, b);
struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0];
if (!EQ (s->u.s.car, Vdead))
return make_lisp_ptr (s, Lisp_Cons);
@@ -4643,6 +4639,7 @@ live_symbol_holding (struct mem_node *m, void *p)
&& (b != symbol_block
|| offset / sizeof b->symbols[0] < symbol_block_index))
{
+ cp = ptr_bounds_copy (cp, b);
struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0];
if (!EQ (s->u.s.function, Vdead))
return make_lisp_symbol (s);
@@ -4702,6 +4699,7 @@ live_misc_holding (struct mem_node *m, void *p)
&& (b != marker_block
|| offset / sizeof b->markers[0] < marker_block_index))
{
+ cp = ptr_bounds_copy (cp, b);
union Lisp_Misc *s = p = cp -= offset % sizeof b->markers[0];
if (s->u_any.type != Lisp_Misc_Free)
return make_lisp_ptr (s, Lisp_Misc);
@@ -5363,7 +5361,7 @@ pure_alloc (size_t size, int type)
pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
if (pure_bytes_used <= pure_size)
- return result;
+ return ptr_bounds_clip (result, size);
/* Don't allocate a large amount here,
because it might get mmap'd and then its address
@@ -5448,7 +5446,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
/* Check the remaining characters. */
if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
/* Found. */
- return non_lisp_beg + start;
+ return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1);
start += last_char_skip;
}
@@ -5604,7 +5602,7 @@ static Lisp_Object
purecopy (Lisp_Object obj)
{
if (INTEGERP (obj)
- || (! SYMBOLP (obj) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj)))
+ || (! SYMBOLP (obj) && PURE_P (XPNTR (obj)))
|| SUBRP (obj))
return obj; /* Already pure. */
@@ -5965,6 +5963,7 @@ garbage_collect_1 (void *end)
stack_copy = xrealloc (stack_copy, stack_size);
stack_copy_size = stack_size;
}
+ stack = ptr_bounds_set (stack, stack_size);
no_sanitize_memcpy (stack_copy, stack, stack_size);
}
}
@@ -6858,7 +6857,9 @@ sweep_conses (void)
for (pos = start; pos < stop; pos++)
{
- if (!CONS_MARKED_P (&cblk->conses[pos]))
+ struct Lisp_Cons *acons
+ = ptr_bounds_copy (&cblk->conses[pos], cblk);
+ if (!CONS_MARKED_P (acons))
{
this_free++;
cblk->conses[pos].u.s.u.chain = cons_free_list;
@@ -6868,7 +6869,7 @@ sweep_conses (void)
else
{
num_used++;
- CONS_UNMARK (&cblk->conses[pos]);
+ CONS_UNMARK (acons);
}
}
}
@@ -6911,17 +6912,20 @@ sweep_floats (void)
register int i;
int this_free = 0;
for (i = 0; i < lim; i++)
- if (!FLOAT_MARKED_P (&fblk->floats[i]))
- {
- this_free++;
- fblk->floats[i].u.chain = float_free_list;
- float_free_list = &fblk->floats[i];
- }
- else
- {
- num_used++;
- FLOAT_UNMARK (&fblk->floats[i]);
- }
+ {
+ struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk);
+ if (!FLOAT_MARKED_P (afloat))
+ {
+ this_free++;
+ fblk->floats[i].u.chain = float_free_list;
+ float_free_list = &fblk->floats[i];
+ }
+ else
+ {
+ num_used++;
+ FLOAT_UNMARK (afloat);
+ }
+ }
lim = FLOAT_BLOCK_SIZE;
/* If this block contains only free floats and we have already
seen more than two blocks worth of free floats then deallocate
diff --git a/src/buffer.c b/src/buffer.c
index c6f9eb28e25..12a467daae4 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -5134,7 +5134,9 @@ init_buffer_once (void)
XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx);
+ /* Make this one a permanent local. */
+ buffer_permanent_local_flags[idx++] = 1;
XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, ctl_arrow), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, fill_column), idx); ++idx;
diff --git a/src/bytecode.c b/src/bytecode.c
index 8746568f166..78207f776c1 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "character.h"
#include "buffer.h"
#include "keyboard.h"
+#include "ptr-bounds.h"
#include "syntax.h"
#include "window.h"
@@ -363,13 +364,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
unsigned char quitcounter = 1;
EMACS_INT stack_items = XFASTINT (maxdepth) + 1;
USE_SAFE_ALLOCA;
- Lisp_Object *stack_base;
- SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length);
- Lisp_Object *stack_lim = stack_base + stack_items;
+ void *alloc;
+ SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length);
+ ptrdiff_t item_bytes = stack_items * word_size;
+ Lisp_Object *stack_base = ptr_bounds_clip (alloc, item_bytes);
Lisp_Object *top = stack_base;
- memcpy (stack_lim, SDATA (bytestr), bytestr_length);
- void *void_stack_lim = stack_lim;
- unsigned char const *bytestr_data = void_stack_lim;
+ Lisp_Object *stack_lim = stack_base + stack_items;
+ unsigned char *bytestr_data = alloc;
+ bytestr_data = ptr_bounds_clip (bytestr_data + item_bytes, bytestr_length);
+ memcpy (bytestr_data, SDATA (bytestr), bytestr_length);
unsigned char const *pc = bytestr_data;
ptrdiff_t count = SPECPDL_INDEX ();
diff --git a/src/callint.c b/src/callint.c
index 5d88082e38d..df26e4abb51 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include "lisp.h"
+#include "ptr-bounds.h"
#include "character.h"
#include "buffer.h"
#include "keyboard.h"
@@ -494,6 +495,9 @@ invoke it. If KEYS is omitted or nil, the return value of
varies = (signed char *) (visargs + nargs);
memclear (args, nargs * (2 * word_size + 1));
+ args = ptr_bounds_clip (args, nargs * sizeof *args);
+ visargs = ptr_bounds_clip (visargs, nargs * sizeof *visargs);
+ varies = ptr_bounds_clip (varies, nargs * sizeof *varies);
if (!NILP (enable))
specbind (Qenable_recursive_minibuffers, Qt);
diff --git a/src/cmds.c b/src/cmds.c
index 1788f22fe57..6a7a0fa50a1 100644
--- a/src/cmds.c
+++ b/src/cmds.c
@@ -439,12 +439,13 @@ internal_self_insert (int c, EMACS_INT n)
int mc = ((NILP (BVAR (current_buffer, enable_multibyte_characters))
&& SINGLE_BYTE_CHAR_P (c))
? UNIBYTE_TO_CHAR (c) : c);
- Lisp_Object string = Fmake_string (make_number (n), make_number (mc));
+ Lisp_Object string = Fmake_string (make_number (n), make_number (mc),
+ Qnil);
if (spaces_to_insert)
{
tem = Fmake_string (make_number (spaces_to_insert),
- make_number (' '));
+ make_number (' '), Qnil);
string = concat2 (string, tem);
}
diff --git a/src/coding.c b/src/coding.c
index d790ad08ea9..1705838ffad 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -10236,7 +10236,7 @@ usage: (define-coding-system-internal ...) */)
ASET (attrs, coding_attr_ccl_encoder, val);
val = args[coding_arg_ccl_valids];
- valids = Fmake_string (make_number (256), make_number (0));
+ valids = Fmake_string (make_number (256), make_number (0), Qnil);
for (tail = val; CONSP (tail); tail = XCDR (tail))
{
int from, to;
diff --git a/src/data.c b/src/data.c
index d54c46d72bf..3c9152049b7 100644
--- a/src/data.c
+++ b/src/data.c
@@ -1852,7 +1852,7 @@ The function `default-value' gets the default value and `set-default' sets it.
}
if (SYMBOL_CONSTANT_P (variable))
- error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
+ xsignal1 (Qsetting_constant, variable);
if (!blv)
{
@@ -1915,8 +1915,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
}
if (sym->u.s.trapped_write == SYMBOL_NOWRITE)
- error ("Symbol %s may not be buffer-local",
- SDATA (SYMBOL_NAME (variable)));
+ xsignal1 (Qsetting_constant, variable);
if (blv ? blv->local_if_set
: (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
@@ -3069,6 +3068,22 @@ usage: (logxor &rest INTS-OR-MARKERS) */)
return arith_driver (Alogxor, nargs, args);
}
+DEFUN ("logcount", Flogcount, Slogcount, 1, 1, 0,
+ doc: /* Return population count of VALUE.
+This is the number of one bits in the two's complement representation
+of VALUE. If VALUE is negative, return the number of zero bits in the
+representation. */)
+ (Lisp_Object value)
+{
+ CHECK_NUMBER (value);
+ EMACS_INT v = XINT (value) < 0 ? -1 - XINT (value) : XINT (value);
+ return make_number (EMACS_UINT_WIDTH <= UINT_WIDTH
+ ? count_one_bits (v)
+ : EMACS_UINT_WIDTH <= ULONG_WIDTH
+ ? count_one_bits_l (v)
+ : count_one_bits_ll (v));
+}
+
static Lisp_Object
ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh)
{
@@ -3856,6 +3871,7 @@ syms_of_data (void)
defsubr (&Slogand);
defsubr (&Slogior);
defsubr (&Slogxor);
+ defsubr (&Slogcount);
defsubr (&Slsh);
defsubr (&Sash);
defsubr (&Sadd1);
diff --git a/src/dispnew.c b/src/dispnew.c
index b0fc5c31fa1..7fea867f660 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -25,6 +25,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <unistd.h>
#include "lisp.h"
+#include "ptr-bounds.h"
#include "termchar.h"
/* cm.h must come after dispextern.h on Windows. */
#include "dispextern.h"
@@ -4652,6 +4653,11 @@ scrolling (struct frame *frame)
unsigned *new_hash = old_hash + height;
int *draw_cost = (int *) (new_hash + height);
int *old_draw_cost = draw_cost + height;
+ old_hash = ptr_bounds_clip (old_hash, height * sizeof *old_hash);
+ new_hash = ptr_bounds_clip (new_hash, height * sizeof *new_hash);
+ draw_cost = ptr_bounds_clip (draw_cost, height * sizeof *draw_cost);
+ old_draw_cost = ptr_bounds_clip (old_draw_cost,
+ height * sizeof *old_draw_cost);
eassert (current_matrix);
diff --git a/src/doprnt.c b/src/doprnt.c
index 89d7e99deb4..d33c95f517b 100644
--- a/src/doprnt.c
+++ b/src/doprnt.c
@@ -503,7 +503,7 @@ esprintf (char *buf, char const *format, ...)
return nbytes;
}
-#if HAVE_MODULES || (defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT)
+#if defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT
/* Format to buffer *BUF of positive size *BUFSIZE, reallocating *BUF
and updating *BUFSIZE if the buffer is too small, and otherwise
diff --git a/src/editfns.c b/src/editfns.c
index f7c26b900a0..6ab26876a88 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -56,6 +56,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "intervals.h"
+#include "ptr-bounds.h"
#include "character.h"
#include "buffer.h"
#include "coding.h"
@@ -1257,10 +1258,10 @@ If POS is out of range, the value is nil. */)
if (NILP (pos))
{
pos_byte = PT_BYTE;
- XSETFASTINT (pos, PT);
+ if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
+ return Qnil;
}
-
- if (MARKERP (pos))
+ else if (MARKERP (pos))
{
pos_byte = marker_byte_position (pos);
if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
@@ -3718,7 +3719,7 @@ It returns the number of characters changed. */)
}
else
{
- string = Fmake_string (make_number (1), val);
+ string = Fmake_string (make_number (1), val, Qnil);
}
replace_range (pos, pos + len, string, 1, 0, 1, 0);
pos_byte += SBYTES (string);
@@ -4208,9 +4209,9 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1;
/* Allocate the info and discarded tables. */
- ptrdiff_t alloca_size;
- if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &alloca_size)
- || INT_ADD_WRAPV (formatlen, alloca_size, &alloca_size)
+ ptrdiff_t info_size, alloca_size;
+ if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size)
+ || INT_ADD_WRAPV (formatlen, info_size, &alloca_size)
|| SIZE_MAX < alloca_size)
memory_full (SIZE_MAX);
info = SAFE_ALLOCA (alloca_size);
@@ -4218,6 +4219,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
string was not copied into the output.
It is 2 if byte I was not the first byte of its character. */
char *discarded = (char *) &info[nspec_bound];
+ info = ptr_bounds_clip (info, info_size);
+ discarded = ptr_bounds_clip (discarded, formatlen);
memset (discarded, 0, formatlen);
/* Try to determine whether the result should be multibyte.
@@ -4623,6 +4626,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
/* Don't use sprintf here, as it might mishandle prec. */
sprintf_buf[0] = XINT (arg);
sprintf_bytes = prec != 0;
+ sprintf_buf[sprintf_bytes] = '\0';
}
else if (conversion == 'd' || conversion == 'i')
{
@@ -4722,11 +4726,19 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
char src0 = src[0];
int exponent_bytes = 0;
bool signedp = src0 == '-' || src0 == '+' || src0 == ' ';
- unsigned char after_sign = src[signedp];
- if (zero_flag && 0 <= char_hexdigit (after_sign))
+ int prefix_bytes = (signedp
+ + ((src[signedp] == '0'
+ && (src[signedp + 1] == 'x'
+ || src[signedp + 1] == 'X'))
+ ? 2 : 0));
+ if (zero_flag)
{
- leading_zeros += padding;
- padding = 0;
+ unsigned char after_prefix = src[prefix_bytes];
+ if (0 <= char_hexdigit (after_prefix))
+ {
+ leading_zeros += padding;
+ padding = 0;
+ }
}
if (excess_precision
@@ -4745,13 +4757,13 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
nchars += padding;
}
- *p = src0;
- src += signedp;
- p += signedp;
+ memcpy (p, src, prefix_bytes);
+ p += prefix_bytes;
+ src += prefix_bytes;
memset (p, '0', leading_zeros);
p += leading_zeros;
int significand_bytes
- = sprintf_bytes - signedp - exponent_bytes;
+ = sprintf_bytes - prefix_bytes - exponent_bytes;
memcpy (p, src, significand_bytes);
p += significand_bytes;
src += significand_bytes;
diff --git a/src/emacs-module.c b/src/emacs-module.c
index b351515c3bd..9a02e7d4821 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -36,6 +36,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <intprops.h>
#include <verify.h>
+/* Work around GCC bug 83162. */
+#if GNUC_PREREQ (4, 3, 0)
+# pragma GCC diagnostic ignored "-Wclobbered"
+#endif
+
/* We use different strategies for allocating the user-visible objects
(struct emacs_runtime, emacs_env, emacs_value), depending on
whether the user supplied the -module-assertions flag. If
@@ -915,9 +920,8 @@ static Lisp_Object ltv_mark;
static Lisp_Object
value_to_lisp_bits (emacs_value v)
{
- intptr_t i = (intptr_t) v;
if (plain_values || USE_LSB_TAG)
- return XIL (i);
+ return XPL (v);
/* With wide EMACS_INT and when tag bits are the most significant,
reassembling integers differs from reassembling pointers in two
@@ -926,6 +930,7 @@ value_to_lisp_bits (emacs_value v)
integer when restoring, but zero-extend pointers because that
makes TAG_PTR faster. */
+ intptr_t i = (intptr_t) v;
EMACS_UINT tag = i & (GCALIGNMENT - 1);
EMACS_UINT untagged = i - tag;
switch (tag)
@@ -989,13 +994,22 @@ value_to_lisp (emacs_value v)
static emacs_value
lisp_to_value_bits (Lisp_Object o)
{
- EMACS_UINT u = XLI (o);
+ if (plain_values || USE_LSB_TAG)
+ return XLP (o);
- /* Compress U into the space of a pointer, possibly losing information. */
- uintptr_t p = (plain_values || USE_LSB_TAG
- ? u
- : (INTEGERP (o) ? u << VALBITS : u & VALMASK) + XTYPE (o));
- return (emacs_value) p;
+ /* Compress O into the space of a pointer, possibly losing information. */
+ EMACS_UINT u = XLI (o);
+ if (INTEGERP (o))
+ {
+ uintptr_t i = (u << VALBITS) + XTYPE (o);
+ return (emacs_value) i;
+ }
+ else
+ {
+ char *p = XLP (o);
+ void *v = p - (u & ~VALMASK) + XTYPE (o);
+ return v;
+ }
}
/* Convert O to an emacs_value. Allocate storage if needed; this can
diff --git a/src/emacs.c b/src/emacs.c
index 0fe7d9113b4..9dd060fd3dd 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -83,6 +83,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "charset.h"
#include "composite.h"
#include "dispextern.h"
+#include "ptr-bounds.h"
#include "regex.h"
#include "sheap.h"
#include "syntax.h"
@@ -1262,6 +1263,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
running_asynch_code = 0;
init_random ();
+#if defined HAVE_JSON && !defined WINDOWSNT
+ init_json ();
+#endif
+
no_loadup
= argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args);
@@ -1542,9 +1547,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#endif
#endif /* HAVE_X_WINDOWS */
-#ifdef HAVE_LIBXML2
syms_of_xml ();
-#endif
#ifdef HAVE_LCMS2
syms_of_lcms2 ();
@@ -1610,6 +1613,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
syms_of_threads ();
syms_of_profiler ();
+#ifdef HAVE_JSON
+ syms_of_json ();
+#endif
+
keys_of_casefiddle ();
keys_of_cmds ();
keys_of_buffer ();
diff --git a/src/eval.c b/src/eval.c
index 272c627dc66..b774fd06139 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1416,6 +1416,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
}
}
+static Lisp_Object
+internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument)
+{
+ struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
+ if (c == NULL)
+ return Qcatch_all_memory_full;
+
+ if (sys_setjmp (c->jmp) == 0)
+ {
+ Lisp_Object val = function (argument);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+ else
+ {
+ eassert (handlerlist == c);
+ Lisp_Object val = c->val;
+ handlerlist = c->next;
+ Fsignal (Qno_catch, val);
+ }
+}
+
+/* Like a combination of internal_condition_case_1 and internal_catch.
+ Catches all signals and throws. Never exits nonlocally; returns
+ Qcatch_all_memory_full if no handler could be allocated. */
+
+Lisp_Object
+internal_catch_all (Lisp_Object (*function) (void *), void *argument,
+ Lisp_Object (*handler) (Lisp_Object))
+{
+ struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE);
+ if (c == NULL)
+ return Qcatch_all_memory_full;
+
+ if (sys_setjmp (c->jmp) == 0)
+ {
+ Lisp_Object val = internal_catch_all_1 (function, argument);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+ else
+ {
+ eassert (handlerlist == c);
+ Lisp_Object val = c->val;
+ handlerlist = c->next;
+ return handler (val);
+ }
+}
+
struct handler *
push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
{
@@ -1986,12 +2037,10 @@ it defines a macro. */)
if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef)))
return fundef;
- if (EQ (macro_only, Qmacro))
- {
- Lisp_Object kind = Fnth (make_number (4), fundef);
- if (! (EQ (kind, Qt) || EQ (kind, Qmacro)))
- return fundef;
- }
+ Lisp_Object kind = Fnth (make_number (4), fundef);
+ if (EQ (macro_only, Qmacro)
+ && !(EQ (kind, Qt) || EQ (kind, Qmacro)))
+ return fundef;
/* This is to make sure that loadup.el gives a clear picture
of what files are preloaded and when. */
@@ -2014,15 +2063,18 @@ it defines a macro. */)
The value saved here is to be restored into Vautoload_queue. */
record_unwind_protect (un_autoload, Vautoload_queue);
Vautoload_queue = Qt;
- /* If `macro_only', assume this autoload to be a "best-effort",
+ /* If `macro_only' is set and fundef isn't a macro, assume this autoload to
+ be a "best-effort" (e.g. to try and find a compiler macro),
so don't signal an error if autoloading fails. */
- Fload (Fcar (Fcdr (fundef)), macro_only, Qt, Qnil, Qt);
+ Lisp_Object ignore_errors
+ = (EQ (kind, Qt) || EQ (kind, Qmacro)) ? Qnil : macro_only;
+ Fload (Fcar (Fcdr (fundef)), ignore_errors, Qt, Qnil, Qt);
/* Once loading finishes, don't undo it. */
Vautoload_queue = Qt;
unbind_to (count, Qnil);
- if (NILP (funname))
+ if (NILP (funname) || !NILP (ignore_errors))
return Qnil;
else
{
@@ -4066,6 +4118,9 @@ alist of active lexical bindings. */);
inhibit_lisp_code = Qnil;
+ DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full");
+ Funintern (Qcatch_all_memory_full, Qnil);
+
defsubr (&Sor);
defsubr (&Sand);
defsubr (&Sif);
diff --git a/src/fileio.c b/src/fileio.c
index c6b454bd9bd..77ff7d8b6e7 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -96,6 +96,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <acl.h>
#include <allocator.h>
#include <careadlinkat.h>
+#include <fsusage.h>
#include <stat-time.h>
#include <tempname.h>
@@ -5786,6 +5787,52 @@ effect except for flushing STREAM's data. */)
return (set_binary_mode (fileno (fp), binmode) == O_BINARY) ? Qt : Qnil;
}
+#ifndef DOS_NT
+
+/* Yield a Lisp float as close as possible to BLOCKSIZE * BLOCKS, with
+ the result negated if NEGATE. */
+static Lisp_Object
+blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate)
+{
+ /* On typical platforms the following code is accurate to 53 bits,
+ which is close enough. BLOCKSIZE is invariably a power of 2, so
+ converting it to double does not lose information. */
+ double bs = blocksize;
+ return make_float (negate ? -bs * -blocks : bs * blocks);
+}
+
+DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
+ doc: /* Return storage information about the file system FILENAME is on.
+Value is a list of numbers (TOTAL FREE AVAIL), where TOTAL is the total
+storage of the file system, FREE is the free storage, and AVAIL is the
+storage available to a non-superuser. All 3 numbers are in bytes.
+If the underlying system call fails, value is nil. */)
+ (Lisp_Object filename)
+{
+ Lisp_Object encoded = ENCODE_FILE (Fexpand_file_name (filename, Qnil));
+
+ /* If the file name has special constructs in it,
+ call the corresponding file handler. */
+ Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info);
+ if (!NILP (handler))
+ {
+ Lisp_Object result = call2 (handler, Qfile_system_info, encoded);
+ if (CONSP (result) || NILP (result))
+ return result;
+ error ("Invalid handler in `file-name-handler-alist'");
+ }
+
+ struct fs_usage u;
+ if (get_fs_usage (SSDATA (encoded), NULL, &u) != 0)
+ return Qnil;
+ return list3 (blocks_to_bytes (u.fsu_blocksize, u.fsu_blocks, false),
+ blocks_to_bytes (u.fsu_blocksize, u.fsu_bfree, false),
+ blocks_to_bytes (u.fsu_blocksize, u.fsu_bavail,
+ u.fsu_bavail_top_bit_set));
+}
+
+#endif /* !DOS_NT */
+
void
init_fileio (void)
{
@@ -5856,6 +5903,7 @@ syms_of_fileio (void)
DEFSYM (Qwrite_region, "write-region");
DEFSYM (Qverify_visited_file_modtime, "verify-visited-file-modtime");
DEFSYM (Qset_visited_file_modtime, "set-visited-file-modtime");
+ DEFSYM (Qfile_system_info, "file-system-info");
/* The symbol bound to coding-system-for-read when
insert-file-contents is called for recovering a file. This is not
@@ -6136,6 +6184,10 @@ This includes interactive calls to `delete-file' and
defsubr (&Sset_binary_mode);
+#ifndef DOS_NT
+ defsubr (&Sfile_system_info);
+#endif
+
#ifdef HAVE_SYNC
defsubr (&Sunix_sync);
#endif
diff --git a/src/frame.c b/src/frame.c
index 5bafbeddcce..94ec9fbdc7d 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -35,6 +35,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
/* These help us bind and responding to switch-frame events. */
#include "keyboard.h"
+#include "ptr-bounds.h"
#include "frame.h"
#include "blockinput.h"
#include "termchar.h"
@@ -4812,6 +4813,8 @@ xrdb_get_resource (XrmDatabase rdb, Lisp_Object attribute, Lisp_Object class, Li
USE_SAFE_ALLOCA;
char *name_key = SAFE_ALLOCA (name_keysize + class_keysize);
char *class_key = name_key + name_keysize;
+ name_key = ptr_bounds_clip (name_key, name_keysize);
+ class_key = ptr_bounds_clip (class_key, class_keysize);
/* Start with emacs.FRAMENAME for the name (the specific one)
and with `Emacs' for the class key (the general one). */
@@ -4890,6 +4893,8 @@ x_get_resource_string (const char *attribute, const char *class)
ptrdiff_t class_keysize = sizeof (EMACS_CLASS) - 1 + strlen (class) + 2;
char *name_key = SAFE_ALLOCA (name_keysize + class_keysize);
char *class_key = name_key + name_keysize;
+ name_key = ptr_bounds_clip (name_key, name_keysize);
+ class_key = ptr_bounds_clip (class_key, class_keysize);
esprintf (name_key, "%s.%s", SSDATA (Vinvocation_name), attribute);
sprintf (class_key, "%s.%s", EMACS_CLASS, class);
diff --git a/src/fringe.c b/src/fringe.c
index 087ef33434d..a5581173743 100644
--- a/src/fringe.c
+++ b/src/fringe.c
@@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "frame.h"
+#include "ptr-bounds.h"
#include "window.h"
#include "dispextern.h"
#include "buffer.h"
@@ -1591,7 +1592,9 @@ If BITMAP already exists, the existing definition is replaced. */)
fb.dynamic = true;
xfb = xmalloc (sizeof fb + fb.height * BYTES_PER_BITMAP_ROW);
- fb.bits = b = (unsigned short *) (xfb + 1);
+ fb.bits = b = ((unsigned short *)
+ ptr_bounds_clip (xfb + 1, fb.height * BYTES_PER_BITMAP_ROW));
+ xfb = ptr_bounds_clip (xfb, sizeof *xfb);
memset (b, 0, fb.height);
j = 0;
diff --git a/src/gmalloc.c b/src/gmalloc.c
index a17d39c1eeb..99cb967e539 100644
--- a/src/gmalloc.c
+++ b/src/gmalloc.c
@@ -40,6 +40,8 @@ License along with this library. If not, see <https://www.gnu.org/licenses/>.
# include "lisp.h"
#endif
+#include "ptr-bounds.h"
+
#ifdef HAVE_MALLOC_H
# if GNUC_PREREQ (4, 2, 0)
# pragma GCC diagnostic ignored "-Wdeprecated-declarations"
@@ -201,7 +203,8 @@ extern size_t _bytes_free;
/* Internal versions of `malloc', `realloc', and `free'
used when these functions need to call each other.
- They are the same but don't call the hooks. */
+ They are the same but don't call the hooks
+ and don't bound the resulting pointers. */
extern void *_malloc_internal (size_t);
extern void *_realloc_internal (void *, size_t);
extern void _free_internal (void *);
@@ -558,7 +561,7 @@ malloc_initialize_1 (void)
_heapinfo[0].free.size = 0;
_heapinfo[0].free.next = _heapinfo[0].free.prev = 0;
_heapindex = 0;
- _heapbase = (char *) _heapinfo;
+ _heapbase = (char *) ptr_bounds_init (_heapinfo);
_heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info));
register_heapinfo ();
@@ -919,7 +922,8 @@ malloc (size_t size)
among multiple threads. We just leave it for compatibility with
glibc malloc (i.e., assignments to gmalloc_hook) for now. */
hook = gmalloc_hook;
- return (hook != NULL ? *hook : _malloc_internal) (size);
+ void *result = (hook ? hook : _malloc_internal) (size);
+ return ptr_bounds_clip (result, size);
}
#if !(defined (_LIBC) || defined (HYBRID_MALLOC))
@@ -997,6 +1001,7 @@ _free_internal_nolock (void *ptr)
if (ptr == NULL)
return;
+ ptr = ptr_bounds_init (ptr);
PROTECT_MALLOC_STATE (0);
@@ -1308,6 +1313,7 @@ _realloc_internal_nolock (void *ptr, size_t size)
else if (ptr == NULL)
return _malloc_internal_nolock (size);
+ ptr = ptr_bounds_init (ptr);
block = BLOCK (ptr);
PROTECT_MALLOC_STATE (0);
@@ -1430,7 +1436,8 @@ realloc (void *ptr, size_t size)
return NULL;
hook = grealloc_hook;
- return (hook != NULL ? *hook : _realloc_internal) (ptr, size);
+ void *result = (hook ? hook : _realloc_internal) (ptr, size);
+ return ptr_bounds_clip (result, size);
}
/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc.
@@ -1604,6 +1611,7 @@ aligned_alloc (size_t alignment, size_t size)
{
l->exact = result;
result = l->aligned = (char *) result + adj;
+ result = ptr_bounds_clip (result, size);
}
UNLOCK_ALIGNED_BLOCKS ();
if (l == NULL)
diff --git a/src/gtkutil.c b/src/gtkutil.c
index 2708e5f0f7c..c279f1d2bcd 100644
--- a/src/gtkutil.c
+++ b/src/gtkutil.c
@@ -1061,16 +1061,23 @@ static void
xg_set_widget_bg (struct frame *f, GtkWidget *w, unsigned long pixel)
{
#ifdef HAVE_GTK3
- GdkRGBA bg;
XColor xbg;
xbg.pixel = pixel;
if (XQueryColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), &xbg))
{
- bg.red = (double)xbg.red/65535.0;
- bg.green = (double)xbg.green/65535.0;
- bg.blue = (double)xbg.blue/65535.0;
- bg.alpha = 1.0;
- gtk_widget_override_background_color (w, GTK_STATE_FLAG_NORMAL, &bg);
+ const char format[] = "* { background-color: #%02x%02x%02x; }";
+ /* The format is always longer than the resulting string. */
+ char buffer[sizeof format];
+ int n = snprintf(buffer, sizeof buffer, format,
+ xbg.red >> 8, xbg.green >> 8, xbg.blue >> 8);
+ eassert (n > 0);
+ eassert (n < sizeof buffer);
+ GtkCssProvider *provider = gtk_css_provider_new ();
+ gtk_css_provider_load_from_data (provider, buffer, -1, NULL);
+ gtk_style_context_add_provider (gtk_widget_get_style_context(w),
+ GTK_STYLE_PROVIDER (provider),
+ GTK_STYLE_PROVIDER_PRIORITY_APPLICATION);
+ g_clear_object (&provider);
}
#else
GdkColor bg;
@@ -1234,9 +1241,11 @@ xg_create_frame_widgets (struct frame *f)
X and GTK+ drawing to a pure GTK+ build. */
gtk_widget_set_double_buffered (wfixed, FALSE);
+#if ! GTK_CHECK_VERSION (3, 22, 0)
gtk_window_set_wmclass (GTK_WINDOW (wtop),
SSDATA (Vx_resource_name),
SSDATA (Vx_resource_class));
+#endif
/* Add callback to do nothing on WM_DELETE_WINDOW. The default in
GTK is to destroy the widget. We want Emacs to do that instead. */
@@ -4099,8 +4108,10 @@ xg_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar,
if (int_gtk_range_get_value (GTK_RANGE (wscroll)) != value)
gtk_range_set_value (GTK_RANGE (wscroll), (gdouble)value);
+#if ! GTK_CHECK_VERSION (3, 18, 0)
else if (changed)
gtk_adjustment_changed (adj);
+#endif
xg_ignore_gtk_scrollbar = 0;
@@ -4137,7 +4148,9 @@ xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar,
gtk_adjustment_configure (adj, (gdouble) value, (gdouble) lower,
(gdouble) upper, (gdouble) step_increment,
(gdouble) page_increment, (gdouble) pagesize);
+#if ! GTK_CHECK_VERSION (3, 18, 0)
gtk_adjustment_changed (adj);
+#endif
unblock_input ();
}
}
diff --git a/src/json.c b/src/json.c
new file mode 100644
index 00000000000..7025ae165cd
--- /dev/null
+++ b/src/json.c
@@ -0,0 +1,757 @@
+/* JSON parsing and serialization.
+
+Copyright (C) 2017 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <errno.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <stdlib.h>
+
+#include <jansson.h>
+
+#include "lisp.h"
+#include "buffer.h"
+#include "coding.h"
+
+#ifdef WINDOWSNT
+# include <windows.h>
+# include "w32.h"
+
+DEF_DLL_FN (void, json_set_alloc_funcs,
+ (json_malloc_t malloc_fn, json_free_t free_fn));
+DEF_DLL_FN (void, json_delete, (json_t *json));
+DEF_DLL_FN (json_t *, json_array, (void));
+DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value));
+DEF_DLL_FN (size_t, json_array_size, (const json_t *array));
+DEF_DLL_FN (json_t *, json_object, (void));
+DEF_DLL_FN (int, json_object_set_new,
+ (json_t *object, const char *key, json_t *value));
+DEF_DLL_FN (json_t *, json_null, (void));
+DEF_DLL_FN (json_t *, json_true, (void));
+DEF_DLL_FN (json_t *, json_false, (void));
+DEF_DLL_FN (json_t *, json_integer, (json_int_t value));
+DEF_DLL_FN (json_t *, json_real, (double value));
+DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len));
+DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags));
+DEF_DLL_FN (int, json_dump_callback,
+ (const json_t *json, json_dump_callback_t callback, void *data,
+ size_t flags));
+DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer));
+DEF_DLL_FN (double, json_real_value, (const json_t *real));
+DEF_DLL_FN (const char *, json_string_value, (const json_t *string));
+DEF_DLL_FN (size_t, json_string_length, (const json_t *string));
+DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index));
+DEF_DLL_FN (size_t, json_object_size, (const json_t *object));
+DEF_DLL_FN (const char *, json_object_iter_key, (void *iter));
+DEF_DLL_FN (void *, json_object_iter, (json_t *object));
+DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter));
+DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key));
+DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter));
+DEF_DLL_FN (json_t *, json_loads,
+ (const char *input, size_t flags, json_error_t *error));
+DEF_DLL_FN (json_t *, json_load_callback,
+ (json_load_callback_t callback, void *data, size_t flags,
+ json_error_t *error));
+
+/* This is called by json_decref, which is an inline function. */
+void json_delete(json_t *json)
+{
+ fn_json_delete (json);
+}
+
+static bool json_initialized;
+
+static bool
+init_json_functions (void)
+{
+ HMODULE library = w32_delayed_load (Qjson);
+
+ if (!library)
+ return false;
+
+ LOAD_DLL_FN (library, json_set_alloc_funcs);
+ LOAD_DLL_FN (library, json_delete);
+ LOAD_DLL_FN (library, json_array);
+ LOAD_DLL_FN (library, json_array_append_new);
+ LOAD_DLL_FN (library, json_array_size);
+ LOAD_DLL_FN (library, json_object);
+ LOAD_DLL_FN (library, json_object_set_new);
+ LOAD_DLL_FN (library, json_null);
+ LOAD_DLL_FN (library, json_true);
+ LOAD_DLL_FN (library, json_false);
+ LOAD_DLL_FN (library, json_integer);
+ LOAD_DLL_FN (library, json_real);
+ LOAD_DLL_FN (library, json_stringn);
+ LOAD_DLL_FN (library, json_dumps);
+ LOAD_DLL_FN (library, json_dump_callback);
+ LOAD_DLL_FN (library, json_integer_value);
+ LOAD_DLL_FN (library, json_real_value);
+ LOAD_DLL_FN (library, json_string_value);
+ LOAD_DLL_FN (library, json_string_length);
+ LOAD_DLL_FN (library, json_array_get);
+ LOAD_DLL_FN (library, json_object_size);
+ LOAD_DLL_FN (library, json_object_iter_key);
+ LOAD_DLL_FN (library, json_object_iter);
+ LOAD_DLL_FN (library, json_object_iter_value);
+ LOAD_DLL_FN (library, json_object_key_to_iter);
+ LOAD_DLL_FN (library, json_object_iter_next);
+ LOAD_DLL_FN (library, json_loads);
+ LOAD_DLL_FN (library, json_load_callback);
+
+ init_json ();
+
+ return true;
+}
+
+#define json_set_alloc_funcs fn_json_set_alloc_funcs
+#define json_array fn_json_array
+#define json_array_append_new fn_json_array_append_new
+#define json_array_size fn_json_array_size
+#define json_object fn_json_object
+#define json_object_set_new fn_json_object_set_new
+#define json_null fn_json_null
+#define json_true fn_json_true
+#define json_false fn_json_false
+#define json_integer fn_json_integer
+#define json_real fn_json_real
+#define json_stringn fn_json_stringn
+#define json_dumps fn_json_dumps
+#define json_dump_callback fn_json_dump_callback
+#define json_integer_value fn_json_integer_value
+#define json_real_value fn_json_real_value
+#define json_string_value fn_json_string_value
+#define json_string_length fn_json_string_length
+#define json_array_get fn_json_array_get
+#define json_object_size fn_json_object_size
+#define json_object_iter_key fn_json_object_iter_key
+#define json_object_iter fn_json_object_iter
+#define json_object_iter_value fn_json_object_iter_value
+#define json_object_key_to_iter fn_json_object_key_to_iter
+#define json_object_iter_next fn_json_object_iter_next
+#define json_loads fn_json_loads
+#define json_load_callback fn_json_load_callback
+
+#endif /* WINDOWSNT */
+
+/* We install a custom allocator so that we can avoid objects larger
+ than PTRDIFF_MAX. Such objects wouldn’t play well with the rest of
+ Emacs’s codebase, which generally uses ptrdiff_t for sizes and
+ indices. The other functions in this file also generally assume
+ that size_t values never exceed PTRDIFF_MAX. */
+
+static void *
+json_malloc (size_t size)
+{
+ if (size > PTRDIFF_MAX)
+ {
+ errno = ENOMEM;
+ return NULL;
+ }
+ return malloc (size);
+}
+
+static void
+json_free (void *ptr)
+{
+ free (ptr);
+}
+
+void
+init_json (void)
+{
+ json_set_alloc_funcs (json_malloc, json_free);
+}
+
+/* Return whether STRING starts with PREFIX. */
+
+static bool
+json_has_prefix (const char *string, const char *prefix)
+{
+ size_t string_len = strlen (string);
+ size_t prefix_len = strlen (prefix);
+ return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0;
+}
+
+/* Return whether STRING ends with SUFFIX. */
+
+static bool
+json_has_suffix (const char *string, const char *suffix)
+{
+ size_t string_len = strlen (string);
+ size_t suffix_len = strlen (suffix);
+ return string_len >= suffix_len
+ && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0;
+}
+
+/* Create a multibyte Lisp string from the UTF-8 string in
+ [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not
+ contain a valid UTF-8 string, an unspecified string is
+ returned. */
+
+static Lisp_Object
+json_make_string (const char *data, ptrdiff_t size)
+{
+ return code_convert_string (make_specified_string (data, -1, size, false),
+ Qutf_8_unix, Qt, false, true, true);
+}
+
+/* Create a multibyte Lisp string from the null-terminated UTF-8
+ string beginning at DATA. If the string is not a valid UTF-8
+ string, an unspecified string is returned. */
+
+static Lisp_Object
+json_build_string (const char *data)
+{
+ return json_make_string (data, strlen (data));
+}
+
+/* Return a unibyte string containing the sequence of UTF-8 encoding
+ units of the UTF-8 representation of STRING. If STRING does not
+ represent a sequence of Unicode scalar values, return a string with
+ unspecified contents. */
+
+static Lisp_Object
+json_encode (Lisp_Object string)
+{
+ return code_convert_string (string, Qutf_8_unix, Qt, true, true, true);
+}
+
+static _Noreturn void
+json_out_of_memory (void)
+{
+ xsignal0 (Qjson_out_of_memory);
+}
+
+/* Signal a Lisp error corresponding to the JSON ERROR. */
+
+static _Noreturn void
+json_parse_error (const json_error_t *error)
+{
+ Lisp_Object symbol;
+ /* FIXME: Upstream Jansson should have a way to return error codes
+ without parsing the error messages. See
+ https://github.com/akheron/jansson/issues/352. */
+ if (json_has_suffix (error->text, "expected near end of file"))
+ symbol = Qjson_end_of_file;
+ else if (json_has_prefix (error->text, "end of file expected"))
+ symbol = Qjson_trailing_content;
+ else
+ symbol = Qjson_parse_error;
+ xsignal (symbol,
+ list5 (json_build_string (error->text),
+ json_build_string (error->source), make_natnum (error->line),
+ make_natnum (error->column), make_natnum (error->position)));
+}
+
+static void
+json_release_object (void *object)
+{
+ json_decref (object);
+}
+
+/* Signal an error if OBJECT is not a string, or if OBJECT contains
+ embedded null characters. */
+
+static void
+check_string_without_embedded_nulls (Lisp_Object object)
+{
+ CHECK_STRING (object);
+ CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
+ Qstring_without_embedded_nulls_p, object);
+}
+
+/* Signal an error of type `json-out-of-memory' if OBJECT is
+ NULL. */
+
+static json_t *
+json_check (json_t *object)
+{
+ if (object == NULL)
+ json_out_of_memory ();
+ return object;
+}
+
+static json_t *lisp_to_json (Lisp_Object);
+
+/* Convert a Lisp object to a toplevel JSON object (array or object).
+ This returns Lisp_Object so we can use unbind_to. The return value
+ is always nil. */
+
+static _GL_ARG_NONNULL ((2)) Lisp_Object
+lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
+{
+ if (VECTORP (lisp))
+ {
+ ptrdiff_t size = ASIZE (lisp);
+ *json = json_check (json_array ());
+ ptrdiff_t count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (json_release_object, json);
+ for (ptrdiff_t i = 0; i < size; ++i)
+ {
+ int status
+ = json_array_append_new (*json, lisp_to_json (AREF (lisp, i)));
+ if (status == -1)
+ json_out_of_memory ();
+ }
+ eassert (json_array_size (*json) == size);
+ clear_unwind_protect (count);
+ return unbind_to (count, Qnil);
+ }
+ else if (HASH_TABLE_P (lisp))
+ {
+ struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
+ *json = json_check (json_object ());
+ ptrdiff_t count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (json_release_object, *json);
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
+ if (!NILP (HASH_HASH (h, i)))
+ {
+ Lisp_Object key = json_encode (HASH_KEY (h, i));
+ /* We can’t specify the length, so the string must be
+ null-terminated. */
+ check_string_without_embedded_nulls (key);
+ int status = json_object_set_new (*json, SSDATA (key),
+ lisp_to_json (HASH_VALUE (h, i)));
+ if (status == -1)
+ json_out_of_memory ();
+ }
+ clear_unwind_protect (count);
+ return unbind_to (count, Qnil);
+ }
+ wrong_type_argument (Qjson_value_p, lisp);
+}
+
+/* Convert LISP to a toplevel JSON object (array or object). Signal
+ an error of type `wrong-type-argument' if LISP is not a vector or
+ hashtable. */
+
+static json_t *
+lisp_to_json_toplevel (Lisp_Object lisp)
+{
+ if (++lisp_eval_depth > max_lisp_eval_depth)
+ xsignal0 (Qjson_object_too_deep);
+ json_t *json;
+ lisp_to_json_toplevel_1 (lisp, &json);
+ --lisp_eval_depth;
+ return json;
+}
+
+/* Convert LISP to any JSON object. Signal an error of type
+ `wrong-type-argument' if the type of LISP can't be converted to a
+ JSON object. */
+
+static json_t *
+lisp_to_json (Lisp_Object lisp)
+{
+ if (EQ (lisp, QCnull))
+ return json_check (json_null ());
+ else if (EQ (lisp, QCfalse))
+ return json_check (json_false ());
+ else if (EQ (lisp, Qt))
+ return json_check (json_true ());
+ else if (INTEGERP (lisp))
+ {
+ CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp);
+ return json_check (json_integer (XINT (lisp)));
+ }
+ else if (FLOATP (lisp))
+ return json_check (json_real (XFLOAT_DATA (lisp)));
+ else if (STRINGP (lisp))
+ {
+ Lisp_Object encoded = json_encode (lisp);
+ ptrdiff_t size = SBYTES (encoded);
+ return json_check (json_stringn (SSDATA (encoded), size));
+ }
+
+ /* LISP now must be a vector or hashtable. */
+ return lisp_to_json_toplevel (lisp);
+}
+
+DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL,
+ doc: /* Return the JSON representation of OBJECT as a string.
+OBJECT must be a vector or hashtable, and its elements can recursively
+contain `:null', `:false', t, numbers, strings, or other vectors and
+hashtables. `:null', `:false', and t will be converted to JSON null,
+false, and true values, respectively. Vectors will be converted to
+JSON arrays, and hashtables to JSON objects. Hashtable keys must be
+strings without embedded null characters and must be unique within
+each object. */)
+ (Lisp_Object object)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+#ifdef WINDOWSNT
+ if (!json_initialized)
+ {
+ Lisp_Object status;
+ json_initialized = init_json_functions ();
+ status = json_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
+ }
+ if (!json_initialized)
+ {
+ message1 ("jansson library not found");
+ return Qnil;
+ }
+#endif
+
+ json_t *json = lisp_to_json_toplevel (object);
+ record_unwind_protect_ptr (json_release_object, json);
+
+ char *string = json_dumps (json, JSON_COMPACT);
+ if (string == NULL)
+ json_out_of_memory ();
+ record_unwind_protect_ptr (free, string);
+
+ return unbind_to (count, json_build_string (string));
+}
+
+struct json_buffer_and_size
+{
+ const char *buffer;
+ ptrdiff_t size;
+};
+
+static Lisp_Object
+json_insert (void *data)
+{
+ struct json_buffer_and_size *buffer_and_size = data;
+ /* FIXME: This should be possible without creating an intermediate
+ string object. */
+ Lisp_Object string
+ = json_make_string (buffer_and_size->buffer, buffer_and_size->size);
+ insert1 (string);
+ return Qnil;
+}
+
+struct json_insert_data
+{
+ /* nil if json_insert succeeded, otherwise the symbol
+ Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */
+ Lisp_Object error;
+};
+
+/* Callback for json_dump_callback that inserts the UTF-8 string in
+ [BUFFER, BUFFER + SIZE) into the current buffer.
+ If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string,
+ an unspecified string is inserted into the buffer. DATA must point
+ to a structure of type json_insert_data. This function may not
+ exit nonlocally. It catches all nonlocal exits and stores them in
+ data->error for reraising. */
+
+static int
+json_insert_callback (const char *buffer, size_t size, void *data)
+{
+ struct json_insert_data *d = data;
+ struct json_buffer_and_size buffer_and_size
+ = {.buffer = buffer, .size = size};
+ d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
+ return NILP (d->error) ? 0 : -1;
+}
+
+DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL,
+ doc: /* Insert the JSON representation of OBJECT before point.
+This is the same as (insert (json-serialize OBJECT)), but potentially
+faster. See the function `json-serialize' for allowed values of
+OBJECT. */)
+ (Lisp_Object object)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+#ifdef WINDOWSNT
+ if (!json_initialized)
+ {
+ Lisp_Object status;
+ json_initialized = init_json_functions ();
+ status = json_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
+ }
+ if (!json_initialized)
+ {
+ message1 ("jansson library not found");
+ return Qnil;
+ }
+#endif
+
+ json_t *json = lisp_to_json (object);
+ record_unwind_protect_ptr (json_release_object, json);
+
+ struct json_insert_data data;
+ int status
+ = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT);
+ if (status == -1)
+ {
+ if (CONSP (data.error))
+ xsignal (XCAR (data.error), XCDR (data.error));
+ else
+ json_out_of_memory ();
+ }
+
+ return unbind_to (count, Qnil);
+}
+
+/* Convert a JSON object to a Lisp object. */
+
+static _GL_ARG_NONNULL ((1)) Lisp_Object
+json_to_lisp (json_t *json)
+{
+ switch (json_typeof (json))
+ {
+ case JSON_NULL:
+ return QCnull;
+ case JSON_FALSE:
+ return QCfalse;
+ case JSON_TRUE:
+ return Qt;
+ case JSON_INTEGER:
+ /* Return an integer if possible, a floating-point number
+ otherwise. This loses precision for integers with large
+ magnitude; however, such integers tend to be nonportable
+ anyway because many JSON implementations use only 64-bit
+ floating-point numbers with 53 mantissa bits. See
+ https://tools.ietf.org/html/rfc7159#section-6 for some
+ discussion. */
+ return make_fixnum_or_float (json_integer_value (json));
+ case JSON_REAL:
+ return make_float (json_real_value (json));
+ case JSON_STRING:
+ return json_make_string (json_string_value (json),
+ json_string_length (json));
+ case JSON_ARRAY:
+ {
+ if (++lisp_eval_depth > max_lisp_eval_depth)
+ xsignal0 (Qjson_object_too_deep);
+ size_t size = json_array_size (json);
+ if (FIXNUM_OVERFLOW_P (size))
+ xsignal0 (Qoverflow_error);
+ Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound);
+ for (ptrdiff_t i = 0; i < size; ++i)
+ ASET (result, i,
+ json_to_lisp (json_array_get (json, i)));
+ --lisp_eval_depth;
+ return result;
+ }
+ case JSON_OBJECT:
+ {
+ if (++lisp_eval_depth > max_lisp_eval_depth)
+ xsignal0 (Qjson_object_too_deep);
+ size_t size = json_object_size (json);
+ if (FIXNUM_OVERFLOW_P (size))
+ xsignal0 (Qoverflow_error);
+ Lisp_Object result = CALLN (Fmake_hash_table, QCtest, Qequal,
+ QCsize, make_natnum (size));
+ struct Lisp_Hash_Table *h = XHASH_TABLE (result);
+ const char *key_str;
+ json_t *value;
+ json_object_foreach (json, key_str, value)
+ {
+ Lisp_Object key = json_build_string (key_str);
+ EMACS_UINT hash;
+ ptrdiff_t i = hash_lookup (h, key, &hash);
+ /* Keys in JSON objects are unique, so the key can’t be
+ present yet. */
+ eassert (i < 0);
+ hash_put (h, key, json_to_lisp (value), hash);
+ }
+ --lisp_eval_depth;
+ return result;
+ }
+ }
+ /* Can’t get here. */
+ emacs_abort ();
+}
+
+DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, 1, NULL,
+ doc: /* Parse the JSON STRING into a Lisp object.
+This is essentially the reverse operation of `json-serialize', which
+see. The returned object will be a vector or hashtable. Its elements
+will be `:null', `:false', t, numbers, strings, or further vectors and
+hashtables. If there are duplicate keys in an object, all but the
+last one are ignored. If STRING doesn't contain a valid JSON object,
+an error of type `json-parse-error' is signaled. */)
+ (Lisp_Object string)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+#ifdef WINDOWSNT
+ if (!json_initialized)
+ {
+ Lisp_Object status;
+ json_initialized = init_json_functions ();
+ status = json_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
+ }
+ if (!json_initialized)
+ {
+ message1 ("jansson library not found");
+ return Qnil;
+ }
+#endif
+
+ Lisp_Object encoded = json_encode (string);
+ check_string_without_embedded_nulls (encoded);
+
+ json_error_t error;
+ json_t *object = json_loads (SSDATA (encoded), 0, &error);
+ if (object == NULL)
+ json_parse_error (&error);
+
+ /* Avoid leaking the object in case of further errors. */
+ if (object != NULL)
+ record_unwind_protect_ptr (json_release_object, object);
+
+ return unbind_to (count, json_to_lisp (object));
+}
+
+struct json_read_buffer_data
+{
+ /* Byte position of position to read the next chunk from. */
+ ptrdiff_t point;
+};
+
+/* Callback for json_load_callback that reads from the current buffer.
+ DATA must point to a structure of type json_read_buffer_data.
+ data->point must point to the byte position to read from; after
+ reading, data->point is advanced accordingly. The buffer point
+ itself is ignored. This function may not exit nonlocally. */
+
+static size_t
+json_read_buffer_callback (void *buffer, size_t buflen, void *data)
+{
+ struct json_read_buffer_data *d = data;
+
+ /* First, parse from point to the gap or the end of the accessible
+ portion, whatever is closer. */
+ ptrdiff_t point = d->point;
+ ptrdiff_t end = BUFFER_CEILING_OF (point) + 1;
+ ptrdiff_t count = end - point;
+ if (buflen < count)
+ count = buflen;
+ memcpy (buffer, BYTE_POS_ADDR (point), count);
+ d->point += count;
+ return count;
+}
+
+DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
+ 0, 0, NULL,
+ doc: /* Read JSON object from current buffer starting at point.
+This is similar to `json-parse-string', which see. Move point after
+the end of the object if parsing was successful. On error, point is
+not moved. */)
+ (void)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+#ifdef WINDOWSNT
+ if (!json_initialized)
+ {
+ Lisp_Object status;
+ json_initialized = init_json_functions ();
+ status = json_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
+ }
+ if (!json_initialized)
+ {
+ message1 ("jansson library not found");
+ return Qnil;
+ }
+#endif
+
+ ptrdiff_t point = PT_BYTE;
+ struct json_read_buffer_data data = {.point = point};
+ json_error_t error;
+ json_t *object = json_load_callback (json_read_buffer_callback, &data,
+ JSON_DISABLE_EOF_CHECK, &error);
+
+ if (object == NULL)
+ json_parse_error (&error);
+
+ /* Avoid leaking the object in case of further errors. */
+ record_unwind_protect_ptr (json_release_object, object);
+
+ /* Convert and then move point only if everything succeeded. */
+ Lisp_Object lisp = json_to_lisp (object);
+
+ /* Adjust point by how much we just read. */
+ point += error.position;
+ SET_PT_BOTH (BYTE_TO_CHAR (point), point);
+
+ return unbind_to (count, lisp);
+}
+
+/* Simplified version of ‘define-error’ that works with pure
+ objects. */
+
+static void
+define_error (Lisp_Object name, const char *message, Lisp_Object parent)
+{
+ eassert (SYMBOLP (name));
+ eassert (SYMBOLP (parent));
+ Lisp_Object parent_conditions = Fget (parent, Qerror_conditions);
+ eassert (CONSP (parent_conditions));
+ eassert (!NILP (Fmemq (parent, parent_conditions)));
+ eassert (NILP (Fmemq (name, parent_conditions)));
+ Fput (name, Qerror_conditions, pure_cons (name, parent_conditions));
+ Fput (name, Qerror_message, build_pure_c_string (message));
+}
+
+void
+syms_of_json (void)
+{
+ DEFSYM (QCnull, ":null");
+ DEFSYM (QCfalse, ":false");
+
+ DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
+ DEFSYM (Qjson_value_p, "json-value-p");
+
+ DEFSYM (Qutf_8_unix, "utf-8-unix");
+
+ DEFSYM (Qjson_error, "json-error");
+ DEFSYM (Qjson_out_of_memory, "json-out-of-memory");
+ DEFSYM (Qjson_parse_error, "json-parse-error");
+ DEFSYM (Qjson_end_of_file, "json-end-of-file");
+ DEFSYM (Qjson_trailing_content, "json-trailing-content");
+ DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
+ define_error (Qjson_error, "generic JSON error", Qerror);
+ define_error (Qjson_out_of_memory,
+ "not enough memory for creating JSON object", Qjson_error);
+ define_error (Qjson_parse_error, "could not parse JSON stream",
+ Qjson_error);
+ define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error);
+ define_error (Qjson_trailing_content, "trailing content after JSON stream",
+ Qjson_parse_error);
+ define_error (Qjson_object_too_deep,
+ "object cyclic or Lisp evaluation too deep", Qjson_error);
+
+ DEFSYM (Qpure, "pure");
+ DEFSYM (Qside_effect_free, "side-effect-free");
+
+ DEFSYM (Qjson_serialize, "json-serialize");
+ DEFSYM (Qjson_parse_string, "json-parse-string");
+ Fput (Qjson_serialize, Qpure, Qt);
+ Fput (Qjson_serialize, Qside_effect_free, Qt);
+ Fput (Qjson_parse_string, Qpure, Qt);
+ Fput (Qjson_parse_string, Qside_effect_free, Qt);
+
+ defsubr (&Sjson_serialize);
+ defsubr (&Sjson_insert);
+ defsubr (&Sjson_parse_string);
+ defsubr (&Sjson_parse_buffer);
+}
diff --git a/src/keyboard.c b/src/keyboard.c
index 57757cf2112..375aa4f6067 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -43,6 +43,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "systime.h"
#include "atimer.h"
#include "process.h"
+#include "menu.h"
#include <errno.h>
#ifdef HAVE_PTHREAD
@@ -1365,6 +1366,7 @@ command_loop_1 (void)
Vthis_command_keys_shift_translated = Qnil;
/* Read next key sequence; i gets its length. */
+ raw_keybuf_count = 0;
i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
Qnil, 0, 1, 1, 0);
@@ -2809,6 +2811,9 @@ read_char (int commandflag, Lisp_Object map,
if (EQ (c, make_number (-2)))
return c;
+
+ if (CONSP (c) && EQ (XCAR (c), Qt))
+ c = XCDR (c);
}
non_reread:
@@ -8450,7 +8455,7 @@ read_char_x_menu_prompt (Lisp_Object map,
/* Display the menu and get the selection. */
Lisp_Object value;
- value = Fx_popup_menu (prev_event, get_keymap (map, 0, 1));
+ value = x_popup_menu_1 (prev_event, get_keymap (map, 0, 1));
if (CONSP (value))
{
Lisp_Object tem;
@@ -8860,6 +8865,11 @@ test_undefined (Lisp_Object binding)
&& EQ (Fcommand_remapping (binding, Qnil, Qnil), Qundefined)));
}
+void init_raw_keybuf_count (void)
+{
+ raw_keybuf_count = 0;
+}
+
/* Read a sequence of keys that ends with a non prefix character,
storing it in KEYBUF, a buffer of size BUFSIZE.
Prompt with PROMPT.
@@ -8916,7 +8926,6 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
ptrdiff_t keys_start;
Lisp_Object current_binding = Qnil;
- Lisp_Object first_event = Qnil;
/* Index of the first key that has no binding.
It is useless to try fkey.start larger than that. */
@@ -8971,7 +8980,11 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
/* List of events for which a fake prefix key has been generated. */
Lisp_Object fake_prefixed_keys = Qnil;
- raw_keybuf_count = 0;
+ /* raw_keybuf_count is now initialized in (most of) the callers of
+ read_key_sequence. This is so that in a recursive call (for
+ mouse menus) a spurious initialization doesn't erase the contents
+ of raw_keybuf created by the outer call. */
+ /* raw_keybuf_count = 0; */
last_nonmenu_event = Qnil;
@@ -9026,6 +9039,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
starting_buffer = current_buffer;
first_unbound = bufsize + 1;
+ Lisp_Object first_event = mock_input > 0 ? keybuf[0] : Qnil;
/* Build our list of keymaps.
If we recognize a function key and replace its escape sequence in
@@ -9343,6 +9357,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
&& BUFFERP (XWINDOW (window)->contents)
&& XBUFFER (XWINDOW (window)->contents) != current_buffer)
{
+ GROW_RAW_KEYBUF;
ASET (raw_keybuf, raw_keybuf_count, key);
raw_keybuf_count++;
keybuf[t] = key;
@@ -9837,6 +9852,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
cancel_hourglass ();
#endif
+ raw_keybuf_count = 0;
i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
prompt, ! NILP (dont_downcase_last),
! NILP (can_return_switch_frame), 0, 0);
diff --git a/src/keyboard.h b/src/keyboard.h
index 662d8e4a4f6..c232e778e21 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -438,6 +438,7 @@ extern unsigned int timers_run;
extern bool menu_separator_name_p (const char *);
extern bool parse_menu_item (Lisp_Object, int);
+extern void init_raw_keybuf_count (void);
extern KBOARD *allocate_kboard (Lisp_Object);
extern void delete_kboard (KBOARD *);
extern void not_single_kboard_state (KBOARD *);
diff --git a/src/lastfile.c b/src/lastfile.c
index 2901f148e17..13022792f25 100644
--- a/src/lastfile.c
+++ b/src/lastfile.c
@@ -49,9 +49,6 @@ char my_edata[] = "End of Emacs initialized data";
isn't always a separate section in NT executables). */
char my_endbss[1];
-/* The Alpha MSVC linker globally segregates all static and public bss
- data, so we must take both into account to determine the true extent
- of the bss area used by Emacs. */
static char _my_endbss[1];
char * my_endbss_static = _my_endbss;
diff --git a/src/lisp.h b/src/lisp.h
index 0daea640d85..eb31ba209a6 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -277,6 +277,18 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
error !;
#endif
+/* Lisp_Word is a scalar word suitable for holding a tagged pointer or
+ integer. Usually it is a pointer to a deliberately-incomplete type
+ 'union Lisp_X'. However, it is EMACS_INT when Lisp_Objects and
+ pointers differ in width. */
+
+#define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX)
+#if LISP_WORDS_ARE_POINTERS
+typedef union Lisp_X *Lisp_Word;
+#else
+typedef EMACS_INT Lisp_Word;
+#endif
+
/* Some operations are so commonly executed that they are implemented
as macros, not functions, because otherwise runtime performance would
suffer too much when compiling with GCC without optimization.
@@ -302,16 +314,37 @@ error !;
functions, once "gcc -Og" (new to GCC 4.8) works well enough for
Emacs developers. Maybe in the year 2020. See Bug#11935.
- Commentary for these macros can be found near their corresponding
- functions, below. */
-
-#if CHECK_LISP_OBJECT_TYPE
-# define lisp_h_XLI(o) ((o).i)
-# define lisp_h_XIL(i) ((Lisp_Object) { i })
+ For the macros that have corresponding functions (defined later),
+ see these functions for commentary. */
+
+/* Convert among the various Lisp-related types: I for EMACS_INT, L
+ for Lisp_Object, P for void *. */
+#if !CHECK_LISP_OBJECT_TYPE
+# if LISP_WORDS_ARE_POINTERS
+# define lisp_h_XLI(o) ((EMACS_INT) (o))
+# define lisp_h_XIL(i) ((Lisp_Object) (i))
+# define lisp_h_XLP(o) ((void *) (o))
+# define lisp_h_XPL(p) ((Lisp_Object) (p))
+# else
+# define lisp_h_XLI(o) (o)
+# define lisp_h_XIL(i) (i)
+# define lisp_h_XLP(o) ((void *) (uintptr_t) (o))
+# define lisp_h_XPL(p) ((Lisp_Object) (uintptr_t) (p))
+# endif
#else
-# define lisp_h_XLI(o) (o)
-# define lisp_h_XIL(i) (i)
+# if LISP_WORDS_ARE_POINTERS
+# define lisp_h_XLI(o) ((EMACS_INT) (o).i)
+# define lisp_h_XIL(i) ((Lisp_Object) {(Lisp_Word) (i)})
+# define lisp_h_XLP(o) ((void *) (o).i)
+# define lisp_h_XPL(p) lisp_h_XIL (p)
+# else
+# define lisp_h_XLI(o) ((o).i)
+# define lisp_h_XIL(i) ((Lisp_Object) {i})
+# define lisp_h_XLP(o) ((void *) (uintptr_t) (o).i)
+# define lisp_h_XPL(p) ((Lisp_Object) {(uintptr_t) (p)})
+# endif
#endif
+
#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) \
@@ -346,14 +379,21 @@ error !;
XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0))
# define lisp_h_XFASTINT(a) XINT (a)
# define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS)
-# define lisp_h_XSYMBOL(a) \
+# ifdef __CHKP__
+# define lisp_h_XSYMBOL(a) \
+ (eassert (SYMBOLP (a)), \
+ (struct Lisp_Symbol *) ((char *) XUNTAG (a, Lisp_Symbol) \
+ + (intptr_t) lispsym))
+# else
+ /* If !__CHKP__ this is equivalent, and is a bit faster as of GCC 7. */
+# define lisp_h_XSYMBOL(a) \
(eassert (SYMBOLP (a)), \
(struct Lisp_Symbol *) ((intptr_t) XLI (a) - Lisp_Symbol \
+ (char *) lispsym))
+# endif
# define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK))
# define lisp_h_XUNTAG(a, type) \
- __builtin_assume_aligned ((void *) (intptr_t) (XLI (a) - (type)), \
- GCALIGNMENT)
+ __builtin_assume_aligned ((char *) XLP (a) - (type), GCALIGNMENT)
#endif
/* When compiling via gcc -O0, define the key operations as macros, as
@@ -370,6 +410,8 @@ error !;
#if DEFINE_KEY_OPS_AS_MACROS
# define XLI(o) lisp_h_XLI (o)
# define XIL(i) lisp_h_XIL (i)
+# define XLP(o) lisp_h_XLP (o)
+# define XPL(p) lisp_h_XPL (p)
# 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)
@@ -416,9 +458,8 @@ error !;
#define case_Lisp_Int case Lisp_Int0: case Lisp_Int1
/* Idea stolen from GDB. Pedantic GCC complains about enum bitfields,
- MSVC doesn't support them, and xlc and Oracle Studio c99 complain
- vociferously about them. */
-#if (defined __STRICT_ANSI__ || defined _MSC_VER || defined __IBMC__ \
+ and xlc and Oracle Studio c99 complain vociferously about them. */
+#if (defined __STRICT_ANSI__ || defined __IBMC__ \
|| (defined __SUNPRO_C && __STDC__))
#define ENUM_BF(TYPE) unsigned int
#else
@@ -544,22 +585,24 @@ enum Lisp_Fwd_Type
your object -- this way, the same object could be used to represent
several disparate C structures. */
-#ifdef CHECK_LISP_OBJECT_TYPE
-typedef struct Lisp_Object { EMACS_INT i; } Lisp_Object;
+/* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a
+ Lisp_Word. However, if CHECK_LISP_OBJECT_TYPE, it is a wrapper
+ around Lisp_Word, to help catch thinkos like 'Lisp_Object x = 0;'.
-#define LISP_INITIALLY(i) {i}
+ LISP_INITIALLY (W) initializes a Lisp object with a tagged value
+ that is a Lisp_Word W. It can be used in a static initializer. */
-#undef CHECK_LISP_OBJECT_TYPE
+#ifdef CHECK_LISP_OBJECT_TYPE
+typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object;
+# define LISP_INITIALLY(w) {w}
+# undef CHECK_LISP_OBJECT_TYPE
enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true };
-#else /* CHECK_LISP_OBJECT_TYPE */
-
-/* If a struct type is not wanted, define Lisp_Object as just a number. */
-
-typedef EMACS_INT Lisp_Object;
-#define LISP_INITIALLY(i) (i)
+#else
+typedef Lisp_Word Lisp_Object;
+# define LISP_INITIALLY(w) (w)
enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false };
-#endif /* CHECK_LISP_OBJECT_TYPE */
+#endif
/* Forward declarations. */
@@ -591,8 +634,10 @@ extern double extract_float (Lisp_Object);
/* Low-level conversion and type checking. */
-/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
- At the machine level, these operations are no-ops. */
+/* Convert among various types use to implement Lisp_Object. At the
+ machine level, these operations may widen or narrow their arguments
+ if pointers differ in width from EMACS_INT; otherwise they are
+ no-ops. */
INLINE EMACS_INT
(XLI) (Lisp_Object o)
@@ -606,6 +651,18 @@ INLINE Lisp_Object
return lisp_h_XIL (i);
}
+INLINE void *
+(XLP) (Lisp_Object o)
+{
+ return lisp_h_XLP (o);
+}
+
+INLINE Lisp_Object
+(XPL) (void *p)
+{
+ return lisp_h_XPL (p);
+}
+
/* Extract A's type. */
INLINE enum Lisp_Type
@@ -633,8 +690,9 @@ INLINE void *
#if USE_LSB_TAG
return lisp_h_XUNTAG (a, type);
#else
- intptr_t i = USE_LSB_TAG ? XLI (a) - type : XLI (a) & VALMASK;
- return (void *) i;
+ EMACS_UINT utype = type;
+ char *p = XLP (a);
+ return p - (utype << (USE_LSB_TAG ? 0 : VALBITS));
#endif
}
@@ -745,35 +803,46 @@ verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0);
#define DEFUN_ARGS_8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)
-/* Yield a signed integer that contains TAG along with PTR.
+/* Typedefs useful for implementing TAG_PTR. untagged_ptr represents
+ a pointer before tagging, and Lisp_Word_tag contains a
+ possibly-shifted tag to be added to an untagged_ptr to convert it
+ to a Lisp_Word. */
+#if LISP_WORDS_ARE_POINTERS
+/* untagged_ptr is a pointer so that the compiler knows that TAG_PTR
+ yields a pointer; this can help with gcc -fcheck-pointer-bounds.
+ It is char * so that adding a tag uses simple machine addition. */
+typedef char *untagged_ptr;
+typedef uintptr_t Lisp_Word_tag;
+#else
+/* untagged_ptr is an unsigned integer instead of a pointer, so that
+ it can be added to the possibly-wider Lisp_Word_tag type without
+ losing information. */
+typedef uintptr_t untagged_ptr;
+typedef EMACS_UINT Lisp_Word_tag;
+#endif
- Sign-extend pointers when USE_LSB_TAG (this simplifies emacs-module.c),
- and zero-extend otherwise (that’s a bit faster here).
- Sign extension matters only when EMACS_INT is wider than a pointer. */
+/* An initializer for a Lisp_Object that contains TAG along with PTR. */
#define TAG_PTR(tag, ptr) \
- (USE_LSB_TAG \
- ? (intptr_t) (ptr) + (tag) \
- : (EMACS_INT) (((EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr)))
-
-/* Yield an integer that contains a symbol tag along with OFFSET.
- OFFSET should be the offset in bytes from 'lispsym' to the symbol. */
-#define TAG_SYMOFFSET(offset) TAG_PTR (Lisp_Symbol, offset)
-
-/* XLI_BUILTIN_LISPSYM (iQwhatever) is equivalent to
- XLI (builtin_lisp_symbol (Qwhatever)),
- except the former expands to an integer constant expression. */
-#define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym)
+ LISP_INITIALLY ((Lisp_Word) \
+ ((untagged_ptr) (ptr) \
+ + ((Lisp_Word_tag) (tag) << (USE_LSB_TAG ? 0 : VALBITS))))
/* LISPSYM_INITIALLY (Qfoo) is equivalent to Qfoo except it is
designed for use as an initializer, even for a constant initializer. */
-#define LISPSYM_INITIALLY(name) LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name))
+#define LISPSYM_INITIALLY(name) \
+ TAG_PTR (Lisp_Symbol, (char *) (intptr_t) ((i##name) * sizeof *lispsym))
/* Declare extern constants for Lisp symbols. These can be helpful
when using a debugger like GDB, on older platforms where the debug
- format does not represent C macros. */
-#define DEFINE_LISP_SYMBOL(name) \
- DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \
- DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name))
+ format does not represent C macros. However, they are unbounded
+ and would just be asking for trouble if checking pointer bounds. */
+#ifdef __CHKP__
+# define DEFINE_LISP_SYMBOL(name)
+#else
+# define DEFINE_LISP_SYMBOL(name) \
+ DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \
+ DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name))
+#endif
/* The index of the C-defined Lisp symbol SYM.
This can be used in a static initializer. */
@@ -837,6 +906,11 @@ INLINE struct Lisp_Symbol *
eassert (SYMBOLP (a));
intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol);
void *p = (char *) lispsym + i;
+# ifdef __CHKP__
+ /* Bypass pointer checking. Although this could be improved it is
+ probably not worth the trouble. */
+ p = __builtin___bnd_set_ptr_bounds (p, sizeof (struct Lisp_Symbol));
+# endif
return p;
#endif
}
@@ -844,7 +918,20 @@ INLINE struct Lisp_Symbol *
INLINE Lisp_Object
make_lisp_symbol (struct Lisp_Symbol *sym)
{
- Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym));
+#ifdef __CHKP__
+ /* Although '__builtin___bnd_narrow_ptr_bounds (sym, sym, sizeof *sym)'
+ should be more efficient, it runs afoul of GCC bug 83251
+ <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=83251>.
+ Also, attempting to call __builtin___bnd_chk_ptr_bounds (sym, sizeof *sym)
+ here seems to trigger a GCC bug, as yet undiagnosed. */
+ char *addr = __builtin___bnd_set_ptr_bounds (sym, sizeof *sym);
+ char *symoffset = addr - (intptr_t) lispsym;
+#else
+ /* If !__CHKP__, GCC 7 x86-64 generates faster code if lispsym is
+ cast to char * rather than to intptr_t. */
+ char *symoffset = (char *) ((char *) sym - (char *) lispsym);
+#endif
+ Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
eassert (XSYMBOL (a) == sym);
return a;
}
@@ -1062,7 +1149,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
INLINE Lisp_Object
make_lisp_ptr (void *ptr, enum Lisp_Type type)
{
- Lisp_Object a = XIL (TAG_PTR (type, ptr));
+ Lisp_Object a = TAG_PTR (type, ptr);
eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr);
return a;
}
@@ -1133,7 +1220,7 @@ XINTPTR (Lisp_Object a)
INLINE Lisp_Object
make_pointer_integer (void *p)
{
- Lisp_Object a = XIL (TAG_PTR (Lisp_Int0, p));
+ Lisp_Object a = TAG_PTR (Lisp_Int0, p);
eassert (INTEGERP (a) && XINTPTR (a) == p);
return a;
}
@@ -1645,8 +1732,10 @@ gc_aset (Lisp_Object array, ptrdiff_t idx, Lisp_Object val)
/* True, since Qnil's representation is zero. Every place in the code
that assumes Qnil is zero should verify (NIL_IS_ZERO), to make it easy
- to find such assumptions later if we change Qnil to be nonzero. */
-enum { NIL_IS_ZERO = XLI_BUILTIN_LISPSYM (iQnil) == 0 };
+ to find such assumptions later if we change Qnil to be nonzero.
+ Test iQnil and Lisp_Symbol instead of Qnil directly, since the latter
+ is not suitable for use in an integer constant expression. */
+enum { NIL_IS_ZERO = iQnil == 0 && Lisp_Symbol == 0 };
/* Clear the object addressed by P, with size NBYTES, so that all its
bytes are zero and all its Lisp values are nil. */
@@ -2960,23 +3049,12 @@ CHECK_NUMBER_CDR (Lisp_Object x)
/* This version of DEFUN declares a function prototype with the right
arguments, so we can catch errors with maxargs at compile-time. */
-#ifdef _MSC_VER
-#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \
- Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \
- static struct Lisp_Subr sname = \
- { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \
- | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \
- { (Lisp_Object (__cdecl *)(void))fnname }, \
- minargs, maxargs, lname, intspec, 0}; \
- Lisp_Object fnname
-#else /* not _MSC_VER */
#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \
static struct Lisp_Subr sname = \
{ { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \
{ .a ## maxargs = fnname }, \
minargs, maxargs, lname, intspec, 0}; \
Lisp_Object fnname
-#endif
/* defsubr (Sname);
is how we define the symbol for function `name' at start-up time. */
@@ -3464,6 +3542,12 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t);
extern void reset_image_types (void);
extern void syms_of_image (void);
+#ifdef HAVE_JSON
+/* Defined in json.c. */
+extern void init_json (void);
+extern void syms_of_json (void);
+#endif
+
/* Defined in insdel.c. */
extern void move_gap_both (ptrdiff_t, ptrdiff_t);
extern _Noreturn void buffer_overflow (void);
@@ -3887,6 +3971,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp
extern Lisp_Object internal_condition_case_n
(Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
+extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object));
extern struct handler *push_handler (Lisp_Object, enum handlertype);
extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
extern void specbind (Lisp_Object, Lisp_Object);
@@ -4422,9 +4507,9 @@ extern void syms_of_xterm (void);
extern char *x_get_keysym_name (int);
#endif /* HAVE_WINDOW_SYSTEM */
-#ifdef HAVE_LIBXML2
/* Defined in xml.c. */
extern void syms_of_xml (void);
+#ifdef HAVE_LIBXML2
extern void xml_cleanup_parser (void);
#endif
diff --git a/src/lread.c b/src/lread.c
index 597ff56c8f5..52897b4fccd 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -1003,14 +1003,11 @@ load_error_handler (Lisp_Object data)
return Qnil;
}
-static void
-load_warn_old_style_backquotes (Lisp_Object file)
+static _Noreturn void
+load_error_old_style_backquotes (void)
{
- if (!NILP (Vlread_old_style_backquotes))
- {
- AUTO_STRING (format, "Loading `%s': old-style backquotes detected!");
- CALLN (Fmessage, format, file);
- }
+ AUTO_STRING (format, "Loading `%s': old-style backquotes detected!");
+ xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name));
}
static void
@@ -1282,10 +1279,6 @@ Return t if the file exists and loads successfully. */)
version = -1;
- /* Check for the presence of old-style quotes and warn about them. */
- specbind (Qlread_old_style_backquotes, Qnil);
- record_unwind_protect (load_warn_old_style_backquotes, file);
-
/* Check for the presence of unescaped character literals and warn
about them. */
specbind (Qlread_unescaped_character_literals, Qnil);
@@ -2269,7 +2262,7 @@ read0 (Lisp_Object readcharfun)
return val;
xsignal1 (Qinvalid_read_syntax,
- Fmake_string (make_number (1), make_number (c)));
+ Fmake_string (make_number (1), make_number (c), Qnil));
}
/* Grow a read buffer BUF that contains OFFSET useful bytes of data,
@@ -3178,10 +3171,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
first_in_list exception (old-style can still be obtained via
"(\`" anyway). */
if (!new_backquote_flag && first_in_list && next_char == ' ')
- {
- Vlread_old_style_backquotes = Qt;
- goto default_label;
- }
+ load_error_old_style_backquotes ();
else
{
Lisp_Object value;
@@ -3232,10 +3222,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
return list2 (comma_type, value);
}
else
- {
- Vlread_old_style_backquotes = Qt;
- goto default_label;
- }
+ load_error_old_style_backquotes ();
}
case '?':
{
@@ -3423,7 +3410,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
row. */
FALLTHROUGH;
default:
- default_label:
if (c <= 040) goto retry;
if (c == NO_BREAK_SPACE)
goto retry;
@@ -4996,12 +4982,6 @@ variables, this must be set in the first line of a file. */);
doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
Veval_buffer_list = Qnil;
- DEFVAR_LISP ("lread--old-style-backquotes", Vlread_old_style_backquotes,
- doc: /* Set to non-nil when `read' encounters an old-style backquote.
-For internal use only. */);
- Vlread_old_style_backquotes = Qnil;
- DEFSYM (Qlread_old_style_backquotes, "lread--old-style-backquotes");
-
DEFVAR_LISP ("lread--unescaped-character-literals",
Vlread_unescaped_character_literals,
doc: /* List of deprecated unescaped character literals encountered by `read'.
diff --git a/src/menu.c b/src/menu.c
index d569b4b29b5..b40c2c04ce7 100644
--- a/src/menu.c
+++ b/src/menu.c
@@ -1112,51 +1112,8 @@ into menu items. */)
return Qnil;
}
-
-DEFUN ("x-popup-menu", Fx_popup_menu, Sx_popup_menu, 2, 2, 0,
- doc: /* Pop up a deck-of-cards menu and return user's selection.
-POSITION is a position specification. This is either a mouse button event
-or a list ((XOFFSET YOFFSET) WINDOW)
-where XOFFSET and YOFFSET are positions in pixels from the top left
-corner of WINDOW. (WINDOW may be a window or a frame object.)
-This controls the position of the top left of the menu as a whole.
-If POSITION is t, it means to use the current mouse position.
-
-MENU is a specifier for a menu. For the simplest case, MENU is a keymap.
-The menu items come from key bindings that have a menu string as well as
-a definition; actually, the "definition" in such a key binding looks like
-\(STRING . REAL-DEFINITION). To give the menu a title, put a string into
-the keymap as a top-level element.
-
-If REAL-DEFINITION is nil, that puts a nonselectable string in the menu.
-Otherwise, REAL-DEFINITION should be a valid key binding definition.
-
-You can also use a list of keymaps as MENU.
- Then each keymap makes a separate pane.
-
-When MENU is a keymap or a list of keymaps, the return value is the
-list of events corresponding to the user's choice. Note that
-`x-popup-menu' does not actually execute the command bound to that
-sequence of events.
-
-Alternatively, you can specify a menu of multiple panes
- with a list of the form (TITLE PANE1 PANE2...),
-where each pane is a list of form (TITLE ITEM1 ITEM2...).
-Each ITEM is normally a cons cell (STRING . VALUE);
-but a string can appear as an item--that makes a nonselectable line
-in the menu.
-With this form of menu, the return value is VALUE from the chosen item.
-
-If POSITION is nil, don't display the menu at all, just precalculate the
-cached information about equivalent key sequences.
-
-If the user gets rid of the menu without making a valid choice, for
-instance by clicking the mouse away from a valid choice or by typing
-keyboard input, then this normally results in a quit and
-`x-popup-menu' does not return. But if POSITION is a mouse button
-event (indicating that the user invoked the menu with the mouse) then
-no quit occurs and `x-popup-menu' returns nil. */)
- (Lisp_Object position, Lisp_Object menu)
+Lisp_Object
+x_popup_menu_1 (Lisp_Object position, Lisp_Object menu)
{
Lisp_Object keymap, tem, tem2;
int xpos = 0, ypos = 0;
@@ -1443,6 +1400,55 @@ no quit occurs and `x-popup-menu' returns nil. */)
return selection;
}
+DEFUN ("x-popup-menu", Fx_popup_menu, Sx_popup_menu, 2, 2, 0,
+ doc: /* Pop up a deck-of-cards menu and return user's selection.
+POSITION is a position specification. This is either a mouse button event
+or a list ((XOFFSET YOFFSET) WINDOW)
+where XOFFSET and YOFFSET are positions in pixels from the top left
+corner of WINDOW. (WINDOW may be a window or a frame object.)
+This controls the position of the top left of the menu as a whole.
+If POSITION is t, it means to use the current mouse position.
+
+MENU is a specifier for a menu. For the simplest case, MENU is a keymap.
+The menu items come from key bindings that have a menu string as well as
+a definition; actually, the "definition" in such a key binding looks like
+\(STRING . REAL-DEFINITION). To give the menu a title, put a string into
+the keymap as a top-level element.
+
+If REAL-DEFINITION is nil, that puts a nonselectable string in the menu.
+Otherwise, REAL-DEFINITION should be a valid key binding definition.
+
+You can also use a list of keymaps as MENU.
+ Then each keymap makes a separate pane.
+
+When MENU is a keymap or a list of keymaps, the return value is the
+list of events corresponding to the user's choice. Note that
+`x-popup-menu' does not actually execute the command bound to that
+sequence of events.
+
+Alternatively, you can specify a menu of multiple panes
+ with a list of the form (TITLE PANE1 PANE2...),
+where each pane is a list of form (TITLE ITEM1 ITEM2...).
+Each ITEM is normally a cons cell (STRING . VALUE);
+but a string can appear as an item--that makes a nonselectable line
+in the menu.
+With this form of menu, the return value is VALUE from the chosen item.
+
+If POSITION is nil, don't display the menu at all, just precalculate the
+cached information about equivalent key sequences.
+
+If the user gets rid of the menu without making a valid choice, for
+instance by clicking the mouse away from a valid choice or by typing
+keyboard input, then this normally results in a quit and
+`x-popup-menu' does not return. But if POSITION is a mouse button
+event (indicating that the user invoked the menu with the mouse) then
+no quit occurs and `x-popup-menu' returns nil. */)
+ (Lisp_Object position, Lisp_Object menu)
+{
+ init_raw_keybuf_count ();
+ return x_popup_menu_1 (position, menu);
+}
+
/* If F's terminal is not capable of displaying a popup dialog,
emulate it with a menu. */
diff --git a/src/menu.h b/src/menu.h
index 1469cc87d99..3335616338d 100644
--- a/src/menu.h
+++ b/src/menu.h
@@ -60,4 +60,5 @@ extern Lisp_Object ns_menu_show (struct frame *, int, int, int,
extern Lisp_Object tty_menu_show (struct frame *, int, int, int,
Lisp_Object, const char **);
extern ptrdiff_t menu_item_width (const unsigned char *);
+extern Lisp_Object x_popup_menu_1 (Lisp_Object position, Lisp_Object menu);
#endif /* MENU_H */
diff --git a/src/msdos.c b/src/msdos.c
index 43730ebedc3..f7c99f63fff 100644
--- a/src/msdos.c
+++ b/src/msdos.c
@@ -1791,7 +1791,7 @@ internal_terminal_init (void)
}
Vinitial_window_system = Qpc;
- Vwindow_system_version = make_number (26); /* RE Emacs version */
+ Vwindow_system_version = make_number (27); /* RE Emacs version */
tty->terminal->type = output_msdos_raw;
/* If Emacs was dumped on DOS/V machine, forget the stale VRAM
diff --git a/src/nsimage.m b/src/nsimage.m
index 9d45b063af1..52e3bae05f1 100644
--- a/src/nsimage.m
+++ b/src/nsimage.m
@@ -76,8 +76,9 @@ ns_load_image (struct frame *f, struct image *img,
{
EmacsImage *eImg = nil;
NSSize size;
- Lisp_Object lisp_index;
+ Lisp_Object lisp_index, lisp_rotation;
unsigned int index;
+ double rotation;
NSTRACE ("ns_load_image");
@@ -86,6 +87,9 @@ ns_load_image (struct frame *f, struct image *img,
lisp_index = Fplist_get (XCDR (img->spec), QCindex);
index = INTEGERP (lisp_index) ? XFASTINT (lisp_index) : 0;
+ lisp_rotation = Fplist_get (XCDR (img->spec), QCrotation);
+ rotation = NUMBERP (lisp_rotation) ? XFLOATINT (lisp_rotation) : 0;
+
if (STRINGP (spec_file))
{
eImg = [EmacsImage allocInitFromFile: spec_file];
@@ -113,6 +117,17 @@ ns_load_image (struct frame *f, struct image *img,
return 0;
}
+ img->lisp_data = [eImg getMetadata];
+
+ if (rotation != 0)
+ {
+ EmacsImage *temp = [eImg rotate:rotation];
+ [eImg release];
+ eImg = temp;
+ }
+
+ [eImg setSizeFromSpec:XCDR (img->spec)];
+
size = [eImg size];
img->width = size.width;
img->height = size.height;
@@ -120,7 +135,6 @@ ns_load_image (struct frame *f, struct image *img,
/* 4) set img->pixmap = emacsimage */
img->pixmap = eImg;
- img->lisp_data = [eImg getMetadata];
return 1;
}
@@ -510,4 +524,102 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
return YES;
}
+- (void)setSizeFromSpec: (Lisp_Object) spec
+{
+ NSSize size = [self size];
+ Lisp_Object value;
+ double scale = 1, aspect = size.width / size.height;
+ double width = -1, height = -1, max_width = -1, max_height = -1;
+
+ value = Fplist_get (spec, QCscale);
+ if (NUMBERP (value))
+ scale = XFLOATINT (value) ;
+
+ value = Fplist_get (spec, QCmax_width);
+ if (NUMBERP (value))
+ max_width = XFLOATINT (value);
+
+ value = Fplist_get (spec, QCmax_height);
+ if (NUMBERP (value))
+ max_height = XFLOATINT (value);
+
+ value = Fplist_get (spec, QCwidth);
+ if (NUMBERP (value))
+ {
+ width = XFLOATINT (value) * scale;
+ /* :width overrides :max-width. */
+ max_width = -1;
+ }
+
+ value = Fplist_get (spec, QCheight);
+ if (NUMBERP (value))
+ {
+ height = XFLOATINT (value) * scale;
+ /* :height overrides :max-height. */
+ max_height = -1;
+ }
+
+ if (width <= 0 && height <= 0)
+ {
+ width = size.width * scale;
+ height = size.height * scale;
+ }
+ else if (width > 0 && height <= 0)
+ height = width / aspect;
+ else if (height > 0 && width <= 0)
+ width = height * aspect;
+
+ if (max_width > 0 && width > max_width)
+ {
+ width = max_width;
+ height = max_width / aspect;
+ }
+
+ if (max_height > 0 && height > max_height)
+ {
+ height = max_height;
+ width = max_height * aspect;
+ }
+
+ [self setSize:NSMakeSize(width, height)];
+}
+
+- (instancetype)rotate: (double)rotation
+{
+ EmacsImage *new_image;
+ NSPoint new_origin;
+ NSSize new_size, size = [self size];
+ NSRect rect = { NSZeroPoint, [self size] };
+
+ /* Create a bezier path of the outline of the image and do the
+ * rotation on it. */
+ NSBezierPath *bounds_path = [NSBezierPath bezierPathWithRect:rect];
+ NSAffineTransform *transform = [NSAffineTransform transform];
+ [transform rotateByDegrees: rotation * -1];
+ [bounds_path transformUsingAffineTransform:transform];
+
+ /* Now we can find out how large the rotated image needs to be. */
+ new_size = [bounds_path bounds].size;
+ new_image = [[EmacsImage alloc] initWithSize:new_size];
+
+ new_origin = NSMakePoint((new_size.width - size.width)/2,
+ (new_size.height - size.height)/2);
+
+ [new_image lockFocus];
+
+ /* Create the final transform. */
+ transform = [NSAffineTransform transform];
+ [transform translateXBy:new_size.width/2 yBy:new_size.height/2];
+ [transform rotateByDegrees: rotation * -1];
+ [transform translateXBy:-new_size.width/2 yBy:-new_size.height/2];
+
+ [transform concat];
+ [self drawAtPoint:new_origin fromRect:NSZeroRect
+ operation:NSCompositingOperationCopy fraction:1];
+
+ [new_image unlockFocus];
+
+ return new_image;
+}
+
@end
diff --git a/src/nsterm.h b/src/nsterm.h
index de96e0dbcbf..c81bf5fb63d 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -646,6 +646,8 @@ typedef id instancetype;
- (NSColor *)stippleMask;
- (Lisp_Object)getMetadata;
- (BOOL)setFrame: (unsigned int) index;
+- (void)setSizeFromSpec: (Lisp_Object) spec;
+- (instancetype)rotate: (double)rotation;
@end
@@ -1306,6 +1308,7 @@ extern char gnustep_base_version[]; /* version tracking */
#define NSWindowStyleMaskUtilityWindow NSUtilityWindowMask
#define NSAlertStyleCritical NSCriticalAlertStyle
#define NSControlSizeRegular NSRegularControlSize
+#define NSCompositingOperationCopy NSCompositeCopy
/* And adds NSWindowStyleMask. */
#ifdef __OBJC__
diff --git a/src/process.c b/src/process.c
index fc46e743328..3a8bcfb3fcf 100644
--- a/src/process.c
+++ b/src/process.c
@@ -3835,7 +3835,6 @@ usage: (make-network-process &rest ARGS) */)
Lisp_Object contact;
struct Lisp_Process *p;
const char *portstring UNINIT;
- ptrdiff_t portstringlen ATTRIBUTE_UNUSED;
char portbuf[INT_BUFSIZE_BOUND (EMACS_INT)];
#ifdef HAVE_LOCAL_SOCKETS
struct sockaddr_un address_un;
@@ -3982,6 +3981,8 @@ usage: (make-network-process &rest ARGS) */)
if (!NILP (host))
{
+ ptrdiff_t portstringlen ATTRIBUTE_UNUSED;
+
/* SERVICE can either be a string or int.
Convert to a C string for later use by getaddrinfo. */
if (EQ (service, Qt))
@@ -4000,37 +4001,38 @@ usage: (make-network-process &rest ARGS) */)
portstring = SSDATA (service);
portstringlen = SBYTES (service);
}
- }
#ifdef HAVE_GETADDRINFO_A
- if (!NILP (host) && !NILP (Fplist_get (contact, QCnowait)))
- {
- ptrdiff_t hostlen = SBYTES (host);
- struct req
- {
- struct gaicb gaicb;
- struct addrinfo hints;
- char str[FLEXIBLE_ARRAY_MEMBER];
- } *req = xmalloc (FLEXSIZEOF (struct req, str,
- hostlen + 1 + portstringlen + 1));
- dns_request = &req->gaicb;
- dns_request->ar_name = req->str;
- dns_request->ar_service = req->str + hostlen + 1;
- dns_request->ar_request = &req->hints;
- dns_request->ar_result = NULL;
- memset (&req->hints, 0, sizeof req->hints);
- req->hints.ai_family = family;
- req->hints.ai_socktype = socktype;
- strcpy (req->str, SSDATA (host));
- strcpy (req->str + hostlen + 1, portstring);
-
- int ret = getaddrinfo_a (GAI_NOWAIT, &dns_request, 1, NULL);
- if (ret)
- error ("%s/%s getaddrinfo_a error %d", SSDATA (host), portstring, ret);
-
- goto open_socket;
- }
+ if (!NILP (Fplist_get (contact, QCnowait)))
+ {
+ ptrdiff_t hostlen = SBYTES (host);
+ struct req
+ {
+ struct gaicb gaicb;
+ struct addrinfo hints;
+ char str[FLEXIBLE_ARRAY_MEMBER];
+ } *req = xmalloc (FLEXSIZEOF (struct req, str,
+ hostlen + 1 + portstringlen + 1));
+ dns_request = &req->gaicb;
+ dns_request->ar_name = req->str;
+ dns_request->ar_service = req->str + hostlen + 1;
+ dns_request->ar_request = &req->hints;
+ dns_request->ar_result = NULL;
+ memset (&req->hints, 0, sizeof req->hints);
+ req->hints.ai_family = family;
+ req->hints.ai_socktype = socktype;
+ strcpy (req->str, SSDATA (host));
+ strcpy (req->str + hostlen + 1, portstring);
+
+ int ret = getaddrinfo_a (GAI_NOWAIT, &dns_request, 1, NULL);
+ if (ret)
+ error ("%s/%s getaddrinfo_a error %d",
+ SSDATA (host), portstring, ret);
+
+ goto open_socket;
+ }
#endif /* HAVE_GETADDRINFO_A */
+ }
/* If we have a host, use getaddrinfo to resolve both host and service.
Otherwise, use getservbyname to lookup the service. */
@@ -5625,16 +5627,6 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
}
else if (nread == -1 && would_block (errno))
;
-#ifdef WINDOWSNT
- /* FIXME: Is this special case still needed? */
- /* Note that we cannot distinguish between no input
- available now and a closed pipe.
- With luck, a closed pipe will be accompanied by
- subprocess termination and SIGCHLD. */
- else if (nread == 0 && !NETCONN_P (proc) && !SERIALCONN_P (proc)
- && !PIPECONN_P (proc))
- ;
-#endif
#ifdef HAVE_PTYS
/* On some OSs with ptys, when the process on one end of
a pty exits, the other end gets an error reading with
diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h
new file mode 100644
index 00000000000..76740da3d33
--- /dev/null
+++ b/src/ptr-bounds.h
@@ -0,0 +1,79 @@
+/* Pointer bounds checking for GNU Emacs
+
+Copyright 2017 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+/* Pointer bounds checking is a no-op unless running on hardware
+ supporting Intel MPX (Intel Skylake or better). Also, it requires
+ GCC 5 and Linux kernel 3.19, or later. Configure with
+ CFLAGS='-fcheck-pointer-bounds -mmpx', perhaps with
+ -fchkp-first-field-has-own-bounds thrown in.
+
+ Although pointer bounds checking can help during debugging, it is
+ disabled by default because it hurts performance significantly.
+ The checking does not detect all pointer errors. For example, a
+ dumped Emacs might not detect a bounds violation of a pointer that
+ was created before Emacs was dumped. */
+
+#ifndef PTR_BOUNDS_H
+#define PTR_BOUNDS_H
+
+#include <stddef.h>
+
+/* When not checking pointer bounds, the following macros simply
+ return their first argument. These macros return either void *, or
+ the same type as their first argument. */
+
+INLINE_HEADER_BEGIN
+
+/* Return a copy of P, with bounds narrowed to [P, P + N). */
+#ifdef __CHKP__
+INLINE void *
+ptr_bounds_clip (void const *p, size_t n)
+{
+ return __builtin___bnd_narrow_ptr_bounds (p, p, n);
+}
+#else
+# define ptr_bounds_clip(p, n) ((void) (size_t) {n}, p)
+#endif
+
+/* Return a copy of P, but with the bounds of Q. */
+#ifdef __CHKP__
+# define ptr_bounds_copy(p, q) __builtin___bnd_copy_ptr_bounds (p, q)
+#else
+# define ptr_bounds_copy(p, q) ((void) (void const *) {q}, p)
+#endif
+
+/* Return a copy of P, but with infinite bounds.
+ This is a loophole in pointer bounds checking. */
+#ifdef __CHKP__
+# define ptr_bounds_init(p) __builtin___bnd_init_ptr_bounds (p)
+#else
+# define ptr_bounds_init(p) (p)
+#endif
+
+/* Return a copy of P, but with bounds [P, P + N).
+ This is a loophole in pointer bounds checking. */
+#ifdef __CHKP__
+# define ptr_bounds_set(p, n) __builtin___bnd_set_ptr_bounds (p, n)
+#else
+# define ptr_bounds_set(p, n) ((void) (size_t) {n}, p)
+#endif
+
+INLINE_HEADER_END
+
+#endif /* PTR_BOUNDS_H */
diff --git a/src/regex.c b/src/regex.c
index 330f2f78a84..d3d910daaa3 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -519,13 +519,7 @@ ptrdiff_t emacs_re_safe_alloca = MAX_ALLOCA;
#endif
/* Type of source-pattern and string chars. */
-#ifdef _MSC_VER
-typedef unsigned char re_char;
-typedef const re_char const_re_char;
-#else
typedef const unsigned char re_char;
-typedef re_char const_re_char;
-#endif
typedef char boolean;
@@ -2403,7 +2397,7 @@ do { \
} while (0)
static reg_errcode_t
-regex_compile (const_re_char *pattern, size_t size,
+regex_compile (re_char *pattern, size_t size,
#ifdef emacs
# define syntax RE_SYNTAX_EMACS
bool posix_backtracking,
@@ -3728,7 +3722,7 @@ insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2, unsigned cha
least one character before the ^. */
static boolean
-at_begline_loc_p (const_re_char *pattern, const_re_char *p, reg_syntax_t syntax)
+at_begline_loc_p (re_char *pattern, re_char *p, reg_syntax_t syntax)
{
re_char *prev = p - 2;
boolean odd_backslashes;
@@ -3769,7 +3763,7 @@ at_begline_loc_p (const_re_char *pattern, const_re_char *p, reg_syntax_t syntax)
at least one character after the $, i.e., `P < PEND'. */
static boolean
-at_endline_loc_p (const_re_char *p, const_re_char *pend, reg_syntax_t syntax)
+at_endline_loc_p (re_char *p, re_char *pend, reg_syntax_t syntax)
{
re_char *next = p;
boolean next_backslash = *next == '\\';
@@ -3813,7 +3807,7 @@ group_in_compile_stack (compile_stack_type compile_stack, regnum_t regnum)
Return -1 if fastmap was not updated accurately. */
static int
-analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
+analyze_first (re_char *p, re_char *pend, char *fastmap,
const int multibyte)
{
int j, k;
@@ -4555,7 +4549,7 @@ static int bcmp_translate (re_char *s1, re_char *s2,
/* If the operation is a match against one or more chars,
return a pointer to the next operation, else return NULL. */
static re_char *
-skip_one_char (const_re_char *p)
+skip_one_char (re_char *p)
{
switch (*p++)
{
@@ -4597,7 +4591,7 @@ skip_one_char (const_re_char *p)
/* Jump over non-matching operations. */
static re_char *
-skip_noops (const_re_char *p, const_re_char *pend)
+skip_noops (re_char *p, re_char *pend)
{
int mcnt;
while (p < pend)
@@ -4628,7 +4622,7 @@ skip_noops (const_re_char *p, const_re_char *pend)
character (i.e. without any translations). UNIBYTE denotes whether c is
unibyte or multibyte character. */
static bool
-execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte)
+execute_charset (re_char **pp, unsigned c, unsigned corig, bool unibyte)
{
re_char *p = *pp, *rtp = NULL;
bool not = (re_opcode_t) *p == charset_not;
@@ -4692,8 +4686,8 @@ execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte)
/* Non-zero if "p1 matches something" implies "p2 fails". */
static int
-mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
- const_re_char *p2)
+mutually_exclusive_p (struct re_pattern_buffer *bufp, re_char *p1,
+ re_char *p2)
{
re_opcode_t op2;
const boolean multibyte = RE_MULTIBYTE_P (bufp);
@@ -4931,8 +4925,8 @@ WEAK_ALIAS (__re_match_2, re_match_2)
/* This is a separate function so that we can force an alloca cleanup
afterwards. */
static regoff_t
-re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
- size_t size1, const_re_char *string2, size_t size2,
+re_match_2_internal (struct re_pattern_buffer *bufp, re_char *string1,
+ size_t size1, re_char *string2, size_t size2,
ssize_t pos, struct re_registers *regs, ssize_t stop)
{
/* General temporaries. */
@@ -6222,10 +6216,10 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
bytes; nonzero otherwise. */
static int
-bcmp_translate (const_re_char *s1, const_re_char *s2, register ssize_t len,
+bcmp_translate (re_char *s1, re_char *s2, ssize_t len,
RE_TRANSLATE_TYPE translate, const int target_multibyte)
{
- register re_char *p1 = s1, *p2 = s2;
+ re_char *p1 = s1, *p2 = s2;
re_char *p1_end = s1 + len;
re_char *p2_end = s2 + len;
diff --git a/src/w32fns.c b/src/w32fns.c
index b81cd70e0a7..18098a4cf84 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -9343,6 +9343,17 @@ If the underlying system call fails, value is nil. */)
filename = Fexpand_file_name (filename, Qnil);
encoded = ENCODE_FILE (filename);
+ /* If the file name has special constructs in it,
+ call the corresponding file handler. */
+ Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info);
+ if (!NILP (handler))
+ {
+ value = call2 (handler, Qfile_system_info, encoded);
+ if (CONSP (value) || NILP (value))
+ return value;
+ error ("Invalid handler in `file-name-handler-alist'");
+ }
+
value = Qnil;
/* Determining the required information on Windows turns out, sadly,
@@ -10413,6 +10424,7 @@ syms_of_w32fns (void)
DEFSYM (Qserif, "serif");
DEFSYM (Qzlib, "zlib");
DEFSYM (Qlcms2, "lcms2");
+ DEFSYM (Qjson, "json");
Fput (Qundefined_color, Qerror_conditions,
listn (CONSTYPE_PURE, 2, Qundefined_color, Qerror));
diff --git a/src/xdisp.c b/src/xdisp.c
index 0a37013c560..3791d982b28 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -12323,7 +12323,7 @@ build_desired_tool_bar_string (struct frame *f)
/* Reuse f->desired_tool_bar_string, if possible. */
if (size < size_needed || NILP (f->desired_tool_bar_string))
fset_desired_tool_bar_string
- (f, Fmake_string (make_number (size_needed), make_number (' ')));
+ (f, Fmake_string (make_number (size_needed), make_number (' '), Qnil));
else
{
AUTO_LIST4 (props, Qdisplay, Qnil, Qmenu_item, Qnil);
@@ -23884,7 +23884,8 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string,
if (field_width > len)
{
field_width -= len;
- lisp_string = Fmake_string (make_number (field_width), make_number (' '));
+ lisp_string = Fmake_string (make_number (field_width), make_number (' '),
+ Qnil);
if (!NILP (props))
Fadd_text_properties (make_number (0), make_number (field_width),
props, lisp_string);
@@ -31891,7 +31892,7 @@ x_draw_bottom_divider (struct window *w)
int x1 = WINDOW_RIGHT_EDGE_X (w);
int y0 = WINDOW_BOTTOM_EDGE_Y (w) - WINDOW_BOTTOM_DIVIDER_WIDTH (w);
int y1 = WINDOW_BOTTOM_EDGE_Y (w);
- struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : false;
+ struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : NULL;
/* If W is vertically combined and has a sibling below, don't draw
over any right divider. */
diff --git a/src/xfaces.c b/src/xfaces.c
index b309c161278..b594e576f50 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -4487,6 +4487,7 @@ lookup_basic_face (struct frame *f, int face_id)
case MOUSE_FACE_ID: name = Qmouse; break;
case MENU_FACE_ID: name = Qmenu; break;
case WINDOW_DIVIDER_FACE_ID: name = Qwindow_divider; break;
+ case VERTICAL_BORDER_FACE_ID: name = Qvertical_border; break;
case WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID: name = Qwindow_divider_first_pixel; break;
case WINDOW_DIVIDER_LAST_PIXEL_FACE_ID: name = Qwindow_divider_last_pixel; break;
case INTERNAL_BORDER_FACE_ID: name = Qinternal_border; break;
diff --git a/src/xfns.c b/src/xfns.c
index 044f14876e3..ac8315caba8 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -215,8 +215,9 @@ x_real_pos_and_offsets (struct frame *f,
int win_x = 0, win_y = 0, outer_x = 0, outer_y = 0;
int real_x = 0, real_y = 0;
bool had_errors = false;
- Window win = (FRAME_PARENT_FRAME (f)
- ? FRAME_X_WINDOW (FRAME_PARENT_FRAME (f))
+ struct frame *parent_frame = FRAME_PARENT_FRAME (f);
+ Window win = (parent_frame
+ ? FRAME_X_WINDOW (parent_frame)
: f->output_data.x->parent_desc);
struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
long max_len = 400;
@@ -355,8 +356,8 @@ x_real_pos_and_offsets (struct frame *f,
outer_geom_cookie = xcb_get_geometry (xcb_conn,
FRAME_OUTER_WINDOW (f));
- if ((dpyinfo->root_window == f->output_data.x->parent_desc)
- && !FRAME_PARENT_FRAME (f))
+ if (!parent_frame
+ && dpyinfo->root_window == f->output_data.x->parent_desc)
/* Try _NET_FRAME_EXTENTS if our parent is the root window. */
prop_cookie = xcb_get_property (xcb_conn, 0, win,
dpyinfo->Xatom_net_frame_extents,
@@ -470,8 +471,7 @@ x_real_pos_and_offsets (struct frame *f,
#endif
}
- if ((dpyinfo->root_window == f->output_data.x->parent_desc)
- && !FRAME_PARENT_FRAME (f))
+ if (!parent_frame && dpyinfo->root_window == f->output_data.x->parent_desc)
{
/* Try _NET_FRAME_EXTENTS if our parent is the root window. */
#ifdef USE_XCB
diff --git a/src/xml.c b/src/xml.c
index d087a34a5e0..7afaa63c421 100644
--- a/src/xml.c
+++ b/src/xml.c
@@ -18,15 +18,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
+#include "lisp.h"
+#include "buffer.h"
+
#ifdef HAVE_LIBXML2
#include <libxml/tree.h>
#include <libxml/parser.h>
#include <libxml/HTMLparser.h>
-#include "lisp.h"
-#include "buffer.h"
-
#ifdef WINDOWSNT
@@ -291,16 +291,43 @@ If DISCARD-COMMENTS is non-nil, all HTML comments are discarded. */)
return parse_region (start, end, base_url, discard_comments, false);
return Qnil;
}
+#endif /* HAVE_LIBXML2 */
+
+DEFUN ("libxml-available-p", Flibxml_available_p, Slibxml_available_p, 0, 0, 0,
+ doc: /* Return t if libxml2 support is available in this instance of Emacs.*/)
+ (void)
+{
+#ifdef HAVE_LIBXML2
+# ifdef WINDOWSNT
+ Lisp_Object found = Fassq (Qlibxml2, Vlibrary_cache);
+ if (CONSP (found))
+ return XCDR (found);
+ else
+ {
+ Lisp_Object status;
+ status = init_libxml2_functions () ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qlibxml2, status), Vlibrary_cache);
+ return status;
+ }
+# else
+ return Qt;
+# endif /* WINDOWSNT */
+#else
+ return Qnil;
+#endif /* HAVE_LIBXML2 */
+}
+
/***********************************************************************
Initialization
***********************************************************************/
void
syms_of_xml (void)
{
+#ifdef HAVE_LIBXML2
defsubr (&Slibxml_parse_html_region);
defsubr (&Slibxml_parse_xml_region);
+#endif
+ defsubr (&Slibxml_available_p);
}
-
-#endif /* HAVE_LIBXML2 */
diff --git a/src/xwidget.c b/src/xwidget.c
index a0c9e034775..c7f0594728c 100644
--- a/src/xwidget.c
+++ b/src/xwidget.c
@@ -392,8 +392,7 @@ webkit_javascript_finished_cb (GObject *webview,
/* FIXME: This might lead to disaster if LISP_CALLBACK’s object
was garbage collected before now. See the FIXME in
Fxwidget_webkit_execute_script. */
- store_xwidget_js_callback_event (xw, XIL ((intptr_t) lisp_callback),
- lisp_value);
+ store_xwidget_js_callback_event (xw, XPL (lisp_callback), lisp_value);
}
@@ -585,22 +584,20 @@ x_draw_xwidget_glyph_string (struct glyph_string *s)
xwidget on screen. Moving and clipping is done here. Also view
initialization. */
struct xwidget *xww = s->xwidget;
- struct xwidget_view *xv;
+ struct xwidget_view *xv = xwidget_view_lookup (xww, s->w);
int clip_right;
int clip_bottom;
int clip_top;
int clip_left;
- /* FIXME: The result of this call is discarded.
- What if the lookup fails? */
- xwidget_view_lookup (xww, s->w);
-
int x = s->x;
int y = s->y + (s->height / 2) - (xww->height / 2);
/* Do initialization here in the display loop because there is no
- other time to know things like window placement etc. */
- xv = xwidget_init_view (xww, s, x, y);
+ other time to know things like window placement etc. Do not
+ create a new view if we have found one that is usable. */
+ if (!xv)
+ xv = xwidget_init_view (xww, s, x, y);
int text_area_x, text_area_y, text_area_width, text_area_height;
@@ -725,7 +722,7 @@ argument procedure FUN.*/)
/* FIXME: This hack might lead to disaster if FUN is garbage
collected before store_xwidget_js_callback_event makes it visible
to Lisp again. See the FIXME in webkit_javascript_finished_cb. */
- gpointer callback_arg = (gpointer) (intptr_t) XLI (fun);
+ gpointer callback_arg = XLP (fun);
/* JavaScript execution happens asynchronously. If an elisp
callback function is provided we pass it to the C callback
View Lorry Controller Status