diff options
Diffstat (limited to 'src')
41 files changed, 749 insertions, 855 deletions
diff --git a/src/Makefile.in b/src/Makefile.in index ab63b926272..552dd2e50ae 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -295,8 +295,8 @@ EMACSRES = @EMACSRES@ W32_RES_LINK=@W32_RES_LINK@ ## Empty if !HAVE_X_WINDOWS -## xfont.o ftfont.o xftfont.o ftxfont.o if HAVE_XFT -## xfont.o ftfont.o ftxfont.o if HAVE_FREETYPE +## xfont.o ftfont.o xftfont.o if HAVE_XFT +## xfont.o ftfont.o if HAVE_FREETYPE ## xfont.o ftfont.o ftcrfont.o if USE_CAIRO ## else xfont.o ## if HAVE_HARFBUZZ, hbfont.o is added regardless of the rest @@ -436,7 +436,7 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ nsterm.o nsfns.o nsmenu.o nsselect.o nsimage.o nsfont.o macfont.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 \ + w16select.o widget.o xfont.o ftfont.o xftfont.o gtkutil.o \ xsettings.o xgselect.o termcap.o hbfont.o ## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty. diff --git a/src/alloc.c b/src/alloc.c index 1c6b664b220..99d5ca149d5 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -104,6 +104,26 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "w32heap.h" /* for sbrk */ #endif +/* MALLOC_SIZE_NEAR (N) is a good number to pass to malloc when + allocating a block of memory with size close to N bytes. + For best results N should be a power of 2. + + When calculating how much memory to allocate, GNU malloc (SIZE) + adds sizeof (size_t) to SIZE for internal overhead, and then rounds + up to a multiple of MALLOC_ALIGNMENT. Emacs can improve + performance a bit on GNU platforms by arranging for the resulting + size to be a power of two. This heuristic is good for glibc 2.0 + (1997) through at least glibc 2.31 (2020), and does not affect + correctness on other platforms. */ + +#define MALLOC_SIZE_NEAR(n) \ + (ROUNDUP (max (n, sizeof (size_t)), MALLOC_ALIGNMENT) - sizeof (size_t)) +#ifdef __i386 +enum { MALLOC_ALIGNMENT = 16 }; +#else +enum { MALLOC_ALIGNMENT = max (2 * sizeof (size_t), alignof (long double)) }; +#endif + #ifdef DOUG_LEA_MALLOC /* Specify maximum number of areas to mmap. It would be nice to use a @@ -694,7 +714,7 @@ malloc_unblock_input (void) malloc_probe (size); \ } while (0) -static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +static void *lmalloc (size_t, bool) ATTRIBUTE_MALLOC_SIZE ((1)); static void *lrealloc (void *, size_t); /* Like malloc but check for no memory and block interrupt input. */ @@ -705,7 +725,7 @@ xmalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = lmalloc (size); + val = lmalloc (size, false); MALLOC_UNBLOCK_INPUT; if (!val && size) @@ -722,12 +742,11 @@ xzalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = lmalloc (size); + val = lmalloc (size, true); MALLOC_UNBLOCK_INPUT; if (!val && size) memory_full (size); - memset (val, 0, size); MALLOC_PROBE (size); return val; } @@ -743,7 +762,7 @@ xrealloc (void *block, size_t size) /* We must call malloc explicitly when BLOCK is 0, since some reallocs don't do this. */ if (! block) - val = lmalloc (size); + val = lmalloc (size, false); else val = lrealloc (block, size); MALLOC_UNBLOCK_INPUT; @@ -939,7 +958,7 @@ void *lisp_malloc_loser EXTERNALLY_VISIBLE; #endif static void * -lisp_malloc (size_t nbytes, enum mem_type type) +lisp_malloc (size_t nbytes, bool clearit, enum mem_type type) { register void *val; @@ -949,7 +968,7 @@ lisp_malloc (size_t nbytes, enum mem_type type) allocated_mem_type = type; #endif - val = lmalloc (nbytes); + val = lmalloc (nbytes, clearit); #if ! USE_LSB_TAG /* If the memory just allocated cannot be addressed thru a Lisp @@ -1290,16 +1309,21 @@ laligned (void *p, size_t size) that's never really exercised) for little benefit. */ static void * -lmalloc (size_t size) +lmalloc (size_t size, bool clearit) { #ifdef USE_ALIGNED_ALLOC if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0) - return aligned_alloc (LISP_ALIGNMENT, size); + { + void *p = aligned_alloc (LISP_ALIGNMENT, size); + if (clearit && p) + memclear (p, size); + return p; + } #endif while (true) { - void *p = malloc (size); + void *p = clearit ? calloc (1, size) : malloc (size); if (laligned (p, size)) return p; free (p); @@ -1328,11 +1352,11 @@ lrealloc (void *p, size_t size) Interval Allocation ***********************************************************************/ -/* Number of intervals allocated in an interval_block structure. - The 1020 is 1024 minus malloc overhead. */ +/* Number of intervals allocated in an interval_block structure. */ -#define INTERVAL_BLOCK_SIZE \ - ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval)) +enum { INTERVAL_BLOCK_SIZE + = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct interval_block *)) + / sizeof (struct interval)) }; /* Intervals are allocated in chunks in the form of an interval_block structure. */ @@ -1377,7 +1401,7 @@ make_interval (void) if (interval_block_index == INTERVAL_BLOCK_SIZE) { struct interval_block *newi - = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP); + = lisp_malloc (sizeof *newi, false, MEM_TYPE_NON_LISP); newi->next = interval_block; interval_block = newi; @@ -1444,10 +1468,9 @@ mark_interval_tree (INTERVAL i) longer used, can be easily recognized, and it's easy to compact the sblocks of small strings which we do in compact_small_strings. */ -/* Size in bytes of an sblock structure used for small strings. This - is 8192 minus malloc overhead. */ +/* Size in bytes of an sblock structure used for small strings. */ -#define SBLOCK_SIZE 8188 +enum { SBLOCK_SIZE = MALLOC_SIZE_NEAR (8192) }; /* Strings larger than this are considered large strings. String data for large strings is allocated from individual sblocks. */ @@ -1522,11 +1545,11 @@ struct sblock sdata data[FLEXIBLE_ARRAY_MEMBER]; }; -/* Number of Lisp strings in a string_block structure. The 1020 is - 1024 minus malloc overhead. */ +/* Number of Lisp strings in a string_block structure. */ -#define STRING_BLOCK_SIZE \ - ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String)) +enum { STRING_BLOCK_SIZE + = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct string_block *)) + / sizeof (struct Lisp_String)) }; /* Structure describing a block from which Lisp_String structures are allocated. */ @@ -1730,7 +1753,7 @@ allocate_string (void) add all the Lisp_Strings in it to the free-list. */ if (string_free_list == NULL) { - struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING); + struct string_block *b = lisp_malloc (sizeof *b, false, MEM_TYPE_STRING); int i; b->next = string_blocks; @@ -1778,15 +1801,16 @@ allocate_string (void) plus a NUL byte at the end. Allocate an sdata structure DATA for S, and set S->u.s.data to SDATA->u.data. Store a NUL byte at the end of S->u.s.data. Set S->u.s.size to NCHARS and S->u.s.size_byte - to NBYTES. Free S->u.s.data if it was initially non-null. */ + to NBYTES. Free S->u.s.data if it was initially non-null. -void + If CLEARIT, also clear the other bytes of S->u.s.data. */ + +static void allocate_string_data (struct Lisp_String *s, - EMACS_INT nchars, EMACS_INT nbytes) + EMACS_INT nchars, EMACS_INT nbytes, bool clearit) { - sdata *data, *old_data; + sdata *data; struct sblock *b; - ptrdiff_t old_nbytes; if (STRING_BYTES_MAX < nbytes) string_overflow (); @@ -1794,13 +1818,6 @@ allocate_string_data (struct Lisp_String *s, /* Determine the number of bytes needed to store NBYTES bytes of string data. */ ptrdiff_t needed = sdata_size (nbytes); - if (s->u.s.data) - { - old_data = SDATA_OF_STRING (s); - old_nbytes = STRING_BYTES (s); - } - else - old_data = NULL; MALLOC_BLOCK_INPUT; @@ -1813,7 +1830,7 @@ allocate_string_data (struct Lisp_String *s, mallopt (M_MMAP_MAX, 0); #endif - b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP); + b = lisp_malloc (size + GC_STRING_EXTRA, clearit, MEM_TYPE_NON_LISP); #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -1825,27 +1842,30 @@ allocate_string_data (struct Lisp_String *s, b->next_free = data; large_sblocks = b; } - else if (current_sblock == NULL - || (((char *) current_sblock + SBLOCK_SIZE - - (char *) current_sblock->next_free) - < (needed + GC_STRING_EXTRA))) - { - /* Not enough room in the current sblock. */ - b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP); - data = b->data; - b->next = NULL; - b->next_free = data; - - if (current_sblock) - current_sblock->next = b; - else - oldest_sblock = b; - current_sblock = b; - } else { b = current_sblock; + + if (b == NULL + || (SBLOCK_SIZE - GC_STRING_EXTRA + < (char *) b->next_free - (char *) b + needed)) + { + /* Not enough room in the current sblock. */ + b = lisp_malloc (SBLOCK_SIZE, false, MEM_TYPE_NON_LISP); + data = b->data; + b->next = NULL; + b->next_free = data; + + if (current_sblock) + current_sblock->next = b; + else + oldest_sblock = b; + current_sblock = b; + } + data = b->next_free; + if (clearit) + memset (SDATA_DATA (data), 0, nbytes); } data->string = s; @@ -1866,16 +1886,53 @@ allocate_string_data (struct Lisp_String *s, GC_STRING_OVERRUN_COOKIE_SIZE); #endif - /* Note that Faset may call to this function when S has already data - assigned. In this case, mark data as free by setting it's string - back-pointer to null, and record the size of the data in it. */ - if (old_data) + tally_consing (needed); +} + +/* Reallocate the data for STRING when a single character is replaced. + The character is at byte offset CIDX_BYTE in the string. + The character being replaced is CLEN bytes long, + and the character that will replace it is NEW_CLEN bytes long. + Return the address of where the caller should store the + the new character. */ + +unsigned char * +resize_string_data (Lisp_Object string, ptrdiff_t cidx_byte, + int clen, int new_clen) +{ + sdata *old_sdata = SDATA_OF_STRING (XSTRING (string)); + ptrdiff_t nchars = SCHARS (string); + ptrdiff_t nbytes = SBYTES (string); + ptrdiff_t new_nbytes = nbytes + (new_clen - clen); + unsigned char *data = SDATA (string); + unsigned char *new_charaddr; + + if (sdata_size (nbytes) == sdata_size (new_nbytes)) { - SDATA_NBYTES (old_data) = old_nbytes; - old_data->string = NULL; + /* No need to reallocate, as the size change falls within the + alignment slop. */ + new_charaddr = data + cidx_byte; + memmove (new_charaddr + new_clen, new_charaddr + clen, + nbytes - (cidx_byte + (clen - 1))); + } + else + { + allocate_string_data (XSTRING (string), nchars, new_nbytes, false); + unsigned char *new_data = SDATA (string); + new_charaddr = new_data + cidx_byte; + memcpy (new_charaddr + new_clen, data + cidx_byte + clen, + nbytes - (cidx_byte + clen)); + memcpy (new_data, data, cidx_byte); + + /* Mark old string data as free by setting its string back-pointer + to null, and record the size of the data in it. */ + SDATA_NBYTES (old_sdata) = nbytes; + old_sdata->string = NULL; } - tally_consing (needed); + clear_string_char_byte_cache (); + + return new_charaddr; } @@ -2110,6 +2167,9 @@ string_overflow (void) error ("Maximum string size exceeded"); } +static Lisp_Object make_clear_string (EMACS_INT, bool); +static Lisp_Object make_clear_multibyte_string (EMACS_INT, EMACS_INT, bool); + 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. @@ -2118,19 +2178,20 @@ 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; + Lisp_Object val; EMACS_INT nbytes; CHECK_FIXNAT (length); CHECK_CHARACTER (init); - c = XFIXNAT (init); + int c = XFIXNAT (init); + bool clearit = !c; + if (ASCII_CHAR_P (c) && NILP (multibyte)) { nbytes = XFIXNUM (length); - val = make_uninit_string (nbytes); - if (nbytes) + val = make_clear_string (nbytes, clearit); + if (nbytes && !clearit) { memset (SDATA (val), c, nbytes); SDATA (val)[nbytes] = 0; @@ -2141,26 +2202,27 @@ a multibyte string even if INIT is an ASCII character. */) unsigned char str[MAX_MULTIBYTE_LENGTH]; ptrdiff_t len = CHAR_STRING (c, str); EMACS_INT string_len = XFIXNUM (length); - unsigned char *p, *beg, *end; if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes)) string_overflow (); - val = make_uninit_multibyte_string (string_len, nbytes); - for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len) + val = make_clear_multibyte_string (string_len, nbytes, clearit); + if (!clearit) { - /* First time we just copy `str' to the data of `val'. */ - if (p == beg) - memcpy (p, str, len); - else + unsigned char *beg = SDATA (val), *end = beg + nbytes; + for (unsigned char *p = beg; p < end; p += len) { - /* Next time we copy largest possible chunk from - initialized to uninitialized part of `val'. */ - len = min (p - beg, end - p); - memcpy (p, beg, len); + /* First time we just copy STR to the data of VAL. */ + if (p == beg) + memcpy (p, str, len); + else + { + /* Next time we copy largest possible chunk from + initialized to uninitialized part of VAL. */ + len = min (p - beg, end - p); + memcpy (p, beg, len); + } } } - if (nbytes) - *p = 0; } return val; @@ -2330,26 +2392,37 @@ make_specified_string (const char *contents, /* Return a unibyte Lisp_String set up to hold LENGTH characters - occupying LENGTH bytes. */ + occupying LENGTH bytes. If CLEARIT, clear its contents to null + bytes; otherwise, the contents are uninitialized. */ -Lisp_Object -make_uninit_string (EMACS_INT length) +static Lisp_Object +make_clear_string (EMACS_INT length, bool clearit) { Lisp_Object val; if (!length) return empty_unibyte_string; - val = make_uninit_multibyte_string (length, length); + val = make_clear_multibyte_string (length, length, clearit); STRING_SET_UNIBYTE (val); return val; } +/* Return a unibyte Lisp_String set up to hold LENGTH characters + occupying LENGTH bytes. */ + +Lisp_Object +make_uninit_string (EMACS_INT length) +{ + return make_clear_string (length, false); +} + /* Return a multibyte Lisp_String set up to hold NCHARS characters - which occupy NBYTES bytes. */ + which occupy NBYTES bytes. If CLEARIT, clear its contents to null + bytes; otherwise, the contents are uninitialized. */ -Lisp_Object -make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) +static Lisp_Object +make_clear_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes, bool clearit) { Lisp_Object string; struct Lisp_String *s; @@ -2361,12 +2434,21 @@ make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) s = allocate_string (); s->u.s.intervals = NULL; - allocate_string_data (s, nchars, nbytes); + allocate_string_data (s, nchars, nbytes, clearit); XSETSTRING (string, s); string_chars_consed += nbytes; return string; } +/* Return a multibyte Lisp_String set up to hold NCHARS characters + which occupy NBYTES bytes. */ + +Lisp_Object +make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) +{ + return make_clear_multibyte_string (nchars, nbytes, false); +} + /* Print arguments to BUF according to a FORMAT, then return a Lisp_String initialized with the data from BUF. */ @@ -3023,6 +3105,14 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } +#ifdef HAVE_MODULES + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MODULE_FUNCTION)) + { + ATTRIBUTE_MAY_ALIAS struct Lisp_Module_Function *function + = (struct Lisp_Module_Function *) vector; + module_finalize_function (function); + } +#endif } /* Reclaim space used by unmarked vectors. */ @@ -3137,7 +3227,7 @@ sweep_vectors (void) at most VECTOR_ELTS_MAX. */ static struct Lisp_Vector * -allocate_vectorlike (ptrdiff_t len) +allocate_vectorlike (ptrdiff_t len, bool clearit) { eassert (0 < len && len <= VECTOR_ELTS_MAX); ptrdiff_t nbytes = header_size + len * word_size; @@ -3151,11 +3241,15 @@ allocate_vectorlike (ptrdiff_t len) #endif if (nbytes <= VBLOCK_BYTES_MAX) - p = allocate_vector_from_block (vroundup (nbytes)); + { + p = allocate_vector_from_block (vroundup (nbytes)); + if (clearit) + memclear (p, nbytes); + } else { struct large_vector *lv = lisp_malloc (large_vector_offset + nbytes, - MEM_TYPE_VECTORLIKE); + clearit, MEM_TYPE_VECTORLIKE); lv->next = large_vectors; large_vectors = lv; p = large_vector_vec (lv); @@ -3178,20 +3272,37 @@ allocate_vectorlike (ptrdiff_t len) } -/* Allocate a vector with LEN slots. */ +/* Allocate a vector with LEN slots. If CLEARIT, clear its slots; + otherwise the vector's slots are uninitialized. */ -struct Lisp_Vector * -allocate_vector (ptrdiff_t len) +static struct Lisp_Vector * +allocate_clear_vector (ptrdiff_t len, bool clearit) { if (len == 0) return XVECTOR (zero_vector); if (VECTOR_ELTS_MAX < len) memory_full (SIZE_MAX); - struct Lisp_Vector *v = allocate_vectorlike (len); + struct Lisp_Vector *v = allocate_vectorlike (len, clearit); v->header.size = len; return v; } +/* Allocate a vector with LEN uninitialized slots. */ + +struct Lisp_Vector * +allocate_vector (ptrdiff_t len) +{ + return allocate_clear_vector (len, false); +} + +/* Allocate a vector with LEN nil slots. */ + +struct Lisp_Vector * +allocate_nil_vector (ptrdiff_t len) +{ + return allocate_clear_vector (len, true); +} + /* Allocate other vector-like structures. */ @@ -3208,7 +3319,7 @@ allocate_pseudovector (int memlen, int lisplen, eassert (lisplen <= size_max); eassert (memlen <= size_max + rest_max); - struct Lisp_Vector *v = allocate_vectorlike (memlen); + struct Lisp_Vector *v = allocate_vectorlike (memlen, false); /* Only the first LISPLEN slots will be traced normally by the GC. */ memclear (v->contents, zerolen * word_size); XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); @@ -3218,7 +3329,7 @@ allocate_pseudovector (int memlen, int lisplen, struct buffer * allocate_buffer (void) { - struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER); + struct buffer *b = lisp_malloc (sizeof *b, false, MEM_TYPE_BUFFER); BUFFER_PVEC_INIT (b); /* Put B on the chain of all buffers including killed ones. */ @@ -3238,7 +3349,7 @@ allocate_record (EMACS_INT count) if (count > PSEUDOVECTOR_SIZE_MASK) error ("Attempt to allocate a record of %"pI"d slots; max is %d", count, PSEUDOVECTOR_SIZE_MASK); - struct Lisp_Vector *p = allocate_vectorlike (count); + struct Lisp_Vector *p = allocate_vectorlike (count, false); p->header.size = count; XSETPVECTYPE (p, PVEC_RECORD); return p; @@ -3291,9 +3402,11 @@ See also the function `vector'. */) Lisp_Object make_vector (ptrdiff_t length, Lisp_Object init) { - struct Lisp_Vector *p = allocate_vector (length); - for (ptrdiff_t i = 0; i < length; i++) - p->contents[i] = init; + bool clearit = NIL_IS_ZERO && NILP (init); + struct Lisp_Vector *p = allocate_clear_vector (length, clearit); + if (!clearit) + for (ptrdiff_t i = 0; i < length; i++) + p->contents[i] = init; return make_lisp_ptr (p, Lisp_Vectorlike); } @@ -3442,7 +3555,7 @@ Its value is void, and its function definition and property list are nil. */) if (symbol_block_index == SYMBOL_BLOCK_SIZE) { struct symbol_block *new - = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL); + = lisp_malloc (sizeof *new, false, MEM_TYPE_SYMBOL); new->next = symbol_block; symbol_block = new; symbol_block_index = 0; @@ -3904,10 +4017,10 @@ refill_memory_reserve (void) MEM_TYPE_SPARE); if (spare_memory[5] == 0) spare_memory[5] = lisp_malloc (sizeof (struct string_block), - MEM_TYPE_SPARE); + false, MEM_TYPE_SPARE); if (spare_memory[6] == 0) spare_memory[6] = lisp_malloc (sizeof (struct string_block), - MEM_TYPE_SPARE); + false, MEM_TYPE_SPARE); if (spare_memory[0] && spare_memory[1] && spare_memory[5]) Vmemory_full = Qnil; #endif diff --git a/src/bytecode.c b/src/bytecode.c index 9e75c9012e0..4624379756d 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -220,10 +220,10 @@ DEFINE (Bdup, 0211) \ DEFINE (Bsave_excursion, 0212) \ DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ DEFINE (Bsave_restriction, 0214) \ -DEFINE (Bcatch, 0215) \ +DEFINE (Bcatch, 0215) /* Obsolete since Emacs-25. */ \ \ DEFINE (Bunwind_protect, 0216) \ -DEFINE (Bcondition_case, 0217) \ +DEFINE (Bcondition_case, 0217) /* Obsolete since Emacs-25. */ \ DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ \ @@ -763,7 +763,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, save_restriction_save ()); NEXT; - CASE (Bcatch): /* Obsolete since 24.4. */ + CASE (Bcatch): /* Obsolete since 25. */ { Lisp_Object v1 = POP; TOP = internal_catch (TOP, eval_sub, v1); @@ -807,7 +807,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; } - CASE (Bcondition_case): /* Obsolete since 24.4. */ + CASE (Bcondition_case): /* Obsolete since 25. */ { Lisp_Object handlers = POP, body = POP; TOP = internal_lisp_condition_case (TOP, body, handlers); diff --git a/src/coding.c b/src/coding.c index ed755b1afcf..8b54281c0bf 100644 --- a/src/coding.c +++ b/src/coding.c @@ -11745,6 +11745,8 @@ syms_of_coding (void) DEFSYM (Qignored, "ignored"); + DEFSYM (Qutf_8_string_p, "utf-8-string-p"); + defsubr (&Scoding_system_p); defsubr (&Sread_coding_system); defsubr (&Sread_non_nil_coding_system); diff --git a/src/data.c b/src/data.c index b1530688468..fae9cee7db1 100644 --- a/src/data.c +++ b/src/data.c @@ -2293,61 +2293,45 @@ bool-vector. IDX starts at 0. */) } else /* STRINGP */ { - int c; - CHECK_IMPURE (array, XSTRING (array)); if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); CHECK_CHARACTER (newelt); - c = XFIXNAT (newelt); + int c = XFIXNAT (newelt); + ptrdiff_t idxval_byte; + int prev_bytes; + unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; if (STRING_MULTIBYTE (array)) { - ptrdiff_t idxval_byte, nbytes; - int prev_bytes, new_bytes; - unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; - - nbytes = SBYTES (array); idxval_byte = string_char_to_byte (array, idxval); p1 = SDATA (array) + idxval_byte; prev_bytes = BYTES_BY_CHAR_HEAD (*p1); - new_bytes = CHAR_STRING (c, p0); - if (prev_bytes != new_bytes) - { - /* We must relocate the string data. */ - ptrdiff_t nchars = SCHARS (array); - USE_SAFE_ALLOCA; - unsigned char *str = SAFE_ALLOCA (nbytes); - - memcpy (str, SDATA (array), nbytes); - allocate_string_data (XSTRING (array), nchars, - nbytes + new_bytes - prev_bytes); - memcpy (SDATA (array), str, idxval_byte); - p1 = SDATA (array) + idxval_byte; - memcpy (p1 + new_bytes, str + idxval_byte + prev_bytes, - nbytes - (idxval_byte + prev_bytes)); - SAFE_FREE (); - clear_string_char_byte_cache (); - } - while (new_bytes--) - *p1++ = *p0++; } - else + else if (SINGLE_BYTE_CHAR_P (c)) { - if (! SINGLE_BYTE_CHAR_P (c)) - { - ptrdiff_t i; - - for (i = SBYTES (array) - 1; i >= 0; i--) - if (SREF (array, i) >= 0x80) - args_out_of_range (array, newelt); - /* ARRAY is an ASCII string. Convert it to a multibyte - string, and try `aset' again. */ - STRING_SET_MULTIBYTE (array); - return Faset (array, idx, newelt); - } SSET (array, idxval, c); + return newelt; } + else + { + for (ptrdiff_t i = SBYTES (array) - 1; i >= 0; i--) + if (!ASCII_CHAR_P (SREF (array, i))) + args_out_of_range (array, newelt); + /* ARRAY is an ASCII string. Convert it to a multibyte string. */ + STRING_SET_MULTIBYTE (array); + idxval_byte = idxval; + p1 = SDATA (array) + idxval_byte; + prev_bytes = 1; + } + + int new_bytes = CHAR_STRING (c, p0); + if (prev_bytes != new_bytes) + p1 = resize_string_data (array, idxval_byte, prev_bytes, new_bytes); + + do + *p1++ = *p0++; + while (--new_bytes != 0); } return newelt; @@ -3310,27 +3294,14 @@ bool_vector_spare_mask (EMACS_INT nr_bits) return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1; } -/* Info about unsigned long long, falling back on unsigned long - if unsigned long long is not available. */ - -#if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH -enum { ULL_WIDTH = ULLONG_WIDTH }; -# define ULL_MAX ULLONG_MAX -#else -enum { ULL_WIDTH = ULONG_WIDTH }; -# define ULL_MAX ULONG_MAX -# define count_one_bits_ll count_one_bits_l -# define count_trailing_zeros_ll count_trailing_zeros_l -#endif - /* Shift VAL right by the width of an unsigned long long. - ULL_WIDTH must be less than BITS_PER_BITS_WORD. */ + ULLONG_WIDTH must be less than BITS_PER_BITS_WORD. */ static bits_word shift_right_ull (bits_word w) { /* Pacify bogus GCC warning about shift count exceeding type width. */ - int shift = ULL_WIDTH - BITS_PER_BITS_WORD < 0 ? ULL_WIDTH : 0; + int shift = ULLONG_WIDTH - BITS_PER_BITS_WORD < 0 ? ULLONG_WIDTH : 0; return w >> shift; } @@ -3347,7 +3318,7 @@ count_one_bits_word (bits_word w) { int i = 0, count = 0; while (count += count_one_bits_ll (w), - (i += ULL_WIDTH) < BITS_PER_BITS_WORD) + (i += ULLONG_WIDTH) < BITS_PER_BITS_WORD) w = shift_right_ull (w); return count; } @@ -3478,7 +3449,7 @@ count_trailing_zero_bits (bits_word val) return count_trailing_zeros (val); if (BITS_WORD_MAX == ULONG_MAX) return count_trailing_zeros_l (val); - if (BITS_WORD_MAX == ULL_MAX) + if (BITS_WORD_MAX == ULLONG_MAX) return count_trailing_zeros_ll (val); /* The rest of this code is for the unlikely platform where bits_word differs @@ -3492,18 +3463,18 @@ count_trailing_zero_bits (bits_word val) { int count; for (count = 0; - count < BITS_PER_BITS_WORD - ULL_WIDTH; - count += ULL_WIDTH) + count < BITS_PER_BITS_WORD - ULLONG_WIDTH; + count += ULLONG_WIDTH) { - if (val & ULL_MAX) + if (val & ULLONG_MAX) return count + count_trailing_zeros_ll (val); val = shift_right_ull (val); } - if (BITS_PER_BITS_WORD % ULL_WIDTH != 0 + if (BITS_PER_BITS_WORD % ULLONG_WIDTH != 0 && BITS_WORD_MAX == (bits_word) -1) val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX, - BITS_PER_BITS_WORD % ULL_WIDTH); + BITS_PER_BITS_WORD % ULLONG_WIDTH); return count + count_trailing_zeros_ll (val); } } @@ -3516,10 +3487,8 @@ bits_word_to_host_endian (bits_word val) #else if (BITS_WORD_MAX >> 31 == 1) return bswap_32 (val); -# if HAVE_UNSIGNED_LONG_LONG if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1) return bswap_64 (val); -# endif { int i; bits_word r = 0; diff --git a/src/deps.mk b/src/deps.mk index a7e1b559173..4d162eeb0f2 100644 --- a/src/deps.mk +++ b/src/deps.mk @@ -239,9 +239,6 @@ xfont.o: dispextern.h xterm.h frame.h blockinput.h character.h charset.h \ xftfont.o: xftfont.c dispextern.h xterm.h frame.h blockinput.h character.h \ charset.h font.h lisp.h globals.h $(config_h) atimer.h systime.h \ fontset.h ccl.h ftfont.h composite.h -ftxfont.o: ftxfont.c dispextern.h xterm.h frame.h blockinput.h character.h \ - charset.h font.h lisp.h globals.h $(config_h) atimer.h systime.h \ - fontset.h ccl.h menu.o: menu.c lisp.h keyboard.h keymap.h frame.h termhooks.h blockinput.h \ dispextern.h $(srcdir)/../lwlib/lwlib.h xterm.h gtkutil.h menu.h \ lisp.h globals.h $(config_h) systime.h coding.h composite.h window.h \ diff --git a/src/dired.c b/src/dired.c index 611477aa4ef..f013a4cea03 100644 --- a/src/dired.c +++ b/src/dired.c @@ -937,7 +937,7 @@ file_attributes (int fd, char const *name, int err = EINVAL; #if defined O_PATH && !defined HAVE_CYGWIN_O_PATH_BUG - int namefd = openat (fd, name, O_PATH | O_CLOEXEC | O_NOFOLLOW); + int namefd = emacs_openat (fd, name, O_PATH | O_CLOEXEC | O_NOFOLLOW, 0); if (namefd < 0) err = errno; else @@ -970,7 +970,7 @@ file_attributes (int fd, char const *name, information to be accurate. */ w32_stat_get_owner_group = 1; #endif - err = fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0 ? 0 : errno; + err = emacs_fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0 ? 0 : errno; #ifdef WINDOWSNT w32_stat_get_owner_group = 0; #endif diff --git a/src/emacs-module.c b/src/emacs-module.c index d56d03203b1..60f16418efa 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -122,12 +122,6 @@ To add a new module function, proceed as follows: /* Function prototype for the module init function. */ typedef int (*emacs_init_function) (struct emacs_runtime *); -/* Function prototype for module user-pointer finalizers. These - should not throw C++ exceptions, so emacs-module.h declares the - corresponding interfaces with EMACS_NOEXCEPT. There is only C code - in this module, though, so this constraint is not enforced here. */ -typedef void (*emacs_finalizer_function) (void *); - /* Memory management. */ @@ -219,6 +213,25 @@ static bool value_storage_contains_p (const struct emacs_value_storage *, static bool module_assertions = false; + +/* Small helper functions. */ + +/* Interprets the string at STR with length LEN as UTF-8 string. + Signals an error if it's not a valid UTF-8 string. */ + +static Lisp_Object +module_decode_utf_8 (const char *str, ptrdiff_t len) +{ + /* We set HANDLE-8-BIT and HANDLE-OVER-UNI to nil to signal an error + if the argument is not a valid UTF-8 string. While it isn't + documented how make_string and make_function behave in this case, + signaling an error is the most defensive and obvious reaction. */ + Lisp_Object s = decode_string_utf_8 (Qnil, str, len, Qnil, false, Qnil, Qnil); + CHECK_TYPE (!NILP (s), Qutf_8_string_p, make_string_from_utf8 (str, len)); + return s; +} + + /* Convenience macros for non-local exit handling. */ /* FIXME: The following implementation for non-local exit handling @@ -333,6 +346,12 @@ static bool module_assertions = false; MODULE_HANDLE_NONLOCAL_EXIT (error_retval) static void +CHECK_MODULE_FUNCTION (Lisp_Object obj) +{ + CHECK_TYPE (MODULE_FUNCTIONP (obj), Qmodule_function_p, obj); +} + +static void CHECK_USER_PTR (Lisp_Object obj) { CHECK_TYPE (USER_PTRP (obj), Quser_ptrp, obj); @@ -343,11 +362,11 @@ CHECK_USER_PTR (Lisp_Object obj) the Emacs main thread. */ static emacs_env * -module_get_environment (struct emacs_runtime *ert) +module_get_environment (struct emacs_runtime *runtime) { module_assert_thread (); - module_assert_runtime (ert); - return ert->private_members->env; + module_assert_runtime (runtime); + return runtime->private_members->env; } /* To make global refs (GC-protected global values) keep a hash that @@ -356,11 +375,11 @@ module_get_environment (struct emacs_runtime *ert) static Lisp_Object Vmodule_refs_hash; static emacs_value -module_make_global_ref (emacs_env *env, emacs_value ref) +module_make_global_ref (emacs_env *env, emacs_value value) { MODULE_FUNCTION_BEGIN (NULL); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); - Lisp_Object new_obj = value_to_lisp (ref), hashcode; + Lisp_Object new_obj = value_to_lisp (value), hashcode; ptrdiff_t i = hash_lookup (h, new_obj, &hashcode); if (i >= 0) @@ -381,14 +400,14 @@ module_make_global_ref (emacs_env *env, emacs_value ref) } static void -module_free_global_ref (emacs_env *env, emacs_value ref) +module_free_global_ref (emacs_env *env, emacs_value global_value) { /* TODO: This probably never signals. */ /* FIXME: Wait a minute. Shouldn't this function report an error if the hash lookup fails? */ MODULE_FUNCTION_BEGIN (); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); - Lisp_Object obj = value_to_lisp (ref); + Lisp_Object obj = value_to_lisp (global_value); ptrdiff_t i = hash_lookup (h, obj, NULL); if (i >= 0) @@ -406,7 +425,7 @@ module_free_global_ref (emacs_env *env, emacs_value ref) if (module_assertions) { ptrdiff_t count = 0; - if (value_storage_contains_p (&global_storage, ref, &count)) + if (value_storage_contains_p (&global_storage, global_value, &count)) return; module_abort ("Global value was not found in list of %"pD"d globals", count); @@ -430,14 +449,15 @@ module_non_local_exit_clear (emacs_env *env) } static enum emacs_funcall_exit -module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) +module_non_local_exit_get (emacs_env *env, + emacs_value *symbol, emacs_value *data) { module_assert_thread (); module_assert_env (env); struct emacs_env_private *p = env->private_members; if (p->pending_non_local_exit != emacs_funcall_exit_return) { - *sym = &p->non_local_exit_symbol; + *symbol = &p->non_local_exit_symbol; *data = &p->non_local_exit_data; } return p->pending_non_local_exit; @@ -445,12 +465,13 @@ module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) /* Like for `signal', DATA must be a list. */ static void -module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data) +module_non_local_exit_signal (emacs_env *env, + emacs_value symbol, emacs_value data) { module_assert_thread (); module_assert_env (env); if (module_non_local_exit_check (env) == emacs_funcall_exit_return) - module_non_local_exit_signal_1 (env, value_to_lisp (sym), + module_non_local_exit_signal_1 (env, value_to_lisp (symbol), value_to_lisp (data)); } @@ -464,10 +485,6 @@ module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value) value_to_lisp (value)); } -/* Function prototype for the module Lisp functions. */ -typedef emacs_value (*emacs_subr) (emacs_env *, ptrdiff_t, - emacs_value [], void *); - /* Module function. */ /* A function environment is an auxiliary structure returned by @@ -484,8 +501,9 @@ struct Lisp_Module_Function /* Fields ignored by GC. */ ptrdiff_t min_arity, max_arity; - emacs_subr subr; + emacs_function subr; void *data; + emacs_finalizer finalizer; } GCALIGNED_STRUCT; static struct Lisp_Module_Function * @@ -503,8 +521,7 @@ allocate_module_function (void) static emacs_value module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, - emacs_subr subr, const char *documentation, - void *data) + emacs_function func, const char *docstring, void *data) { MODULE_FUNCTION_BEGIN (NULL); @@ -518,11 +535,13 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, struct Lisp_Module_Function *function = allocate_module_function (); function->min_arity = min_arity; function->max_arity = max_arity; - function->subr = subr; + function->subr = func; function->data = data; + function->finalizer = NULL; - if (documentation) - function->documentation = build_string_from_utf8 (documentation); + if (docstring) + function->documentation + = module_decode_utf_8 (docstring, strlen (docstring)); Lisp_Object result; XSET_MODULE_FUNCTION (result, function); @@ -531,9 +550,35 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, return lisp_to_value (env, result); } +static emacs_finalizer +module_get_function_finalizer (emacs_env *env, emacs_value arg) +{ + MODULE_FUNCTION_BEGIN (NULL); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_MODULE_FUNCTION (lisp); + return XMODULE_FUNCTION (lisp)->finalizer; +} + +static void +module_set_function_finalizer (emacs_env *env, emacs_value arg, + emacs_finalizer fin) +{ + MODULE_FUNCTION_BEGIN (); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_MODULE_FUNCTION (lisp); + XMODULE_FUNCTION (lisp)->finalizer = fin; +} + +void +module_finalize_function (const struct Lisp_Module_Function *func) +{ + if (func->finalizer != NULL) + func->finalizer (func->data); +} + static emacs_value -module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, - emacs_value args[]) +module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs, + emacs_value *args) { MODULE_FUNCTION_BEGIN (NULL); @@ -545,7 +590,7 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, if (INT_ADD_WRAPV (nargs, 1, &nargs1)) overflow_error (); SAFE_ALLOCA_LISP (newargs, nargs1); - newargs[0] = value_to_lisp (fun); + newargs[0] = value_to_lisp (func); for (ptrdiff_t i = 0; i < nargs; i++) newargs[1 + i] = value_to_lisp (args[i]); emacs_value result = lisp_to_value (env, Ffuncall (nargs1, newargs)); @@ -561,17 +606,17 @@ module_intern (emacs_env *env, const char *name) } static emacs_value -module_type_of (emacs_env *env, emacs_value value) +module_type_of (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - return lisp_to_value (env, Ftype_of (value_to_lisp (value))); + return lisp_to_value (env, Ftype_of (value_to_lisp (arg))); } static bool -module_is_not_nil (emacs_env *env, emacs_value value) +module_is_not_nil (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN_NO_CATCH (false); - return ! NILP (value_to_lisp (value)); + return ! NILP (value_to_lisp (arg)); } static bool @@ -582,14 +627,14 @@ module_eq (emacs_env *env, emacs_value a, emacs_value b) } static intmax_t -module_extract_integer (emacs_env *env, emacs_value n) +module_extract_integer (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object l = value_to_lisp (n); - CHECK_INTEGER (l); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_INTEGER (lisp); intmax_t i; - if (! integer_to_intmax (l, &i)) - xsignal1 (Qoverflow_error, l); + if (! integer_to_intmax (lisp, &i)) + xsignal1 (Qoverflow_error, lisp); return i; } @@ -601,10 +646,10 @@ module_make_integer (emacs_env *env, intmax_t n) } static double -module_extract_float (emacs_env *env, emacs_value f) +module_extract_float (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object lisp = value_to_lisp (f); + Lisp_Object lisp = value_to_lisp (arg); CHECK_TYPE (FLOATP (lisp), Qfloatp, lisp); return XFLOAT_DATA (lisp); } @@ -617,8 +662,8 @@ module_make_float (emacs_env *env, double d) } static bool -module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, - ptrdiff_t *length) +module_copy_string_contents (emacs_env *env, emacs_value value, char *buf, + ptrdiff_t *len) { MODULE_FUNCTION_BEGIN (false); Lisp_Object lisp_str = value_to_lisp (value); @@ -642,77 +687,77 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, ptrdiff_t raw_size = SBYTES (lisp_str_utf8); ptrdiff_t required_buf_size = raw_size + 1; - if (buffer == NULL) + if (buf == NULL) { - *length = required_buf_size; + *len = required_buf_size; return true; } - if (*length < required_buf_size) + if (*len < required_buf_size) { - ptrdiff_t actual = *length; - *length = required_buf_size; + ptrdiff_t actual = *len; + *len = required_buf_size; args_out_of_range_3 (INT_TO_INTEGER (actual), INT_TO_INTEGER (required_buf_size), INT_TO_INTEGER (PTRDIFF_MAX)); } - *length = required_buf_size; - memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1); + *len = required_buf_size; + memcpy (buf, SDATA (lisp_str_utf8), raw_size + 1); return true; } static emacs_value -module_make_string (emacs_env *env, const char *str, ptrdiff_t length) +module_make_string (emacs_env *env, const char *str, ptrdiff_t len) { MODULE_FUNCTION_BEGIN (NULL); - if (! (0 <= length && length <= STRING_BYTES_BOUND)) + if (! (0 <= len && len <= STRING_BYTES_BOUND)) overflow_error (); - Lisp_Object lstr = make_string_from_utf8 (str, length); + Lisp_Object lstr = module_decode_utf_8 (str, len); return lisp_to_value (env, lstr); } static emacs_value -module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) +module_make_user_ptr (emacs_env *env, emacs_finalizer fin, void *ptr) { MODULE_FUNCTION_BEGIN (NULL); return lisp_to_value (env, make_user_ptr (fin, ptr)); } static void * -module_get_user_ptr (emacs_env *env, emacs_value uptr) +module_get_user_ptr (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->p; } static void -module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr) +module_set_user_ptr (emacs_env *env, emacs_value arg, void *ptr) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->p = ptr; } -static emacs_finalizer_function -module_get_user_finalizer (emacs_env *env, emacs_value uptr) +static emacs_finalizer +module_get_user_finalizer (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->finalizer; } static void -module_set_user_finalizer (emacs_env *env, emacs_value uptr, - emacs_finalizer_function fin) +module_set_user_finalizer (emacs_env *env, emacs_value arg, + emacs_finalizer fin) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->finalizer = fin; } @@ -727,30 +772,31 @@ check_vec_index (Lisp_Object lvec, ptrdiff_t i) } static void -module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) +module_vec_set (emacs_env *env, emacs_value vector, ptrdiff_t index, + emacs_value value) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lvec = value_to_lisp (vec); - check_vec_index (lvec, i); - ASET (lvec, i, value_to_lisp (val)); + Lisp_Object lisp = value_to_lisp (vector); + check_vec_index (lisp, index); + ASET (lisp, index, value_to_lisp (value)); } static emacs_value -module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) +module_vec_get (emacs_env *env, emacs_value vector, ptrdiff_t index) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lvec = value_to_lisp (vec); - check_vec_index (lvec, i); - return lisp_to_value (env, AREF (lvec, i)); + Lisp_Object lisp = value_to_lisp (vector); + check_vec_index (lisp, index); + return lisp_to_value (env, AREF (lisp, index)); } static ptrdiff_t -module_vec_size (emacs_env *env, emacs_value vec) +module_vec_size (emacs_env *env, emacs_value vector) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object lvec = value_to_lisp (vec); - CHECK_VECTOR (lvec); - return ASIZE (lvec); + Lisp_Object lisp = value_to_lisp (vector); + CHECK_VECTOR (lisp); + return ASIZE (lisp); } /* This function should return true if and only if maybe_quit would @@ -771,10 +817,10 @@ module_process_input (emacs_env *env) } static struct timespec -module_extract_time (emacs_env *env, emacs_value value) +module_extract_time (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN ((struct timespec) {0}); - return lisp_time_argument (value_to_lisp (value)); + return lisp_time_argument (value_to_lisp (arg)); } static emacs_value @@ -1072,6 +1118,12 @@ module_function_address (const struct Lisp_Module_Function *function) return (module_funcptr) function->subr; } +void * +module_function_data (const struct Lisp_Module_Function *function) +{ + return function->data; +} + /* Helper functions. */ @@ -1088,14 +1140,14 @@ module_assert_thread (void) } static void -module_assert_runtime (struct emacs_runtime *ert) +module_assert_runtime (struct emacs_runtime *runtime) { if (! module_assertions) return; ptrdiff_t count = 0; for (Lisp_Object tail = Vmodule_runtimes; CONSP (tail); tail = XCDR (tail)) { - if (xmint_pointer (XCAR (tail)) == ert) + if (xmint_pointer (XCAR (tail)) == runtime) return; ++count; } @@ -1337,6 +1389,8 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) env->make_time = module_make_time; env->extract_big_integer = module_extract_big_integer; env->make_big_integer = module_make_big_integer; + env->get_function_finalizer = module_get_function_finalizer; + env->set_function_finalizer = module_set_function_finalizer; Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments); return env; } diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in index 898021dc5e6..cd75c0907e4 100644 --- a/src/emacs-module.h.in +++ b/src/emacs-module.h.in @@ -42,6 +42,12 @@ information how to write modules and use this header file. # define EMACS_NOEXCEPT #endif +#if defined __cplusplus && __cplusplus >= 201703L +# define EMACS_NOEXCEPT_TYPEDEF noexcept +#else +# define EMACS_NOEXCEPT_TYPEDEF +#endif + #ifdef __has_attribute #if __has_attribute(__nonnull__) # define EMACS_ATTRIBUTE_NONNULL(...) __attribute__((__nonnull__(__VA_ARGS__))) @@ -56,7 +62,7 @@ extern "C" { #endif /* Current environment. */ -typedef struct emacs_env_27 emacs_env; +typedef struct emacs_env_@emacs_major_version@ emacs_env; /* Opaque pointer representing an Emacs Lisp value. BEWARE: Do not assume NULL is a valid value! */ @@ -74,10 +80,25 @@ struct emacs_runtime struct emacs_runtime_private *private_members; /* Return an environment pointer. */ - emacs_env *(*get_environment) (struct emacs_runtime *ert) + emacs_env *(*get_environment) (struct emacs_runtime *runtime) EMACS_ATTRIBUTE_NONNULL(1); }; +/* Type aliases for function pointer types used in the module API. + Note that we don't use these aliases directly in the API to be able + to mark the function arguments as 'noexcept' before C++20. + However, users can use them if they want. */ + +/* Function prototype for the module Lisp functions. These must not + throw C++ exceptions. */ +typedef emacs_value (*emacs_function) (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, + void *data) + EMACS_NOEXCEPT_TYPEDEF EMACS_ATTRIBUTE_NONNULL (1); + +/* Function prototype for module user-pointer and function finalizers. + These must not throw C++ exceptions. */ +typedef void (*emacs_finalizer) (void *data) EMACS_NOEXCEPT_TYPEDEF; /* Possible Emacs function call outcomes. */ enum emacs_funcall_exit @@ -131,8 +152,19 @@ struct emacs_env_27 @module_env_snippet_27@ }; +struct emacs_env_28 +{ +@module_env_snippet_25@ + +@module_env_snippet_26@ + +@module_env_snippet_27@ + +@module_env_snippet_28@ +}; + /* Every module should define a function as follows. */ -extern int emacs_module_init (struct emacs_runtime *ert) +extern int emacs_module_init (struct emacs_runtime *runtime) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); diff --git a/src/fileio.c b/src/fileio.c index 34934dd6df6..87a17eab425 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -1952,7 +1952,10 @@ barf_or_query_if_file_exists (Lisp_Object absname, bool known_to_exist, encoded_filename = ENCODE_FILE (absname); - if (! known_to_exist && lstat (SSDATA (encoded_filename), &statbuf) == 0) + if (! known_to_exist + && (emacs_fstatat (AT_FDCWD, SSDATA (encoded_filename), + &statbuf, AT_SYMLINK_NOFOLLOW) + == 0)) { if (S_ISDIR (statbuf.st_mode)) xsignal2 (Qfile_error, @@ -2555,7 +2558,9 @@ This is what happens in interactive use with M-x. */) bool dirp = !NILP (Fdirectory_name_p (file)); if (!dirp) { - if (lstat (SSDATA (encoded_file), &file_st) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (encoded_file), + &file_st, AT_SYMLINK_NOFOLLOW) + != 0) report_file_error ("Renaming", list2 (file, newname)); dirp = S_ISDIR (file_st.st_mode) != 0; } @@ -2928,7 +2933,8 @@ file_directory_p (Lisp_Object file) #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); + int fd = emacs_openat (AT_FDCWD, SSDATA (file), + O_PATH | O_CLOEXEC | O_DIRECTORY, 0); if (0 <= fd) { emacs_close (fd); @@ -2939,9 +2945,9 @@ file_directory_p (Lisp_Object file) /* O_PATH is defined but evidently this Linux kernel predates 2.6.39. Fall back on generic POSIX code. */ # endif - /* Use file_accessible_directory_p, as it avoids stat EOVERFLOW + /* Use file_accessible_directory_p, as it avoids fstatat EOVERFLOW problems and could be cheaper. However, if it fails because FILE - is inaccessible, fall back on stat; if the latter fails with + is inaccessible, fall back on fstatat; 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)) @@ -2949,7 +2955,7 @@ file_directory_p (Lisp_Object file) if (errno != EACCES) return false; struct stat st; - if (stat (SSDATA (file), &st) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (file), &st, 0) != 0) return errno == EOVERFLOW; if (S_ISDIR (st.st_mode)) return true; @@ -3080,7 +3086,7 @@ See `file-symlink-p' to distinguish symlinks. */) Vw32_get_true_file_attributes = Qt; #endif - int stat_result = stat (SSDATA (absname), &st); + int stat_result = emacs_fstatat (AT_FDCWD, SSDATA (absname), &st, 0); #ifdef WINDOWSNT Vw32_get_true_file_attributes = true_attributes; @@ -3340,7 +3346,7 @@ Return nil if FILENAME does not exist. */) if (!NILP (handler)) return call2 (handler, Qfile_modes, absname); - if (stat (SSDATA (ENCODE_FILE (absname)), &st) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname)), &st, 0) != 0) return file_attribute_errno (absname, errno); return make_fixnum (st.st_mode & 07777); } @@ -3486,7 +3492,7 @@ otherwise, if FILE2 does not exist, the answer is t. */) return call3 (handler, Qfile_newer_than_file_p, absname1, absname2); int err1; - if (stat (SSDATA (ENCODE_FILE (absname1)), &st1) == 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname1)), &st1, 0) == 0) err1 = 0; else { @@ -3494,7 +3500,7 @@ otherwise, if FILE2 does not exist, the answer is t. */) if (err1 != EOVERFLOW) return file_attribute_errno (absname1, err1); } - if (stat (SSDATA (ENCODE_FILE (absname2)), &st2) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname2)), &st2, 0) != 0) { file_attribute_errno (absname2, errno); return Qt; @@ -3880,7 +3886,7 @@ by calling `format-decode', which see. */) if (end_offset < 0) buffer_overflow (); - /* The file size returned from stat may be zero, but data + /* The file size returned from fstat may be zero, but data may be readable nonetheless, for example when this is a file in the /proc filesystem. */ if (end_offset == 0) @@ -5625,7 +5631,7 @@ See Info node `(elisp)Modification Time' for more details. */) filename = ENCODE_FILE (BVAR (b, filename)); - mtime = (stat (SSDATA (filename), &st) == 0 + mtime = (emacs_fstatat (AT_FDCWD, SSDATA (filename), &st, 0) == 0 ? get_stat_mtime (&st) : time_error_value (errno)); if (timespec_cmp (mtime, b->modtime) == 0 @@ -5689,7 +5695,8 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */) /* The handler can find the file name the same way we did. */ return call2 (handler, Qset_visited_file_modtime, Qnil); - if (stat (SSDATA (ENCODE_FILE (filename)), &st) == 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (filename)), &st, 0) + == 0) { current_buffer->modtime = get_stat_mtime (&st); current_buffer->modtime_size = st.st_size; @@ -5728,12 +5735,14 @@ auto_save_1 (void) /* Get visited file's mode to become the auto save file's mode. */ if (! NILP (BVAR (current_buffer, filename))) { - if (stat (SSDATA (BVAR (current_buffer, filename)), &st) >= 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (BVAR (current_buffer, filename)), + &st, 0) + == 0) /* But make sure we can overwrite it later! */ auto_save_mode_bits = (st.st_mode | 0600) & 0777; else if (modes = Ffile_modes (BVAR (current_buffer, filename)), FIXNUMP (modes)) - /* Remote files don't cooperate with stat. */ + /* Remote files don't cooperate with fstatat. */ auto_save_mode_bits = (XFIXNUM (modes) | 0600) & 0777; } diff --git a/src/filelock.c b/src/filelock.c index b28f16e9b5a..73202f0b2c4 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -347,7 +347,8 @@ rename_lock_file (char const *old, char const *new, bool force) potential race condition since some other process may create NEW immediately after the existence check, but it's the best we can portably do here. */ - if (lstat (new, &st) == 0 || errno == EOVERFLOW) + if (emacs_fstatat (AT_FDCWD, new, &st, AT_SYMLINK_NOFOLLOW) == 0 + || errno == EOVERFLOW) { errno = EEXIST; return -1; diff --git a/src/fns.c b/src/fns.c index 3b5feace521..436ef1c7b74 100644 --- a/src/fns.c +++ b/src/fns.c @@ -47,6 +47,7 @@ static void sort_vector_copy (Lisp_Object, ptrdiff_t, enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES }; static bool internal_equal (Lisp_Object, Lisp_Object, enum equal_kind, int, Lisp_Object); +static EMACS_UINT sxhash_obj (Lisp_Object, int); DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, doc: /* Return the ARGUMENT unchanged. */ @@ -2433,6 +2434,9 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, same size. */ if (ASIZE (o2) != size) return false; + + /* Compare bignums, overlays, markers, and boolvectors + specially, by comparing their values. */ if (BIGNUMP (o1)) return mpz_cmp (*xbignum_val (o1), *xbignum_val (o2)) == 0; if (OVERLAYP (o1)) @@ -2453,21 +2457,12 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, && (XMARKER (o1)->buffer == 0 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos)); } - /* Boolvectors are compared much like strings. */ if (BOOL_VECTOR_P (o1)) { EMACS_INT size = bool_vector_size (o1); - if (size != bool_vector_size (o2)) - return false; - if (memcmp (bool_vector_data (o1), bool_vector_data (o2), - bool_vector_bytes (size))) - return false; - return true; - } - if (WINDOW_CONFIGURATIONP (o1)) - { - eassert (equal_kind != EQUAL_NO_QUIT); - return compare_window_configurations (o1, o2, false); + return (size == bool_vector_size (o2) + && !memcmp (bool_vector_data (o1), bool_vector_data (o2), + bool_vector_bytes (size))); } /* Aside from them, only true vectors, char-tables, compiled @@ -2493,16 +2488,11 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, break; case Lisp_String: - if (SCHARS (o1) != SCHARS (o2)) - return false; - if (SBYTES (o1) != SBYTES (o2)) - return false; - if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1))) - return false; - if (equal_kind == EQUAL_INCLUDING_PROPERTIES - && !compare_string_intervals (o1, o2)) - return false; - return true; + return (SCHARS (o1) == SCHARS (o2) + && SBYTES (o1) == SBYTES (o2) + && !memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)) + && (equal_kind != EQUAL_INCLUDING_PROPERTIES + || compare_string_intervals (o1, o2))); default: break; @@ -4022,7 +4012,7 @@ hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h) Lisp_Object hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h) { - return make_ufixnum (sxhash (key, 0)); + return make_ufixnum (sxhash (key)); } /* Ignore HT and return a hash code for KEY which uses 'eql' to compare keys. @@ -4042,7 +4032,7 @@ hashfn_user_defined (Lisp_Object key, struct Lisp_Hash_Table *h) { Lisp_Object args[] = { h->test.user_hash_function, key }; Lisp_Object hash = hash_table_user_defined_call (ARRAYELTS (args), args, h); - return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash, 0)); + return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash)); } struct hash_table_test const @@ -4606,13 +4596,13 @@ sxhash_list (Lisp_Object list, int depth) CONSP (list) && i < SXHASH_MAX_LEN; list = XCDR (list), ++i) { - EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1); + EMACS_UINT hash2 = sxhash_obj (XCAR (list), depth + 1); hash = sxhash_combine (hash, hash2); } if (!NILP (list)) { - EMACS_UINT hash2 = sxhash (list, depth + 1); + EMACS_UINT hash2 = sxhash_obj (list, depth + 1); hash = sxhash_combine (hash, hash2); } @@ -4632,7 +4622,7 @@ sxhash_vector (Lisp_Object vec, int depth) n = min (SXHASH_MAX_LEN, hash & PSEUDOVECTOR_FLAG ? PVSIZE (vec) : hash); for (i = 0; i < n; ++i) { - EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1); + EMACS_UINT hash2 = sxhash_obj (AREF (vec, i), depth + 1); hash = sxhash_combine (hash, hash2); } @@ -4675,58 +4665,78 @@ sxhash_bignum (Lisp_Object bignum) structure. Value is an unsigned integer clipped to INTMASK. */ EMACS_UINT -sxhash (Lisp_Object obj, int depth) +sxhash (Lisp_Object obj) { - EMACS_UINT hash; + return sxhash_obj (obj, 0); +} +static EMACS_UINT +sxhash_obj (Lisp_Object obj, int depth) +{ if (depth > SXHASH_MAX_DEPTH) return 0; switch (XTYPE (obj)) { case_Lisp_Int: - hash = XUFIXNUM (obj); - break; + return XUFIXNUM (obj); case Lisp_Symbol: - hash = XHASH (obj); - break; + return XHASH (obj); case Lisp_String: - hash = sxhash_string (SSDATA (obj), SBYTES (obj)); - break; + return sxhash_string (SSDATA (obj), SBYTES (obj)); - /* This can be everything from a vector to an overlay. */ case Lisp_Vectorlike: - if (BIGNUMP (obj)) - hash = sxhash_bignum (obj); - else if (VECTORP (obj) || RECORDP (obj)) - /* According to the CL HyperSpec, two arrays are equal only if - they are `eq', except for strings and bit-vectors. In - Emacs, this works differently. We have to compare element - by element. Same for records. */ - hash = sxhash_vector (obj, depth); - else if (BOOL_VECTOR_P (obj)) - hash = sxhash_bool_vector (obj); - else - /* Others are `equal' if they are `eq', so let's take their - address as hash. */ - hash = XHASH (obj); - break; + { + enum pvec_type pvec_type = PSEUDOVECTOR_TYPE (XVECTOR (obj)); + if (! (PVEC_NORMAL_VECTOR < pvec_type && pvec_type < PVEC_COMPILED)) + { + /* According to the CL HyperSpec, two arrays are equal only if + they are 'eq', except for strings and bit-vectors. In + Emacs, this works differently. We have to compare element + by element. Same for pseudovectors that internal_equal + examines the Lisp contents of. */ + return (SUB_CHAR_TABLE_P (obj) + /* 'sxhash_vector' can't be applies to a sub-char-table and + it's probably not worth looking into them anyway! */ + ? 42 + : sxhash_vector (obj, depth)); + } + else if (pvec_type == PVEC_BIGNUM) + return sxhash_bignum (obj); + else if (pvec_type == PVEC_MARKER) + { + ptrdiff_t bytepos + = XMARKER (obj)->buffer ? XMARKER (obj)->bytepos : 0; + EMACS_UINT hash + = sxhash_combine ((intptr_t) XMARKER (obj)->buffer, bytepos); + return SXHASH_REDUCE (hash); + } + else if (pvec_type == PVEC_BOOL_VECTOR) + return sxhash_bool_vector (obj); + else if (pvec_type == PVEC_OVERLAY) + { + EMACS_UINT hash = sxhash_obj (OVERLAY_START (obj), depth); + hash = sxhash_combine (hash, sxhash_obj (OVERLAY_END (obj), depth)); + hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth)); + return SXHASH_REDUCE (hash); + } + else + /* Others are 'equal' if they are 'eq', so take their + address as hash. */ + return XHASH (obj); + } case Lisp_Cons: - hash = sxhash_list (obj, depth); - break; + return sxhash_list (obj, depth); case Lisp_Float: - hash = sxhash_float (XFLOAT_DATA (obj)); - break; + return sxhash_float (XFLOAT_DATA (obj)); default: emacs_abort (); } - - return hash; } diff --git a/src/font.c b/src/font.c index 2b90903c909..bb39aef92d5 100644 --- a/src/font.c +++ b/src/font.c @@ -5545,7 +5545,6 @@ cause Xft crashes. Only has an effect in Xft builds. */); #ifdef USE_CAIRO syms_of_ftcrfont (); #else - syms_of_ftxfont (); #ifdef HAVE_XFT syms_of_xftfont (); #endif /* HAVE_XFT */ diff --git a/src/font.h b/src/font.h index 633d92709c5..0561e3c83f5 100644 --- a/src/font.h +++ b/src/font.h @@ -69,8 +69,8 @@ INLINE_HEADER_BEGIN enum font_property_index { - /* FONT-TYPE is a symbol indicating a font backend; currently `x', - `xft', and `ftx' are available on X, `uniscribe' and `gdi' on + /* FONT-TYPE is a symbol indicating a font backend; currently `x' + and `xft' are available on X, `uniscribe' and `gdi' on Windows, and `ns' under Cocoa / GNUstep. */ FONT_TYPE_INDEX, @@ -938,7 +938,6 @@ extern void syms_of_ftfont (void); extern struct font_driver const xfont_driver; extern Lisp_Object xfont_get_cache (struct frame *); extern void syms_of_xfont (void); -extern void syms_of_ftxfont (void); #ifdef HAVE_XFT extern struct font_driver const xftfont_driver; #ifdef HAVE_HARFBUZZ @@ -946,7 +945,6 @@ extern struct font_driver xfthbfont_driver; #endif /* HAVE_HARFBUZZ */ #endif #if defined HAVE_FREETYPE || defined HAVE_XFT -extern struct font_driver const ftxfont_driver; extern void syms_of_xftfont (void); #endif #ifdef HAVE_BDFFONT diff --git a/src/frame.c b/src/frame.c index 88d6f22fc0a..51fc78ab703 100644 --- a/src/frame.c +++ b/src/frame.c @@ -904,7 +904,7 @@ make_frame (bool mini_p) f->last_tool_bar_item = -1; #endif #ifdef NS_IMPL_COCOA - f->ns_appearance = ns_appearance_aqua; + f->ns_appearance = ns_appearance_system_default; f->ns_transparent_titlebar = false; #endif #endif diff --git a/src/frame.h b/src/frame.h index 6ab690c0ff5..68dc0ce3649 100644 --- a/src/frame.h +++ b/src/frame.h @@ -69,8 +69,9 @@ enum internal_border_part #ifdef NS_IMPL_COCOA enum ns_appearance_type { - ns_appearance_aqua, - ns_appearance_vibrant_dark + ns_appearance_system_default, + ns_appearance_aqua, + ns_appearance_vibrant_dark }; #endif #endif /* HAVE_WINDOW_SYSTEM */ diff --git a/src/ftxfont.c b/src/ftxfont.c deleted file mode 100644 index 9bbb2c064c2..00000000000 --- a/src/ftxfont.c +++ /dev/null @@ -1,371 +0,0 @@ -/* ftxfont.c -- FreeType font driver on X (without using XFT). - Copyright (C) 2006-2020 Free Software Foundation, Inc. - Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 - National Institute of Advanced Industrial Science and Technology (AIST) - Registration Number H13PRO009 - -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 <X11/Xlib.h> - -#include "lisp.h" -#include "xterm.h" -#include "frame.h" -#include "blockinput.h" -#include "font.h" -#include "pdumper.h" - -/* FTX font driver. */ - -struct ftxfont_frame_data -{ - /* Background and foreground colors. */ - XColor colors[2]; - /* GCs interpolating the above colors. gcs[0] is for a color - closest to BACKGROUND, and gcs[5] is for a color closest to - FOREGROUND. */ - GC gcs[6]; - struct ftxfont_frame_data *next; -}; - - -/* Return an array of 6 GCs for antialiasing. */ - -static GC * -ftxfont_get_gcs (struct frame *f, unsigned long foreground, unsigned long background) -{ - XColor color; - XGCValues xgcv; - int i; - struct ftxfont_frame_data *data = font_get_frame_data (f, Qftx); - struct ftxfont_frame_data *prev = NULL, *this = NULL, *new; - - if (data) - { - for (this = data; this; prev = this, this = this->next) - { - if (this->colors[0].pixel < background) - continue; - if (this->colors[0].pixel > background) - break; - if (this->colors[1].pixel < foreground) - continue; - if (this->colors[1].pixel > foreground) - break; - return this->gcs; - } - } - - new = xmalloc (sizeof *new); - new->next = this; - if (prev) - prev->next = new; - font_put_frame_data (f, Qftx, new); - - new->colors[0].pixel = background; - new->colors[1].pixel = foreground; - - block_input (); - XQueryColors (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), new->colors, 2); - for (i = 1; i < 7; i++) - { - /* Interpolate colors linearly. Any better algorithm? */ - color.red - = (new->colors[1].red * i + new->colors[0].red * (8 - i)) / 8; - color.green - = (new->colors[1].green * i + new->colors[0].green * (8 - i)) / 8; - color.blue - = (new->colors[1].blue * i + new->colors[0].blue * (8 - i)) / 8; - if (! x_alloc_nearest_color (f, FRAME_X_COLORMAP (f), &color)) - break; - xgcv.foreground = color.pixel; - new->gcs[i - 1] = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - GCForeground, &xgcv); - } - unblock_input (); - - if (i < 7) - { - block_input (); - for (i--; i >= 0; i--) - XFreeGC (FRAME_X_DISPLAY (f), new->gcs[i]); - unblock_input (); - if (prev) - prev->next = new->next; - else if (data) - font_put_frame_data (f, Qftx, new->next); - xfree (new); - return NULL; - } - return new->gcs; -} - -static int -ftxfont_draw_bitmap (struct frame *f, GC gc_fore, GC *gcs, struct font *font, - unsigned int code, int x, int y, XPoint *p, int size, - int *n, bool flush) -{ - struct font_bitmap bitmap; - unsigned char *b; - int i, j; - - if (ftfont_get_bitmap (font, code, &bitmap, size > 0x100 ? 1 : 8) < 0) - return 0; - if (size > 0x100) - { - for (i = 0, b = bitmap.buffer; i < bitmap.rows; - i++, b += bitmap.pitch) - { - for (j = 0; j < bitmap.width; j++) - if (b[j / 8] & (1 << (7 - (j % 8)))) - { - p[n[0]].x = x + bitmap.left + j; - p[n[0]].y = y - bitmap.top + i; - if (++n[0] == size) - { - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p, size, CoordModeOrigin); - n[0] = 0; - } - } - } - if (flush && n[0] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p, n[0], CoordModeOrigin); - } - else - { - for (i = 0, b = bitmap.buffer; i < bitmap.rows; - i++, b += bitmap.pitch) - { - for (j = 0; j < bitmap.width; j++) - { - int idx = (bitmap.bits_per_pixel == 1 - ? ((b[j / 8] & (1 << (7 - (j % 8)))) ? 6 : -1) - : (b[j] >> 5) - 1); - - if (idx >= 0) - { - XPoint *pp = p + size * idx; - - pp[n[idx]].x = x + bitmap.left + j; - pp[n[idx]].y = y - bitmap.top + i; - if (++(n[idx]) == size) - { - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - idx == 6 ? gc_fore : gcs[idx], pp, size, - CoordModeOrigin); - n[idx] = 0; - } - } - } - } - if (flush) - { - for (i = 0; i < 6; i++) - if (n[i] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gcs[i], p + 0x100 * i, n[i], CoordModeOrigin); - if (n[6] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p + 0x600, n[6], CoordModeOrigin); - } - } - - /* There is no ftfont_free_bitmap, so do not try to free BITMAP. */ - - return bitmap.advance; -} - -static void -ftxfont_draw_background (struct frame *f, struct font *font, GC gc, int x, int y, - int width) -{ - XGCValues xgcv; - - XGetGCValues (FRAME_X_DISPLAY (f), gc, - GCForeground | GCBackground, &xgcv); - XSetForeground (FRAME_X_DISPLAY (f), gc, xgcv.background); - XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc, - x, y - FONT_BASE (font), width, FONT_HEIGHT (font)); - XSetForeground (FRAME_X_DISPLAY (f), gc, xgcv.foreground); -} - -static Lisp_Object -ftxfont_list (struct frame *f, Lisp_Object spec) -{ - return ftfont_list2 (f, spec, Qftx); -} - -static Lisp_Object -ftxfont_match (struct frame *f, Lisp_Object spec) -{ - return ftfont_match2 (f, spec, Qftx); -} - -static Lisp_Object -ftxfont_open (struct frame *f, Lisp_Object entity, int pixel_size) -{ - Lisp_Object font_object = ftfont_open (f, entity, pixel_size); - if (NILP (font_object)) - return Qnil; - struct font *font = XFONT_OBJECT (font_object); - font->driver = &ftxfont_driver; - return font_object; -} - -static void -ftxfont_close (struct font *font) -{ - ftfont_close (font); -} - -static int -ftxfont_draw (struct glyph_string *s, int from, int to, int x, int y, - bool with_background) -{ - struct frame *f = s->f; - struct face *face = s->face; - struct font *font = s->font; - XPoint p[0x700]; - int n[7]; - unsigned *code = s->char2b + from; - int len = to - from; - int i; - GC *gcs; - int xadvance; - - n[0] = n[1] = n[2] = n[3] = n[4] = n[5] = n[6] = 0; - - block_input (); - if (with_background) - ftxfont_draw_background (f, font, s->gc, x, y, s->width); - - if (face->gc == s->gc) - { - gcs = ftxfont_get_gcs (f, face->foreground, face->background); - } - else - { - XGCValues xgcv; - unsigned long mask = GCForeground | GCBackground; - - XGetGCValues (FRAME_X_DISPLAY (f), s->gc, mask, &xgcv); - gcs = ftxfont_get_gcs (f, xgcv.foreground, xgcv.background); - } - - if (gcs) - { - if (s->num_clips) - for (i = 0; i < 6; i++) - XSetClipRectangles (FRAME_X_DISPLAY (f), gcs[i], 0, 0, - s->clip, s->num_clips, Unsorted); - - for (i = 0; i < len; i++) - { - xadvance = ftxfont_draw_bitmap (f, s->gc, gcs, font, code[i], x, y, - p, 0x100, n, i + 1 == len); - x += (s->padding_p ? 1 : xadvance); - } - if (s->num_clips) - for (i = 0; i < 6; i++) - XSetClipMask (FRAME_X_DISPLAY (f), gcs[i], None); - } - else - { - /* We can't draw with antialiasing. - s->gc should already have a proper clipping setting. */ - for (i = 0; i < len; i++) - { - xadvance = ftxfont_draw_bitmap (f, s->gc, NULL, font, code[i], x, y, - p, 0x700, n, i + 1 == len); - x += (s->padding_p ? 1 : xadvance); - } - } - - unblock_input (); - - return len; -} - -static int -ftxfont_end_for_frame (struct frame *f) -{ - struct ftxfont_frame_data *data = font_get_frame_data (f, Qftx); - - block_input (); - while (data) - { - struct ftxfont_frame_data *next = data->next; - int i; - - for (i = 0; i < 6; i++) - XFreeGC (FRAME_X_DISPLAY (f), data->gcs[i]); - xfree (data); - data = next; - } - unblock_input (); - font_put_frame_data (f, Qftx, NULL); - return 0; -} - - - -static void syms_of_ftxfont_for_pdumper (void); - -struct font_driver const ftxfont_driver = - { - /* We can't draw a text without device dependent functions. */ - .type = LISPSYM_INITIALLY (Qftx), - .get_cache = ftfont_get_cache, - .list = ftxfont_list, - .match = ftxfont_match, - .list_family = ftfont_list_family, - .open_font = ftxfont_open, - .close_font = ftxfont_close, - .has_char = ftfont_has_char, - .encode_char = ftfont_encode_char, - .text_extents = ftfont_text_extents, - .draw = ftxfont_draw, - .get_bitmap = ftfont_get_bitmap, - .anchor_point = ftfont_anchor_point, -#ifdef HAVE_LIBOTF - .otf_capability = ftfont_otf_capability, -#endif - .end_for_frame = ftxfont_end_for_frame, -#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF - .shape = ftfont_shape, -#endif -#if defined HAVE_OTF_GET_VARIATION_GLYPHS || defined HAVE_FT_FACE_GETCHARVARIANTINDEX - .get_variation_glyphs = ftfont_variation_glyphs, -#endif - .filter_properties = ftfont_filter_properties, - .combining_capability = ftfont_combining_capability, - }; - -void -syms_of_ftxfont (void) -{ - DEFSYM (Qftx, "ftx"); - pdumper_do_now_and_after_load (syms_of_ftxfont_for_pdumper); -} - -static void -syms_of_ftxfont_for_pdumper (void) -{ - register_font_driver (&ftxfont_driver, NULL); -} diff --git a/src/gtkutil.c b/src/gtkutil.c index 6308c38f164..5e7cf3d2114 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifdef USE_GTK #include <float.h> #include <stdio.h> +#include <stdlib.h> #include <c-ctype.h> diff --git a/src/image.c b/src/image.c index 56878bcb8cb..65d59254f02 100644 --- a/src/image.c +++ b/src/image.c @@ -1620,7 +1620,7 @@ search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash) static void uncache_image (struct frame *f, Lisp_Object spec) { - struct image *img = search_image_cache (f, spec, sxhash (spec, 0)); + struct image *img = search_image_cache (f, spec, sxhash (spec)); if (img) { free_image (f, img); @@ -2285,7 +2285,7 @@ lookup_image (struct frame *f, Lisp_Object spec) eassert (valid_image_p (spec)); /* Look up SPEC in the hash table of the image cache. */ - hash = sxhash (spec, 0); + hash = sxhash (spec); img = search_image_cache (f, spec, hash); if (img && img->load_failed_p) { diff --git a/src/json.c b/src/json.c index 2e50ce514fd..30027675580 100644 --- a/src/json.c +++ b/src/json.c @@ -1121,7 +1121,6 @@ syms_of_json (void) 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"); diff --git a/src/lisp.h b/src/lisp.h index 8674fe11a64..0bd375658e2 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1069,7 +1069,7 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) with PVEC_TYPE_MASK to indicate the actual type. */ enum pvec_type { - PVEC_NORMAL_VECTOR, + PVEC_NORMAL_VECTOR, /* Should be first, for sxhash_obj. */ PVEC_FREE, PVEC_BIGNUM, PVEC_MARKER, @@ -1094,7 +1094,7 @@ enum pvec_type PVEC_CONDVAR, PVEC_MODULE_FUNCTION, - /* These should be last, check internal_equal to see why. */ + /* These should be last, for internal_equal and sxhash_obj. */ PVEC_COMPILED, PVEC_CHAR_TABLE, PVEC_SUB_CHAR_TABLE, @@ -3652,7 +3652,7 @@ extern bool sweep_weak_table (struct Lisp_Hash_Table *, bool); extern void hexbuf_digest (char *, void const *, int); extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *); EMACS_UINT hash_string (char const *, ptrdiff_t); -EMACS_UINT sxhash (Lisp_Object, int); +EMACS_UINT sxhash (Lisp_Object); Lisp_Object hashfn_eql (Lisp_Object, struct Lisp_Hash_Table *); Lisp_Object hashfn_equal (Lisp_Object, struct Lisp_Hash_Table *); Lisp_Object hashfn_user_defined (Lisp_Object, struct Lisp_Hash_Table *); @@ -3812,7 +3812,7 @@ extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t, /* Defined in alloc.c. */ extern void *my_heap_start (void); extern void check_pure_size (void); -extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT); +unsigned char *resize_string_data (Lisp_Object, ptrdiff_t, int, int); extern void malloc_warning (const char *); extern AVOID memory_full (size_t); extern AVOID buffer_memory_full (ptrdiff_t); @@ -3942,6 +3942,7 @@ extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object); extern void make_byte_code (struct Lisp_Vector *); extern struct Lisp_Vector *allocate_vector (ptrdiff_t); +extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t); /* Make an uninitialized vector for SIZE objects. NOTE: you must be sure that GC cannot happen until the vector is completely @@ -3977,9 +3978,7 @@ make_uninit_sub_char_table (int depth, int min_char) INLINE Lisp_Object make_nil_vector (ptrdiff_t size) { - Lisp_Object vec = make_uninit_vector (size); - memclear (XVECTOR (vec)->contents, size * word_size); - return vec; + return make_lisp_ptr (allocate_nil_vector (size), Lisp_Vectorlike); } extern struct Lisp_Vector *allocate_pseudovector (int, int, int, @@ -4245,6 +4244,8 @@ extern Lisp_Object module_function_documentation (struct Lisp_Module_Function const *); extern module_funcptr module_function_address (struct Lisp_Module_Function const *); +extern void *module_function_data (const struct Lisp_Module_Function *); +extern void module_finalize_function (const struct Lisp_Module_Function *); extern void mark_modules (void); extern void init_module_assertions (bool); extern void syms_of_module (void); @@ -4604,6 +4605,8 @@ extern void seed_random (void *, ptrdiff_t); extern void init_random (void); extern void emacs_backtrace (int); extern AVOID emacs_abort (void) NO_INLINE; +extern int emacs_fstatat (int, char const *, void *, int); +extern int emacs_openat (int, char const *, int, int); extern int emacs_open (const char *, int, int); extern int emacs_pipe (int[2]); extern int emacs_close (int); diff --git a/src/lread.c b/src/lread.c index af7480a9769..69dd73912bc 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1199,6 +1199,9 @@ Return t if the file exists and loads successfully. */) || suffix_p (file, ".elc") #ifdef HAVE_MODULES || suffix_p (file, MODULES_SUFFIX) +#ifdef MODULES_SECONDARY_SUFFIX + || suffix_p (file, MODULES_SECONDARY_SUFFIX) +#endif #endif ) must_suffix = Qnil; @@ -1268,7 +1271,12 @@ Return t if the file exists and loads successfully. */) } #ifdef HAVE_MODULES - bool is_module = suffix_p (found, MODULES_SUFFIX); + bool is_module = + suffix_p (found, MODULES_SUFFIX) +#ifdef MODULES_SECONDARY_SUFFIX + || suffix_p (found, MODULES_SECONDARY_SUFFIX) +#endif + ; #else bool is_module = false; #endif @@ -1345,11 +1353,11 @@ Return t if the file exists and loads successfully. */) ignores suffix order due to load_prefer_newer. */ if (!load_prefer_newer && is_elc) { - result = stat (SSDATA (efound), &s1); + result = emacs_fstatat (AT_FDCWD, SSDATA (efound), &s1, 0); if (result == 0) { SSET (efound, SBYTES (efound) - 1, 0); - result = stat (SSDATA (efound), &s2); + result = emacs_fstatat (AT_FDCWD, SSDATA (efound), &s2, 0); SSET (efound, SBYTES (efound) - 1, 'c'); } @@ -4856,9 +4864,16 @@ This list should not include the empty string. `load' and related functions try to append these suffixes, in order, to the specified file name if a suffix is allowed or required. */); #ifdef HAVE_MODULES +#ifdef MODULES_SECONDARY_SUFFIX + Vload_suffixes = list4 (build_pure_c_string (".elc"), + build_pure_c_string (".el"), + build_pure_c_string (MODULES_SUFFIX), + build_pure_c_string (MODULES_SECONDARY_SUFFIX)); +#else Vload_suffixes = list3 (build_pure_c_string (".elc"), build_pure_c_string (".el"), build_pure_c_string (MODULES_SUFFIX)); +#endif #else Vload_suffixes = list2 (build_pure_c_string (".elc"), build_pure_c_string (".el")); diff --git a/src/macfont.m b/src/macfont.m index c1bc30ff3ec..442a2566037 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -1126,7 +1126,8 @@ struct macfont_metrics }; #define METRICS_VALUE(metrics, member) \ - (((metrics)->member##_high << 8) | (metrics)->member##_low) + ((int) (((unsigned int) (metrics)->member##_high << 8) \ + | (metrics)->member##_low)) #define METRICS_SET_VALUE(metrics, member, value) \ do {short tmp = (value); (metrics)->member##_low = tmp & 0xff; \ (metrics)->member##_high = tmp >> 8;} while (0) diff --git a/src/minibuf.c b/src/minibuf.c index c5f61456900..8ebdff12527 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -414,12 +414,13 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, if (!enable_recursive_minibuffers && minibuf_level > 0) { + Lisp_Object str + = build_string ("Command attempted to use minibuffer while in minibuffer"); if (EQ (selected_window, minibuf_window)) - error ("Command attempted to use minibuffer while in minibuffer"); + Fsignal (Quser_error, (list1 (str))); else /* If we're in another window, cancel the minibuffer that's active. */ - Fthrow (Qexit, - build_string ("Command attempted to use minibuffer while in minibuffer")); + Fthrow (Qexit, str); } if ((noninteractive diff --git a/src/module-env-25.h b/src/module-env-25.h index d8f8eb68119..01ce65e9148 100644 --- a/src/module-env-25.h +++ b/src/module-env-25.h @@ -6,12 +6,10 @@ /* Memory management. */ - emacs_value (*make_global_ref) (emacs_env *env, - emacs_value any_reference) + emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); - void (*free_global_ref) (emacs_env *env, - emacs_value global_reference) + void (*free_global_ref) (emacs_env *env, emacs_value global_value) EMACS_ATTRIBUTE_NONNULL(1); /* Non-local exit handling. */ @@ -23,19 +21,15 @@ EMACS_ATTRIBUTE_NONNULL(1); enum emacs_funcall_exit (*non_local_exit_get) - (emacs_env *env, - emacs_value *non_local_exit_symbol_out, - emacs_value *non_local_exit_data_out) + (emacs_env *env, emacs_value *symbol, emacs_value *data) EMACS_ATTRIBUTE_NONNULL(1, 2, 3); void (*non_local_exit_signal) (emacs_env *env, - emacs_value non_local_exit_symbol, - emacs_value non_local_exit_data) + emacs_value symbol, emacs_value data) EMACS_ATTRIBUTE_NONNULL(1); void (*non_local_exit_throw) (emacs_env *env, - emacs_value tag, - emacs_value value) + emacs_value tag, emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); /* Function registration. */ @@ -43,48 +37,46 @@ emacs_value (*make_function) (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, - emacs_value (*function) (emacs_env *env, - ptrdiff_t nargs, - emacs_value args[], - void *) + emacs_value (*func) (emacs_env *env, + ptrdiff_t nargs, + emacs_value* args, + void *data) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1), - const char *documentation, + const char *docstring, void *data) EMACS_ATTRIBUTE_NONNULL(1, 4); emacs_value (*funcall) (emacs_env *env, - emacs_value function, + emacs_value func, ptrdiff_t nargs, - emacs_value args[]) + emacs_value* args) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*intern) (emacs_env *env, - const char *symbol_name) + emacs_value (*intern) (emacs_env *env, const char *name) EMACS_ATTRIBUTE_NONNULL(1, 2); /* Type conversion. */ - emacs_value (*type_of) (emacs_env *env, - emacs_value value) + emacs_value (*type_of) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - bool (*is_not_nil) (emacs_env *env, emacs_value value) + bool (*is_not_nil) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) EMACS_ATTRIBUTE_NONNULL(1); - intmax_t (*extract_integer) (emacs_env *env, emacs_value value) + intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*make_integer) (emacs_env *env, intmax_t value) + emacs_value (*make_integer) (emacs_env *env, intmax_t n) EMACS_ATTRIBUTE_NONNULL(1); - double (*extract_float) (emacs_env *env, emacs_value value) + double (*extract_float) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*make_float) (emacs_env *env, double value) + emacs_value (*make_float) (emacs_env *env, double d) EMACS_ATTRIBUTE_NONNULL(1); /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 @@ -101,13 +93,13 @@ bool (*copy_string_contents) (emacs_env *env, emacs_value value, - char *buffer, - ptrdiff_t *size_inout) + char *buf, + ptrdiff_t *len) EMACS_ATTRIBUTE_NONNULL(1, 4); /* Create a Lisp string from a utf8 encoded string. */ emacs_value (*make_string) (emacs_env *env, - const char *contents, ptrdiff_t length) + const char *str, ptrdiff_t len) EMACS_ATTRIBUTE_NONNULL(1, 2); /* Embedded pointer type. */ @@ -116,25 +108,24 @@ void *ptr) EMACS_ATTRIBUTE_NONNULL(1); - void *(*get_user_ptr) (emacs_env *env, emacs_value uptr) + void *(*get_user_ptr) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_ptr) (emacs_env *env, emacs_value uptr, void *ptr) + void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) EMACS_ATTRIBUTE_NONNULL(1); void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_finalizer) (emacs_env *env, - emacs_value uptr, + void (*set_user_finalizer) (emacs_env *env, emacs_value arg, void (*fin) (void *) EMACS_NOEXCEPT) EMACS_ATTRIBUTE_NONNULL(1); /* Vector functions. */ - emacs_value (*vec_get) (emacs_env *env, emacs_value vec, ptrdiff_t i) + emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) EMACS_ATTRIBUTE_NONNULL(1); - void (*vec_set) (emacs_env *env, emacs_value vec, ptrdiff_t i, - emacs_value val) + void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, + emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); - ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vec) + ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) EMACS_ATTRIBUTE_NONNULL(1); diff --git a/src/module-env-27.h b/src/module-env-27.h index 0fe2557d71b..9ef3c8b33bb 100644 --- a/src/module-env-27.h +++ b/src/module-env-27.h @@ -3,7 +3,7 @@ enum emacs_process_input_result (*process_input) (emacs_env *env) EMACS_ATTRIBUTE_NONNULL (1); - struct timespec (*extract_time) (emacs_env *env, emacs_value value) + struct timespec (*extract_time) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL (1); emacs_value (*make_time) (emacs_env *env, struct timespec time) diff --git a/src/module-env-28.h b/src/module-env-28.h new file mode 100644 index 00000000000..a2479a8f744 --- /dev/null +++ b/src/module-env-28.h @@ -0,0 +1,11 @@ + /* Add module environment functions newly added in Emacs 28 here. + Before Emacs 28 is released, remove this comment and start + module-env-29.h on the master branch. */ + + void (*(*EMACS_ATTRIBUTE_NONNULL (1) + get_function_finalizer) (emacs_env *env, + emacs_value arg)) (void *) EMACS_NOEXCEPT; + + void (*set_function_finalizer) (emacs_env *env, emacs_value arg, + void (*fin) (void *) EMACS_NOEXCEPT) + EMACS_ATTRIBUTE_NONNULL (1); diff --git a/src/msdos.c b/src/msdos.c index 6a89178a6e9..a09b3ba7924 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -1794,7 +1794,7 @@ internal_terminal_init (void) } Vinitial_window_system = Qpc; - Vwindow_system_version = make_fixnum (27); /* RE Emacs version */ + Vwindow_system_version = make_fixnum (28); /* 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 93d5a1e9488..42bd88eeb47 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -255,7 +255,10 @@ ns_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) [col getRed: &r green: &g blue: &b alpha: &alpha]; FRAME_FOREGROUND_PIXEL (f) = - ARGB_TO_ULONG ((int)(alpha*0xff), (int)(r*0xff), (int)(g*0xff), (int)(b*0xff)); + ARGB_TO_ULONG ((unsigned long) (alpha * 0xff), + (unsigned long) (r * 0xff), + (unsigned long) (g * 0xff), + (unsigned long) (b * 0xff)); if (FRAME_NS_VIEW (f)) { @@ -296,7 +299,10 @@ ns_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) [col getRed: &r green: &g blue: &b alpha: &alpha]; FRAME_BACKGROUND_PIXEL (f) = - ARGB_TO_ULONG ((int)(alpha*0xff), (int)(r*0xff), (int)(g*0xff), (int)(b*0xff)); + ARGB_TO_ULONG ((unsigned long) (alpha * 0xff), + (unsigned long) (r * 0xff), + (unsigned long) (g * 0xff), + (unsigned long) (b * 0xff)); if (view != nil) { @@ -1271,14 +1277,20 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, #ifdef NS_IMPL_COCOA tem = gui_display_get_arg (dpyinfo, parms, Qns_appearance, NULL, NULL, RES_TYPE_SYMBOL); - FRAME_NS_APPEARANCE (f) = EQ (tem, Qdark) - ? ns_appearance_vibrant_dark : ns_appearance_aqua; - store_frame_param (f, Qns_appearance, tem); + if (EQ (tem, Qdark)) + FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; + else if (EQ (tem, Qlight)) + FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; + else + FRAME_NS_APPEARANCE (f) = ns_appearance_system_default; + store_frame_param (f, Qns_appearance, + (!NILP (tem) && !EQ (tem, Qunbound)) ? tem : Qnil); tem = gui_display_get_arg (dpyinfo, parms, Qns_transparent_titlebar, NULL, NULL, RES_TYPE_BOOLEAN); FRAME_NS_TRANSPARENT_TITLEBAR (f) = !NILP (tem) && !EQ (tem, Qunbound); - store_frame_param (f, Qns_transparent_titlebar, tem); + store_frame_param (f, Qns_transparent_titlebar, + FRAME_NS_TRANSPARENT_TITLEBAR (f) ? Qt : Qnil); #endif parent_frame = gui_display_get_arg (dpyinfo, parms, Qparent_frame, NULL, NULL, @@ -3135,6 +3147,7 @@ syms_of_nsfns (void) DEFSYM (Qframe_title_format, "frame-title-format"); DEFSYM (Qicon_title_format, "icon-title-format"); DEFSYM (Qdark, "dark"); + DEFSYM (Qlight, "light"); DEFVAR_LISP ("ns-icon-type-alist", Vns_icon_type_alist, doc: /* Alist of elements (REGEXP . IMAGE) for images of icons associated to frames. diff --git a/src/nsimage.m b/src/nsimage.m index fa1e98b8848..3cccc984ca9 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -407,9 +407,10 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) if (pixmapData[0] != NULL) { int loc = x + y * [self size].width; - return (pixmapData[3][loc] << 24) /* alpha */ - | (pixmapData[0][loc] << 16) | (pixmapData[1][loc] << 8) - | (pixmapData[2][loc]); + return (((unsigned long) pixmapData[3][loc] << 24) /* alpha */ + | ((unsigned long) pixmapData[0][loc] << 16) + | ((unsigned long) pixmapData[1][loc] << 8) + | (unsigned long) pixmapData[2][loc]); } else { diff --git a/src/nsterm.h b/src/nsterm.h index fb9ac1b462c..8baa65f5783 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -471,6 +471,8 @@ typedef id instancetype; { NSPoint grabOffset; } + +- (void)setAppearance; @end diff --git a/src/nsterm.m b/src/nsterm.m index 03754e5ae53..57573ef8d7e 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -2025,17 +2025,13 @@ ns_set_appearance (struct frame *f, Lisp_Object new_value, Lisp_Object old_value return; if (EQ (new_value, Qdark)) - { - window.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameVibrantDark]; - FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; - } + FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; + else if (EQ (new_value, Qlight)) + FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; else - { - window.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameAqua]; - FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; - } + FRAME_NS_APPEARANCE (f) = ns_appearance_system_default; + + [window setAppearance]; #endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 */ } @@ -2301,8 +2297,10 @@ ns_color_index_to_rgba(int idx, struct frame *f) EmacsCGFloat r, g, b, a; [col getRed: &r green: &g blue: &b alpha: &a]; - return ARGB_TO_ULONG((int)(a*255), - (int)(r*255), (int)(g*255), (int)(b*255)); + return ARGB_TO_ULONG((unsigned long) (a * 255), + (unsigned long) (r * 255), + (unsigned long) (g * 255), + (unsigned long) (b * 255)); } void @@ -2322,8 +2320,10 @@ ns_query_color(void *col, Emacs_Color *color_def, bool setPixel) if (setPixel == YES) color_def->pixel - = ARGB_TO_ULONG((int)(a*255), - (int)(r*255), (int)(g*255), (int)(b*255)); + = ARGB_TO_ULONG((unsigned long) (a * 255), + (unsigned long) (r * 255), + (unsigned long) (g * 255), + (unsigned long) (b * 255)); } bool @@ -7465,16 +7465,8 @@ not_in_argv (NSString *arg) if (! FRAME_UNDECORATED (f)) [self createToolbar: f]; -#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 -#ifndef NSAppKitVersionNumber10_10 -#define NSAppKitVersionNumber10_10 1343 -#endif - if (NSAppKitVersionNumber >= NSAppKitVersionNumber10_10 - && FRAME_NS_APPEARANCE (f) != ns_appearance_aqua) - win.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameVibrantDark]; -#endif + [win setAppearance]; #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 if ([win respondsToSelector: @selector(titlebarAppearsTransparent)]) @@ -8724,6 +8716,32 @@ not_in_argv (NSString *arg) #endif } +- (void)setAppearance +{ +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 + struct frame *f = ((EmacsView *)[self delegate])->emacsframe; + NSAppearance *appearance = nil; + + NSTRACE ("[EmacsWindow setAppearance]"); + +#ifndef NSAppKitVersionNumber10_10 +#define NSAppKitVersionNumber10_10 1343 +#endif + + if (NSAppKitVersionNumber < NSAppKitVersionNumber10_10) + return; + + if (FRAME_NS_APPEARANCE (f) == ns_appearance_vibrant_dark) + appearance = + [NSAppearance appearanceNamed:NSAppearanceNameVibrantDark]; + else if (FRAME_NS_APPEARANCE (f) == ns_appearance_aqua) + appearance = + [NSAppearance appearanceNamed:NSAppearanceNameAqua]; + + [self setAppearance:appearance]; +#endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 */ +} + - (void)setFrame:(NSRect)windowFrame display:(BOOL)displayViews { diff --git a/src/pdumper.c b/src/pdumper.c index 3ee11460405..0039f1a9ed8 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2961,7 +2961,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_E55BD36F8E +#if CHECK_STRUCTS && !defined HASH_pvec_type_A4A6E9984D # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); diff --git a/src/print.c b/src/print.c index 425b0dc4ee3..634169dbdbd 100644 --- a/src/print.c +++ b/src/print.c @@ -1365,6 +1365,22 @@ data_from_funcptr (void (*funcptr) (void)) interchangeably, so it's OK to assume that here too. */ return (void const *) funcptr; } + +/* Print the value of the pointer PTR. */ + +static void +print_pointer (Lisp_Object printcharfun, char *buf, const char *prefix, + const void *ptr) +{ + uintptr_t ui = (uintptr_t) ptr; + + /* In theory this assignment could lose info on pre-C99 hosts, but + in practice it doesn't. */ + uintmax_t up = ui; + + int len = sprintf (buf, "%s 0x%" PRIxMAX, prefix, up); + strout (buf, len, len, printcharfun); +} #endif static bool @@ -1796,26 +1812,22 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_MODULE_FUNCTION: { print_c_string ("#<module function ", printcharfun); - module_funcptr ptr = module_function_address (XMODULE_FUNCTION (obj)); + const struct Lisp_Module_Function *function = XMODULE_FUNCTION (obj); + module_funcptr ptr = module_function_address (function); char const *file; char const *symbol; dynlib_addr (ptr, &file, &symbol); if (symbol == NULL) - { - uintptr_t ui = (uintptr_t) data_from_funcptr (ptr); - - /* In theory this assignment could lose info on pre-C99 - hosts, but in practice it doesn't. */ - uintmax_t up = ui; - - int len = sprintf (buf, "at 0x%"PRIxMAX, up); - strout (buf, len, len, printcharfun); - } - else + print_pointer (printcharfun, buf, "at", data_from_funcptr (ptr)); + else print_c_string (symbol, printcharfun); - if (file != NULL) + void *data = module_function_data (function); + if (data != NULL) + print_pointer (printcharfun, buf, " with data", data); + + if (file != NULL) { print_c_string (" from ", printcharfun); print_c_string (file, printcharfun); @@ -1838,7 +1850,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT), max (sizeof " . #" + INT_STRLEN_BOUND (intmax_t), - max ((sizeof "at 0x" + max ((sizeof " with data 0x" + (sizeof (uintmax_t) * CHAR_BIT + 4 - 1) / 4), 40)))]; current_thread->stack_top = buf; diff --git a/src/sysdep.c b/src/sysdep.c index cb2f7f2f23c..e8e8bbfb502 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -135,11 +135,6 @@ int _cdecl _spawnlp (int, const char *, const char *, ...); # include <sys/socket.h> #endif -/* ULLONG_MAX is missing on Red Hat Linux 7.3; see Bug#11781. */ -#ifndef ULLONG_MAX -#define ULLONG_MAX TYPE_MAXIMUM (unsigned long long int) -#endif - /* Declare here, including term.h is problematic on some systems. */ extern void tputs (const char *, int, int (*)(int)); @@ -317,8 +312,8 @@ get_current_dir_name_or_unreachable (void) if (pwd && (pwdlen = strnlen (pwd, bufsize_max)) < bufsize_max && IS_DIRECTORY_SEP (pwd[pwdlen && IS_DEVICE_SEP (pwd[1]) ? 2 : 0]) - && stat (pwd, &pwdstat) == 0 - && stat (".", &dotstat) == 0 + && emacs_fstatat (AT_FDCWD, pwd, &pwdstat, 0) == 0 + && emacs_fstatat (AT_FDCWD, ".", &dotstat, 0) == 0 && dotstat.st_ino == pwdstat.st_ino && dotstat.st_dev == pwdstat.st_dev) { @@ -2454,7 +2449,27 @@ emacs_abort (void) } #endif -/* Open FILE for Emacs use, using open flags OFLAG and mode MODE. +/* Assuming the directory DIRFD, store information about FILENAME into *ST, + using FLAGS to control how the status is obtained. + Do not fail merely because fetching info was interrupted by a signal. + Allow the user to quit. + + The type of ST is void * instead of struct stat * because the + latter type would be problematic in lisp.h. Some platforms may + play tricks like "#define stat stat64" in <sys/stat.h>, and lisp.h + does not include <sys/stat.h>. */ + +int +emacs_fstatat (int dirfd, char const *filename, void *st, int flags) +{ + int r; + while ((r = fstatat (dirfd, filename, st, flags)) != 0 && errno == EINTR) + maybe_quit (); + return r; +} + +/* Assuming the directory DIRFD, open FILE for Emacs use, + using open flags OFLAGS and mode MODE. Use binary I/O on systems that care about text vs binary I/O. Arrange for subprograms to not inherit the file descriptor. Prefer a method that is multithread-safe, if available. @@ -2462,17 +2477,23 @@ emacs_abort (void) Allow the user to quit. */ int -emacs_open (const char *file, int oflags, int mode) +emacs_openat (int dirfd, char const *file, int oflags, int mode) { int fd; if (! (oflags & O_TEXT)) oflags |= O_BINARY; oflags |= O_CLOEXEC; - while ((fd = open (file, oflags, mode)) < 0 && errno == EINTR) + while ((fd = openat (dirfd, file, oflags, mode)) < 0 && errno == EINTR) maybe_quit (); return fd; } +int +emacs_open (char const *file, int oflags, int mode) +{ + return emacs_openat (AT_FDCWD, file, oflags, mode); +} + /* Open FILE as a stream for Emacs use, with mode MODE. Act like emacs_open with respect to threads, signals, and quits. */ @@ -3141,7 +3162,7 @@ make_lisp_timeval (struct timeval t) #endif -#if defined GNU_LINUX && defined HAVE_LONG_LONG_INT +#ifdef GNU_LINUX static struct timespec time_from_jiffies (unsigned long long tval, long hz) { diff --git a/src/thread.c b/src/thread.c index c7fe0614269..df1a7053826 100644 --- a/src/thread.c +++ b/src/thread.c @@ -1114,9 +1114,6 @@ syms_of_threads (void) staticpro (&last_thread_error); last_thread_error = Qnil; - Fdefalias (intern_c_string ("thread-alive-p"), - intern_c_string ("thread-live-p"), Qnil); - Fprovide (intern_c_string ("threads"), Qnil); } diff --git a/src/w32heap.c b/src/w32heap.c index 3a6c7804675..ececc73c026 100644 --- a/src/w32heap.c +++ b/src/w32heap.c @@ -597,6 +597,16 @@ free_after_dump_9x (void *ptr) } } +void * +sys_calloc (size_t number, size_t size) +{ + size_t nbytes = number * size; + void *ptr = (*the_malloc_fn) (nbytes); + if (ptr) + memset (ptr, 0, nbytes); + return ptr; +} + #if defined HAVE_UNEXEC && defined ENABLE_CHECKING void report_temacs_memory_usage (void) diff --git a/src/window.c b/src/window.c index ff17cd88f38..8cdad27b664 100644 --- a/src/window.c +++ b/src/window.c @@ -7976,19 +7976,17 @@ foreach_window_1 (struct window *w, bool (*fn) (struct window *, void *), /* Return true if window configurations CONFIGURATION1 and CONFIGURATION2 describe the same state of affairs. This is used by Fequal. - IGNORE_POSITIONS means ignore non-matching scroll positions - and the like. + Ignore non-matching scroll positions and the like. This ignores a couple of things like the dedication status of window, combination_limit and the like. This might have to be fixed. */ -bool +static bool compare_window_configurations (Lisp_Object configuration1, - Lisp_Object configuration2, - bool ignore_positions) + Lisp_Object configuration2) { - register struct save_window_data *d1, *d2; + struct save_window_data *d1, *d2; struct Lisp_Vector *sws1, *sws2; ptrdiff_t i; @@ -8006,9 +8004,6 @@ compare_window_configurations (Lisp_Object configuration1, || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines || !EQ (d1->selected_frame, d2->selected_frame) || !EQ (d1->f_current_buffer, d2->f_current_buffer) - || (!ignore_positions - && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window) - || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window))) || !EQ (d1->focus_frame, d2->focus_frame) /* Verify that the two configurations have the same number of windows. */ || sws1->header.size != sws2->header.size) @@ -8041,12 +8036,6 @@ compare_window_configurations (Lisp_Object configuration1, equality. */ || !EQ (sw1->parent, sw2->parent) || !EQ (sw1->prev, sw2->prev) - || (!ignore_positions - && (!EQ (sw1->hscroll, sw2->hscroll) - || !EQ (sw1->min_hscroll, sw2->min_hscroll) - || !EQ (sw1->start_at_line_beg, sw2->start_at_line_beg) - || NILP (Fequal (sw1->start, sw2->start)) - || NILP (Fequal (sw1->pointm, sw2->pointm)))) || !EQ (sw1->left_margin_cols, sw2->left_margin_cols) || !EQ (sw1->right_margin_cols, sw2->right_margin_cols) || !EQ (sw1->left_fringe_width, sw2->left_fringe_width) @@ -8071,7 +8060,7 @@ This function ignores details such as the values of point and scrolling positions. */) (Lisp_Object x, Lisp_Object y) { - if (compare_window_configurations (x, y, true)) + if (compare_window_configurations (x, y)) return Qt; return Qnil; } diff --git a/src/window.h b/src/window.h index aa8d2c8d1d2..167d1be7abb 100644 --- a/src/window.h +++ b/src/window.h @@ -1184,7 +1184,6 @@ extern Lisp_Object window_list (void); extern Lisp_Object window_parameter (struct window *, Lisp_Object parameter); extern struct window *decode_live_window (Lisp_Object); extern struct window *decode_any_window (Lisp_Object); -extern bool compare_window_configurations (Lisp_Object, Lisp_Object, bool); extern void mark_window_cursors_off (struct window *); extern bool window_wants_mode_line (struct window *); extern bool window_wants_header_line (struct window *); diff --git a/src/xdisp.c b/src/xdisp.c index 5b21aaa85a9..516013ce4ba 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -8573,7 +8573,7 @@ compute_stop_pos_backwards (struct it *it) position before that. This is called when we bump into a stop position while reordering bidirectional text. CHARPOS should be the last previously processed stop_pos (or BEGV/0, if none were - processed yet) whose position is less that IT's current + processed yet) whose position is less than IT's current position. */ static void diff --git a/src/xfns.c b/src/xfns.c index 276ea1c3935..5758bb7a18c 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -3878,8 +3878,6 @@ This function is an internal primitive--use `make-frame' instead. */) #ifdef HAVE_HARFBUZZ register_font_driver (&xfthbfont_driver, f); #endif -#else /* not HAVE_XFT */ - register_font_driver (&ftxfont_driver, f); #endif /* not HAVE_XFT */ #endif /* HAVE_FREETYPE */ #endif /* not USE_CAIRO */ @@ -6364,8 +6362,6 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) #ifdef HAVE_HARFBUZZ register_font_driver (&xfthbfont_driver, f); #endif -#else /* not HAVE_XFT */ - register_font_driver (&ftxfont_driver, f); #endif /* not HAVE_XFT */ #endif /* HAVE_FREETYPE */ #endif /* not USE_CAIRO */ |