diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/.gdbinit | 22 | ||||
| -rw-r--r-- | src/Makefile.in | 20 | ||||
| -rw-r--r-- | src/alloc.c | 130 | ||||
| -rw-r--r-- | src/buffer.c | 4 | ||||
| -rw-r--r-- | src/bytecode.c | 15 | ||||
| -rw-r--r-- | src/callint.c | 300 | ||||
| -rw-r--r-- | src/character.c | 26 | ||||
| -rw-r--r-- | src/character.h | 2 | ||||
| -rw-r--r-- | src/cmds.c | 5 | ||||
| -rw-r--r-- | src/coding.c | 31 | ||||
| -rw-r--r-- | src/coding.h | 27 | ||||
| -rw-r--r-- | src/data.c | 22 | ||||
| -rw-r--r-- | src/decompress.c | 29 | ||||
| -rw-r--r-- | src/dispextern.h | 9 | ||||
| -rw-r--r-- | src/dispnew.c | 11 | ||||
| -rw-r--r-- | src/doprnt.c | 2 | ||||
| -rw-r--r-- | src/editfns.c | 45 | ||||
| -rw-r--r-- | src/emacs-module.c | 42 | ||||
| -rw-r--r-- | src/emacs.c | 20 | ||||
| -rw-r--r-- | src/eval.c | 73 | ||||
| -rw-r--r-- | src/fileio.c | 98 | ||||
| -rw-r--r-- | src/fns.c | 1 | ||||
| -rw-r--r-- | src/frame.c | 64 | ||||
| -rw-r--r-- | src/frame.h | 7 | ||||
| -rw-r--r-- | src/fringe.c | 5 | ||||
| -rw-r--r-- | src/gmalloc.c | 16 | ||||
| -rw-r--r-- | src/gtkutil.c | 39 | ||||
| -rw-r--r-- | src/json.c | 920 | ||||
| -rw-r--r-- | src/keyboard.c | 386 | ||||
| -rw-r--r-- | src/keyboard.h | 1 | ||||
| -rw-r--r-- | src/kqueue.c | 2 | ||||
| -rw-r--r-- | src/lastfile.c | 3 | ||||
| -rw-r--r-- | src/lisp.h | 231 | ||||
| -rw-r--r-- | src/lread.c | 145 | ||||
| -rw-r--r-- | src/macfont.m | 2 | ||||
| -rw-r--r-- | src/menu.c | 96 | ||||
| -rw-r--r-- | src/menu.h | 1 | ||||
| -rw-r--r-- | src/msdos.c | 2 | ||||
| -rw-r--r-- | src/nsfns.m | 32 | ||||
| -rw-r--r-- | src/nsimage.m | 116 | ||||
| -rw-r--r-- | src/nsmenu.m | 10 | ||||
| -rw-r--r-- | src/nsselect.m | 8 | ||||
| -rw-r--r-- | src/nsterm.h | 10 | ||||
| -rw-r--r-- | src/nsterm.m | 224 | ||||
| -rw-r--r-- | src/print.c | 5 | ||||
| -rw-r--r-- | src/process.c | 78 | ||||
| -rw-r--r-- | src/ptr-bounds.h | 79 | ||||
| -rw-r--r-- | src/regex.c | 37 | ||||
| -rw-r--r-- | src/regex.h | 9 | ||||
| -rw-r--r-- | src/syntax.c | 26 | ||||
| -rw-r--r-- | src/sysdep.c | 2 | ||||
| -rw-r--r-- | src/syssignal.h | 1 | ||||
| -rw-r--r-- | src/systhread.c | 18 | ||||
| -rw-r--r-- | src/systhread.h | 1 | ||||
| -rw-r--r-- | src/thread.c | 8 | ||||
| -rw-r--r-- | src/thread.h | 1 | ||||
| -rw-r--r-- | src/w32cygwinx.c | 140 | ||||
| -rw-r--r-- | src/w32fns.c | 232 | ||||
| -rw-r--r-- | src/w32term.c | 4 | ||||
| -rw-r--r-- | src/w32term.h | 2 | ||||
| -rw-r--r-- | src/xdisp.c | 47 | ||||
| -rw-r--r-- | src/xfaces.c | 6 | ||||
| -rw-r--r-- | src/xfns.c | 269 | ||||
| -rw-r--r-- | src/xml.c | 37 | ||||
| -rw-r--r-- | src/xterm.c | 19 | ||||
| -rw-r--r-- | src/xterm.h | 2 | ||||
| -rw-r--r-- | src/xwidget.c | 17 |
67 files changed, 3007 insertions, 1287 deletions
diff --git a/src/.gdbinit b/src/.gdbinit index db7185bc450..a5411e66d56 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -49,7 +49,7 @@ define xgetptr else set $bugfix = $arg0 end - set $ptr = $bugfix & VALMASK + set $ptr = (EMACS_INT) $bugfix & VALMASK end define xgetint @@ -58,7 +58,7 @@ define xgetint else set $bugfix = $arg0 end - set $int = $bugfix << (USE_LSB_TAG ? 0 : INTTYPEBITS) >> INTTYPEBITS + set $int = (EMACS_INT) $bugfix << (USE_LSB_TAG ? 0 : INTTYPEBITS) >> INTTYPEBITS end define xgettype @@ -67,7 +67,7 @@ define xgettype else set $bugfix = $arg0 end - set $type = (enum Lisp_Type) (USE_LSB_TAG ? $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS) + set $type = (enum Lisp_Type) (USE_LSB_TAG ? (EMACS_INT) $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS) end define xgetsym @@ -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 15ca1667d65..c84859cb4f1 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -277,11 +277,12 @@ NS_OBJC_OBJ=@NS_OBJC_OBJ@ ## Used only for GNUstep. GNU_OBJC_CFLAGS=$(patsubst -specs=%-hardened-cc1,,@GNU_OBJC_CFLAGS@) ## w32fns.o w32menu.c w32reg.o fringe.o fontset.o w32font.o w32term.o -## w32xfns.o w32select.o image.o w32uniscribe.o if HAVE_W32, else -## empty. +## w32xfns.o w32select.o image.o w32uniscribe.o w32cygwinx.o if HAVE_W32, +## w32cygwinx.o if CYGWIN but not HAVE_W32, else empty. W32_OBJ=@W32_OBJ@ ## -lkernel32 -luser32 -lusp10 -lgdi32 -lole32 -lcomdlg32 -lcomctl32 -## --lwinspool if HAVE_W32, else empty. +## -lwinspool if HAVE_W32, +## -lkernel32 if CYGWIN but not HAVE_W32, else empty. W32_LIBS=@W32_LIBS@ ## emacs.res if HAVE_W32 @@ -312,6 +313,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 +368,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 +402,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. @@ -408,7 +413,7 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ xterm.o xfns.o xmenu.o xselect.o xrdb.o xsmfns.o fringe.o image.o \ fontset.o dbusbind.o cygw32.o \ nsterm.o nsfns.o nsmenu.o nsselect.o nsimage.o nsfont.o macfont.o \ - w32.o w32console.o w32fns.o w32heap.o w32inevt.o w32notify.o \ + w32.o w32console.o w32cygwinx.o w32fns.o w32heap.o w32inevt.o w32notify.o \ w32menu.o w32proc.o w32reg.o w32select.o w32term.o w32xfns.o \ w16select.o widget.o xfont.o ftfont.o xftfont.o ftxfont.o gtkutil.o \ xsettings.o xgselect.o termcap.o @@ -493,7 +498,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 9d0e2d37e3c..ea8fdeee483 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 9b54e4b7787..f8c57a74b4e 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -5144,7 +5144,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 e51f9095b36..55b193ffb2f 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 e4491e9085a..08a8bba4646 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" @@ -270,44 +271,16 @@ invoke it. If KEYS is omitted or nil, the return value of `this-command-keys-vector' is used. */) (Lisp_Object function, Lisp_Object record_flag, Lisp_Object keys) { - /* `args' will contain the array of arguments to pass to the function. - `visargs' will contain the same list but in a nicer form, so that if we - pass it to Fformat_message it will be understandable to a human. */ - Lisp_Object *args, *visargs; - Lisp_Object specs; - Lisp_Object filter_specs; - Lisp_Object teml; - Lisp_Object up_event; - Lisp_Object enable; - USE_SAFE_ALLOCA; ptrdiff_t speccount = SPECPDL_INDEX (); - /* The index of the next element of this_command_keys to examine for - the 'e' interactive code. */ - ptrdiff_t next_event; - - Lisp_Object prefix_arg; - char *string; - const char *tem; - - /* If varies[i] > 0, the i'th argument shouldn't just have its value - in this call quoted in the command history. It should be - recorded as a call to the function named callint_argfuns[varies[i]]. */ - signed char *varies; - - ptrdiff_t i, nargs; - ptrdiff_t mark; - bool arg_from_tty = 0; + bool arg_from_tty = false; ptrdiff_t key_count; - bool record_then_fail = 0; - - Lisp_Object save_this_command, save_last_command; - Lisp_Object save_this_original_command, save_real_this_command; + bool record_then_fail = false; - save_this_command = Vthis_command; - save_this_original_command = Vthis_original_command; - save_real_this_command = Vreal_this_command; - save_last_command = KVAR (current_kboard, Vlast_command); + Lisp_Object save_this_command = Vthis_command; + Lisp_Object save_this_original_command = Vthis_original_command; + Lisp_Object save_real_this_command = Vreal_this_command; + Lisp_Object save_last_command = KVAR (current_kboard, Vlast_command); if (NILP (keys)) keys = this_command_keys, key_count = this_command_key_count; @@ -318,55 +291,44 @@ invoke it. If KEYS is omitted or nil, the return value of } /* Save this now, since use of minibuffer will clobber it. */ - prefix_arg = Vcurrent_prefix_arg; + Lisp_Object prefix_arg = Vcurrent_prefix_arg; - if (SYMBOLP (function)) - enable = Fget (function, Qenable_recursive_minibuffers); - else - enable = Qnil; - - specs = Qnil; - string = 0; - /* The idea of FILTER_SPECS is to provide a way to - specify how to represent the arguments in command history. - The feature is not fully implemented. */ - filter_specs = Qnil; + Lisp_Object enable = (SYMBOLP (function) + ? Fget (function, Qenable_recursive_minibuffers) + : Qnil); /* If k or K discard an up-event, save it here so it can be retrieved with U. */ - up_event = Qnil; + Lisp_Object up_event = Qnil; /* Set SPECS to the interactive form, or barf if not interactive. */ - { - Lisp_Object form; - form = Finteractive_form (function); - if (CONSP (form)) - specs = filter_specs = Fcar (XCDR (form)); - else - wrong_type_argument (Qcommandp, function); - } + Lisp_Object form = Finteractive_form (function); + if (! CONSP (form)) + wrong_type_argument (Qcommandp, function); + Lisp_Object specs = Fcar (XCDR (form)); + + /* At this point the value of SPECS could help provide a way to + specify how to represent the arguments in command history. + The feature is not fully implemented. */ /* If SPECS is not a string, invent one. */ if (! STRINGP (specs)) { - Lisp_Object input; Lisp_Object funval = Findirect_function (function, Qt); uintmax_t events = num_input_events; - input = specs; + Lisp_Object input = specs; /* Compute the arg values using the user's expression. */ specs = Feval (specs, CONSP (funval) && EQ (Qclosure, XCAR (funval)) ? CAR_SAFE (XCDR (funval)) : Qnil); if (events != num_input_events || !NILP (record_flag)) { - /* We should record this command on the command history. */ - Lisp_Object values; - Lisp_Object this_cmd; - /* Make a copy of the list of values, for the command history, + /* We should record this command on the command history. + Make a copy of the list of values, for the command history, and turn them into things we can eval. */ - values = quotify_args (Fcopy_sequence (specs)); + Lisp_Object values = quotify_args (Fcopy_sequence (specs)); fix_command (input, values); - this_cmd = Fcons (function, values); + Lisp_Object this_cmd = Fcons (function, values); if (history_delete_duplicates) Vcommand_history = Fdelete (this_cmd, Vcommand_history); Vcommand_history = Fcons (this_cmd, Vcommand_history); @@ -374,7 +336,7 @@ invoke it. If KEYS is omitted or nil, the return value of /* Don't keep command history around forever. */ if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0) { - teml = Fnthcdr (Vhistory_length, Vcommand_history); + Lisp_Object teml = Fnthcdr (Vhistory_length, Vcommand_history); if (CONSP (teml)) XSETCDR (teml, Qnil); } @@ -385,46 +347,42 @@ invoke it. If KEYS is omitted or nil, the return value of Vreal_this_command = save_real_this_command; kset_last_command (current_kboard, save_last_command); - Lisp_Object result - = unbind_to (speccount, CALLN (Fapply, Qfuncall_interactively, - function, specs)); - SAFE_FREE (); - return result; + return unbind_to (speccount, CALLN (Fapply, Qfuncall_interactively, + function, specs)); } /* SPECS is set to a string; use it as an interactive prompt. Copy it so that STRING will be valid even if a GC relocates SPECS. */ - SAFE_ALLOCA_STRING (string, specs); - - /* Here if function specifies a string to control parsing the defaults. */ + USE_SAFE_ALLOCA; + ptrdiff_t string_len = SBYTES (specs); + char *string = SAFE_ALLOCA (string_len + 1); + memcpy (string, SDATA (specs), string_len + 1); + char *string_end = string + string_len; - /* Set next_event to point to the first event with parameters. */ + /* The index of the next element of this_command_keys to examine for + the 'e' interactive code. Initialize it to point to the first + event with parameters. */ + ptrdiff_t next_event; for (next_event = 0; next_event < key_count; next_event++) if (EVENT_HAS_PARAMETERS (AREF (keys, next_event))) break; /* Handle special starting chars `*' and `@'. Also `-'. */ /* Note that `+' is reserved for user extensions. */ - while (1) + for (;; string++) { if (*string == '+') error ("`+' is not used in `interactive' for ordinary commands"); else if (*string == '*') { - string++; if (!NILP (BVAR (current_buffer, read_only))) { if (!NILP (record_flag)) { - char *p = string; - while (*p) - { - if (! (*p == 'r' || *p == 'p' || *p == 'P' - || *p == '\n')) - Fbarf_if_buffer_read_only (Qnil); - p++; - } - record_then_fail = 1; + for (char *p = string + 1; p < string_end; p++) + if (! (*p == 'r' || *p == 'p' || *p == 'P' || *p == '\n')) + Fbarf_if_buffer_read_only (Qnil); + record_then_fail = true; } else Fbarf_if_buffer_read_only (Qnil); @@ -432,14 +390,12 @@ invoke it. If KEYS is omitted or nil, the return value of } /* Ignore this for semi-compatibility with Lucid. */ else if (*string == '-') - string++; + ; else if (*string == '@') { - Lisp_Object event, w; - - event = (next_event < key_count - ? AREF (keys, next_event) - : Qnil); + Lisp_Object w, event = (next_event < key_count + ? AREF (keys, next_event) + : Qnil); if (EVENT_HAS_PARAMETERS (event) && (w = XCDR (event), CONSP (w)) && (w = XCAR (w), CONSP (w)) @@ -454,32 +410,23 @@ invoke it. If KEYS is omitted or nil, the return value of Fselect_window (w, Qnil); } - string++; } else if (*string == '^') - { - call0 (Qhandle_shift_selection); - string++; - } + call0 (Qhandle_shift_selection); else break; } /* Count the number of arguments, which is two (the function itself and `funcall-interactively') plus the number of arguments the interactive spec would have us give to the function. */ - tem = string; - for (nargs = 2; *tem; ) + ptrdiff_t nargs = 2; + for (char const *tem = string; tem < string_end; tem++) { /* 'r' specifications ("point and mark as 2 numeric args") produce *two* arguments. */ - if (*tem == 'r') - nargs += 2; - else - nargs++; - tem = strchr (tem, '\n'); - if (tem) - ++tem; - else + nargs += 1 + (*tem == 'r'); + tem = memchr (tem, '\n', string_len - (tem - string)); + if (!tem) break; } @@ -487,21 +434,34 @@ invoke it. If KEYS is omitted or nil, the return value of && MOST_POSITIVE_FIXNUM < nargs) memory_full (SIZE_MAX); - /* Allocate them all at one go. This wastes a bit of memory, but + /* ARGS will contain the array of arguments to pass to the function. + VISARGS will contain the same list but in a nicer form, so that if we + pass it to Fformat_message it will be understandable to a human. + Allocate them all at one go. This wastes a bit of memory, but it's OK to trade space for speed. */ + Lisp_Object *args; SAFE_NALLOCA (args, 3, nargs); - visargs = args + nargs; - varies = (signed char *) (visargs + nargs); + Lisp_Object *visargs = args + nargs; + /* If varies[I] > 0, the Ith argument shouldn't just have its value + in this call quoted in the command history. It should be + recorded as a call to the function named callint_argfuns[varies[I]]. */ + signed char *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); - tem = string; - for (i = 2; *tem; i++) + char const *tem = string; + for (ptrdiff_t i = 2; tem < string_end; i++) { - visargs[1] = make_string (tem + 1, strcspn (tem + 1, "\n")); + char *pnl = memchr (tem + 1, '\n', string_len - (tem + 1 - string)); + ptrdiff_t sz = pnl ? pnl - (tem + 1) : string_end - (tem + 1); + + visargs[1] = make_string (tem + 1, sz); callint_message = Fformat_message (i - 1, visargs + 1); switch (*tem) @@ -510,9 +470,7 @@ invoke it. If KEYS is omitted or nil, the return value of visargs[i] = Fcompleting_read (callint_message, Vobarray, Qfboundp, Qt, Qnil, Qnil, Qnil, Qnil); - /* Passing args[i] directly stimulates compiler bug. */ - teml = visargs[i]; - args[i] = Fintern (teml, Qnil); + args[i] = Fintern (visargs[i], Qnil); break; case 'b': /* Name of existing buffer. */ @@ -524,7 +482,8 @@ invoke it. If KEYS is omitted or nil, the return value of case 'B': /* Name of buffer, possibly nonexistent. */ args[i] = Fread_buffer (callint_message, - Fother_buffer (Fcurrent_buffer (), Qnil, Qnil), + Fother_buffer (Fcurrent_buffer (), + Qnil, Qnil), Qnil, Qnil); break; @@ -535,20 +494,17 @@ invoke it. If KEYS is omitted or nil, the return value of Qface, Qminibuffer_prompt, callint_message); args[i] = Fread_char (callint_message, Qnil, Qnil); message1_nolog (0); - /* Passing args[i] directly stimulates compiler bug. */ - teml = args[i]; /* See bug#8479. */ - if (! CHARACTERP (teml)) error ("Non-character input-event"); - visargs[i] = Fchar_to_string (teml); + if (! CHARACTERP (args[i])) + error ("Non-character input-event"); + visargs[i] = Fchar_to_string (args[i]); break; case 'C': /* Command: symbol with interactive function. */ visargs[i] = Fcompleting_read (callint_message, Vobarray, Qcommandp, Qt, Qnil, Qnil, Qnil, Qnil); - /* Passing args[i] directly stimulates compiler bug. */ - teml = visargs[i]; - args[i] = Fintern (teml, Qnil); + args[i] = Fintern (visargs[i], Qnil); break; case 'd': /* Value of point. Does not do I/O. */ @@ -559,8 +515,8 @@ invoke it. If KEYS is omitted or nil, the return value of break; case 'D': /* Directory name. */ - args[i] = read_file_name (BVAR (current_buffer, directory), Qlambda, Qnil, - Qfile_directory_p); + args[i] = read_file_name (BVAR (current_buffer, directory), Qlambda, + Qnil, Qfile_directory_p); break; case 'f': /* Existing file name. */ @@ -591,21 +547,19 @@ invoke it. If KEYS is omitted or nil, the return value of args[i] = Fread_key_sequence (callint_message, Qnil, Qnil, Qnil, Qnil); unbind_to (speccount1, Qnil); - teml = args[i]; - visargs[i] = Fkey_description (teml, Qnil); + visargs[i] = Fkey_description (args[i], Qnil); /* If the key sequence ends with a down-event, discard the following up-event. */ - teml = Faref (args[i], make_number (XINT (Flength (args[i])) - 1)); + Lisp_Object teml + = Faref (args[i], make_number (XINT (Flength (args[i])) - 1)); if (CONSP (teml)) teml = XCAR (teml); if (SYMBOLP (teml)) { - Lisp_Object tem2; - teml = Fget (teml, Qevent_symbol_elements); /* Ignore first element, which is the base key. */ - tem2 = Fmemq (Qdown, Fcdr (teml)); + Lisp_Object tem2 = Fmemq (Qdown, Fcdr (teml)); if (! NILP (tem2)) up_event = Fread_event (Qnil, Qnil, Qnil); } @@ -622,22 +576,20 @@ invoke it. If KEYS is omitted or nil, the return value of Qface, Qminibuffer_prompt, callint_message); args[i] = Fread_key_sequence_vector (callint_message, Qnil, Qt, Qnil, Qnil); - teml = args[i]; - visargs[i] = Fkey_description (teml, Qnil); + visargs[i] = Fkey_description (args[i], Qnil); unbind_to (speccount1, Qnil); /* If the key sequence ends with a down-event, discard the following up-event. */ - teml = Faref (args[i], make_number (XINT (Flength (args[i])) - 1)); + Lisp_Object teml + = Faref (args[i], make_number (XINT (Flength (args[i])) - 1)); if (CONSP (teml)) teml = XCAR (teml); if (SYMBOLP (teml)) { - Lisp_Object tem2; - teml = Fget (teml, Qevent_symbol_elements); /* Ignore first element, which is the base key. */ - tem2 = Fmemq (Qdown, Fcdr (teml)); + Lisp_Object tem2 = Fmemq (Qdown, Fcdr (teml)); if (! NILP (tem2)) up_event = Fread_event (Qnil, Qnil, Qnil); } @@ -649,8 +601,7 @@ invoke it. If KEYS is omitted or nil, the return value of { args[i] = Fmake_vector (make_number (1), up_event); up_event = Qnil; - teml = args[i]; - visargs[i] = Fkey_description (teml, Qnil); + visargs[i] = Fkey_description (args[i], Qnil); } break; @@ -661,18 +612,18 @@ invoke it. If KEYS is omitted or nil, the return value of ? SSDATA (SYMBOL_NAME (function)) : "command")); args[i] = AREF (keys, next_event); - next_event++; varies[i] = -1; /* Find the next parameterized event. */ - while (next_event < key_count - && !(EVENT_HAS_PARAMETERS (AREF (keys, next_event)))) + do next_event++; + while (next_event < key_count + && ! EVENT_HAS_PARAMETERS (AREF (keys, next_event))); break; case 'm': /* Value of mark. Does not do I/O. */ - check_mark (0); + check_mark (false); /* visargs[i] = Qnil; */ args[i] = BVAR (current_buffer, mark); varies[i] = 2; @@ -690,9 +641,7 @@ invoke it. If KEYS is omitted or nil, the return value of FALLTHROUGH; case 'n': /* Read number from minibuffer. */ args[i] = call1 (Qread_number, callint_message); - /* Passing args[i] directly stimulates compiler bug. */ - teml = args[i]; - visargs[i] = Fnumber_to_string (teml); + visargs[i] = Fnumber_to_string (args[i]); break; case 'P': /* Prefix arg in raw form. Does no I/O. */ @@ -709,15 +658,16 @@ invoke it. If KEYS is omitted or nil, the return value of break; case 'r': /* Region, point and mark as 2 args. */ - check_mark (1); - set_marker_both (point_marker, Qnil, PT, PT_BYTE); - /* visargs[i+1] = Qnil; */ - mark = marker_position (BVAR (current_buffer, mark)); - /* visargs[i] = Qnil; */ - args[i] = PT < mark ? point_marker : BVAR (current_buffer, mark); - varies[i] = 3; - args[++i] = PT > mark ? point_marker : BVAR (current_buffer, mark); - varies[i] = 4; + { + check_mark (true); + set_marker_both (point_marker, Qnil, PT, PT_BYTE); + ptrdiff_t mark = marker_position (BVAR (current_buffer, mark)); + /* visargs[i] = visargs[i + 1] = Qnil; */ + args[i] = PT < mark ? point_marker : BVAR (current_buffer, mark); + varies[i] = 3; + args[++i] = PT > mark ? point_marker : BVAR (current_buffer, mark); + varies[i] = 4; + } break; case 's': /* String read via minibuffer without @@ -729,9 +679,7 @@ invoke it. If KEYS is omitted or nil, the return value of case 'S': /* Any symbol. */ visargs[i] = Fread_string (callint_message, Qnil, Qnil, Qnil, Qnil); - /* Passing args[i] directly stimulates compiler bug. */ - teml = visargs[i]; - args[i] = Fintern (teml, Qnil); + args[i] = Fintern (visargs[i], Qnil); break; case 'v': /* Variable name: symbol that is @@ -777,7 +725,7 @@ invoke it. If KEYS is omitted or nil, the return value of { /* How many bytes are left unprocessed in the specs string? (Note that this excludes the trailing null byte.) */ - ptrdiff_t bytes_left = SBYTES (specs) - (tem - string); + ptrdiff_t bytes_left = string_len - (tem - string); unsigned letter; /* If we have enough bytes left to treat the sequence as a @@ -788,20 +736,21 @@ invoke it. If KEYS is omitted or nil, the return value of else letter = *((unsigned char *) tem); - error ("Invalid control letter `%c' (#o%03o, #x%04x) in interactive calling string", + error (("Invalid control letter `%c' (#o%03o, #x%04x)" + " in interactive calling string"), (int) letter, letter, letter); } } if (varies[i] == 0) - arg_from_tty = 1; + arg_from_tty = true; if (NILP (visargs[i]) && STRINGP (args[i])) visargs[i] = args[i]; - tem = strchr (tem, '\n'); + tem = memchr (tem, '\n', string_len - (tem - string)); if (tem) tem++; - else tem = ""; + else tem = string_end; } unbind_to (speccount, Qnil); @@ -815,19 +764,16 @@ invoke it. If KEYS is omitted or nil, the return value of /* We don't need `visargs' any more, so let's recycle it since we need an array of just the same size. */ visargs[1] = function; - for (i = 2; i < nargs; i++) - { - if (varies[i] > 0) - visargs[i] = list1 (intern (callint_argfuns[varies[i]])); - else - visargs[i] = quotify_arg (args[i]); - } + for (ptrdiff_t i = 2; i < nargs; i++) + visargs[i] = (varies[i] > 0 + ? list1 (intern (callint_argfuns[varies[i]])) + : quotify_arg (args[i])); Vcommand_history = Fcons (Flist (nargs - 1, visargs + 1), Vcommand_history); /* Don't keep command history around forever. */ if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0) { - teml = Fnthcdr (Vhistory_length, Vcommand_history); + Lisp_Object teml = Fnthcdr (Vhistory_length, Vcommand_history); if (CONSP (teml)) XSETCDR (teml, Qnil); } @@ -835,7 +781,7 @@ invoke it. If KEYS is omitted or nil, the return value of /* If we used a marker to hold point, mark, or an end of the region, temporarily, convert it to an integer now. */ - for (i = 2; i < nargs; i++) + for (ptrdiff_t i = 2; i < nargs; i++) if (varies[i] >= 1 && varies[i] <= 4) XSETINT (args[i], marker_position (args[i])); @@ -847,15 +793,11 @@ invoke it. If KEYS is omitted or nil, the return value of Vreal_this_command = save_real_this_command; kset_last_command (current_kboard, save_last_command); - { - Lisp_Object val; - specbind (Qcommand_debug_status, Qnil); + specbind (Qcommand_debug_status, Qnil); - val = Ffuncall (nargs, args); - val = unbind_to (speccount, val); - SAFE_FREE (); - return val; - } + Lisp_Object val = Ffuncall (nargs, args); + SAFE_FREE (); + return unbind_to (speccount, val); } DEFUN ("prefix-numeric-value", Fprefix_numeric_value, Sprefix_numeric_value, diff --git a/src/character.c b/src/character.c index fa817a50317..4a934c7801c 100644 --- a/src/character.c +++ b/src/character.c @@ -1050,6 +1050,32 @@ blankp (int c) return XINT (category) == UNICODE_CATEGORY_Zs; /* separator, space */ } + +/* Return true for characters that would read as symbol characters, + but graphically may be confused with some kind of punctuation. We + require an escaping backslash, when such characters begin a + symbol. */ +bool +confusable_symbol_character_p (int ch) +{ + switch (ch) + { + case 0x2018: /* LEFT SINGLE QUOTATION MARK */ + case 0x2019: /* RIGHT SINGLE QUOTATION MARK */ + case 0x201B: /* SINGLE HIGH-REVERSED-9 QUOTATION MARK */ + case 0x201C: /* LEFT DOUBLE QUOTATION MARK */ + case 0x201D: /* RIGHT DOUBLE QUOTATION MARK */ + case 0x201F: /* DOUBLE HIGH-REVERSED-9 QUOTATION MARK */ + case 0x301E: /* DOUBLE PRIME QUOTATION MARK */ + case 0xFF02: /* FULLWIDTH QUOTATION MARK */ + case 0xFF07: /* FULLWIDTH APOSTROPHE */ + return true; + + default: + return false; + } +} + signed char HEXDIGIT_CONST hexdigit[UCHAR_MAX + 1] = { #if HEXDIGIT_IS_CONST diff --git a/src/character.h b/src/character.h index c716885d46b..d9e2d7bfc67 100644 --- a/src/character.h +++ b/src/character.h @@ -682,6 +682,8 @@ extern bool graphicp (int); extern bool printablep (int); extern bool blankp (int); +extern bool confusable_symbol_character_p (int ch); + /* Return a translation table of id number ID. */ #define GET_TRANSLATION_TABLE(id) \ (XCDR (XVECTOR (Vtranslation_table_vector)->contents[(id)])) diff --git a/src/cmds.c b/src/cmds.c index db3924e3f6a..96b712ed6d2 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 a7b040e2712..901f806e44b 100644 --- a/src/coding.c +++ b/src/coding.c @@ -1515,13 +1515,6 @@ encode_coding_utf_8 (struct coding_system *coding) /* See the above "GENERAL NOTES on `detect_coding_XXX ()' functions". Return true if a text is encoded in one of UTF-16 based coding systems. */ -#define UTF_16_HIGH_SURROGATE_P(val) \ - (((val) & 0xFC00) == 0xD800) - -#define UTF_16_LOW_SURROGATE_P(val) \ - (((val) & 0xFC00) == 0xDC00) - - static bool detect_coding_utf_16 (struct coding_system *coding, struct coding_detection_info *detect_info) @@ -6360,6 +6353,27 @@ check_utf_8 (struct coding_system *coding) } +/* Return whether STRING is a valid UTF-8 string. STRING must be a + unibyte string. */ + +bool +utf8_string_p (Lisp_Object string) +{ + eassert (!STRING_MULTIBYTE (string)); + struct coding_system coding; + setup_coding_system (Qutf_8_unix, &coding); + /* We initialize only the fields that check_utf_8 accesses. */ + coding.head_ascii = -1; + coding.src_pos = 0; + coding.src_pos_byte = 0; + coding.src_chars = SCHARS (string); + coding.src_bytes = SBYTES (string); + coding.src_object = string; + coding.eol_seen = EOL_SEEN_NONE; + return check_utf_8 (&coding) != -1; +} + + /* Detect how end-of-line of a text of length SRC_BYTES pointed by SOURCE is encoded. If CATEGORY is one of coding_category_utf_16_XXXX, assume that CR and LF are encoded by @@ -10249,7 +10263,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; @@ -10859,6 +10873,7 @@ syms_of_coding (void) DEFSYM (Qiso_2022, "iso-2022"); DEFSYM (Qutf_8, "utf-8"); + DEFSYM (Qutf_8_unix, "utf-8-unix"); DEFSYM (Qutf_8_emacs, "utf-8-emacs"); #if defined (WINDOWSNT) || defined (CYGWIN) diff --git a/src/coding.h b/src/coding.h index 2a87fc32e9d..165c1b29b71 100644 --- a/src/coding.h +++ b/src/coding.h @@ -662,9 +662,22 @@ struct coding_system /* Note that this encodes utf-8, not utf-8-emacs, so it's not a no-op. */ #define ENCODE_UTF_8(str) code_convert_string_norecord (str, Qutf_8, true) +/* Return true if VAL is a high surrogate. VAL must be a 16-bit code + unit. */ + +#define UTF_16_HIGH_SURROGATE_P(val) \ + (((val) & 0xFC00) == 0xD800) + +/* Return true if VAL is a low surrogate. VAL must be a 16-bit code + unit. */ + +#define UTF_16_LOW_SURROGATE_P(val) \ + (((val) & 0xFC00) == 0xDC00) + /* Extern declarations. */ extern Lisp_Object code_conversion_save (bool, bool); extern bool encode_coding_utf_8 (struct coding_system *); +extern bool utf8_string_p (Lisp_Object); extern void setup_coding_system (Lisp_Object, struct coding_system *); extern Lisp_Object coding_charset_list (struct coding_system *); extern Lisp_Object coding_system_charset_list (Lisp_Object); @@ -687,6 +700,8 @@ extern void decode_coding_object (struct coding_system *, extern void encode_coding_object (struct coding_system *, Lisp_Object, ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, Lisp_Object); +/* Defined in this file. */ +INLINE int surrogates_to_codepoint (int, int); #if defined (WINDOWSNT) || defined (CYGWIN) @@ -731,6 +746,18 @@ extern Lisp_Object from_unicode_buffer (const wchar_t *wstr); } while (false) +/* Return the Unicode code point for the given UTF-16 surrogates. */ + +INLINE int +surrogates_to_codepoint (int low, int high) +{ + eassert (0 <= low && low <= 0xFFFF); + eassert (0 <= high && high <= 0xFFFF); + eassert (UTF_16_LOW_SURROGATE_P (low)); + eassert (UTF_16_HIGH_SURROGATE_P (high)); + return 0x10000 + (low - 0xDC00) + ((high - 0xD800) * 0x400); +} + extern Lisp_Object preferred_coding_system (void); diff --git a/src/data.c b/src/data.c index 53a92ac03bb..72abfefb01f 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/decompress.c b/src/decompress.c index 41de6da1dd2..6f75f821c40 100644 --- a/src/decompress.c +++ b/src/decompress.c @@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "buffer.h" +#include "composite.h" #include <verify.h> @@ -66,7 +67,7 @@ init_zlib_functions (void) struct decompress_unwind_data { - ptrdiff_t old_point, start, nbytes; + ptrdiff_t old_point, orig, start, nbytes; z_stream *stream; }; @@ -76,10 +77,19 @@ unwind_decompress (void *ddata) struct decompress_unwind_data *data = ddata; inflateEnd (data->stream); - /* Delete any uncompressed data already inserted on error. */ + /* Delete any uncompressed data already inserted on error, but + without calling the change hooks. */ if (data->start) - del_range (data->start, data->start + data->nbytes); - + { + del_range_2 (data->start, data->start, /* byte, char offsets the same */ + data->start + data->nbytes, data->start + data->nbytes, + 0); + update_compositions (data->start, data->start, CHECK_HEAD); + /* "Balance" the before-change-functions call, which would + otherwise be left "hanging". */ + signal_after_change (data->orig, data->start - data->orig, + data->start - data->orig); + } /* Put point where it was, or if the buffer has shrunk because the compressed data is bigger than the uncompressed, at point-max. */ @@ -141,6 +151,10 @@ This function can be called only in unibyte buffers. */) the same. */ istart = XINT (start); iend = XINT (end); + + /* Do the following before manipulating the gap. */ + modify_text (istart, iend); + move_gap_both (iend, iend); stream.zalloc = Z_NULL; @@ -154,6 +168,7 @@ This function can be called only in unibyte buffers. */) if (inflateInit2 (&stream, MAX_WBITS + 32) != Z_OK) return Qnil; + unwind_data.orig = istart; unwind_data.start = iend; unwind_data.stream = &stream; unwind_data.old_point = PT; @@ -196,7 +211,11 @@ This function can be called only in unibyte buffers. */) unwind_data.start = 0; /* Delete the compressed data. */ - del_range (istart, iend); + del_range_2 (istart, istart, /* byte and char offsets are the same. */ + iend, iend, 0); + + signal_after_change (istart, iend - istart, unwind_data.nbytes); + update_compositions (istart, istart, CHECK_HEAD); return unbind_to (count, Qt); } diff --git a/src/dispextern.h b/src/dispextern.h index 25bd6b24f22..441361b4083 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3452,15 +3452,6 @@ void gamma_correct (struct frame *, COLORREF *); void x_implicitly_set_name (struct frame *, Lisp_Object, Lisp_Object); void x_change_tool_bar_height (struct frame *f, int); -/* The frame used to display a tooltip. - - Note: In a GTK build with non-zero x_gtk_use_system_tooltips, this - variable holds the frame that shows the tooltip, not the frame of - the tooltip itself, so checking whether a frame is a tooltip frame - cannot just compare the frame to what this variable holds. */ -extern Lisp_Object tip_frame; - -extern Window tip_window; extern frame_parm_handler x_frame_parm_handlers[]; extern void start_hourglass (void); diff --git a/src/dispnew.c b/src/dispnew.c index ae6799bb85c..56f125218dc 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); @@ -5208,6 +5214,11 @@ buffer_posn_from_coords (struct window *w, int *x, int *y, struct display_pos *p #ifdef HAVE_WINDOW_SYSTEM if (it.what == IT_IMAGE) { + /* Note that this ignores images that are fringe bitmaps, + because their image ID is zero, and so IMAGE_OPT_FROM_ID will + return NULL. This is okay, since fringe bitmaps are not + displayed in the text area, and so are never the object we + are interested in. */ img = IMAGE_OPT_FROM_ID (it.f, it.image_id); if (img && !NILP (img->spec)) *object = img->spec; diff --git a/src/doprnt.c b/src/doprnt.c index cc5ce65105b..f194b43e0a9 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 d0ccdbddc29..96bb271b2d6 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; @@ -5281,8 +5293,7 @@ Transposing beyond buffer boundaries is an error. */) { USE_SAFE_ALLOCA; - modify_text (start1, end1); - modify_text (start2, end2); + modify_text (start1, end2); record_change (start1, len1); record_change (start2, len2); tmp_interval1 = copy_intervals (cur_intv, start1, len1); diff --git a/src/emacs-module.c b/src/emacs-module.c index 1b19e8033df..385c3089a90 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 @@ -800,18 +805,6 @@ module_function_arity (const struct Lisp_Module_Function *const function) /* Helper functions. */ -static bool -in_current_thread (void) -{ - if (current_thread == NULL) - return false; -#ifdef HAVE_PTHREAD - return pthread_equal (pthread_self (), current_thread->thread_id); -#elif defined WINDOWSNT - return GetCurrentThreadId () == current_thread->thread_id; -#endif -} - static void module_assert_thread (void) { @@ -915,9 +908,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 +918,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 +982,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 017c62308c1..8ea61b71fb7 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 (); @@ -1563,6 +1566,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_fontset (); #endif /* HAVE_NTGUI */ +#if defined HAVE_NTGUI || defined CYGWIN + syms_of_w32cygwinx (); +#endif + #if defined WINDOWSNT || defined HAVE_NTGUI syms_of_w32select (); #endif @@ -1610,6 +1617,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 (); @@ -2013,7 +2024,10 @@ all of which are called before Emacs is actually killed. */ /* Fsignal calls emacs_abort () if it sees that waiting_for_input is set. */ waiting_for_input = 0; - run_hook (Qkill_emacs_hook); + if (noninteractive) + safe_run_hooks (Qkill_emacs_hook); + else + run_hook (Qkill_emacs_hook); #ifdef HAVE_X_WINDOWS /* Transfer any clipboards we own to the clipboard manager. */ diff --git a/src/eval.c b/src/eval.c index e05a17f7b4b..3c2b300096b 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 c4a10000bc3..be29e60fc0a 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> @@ -138,7 +139,7 @@ static bool e_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t, struct coding_system *); -/* Return true if FILENAME exists. */ +/* Return true if FILENAME exists, otherwise return false and set errno. */ static bool check_existing (const char *filename) @@ -2594,7 +2595,7 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0, /* The read-only attribute of the parent directory doesn't affect whether a file or directory can be created within it. Some day we should check ACLs though, which do affect this. */ - return file_directory_p (SSDATA (dir)) ? Qt : Qnil; + return file_directory_p (dir) ? Qt : Qnil; #else return check_writable (SSDATA (dir), W_OK | X_OK) ? Qt : Qnil; #endif @@ -2688,19 +2689,47 @@ See `file-symlink-p' to distinguish symlinks. */) absname = ENCODE_FILE (absname); - return file_directory_p (SSDATA (absname)) ? Qt : Qnil; + return file_directory_p (absname) ? Qt : Qnil; } -/* Return true if FILE is a directory or a symlink to a directory. */ +/* Return true if FILE is a directory or a symlink to a directory. + Otherwise return false and set errno. */ bool -file_directory_p (char const *file) +file_directory_p (Lisp_Object file) { #ifdef WINDOWSNT /* This is cheaper than 'stat'. */ - return faccessat (AT_FDCWD, file, D_OK, AT_EACCESS) == 0; + return faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0; #else +# ifdef O_PATH + /* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */ + int fd = openat (AT_FDCWD, SSDATA (file), O_PATH | O_CLOEXEC | O_DIRECTORY); + if (0 <= fd) + { + emacs_close (fd); + return true; + } + if (errno != EINVAL) + return false; + /* O_PATH is defined but evidently this Linux kernel predates 2.6.39. + Fall back on generic POSIX code. */ +# endif + /* Use file_accessible_directory, as it avoids stat EOVERFLOW + problems and could be cheaper. However, if it fails because FILE + is inaccessible, fall back on stat; if the latter fails with + EOVERFLOW then FILE must have been a directory unless a race + condition occurred (a problem hard to work around portably). */ + if (file_accessible_directory_p (file)) + return true; + if (errno != EACCES) + return false; struct stat st; - return stat (file, &st) == 0 && S_ISDIR (st.st_mode); + if (stat (SSDATA (file), &st) != 0) + return errno == EOVERFLOW; + if (S_ISDIR (st.st_mode)) + return true; + errno = ENOTDIR; + return false; #endif } @@ -2761,7 +2790,7 @@ file_accessible_directory_p (Lisp_Object file) return (SBYTES (file) == 0 || w32_accessible_directory_p (SSDATA (file), SBYTES (file))); # else /* MSDOS */ - return file_directory_p (SSDATA (file)); + return file_directory_p (file); # endif /* MSDOS */ #else /* !DOS_NT */ /* On POSIXish platforms, use just one system call; this avoids a @@ -3191,7 +3220,7 @@ Use the current time if TIMESTAMP is nil. TIMESTAMP is in the format of { #ifdef MSDOS /* Setting times on a directory always fails. */ - if (file_directory_p (SSDATA (encoded_absname))) + if (file_directory_p (encoded_absname)) return Qnil; #endif report_file_error ("Setting file times", absname); @@ -5786,6 +5815,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 +5931,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 +6212,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/fns.c b/src/fns.c index aba34fd2611..47457e44c8e 100644 --- a/src/fns.c +++ b/src/fns.c @@ -3319,6 +3319,7 @@ If the region can't be decoded, signal an error and don't modify the buffer. */ and delete the old. (Insert first in order to preserve markers.) */ TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg); insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0); + signal_after_change (XFASTINT (beg), 0, inserted_chars); SAFE_FREE (); /* Delete the original text. */ diff --git a/src/frame.c b/src/frame.c index d5b080d688a..9b560808128 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" @@ -831,6 +832,7 @@ make_frame (bool mini_p) f->no_focus_on_map = false; f->no_accept_focus = false; f->z_group = z_group_none; + f->tooltip = false; #if ! defined (USE_GTK) && ! defined (HAVE_NS) f->last_tool_bar_item = -1; #endif @@ -1466,20 +1468,21 @@ DEFUN ("selected-frame", Fselected_frame, Sselected_frame, 0, 0, 0, DEFUN ("frame-list", Fframe_list, Sframe_list, 0, 0, 0, - doc: /* Return a list of all live frames. */) + doc: /* Return a list of all live frames. +The return value does not include any tooltip frame. */) (void) { - Lisp_Object frames; - frames = Fcopy_sequence (Vframe_list); #ifdef HAVE_WINDOW_SYSTEM - if (FRAMEP (tip_frame) -#ifdef USE_GTK - && !NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - ) - frames = Fdelq (tip_frame, frames); -#endif - return frames; + Lisp_Object list = Qnil, tail, frame; + + FOR_EACH_FRAME (tail, frame) + if (!FRAME_TOOLTIP_P (XFRAME (frame))) + list = Fcons (frame, list); + /* Reverse list for consistency with the !HAVE_WINDOW_SYSTEM case. */ + return Fnreverse (list); +#else /* !HAVE_WINDOW_SYSTEM */ + return Fcopy_sequence (Vframe_list); +#endif /* HAVE_WINDOW_SYSTEM */ } DEFUN ("frame-parent", Fframe_parent, Sframe_parent, @@ -1710,7 +1713,8 @@ DEFUN ("last-nonminibuffer-frame", Flast_nonminibuf_frame, * other_frames: * * Return true if there exists at least one visible or iconified frame - * but F. Return false otherwise. + * but F. Tooltip frames do not qualify as candidates. Return false + * if no such frame exists. * * INVISIBLE true means we are called from make_frame_invisible where * such a frame must be visible or iconified. INVISIBLE nil means we @@ -1724,7 +1728,6 @@ static bool other_frames (struct frame *f, bool invisible, bool force) { Lisp_Object frames, frame, frame1; - struct frame *f1; Lisp_Object minibuffer_window = FRAME_MINIBUF_WINDOW (f); XSETFRAME (frame, f); @@ -1734,7 +1737,8 @@ other_frames (struct frame *f, bool invisible, bool force) FOR_EACH_FRAME (frames, frame1) { - f1 = XFRAME (frame1); + struct frame *f1 = XFRAME (frame1); + if (f != f1) { /* Verify that we can still talk to the frame's X window, and @@ -1743,7 +1747,7 @@ other_frames (struct frame *f, bool invisible, bool force) if (FRAME_WINDOW_P (f1)) x_sync (f1); #endif - if (NILP (Fframe_parameter (frame1, Qtooltip)) + if (!FRAME_TOOLTIP_P (f1) /* Tooltips and child frames count neither for invisibility nor for deletions. */ && !FRAME_PARENT_FRAME (f1) @@ -1876,7 +1880,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force) } } - is_tooltip_frame = !NILP (Fframe_parameter (frame, Qtooltip)); + is_tooltip_frame = FRAME_TOOLTIP_P (f); /* Run `delete-frame-functions' unless FORCE is `noelisp' or frame is a tooltip. FORCE is set to `noelisp' when handling @@ -1924,27 +1928,31 @@ delete_frame (Lisp_Object frame, Lisp_Object force) Do not call next_frame here because it may loop forever. See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=15025. */ FOR_EACH_FRAME (tail, frame1) - if (!EQ (frame, frame1) - && NILP (Fframe_parameter (frame1, Qtooltip)) - && (FRAME_TERMINAL (XFRAME (frame)) - == FRAME_TERMINAL (XFRAME (frame1))) - && FRAME_VISIBLE_P (XFRAME (frame1))) - break; + { + struct frame *f1 = XFRAME (frame1); + + if (!EQ (frame, frame1) + && !FRAME_TOOLTIP_P (f1) + && FRAME_TERMINAL (f) == FRAME_TERMINAL (f1) + && FRAME_VISIBLE_P (f1)) + break; + } /* If there is none, find *some* other frame. */ if (NILP (frame1) || EQ (frame1, frame)) { FOR_EACH_FRAME (tail, frame1) { + struct frame *f1 = XFRAME (frame1); + if (!EQ (frame, frame1) - && FRAME_LIVE_P (XFRAME (frame1)) - && NILP (Fframe_parameter (frame1, Qtooltip))) + && FRAME_LIVE_P (f1) + && !FRAME_TOOLTIP_P (f1)) { - /* Do not change a text terminal's top-frame. */ - struct frame *f1 = XFRAME (frame1); if (FRAME_TERMCAP_P (f1) || FRAME_MSDOS_P (f1)) { Lisp_Object top_frame = FRAME_TTY (f1)->top_frame; + if (!EQ (top_frame, frame)) frame1 = top_frame; } @@ -4817,6 +4825,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). */ @@ -4895,6 +4905,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/frame.h b/src/frame.h index 402d6c0a7b2..2c9c4143886 100644 --- a/src/frame.h +++ b/src/frame.h @@ -342,6 +342,9 @@ struct frame ENUM_BF (output_method) output_method : 3; #ifdef HAVE_WINDOW_SYSTEM + /* True if this frame is a tooltip frame. */ + bool_bf tooltip : 1; + /* See FULLSCREEN_ enum on top. */ ENUM_BF (fullscreen_type) want_fullscreen : 4; @@ -351,9 +354,7 @@ struct frame /* Nonzero if we should actually display horizontal scroll bars on this frame. */ bool_bf horizontal_scroll_bars : 1; -#endif /* HAVE_WINDOW_SYSTEM */ -#if defined (HAVE_WINDOW_SYSTEM) /* True if this is an undecorated frame. */ bool_bf undecorated : 1; @@ -967,6 +968,7 @@ default_pixels_per_inch_y (void) #define FRAME_Z_GROUP_ABOVE_SUSPENDED(f) \ ((f)->z_group == z_group_above_suspended) #define FRAME_Z_GROUP_BELOW(f) ((f)->z_group == z_group_below) +#define FRAME_TOOLTIP_P(f) ((f)->tooltip) #ifdef NS_IMPL_COCOA #define FRAME_NS_APPEARANCE(f) ((f)->ns_appearance) #define FRAME_NS_TRANSPARENT_TITLEBAR(f) ((f)->ns_transparent_titlebar) @@ -983,6 +985,7 @@ default_pixels_per_inch_y (void) #define FRAME_Z_GROUP_NONE(f) ((void) (f), true) #define FRAME_Z_GROUP_ABOVE(f) ((void) (f), false) #define FRAME_Z_GROUP_BELOW(f) ((void) (f), false) +#define FRAME_TOOLTIP_P(f) ((void) f, false) #endif /* HAVE_WINDOW_SYSTEM */ /* Whether horizontal scroll bars are currently enabled for frame F. */ diff --git a/src/fringe.c b/src/fringe.c index 34bc5db06d1..85aa14da727 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 d013f1f72c6..ebba789f610 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 83b306a730a..3f21288f461 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -687,6 +687,7 @@ qttip_cb (GtkWidget *widget, g_signal_connect (x->ttip_lbl, "hierarchy-changed", G_CALLBACK (hierarchy_ch_cb), f); } + return FALSE; } @@ -713,7 +714,8 @@ xg_prepare_tooltip (struct frame *f, GtkRequisition req; Lisp_Object encoded_string; - if (!x->ttip_lbl) return 0; + if (!x->ttip_lbl) + return FALSE; block_input (); encoded_string = ENCODE_UTF_8 (string); @@ -745,7 +747,7 @@ xg_prepare_tooltip (struct frame *f, unblock_input (); - return 1; + return TRUE; #endif /* USE_GTK_TOOLTIP */ } @@ -768,18 +770,18 @@ xg_show_tooltip (struct frame *f, int root_x, int root_y) #endif } + /* Hide tooltip if shown. Do nothing if not shown. Return true if tip was hidden, false if not (i.e. not using system tooltips). */ - bool xg_hide_tooltip (struct frame *f) { - bool ret = 0; #ifdef USE_GTK_TOOLTIP if (f->output_data.x->ttip_window) { GtkWindow *win = f->output_data.x->ttip_window; + block_input (); gtk_widget_hide (GTK_WIDGET (win)); @@ -792,10 +794,10 @@ xg_hide_tooltip (struct frame *f) } unblock_input (); - ret = 1; + return TRUE; } #endif - return ret; + return FALSE; } @@ -1064,16 +1066,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; @@ -1237,9 +1246,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. */ @@ -4108,8 +4119,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; @@ -4146,7 +4159,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..b046d34f667 --- /dev/null +++ b/src/json.c @@ -0,0 +1,920 @@ +/* JSON parsing and serialization. + +Copyright (C) 2017-2018 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" + +#define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00) + +#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 (json_t *, json_object_get, (const json_t *object, const char *key)); +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_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_get fn_json_object_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); +} + +#if !JSON_HAS_ERROR_CODE + +/* 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; +} + +#endif + +/* 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. + Note that all callers below either pass only value UTF-8 strings or + use this function for formatting error messages; in the latter case + correctness isn't critical. */ + +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. Note that all callers + below either pass only value UTF-8 strings or use this function for + formatting error messages; in the latter case correctness isn't + critical. */ + +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) +{ + /* FIXME: Raise an error if STRING is not a scalar value + sequence. */ + 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; +#if JSON_HAS_ERROR_CODE + switch (json_error_code (error)) + { + case json_error_premature_end_of_input: + symbol = Qjson_end_of_file; + break; + case json_error_end_of_input_expected: + symbol = Qjson_trailing_content; + break; + default: + symbol = Qjson_parse_error; + break; + } +#else + 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; +#endif + 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; +} + +/* If STRING is not a valid UTF-8 string, signal an error of type + `wrong-type-argument'. STRING must be a unibyte string. */ + +static void +json_check_utf8 (Lisp_Object string) +{ + CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string); +} + +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); + const char *key_str = SSDATA (key); + /* Reject duplicate keys. These are possible if the hash + table test is not `equal'. */ + if (json_object_get (*json, key_str) != NULL) + wrong_type_argument (Qjson_value_p, lisp); + int status = json_object_set_new (*json, key_str, + lisp_to_json (HASH_VALUE (h, i))); + if (status == -1) + { + /* A failure can be caused either by an invalid key or + by low memory. */ + json_check_utf8 (key); + json_out_of_memory (); + } + } + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + else if (NILP (lisp)) + { + *json = json_check (json_object ()); + return Qnil; + } + else if (CONSP (lisp)) + { + Lisp_Object tail = lisp; + *json = json_check (json_object ()); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, *json); + FOR_EACH_TAIL (tail) + { + Lisp_Object pair = XCAR (tail); + CHECK_CONS (pair); + Lisp_Object key_symbol = XCAR (pair); + Lisp_Object value = XCDR (pair); + CHECK_SYMBOL (key_symbol); + Lisp_Object key = SYMBOL_NAME (key_symbol); + /* We can't specify the length, so the string must be + null-terminated. */ + check_string_without_embedded_nulls (key); + const char *key_str = SSDATA (key); + /* Only add element if key is not already present. */ + if (json_object_get (*json, key_str) == NULL) + { + int status + = json_object_set_new (*json, key_str, lisp_to_json (value)); + if (status == -1) + json_out_of_memory (); + } + } + CHECK_LIST_END (tail, lisp); + 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, + hashtable, or alist. */ + +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); + json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded)); + if (json == NULL) + { + /* A failure can be caused either by an invalid string or by + low memory. */ + json_check_utf8 (encoded); + json_out_of_memory (); + } + return json; + } + + /* LISP now must be a vector, hashtable, or alist. */ + 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, hashtable, or alist, and its elements can +recursively contain `:null', `:false', t, numbers, strings, or other +vectors hashtables, and alist. `:null', `:false', and t will be +converted to JSON null, false, and true values, respectively. Vectors +will be converted to JSON arrays, and hashtables and alists to JSON +objects. Hashtable keys must be strings without embedded null +characters and must be unique within each object. Alist keys must be +symbols; if a key is duplicate, the first instance is used. */) + (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); + + /* If desired, we might want to add the following flags: + JSON_DECODE_ANY, JSON_ALLOW_NUL. */ + 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; + /* If desired, we might want to add the following flags: + JSON_DECODE_ANY, JSON_ALLOW_NUL. */ + 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); +} + +enum json_object_type { + json_object_hashtable, + json_object_alist, +}; + +/* Convert a JSON object to a Lisp object. */ + +static _GL_ARG_NONNULL ((1)) Lisp_Object +json_to_lisp (json_t *json, enum json_object_type object_type) +{ + 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), object_type)); + --lisp_eval_depth; + return result; + } + case JSON_OBJECT: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + Lisp_Object result; + switch (object_type) + { + case json_object_hashtable: + { + size_t size = json_object_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal0 (Qoverflow_error); + 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, object_type), hash); + } + break; + } + case json_object_alist: + { + result = Qnil; + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + Lisp_Object key = Fintern (json_build_string (key_str), Qnil); + result + = Fcons (Fcons (key, json_to_lisp (value, object_type)), + result); + } + result = Fnreverse (result); + break; + } + default: + /* Can't get here. */ + emacs_abort (); + } + --lisp_eval_depth; + return result; + } + } + /* Can't get here. */ + emacs_abort (); +} + +static enum json_object_type +json_parse_object_type (ptrdiff_t nargs, Lisp_Object *args) +{ + switch (nargs) + { + case 0: + return json_object_hashtable; + case 2: + { + Lisp_Object key = args[0]; + Lisp_Object value = args[1]; + if (!EQ (key, QCobject_type)) + wrong_choice (list1 (QCobject_type), key); + if (EQ (value, Qhash_table)) + return json_object_hashtable; + else if (EQ (value, Qalist)) + return json_object_alist; + else + wrong_choice (list2 (Qhash_table, Qalist), value); + } + default: + wrong_type_argument (Qplistp, Flist (nargs, args)); + } +} + +DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY, + 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, hashtable, or alist. Its +elements will be `:null', `:false', t, numbers, strings, or further +vectors, hashtables, and alists. 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. +The keyword argument `:object-type' specifies which Lisp type is used +to represent objects; it can be `hash-table' or `alist'. +usage: (json-parse-string STRING &key (OBJECT-TYPE \\='hash-table)) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + 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 string = args[0]; + Lisp_Object encoded = json_encode (string); + check_string_without_embedded_nulls (encoded); + enum json_object_type object_type + = json_parse_object_type (nargs - 1, args + 1); + + 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, object_type)); +} + +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, MANY, 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. +usage: (json-parse-buffer &key (OBJECT-TYPE \\='hash-table)) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + 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 + + enum json_object_type object_type = json_parse_object_type (nargs, args); + + 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, object_type); + + /* 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_string_p, "utf-8-string-p"); + + 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); + + DEFSYM (QCobject_type, ":object-type"); + DEFSYM (Qalist, "alist"); + + 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 16744acba88..75fbe459b2b 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); @@ -1869,6 +1871,7 @@ int poll_suppress_count; static struct atimer *poll_timer; +#if defined CYGWIN || defined DOS_NT /* Poll for input, so that we catch a C-g if it comes in. */ void poll_for_input_1 (void) @@ -1877,6 +1880,7 @@ poll_for_input_1 (void) && !waiting_for_input) gobble_input (); } +#endif /* Timer callback function for poll_timer. TIMER is equal to poll_timer. */ @@ -1928,20 +1932,22 @@ start_polling (void) #endif } +#if defined CYGWIN || defined DOS_NT /* True if we are using polling to handle input asynchronously. */ bool input_polling_used (void) { -#ifdef POLL_FOR_INPUT +# ifdef POLL_FOR_INPUT /* XXX This condition was (read_socket_hook && !interrupt_input), but read_socket_hook is not global anymore. Let's pretend that it's always set. */ return !interrupt_input; -#else - return 0; -#endif +# else + return false; +# endif } +#endif /* Turn off polling. */ @@ -2809,6 +2815,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: @@ -3727,7 +3736,7 @@ kbd_buffer_events_waiting (void) /* Clear input event EVENT. */ static void -clear_event (union buffered_input_event *event) +clear_event (struct input_event *event) { event->kind = NO_EVENT; } @@ -3864,8 +3873,10 @@ kbd_buffer_get_event (KBOARD **kbp, /* These two kinds of events get special handling and don't actually appear to the command loop. We return nil for them. */ - if (event->kind == SELECTION_REQUEST_EVENT - || event->kind == SELECTION_CLEAR_EVENT) + switch (event->kind) + { + case SELECTION_REQUEST_EVENT: + case SELECTION_CLEAR_EVENT: { #ifdef HAVE_X11 /* Remove it from the buffer before processing it, @@ -3881,202 +3892,58 @@ kbd_buffer_get_event (KBOARD **kbp, emacs_abort (); #endif } + break; -#if defined (HAVE_NS) - else if (event->kind == NS_TEXT_EVENT) - { - if (event->ie.code == KEY_NS_PUT_WORKING_TEXT) - obj = list1 (intern ("ns-put-working-text")); - else - obj = list1 (intern ("ns-unput-working-text")); - kbd_fetch_ptr = event + 1; - if (used_mouse_menu) - *used_mouse_menu = true; - } -#endif - -#if defined (HAVE_X11) || defined (HAVE_NTGUI) \ - || defined (HAVE_NS) - else if (event->kind == DELETE_WINDOW_EVENT) - { - /* Make an event (delete-frame (FRAME)). */ - obj = list2 (Qdelete_frame, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } -#endif - -#ifdef HAVE_NTGUI - else if (event->kind == END_SESSION_EVENT) - { - /* Make an event (end-session). */ - obj = list1 (Qend_session); - kbd_fetch_ptr = event + 1; - } -#endif - -#if defined (HAVE_X11) || defined (HAVE_NTGUI) \ - || defined (HAVE_NS) - else if (event->kind == ICONIFY_EVENT) - { - /* Make an event (iconify-frame (FRAME)). */ - obj = list2 (Qiconify_frame, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } - else if (event->kind == DEICONIFY_EVENT) - { - /* Make an event (make-frame-visible (FRAME)). */ - obj = list2 (Qmake_frame_visible, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } -#endif - else if (event->kind == BUFFER_SWITCH_EVENT) - { - /* The value doesn't matter here; only the type is tested. */ - XSETBUFFER (obj, current_buffer); - kbd_fetch_ptr = event + 1; - } #if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ || defined (HAVE_NS) || defined (USE_GTK) - else if (event->kind == MENU_BAR_ACTIVATE_EVENT) + case MENU_BAR_ACTIVATE_EVENT: { kbd_fetch_ptr = event + 1; input_pending = readable_events (0); if (FRAME_LIVE_P (XFRAME (event->ie.frame_or_window))) x_activate_menubar (XFRAME (event->ie.frame_or_window)); } + break; +#endif +#if defined (HAVE_NS) + case NS_TEXT_EVENT: + if (used_mouse_menu) + *used_mouse_menu = true; + FALLTHROUGH; #endif #ifdef HAVE_NTGUI - else if (event->kind == LANGUAGE_CHANGE_EVENT) - { - /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID). */ - obj = list4 (Qlanguage_change, - event->ie.frame_or_window, - make_number (event->ie.code), - make_number (event->ie.modifiers)); - kbd_fetch_ptr = event + 1; - } + case END_SESSION_EVENT: + case LANGUAGE_CHANGE_EVENT: #endif -#ifdef USE_FILE_NOTIFY - else if (event->kind == FILE_NOTIFY_EVENT) - { -#ifdef HAVE_W32NOTIFY - /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK). */ - obj = list3 (Qfile_notify, event->ie.arg, event->ie.frame_or_window); -#else - obj = make_lispy_event (&event->ie); +#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS) + case DELETE_WINDOW_EVENT: + case ICONIFY_EVENT: + case DEICONIFY_EVENT: + case MOVE_FRAME_EVENT: #endif - kbd_fetch_ptr = event + 1; - } -#endif /* USE_FILE_NOTIFY */ - else if (event->kind == SAVE_SESSION_EVENT) - { - obj = list2 (Qsave_session, event->ie.arg); - kbd_fetch_ptr = event + 1; - } - /* Just discard these, by returning nil. - With MULTI_KBOARD, these events are used as placeholders - when we need to randomly delete events from the queue. - (They shouldn't otherwise be found in the buffer, - but on some machines it appears they do show up - even without MULTI_KBOARD.) */ - /* On Windows NT/9X, NO_EVENT is used to delete extraneous - mouse events during a popup-menu call. */ - else if (event->kind == NO_EVENT) - kbd_fetch_ptr = event + 1; - else if (event->kind == HELP_EVENT) - { - Lisp_Object object, position, help, frame, window; - - frame = event->ie.frame_or_window; - object = event->ie.arg; - position = make_number (Time_to_position (event->ie.timestamp)); - window = event->ie.x; - help = event->ie.y; - clear_event (event); - - kbd_fetch_ptr = event + 1; - if (!WINDOWP (window)) - window = Qnil; - obj = Fcons (Qhelp_echo, - list5 (frame, help, window, object, position)); - } - else if (event->kind == FOCUS_IN_EVENT) - { - /* Notification of a FocusIn event. The frame receiving the - focus is in event->frame_or_window. Generate a - switch-frame event if necessary. */ - Lisp_Object frame, focus; - - frame = event->ie.frame_or_window; - focus = FRAME_FOCUS_FRAME (XFRAME (frame)); - if (FRAMEP (focus)) - frame = focus; - - if ( -#ifdef HAVE_X11 - ! NILP (event->ie.arg) - && +#ifdef USE_FILE_NOTIFY + case FILE_NOTIFY_EVENT: #endif - !EQ (frame, internal_last_event_frame) - && !EQ (frame, selected_frame)) - obj = make_lispy_switch_frame (frame); - else - obj = make_lispy_focus_in (frame); - - internal_last_event_frame = frame; - kbd_fetch_ptr = event + 1; - } - else if (event->kind == FOCUS_OUT_EVENT) - { -#ifdef HAVE_WINDOW_SYSTEM - - Display_Info *di; - Lisp_Object frame = event->ie.frame_or_window; - bool focused = false; - - for (di = x_display_list; di && ! focused; di = di->next) - focused = di->x_highlight_frame != 0; - - if (!focused) - obj = make_lispy_focus_out (frame); - -#endif /* HAVE_WINDOW_SYSTEM */ - - kbd_fetch_ptr = event + 1; - } #ifdef HAVE_DBUS - else if (event->kind == DBUS_EVENT) - { - obj = make_lispy_event (&event->ie); - kbd_fetch_ptr = event + 1; - } -#endif -#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS) - else if (event->kind == MOVE_FRAME_EVENT) - { - /* Make an event (move-frame (FRAME)). */ - obj = list2 (Qmove_frame, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } + case DBUS_EVENT: #endif #ifdef HAVE_XWIDGETS - else if (event->kind == XWIDGET_EVENT) - { - obj = make_lispy_event (&event->ie); - kbd_fetch_ptr = event + 1; - } + case XWIDGET_EVENT: #endif - else if (event->kind == CONFIG_CHANGED_EVENT) - { - obj = make_lispy_event (&event->ie); - kbd_fetch_ptr = event + 1; - } - else if (event->kind == SELECT_WINDOW_EVENT) - { - obj = list2 (Qselect_window, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } - else + case BUFFER_SWITCH_EVENT: + case SAVE_SESSION_EVENT: + case NO_EVENT: + case HELP_EVENT: + case FOCUS_IN_EVENT: + case CONFIG_CHANGED_EVENT: + case FOCUS_OUT_EVENT: + case SELECT_WINDOW_EVENT: + { + obj = make_lispy_event (&event->ie); + kbd_fetch_ptr = event + 1; + } + break; + default: { /* If this event is on a different frame, return a switch-frame this time, and leave the event in the queue for next time. */ @@ -4126,10 +3993,11 @@ kbd_buffer_get_event (KBOARD **kbp, #endif /* Wipe out this event, to catch bugs. */ - clear_event (event); + clear_event (&event->ie); kbd_fetch_ptr = event + 1; } } + } } /* Try generating a mouse motion event. */ else if (!NILP (do_mouse_tracking) && some_mouse_moved ()) @@ -5439,7 +5307,101 @@ make_lispy_event (struct input_event *event) switch (event->kind) { - /* A simple keystroke. */ +#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS) + case DELETE_WINDOW_EVENT: + /* Make an event (delete-frame (FRAME)). */ + return list2 (Qdelete_frame, list1 (event->frame_or_window)); + + case ICONIFY_EVENT: + /* Make an event (iconify-frame (FRAME)). */ + return list2 (Qiconify_frame, list1 (event->frame_or_window)); + + case DEICONIFY_EVENT: + /* Make an event (make-frame-visible (FRAME)). */ + return list2 (Qmake_frame_visible, list1 (event->frame_or_window)); + + case MOVE_FRAME_EVENT: + /* Make an event (move-frame (FRAME)). */ + return list2 (Qmove_frame, list1 (event->frame_or_window)); +#endif + + case BUFFER_SWITCH_EVENT: + { + /* The value doesn't matter here; only the type is tested. */ + Lisp_Object obj; + XSETBUFFER (obj, current_buffer); + return obj; + } + + /* Just discard these, by returning nil. + With MULTI_KBOARD, these events are used as placeholders + when we need to randomly delete events from the queue. + (They shouldn't otherwise be found in the buffer, + but on some machines it appears they do show up + even without MULTI_KBOARD.) */ + /* On Windows NT/9X, NO_EVENT is used to delete extraneous + mouse events during a popup-menu call. */ + case NO_EVENT: + return Qnil; + + case HELP_EVENT: + { + Lisp_Object frame = event->frame_or_window; + Lisp_Object object = event->arg; + Lisp_Object position + = make_number (Time_to_position (event->timestamp)); + Lisp_Object window = event->x; + Lisp_Object help = event->y; + clear_event (event); + + if (!WINDOWP (window)) + window = Qnil; + return Fcons (Qhelp_echo, + list5 (frame, help, window, object, position)); + } + + case FOCUS_IN_EVENT: + { + /* Notification of a FocusIn event. The frame receiving the + focus is in event->frame_or_window. Generate a + switch-frame event if necessary. */ + + Lisp_Object frame = event->frame_or_window; + Lisp_Object focus = FRAME_FOCUS_FRAME (XFRAME (frame)); + if (FRAMEP (focus)) + frame = focus; + bool switching + = ( +#ifdef HAVE_X11 + ! NILP (event->arg) + && +#endif + !EQ (frame, internal_last_event_frame) + && !EQ (frame, selected_frame)); + internal_last_event_frame = frame; + + return (switching ? make_lispy_switch_frame (frame) + : make_lispy_focus_in (frame)); + } + + case FOCUS_OUT_EVENT: + { +#ifdef HAVE_WINDOW_SYSTEM + + Display_Info *di; + Lisp_Object frame = event->frame_or_window; + bool focused = false; + + for (di = x_display_list; di && ! focused; di = di->next) + focused = di->x_highlight_frame != 0; + + return focused ? Qnil + : make_lispy_focus_out (frame); + +#endif /* HAVE_WINDOW_SYSTEM */ + } + + /* A simple keystroke. */ case ASCII_KEYSTROKE_EVENT: case MULTIBYTE_CHAR_KEYSTROKE_EVENT: { @@ -5503,6 +5465,11 @@ make_lispy_event (struct input_event *event) } #ifdef HAVE_NS + case NS_TEXT_EVENT: + return list1 (intern (event->code == KEY_NS_PUT_WORKING_TEXT + ? "ns-put-working-text" + : "ns-unput-working-text")); + /* NS_NONKEY_EVENTs are just like NON_ASCII_KEYSTROKE_EVENTs, except that they are non-key events (last-nonmenu-event is nil). */ case NS_NONKEY_EVENT: @@ -5565,6 +5532,17 @@ make_lispy_event (struct input_event *event) PTRDIFF_MAX); #ifdef HAVE_NTGUI + case END_SESSION_EVENT: + /* Make an event (end-session). */ + return list1 (Qend_session); + + case LANGUAGE_CHANGE_EVENT: + /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID). */ + return list4 (Qlanguage_change, + event->frame_or_window, + make_number (event->code), + make_number (event->modifiers)); + case MULTIMEDIA_KEY_EVENT: if (event->code < ARRAYELTS (lispy_multimedia_keys) && event->code > 0 && lispy_multimedia_keys[event->code]) @@ -6058,7 +6036,7 @@ make_lispy_event (struct input_event *event) } case SAVE_SESSION_EVENT: - return Qsave_session; + return list2 (Qsave_session, event->arg); #ifdef HAVE_DBUS case DBUS_EVENT: @@ -6074,12 +6052,15 @@ make_lispy_event (struct input_event *event) } #endif -#if defined HAVE_INOTIFY || defined HAVE_KQUEUE || defined HAVE_GFILENOTIFY +#ifdef USE_FILE_NOTIFY case FILE_NOTIFY_EVENT: - { - return Fcons (Qfile_notify, event->arg); - } -#endif /* HAVE_INOTIFY || HAVE_KQUEUE || HAVE_GFILENOTIFY */ +#ifdef HAVE_W32NOTIFY + /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK). */ + return list3 (Qfile_notify, event->arg, event->frame_or_window); +#else + return Fcons (Qfile_notify, event->arg); +#endif +#endif /* USE_FILE_NOTIFY */ case CONFIG_CHANGED_EVENT: return list3 (Qconfig_changed_event, @@ -8450,7 +8431,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 +8841,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 +8902,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 +8956,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 +9015,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 +9333,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 +9828,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); @@ -10294,7 +10286,7 @@ stuff_buffered_input (Lisp_Object stuffstring) if (kbd_fetch_ptr->kind == ASCII_KEYSTROKE_EVENT) stuff_char (kbd_fetch_ptr->ie.code); - clear_event (kbd_fetch_ptr); + clear_event (&kbd_fetch_ptr->ie); } input_pending = false; diff --git a/src/keyboard.h b/src/keyboard.h index 9106646ced2..cae949893f4 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/kqueue.c b/src/kqueue.c index 69d5269d302..7a4f6a471c4 100644 --- a/src/kqueue.c +++ b/src/kqueue.c @@ -24,7 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <sys/types.h> #include <sys/event.h> #include <sys/time.h> -#include <sys/file.h> +#include <fcntl.h> #include "lisp.h" #include "keyboard.h" #include "process.h" diff --git a/src/lastfile.c b/src/lastfile.c index fe8ac85a320..ec5311158e5 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 57e4f4b9853..a7f0a1d78ff 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 @@ -542,24 +583,29 @@ enum Lisp_Fwd_Type resources allocated for it that are not Lisp objects. You can even make a pointer to the function that frees the resources a slot in your object -- this way, the same object could be used to represent - several disparate C structures. */ + several disparate C structures. -#ifdef CHECK_LISP_OBJECT_TYPE - -typedef struct Lisp_Object { EMACS_INT i; } Lisp_Object; + You also need to add the new type to the constant + `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */ -#define LISP_INITIALLY(i) {i} -#undef CHECK_LISP_OBJECT_TYPE -enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; -#else /* CHECK_LISP_OBJECT_TYPE */ +/* 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;'. -/* If a struct type is not wanted, define Lisp_Object as just a number. */ + 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. */ -typedef EMACS_INT Lisp_Object; -#define LISP_INITIALLY(i) (i) +#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 +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 +637,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 +654,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 +693,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 +806,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 +909,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 +921,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 +1152,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 +1223,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 +1735,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 +3052,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 +3545,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 +3974,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); @@ -4042,7 +4130,7 @@ extern _Noreturn void report_file_error (const char *, Lisp_Object); extern _Noreturn void report_file_notify_error (const char *, Lisp_Object); extern bool internal_delete_file (Lisp_Object); extern Lisp_Object emacs_readlinkat (int, const char *); -extern bool file_directory_p (const char *); +extern bool file_directory_p (Lisp_Object); extern bool file_accessible_directory_p (Lisp_Object); extern void init_fileio (void); extern void syms_of_fileio (void); @@ -4397,6 +4485,11 @@ extern void syms_of_gfilenotify (void); extern void syms_of_w32notify (void); #endif +#if defined HAVE_NTGUI || defined CYGWIN +/* Defined in w32cygwinx.c. */ +extern void syms_of_w32cygwinx (void); +#endif + /* Defined in xfaces.c. */ extern Lisp_Object Vface_alternative_font_family_alist; extern Lisp_Object Vface_alternative_font_registry_alist; @@ -4422,9 +4515,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 3104c441ecf..7cacd47d510 100644 --- a/src/lread.c +++ b/src/lread.c @@ -147,10 +147,10 @@ static ptrdiff_t prev_saved_doc_string_length; /* This is the file position that string came from. */ static file_offset prev_saved_doc_string_position; -/* True means inside a new-style backquote - with no surrounding parentheses. - Fread initializes this to false, so we need not specbind it - or worry about what happens to it when there is an error. */ +/* True means inside a new-style backquote with no surrounding + parentheses. Fread initializes this to the value of + `force_new_style_backquotes', so we need not specbind it or worry + about what happens to it when there is an error. */ static bool new_backquote_flag; /* A list of file names for files being loaded in Fload. Used to @@ -164,6 +164,8 @@ static int read_emacs_mule_char (int, int (*) (int, Lisp_Object), static void readevalloop (Lisp_Object, struct infile *, Lisp_Object, bool, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + +static void build_load_history (Lisp_Object, bool); /* Functions that read one byte from the current source READCHARFUN or unreads one byte. If the integer argument C is -1, it returns @@ -1003,13 +1005,15 @@ 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)) + if (NILP (Vload_file_name)) + xsignal1 (Qerror, build_string ("Old-style backquotes detected!")); + else { AUTO_STRING (format, "Loading `%s': old-style backquotes detected!"); - CALLN (Fmessage, format, file); + xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name)); } } @@ -1244,8 +1248,9 @@ Return t if the file exists and loads successfully. */) } #ifdef HAVE_MODULES - if (suffix_p (found, MODULES_SUFFIX)) - return unbind_to (count, Fmodule_load (found)); + bool is_module = suffix_p (found, MODULES_SUFFIX); +#else + bool is_module = false; #endif /* Check if we're stuck in a recursive load cycle. @@ -1282,10 +1287,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); @@ -1350,7 +1351,7 @@ Return t if the file exists and loads successfully. */) } /* !load_prefer_newer */ } } - else + else if (!is_module) { /* We are loading a source file (*.el). */ if (!NILP (Vload_source_file_function)) @@ -1377,7 +1378,7 @@ Return t if the file exists and loads successfully. */) stream = NULL; errno = EINVAL; } - else + else if (!is_module) { #ifdef WINDOWSNT emacs_close (fd); @@ -1388,9 +1389,23 @@ Return t if the file exists and loads successfully. */) stream = fdopen (fd, fmode); #endif } - if (! stream) - report_file_error ("Opening stdio stream", file); - set_unwind_protect_ptr (fd_index, close_infile_unwind, stream); + + if (is_module) + { + /* `module-load' uses the file name, so we can close the stream + now. */ + if (fd >= 0) + { + emacs_close (fd); + clear_unwind_protect (fd_index); + } + } + else + { + if (! stream) + report_file_error ("Opening stdio stream", file); + set_unwind_protect_ptr (fd_index, close_infile_unwind, stream); + } if (! NILP (Vpurify_flag)) Vpreloaded_file_list = Fcons (Fpurecopy (file), Vpreloaded_file_list); @@ -1400,6 +1415,8 @@ Return t if the file exists and loads successfully. */) if (!safe_p) message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...", file, 1); + else if (is_module) + message_with_string ("Loading %s (module)...", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...", file, 1); else if (newer) @@ -1413,24 +1430,39 @@ Return t if the file exists and loads successfully. */) specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); - struct infile input; - input.stream = stream; - input.lookahead = 0; - infile = &input; - - if (lisp_file_lexically_bound_p (Qget_file_char)) - Fset (Qlexical_binding, Qt); - - if (! version || version >= 22) - readevalloop (Qget_file_char, &input, hist_file_name, - 0, Qnil, Qnil, Qnil, Qnil); + if (is_module) + { +#ifdef HAVE_MODULES + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fmodule_load (found); + build_load_history (found, true); +#else + /* This cannot happen. */ + emacs_abort (); +#endif + } else { - /* We can't handle a file which was compiled with - byte-compile-dynamic by older version of Emacs. */ - specbind (Qload_force_doc_strings, Qt); - readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name, - 0, Qnil, Qnil, Qnil, Qnil); + struct infile input; + input.stream = stream; + input.lookahead = 0; + infile = &input; + + if (lisp_file_lexically_bound_p (Qget_file_char)) + Fset (Qlexical_binding, Qt); + + if (! version || version >= 22) + readevalloop (Qget_file_char, &input, hist_file_name, + 0, Qnil, Qnil, Qnil, Qnil); + else + { + /* We can't handle a file which was compiled with + byte-compile-dynamic by older version of Emacs. */ + specbind (Qload_force_doc_strings, Qt); + readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name, + 0, Qnil, Qnil, Qnil, Qnil); + } } unbind_to (count, Qnil); @@ -1451,6 +1483,8 @@ Return t if the file exists and loads successfully. */) if (!safe_p) message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done", file, 1); + else if (is_module) + message_with_string ("Loading %s (module)...done", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...done", file, 1); else if (newer) @@ -1668,7 +1702,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, AT_EACCESS) == 0) { - if (file_directory_p (pfn)) + if (file_directory_p (encoded_fn)) last_errno = EISDIR; else fd = 1; @@ -2194,7 +2228,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) Lisp_Object retval; readchar_count = 0; - new_backquote_flag = 0; + new_backquote_flag = force_new_style_backquotes; /* We can get called from readevalloop which may have set these already. */ if (! HASH_TABLE_P (read_objects_map) @@ -2269,7 +2303,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 +3212,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 +3263,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 +3451,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; @@ -3479,6 +3506,13 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (! NILP (result)) return unbind_to (count, result); } + if (!quoted && multibyte) + { + int ch = STRING_CHAR ((unsigned char *) read_buffer); + if (confusable_symbol_character_p (ch)) + xsignal2 (Qinvalid_read_syntax, build_string ("strange quote"), + CALLN (Fstring, make_number (ch))); + } { Lisp_Object result; ptrdiff_t nbytes = p - read_buffer; @@ -4978,12 +5012,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'. @@ -5008,6 +5036,17 @@ Note that if you customize this, obviously it will not affect files that are loaded before your customizations are read! */); load_prefer_newer = 0; + DEFVAR_BOOL ("force-new-style-backquotes", force_new_style_backquotes, + doc: /* Non-nil means to always use the current syntax for backquotes. +If nil, `load' and `read' raise errors when encountering some +old-style variants of backquote and comma. If non-nil, these +constructs are always interpreted as described in the Info node +`(elisp)Backquotes', even if that interpretation is incompatible with +previous versions of Emacs. Setting this variable to non-nil makes +Emacs compatible with the behavior planned for Emacs 28. In Emacs 28, +this variable will become obsolete. */); + force_new_style_backquotes = false; + /* Vsource_directory was initialized in init_lread. */ DEFSYM (Qcurrent_load_list, "current-load-list"); diff --git a/src/macfont.m b/src/macfont.m index dd7c50f2719..817071fa44f 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -1441,8 +1441,6 @@ macfont_get_glyph_for_character (struct font *font, UTF32Char c) CGGlyph *glyphs; int i, len; int nrows; - dispatch_queue_t queue; - dispatch_group_t group = NULL; int nkeys; if (row != 0) diff --git a/src/menu.c b/src/menu.c index d5e1638b7cd..93e793a5d91 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 4c4ac83424f..104f6dc81d2 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 94e975eaa21..eedbf7b1a6c 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/nsfns.m b/src/nsfns.m index 7f2f060dda8..0f60bb8107f 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -1896,10 +1896,12 @@ If omitted or nil, that stands for the selected frame's display. */) { case NSBackingStoreBuffered: return intern ("buffered"); +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 case NSBackingStoreRetained: return intern ("retained"); case NSBackingStoreNonretained: return intern ("non-retained"); +#endif default: error ("Strange value for backingType parameter of frame"); } @@ -1953,9 +1955,11 @@ If omitted or nil, that stands for the selected frame's display. */) case NSBackingStoreBuffered: return Qt; +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 case NSBackingStoreRetained: case NSBackingStoreNonretained: return Qnil; +#endif default: error ("Strange value for backingType parameter of frame"); @@ -2749,10 +2753,6 @@ If omitted or nil, that stands for the selected frame's display. */) return make_number (1 << min (dpyinfo->n_planes, 24)); } - -/* Unused dummy def needed for compatibility. */ -Lisp_Object tip_frame; - /* TODO: move to xdisp or similar */ static void compute_tip_xy (struct frame *f, @@ -2869,6 +2869,8 @@ Text larger than the specified size is clipped. */) struct frame *f; char *str; NSSize size; + NSColor *color; + Lisp_Object t; specbind (Qinhibit_redisplay, Qt); @@ -2896,6 +2898,14 @@ Text larger than the specified size is clipped. */) else Fx_hide_tip (); + t = x_get_arg (NULL, parms, Qbackground_color, NULL, NULL, RES_TYPE_STRING); + if (ns_lisp_to_color (t, &color) == 0) + [ns_tooltip setBackgroundColor: color]; + + t = x_get_arg (NULL, parms, Qforeground_color, NULL, NULL, RES_TYPE_STRING); + if (ns_lisp_to_color (t, &color) == 0) + [ns_tooltip setForegroundColor: color]; + [ns_tooltip setText: str]; size = [ns_tooltip frame].size; @@ -3121,6 +3131,19 @@ position (0, 0) of the selected frame's terminal. */) (pt.y - screen.frame.origin.y))); } +DEFUN ("ns-show-character-palette", + Fns_show_character_palette, + Sns_show_character_palette, 0, 0, 0, + doc: /* Show the macOS character palette. */) + (void) +{ + struct frame *f = SELECTED_FRAME (); + EmacsView *view = FRAME_NS_VIEW (f); + [NSApp orderFrontCharacterPalette:view]; + + return Qnil; +} + /* ========================================================================== Class implementations @@ -3312,6 +3335,7 @@ be used as the image of the icon representing the frame. */); defsubr (&Sns_frame_restack); defsubr (&Sns_set_mouse_absolute_pixel_position); defsubr (&Sns_mouse_absolute_pixel_position); + defsubr (&Sns_show_character_palette); defsubr (&Sx_display_mm_width); defsubr (&Sx_display_mm_height); defsubr (&Sx_display_screens); diff --git a/src/nsimage.m b/src/nsimage.m index 6bce61626ff..e9af58b8afa 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/nsmenu.m b/src/nsmenu.m index 604adcf40b5..58b45fb38e5 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -1373,6 +1373,16 @@ update_frame_tool_bar (struct frame *f) [textField setFrame: r]; } +- (void) setBackgroundColor: (NSColor *)col +{ + [textField setBackgroundColor: col]; +} + +- (void) setForegroundColor: (NSColor *)col +{ + [textField setTextColor: col]; +} + - (void) showAtX: (int)x Y: (int)y for: (int)seconds { NSRect wr = [win frame]; diff --git a/src/nsselect.m b/src/nsselect.m index bee628b7576..d8b4e2c7af8 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -36,7 +36,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) static Lisp_Object Vselection_alist; -/* NSGeneralPboard is pretty much analogous to X11 CLIPBOARD */ +/* NSPasteboardNameGeneral is pretty much analogous to X11 CLIPBOARD */ static NSString *NXPrimaryPboard; static NSString *NXSecondaryPboard; @@ -54,7 +54,7 @@ static NSString * symbol_to_nsstring (Lisp_Object sym) { CHECK_SYMBOL (sym); - if (EQ (sym, QCLIPBOARD)) return NSGeneralPboard; + if (EQ (sym, QCLIPBOARD)) return NSPasteboardNameGeneral; if (EQ (sym, QPRIMARY)) return NXPrimaryPboard; if (EQ (sym, QSECONDARY)) return NXSecondaryPboard; if (EQ (sym, QTEXT)) return NSStringPboardType; @@ -70,7 +70,7 @@ ns_symbol_to_pb (Lisp_Object symbol) static Lisp_Object ns_string_to_symbol (NSString *t) { - if ([t isEqualToString: NSGeneralPboard]) + if ([t isEqualToString: NSPasteboardNameGeneral]) return QCLIPBOARD; if ([t isEqualToString: NXPrimaryPboard]) return QPRIMARY; @@ -469,7 +469,7 @@ nxatoms_of_nsselect (void) pasteboard_changecount = [[NSMutableDictionary dictionaryWithObjectsAndKeys: - [NSNumber numberWithLong:0], NSGeneralPboard, + [NSNumber numberWithLong:0], NSPasteboardNameGeneral, [NSNumber numberWithLong:0], NXPrimaryPboard, [NSNumber numberWithLong:0], NXSecondaryPboard, [NSNumber numberWithLong:0], NSStringPboardType, diff --git a/src/nsterm.h b/src/nsterm.h index 588b9fc6443..cc4c6d5e910 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -585,6 +585,8 @@ typedef id instancetype; } - (instancetype) init; - (void) setText: (char *)text; +- (void) setBackgroundColor: (NSColor *)col; +- (void) setForegroundColor: (NSColor *)col; - (void) showAtX: (int)x Y: (int)y for: (int)seconds; - (void) hide; - (BOOL) isActive; @@ -646,6 +648,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 +1310,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__ @@ -1319,5 +1324,10 @@ enum NSWindowTabbingMode NSWindowTabbingModePreferred, NSWindowTabbingModeDisallowed }; +#endif /* !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_12) */ + +#if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_13) +/* Deprecated in macOS 10.13. */ +#define NSPasteboardNameGeneral NSGeneralPboard #endif #endif /* HAVE_NS */ diff --git a/src/nsterm.m b/src/nsterm.m index 51a53828b5b..b7f5a32c098 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -37,6 +37,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #include <time.h> #include <signal.h> #include <unistd.h> +#include <stdbool.h> #include <c-ctype.h> #include <c-strcase.h> @@ -1735,7 +1736,6 @@ x_set_offset (struct frame *f, int xoff, int yoff, int change_grav) -------------------------------------------------------------------------- */ { NSView *view = FRAME_NS_VIEW (f); - NSArray *screens = [NSScreen screens]; NSScreen *screen = [[view window] screen]; NSTRACE ("x_set_offset"); @@ -5945,7 +5945,6 @@ not_in_argv (NSString *arg) @end /* EmacsApp */ - /* ========================================================================== EmacsView implementation @@ -6030,7 +6029,13 @@ not_in_argv (NSString *arg) if (!NSIsEmptyRect (visible)) [self addCursorRect: visible cursor: currentCursor]; - [currentCursor setOnMouseEntered: YES]; + +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 + if ([currentCursor respondsToSelector: @selector(setOnMouseEntered)]) +#endif + [currentCursor setOnMouseEntered: YES]; +#endif } @@ -6045,7 +6050,6 @@ not_in_argv (NSString *arg) int code; unsigned fnKeysym = 0; static NSMutableArray *nsEvArray; - int left_is_none; unsigned int flags = [theEvent modifierFlags]; NSTRACE ("[EmacsView keyDown:]"); @@ -6087,10 +6091,8 @@ not_in_argv (NSString *arg) if (!processingCompose) { - /* When using screen sharing, no left or right information is sent, - so use Left key in those cases. */ - int is_left_key, is_right_key; - + /* FIXME: What should happen for key sequences with more than + one character? */ code = ([[theEvent charactersIgnoringModifiers] length] == 0) ? 0 : [[theEvent charactersIgnoringModifiers] characterAtIndex: 0]; @@ -6137,131 +6139,47 @@ not_in_argv (NSString *arg) if (flags & NSEventModifierFlagShift) emacs_event->modifiers |= shift_modifier; - is_right_key = (flags & NSRightCommandKeyMask) == NSRightCommandKeyMask; - is_left_key = (flags & NSLeftCommandKeyMask) == NSLeftCommandKeyMask - || (! is_right_key && (flags & NSEventModifierFlagCommand) == NSEventModifierFlagCommand); - - if (is_right_key) - emacs_event->modifiers |= parse_solitary_modifier - (EQ (ns_right_command_modifier, Qleft) - ? ns_command_modifier - : ns_right_command_modifier); - - if (is_left_key) - { - emacs_event->modifiers |= parse_solitary_modifier - (ns_command_modifier); - - /* if super (default), take input manager's word so things like - dvorak / qwerty layout work */ - if (EQ (ns_command_modifier, Qsuper) - && !fnKeysym - && [[theEvent characters] length] != 0) - { - /* XXX: the code we get will be unshifted, so if we have - a shift modifier, must convert ourselves */ - if (!(flags & NSEventModifierFlagShift)) - code = [[theEvent characters] characterAtIndex: 0]; -#if 0 - /* this is ugly and also requires linking w/Carbon framework - (for LMGetKbdType) so for now leave this rare (?) case - undealt with.. in future look into CGEvent methods */ - else - { - long smv = GetScriptManagerVariable (smKeyScript); - Handle uchrHandle = GetResource - ('uchr', GetScriptVariable (smv, smScriptKeys)); - UInt32 dummy = 0; - UCKeyTranslate ((UCKeyboardLayout *) *uchrHandle, - [[theEvent characters] characterAtIndex: 0], - kUCKeyActionDisplay, - (flags & ~NSEventModifierFlagCommand) >> 8, - LMGetKbdType (), kUCKeyTranslateNoDeadKeysMask, - &dummy, 1, &dummy, &code); - code &= 0xFF; - } -#endif - } - } - - is_right_key = (flags & NSRightControlKeyMask) == NSRightControlKeyMask; - is_left_key = (flags & NSLeftControlKeyMask) == NSLeftControlKeyMask - || (! is_right_key && (flags & NSEventModifierFlagControl) == NSEventModifierFlagControl); - - if (is_right_key) - emacs_event->modifiers |= parse_solitary_modifier - (EQ (ns_right_control_modifier, Qleft) - ? ns_control_modifier - : ns_right_control_modifier); - - if (is_left_key) - emacs_event->modifiers |= parse_solitary_modifier - (ns_control_modifier); - - if (flags & NS_FUNCTION_KEY_MASK && !fnKeysym) - emacs_event->modifiers |= - parse_solitary_modifier (ns_function_modifier); - - left_is_none = NILP (ns_alternate_modifier) - || EQ (ns_alternate_modifier, Qnone); - - is_right_key = (flags & NSRightAlternateKeyMask) - == NSRightAlternateKeyMask; - is_left_key = (flags & NSLeftAlternateKeyMask) == NSLeftAlternateKeyMask - || (! is_right_key - && (flags & NSEventModifierFlagOption) == NSEventModifierFlagOption); - - if (is_right_key) - { - if ((NILP (ns_right_alternate_modifier) - || EQ (ns_right_alternate_modifier, Qnone) - || (EQ (ns_right_alternate_modifier, Qleft) && left_is_none)) - && !fnKeysym) - { /* accept pre-interp alt comb */ - if ([[theEvent characters] length] > 0) - code = [[theEvent characters] characterAtIndex: 0]; - /*HACK: clear lone shift modifier to stop next if from firing */ - if (emacs_event->modifiers == shift_modifier) - emacs_event->modifiers = 0; - } - else - emacs_event->modifiers |= parse_solitary_modifier - (EQ (ns_right_alternate_modifier, Qleft) - ? ns_alternate_modifier - : ns_right_alternate_modifier); - } - - if (is_left_key) /* default = meta */ - { - if (left_is_none && !fnKeysym) - { /* accept pre-interp alt comb */ - if ([[theEvent characters] length] > 0) - code = [[theEvent characters] characterAtIndex: 0]; - /*HACK: clear lone shift modifier to stop next if from firing */ - if (emacs_event->modifiers == shift_modifier) - emacs_event->modifiers = 0; - } - else - emacs_event->modifiers |= - parse_solitary_modifier (ns_alternate_modifier); - } - - if (NS_KEYLOG) - fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n", - (unsigned) code, fnKeysym, flags, emacs_event->modifiers); - - /* if it was a function key or had modifiers, pass it directly to emacs */ + /* The ⌘ and ⌥ modifiers can be either shift-like (for alternate + character input) or control-like (as command prefix). If we + have only shift-like modifiers, then we should use the + translated characters (returned by the characters method); if + we have only control-like modifiers, then we should use the + untranslated characters (returned by the + charactersIgnoringModifiers method). An annoyance happens if + we have both shift-like and control-like modifiers because + the NSEvent API doesn’t let us ignore only some modifiers. + Therefore we ignore all shift-like modifiers in that + case. */ + + /* EV_MODIFIERS2 uses parse_solitary_modifier on all known + modifier keys, which returns 0 for shift-like modifiers. + Therefore its return value is the set of control-like + modifiers. */ + unsigned int control_modifiers = EV_MODIFIERS2 (flags); + emacs_event->modifiers |= control_modifiers; + + if (NS_KEYLOG) + fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n", + code, fnKeysym, flags, emacs_event->modifiers); + + /* If it was a function key or had control-like modifiers, pass + it directly to Emacs. */ if (fnKeysym || (emacs_event->modifiers && (emacs_event->modifiers != shift_modifier) && [[theEvent charactersIgnoringModifiers] length] > 0)) /*[[theEvent characters] length] */ { emacs_event->kind = NON_ASCII_KEYSTROKE_EVENT; + /* FIXME: What are the next four lines supposed to do? */ if (code < 0x20) code |= (1<<28)|(3<<16); else if (code == 0x7f) code |= (1<<28)|(3<<16); else if (!fnKeysym) + /* FIXME: This seems wrong, characters in the range + [0x80, 0xFF] are not ASCII characters. Can’t we just + use MULTIBYTE_CHAR_KEYSTROKE_EVENT here for all kinds + of characters? */ emacs_event->kind = code > 0xFF ? MULTIBYTE_CHAR_KEYSTROKE_EVENT : ASCII_KEYSTROKE_EVENT; @@ -6272,11 +6190,32 @@ not_in_argv (NSString *arg) } } + /* If we get here, a non-function key without control-like modifiers + was hit. Use interpretKeyEvents, which in turn will call + insertText; see + https://developer.apple.com/library/mac/documentation/Cocoa/Conceptual/EventOverview/HandlingKeyEvents/HandlingKeyEvents.html. */ if (NS_KEYLOG && !processingCompose) fprintf (stderr, "keyDown: Begin compose sequence.\n"); + /* FIXME: interpretKeyEvents doesn’t seem to send insertText if ⌘ is + used as shift-like modifier, at least on El Capitan. Mask it + out. This shouldn’t be needed though; we should figure out what + the correct way of handling ⌘ is. */ + if ([theEvent modifierFlags] & NSEventModifierFlagCommand) + theEvent = [NSEvent keyEventWithType:[theEvent type] + location:[theEvent locationInWindow] + modifierFlags:[theEvent modifierFlags] & ~NSEventModifierFlagCommand + timestamp:[theEvent timestamp] + windowNumber:[theEvent windowNumber] + context:nil + characters:[theEvent characters] + charactersIgnoringModifiers:[theEvent charactersIgnoringModifiers] + isARepeat:[theEvent isARepeat] + keyCode:[theEvent keyCode]]; + processingCompose = YES; + /* FIXME: Use [NSArray arrayWithObject:theEvent]? */ [nsEvArray addObject: theEvent]; [self interpretKeyEvents: nsEvArray]; [nsEvArray removeObject: theEvent]; @@ -6291,14 +6230,20 @@ not_in_argv (NSString *arg) by doCommandBySelector: deleteBackward: */ - (void)insertText: (id)aString { - int code; - int len = [(NSString *)aString length]; - int i; + NSString *s; + NSUInteger len; NSTRACE ("[EmacsView insertText:]"); + if ([aString isKindOfClass:[NSAttributedString class]]) + s = [aString string]; + else + s = aString; + + len = [s length]; + if (NS_KEYLOG) - NSLog (@"insertText '%@'\tlen = %d", aString, len); + NSLog (@"insertText '%@'\tlen = %lu", aString, (unsigned long) len); processingCompose = NO; if (!emacs_event) @@ -6308,10 +6253,24 @@ not_in_argv (NSString *arg) if (workingText != nil) [self deleteWorkingText]; + /* It might be preferable to use getCharacters:range: below, + cf. https://developer.apple.com/library/content/documentation/Cocoa/Conceptual/CocoaPerformance/Articles/StringDrawing.html#//apple_ref/doc/uid/TP40001445-112378. + However, we probably can't use SAFE_NALLOCA here because it might + exit nonlocally. */ + /* now insert the string as keystrokes */ - for (i =0; i<len; i++) + for (NSUInteger i = 0; i < len; i++) { - code = [aString characterAtIndex: i]; + NSUInteger code = [s characterAtIndex:i]; + if (UTF_16_HIGH_SURROGATE_P (code) && i < len - 1) + { + unichar low = [s characterAtIndex:i + 1]; + if (UTF_16_LOW_SURROGATE_P (low)) + { + code = surrogates_to_codepoint (low, code); + ++i; + } + } /* TODO: still need this? */ if (code == 0x2DC) code = '~'; /* 0x7E */ @@ -8760,7 +8719,14 @@ not_in_argv (NSString *arg) if (!NSIsEmptyRect (visible)) [self addCursorRect: visible cursor: [NSCursor arrowCursor]]; - [[NSCursor arrowCursor] setOnMouseEntered: YES]; + +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 + if ([[NSCursor arrowCursor] respondsToSelector: + @selector(setOnMouseEntered)]) +#endif + [[NSCursor arrowCursor] setOnMouseEntered: YES]; +#endif } diff --git a/src/print.c b/src/print.c index af1e85f6e7b..b3c0f6f38fc 100644 --- a/src/print.c +++ b/src/print.c @@ -1971,7 +1971,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) || c == ';' || c == '#' || c == '(' || c == ')' || c == ',' || c == '.' || c == '`' || c == '[' || c == ']' || c == '?' || c <= 040 - || confusing) + || confusing + || (i == 1 && confusable_symbol_character_p (c))) { printchar ('\\', printcharfun); confusing = false; @@ -2366,7 +2367,7 @@ This affects only `prin1'. */); DEFVAR_BOOL ("print-quoted", print_quoted, doc: /* Non-nil means print quoted forms with reader syntax. I.e., (quote foo) prints as \\='foo, (function foo) as #\\='foo. */); - print_quoted = 0; + print_quoted = true; DEFVAR_LISP ("print-gensym", Vprint_gensym, doc: /* Non-nil means print uninterned symbols so they will read as uninterned. diff --git a/src/process.c b/src/process.c index 8a438cfeb8b..ff3edbb11a0 100644 --- a/src/process.c +++ b/src/process.c @@ -1248,10 +1248,7 @@ passed to the filter. The filter gets two arguments: the process and the string of output. The string argument is normally a multibyte string, except: - if the process's input coding system is no-conversion or raw-text, - it is a unibyte string (the non-converted input), or else -- if `default-enable-multibyte-characters' is nil, it is a unibyte - string (the result of converting the decoded input multibyte - string to unibyte with `string-make-unibyte'). */) + it is a unibyte string (the non-converted input). */) (Lisp_Object process, Lisp_Object filter) { CHECK_PROCESS (process); @@ -3761,8 +3758,7 @@ The stopped state is cleared by `continue-process' and set by :filter-multibyte BOOL -- If BOOL is non-nil, strings given to the process filter are multibyte, otherwise they are unibyte. -If this keyword is not specified, the strings are multibyte if -the default value of `enable-multibyte-characters' is non-nil. +If this keyword is not specified, the strings are multibyte. :sentinel SENTINEL -- Install SENTINEL as the process sentinel. @@ -3839,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; @@ -3986,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)) @@ -4004,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. */ @@ -5629,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..8cbd58d72b0 --- /dev/null +++ b/src/ptr-bounds.h @@ -0,0 +1,79 @@ +/* Pointer bounds checking for GNU Emacs + +Copyright 2017-2018 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 d70a59cbb85..122cf712422 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; @@ -1200,7 +1194,8 @@ static const char *re_error_msgid[] = gettext_noop ("Premature end of regular expression"), /* REG_EEND */ gettext_noop ("Regular expression too big"), /* REG_ESIZE */ gettext_noop ("Unmatched ) or \\)"), /* REG_ERPAREN */ - gettext_noop ("Range striding over charsets") /* REG_ERANGEX */ + gettext_noop ("Range striding over charsets"), /* REG_ERANGEX */ + gettext_noop ("Invalid content of \\{\\}, repetitions too big") /* REG_ESIZEBR */ }; /* Whether to allocate memory during matching. */ @@ -1921,7 +1916,7 @@ struct range_table_work_area if (num < 0) \ num = 0; \ if (RE_DUP_MAX / 10 - (RE_DUP_MAX % 10 < c - '0') < num) \ - FREE_STACK_RETURN (REG_BADBR); \ + FREE_STACK_RETURN (REG_ESIZEBR); \ num = num * 10 + c - '0'; \ if (p == pend) \ FREE_STACK_RETURN (REG_EBRACE); \ @@ -2403,7 +2398,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 +3723,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 +3764,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 +3808,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 +4550,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 +4592,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 +4623,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 +4687,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 +4926,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 +6217,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/regex.h b/src/regex.h index b4aad6daac9..6974951f575 100644 --- a/src/regex.h +++ b/src/regex.h @@ -270,8 +270,10 @@ extern ptrdiff_t emacs_re_safe_alloca; #ifdef RE_DUP_MAX # undef RE_DUP_MAX #endif -/* If sizeof(int) == 2, then ((1 << 15) - 1) overflows. */ -#define RE_DUP_MAX (0x7fff) +/* Repeat counts are stored in opcodes as 2 byte integers. This was + previously limited to 7fff because the parsing code uses signed + ints. But Emacs only runs on 32 bit platforms anyway. */ +#define RE_DUP_MAX (0xffff) /* POSIX `cflags' bits (i.e., information for `regcomp'). */ @@ -337,7 +339,8 @@ typedef enum REG_EEND, /* Premature end. */ REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */ REG_ERPAREN, /* Unmatched ) or \); not returned from regcomp. */ - REG_ERANGEX /* Range striding over charsets. */ + REG_ERANGEX, /* Range striding over charsets. */ + REG_ESIZEBR /* n or m too big in \{n,m\} */ } reg_errcode_t; /* This data structure represents a compiled pattern. Before calling diff --git a/src/syntax.c b/src/syntax.c index e6a21e5433e..52cec23cd7e 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -605,6 +605,26 @@ find_defun_start (ptrdiff_t pos, ptrdiff_t pos_byte) && MODIFF == find_start_modiff) return find_start_value; + if (!NILP (Vcomment_use_syntax_ppss)) + { + EMACS_INT modiffs = CHARS_MODIFF; + Lisp_Object ppss = call1 (Qsyntax_ppss, make_number (pos)); + if (modiffs != CHARS_MODIFF) + error ("syntax-ppss modified the buffer!"); + TEMP_SET_PT_BOTH (opoint, opoint_byte); + Lisp_Object boc = Fnth (make_number (8), ppss); + if (NUMBERP (boc)) + { + find_start_value = XINT (boc); + find_start_value_byte = CHAR_TO_BYTE (find_start_value); + } + else + { + find_start_value = pos; + find_start_value_byte = pos_byte; + } + goto found; + } if (!open_paren_in_column_0_is_defun_start) { find_start_value = BEGV; @@ -874,6 +894,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, case Sopen: /* Assume a defun-start point is outside of strings. */ if (open_paren_in_column_0_is_defun_start + && NILP (Vcomment_use_syntax_ppss) && (from == stop || (temp_byte = dec_bytepos (from_byte), FETCH_CHAR (temp_byte) == '\n'))) @@ -3694,6 +3715,11 @@ void syms_of_syntax (void) { DEFSYM (Qsyntax_table_p, "syntax-table-p"); + DEFSYM (Qsyntax_ppss, "syntax-ppss"); + DEFVAR_LISP ("comment-use-syntax-ppss", + Vcomment_use_syntax_ppss, + doc: /* Non-nil means `forward-comment' can use `syntax-ppss' internally. */); + Vcomment_use_syntax_ppss = Qt; staticpro (&Vsyntax_code_object); diff --git a/src/sysdep.c b/src/sysdep.c index 34bff23386d..bc34d8dc059 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -1671,7 +1671,7 @@ emacs_sigaction_init (struct sigaction *action, signal_handler_t handler) } #ifdef FORWARD_SIGNAL_TO_MAIN_THREAD -pthread_t main_thread_id; +static pthread_t main_thread_id; #endif /* SIG has arrived at the current process. Deliver it to the main diff --git a/src/syssignal.h b/src/syssignal.h index 4f6da845ad1..0887eacb05d 100644 --- a/src/syssignal.h +++ b/src/syssignal.h @@ -32,7 +32,6 @@ extern void unblock_tty_out_signal (sigset_t const *); #ifdef HAVE_PTHREAD #include <pthread.h> -extern pthread_t main_thread_id; /* If defined, asynchronous signals delivered to a non-main thread are forwarded to the main thread. */ #define FORWARD_SIGNAL_TO_MAIN_THREAD diff --git a/src/systhread.c b/src/systhread.c index 4ffb7db143a..3f162a2bcbf 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -74,6 +74,12 @@ sys_thread_self (void) return 0; } +bool +sys_thread_equal (sys_thread_t t, sys_thread_t u) +{ + return t == u; +} + int sys_thread_create (sys_thread_t *t, const char *name, thread_creation_function *func, void *datum) @@ -155,6 +161,12 @@ sys_thread_self (void) return pthread_self (); } +bool +sys_thread_equal (sys_thread_t t, sys_thread_t u) +{ + return pthread_equal (t, u); +} + int sys_thread_create (sys_thread_t *thread_ptr, const char *name, thread_creation_function *func, void *arg) @@ -323,6 +335,12 @@ sys_thread_self (void) return (sys_thread_t) GetCurrentThreadId (); } +bool +sys_thread_equal (sys_thread_t t, sys_thread_t u) +{ + return t == u; +} + static thread_creation_function *thread_start_address; /* _beginthread wants a void function, while we are passed a function diff --git a/src/systhread.h b/src/systhread.h index 4745d220654..5dbb12dffb6 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -100,6 +100,7 @@ extern void sys_cond_broadcast (sys_cond_t *); extern void sys_cond_destroy (sys_cond_t *); extern sys_thread_t sys_thread_self (void); +extern bool sys_thread_equal (sys_thread_t, sys_thread_t); extern int sys_thread_create (sys_thread_t *, const char *, thread_creation_function *, diff --git a/src/thread.c b/src/thread.c index 60902b252b4..f11e3e5addb 100644 --- a/src/thread.c +++ b/src/thread.c @@ -1022,6 +1022,14 @@ main_thread_p (void *ptr) return ptr == &main_thread; } +bool +in_current_thread (void) +{ + if (current_thread == NULL) + return false; + return sys_thread_equal (sys_thread_self (), current_thread->thread_id); +} + void init_threads_once (void) { diff --git a/src/thread.h b/src/thread.h index 5746512b799..5ab5e90c70d 100644 --- a/src/thread.h +++ b/src/thread.h @@ -303,6 +303,7 @@ extern void init_threads_once (void); extern void init_threads (void); extern void syms_of_threads (void); extern bool main_thread_p (void *); +extern bool in_current_thread (void); typedef int select_func (int, fd_set *, fd_set *, fd_set *, const struct timespec *, const sigset_t *); diff --git a/src/w32cygwinx.c b/src/w32cygwinx.c new file mode 100644 index 00000000000..8d3ae164cf6 --- /dev/null +++ b/src/w32cygwinx.c @@ -0,0 +1,140 @@ +/* Common functions for the Microsoft Windows and Cygwin builds. + +Copyright (C) 2018 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 <stdio.h> + +#include "lisp.h" +#include "w32common.h" + +DEFUN ("w32-battery-status", Fw32_battery_status, Sw32_battery_status, 0, 0, 0, + doc: /* Get power status information from Windows system. + +The following %-sequences are provided: +%L AC line status (verbose) +%B Battery status (verbose) +%b Battery status, empty means high, `-' means low, + `!' means critical, and `+' means charging +%p Battery load percentage +%s Remaining time (to charge or discharge) in seconds +%m Remaining time (to charge or discharge) in minutes +%h Remaining time (to charge or discharge) in hours +%t Remaining time (to charge or discharge) in the form `h:min' */) + (void) +{ + Lisp_Object status = Qnil; + + SYSTEM_POWER_STATUS system_status; + if (GetSystemPowerStatus (&system_status)) + { + Lisp_Object line_status, battery_status, battery_status_symbol; + Lisp_Object load_percentage, seconds, minutes, hours, remain; + + long seconds_left = (long) system_status.BatteryLifeTime; + + if (system_status.ACLineStatus == 0) + line_status = build_string ("off-line"); + else if (system_status.ACLineStatus == 1) + line_status = build_string ("on-line"); + else + line_status = build_string ("N/A"); + + if (system_status.BatteryFlag & 128) + { + battery_status = build_string ("N/A"); + battery_status_symbol = empty_unibyte_string; + } + else if (system_status.BatteryFlag & 8) + { + battery_status = build_string ("charging"); + battery_status_symbol = build_string ("+"); + if (system_status.BatteryFullLifeTime != -1L) + seconds_left = system_status.BatteryFullLifeTime - seconds_left; + } + else if (system_status.BatteryFlag & 4) + { + battery_status = build_string ("critical"); + battery_status_symbol = build_string ("!"); + } + else if (system_status.BatteryFlag & 2) + { + battery_status = build_string ("low"); + battery_status_symbol = build_string ("-"); + } + else if (system_status.BatteryFlag & 1) + { + battery_status = build_string ("high"); + battery_status_symbol = empty_unibyte_string; + } + else + { + battery_status = build_string ("medium"); + battery_status_symbol = empty_unibyte_string; + } + + if (system_status.BatteryLifePercent > 100) + load_percentage = build_string ("N/A"); + else + { + char buffer[16]; + snprintf (buffer, 16, "%d", system_status.BatteryLifePercent); + load_percentage = build_string (buffer); + } + + if (seconds_left < 0) + seconds = minutes = hours = remain = build_string ("N/A"); + else + { + long m; + double h; + char buffer[16]; + snprintf (buffer, 16, "%ld", seconds_left); + seconds = build_string (buffer); + + m = seconds_left / 60; + snprintf (buffer, 16, "%ld", m); + minutes = build_string (buffer); + + h = seconds_left / 3600.0; + snprintf (buffer, 16, "%3.1f", h); + hours = build_string (buffer); + + snprintf (buffer, 16, "%ld:%02ld", m / 60, m % 60); + remain = build_string (buffer); + } + + status = listn (CONSTYPE_HEAP, 8, + Fcons (make_number ('L'), line_status), + Fcons (make_number ('B'), battery_status), + Fcons (make_number ('b'), battery_status_symbol), + Fcons (make_number ('p'), load_percentage), + Fcons (make_number ('s'), seconds), + Fcons (make_number ('m'), minutes), + Fcons (make_number ('h'), hours), + Fcons (make_number ('t'), remain)); + } + return status; +} + +void +syms_of_w32cygwinx (void) +{ + defsubr (&Sw32_battery_status); +} diff --git a/src/w32fns.c b/src/w32fns.c index e50b7d5c3c3..27c765ed920 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -6423,7 +6423,7 @@ w32_display_monitor_attributes_list (void) { struct frame *f = XFRAME (frame); - if (FRAME_W32_P (f) && !EQ (frame, tip_frame)) + if (FRAME_W32_P (f) && !FRAME_TOOLTIP_P (f)) { HMONITOR monitor = monitor_from_window_fn (FRAME_W32_WINDOW (f), @@ -6510,7 +6510,7 @@ w32_display_monitor_attributes_list_fallback (struct w32_display_info *dpyinfo) { struct frame *f = XFRAME (frame); - if (FRAME_W32_P (f) && !EQ (frame, tip_frame)) + if (FRAME_W32_P (f) && !FRAME_TOOLTIP_P (f)) frames = Fcons (frame, frames); } attributes = Fcons (Fcons (Qframes, frames), attributes); @@ -6916,20 +6916,25 @@ no value of TYPE (always string in the MS Windows case). */) static void compute_tip_xy (struct frame *, Lisp_Object, Lisp_Object, Lisp_Object, int, int, int *, int *); -/* The frame of a currently visible tooltip. */ - +/* The frame of the currently visible tooltip. */ Lisp_Object tip_frame; -/* If non-nil, a timer started that hides the last tooltip when it - fires. */ +/* The window-system window corresponding to the frame of the + currently visible tooltip. */ +Window tip_window; +/* A timer that hides or deletes the currently visible tooltip when it + fires. */ Lisp_Object tip_timer; -Window tip_window; -/* If non-nil, a vector of 3 elements containing the last args - with which x-show-tip was called. See there. */ +/* STRING argument of last `x-show-tip' call. */ +Lisp_Object tip_last_string; + +/* FRAME argument of last `x-show-tip' call. */ +Lisp_Object tip_last_frame; -Lisp_Object last_show_tip_args; +/* PARMS argument of last `x-show-tip' call. */ +Lisp_Object tip_last_parms; static void @@ -7002,6 +7007,7 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms) FRAME_FONTSET (f) = -1; fset_icon_name (f, Qnil); + f->tooltip = true; #ifdef GLYPH_DEBUG image_cache_refcount = @@ -7261,7 +7267,17 @@ compute_tip_xy (struct frame *f, *root_x = min_x; } -/* Hide tooltip. Delete its frame if DELETE is true. */ +/** + * x_hide_tip: + * + * Hide currently visible tooltip and cancel its timer. + * + * This will try to make tooltip_frame invisible (if DELETE is false) + * or delete tooltip_frame (if DELETE is true). + * + * Return Qt if the tooltip was either deleted or made invisible, Qnil + * otherwise. + */ static Lisp_Object x_hide_tip (bool delete) { @@ -7286,15 +7302,20 @@ x_hide_tip (bool delete) if (FRAMEP (tip_frame)) { - if (delete) + if (FRAME_LIVE_P (XFRAME (tip_frame))) { - delete_frame (tip_frame, Qnil); - tip_frame = Qnil; + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + x_make_frame_invisible (XFRAME (tip_frame)); + + was_open = Qt; } else - x_make_frame_invisible (XFRAME (tip_frame)); - - was_open = Qt; + tip_frame = Qnil; } else tip_frame = Qnil; @@ -7334,7 +7355,8 @@ with offset DY added (default is -10). A tooltip's maximum size is specified by `x-max-tooltip-size'. Text larger than the specified size is clipped. */) - (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) + (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, + Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) { struct frame *tip_f; struct window *w; @@ -7345,8 +7367,7 @@ Text larger than the specified size is clipped. */) int old_windows_or_buffers_changed = windows_or_buffers_changed; ptrdiff_t count = SPECPDL_INDEX (); ptrdiff_t count_1; - Lisp_Object window, size; - Lisp_Object tip_buf; + Lisp_Object window, size, tip_buf; AUTO_STRING (tip, " *tip*"); specbind (Qinhibit_redisplay, Qt); @@ -7368,19 +7389,12 @@ Text larger than the specified size is clipped. */) else CHECK_NUMBER (dy); - if (NILP (last_show_tip_args)) - last_show_tip_args = Fmake_vector (make_number (3), Qnil); - if (FRAMEP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) { - Lisp_Object last_string = AREF (last_show_tip_args, 0); - Lisp_Object last_frame = AREF (last_show_tip_args, 1); - Lisp_Object last_parms = AREF (last_show_tip_args, 2); - if (FRAME_VISIBLE_P (XFRAME (tip_frame)) - && EQ (frame, last_frame) - && !NILP (Fequal_including_properties (last_string, string)) - && !NILP (Fequal (last_parms, parms))) + && EQ (frame, tip_last_frame) + && !NILP (Fequal_including_properties (string, tip_last_string)) + && !NILP (Fequal (parms, tip_last_parms))) { /* Only DX and DY have changed. */ tip_f = XFRAME (tip_frame); @@ -7414,14 +7428,14 @@ Text larger than the specified size is clipped. */) goto start_timer; } - else if (tooltip_reuse_hidden_frame && EQ (frame, last_frame)) + else if (tooltip_reuse_hidden_frame && EQ (frame, tip_last_frame)) { bool delete = false; Lisp_Object tail, elt, parm, last; /* Check if every parameter in PARMS has the same value in - last_parms. This may destruct last_parms which, however, - will be recreated below. */ + tip_last_parms. This may destruct tip_last_parms + which, however, will be recreated below. */ for (tail = parms; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); @@ -7431,7 +7445,7 @@ Text larger than the specified size is clipped. */) if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright) && !EQ (parm, Qbottom)) { - last = Fassq (parm, last_parms); + last = Fassq (parm, tip_last_parms); if (NILP (Fequal (Fcdr (elt), Fcdr (last)))) { /* We lost, delete the old tooltip. */ @@ -7439,15 +7453,17 @@ Text larger than the specified size is clipped. */) break; } else - last_parms = call2 (Qassq_delete_all, parm, last_parms); + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); } else - last_parms = call2 (Qassq_delete_all, parm, last_parms); + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); } - /* Now check if there's a parameter left in last_parms with a + /* Now check if there's a parameter left in tip_last_parms with a non-nil value. */ - for (tail = last_parms; CONSP (tail); tail = XCDR (tail)) + for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); parm = Fcar (elt); @@ -7468,9 +7484,9 @@ Text larger than the specified size is clipped. */) else x_hide_tip (true); - ASET (last_show_tip_args, 0, string); - ASET (last_show_tip_args, 1, frame); - ASET (last_show_tip_args, 2, parms); + tip_last_frame = frame; + tip_last_string = string; + tip_last_parms = parms; /* Block input until the tip has been fully drawn, to avoid crashes when drawing tips in menus. */ @@ -7486,7 +7502,8 @@ Text larger than the specified size is clipped. */) if (NILP (Fassq (Qborder_width, parms))) parms = Fcons (Fcons (Qborder_width, make_number (1)), parms); if (NILP (Fassq (Qborder_color, parms))) - parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms); + parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), + parms); if (NILP (Fassq (Qbackground_color, parms))) parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")), parms); @@ -9213,115 +9230,6 @@ The coordinates X and Y are interpreted in pixels relative to a position return Qnil; } -DEFUN ("w32-battery-status", Fw32_battery_status, Sw32_battery_status, 0, 0, 0, - doc: /* Get power status information from Windows system. - -The following %-sequences are provided: -%L AC line status (verbose) -%B Battery status (verbose) -%b Battery status, empty means high, `-' means low, - `!' means critical, and `+' means charging -%p Battery load percentage -%s Remaining time (to charge or discharge) in seconds -%m Remaining time (to charge or discharge) in minutes -%h Remaining time (to charge or discharge) in hours -%t Remaining time (to charge or discharge) in the form `h:min' */) - (void) -{ - Lisp_Object status = Qnil; - - SYSTEM_POWER_STATUS system_status; - if (GetSystemPowerStatus (&system_status)) - { - Lisp_Object line_status, battery_status, battery_status_symbol; - Lisp_Object load_percentage, seconds, minutes, hours, remain; - - long seconds_left = (long) system_status.BatteryLifeTime; - - if (system_status.ACLineStatus == 0) - line_status = build_string ("off-line"); - else if (system_status.ACLineStatus == 1) - line_status = build_string ("on-line"); - else - line_status = build_string ("N/A"); - - if (system_status.BatteryFlag & 128) - { - battery_status = build_string ("N/A"); - battery_status_symbol = empty_unibyte_string; - } - else if (system_status.BatteryFlag & 8) - { - battery_status = build_string ("charging"); - battery_status_symbol = build_string ("+"); - if (system_status.BatteryFullLifeTime != -1L) - seconds_left = system_status.BatteryFullLifeTime - seconds_left; - } - else if (system_status.BatteryFlag & 4) - { - battery_status = build_string ("critical"); - battery_status_symbol = build_string ("!"); - } - else if (system_status.BatteryFlag & 2) - { - battery_status = build_string ("low"); - battery_status_symbol = build_string ("-"); - } - else if (system_status.BatteryFlag & 1) - { - battery_status = build_string ("high"); - battery_status_symbol = empty_unibyte_string; - } - else - { - battery_status = build_string ("medium"); - battery_status_symbol = empty_unibyte_string; - } - - if (system_status.BatteryLifePercent > 100) - load_percentage = build_string ("N/A"); - else - { - char buffer[16]; - snprintf (buffer, 16, "%d", system_status.BatteryLifePercent); - load_percentage = build_string (buffer); - } - - if (seconds_left < 0) - seconds = minutes = hours = remain = build_string ("N/A"); - else - { - long m; - double h; - char buffer[16]; - snprintf (buffer, 16, "%ld", seconds_left); - seconds = build_string (buffer); - - m = seconds_left / 60; - snprintf (buffer, 16, "%ld", m); - minutes = build_string (buffer); - - h = seconds_left / 3600.0; - snprintf (buffer, 16, "%3.1f", h); - hours = build_string (buffer); - - snprintf (buffer, 16, "%ld:%02ld", m / 60, m % 60); - remain = build_string (buffer); - } - - status = listn (CONSTYPE_HEAP, 8, - Fcons (make_number ('L'), line_status), - Fcons (make_number ('B'), battery_status), - Fcons (make_number ('b'), battery_status_symbol), - Fcons (make_number ('p'), load_percentage), - Fcons (make_number ('s'), seconds), - Fcons (make_number ('m'), minutes), - Fcons (make_number ('h'), hours), - Fcons (make_number ('t'), remain)); - } - return status; -} - #ifdef WINDOWSNT typedef BOOL (WINAPI *GetDiskFreeSpaceExW_Proc) @@ -9343,6 +9251,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 +10332,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)); @@ -10774,7 +10694,6 @@ tip frame. */); defsubr (&Sw32_reconstruct_hot_key); defsubr (&Sw32_toggle_lock_key); defsubr (&Sw32_window_exists_p); - defsubr (&Sw32_battery_status); defsubr (&Sw32__menu_bar_in_use); #if defined WINDOWSNT && !defined HAVE_DBUS defsubr (&Sw32_notification_notify); @@ -10793,9 +10712,12 @@ tip frame. */); staticpro (&tip_timer); tip_frame = Qnil; staticpro (&tip_frame); - - last_show_tip_args = Qnil; - staticpro (&last_show_tip_args); + tip_last_frame = Qnil; + staticpro (&tip_last_frame); + tip_last_string = Qnil; + staticpro (&tip_last_string); + tip_last_parms = Qnil; + staticpro (&tip_last_parms); defsubr (&Sx_file_dialog); #ifdef WINDOWSNT diff --git a/src/w32term.c b/src/w32term.c index db4ccf58138..137c798c463 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -5569,7 +5569,7 @@ w32_read_socket (struct terminal *terminal, struct frame *f = XFRAME (frame); /* The tooltip has been drawn already. Avoid the SET_FRAME_GARBAGED below. */ - if (EQ (frame, tip_frame)) + if (FRAME_TOOLTIP_P (f)) continue; /* Check "visible" frames and mark each as obscured or not. @@ -6046,7 +6046,7 @@ x_new_font (struct frame *f, Lisp_Object font_object, int fontset) /* Don't change the size of a tip frame; there's no point in doing it because it's done in Fx_show_tip, and it leads to problems because the tip frame has no widget. */ - if (NILP (tip_frame) || XFRAME (tip_frame) != f) + if (!FRAME_TOOLTIP_P (f)) adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3, false, Qfont); diff --git a/src/w32term.h b/src/w32term.h index e500b730ead..c69bebeebdd 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -817,6 +817,8 @@ extern struct window *w32_system_caret_window; extern int w32_system_caret_hdr_height; extern int w32_system_caret_mode_height; +extern Window tip_window; + #ifdef _MSC_VER #ifndef EnumSystemLocales /* MSVC headers define these only for _WIN32_WINNT >= 0x0500. */ diff --git a/src/xdisp.c b/src/xdisp.c index bf1737b9cf7..55f3151b4f2 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -8790,7 +8790,16 @@ move_it_in_display_line_to (struct it *it, if (it->line_wrap == TRUNCATE) { - if (BUFFER_POS_REACHED_P ()) + /* If it->pixel_width is zero, the last PRODUCE_GLYPHS call + produced something that doesn't consume any screen estate + in the text area, so we don't want to exit the loop at + TO_CHARPOS, before we produce the glyph for that buffer + position. This happens, e.g., when there's an overlay at + TO_CHARPOS that draws a fringe bitmap. */ + if (BUFFER_POS_REACHED_P () + && (it->pixel_width > 0 + || IT_CHARPOS (*it) > to_charpos + || it->area != TEXT_AREA)) { result = MOVE_POS_MATCH_OR_ZV; break; @@ -11881,7 +11890,7 @@ x_consider_frame_title (Lisp_Object frame) if ((FRAME_WINDOW_P (f) || FRAME_MINIBUF_ONLY_P (f) || f->explicit_name) - && NILP (Fframe_parameter (frame, Qtooltip))) + && !FRAME_TOOLTIP_P (f)) { /* Do we have more than one visible frame on this X display? */ Lisp_Object tail, other_frame, fmt; @@ -11898,8 +11907,8 @@ x_consider_frame_title (Lisp_Object frame) if (tf != f && FRAME_KBOARD (tf) == FRAME_KBOARD (f) && !FRAME_MINIBUF_ONLY_P (tf) - && !EQ (other_frame, tip_frame) && !FRAME_PARENT_FRAME (tf) + && !FRAME_TOOLTIP_P (tf) && (FRAME_VISIBLE_P (tf) || FRAME_ICONIFIED_P (tf))) break; } @@ -11968,13 +11977,6 @@ prepare_menu_bars (void) { bool all_windows = windows_or_buffers_changed || update_mode_lines; bool some_windows = REDISPLAY_SOME_P (); - Lisp_Object tooltip_frame; - -#ifdef HAVE_WINDOW_SYSTEM - tooltip_frame = tip_frame; -#else - tooltip_frame = Qnil; -#endif if (FUNCTIONP (Vpre_redisplay_function)) { @@ -12015,7 +12017,7 @@ prepare_menu_bars (void) && !XBUFFER (w->contents)->text->redisplay) continue; - if (!EQ (frame, tooltip_frame) + if (!FRAME_TOOLTIP_P (f) && !FRAME_PARENT_FRAME (f) && (FRAME_ICONIFIED_P (f) || FRAME_VISIBLE_P (f) == 1 @@ -12053,7 +12055,7 @@ prepare_menu_bars (void) struct window *w = XWINDOW (FRAME_SELECTED_WINDOW (f)); /* Ignore tooltip frame. */ - if (EQ (frame, tooltip_frame)) + if (FRAME_TOOLTIP_P (f)) continue; if (some_windows @@ -12338,7 +12340,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); @@ -21175,13 +21177,7 @@ should_produce_line_number (struct it *it) #ifdef HAVE_WINDOW_SYSTEM /* Don't display line number in tooltip frames. */ - if (FRAMEP (tip_frame) && EQ (WINDOW_FRAME (it->w), tip_frame) -#ifdef USE_GTK - /* GTK builds store in tip_frame the frame that shows the tip, - so we need an additional test. */ - && !NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - ) + if (FRAME_TOOLTIP_P (XFRAME (WINDOW_FRAME (it->w)))) return false; #endif @@ -23911,7 +23907,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); @@ -30855,9 +30852,11 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, = buffer_local_value (Qmode_line_default_help_echo, w->contents); - if (STRINGP (default_help)) + if (FUNCTIONP (default_help) || STRINGP (default_help)) { - help_echo_string = default_help; + help_echo_string = (FUNCTIONP (default_help) + ? safe_call1 (default_help, window) + : default_help); XSETWINDOW (help_echo_window, w); help_echo_object = Qnil; help_echo_pos = -1; @@ -31924,7 +31923,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 f1fc6bb632f..77afee4587d 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; @@ -6525,7 +6526,12 @@ other font of the appropriate family and registry is available. */); doc: /* List of ignored fonts. Each element is a regular expression that matches names of fonts to ignore. */); +#ifdef HAVE_OTF_KANNADA_BUG + /* https://debbugs.gnu.org/30193 */ + Vface_ignored_fonts = list1 (build_string ("Noto Serif Kannada")); +#else Vface_ignored_fonts = Qnil; +#endif DEFVAR_LISP ("face-remapping-alist", Vface_remapping_alist, doc: /* Alist of face remappings. diff --git a/src/xfns.c b/src/xfns.c index 20fe61bffd8..db1ce311021 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 @@ -4612,8 +4612,9 @@ x_make_monitor_attribute_list (struct MonitorInfo *monitors, { struct frame *f = XFRAME (frame); - if (FRAME_X_P (f) && FRAME_DISPLAY_INFO (f) == dpyinfo - && !EQ (frame, tip_frame)) + if (FRAME_X_P (f) + && FRAME_DISPLAY_INFO (f) == dpyinfo + && !FRAME_TOOLTIP_P (f)) { int i = x_get_monitor_for_frame (f, monitors, n_monitors); ASET (monitor_frames, i, Fcons (frame, AREF (monitor_frames, i))); @@ -4914,12 +4915,9 @@ Internal use only, use `display-monitor-attributes-list' instead. */) { struct frame *f = XFRAME (frame); - if (FRAME_X_P (f) && FRAME_DISPLAY_INFO (f) == dpyinfo - && !(EQ (frame, tip_frame) -#ifdef USE_GTK - && !NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - )) + if (FRAME_X_P (f) + && FRAME_DISPLAY_INFO (f) == dpyinfo + && !FRAME_TOOLTIP_P (f)) { GdkWindow *gwin = gtk_widget_get_window (FRAME_GTK_WIDGET (f)); @@ -6063,22 +6061,27 @@ Otherwise, the return value is a vector with the following fields: ***********************************************************************/ static void compute_tip_xy (struct frame *, Lisp_Object, Lisp_Object, - Lisp_Object, int, int, int *, int *); + Lisp_Object, int, int, int *, int *); -/* The frame of a currently visible tooltip. */ +/* The frame of the currently visible tooltip. */ +static Lisp_Object tip_frame; -Lisp_Object tip_frame; +/* The window-system window corresponding to the frame of the + currently visible tooltip. */ +Window tip_window; -/* If non-nil, a timer started that hides the last tooltip when it +/* A timer that hides or deletes the currently visible tooltip when it fires. */ - static Lisp_Object tip_timer; -Window tip_window; -/* If non-nil, a vector of 3 elements containing the last args - with which x-show-tip was called. See there. */ +/* STRING argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_string; -static Lisp_Object last_show_tip_args; +/* FRAME argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_frame; + +/* PARMS argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_parms; static void @@ -6152,6 +6155,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) f->output_data.x->white_relief.pixel = -1; f->output_data.x->black_relief.pixel = -1; + f->tooltip = true; fset_icon_name (f, Qnil); FRAME_DISPLAY_INFO (f) = dpyinfo; f->output_data.x->parent_desc = FRAME_DISPLAY_INFO (f)->root_window; @@ -6416,7 +6420,9 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) the display in *ROOT_X, and *ROOT_Y. */ static void -compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, int width, int height, int *root_x, int *root_y) +compute_tip_xy (struct frame *f, + Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, + int width, int height, int *root_x, int *root_y) { Lisp_Object left, top, right, bottom; int win_x, win_y; @@ -6513,7 +6519,19 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object } -/* Hide tooltip. Delete its frame if DELETE is true. */ +/** + * x_hide_tip: + * + * Hide currently visible tooltip and cancel its timer. + * + * If GTK+ system tooltips are used, this will try to hide the tooltip + * referenced by the x_output structure of tooltip_last_frame. For + * Emacs tooltips this will try to make tooltip_frame invisible (if + * DELETE is false) or delete tooltip_frame (if DELETE is true). + * + * Return Qt if the tooltip was either deleted or made invisible, Qnil + * otherwise. + */ static Lisp_Object x_hide_tip (bool delete) { @@ -6523,10 +6541,17 @@ x_hide_tip (bool delete) tip_timer = Qnil; } - - if (NILP (tip_frame) - || (!delete && FRAMEP (tip_frame) - && !FRAME_VISIBLE_P (XFRAME (tip_frame)))) +#ifdef USE_GTK + /* The GTK+ system tooltip window can be found via the x_output + structure of tip_last_frame, if it still exists. */ + if (x_gtk_use_system_tooltips && NILP (tip_last_frame)) + return Qnil; + else if (!x_gtk_use_system_tooltips + && (NILP (tip_frame) + || (!delete + && FRAMEP (tip_frame) + && FRAME_LIVE_P (XFRAME (tip_frame)) + && !FRAME_VISIBLE_P (XFRAME (tip_frame))))) return Qnil; else { @@ -6537,61 +6562,114 @@ x_hide_tip (bool delete) specbind (Qinhibit_redisplay, Qt); specbind (Qinhibit_quit, Qt); -#ifdef USE_GTK - { - /* When using system tooltip, tip_frame is the Emacs frame on - which the tip is shown. */ - struct frame *f = XFRAME (tip_frame); - - if (FRAME_LIVE_P (f) && xg_hide_tooltip (f)) - { - tip_frame = Qnil; - was_open = Qt; - } - } -#endif + if (x_gtk_use_system_tooltips) + { + /* The GTK+ system tooltip window is stored in the x_output + structure of tip_last_frame. */ + struct frame *f = XFRAME (tip_last_frame); - if (FRAMEP (tip_frame)) + if (FRAME_LIVE_P (f)) + { + if (xg_hide_tooltip (f)) + was_open = Qt; + } + else + tip_last_frame = Qnil; + } + else { - if (delete) + if (FRAMEP (tip_frame)) { - delete_frame (tip_frame, Qnil); - tip_frame = Qnil; + struct frame *f = XFRAME (tip_frame); + + if (FRAME_LIVE_P (f)) + { + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + x_make_frame_invisible (f); + + was_open = Qt; + } + else + tip_frame = Qnil; } else - x_make_frame_invisible (XFRAME (tip_frame)); + tip_frame = Qnil; + } + + return unbind_to (count, was_open); + } +#else /* not USE_GTK */ + if (NILP (tip_frame) + || (!delete + && FRAMEP (tip_frame) + && FRAME_LIVE_P (XFRAME (tip_frame)) + && !FRAME_VISIBLE_P (XFRAME (tip_frame)))) + return Qnil; + else + { + ptrdiff_t count; + Lisp_Object was_open = Qnil; + + count = SPECPDL_INDEX (); + specbind (Qinhibit_redisplay, Qt); + specbind (Qinhibit_quit, Qt); + + if (FRAMEP (tip_frame)) + { + struct frame *f = XFRAME (tip_frame); - was_open = Qt; + if (FRAME_LIVE_P (f)) + { + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + x_make_frame_invisible (XFRAME (tip_frame)); #ifdef USE_LUCID - /* Bloodcurdling hack alert: The Lucid menu bar widget's - redisplay procedure is not called when a tip frame over - menu items is unmapped. Redisplay the menu manually... */ - { - Widget w; - struct frame *f = SELECTED_FRAME (); - if (FRAME_X_P (f) && FRAME_LIVE_P (f)) + /* Bloodcurdling hack alert: The Lucid menu bar widget's + redisplay procedure is not called when a tip frame over + menu items is unmapped. Redisplay the menu manually... */ { - w = f->output_data.x->menubar_widget; + Widget w; + struct frame *f = SELECTED_FRAME (); - if (!DoesSaveUnders (FRAME_DISPLAY_INFO (f)->screen) - && w != NULL) + if (FRAME_X_P (f) && FRAME_LIVE_P (f)) { - block_input (); - xlwmenu_redisplay (w); - unblock_input (); + w = f->output_data.x->menubar_widget; + + if (!DoesSaveUnders (FRAME_DISPLAY_INFO (f)->screen) + && w != NULL) + { + block_input (); + xlwmenu_redisplay (w); + unblock_input (); + } } } - } #endif /* USE_LUCID */ + + was_open = Qt; + } + else + tip_frame = Qnil; } else tip_frame = Qnil; return unbind_to (count, was_open); } +#endif /* USE_GTK */ } + DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, doc: /* Show STRING in a "tooltip" window on frame FRAME. A tooltip window is a small X window displaying a string. @@ -6622,7 +6700,8 @@ with offset DY added (default is -10). A tooltip's maximum size is specified by `x-max-tooltip-size'. Text larger than the specified size is clipped. */) - (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) + (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, + Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) { struct frame *f, *tip_f; struct window *w; @@ -6633,8 +6712,7 @@ Text larger than the specified size is clipped. */) int old_windows_or_buffers_changed = windows_or_buffers_changed; ptrdiff_t count = SPECPDL_INDEX (); ptrdiff_t count_1; - Lisp_Object window, size; - Lisp_Object tip_buf; + Lisp_Object window, size, tip_buf; AUTO_STRING (tip, " *tip*"); specbind (Qinhibit_redisplay, Qt); @@ -6673,36 +6751,27 @@ Text larger than the specified size is clipped. */) { compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y); xg_show_tooltip (f, root_x, root_y); - /* This is used in Fx_hide_tip. */ - XSETFRAME (tip_frame, f); + tip_last_frame = frame; } + unblock_input (); if (ok) goto start_timer; } #endif /* USE_GTK */ - if (NILP (last_show_tip_args)) - last_show_tip_args = Fmake_vector (make_number (3), Qnil); - if (FRAMEP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) { - Lisp_Object last_string = AREF (last_show_tip_args, 0); - Lisp_Object last_frame = AREF (last_show_tip_args, 1); - Lisp_Object last_parms = AREF (last_show_tip_args, 2); - if (FRAME_VISIBLE_P (XFRAME (tip_frame)) - && EQ (frame, last_frame) - && !NILP (Fequal_including_properties (last_string, string)) - && !NILP (Fequal (last_parms, parms))) + && EQ (frame, tip_last_frame) + && !NILP (Fequal_including_properties (tip_last_string, string)) + && !NILP (Fequal (tip_last_parms, parms))) { /* Only DX and DY have changed. */ tip_f = XFRAME (tip_frame); if (!NILP (tip_timer)) { - Lisp_Object timer = tip_timer; - + call1 (Qcancel_timer, tip_timer); tip_timer = Qnil; - call1 (Qcancel_timer, timer); } block_input (); @@ -6714,15 +6783,14 @@ Text larger than the specified size is clipped. */) goto start_timer; } - else if (tooltip_reuse_hidden_frame && EQ (frame, last_frame)) + else if (tooltip_reuse_hidden_frame && EQ (frame, tip_last_frame)) { bool delete = false; Lisp_Object tail, elt, parm, last; /* Check if every parameter in PARMS has the same value in - last_parms unless it should be ignored by means of - Vtooltip_reuse_hidden_frame_parameters. This may destruct - last_parms which, however, will be recreated below. */ + tip_last_parms. This may destruct tip_last_parms which, + however, will be recreated below. */ for (tail = parms; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); @@ -6732,7 +6800,7 @@ Text larger than the specified size is clipped. */) if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright) && !EQ (parm, Qbottom)) { - last = Fassq (parm, last_parms); + last = Fassq (parm, tip_last_parms); if (NILP (Fequal (Fcdr (elt), Fcdr (last)))) { /* We lost, delete the old tooltip. */ @@ -6740,17 +6808,18 @@ Text larger than the specified size is clipped. */) break; } else - last_parms = call2 (Qassq_delete_all, parm, last_parms); + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); } else - last_parms = call2 (Qassq_delete_all, parm, last_parms); + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); } - /* Now check if every parameter in what is left of last_parms - with a non-nil value has an association in PARMS unless it - should be ignored by means of - Vtooltip_reuse_hidden_frame_parameters. */ - for (tail = last_parms; CONSP (tail); tail = XCDR (tail)) + /* Now check if every parameter in what is left of + tip_last_parms with a non-nil value has an association in + PARMS. */ + for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); parm = Fcar (elt); @@ -6771,9 +6840,9 @@ Text larger than the specified size is clipped. */) else x_hide_tip (true); - ASET (last_show_tip_args, 0, string); - ASET (last_show_tip_args, 1, frame); - ASET (last_show_tip_args, 2, parms); + tip_last_frame = frame; + tip_last_string = string; + tip_last_parms = parms; if (!FRAMEP (tip_frame) || !FRAME_LIVE_P (XFRAME (tip_frame))) { @@ -7834,7 +7903,6 @@ When using Gtk+ tooltips, the tooltip face is not used. */); defsubr (&Sx_display_list); defsubr (&Sx_synchronize); defsubr (&Sx_backspace_delete_keys_p); - defsubr (&Sx_show_tip); defsubr (&Sx_hide_tip); defsubr (&Sx_double_buffered_p); @@ -7842,9 +7910,12 @@ When using Gtk+ tooltips, the tooltip face is not used. */); staticpro (&tip_timer); tip_frame = Qnil; staticpro (&tip_frame); - - last_show_tip_args = Qnil; - staticpro (&last_show_tip_args); + tip_last_frame = Qnil; + staticpro (&tip_last_frame); + tip_last_string = Qnil; + staticpro (&tip_last_string); + tip_last_parms = Qnil; + staticpro (&tip_last_parms); defsubr (&Sx_uses_old_gtk_dialog); #if defined (USE_MOTIF) || defined (USE_GTK) diff --git a/src/xml.c b/src/xml.c index 8bf5a3d122b..42059d77131 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/xterm.c b/src/xterm.c index 364a8a8db02..7603e4f3991 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -996,12 +996,7 @@ static void x_update_begin (struct frame *f) { #ifdef USE_CAIRO - if (! NILP (tip_frame) && XFRAME (tip_frame) == f - && ! FRAME_VISIBLE_P (f) -#ifdef USE_GTK - && !NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - ) + if (FRAME_TOOLTIP_P (f) && !FRAME_VISIBLE_P (f)) return; if (! FRAME_CR_SURFACE (f)) @@ -8091,7 +8086,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* Redo the mouse-highlight after the tooltip has gone. */ if (event->xunmap.window == tip_window) { - tip_window = 0; + tip_window = None; x_redo_mouse_highlight (dpyinfo); } @@ -8733,7 +8728,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, #ifdef USE_X_TOOLKIT /* Tip frames are pure X window, set size for them. */ - if (! NILP (tip_frame) && XFRAME (tip_frame) == f) + if (FRAME_TOOLTIP_P (f)) { if (FRAME_PIXEL_HEIGHT (f) != configureEvent.xconfigure.height || FRAME_PIXEL_WIDTH (f) != configureEvent.xconfigure.width) @@ -9971,11 +9966,7 @@ x_new_font (struct frame *f, Lisp_Object font_object, int fontset) /* Don't change the size of a tip frame; there's no point in doing it because it's done in Fx_show_tip, and it leads to problems because the tip frame has no widget. */ - if (NILP (tip_frame) || XFRAME (tip_frame) != f -#ifdef USE_GTK - || NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - ) + if (!FRAME_TOOLTIP_P (f)) { adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3, @@ -11209,7 +11200,7 @@ x_set_window_size (struct frame *f, bool change_gravity, /* The following breaks our calculations. If it's really needed, think of something else. */ #if false - if (NILP (tip_frame) || XFRAME (tip_frame) != f) + if (!FRAME_TOOLTIP_P (f)) { int text_width, text_height; diff --git a/src/xterm.h b/src/xterm.h index f73dd0e25ab..1849a5c9535 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -503,6 +503,8 @@ extern bool x_display_ok (const char *); extern void select_visual (struct x_display_info *); +extern Window tip_window; + /* Each X frame object points to its own struct x_output object in the output_data.x field. The x_output structure contains the information that is specific to X windows. */ diff --git a/src/xwidget.c b/src/xwidget.c index 530d1af707a..95fa5f19c40 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 |