diff options
Diffstat (limited to 'test/manual/etags/c-src/emacs/src')
-rw-r--r-- | test/manual/etags/c-src/emacs/src/gmalloc.c | 2040 | ||||
-rw-r--r-- | test/manual/etags/c-src/emacs/src/keyboard.c | 11960 | ||||
-rw-r--r-- | test/manual/etags/c-src/emacs/src/lisp.h | 4817 | ||||
-rw-r--r-- | test/manual/etags/c-src/emacs/src/regex.h | 630 |
4 files changed, 19447 insertions, 0 deletions
diff --git a/test/manual/etags/c-src/emacs/src/gmalloc.c b/test/manual/etags/c-src/emacs/src/gmalloc.c new file mode 100644 index 00000000000..a88f4ab75e0 --- /dev/null +++ b/test/manual/etags/c-src/emacs/src/gmalloc.c @@ -0,0 +1,2040 @@ +/* Declarations for `malloc' and friends. + Copyright (C) 1990-1993, 1995-1996, 1999, 2002-2007, 2013-2015 Free + Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library 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 2 of the +License, or (at your option) any later version. + +This library 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 this library. If not, see <http://www.gnu.org/licenses/>. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#include <config.h> + +#if defined HAVE_PTHREAD && !defined HYBRID_MALLOC +#define USE_PTHREAD +#endif + +#include <string.h> +#include <limits.h> +#include <stdint.h> + +#ifdef HYBRID_GET_CURRENT_DIR_NAME +#undef get_current_dir_name +#endif + +#include <unistd.h> + +#ifdef USE_PTHREAD +#include <pthread.h> +#endif + +#ifdef WINDOWSNT +#include <w32heap.h> /* for sbrk */ +#endif + +#ifdef emacs +extern void emacs_abort (void); +#endif + +/* If HYBRID_MALLOC is defined, then temacs will use malloc, + realloc... as defined in this file (and renamed gmalloc, + grealloc... via the macros that follow). The dumped emacs, + however, will use the system malloc, realloc.... In other source + files, malloc, realloc... are renamed hybrid_malloc, + hybrid_realloc... via macros in conf_post.h. hybrid_malloc and + friends are wrapper functions defined later in this file. + aligned_alloc is defined as a macro only in alloc.c. + + As of this writing (August 2014), Cygwin is the only platform on + which HYBRID_MACRO is defined. Any other platform that wants to + define it will have to define the macros DUMPED and + ALLOCATED_BEFORE_DUMPING, defined below for Cygwin. */ +#ifdef HYBRID_MALLOC +#undef malloc +#undef realloc +#undef calloc +#undef free +#define malloc gmalloc +#define realloc grealloc +#define calloc gcalloc +#define aligned_alloc galigned_alloc +#define free gfree +#endif /* HYBRID_MALLOC */ + +#ifdef CYGWIN +extern void *bss_sbrk (ptrdiff_t size); +extern int bss_sbrk_did_unexec; +extern char bss_sbrk_buffer[]; +extern void *bss_sbrk_buffer_end; +#define DUMPED bss_sbrk_did_unexec +#define ALLOCATED_BEFORE_DUMPING(P) \ + ((P) < bss_sbrk_buffer_end && (P) >= (void *) bss_sbrk_buffer) +#endif + +#ifdef __cplusplus +extern "C" +{ +#endif + +#include <stddef.h> + + +/* Allocate SIZE bytes of memory. */ +extern void *malloc (size_t size) ATTRIBUTE_MALLOC_SIZE ((1)); +/* Re-allocate the previously allocated block + in ptr, making the new block SIZE bytes long. */ +extern void *realloc (void *ptr, size_t size) ATTRIBUTE_ALLOC_SIZE ((2)); +/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */ +extern void *calloc (size_t nmemb, size_t size) ATTRIBUTE_MALLOC_SIZE ((1,2)); +/* Free a block allocated by `malloc', `realloc' or `calloc'. */ +extern void free (void *ptr); + +/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */ +#ifdef MSDOS +extern void *aligned_alloc (size_t, size_t); +extern void *memalign (size_t, size_t); +extern int posix_memalign (void **, size_t, size_t); +#endif + +#ifdef USE_PTHREAD +/* Set up mutexes and make malloc etc. thread-safe. */ +extern void malloc_enable_thread (void); +#endif + +#ifdef emacs +extern void emacs_abort (void); +#endif + +/* The allocator divides the heap into blocks of fixed size; large + requests receive one or more whole blocks, and small requests + receive a fragment of a block. Fragment sizes are powers of two, + and all fragments of a block are the same size. When all the + fragments in a block have been freed, the block itself is freed. */ +#define INT_BIT (CHAR_BIT * sizeof (int)) +#define BLOCKLOG (INT_BIT > 16 ? 12 : 9) +#define BLOCKSIZE (1 << BLOCKLOG) +#define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE) + +/* Determine the amount of memory spanned by the initial heap table + (not an absolute limit). */ +#define HEAP (INT_BIT > 16 ? 4194304 : 65536) + +/* Number of contiguous free blocks allowed to build up at the end of + memory before they will be returned to the system. */ +#define FINAL_FREE_BLOCKS 8 + +/* Data structure giving per-block information. */ +typedef union + { + /* Heap information for a busy block. */ + struct + { + /* Zero for a large (multiblock) object, or positive giving the + logarithm to the base two of the fragment size. */ + int type; + union + { + struct + { + size_t nfree; /* Free frags in a fragmented block. */ + size_t first; /* First free fragment of the block. */ + } frag; + /* For a large object, in its first block, this has the number + of blocks in the object. In the other blocks, this has a + negative number which says how far back the first block is. */ + ptrdiff_t size; + } info; + } busy; + /* Heap information for a free block + (that may be the first of a free cluster). */ + struct + { + size_t size; /* Size (in blocks) of a free cluster. */ + size_t next; /* Index of next free cluster. */ + size_t prev; /* Index of previous free cluster. */ + } free; + } malloc_info; + +/* Pointer to first block of the heap. */ +extern char *_heapbase; + +/* Table indexed by block number giving per-block information. */ +extern malloc_info *_heapinfo; + +/* Address to block number and vice versa. */ +#define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1) +#define ADDRESS(B) ((void *) (((B) - 1) * BLOCKSIZE + _heapbase)) + +/* Current search index for the heap table. */ +extern size_t _heapindex; + +/* Limit of valid info table indices. */ +extern size_t _heaplimit; + +/* Doubly linked lists of free fragments. */ +struct list + { + struct list *next; + struct list *prev; + }; + +/* Free list headers for each fragment size. */ +extern struct list _fraghead[]; + +/* List of blocks allocated with aligned_alloc and friends. */ +struct alignlist + { + struct alignlist *next; + void *aligned; /* The address that aligned_alloc returned. */ + void *exact; /* The address that malloc returned. */ + }; +extern struct alignlist *_aligned_blocks; + +/* Instrumentation. */ +extern size_t _chunks_used; +extern size_t _bytes_used; +extern size_t _chunks_free; +extern size_t _bytes_free; + +/* Internal versions of `malloc', `realloc', and `free' + used when these functions need to call each other. + They are the same but don't call the hooks. */ +extern void *_malloc_internal (size_t); +extern void *_realloc_internal (void *, size_t); +extern void _free_internal (void *); +extern void *_malloc_internal_nolock (size_t); +extern void *_realloc_internal_nolock (void *, size_t); +extern void _free_internal_nolock (void *); + +#ifdef USE_PTHREAD +extern pthread_mutex_t _malloc_mutex, _aligned_blocks_mutex; +extern int _malloc_thread_enabled_p; +#define LOCK() \ + do { \ + if (_malloc_thread_enabled_p) \ + pthread_mutex_lock (&_malloc_mutex); \ + } while (0) +#define UNLOCK() \ + do { \ + if (_malloc_thread_enabled_p) \ + pthread_mutex_unlock (&_malloc_mutex); \ + } while (0) +#define LOCK_ALIGNED_BLOCKS() \ + do { \ + if (_malloc_thread_enabled_p) \ + pthread_mutex_lock (&_aligned_blocks_mutex); \ + } while (0) +#define UNLOCK_ALIGNED_BLOCKS() \ + do { \ + if (_malloc_thread_enabled_p) \ + pthread_mutex_unlock (&_aligned_blocks_mutex); \ + } while (0) +#else +#define LOCK() +#define UNLOCK() +#define LOCK_ALIGNED_BLOCKS() +#define UNLOCK_ALIGNED_BLOCKS() +#endif + +/* Given an address in the middle of a malloc'd object, + return the address of the beginning of the object. */ +extern void *malloc_find_object_address (void *ptr); + +/* Underlying allocation function; successive calls should + return contiguous pieces of memory. */ +extern void *(*__morecore) (ptrdiff_t size); + +/* Default value of `__morecore'. */ +extern void *__default_morecore (ptrdiff_t size); + +/* If not NULL, this function is called after each time + `__morecore' is called to increase the data size. */ +extern void (*__after_morecore_hook) (void); + +/* Number of extra blocks to get each time we ask for more core. + This reduces the frequency of calling `(*__morecore)'. */ +extern size_t __malloc_extra_blocks; + +/* Nonzero if `malloc' has been called and done its initialization. */ +extern int __malloc_initialized; +/* Function called to initialize malloc data structures. */ +extern int __malloc_initialize (void); + +/* Hooks for debugging versions. */ +extern void (*__malloc_initialize_hook) (void); +extern void (*__free_hook) (void *ptr); +extern void *(*__malloc_hook) (size_t size); +extern void *(*__realloc_hook) (void *ptr, size_t size); +extern void *(*__memalign_hook) (size_t size, size_t alignment); + +/* Return values for `mprobe': these are the kinds of inconsistencies that + `mcheck' enables detection of. */ +enum mcheck_status + { + MCHECK_DISABLED = -1, /* Consistency checking is not turned on. */ + MCHECK_OK, /* Block is fine. */ + MCHECK_FREE, /* Block freed twice. */ + MCHECK_HEAD, /* Memory before the block was clobbered. */ + MCHECK_TAIL /* Memory after the block was clobbered. */ + }; + +/* Activate a standard collection of debugging hooks. This must be called + before `malloc' is ever called. ABORTFUNC is called with an error code + (see enum above) when an inconsistency is detected. If ABORTFUNC is + null, the standard function prints on stderr and then calls `abort'. */ +extern int mcheck (void (*abortfunc) (enum mcheck_status)); + +/* Check for aberrations in a particular malloc'd block. You must have + called `mcheck' already. These are the same checks that `mcheck' does + when you free or reallocate a block. */ +extern enum mcheck_status mprobe (void *ptr); + +/* Activate a standard collection of tracing hooks. */ +extern void mtrace (void); +extern void muntrace (void); + +/* Statistics available to the user. */ +struct mstats + { + size_t bytes_total; /* Total size of the heap. */ + size_t chunks_used; /* Chunks allocated by the user. */ + size_t bytes_used; /* Byte total of user-allocated chunks. */ + size_t chunks_free; /* Chunks in the free list. */ + size_t bytes_free; /* Byte total of chunks in the free list. */ + }; + +/* Pick up the current statistics. */ +extern struct mstats mstats (void); + +/* Call WARNFUN with a warning message when memory usage is high. */ +extern void memory_warnings (void *start, void (*warnfun) (const char *)); + +#ifdef __cplusplus +} +#endif + +/* Memory allocator `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library 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 2 of the +License, or (at your option) any later version. + +This library 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 this library. If not, see <http://www.gnu.org/licenses/>. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#include <errno.h> + +void *(*__morecore) (ptrdiff_t size) = __default_morecore; + +/* Debugging hook for `malloc'. */ +void *(*__malloc_hook) (size_t size); + +/* Pointer to the base of the first block. */ +char *_heapbase; + +/* Block information table. Allocated with align/__free (not malloc/free). */ +malloc_info *_heapinfo; + +/* Number of info entries. */ +static size_t heapsize; + +/* Search index in the info table. */ +size_t _heapindex; + +/* Limit of valid info table indices. */ +size_t _heaplimit; + +/* Free lists for each fragment size. */ +struct list _fraghead[BLOCKLOG]; + +/* Instrumentation. */ +size_t _chunks_used; +size_t _bytes_used; +size_t _chunks_free; +size_t _bytes_free; + +/* Are you experienced? */ +int __malloc_initialized; + +size_t __malloc_extra_blocks; + +void (*__malloc_initialize_hook) (void); +void (*__after_morecore_hook) (void); + +#if defined GC_MALLOC_CHECK && defined GC_PROTECT_MALLOC_STATE + +/* Some code for hunting a bug writing into _heapinfo. + + Call this macro with argument PROT non-zero to protect internal + malloc state against writing to it, call it with a zero argument to + make it readable and writable. + + Note that this only works if BLOCKSIZE == page size, which is + the case on the i386. */ + +#include <sys/types.h> +#include <sys/mman.h> + +static int state_protected_p; +static size_t last_state_size; +static malloc_info *last_heapinfo; + +void +protect_malloc_state (int protect_p) +{ + /* If _heapinfo has been relocated, make sure its old location + isn't left read-only; it will be reused by malloc. */ + if (_heapinfo != last_heapinfo + && last_heapinfo + && state_protected_p) + mprotect (last_heapinfo, last_state_size, PROT_READ | PROT_WRITE); + + last_state_size = _heaplimit * sizeof *_heapinfo; + last_heapinfo = _heapinfo; + + if (protect_p != state_protected_p) + { + state_protected_p = protect_p; + if (mprotect (_heapinfo, last_state_size, + protect_p ? PROT_READ : PROT_READ | PROT_WRITE) != 0) + abort (); + } +} + +#define PROTECT_MALLOC_STATE(PROT) protect_malloc_state (PROT) + +#else +#define PROTECT_MALLOC_STATE(PROT) /* empty */ +#endif + + +/* Aligned allocation. */ +static void * +align (size_t size) +{ + void *result; + ptrdiff_t adj; + + /* align accepts an unsigned argument, but __morecore accepts a + signed one. This could lead to trouble if SIZE overflows the + ptrdiff_t type accepted by __morecore. We just punt in that + case, since they are requesting a ludicrous amount anyway. */ + if (PTRDIFF_MAX < size) + result = 0; + else + result = (*__morecore) (size); + adj = (uintptr_t) result % BLOCKSIZE; + if (adj != 0) + { + adj = BLOCKSIZE - adj; + (*__morecore) (adj); + result = (char *) result + adj; + } + + if (__after_morecore_hook) + (*__after_morecore_hook) (); + + return result; +} + +/* Get SIZE bytes, if we can get them starting at END. + Return the address of the space we got. + If we cannot get space at END, fail and return 0. */ +static void * +get_contiguous_space (ptrdiff_t size, void *position) +{ + void *before; + void *after; + + before = (*__morecore) (0); + /* If we can tell in advance that the break is at the wrong place, + fail now. */ + if (before != position) + return 0; + + /* Allocate SIZE bytes and get the address of them. */ + after = (*__morecore) (size); + if (!after) + return 0; + + /* It was not contiguous--reject it. */ + if (after != position) + { + (*__morecore) (- size); + return 0; + } + + return after; +} + + +/* This is called when `_heapinfo' and `heapsize' have just + been set to describe a new info table. Set up the table + to describe itself and account for it in the statistics. */ +static void +register_heapinfo (void) +{ + size_t block, blocks; + + block = BLOCK (_heapinfo); + blocks = BLOCKIFY (heapsize * sizeof (malloc_info)); + + /* Account for the _heapinfo block itself in the statistics. */ + _bytes_used += blocks * BLOCKSIZE; + ++_chunks_used; + + /* Describe the heapinfo block itself in the heapinfo. */ + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + /* Leave back-pointers for malloc_find_address. */ + while (--blocks > 0) + _heapinfo[block + blocks].busy.info.size = -blocks; +} + +#ifdef USE_PTHREAD +pthread_mutex_t _malloc_mutex = PTHREAD_MUTEX_INITIALIZER; +pthread_mutex_t _aligned_blocks_mutex = PTHREAD_MUTEX_INITIALIZER; +int _malloc_thread_enabled_p; + +static void +malloc_atfork_handler_prepare (void) +{ + LOCK (); + LOCK_ALIGNED_BLOCKS (); +} + +static void +malloc_atfork_handler_parent (void) +{ + UNLOCK_ALIGNED_BLOCKS (); + UNLOCK (); +} + +static void +malloc_atfork_handler_child (void) +{ + UNLOCK_ALIGNED_BLOCKS (); + UNLOCK (); +} + +/* Set up mutexes and make malloc etc. thread-safe. */ +void +malloc_enable_thread (void) +{ + if (_malloc_thread_enabled_p) + return; + + /* Some pthread implementations call malloc for statically + initialized mutexes when they are used first. To avoid such a + situation, we initialize mutexes here while their use is + disabled in malloc etc. */ + pthread_mutex_init (&_malloc_mutex, NULL); + pthread_mutex_init (&_aligned_blocks_mutex, NULL); + pthread_atfork (malloc_atfork_handler_prepare, + malloc_atfork_handler_parent, + malloc_atfork_handler_child); + _malloc_thread_enabled_p = 1; +} +#endif /* USE_PTHREAD */ + +static void +malloc_initialize_1 (void) +{ +#ifdef GC_MCHECK + mcheck (NULL); +#endif + + if (__malloc_initialize_hook) + (*__malloc_initialize_hook) (); + + heapsize = HEAP / BLOCKSIZE; + _heapinfo = align (heapsize * sizeof (malloc_info)); + if (_heapinfo == NULL) + return; + memset (_heapinfo, 0, heapsize * sizeof (malloc_info)); + _heapinfo[0].free.size = 0; + _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; + _heapindex = 0; + _heapbase = (char *) _heapinfo; + _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info)); + + register_heapinfo (); + + __malloc_initialized = 1; + PROTECT_MALLOC_STATE (1); + return; +} + +/* Set everything up and remember that we have. + main will call malloc which calls this function. That is before any threads + or signal handlers has been set up, so we don't need thread protection. */ +int +__malloc_initialize (void) +{ + if (__malloc_initialized) + return 0; + + malloc_initialize_1 (); + + return __malloc_initialized; +} + +static int morecore_recursing; + +/* Get neatly aligned memory, initializing or + growing the heap info table as necessary. */ +static void * +morecore_nolock (size_t size) +{ + void *result; + malloc_info *newinfo, *oldinfo; + size_t newsize; + + if (morecore_recursing) + /* Avoid recursion. The caller will know how to handle a null return. */ + return NULL; + + result = align (size); + if (result == NULL) + return NULL; + + PROTECT_MALLOC_STATE (0); + + /* Check if we need to grow the info table. */ + if ((size_t) BLOCK ((char *) result + size) > heapsize) + { + /* Calculate the new _heapinfo table size. We do not account for the + added blocks in the table itself, as we hope to place them in + existing free space, which is already covered by part of the + existing table. */ + newsize = heapsize; + do + newsize *= 2; + while ((size_t) BLOCK ((char *) result + size) > newsize); + + /* We must not reuse existing core for the new info table when called + from realloc in the case of growing a large block, because the + block being grown is momentarily marked as free. In this case + _heaplimit is zero so we know not to reuse space for internal + allocation. */ + if (_heaplimit != 0) + { + /* First try to allocate the new info table in core we already + have, in the usual way using realloc. If realloc cannot + extend it in place or relocate it to existing sufficient core, + we will get called again, and the code above will notice the + `morecore_recursing' flag and return null. */ + int save = errno; /* Don't want to clobber errno with ENOMEM. */ + morecore_recursing = 1; + newinfo = _realloc_internal_nolock (_heapinfo, + newsize * sizeof (malloc_info)); + morecore_recursing = 0; + if (newinfo == NULL) + errno = save; + else + { + /* We found some space in core, and realloc has put the old + table's blocks on the free list. Now zero the new part + of the table and install the new table location. */ + memset (&newinfo[heapsize], 0, + (newsize - heapsize) * sizeof (malloc_info)); + _heapinfo = newinfo; + heapsize = newsize; + goto got_heap; + } + } + + /* Allocate new space for the malloc info table. */ + while (1) + { + newinfo = align (newsize * sizeof (malloc_info)); + + /* Did it fail? */ + if (newinfo == NULL) + { + (*__morecore) (-size); + return NULL; + } + + /* Is it big enough to record status for its own space? + If so, we win. */ + if ((size_t) BLOCK ((char *) newinfo + + newsize * sizeof (malloc_info)) + < newsize) + break; + + /* Must try again. First give back most of what we just got. */ + (*__morecore) (- newsize * sizeof (malloc_info)); + newsize *= 2; + } + + /* Copy the old table to the beginning of the new, + and zero the rest of the new table. */ + memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info)); + memset (&newinfo[heapsize], 0, + (newsize - heapsize) * sizeof (malloc_info)); + oldinfo = _heapinfo; + _heapinfo = newinfo; + heapsize = newsize; + + register_heapinfo (); + + /* Reset _heaplimit so _free_internal never decides + it can relocate or resize the info table. */ + _heaplimit = 0; + _free_internal_nolock (oldinfo); + PROTECT_MALLOC_STATE (0); + + /* The new heap limit includes the new table just allocated. */ + _heaplimit = BLOCK ((char *) newinfo + heapsize * sizeof (malloc_info)); + return result; + } + + got_heap: + _heaplimit = BLOCK ((char *) result + size); + return result; +} + +/* Allocate memory from the heap. */ +void * +_malloc_internal_nolock (size_t size) +{ + void *result; + size_t block, blocks, lastblocks, start; + register size_t i; + struct list *next; + + /* ANSI C allows `malloc (0)' to either return NULL, or to return a + valid address you can realloc and free (though not dereference). + + It turns out that some extant code (sunrpc, at least Ultrix's version) + expects `malloc (0)' to return non-NULL and breaks otherwise. + Be compatible. */ + +#if 0 + if (size == 0) + return NULL; +#endif + + PROTECT_MALLOC_STATE (0); + + if (size < sizeof (struct list)) + size = sizeof (struct list); + + /* Determine the allocation policy based on the request size. */ + if (size <= BLOCKSIZE / 2) + { + /* Small allocation to receive a fragment of a block. + Determine the logarithm to base two of the fragment size. */ + register size_t log = 1; + --size; + while ((size /= 2) != 0) + ++log; + + /* Look in the fragment lists for a + free fragment of the desired size. */ + next = _fraghead[log].next; + if (next != NULL) + { + /* There are free fragments of this size. + Pop a fragment out of the fragment list and return it. + Update the block's nfree and first counters. */ + result = next; + next->prev->next = next->next; + if (next->next != NULL) + next->next->prev = next->prev; + block = BLOCK (result); + if (--_heapinfo[block].busy.info.frag.nfree != 0) + _heapinfo[block].busy.info.frag.first = + (uintptr_t) next->next % BLOCKSIZE >> log; + + /* Update the statistics. */ + ++_chunks_used; + _bytes_used += 1 << log; + --_chunks_free; + _bytes_free -= 1 << log; + } + else + { + /* No free fragments of the desired size, so get a new block + and break it into fragments, returning the first. */ +#ifdef GC_MALLOC_CHECK + result = _malloc_internal_nolock (BLOCKSIZE); + PROTECT_MALLOC_STATE (0); +#elif defined (USE_PTHREAD) + result = _malloc_internal_nolock (BLOCKSIZE); +#else + result = malloc (BLOCKSIZE); +#endif + if (result == NULL) + { + PROTECT_MALLOC_STATE (1); + goto out; + } + + /* Link all fragments but the first into the free list. */ + next = (struct list *) ((char *) result + (1 << log)); + next->next = NULL; + next->prev = &_fraghead[log]; + _fraghead[log].next = next; + + for (i = 2; i < (size_t) (BLOCKSIZE >> log); ++i) + { + next = (struct list *) ((char *) result + (i << log)); + next->next = _fraghead[log].next; + next->prev = &_fraghead[log]; + next->prev->next = next; + next->next->prev = next; + } + + /* Initialize the nfree and first counters for this block. */ + block = BLOCK (result); + _heapinfo[block].busy.type = log; + _heapinfo[block].busy.info.frag.nfree = i - 1; + _heapinfo[block].busy.info.frag.first = i - 1; + + _chunks_free += (BLOCKSIZE >> log) - 1; + _bytes_free += BLOCKSIZE - (1 << log); + _bytes_used -= BLOCKSIZE - (1 << log); + } + } + else + { + /* Large allocation to receive one or more blocks. + Search the free list in a circle starting at the last place visited. + If we loop completely around without finding a large enough + space we will have to get more memory from the system. */ + blocks = BLOCKIFY (size); + start = block = _heapindex; + while (_heapinfo[block].free.size < blocks) + { + block = _heapinfo[block].free.next; + if (block == start) + { + /* Need to get more from the system. Get a little extra. */ + size_t wantblocks = blocks + __malloc_extra_blocks; + block = _heapinfo[0].free.prev; + lastblocks = _heapinfo[block].free.size; + /* Check to see if the new core will be contiguous with the + final free block; if so we don't need to get as much. */ + if (_heaplimit != 0 && block + lastblocks == _heaplimit && + /* We can't do this if we will have to make the heap info + table bigger to accommodate the new space. */ + block + wantblocks <= heapsize && + get_contiguous_space ((wantblocks - lastblocks) * BLOCKSIZE, + ADDRESS (block + lastblocks))) + { + /* We got it contiguously. Which block we are extending + (the `final free block' referred to above) might have + changed, if it got combined with a freed info table. */ + block = _heapinfo[0].free.prev; + _heapinfo[block].free.size += (wantblocks - lastblocks); + _bytes_free += (wantblocks - lastblocks) * BLOCKSIZE; + _heaplimit += wantblocks - lastblocks; + continue; + } + result = morecore_nolock (wantblocks * BLOCKSIZE); + if (result == NULL) + goto out; + block = BLOCK (result); + /* Put the new block at the end of the free list. */ + _heapinfo[block].free.size = wantblocks; + _heapinfo[block].free.prev = _heapinfo[0].free.prev; + _heapinfo[block].free.next = 0; + _heapinfo[0].free.prev = block; + _heapinfo[_heapinfo[block].free.prev].free.next = block; + ++_chunks_free; + /* Now loop to use some of that block for this allocation. */ + } + } + + /* At this point we have found a suitable free list entry. + Figure out how to remove what we need from the list. */ + result = ADDRESS (block); + if (_heapinfo[block].free.size > blocks) + { + /* The block we found has a bit left over, + so relink the tail end back into the free list. */ + _heapinfo[block + blocks].free.size + = _heapinfo[block].free.size - blocks; + _heapinfo[block + blocks].free.next + = _heapinfo[block].free.next; + _heapinfo[block + blocks].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[_heapinfo[block].free.next].free.prev + = _heapindex = block + blocks; + } + else + { + /* The block exactly matches our requirements, + so just remove it from the list. */ + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapindex = _heapinfo[block].free.next; + --_chunks_free; + } + + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + ++_chunks_used; + _bytes_used += blocks * BLOCKSIZE; + _bytes_free -= blocks * BLOCKSIZE; + + /* Mark all the blocks of the object just allocated except for the + first with a negative number so you can find the first block by + adding that adjustment. */ + while (--blocks > 0) + _heapinfo[block + blocks].busy.info.size = -blocks; + } + + PROTECT_MALLOC_STATE (1); + out: + return result; +} + +void * +_malloc_internal (size_t size) +{ + void *result; + + LOCK (); + result = _malloc_internal_nolock (size); + UNLOCK (); + + return result; +} + +void * +malloc (size_t size) +{ + void *(*hook) (size_t); + + if (!__malloc_initialized && !__malloc_initialize ()) + return NULL; + + /* Copy the value of __malloc_hook to an automatic variable in case + __malloc_hook is modified in another thread between its + NULL-check and the use. + + Note: Strictly speaking, this is not a right solution. We should + use mutexes to access non-read-only variables that are shared + among multiple threads. We just leave it for compatibility with + glibc malloc (i.e., assignments to __malloc_hook) for now. */ + hook = __malloc_hook; + return (hook != NULL ? *hook : _malloc_internal) (size); +} + +#ifndef _LIBC + +/* On some ANSI C systems, some libc functions call _malloc, _free + and _realloc. Make them use the GNU functions. */ + +extern void *_malloc (size_t); +extern void _free (void *); +extern void *_realloc (void *, size_t); + +void * +_malloc (size_t size) +{ + return malloc (size); +} + +void +_free (void *ptr) +{ + free (ptr); +} + +void * +_realloc (void *ptr, size_t size) +{ + return realloc (ptr, size); +} + +#endif +/* Free a block of memory allocated by `malloc'. + Copyright 1990, 1991, 1992, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library 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 2 of the +License, or (at your option) any later version. + +This library 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 this library. If not, see <http://www.gnu.org/licenses/>. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + + +/* Debugging hook for free. */ +void (*__free_hook) (void *__ptr); + +/* List of blocks allocated by aligned_alloc. */ +struct alignlist *_aligned_blocks = NULL; + +/* Return memory to the heap. + Like `_free_internal' but don't lock mutex. */ +void +_free_internal_nolock (void *ptr) +{ + int type; + size_t block, blocks; + register size_t i; + struct list *prev, *next; + void *curbrk; + const size_t lesscore_threshold + /* Threshold of free space at which we will return some to the system. */ + = FINAL_FREE_BLOCKS + 2 * __malloc_extra_blocks; + + register struct alignlist *l; + + if (ptr == NULL) + return; + + PROTECT_MALLOC_STATE (0); + + LOCK_ALIGNED_BLOCKS (); + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == ptr) + { + l->aligned = NULL; /* Mark the slot in the list as free. */ + ptr = l->exact; + break; + } + UNLOCK_ALIGNED_BLOCKS (); + + block = BLOCK (ptr); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Get as many statistics as early as we can. */ + --_chunks_used; + _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE; + _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE; + + /* Find the free cluster previous to this one in the free list. + Start searching at the last block referenced; this may benefit + programs with locality of allocation. */ + i = _heapindex; + if (i > block) + while (i > block) + i = _heapinfo[i].free.prev; + else + { + do + i = _heapinfo[i].free.next; + while (i > 0 && i < block); + i = _heapinfo[i].free.prev; + } + + /* Determine how to link this block into the free list. */ + if (block == i + _heapinfo[i].free.size) + { + /* Coalesce this block with its predecessor. */ + _heapinfo[i].free.size += _heapinfo[block].busy.info.size; + block = i; + } + else + { + /* Really link this block back into the free list. */ + _heapinfo[block].free.size = _heapinfo[block].busy.info.size; + _heapinfo[block].free.next = _heapinfo[i].free.next; + _heapinfo[block].free.prev = i; + _heapinfo[i].free.next = block; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + ++_chunks_free; + } + + /* Now that the block is linked in, see if we can coalesce it + with its successor (by deleting its successor from the list + and adding in its size). */ + if (block + _heapinfo[block].free.size == _heapinfo[block].free.next) + { + _heapinfo[block].free.size + += _heapinfo[_heapinfo[block].free.next].free.size; + _heapinfo[block].free.next + = _heapinfo[_heapinfo[block].free.next].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + --_chunks_free; + } + + /* How many trailing free blocks are there now? */ + blocks = _heapinfo[block].free.size; + + /* Where is the current end of accessible core? */ + curbrk = (*__morecore) (0); + + if (_heaplimit != 0 && curbrk == ADDRESS (_heaplimit)) + { + /* The end of the malloc heap is at the end of accessible core. + It's possible that moving _heapinfo will allow us to + return some space to the system. */ + + size_t info_block = BLOCK (_heapinfo); + size_t info_blocks = _heapinfo[info_block].busy.info.size; + size_t prev_block = _heapinfo[block].free.prev; + size_t prev_blocks = _heapinfo[prev_block].free.size; + size_t next_block = _heapinfo[block].free.next; + size_t next_blocks = _heapinfo[next_block].free.size; + + if (/* Win if this block being freed is last in core, the info table + is just before it, the previous free block is just before the + info table, and the two free blocks together form a useful + amount to return to the system. */ + (block + blocks == _heaplimit && + info_block + info_blocks == block && + prev_block != 0 && prev_block + prev_blocks == info_block && + blocks + prev_blocks >= lesscore_threshold) || + /* Nope, not the case. We can also win if this block being + freed is just before the info table, and the table extends + to the end of core or is followed only by a free block, + and the total free space is worth returning to the system. */ + (block + blocks == info_block && + ((info_block + info_blocks == _heaplimit && + blocks >= lesscore_threshold) || + (info_block + info_blocks == next_block && + next_block + next_blocks == _heaplimit && + blocks + next_blocks >= lesscore_threshold))) + ) + { + malloc_info *newinfo; + size_t oldlimit = _heaplimit; + + /* Free the old info table, clearing _heaplimit to avoid + recursion into this code. We don't want to return the + table's blocks to the system before we have copied them to + the new location. */ + _heaplimit = 0; + _free_internal_nolock (_heapinfo); + _heaplimit = oldlimit; + + /* Tell malloc to search from the beginning of the heap for + free blocks, so it doesn't reuse the ones just freed. */ + _heapindex = 0; + + /* Allocate new space for the info table and move its data. */ + newinfo = _malloc_internal_nolock (info_blocks * BLOCKSIZE); + PROTECT_MALLOC_STATE (0); + memmove (newinfo, _heapinfo, info_blocks * BLOCKSIZE); + _heapinfo = newinfo; + + /* We should now have coalesced the free block with the + blocks freed from the old info table. Examine the entire + trailing free block to decide below whether to return some + to the system. */ + block = _heapinfo[0].free.prev; + blocks = _heapinfo[block].free.size; + } + + /* Now see if we can return stuff to the system. */ + if (block + blocks == _heaplimit && blocks >= lesscore_threshold) + { + register size_t bytes = blocks * BLOCKSIZE; + _heaplimit -= blocks; + (*__morecore) (-bytes); + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[block].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + block = _heapinfo[block].free.prev; + --_chunks_free; + _bytes_free -= bytes; + } + } + + /* Set the next search to begin at this block. */ + _heapindex = block; + break; + + default: + /* Do some of the statistics. */ + --_chunks_used; + _bytes_used -= 1 << type; + ++_chunks_free; + _bytes_free += 1 << type; + + /* Get the address of the first free fragment in this block. */ + prev = (struct list *) ((char *) ADDRESS (block) + + (_heapinfo[block].busy.info.frag.first << type)); + + if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1) + { + /* If all fragments of this block are free, remove them + from the fragment list and free the whole block. */ + next = prev; + for (i = 1; i < (size_t) (BLOCKSIZE >> type); ++i) + next = next->next; + prev->prev->next = next; + if (next != NULL) + next->prev = prev->prev; + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = 1; + + /* Keep the statistics accurate. */ + ++_chunks_used; + _bytes_used += BLOCKSIZE; + _chunks_free -= BLOCKSIZE >> type; + _bytes_free -= BLOCKSIZE; + +#if defined (GC_MALLOC_CHECK) || defined (USE_PTHREAD) + _free_internal_nolock (ADDRESS (block)); +#else + free (ADDRESS (block)); +#endif + } + else if (_heapinfo[block].busy.info.frag.nfree != 0) + { + /* If some fragments of this block are free, link this + fragment into the fragment list after the first free + fragment of this block. */ + next = ptr; + next->next = prev->next; + next->prev = prev; + prev->next = next; + if (next->next != NULL) + next->next->prev = next; + ++_heapinfo[block].busy.info.frag.nfree; + } + else + { + /* No fragments of this block are free, so link this + fragment into the fragment list and announce that + it is the first free fragment of this block. */ + prev = ptr; + _heapinfo[block].busy.info.frag.nfree = 1; + _heapinfo[block].busy.info.frag.first = + (uintptr_t) ptr % BLOCKSIZE >> type; + prev->next = _fraghead[type].next; + prev->prev = &_fraghead[type]; + prev->prev->next = prev; + if (prev->next != NULL) + prev->next->prev = prev; + } + break; + } + + PROTECT_MALLOC_STATE (1); +} + +/* Return memory to the heap. + Like `free' but don't call a __free_hook if there is one. */ +void +_free_internal (void *ptr) +{ + LOCK (); + _free_internal_nolock (ptr); + UNLOCK (); +} + +/* Return memory to the heap. */ + +void +free (void *ptr) +{ + void (*hook) (void *) = __free_hook; + + if (hook != NULL) + (*hook) (ptr); + else + _free_internal (ptr); +} + +/* Define the `cfree' alias for `free'. */ +#ifdef weak_alias +weak_alias (free, cfree) +#else +void +cfree (void *ptr) +{ + free (ptr); +} +#endif +/* Change the size of a block allocated by `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library 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 2 of the +License, or (at your option) any later version. + +This library 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 this library. If not, see <http://www.gnu.org/licenses/>. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef min +#define min(a, b) ((a) < (b) ? (a) : (b)) +#endif + +/* Debugging hook for realloc. */ +void *(*__realloc_hook) (void *ptr, size_t size); + +/* Resize the given region to the new size, returning a pointer + to the (possibly moved) region. This is optimized for speed; + some benchmarks seem to indicate that greater compactness is + achieved by unconditionally allocating and copying to a + new region. This module has incestuous knowledge of the + internals of both free and malloc. */ +void * +_realloc_internal_nolock (void *ptr, size_t size) +{ + void *result; + int type; + size_t block, blocks, oldlimit; + + if (size == 0) + { + _free_internal_nolock (ptr); + return _malloc_internal_nolock (0); + } + else if (ptr == NULL) + return _malloc_internal_nolock (size); + + block = BLOCK (ptr); + + PROTECT_MALLOC_STATE (0); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Maybe reallocate a large block to a small fragment. */ + if (size <= BLOCKSIZE / 2) + { + result = _malloc_internal_nolock (size); + if (result != NULL) + { + memcpy (result, ptr, size); + _free_internal_nolock (ptr); + goto out; + } + } + + /* The new size is a large allocation as well; + see if we can hold it in place. */ + blocks = BLOCKIFY (size); + if (blocks < _heapinfo[block].busy.info.size) + { + /* The new size is smaller; return + excess memory to the free list. */ + _heapinfo[block + blocks].busy.type = 0; + _heapinfo[block + blocks].busy.info.size + = _heapinfo[block].busy.info.size - blocks; + _heapinfo[block].busy.info.size = blocks; + /* We have just created a new chunk by splitting a chunk in two. + Now we will free this chunk; increment the statistics counter + so it doesn't become wrong when _free_internal decrements it. */ + ++_chunks_used; + _free_internal_nolock (ADDRESS (block + blocks)); + result = ptr; + } + else if (blocks == _heapinfo[block].busy.info.size) + /* No size change necessary. */ + result = ptr; + else + { + /* Won't fit, so allocate a new region that will. + Free the old region first in case there is sufficient + adjacent free space to grow without moving. */ + blocks = _heapinfo[block].busy.info.size; + /* Prevent free from actually returning memory to the system. */ + oldlimit = _heaplimit; + _heaplimit = 0; + _free_internal_nolock (ptr); + result = _malloc_internal_nolock (size); + PROTECT_MALLOC_STATE (0); + if (_heaplimit == 0) + _heaplimit = oldlimit; + if (result == NULL) + { + /* Now we're really in trouble. We have to unfree + the thing we just freed. Unfortunately it might + have been coalesced with its neighbors. */ + if (_heapindex == block) + (void) _malloc_internal_nolock (blocks * BLOCKSIZE); + else + { + void *previous + = _malloc_internal_nolock ((block - _heapindex) * BLOCKSIZE); + (void) _malloc_internal_nolock (blocks * BLOCKSIZE); + _free_internal_nolock (previous); + } + goto out; + } + if (ptr != result) + memmove (result, ptr, blocks * BLOCKSIZE); + } + break; + + default: + /* Old size is a fragment; type is logarithm + to base two of the fragment size. */ + if (size > (size_t) (1 << (type - 1)) && + size <= (size_t) (1 << type)) + /* The new size is the same kind of fragment. */ + result = ptr; + else + { + /* The new size is different; allocate a new space, + and copy the lesser of the new size and the old. */ + result = _malloc_internal_nolock (size); + if (result == NULL) + goto out; + memcpy (result, ptr, min (size, (size_t) 1 << type)); + _free_internal_nolock (ptr); + } + break; + } + + PROTECT_MALLOC_STATE (1); + out: + return result; +} + +void * +_realloc_internal (void *ptr, size_t size) +{ + void *result; + + LOCK (); + result = _realloc_internal_nolock (ptr, size); + UNLOCK (); + + return result; +} + +void * +realloc (void *ptr, size_t size) +{ + void *(*hook) (void *, size_t); + + if (!__malloc_initialized && !__malloc_initialize ()) + return NULL; + + hook = __realloc_hook; + return (hook != NULL ? *hook : _realloc_internal) (ptr, size); +} +/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. + +This library 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 2 of the +License, or (at your option) any later version. + +This library 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 this library. If not, see <http://www.gnu.org/licenses/>. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +/* Allocate an array of NMEMB elements each SIZE bytes long. + The entire array is initialized to zeros. */ +void * +calloc (size_t nmemb, size_t size) +{ + void *result; + size_t bytes = nmemb * size; + + if (size != 0 && bytes / size != nmemb) + { + errno = ENOMEM; + return NULL; + } + + result = malloc (bytes); + if (result) + return memset (result, 0, bytes); + return result; +} +/* Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library 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 2, or (at your option) +any later version. + +The GNU C Library 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 the GNU C Library. If not, see <http://www.gnu.org/licenses/>. */ + +/* uClibc defines __GNU_LIBRARY__, but it is not completely + compatible. */ +#if !defined (__GNU_LIBRARY__) || defined (__UCLIBC__) +#define __sbrk sbrk +#else /* __GNU_LIBRARY__ && ! defined (__UCLIBC__) */ +/* It is best not to declare this and cast its result on foreign operating + systems with potentially hostile include files. */ + +extern void *__sbrk (ptrdiff_t increment); +#endif /* __GNU_LIBRARY__ && ! defined (__UCLIBC__) */ + +/* Allocate INCREMENT more bytes of data space, + and return the start of data space, or NULL on errors. + If INCREMENT is negative, shrink data space. */ +void * +__default_morecore (ptrdiff_t increment) +{ + void *result; +#if defined (CYGWIN) + if (!DUMPED) + { + return bss_sbrk (increment); + } +#endif + result = (void *) __sbrk (increment); + if (result == (void *) -1) + return NULL; + return result; +} +/* Copyright (C) 1991, 92, 93, 94, 95, 96 Free Software Foundation, Inc. + +This library 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 2 of the +License, or (at your option) any later version. + +This library 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 this library. If not, see <http://www.gnu.org/licenses/>. */ + +void *(*__memalign_hook) (size_t size, size_t alignment); + +void * +aligned_alloc (size_t alignment, size_t size) +{ + void *result; + size_t adj, lastadj; + void *(*hook) (size_t, size_t) = __memalign_hook; + + if (hook) + return (*hook) (alignment, size); + + /* Allocate a block with enough extra space to pad the block with up to + (ALIGNMENT - 1) bytes if necessary. */ + if (- size < alignment) + { + errno = ENOMEM; + return NULL; + } + result = malloc (size + alignment - 1); + if (result == NULL) + return NULL; + + /* Figure out how much we will need to pad this particular block + to achieve the required alignment. */ + adj = alignment - (uintptr_t) result % alignment; + if (adj == alignment) + adj = 0; + + if (adj != alignment - 1) + { + do + { + /* Reallocate the block with only as much excess as it + needs. */ + free (result); + result = malloc (size + adj); + if (result == NULL) /* Impossible unless interrupted. */ + return NULL; + + lastadj = adj; + adj = alignment - (uintptr_t) result % alignment; + if (adj == alignment) + adj = 0; + /* It's conceivable we might have been so unlucky as to get + a different block with weaker alignment. If so, this + block is too short to contain SIZE after alignment + correction. So we must try again and get another block, + slightly larger. */ + } while (adj > lastadj); + } + + if (adj != 0) + { + /* Record this block in the list of aligned blocks, so that `free' + can identify the pointer it is passed, which will be in the middle + of an allocated block. */ + + struct alignlist *l; + LOCK_ALIGNED_BLOCKS (); + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == NULL) + /* This slot is free. Use it. */ + break; + if (l == NULL) + { + l = malloc (sizeof *l); + if (l != NULL) + { + l->next = _aligned_blocks; + _aligned_blocks = l; + } + } + if (l != NULL) + { + l->exact = result; + result = l->aligned = (char *) result + adj; + } + UNLOCK_ALIGNED_BLOCKS (); + if (l == NULL) + { + free (result); + result = NULL; + } + } + + return result; +} + +/* An obsolete alias for aligned_alloc, for any old libraries that use + this alias. */ + +void * +memalign (size_t alignment, size_t size) +{ + return aligned_alloc (alignment, size); +} + +/* If HYBRID_MALLOC is defined, we may want to use the system + posix_memalign below. */ +#ifndef HYBRID_MALLOC +int +posix_memalign (void **memptr, size_t alignment, size_t size) +{ + void *mem; + + if (alignment == 0 + || alignment % sizeof (void *) != 0 + || (alignment & (alignment - 1)) != 0) + return EINVAL; + + mem = aligned_alloc (alignment, size); + if (mem == NULL) + return ENOMEM; + + *memptr = mem; + + return 0; +} +#endif + +/* Allocate memory on a page boundary. + Copyright (C) 1991, 92, 93, 94, 96 Free Software Foundation, Inc. + +This library 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 2 of the +License, or (at your option) any later version. + +This library 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 this library. If not, see <http://www.gnu.org/licenses/>. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +/* Allocate SIZE bytes on a page boundary. */ +extern void *valloc (size_t); + +#if defined _SC_PAGESIZE || !defined HAVE_GETPAGESIZE +# include "getpagesize.h" +#elif !defined getpagesize +extern int getpagesize (void); +#endif + +static size_t pagesize; + +void * +valloc (size_t size) +{ + if (pagesize == 0) + pagesize = getpagesize (); + + return aligned_alloc (pagesize, size); +} + +#ifdef HYBRID_MALLOC +#undef malloc +#undef realloc +#undef calloc +#undef aligned_alloc +#undef free + +/* Declare system malloc and friends. */ +extern void *malloc (size_t size); +extern void *realloc (void *ptr, size_t size); +extern void *calloc (size_t nmemb, size_t size); +extern void free (void *ptr); +#ifdef HAVE_ALIGNED_ALLOC +extern void *aligned_alloc (size_t alignment, size_t size); +#elif defined HAVE_POSIX_MEMALIGN +extern int posix_memalign (void **memptr, size_t alignment, size_t size); +#endif + +/* See the comments near the beginning of this file for explanations + of the following functions. */ + +void * +hybrid_malloc (size_t size) +{ + if (DUMPED) + return malloc (size); + return gmalloc (size); +} + +void * +hybrid_calloc (size_t nmemb, size_t size) +{ + if (DUMPED) + return calloc (nmemb, size); + return gcalloc (nmemb, size); +} + +void +hybrid_free (void *ptr) +{ + if (!DUMPED) + gfree (ptr); + else if (!ALLOCATED_BEFORE_DUMPING (ptr)) + free (ptr); + /* Otherwise the dumped emacs is trying to free something allocated + before dumping; do nothing. */ + return; +} + +#if defined HAVE_ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN +void * +hybrid_aligned_alloc (size_t alignment, size_t size) +{ + if (!DUMPED) + return galigned_alloc (alignment, size); + /* The following is copied from alloc.c */ +#ifdef HAVE_ALIGNED_ALLOC + return aligned_alloc (alignment, size); +#else /* HAVE_POSIX_MEMALIGN */ + void *p; + return posix_memalign (&p, alignment, size) == 0 ? p : 0; +#endif +} +#endif + +void * +hybrid_realloc (void *ptr, size_t size) +{ + void *result; + int type; + size_t block, oldsize; + + if (!DUMPED) + return grealloc (ptr, size); + if (!ALLOCATED_BEFORE_DUMPING (ptr)) + return realloc (ptr, size); + + /* The dumped emacs is trying to realloc storage allocated before + dumping. We just malloc new space and copy the data. */ + if (size == 0 || ptr == NULL) + return malloc (size); + block = ((char *) ptr - _heapbase) / BLOCKSIZE + 1; + type = _heapinfo[block].busy.type; + oldsize = + type == 0 ? _heapinfo[block].busy.info.size * BLOCKSIZE + : (size_t) 1 << type; + result = malloc (size); + if (result) + return memcpy (result, ptr, min (oldsize, size)); + return result; +} + +#ifdef HYBRID_GET_CURRENT_DIR_NAME +/* Defined in sysdep.c. */ +char *gget_current_dir_name (void); + +char * +hybrid_get_current_dir_name (void) +{ + if (DUMPED) + return get_current_dir_name (); + return gget_current_dir_name (); +} +#endif + +#endif /* HYBRID_MALLOC */ + +#ifdef GC_MCHECK + +/* Standard debugging hooks for `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library 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 2 of the +License, or (at your option) any later version. + +This library 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 this library. If not, see <http://www.gnu.org/licenses/>. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#include <stdio.h> + +/* Old hook values. */ +static void (*old_free_hook) (void *ptr); +static void *(*old_malloc_hook) (size_t size); +static void *(*old_realloc_hook) (void *ptr, size_t size); + +/* Function to call when something awful happens. */ +static void (*abortfunc) (enum mcheck_status); + +/* Arbitrary magical numbers. */ +#define MAGICWORD (SIZE_MAX / 11 ^ SIZE_MAX / 13 << 3) +#define MAGICFREE (SIZE_MAX / 17 ^ SIZE_MAX / 19 << 4) +#define MAGICBYTE ((char) 0xd7) +#define MALLOCFLOOD ((char) 0x93) +#define FREEFLOOD ((char) 0x95) + +struct hdr + { + size_t size; /* Exact size requested by user. */ + size_t magic; /* Magic number to check header integrity. */ + }; + +static enum mcheck_status +checkhdr (const struct hdr *hdr) +{ + enum mcheck_status status; + switch (hdr->magic) + { + default: + status = MCHECK_HEAD; + break; + case MAGICFREE: + status = MCHECK_FREE; + break; + case MAGICWORD: + if (((char *) &hdr[1])[hdr->size] != MAGICBYTE) + status = MCHECK_TAIL; + else + status = MCHECK_OK; + break; + } + if (status != MCHECK_OK) + (*abortfunc) (status); + return status; +} + +static void +freehook (void *ptr) +{ + struct hdr *hdr; + + if (ptr) + { + struct alignlist *l; + + /* If the block was allocated by aligned_alloc, its real pointer + to free is recorded in _aligned_blocks; find that. */ + PROTECT_MALLOC_STATE (0); + LOCK_ALIGNED_BLOCKS (); + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == ptr) + { + l->aligned = NULL; /* Mark the slot in the list as free. */ + ptr = l->exact; + break; + } + UNLOCK_ALIGNED_BLOCKS (); + PROTECT_MALLOC_STATE (1); + + hdr = ((struct hdr *) ptr) - 1; + checkhdr (hdr); + hdr->magic = MAGICFREE; + memset (ptr, FREEFLOOD, hdr->size); + } + else + hdr = NULL; + + __free_hook = old_free_hook; + free (hdr); + __free_hook = freehook; +} + +static void * +mallochook (size_t size) +{ + struct hdr *hdr; + + __malloc_hook = old_malloc_hook; + hdr = malloc (sizeof *hdr + size + 1); + __malloc_hook = mallochook; + if (hdr == NULL) + return NULL; + + hdr->size = size; + hdr->magic = MAGICWORD; + ((char *) &hdr[1])[size] = MAGICBYTE; + return memset (hdr + 1, MALLOCFLOOD, size); +} + +static void * +reallochook (void *ptr, size_t size) +{ + struct hdr *hdr = NULL; + size_t osize = 0; + + if (ptr) + { + hdr = ((struct hdr *) ptr) - 1; + osize = hdr->size; + + checkhdr (hdr); + if (size < osize) + memset ((char *) ptr + size, FREEFLOOD, osize - size); + } + + __free_hook = old_free_hook; + __malloc_hook = old_malloc_hook; + __realloc_hook = old_realloc_hook; + hdr = realloc (hdr, sizeof *hdr + size + 1); + __free_hook = freehook; + __malloc_hook = mallochook; + __realloc_hook = reallochook; + if (hdr == NULL) + return NULL; + + hdr->size = size; + hdr->magic = MAGICWORD; + ((char *) &hdr[1])[size] = MAGICBYTE; + if (size > osize) + memset ((char *) (hdr + 1) + osize, MALLOCFLOOD, size - osize); + return hdr + 1; +} + +static void +mabort (enum mcheck_status status) +{ + const char *msg; + switch (status) + { + case MCHECK_OK: + msg = "memory is consistent, library is buggy"; + break; + case MCHECK_HEAD: + msg = "memory clobbered before allocated block"; + break; + case MCHECK_TAIL: + msg = "memory clobbered past end of allocated block"; + break; + case MCHECK_FREE: + msg = "block freed twice"; + break; + default: + msg = "bogus mcheck_status, library is buggy"; + break; + } +#ifdef __GNU_LIBRARY__ + __libc_fatal (msg); +#else + fprintf (stderr, "mcheck: %s\n", msg); + fflush (stderr); +# ifdef emacs + emacs_abort (); +# else + abort (); +# endif +#endif +} + +static int mcheck_used = 0; + +int +mcheck (void (*func) (enum mcheck_status)) +{ + abortfunc = (func != NULL) ? func : &mabort; + + /* These hooks may not be safely inserted if malloc is already in use. */ + if (!__malloc_initialized && !mcheck_used) + { + old_free_hook = __free_hook; + __free_hook = freehook; + old_malloc_hook = __malloc_hook; + __malloc_hook = mallochook; + old_realloc_hook = __realloc_hook; + __realloc_hook = reallochook; + mcheck_used = 1; + } + + return mcheck_used ? 0 : -1; +} + +enum mcheck_status +mprobe (void *ptr) +{ + return mcheck_used ? checkhdr (ptr) : MCHECK_DISABLED; +} + +#endif /* GC_MCHECK */ diff --git a/test/manual/etags/c-src/emacs/src/keyboard.c b/test/manual/etags/c-src/emacs/src/keyboard.c new file mode 100644 index 00000000000..77f7fb97898 --- /dev/null +++ b/test/manual/etags/c-src/emacs/src/keyboard.c @@ -0,0 +1,11960 @@ +/* Keyboard and mouse input; editor command loop. + +Copyright (C) 1985-1989, 1993-1997, 1999-2015 Free Software Foundation, +Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include "sysstdio.h" +#include <sys/stat.h> + +#include "lisp.h" +#include "termchar.h" +#include "termopts.h" +#include "frame.h" +#include "termhooks.h" +#include "macros.h" +#include "keyboard.h" +#include "window.h" +#include "commands.h" +#include "character.h" +#include "buffer.h" +#include "disptab.h" +#include "dispextern.h" +#include "syntax.h" +#include "intervals.h" +#include "keymap.h" +#include "blockinput.h" +#include "puresize.h" +#include "systime.h" +#include "atimer.h" +#include "process.h" +#include <errno.h> + +#ifdef HAVE_PTHREAD +#include <pthread.h> +#endif +#ifdef MSDOS +#include "msdos.h" +#include <time.h> +#else /* not MSDOS */ +#include <sys/ioctl.h> +#endif /* not MSDOS */ + +#if defined USABLE_FIONREAD && defined USG5_4 +# include <sys/filio.h> +#endif + +#include "syssignal.h" + +#include <sys/types.h> +#include <unistd.h> +#include <fcntl.h> + +#ifdef HAVE_WINDOW_SYSTEM +#include TERM_HEADER +#endif /* HAVE_WINDOW_SYSTEM */ + +/* Variables for blockinput.h: */ + +/* Positive if interrupt input is blocked right now. */ +volatile int interrupt_input_blocked; + +/* True means an input interrupt or alarm signal has arrived. + The QUIT macro checks this. */ +volatile bool pending_signals; + +#define KBD_BUFFER_SIZE 4096 + +KBOARD *initial_kboard; +KBOARD *current_kboard; +static KBOARD *all_kboards; + +/* True in the single-kboard state, false in the any-kboard state. */ +static bool single_kboard; + +#define NUM_RECENT_KEYS (300) + +/* Index for storing next element into recent_keys. */ +static int recent_keys_index; + +/* Total number of elements stored into recent_keys. */ +static int total_keys; + +/* This vector holds the last NUM_RECENT_KEYS keystrokes. */ +static Lisp_Object recent_keys; + +/* Vector holding the key sequence that invoked the current command. + It is reused for each command, and it may be longer than the current + sequence; this_command_key_count indicates how many elements + actually mean something. + It's easier to staticpro a single Lisp_Object than an array. */ +Lisp_Object this_command_keys; +ptrdiff_t this_command_key_count; + +/* True after calling Freset_this_command_lengths. + Usually it is false. */ +static bool this_command_key_count_reset; + +/* This vector is used as a buffer to record the events that were actually read + by read_key_sequence. */ +static Lisp_Object raw_keybuf; +static int raw_keybuf_count; + +#define GROW_RAW_KEYBUF \ + if (raw_keybuf_count == ASIZE (raw_keybuf)) \ + raw_keybuf = larger_vector (raw_keybuf, 1, -1) + +/* Number of elements of this_command_keys + that precede this key sequence. */ +static ptrdiff_t this_single_command_key_start; + +/* Record values of this_command_key_count and echo_length () + before this command was read. */ +static ptrdiff_t before_command_key_count; +static ptrdiff_t before_command_echo_length; + +#ifdef HAVE_STACK_OVERFLOW_HANDLING + +/* For longjmp to recover from C stack overflow. */ +sigjmp_buf return_to_command_loop; + +/* Message displayed by Vtop_level when recovering from C stack overflow. */ +static Lisp_Object recover_top_level_message; + +#endif /* HAVE_STACK_OVERFLOW_HANDLING */ + +/* Message normally displayed by Vtop_level. */ +static Lisp_Object regular_top_level_message; + +/* For longjmp to where kbd input is being done. */ + +static sys_jmp_buf getcjmp; + +/* True while doing kbd input. */ +bool waiting_for_input; + +/* True while displaying for echoing. Delays C-g throwing. */ + +static bool echoing; + +/* Non-null means we can start echoing at the next input pause even + though there is something in the echo area. */ + +static struct kboard *ok_to_echo_at_next_pause; + +/* The kboard last echoing, or null for none. Reset to 0 in + cancel_echoing. If non-null, and a current echo area message + exists, and echo_message_buffer is eq to the current message + buffer, we know that the message comes from echo_kboard. */ + +struct kboard *echo_kboard; + +/* The buffer used for echoing. Set in echo_now, reset in + cancel_echoing. */ + +Lisp_Object echo_message_buffer; + +/* True means C-g should cause immediate error-signal. */ +bool immediate_quit; + +/* Character that causes a quit. Normally C-g. + + If we are running on an ordinary terminal, this must be an ordinary + ASCII char, since we want to make it our interrupt character. + + If we are not running on an ordinary terminal, it still needs to be + an ordinary ASCII char. This character needs to be recognized in + the input interrupt handler. At this point, the keystroke is + represented as a struct input_event, while the desired quit + character is specified as a lispy event. The mapping from struct + input_events to lispy events cannot run in an interrupt handler, + and the reverse mapping is difficult for anything but ASCII + keystrokes. + + FOR THESE ELABORATE AND UNSATISFYING REASONS, quit_char must be an + ASCII character. */ +int quit_char; + +/* Current depth in recursive edits. */ +EMACS_INT command_loop_level; + +/* If not Qnil, this is a switch-frame event which we decided to put + off until the end of a key sequence. This should be read as the + next command input, after any unread_command_events. + + read_key_sequence uses this to delay switch-frame events until the + end of the key sequence; Fread_char uses it to put off switch-frame + events until a non-ASCII event is acceptable as input. */ +Lisp_Object unread_switch_frame; + +/* Last size recorded for a current buffer which is not a minibuffer. */ +static ptrdiff_t last_non_minibuf_size; + +/* Total number of times read_char has returned, modulo UINTMAX_MAX + 1. */ +uintmax_t num_input_events; + +/* Value of num_nonmacro_input_events as of last auto save. */ + +static EMACS_INT last_auto_save; + +/* The value of point when the last command was started. */ +static ptrdiff_t last_point_position; + +/* The frame in which the last input event occurred, or Qmacro if the + last event came from a macro. We use this to determine when to + generate switch-frame events. This may be cleared by functions + like Fselect_frame, to make sure that a switch-frame event is + generated by the next character. + + FIXME: This is modified by a signal handler so it should be volatile. + It's exported to Lisp, though, so it can't simply be marked + 'volatile' here. */ +Lisp_Object internal_last_event_frame; + +/* `read_key_sequence' stores here the command definition of the + key sequence that it reads. */ +static Lisp_Object read_key_sequence_cmd; +static Lisp_Object read_key_sequence_remapped; + +/* File in which we write all commands we read. */ +static FILE *dribble; + +/* True if input is available. */ +bool input_pending; + +/* True if more input was available last time we read an event. + + Since redisplay can take a significant amount of time and is not + indispensable to perform the user's commands, when input arrives + "too fast", Emacs skips redisplay. More specifically, if the next + command has already been input when we finish the previous command, + we skip the intermediate redisplay. + + This is useful to try and make sure Emacs keeps up with fast input + rates, such as auto-repeating keys. But in some cases, this proves + too conservative: we may end up disabling redisplay for the whole + duration of a key repetition, even though we could afford to + redisplay every once in a while. + + So we "sample" the input_pending flag before running a command and + use *that* value after running the command to decide whether to + skip redisplay or not. This way, we only skip redisplay if we + really can't keep up with the repeat rate. + + This only makes a difference if the next input arrives while running the + command, which is very unlikely if the command is executed quickly. + IOW this tends to avoid skipping redisplay after a long running command + (which is a case where skipping redisplay is not very useful since the + redisplay time is small compared to the time it took to run the command). + + A typical use case is when scrolling. Scrolling time can be split into: + - Time to do jit-lock on the newly displayed portion of buffer. + - Time to run the actual scroll command. + - Time to perform the redisplay. + Jit-lock can happen either during the command or during the redisplay. + In the most painful cases, the jit-lock time is the one that dominates. + Also jit-lock can be tweaked (via jit-lock-defer) to delay its job, at the + cost of temporary inaccuracy in display and scrolling. + So without input_was_pending, what typically happens is the following: + - when the command starts, there's no pending input (yet). + - the scroll command triggers jit-lock. + - during the long jit-lock time the next input arrives. + - at the end of the command, we check input_pending and hence decide to + skip redisplay. + - we read the next input and start over. + End result: all the hard work of jit-locking is "wasted" since redisplay + doesn't actually happens (at least not before the input rate slows down). + With input_was_pending redisplay is still skipped if Emacs can't keep up + with the input rate, but if it can keep up just enough that there's no + input_pending when we begin the command, then redisplay is not skipped + which results in better feedback to the user. */ +static bool input_was_pending; + +/* Circular buffer for pre-read keyboard input. */ + +static struct input_event kbd_buffer[KBD_BUFFER_SIZE]; + +/* Pointer to next available character in kbd_buffer. + If kbd_fetch_ptr == kbd_store_ptr, the buffer is empty. + This may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the + next available char is in kbd_buffer[0]. */ +static struct input_event *kbd_fetch_ptr; + +/* Pointer to next place to store character in kbd_buffer. This + may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the next + character should go in kbd_buffer[0]. */ +static struct input_event * volatile kbd_store_ptr; + +/* The above pair of variables forms a "queue empty" flag. When we + enqueue a non-hook event, we increment kbd_store_ptr. When we + dequeue a non-hook event, we increment kbd_fetch_ptr. We say that + there is input available if the two pointers are not equal. + + Why not just have a flag set and cleared by the enqueuing and + dequeuing functions? Such a flag could be screwed up by interrupts + at inopportune times. */ + +static void recursive_edit_unwind (Lisp_Object buffer); +static Lisp_Object command_loop (void); + +static void echo_now (void); +static ptrdiff_t echo_length (void); + +/* Incremented whenever a timer is run. */ +unsigned timers_run; + +/* Address (if not 0) of struct timespec to zero out if a SIGIO interrupt + happens. */ +struct timespec *input_available_clear_time; + +/* True means use SIGIO interrupts; false means use CBREAK mode. + Default is true if INTERRUPT_INPUT is defined. */ +bool interrupt_input; + +/* Nonzero while interrupts are temporarily deferred during redisplay. */ +bool interrupts_deferred; + +/* The time when Emacs started being idle. */ + +static struct timespec timer_idleness_start_time; + +/* After Emacs stops being idle, this saves the last value + of timer_idleness_start_time from when it was idle. */ + +static struct timespec timer_last_idleness_start_time; + + +/* Global variable declarations. */ + +/* Flags for readable_events. */ +#define READABLE_EVENTS_DO_TIMERS_NOW (1 << 0) +#define READABLE_EVENTS_FILTER_EVENTS (1 << 1) +#define READABLE_EVENTS_IGNORE_SQUEEZABLES (1 << 2) + +/* Function for init_keyboard to call with no args (if nonzero). */ +static void (*keyboard_init_hook) (void); + +static bool get_input_pending (int); +static bool readable_events (int); +static Lisp_Object read_char_x_menu_prompt (Lisp_Object, + Lisp_Object, bool *); +static Lisp_Object read_char_minibuf_menu_prompt (int, Lisp_Object); +static Lisp_Object make_lispy_event (struct input_event *); +static Lisp_Object make_lispy_movement (struct frame *, Lisp_Object, + enum scroll_bar_part, + Lisp_Object, Lisp_Object, + Time); +static Lisp_Object modify_event_symbol (ptrdiff_t, int, Lisp_Object, + Lisp_Object, const char *const *, + Lisp_Object *, ptrdiff_t); +static Lisp_Object make_lispy_switch_frame (Lisp_Object); +static Lisp_Object make_lispy_focus_in (Lisp_Object); +#ifdef HAVE_WINDOW_SYSTEM +static Lisp_Object make_lispy_focus_out (Lisp_Object); +#endif /* HAVE_WINDOW_SYSTEM */ +static bool help_char_p (Lisp_Object); +static void save_getcjmp (sys_jmp_buf); +static void restore_getcjmp (sys_jmp_buf); +static Lisp_Object apply_modifiers (int, Lisp_Object); +static void clear_event (struct input_event *); +static void restore_kboard_configuration (int); +#ifdef USABLE_SIGIO +static void deliver_input_available_signal (int signo); +#endif +static void handle_interrupt (bool); +static _Noreturn void quit_throw_to_read_char (bool); +static void process_special_events (void); +static void timer_start_idle (void); +static void timer_stop_idle (void); +static void timer_resume_idle (void); +static void deliver_user_signal (int); +static char *find_user_signal_name (int); +static void store_user_signal_events (void); + +/* These setters are used only in this file, so they can be private. */ +static void +kset_echo_string (struct kboard *kb, Lisp_Object val) +{ + kb->echo_string_ = val; +} +static void +kset_kbd_queue (struct kboard *kb, Lisp_Object val) +{ + kb->kbd_queue_ = val; +} +static void +kset_keyboard_translate_table (struct kboard *kb, Lisp_Object val) +{ + kb->Vkeyboard_translate_table_ = val; +} +static void +kset_last_prefix_arg (struct kboard *kb, Lisp_Object val) +{ + kb->Vlast_prefix_arg_ = val; +} +static void +kset_last_repeatable_command (struct kboard *kb, Lisp_Object val) +{ + kb->Vlast_repeatable_command_ = val; +} +static void +kset_local_function_key_map (struct kboard *kb, Lisp_Object val) +{ + kb->Vlocal_function_key_map_ = val; +} +static void +kset_overriding_terminal_local_map (struct kboard *kb, Lisp_Object val) +{ + kb->Voverriding_terminal_local_map_ = val; +} +static void +kset_real_last_command (struct kboard *kb, Lisp_Object val) +{ + kb->Vreal_last_command_ = val; +} +static void +kset_system_key_syms (struct kboard *kb, Lisp_Object val) +{ + kb->system_key_syms_ = val; +} + + +/* Add C to the echo string, without echoing it immediately. C can be + a character, which is pretty-printed, or a symbol, whose name is + printed. */ + +static void +echo_add_key (Lisp_Object c) +{ + char initbuf[KEY_DESCRIPTION_SIZE + 100]; + ptrdiff_t size = sizeof initbuf; + char *buffer = initbuf; + char *ptr = buffer; + Lisp_Object echo_string; + USE_SAFE_ALLOCA; + + echo_string = KVAR (current_kboard, echo_string); + + /* If someone has passed us a composite event, use its head symbol. */ + c = EVENT_HEAD (c); + + if (INTEGERP (c)) + ptr = push_key_description (XINT (c), ptr); + else if (SYMBOLP (c)) + { + Lisp_Object name = SYMBOL_NAME (c); + ptrdiff_t nbytes = SBYTES (name); + + if (size - (ptr - buffer) < nbytes) + { + ptrdiff_t offset = ptr - buffer; + size = max (2 * size, size + nbytes); + buffer = SAFE_ALLOCA (size); + ptr = buffer + offset; + } + + ptr += copy_text (SDATA (name), (unsigned char *) ptr, nbytes, + STRING_MULTIBYTE (name), 1); + } + + if ((NILP (echo_string) || SCHARS (echo_string) == 0) + && help_char_p (c)) + { + static const char text[] = " (Type ? for further options)"; + int len = sizeof text - 1; + + if (size - (ptr - buffer) < len) + { + ptrdiff_t offset = ptr - buffer; + size += len; + buffer = SAFE_ALLOCA (size); + ptr = buffer + offset; + } + + memcpy (ptr, text, len); + ptr += len; + } + + /* Replace a dash from echo_dash with a space, otherwise add a space + at the end as a separator between keys. */ + AUTO_STRING (space, " "); + if (STRINGP (echo_string) && SCHARS (echo_string) > 1) + { + Lisp_Object last_char, prev_char, idx; + + idx = make_number (SCHARS (echo_string) - 2); + prev_char = Faref (echo_string, idx); + + idx = make_number (SCHARS (echo_string) - 1); + last_char = Faref (echo_string, idx); + + /* We test PREV_CHAR to make sure this isn't the echoing of a + minus-sign. */ + if (XINT (last_char) == '-' && XINT (prev_char) != ' ') + Faset (echo_string, idx, make_number (' ')); + else + echo_string = concat2 (echo_string, space); + } + else if (STRINGP (echo_string) && SCHARS (echo_string) > 0) + echo_string = concat2 (echo_string, space); + + kset_echo_string + (current_kboard, + concat2 (echo_string, make_string (buffer, ptr - buffer))); + SAFE_FREE (); +} + +/* Add C to the echo string, if echoing is going on. C can be a + character or a symbol. */ + +static void +echo_char (Lisp_Object c) +{ + if (current_kboard->immediate_echo) + { + echo_add_key (c); + echo_now (); + } +} + +/* Temporarily add a dash to the end of the echo string if it's not + empty, so that it serves as a mini-prompt for the very next + character. */ + +static void +echo_dash (void) +{ + /* Do nothing if not echoing at all. */ + if (NILP (KVAR (current_kboard, echo_string))) + return; + + if (this_command_key_count == 0) + return; + + if (!current_kboard->immediate_echo + && SCHARS (KVAR (current_kboard, echo_string)) == 0) + return; + + /* Do nothing if we just printed a prompt. */ + if (current_kboard->echo_after_prompt + == SCHARS (KVAR (current_kboard, echo_string))) + return; + + /* Do nothing if we have already put a dash at the end. */ + if (SCHARS (KVAR (current_kboard, echo_string)) > 1) + { + Lisp_Object last_char, prev_char, idx; + + idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 2); + prev_char = Faref (KVAR (current_kboard, echo_string), idx); + + idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 1); + last_char = Faref (KVAR (current_kboard, echo_string), idx); + + if (XINT (last_char) == '-' && XINT (prev_char) != ' ') + return; + } + + /* Put a dash at the end of the buffer temporarily, + but make it go away when the next character is added. */ + AUTO_STRING (dash, "-"); + kset_echo_string (current_kboard, + concat2 (KVAR (current_kboard, echo_string), dash)); + echo_now (); +} + +/* Display the current echo string, and begin echoing if not already + doing so. */ + +static void +echo_now (void) +{ + if (!current_kboard->immediate_echo) + { + ptrdiff_t i; + current_kboard->immediate_echo = 1; + + for (i = 0; i < this_command_key_count; i++) + { + Lisp_Object c; + + /* Set before_command_echo_length to the value that would + have been saved before the start of this subcommand in + command_loop_1, if we had already been echoing then. */ + if (i == this_single_command_key_start) + before_command_echo_length = echo_length (); + + c = AREF (this_command_keys, i); + if (! (EVENT_HAS_PARAMETERS (c) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_movement))) + echo_char (c); + } + + /* Set before_command_echo_length to the value that would + have been saved before the start of this subcommand in + command_loop_1, if we had already been echoing then. */ + if (this_command_key_count == this_single_command_key_start) + before_command_echo_length = echo_length (); + + /* Put a dash at the end to invite the user to type more. */ + echo_dash (); + } + + echoing = 1; + /* FIXME: Use call (Qmessage) so it can be advised (e.g. emacspeak). */ + message3_nolog (KVAR (current_kboard, echo_string)); + echoing = 0; + + /* Record in what buffer we echoed, and from which kboard. */ + echo_message_buffer = echo_area_buffer[0]; + echo_kboard = current_kboard; + + if (waiting_for_input && !NILP (Vquit_flag)) + quit_throw_to_read_char (0); +} + +/* Turn off echoing, for the start of a new command. */ + +void +cancel_echoing (void) +{ + current_kboard->immediate_echo = 0; + current_kboard->echo_after_prompt = -1; + kset_echo_string (current_kboard, Qnil); + ok_to_echo_at_next_pause = NULL; + echo_kboard = NULL; + echo_message_buffer = Qnil; +} + +/* Return the length of the current echo string. */ + +static ptrdiff_t +echo_length (void) +{ + return (STRINGP (KVAR (current_kboard, echo_string)) + ? SCHARS (KVAR (current_kboard, echo_string)) + : 0); +} + +/* Truncate the current echo message to its first LEN chars. + This and echo_char get used by read_key_sequence when the user + switches frames while entering a key sequence. */ + +static void +echo_truncate (ptrdiff_t nchars) +{ + if (STRINGP (KVAR (current_kboard, echo_string))) + kset_echo_string (current_kboard, + Fsubstring (KVAR (current_kboard, echo_string), + make_number (0), make_number (nchars))); + truncate_echo_area (nchars); +} + + +/* Functions for manipulating this_command_keys. */ +static void +add_command_key (Lisp_Object key) +{ +#if 0 /* Not needed after we made Freset_this_command_lengths + do the job immediately. */ + /* If reset-this-command-length was called recently, obey it now. + See the doc string of that function for an explanation of why. */ + if (before_command_restore_flag) + { + this_command_key_count = before_command_key_count_1; + if (this_command_key_count < this_single_command_key_start) + this_single_command_key_start = this_command_key_count; + echo_truncate (before_command_echo_length_1); + before_command_restore_flag = 0; + } +#endif + + if (this_command_key_count >= ASIZE (this_command_keys)) + this_command_keys = larger_vector (this_command_keys, 1, -1); + + ASET (this_command_keys, this_command_key_count, key); + ++this_command_key_count; +} + + +Lisp_Object +recursive_edit_1 (void) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object val; + + if (command_loop_level > 0) + { + specbind (Qstandard_output, Qt); + specbind (Qstandard_input, Qt); + } + +#ifdef HAVE_WINDOW_SYSTEM + /* The command loop has started an hourglass timer, so we have to + cancel it here, otherwise it will fire because the recursive edit + can take some time. Do not check for display_hourglass_p here, + because it could already be nil. */ + cancel_hourglass (); +#endif + + /* This function may have been called from a debugger called from + within redisplay, for instance by Edebugging a function called + from fontification-functions. We want to allow redisplay in + the debugging session. + + The recursive edit is left with a `(throw exit ...)'. The `exit' + tag is not caught anywhere in redisplay, i.e. when we leave the + recursive edit, the original redisplay leading to the recursive + edit will be unwound. The outcome should therefore be safe. */ + specbind (Qinhibit_redisplay, Qnil); + redisplaying_p = 0; + + val = command_loop (); + if (EQ (val, Qt)) + Fsignal (Qquit, Qnil); + /* Handle throw from read_minibuf when using minibuffer + while it's active but we're in another window. */ + if (STRINGP (val)) + xsignal1 (Qerror, val); + + return unbind_to (count, Qnil); +} + +/* When an auto-save happens, record the "time", and don't do again soon. */ + +void +record_auto_save (void) +{ + last_auto_save = num_nonmacro_input_events; +} + +/* Make an auto save happen as soon as possible at command level. */ + +#ifdef SIGDANGER +void +force_auto_save_soon (void) +{ + last_auto_save = - auto_save_interval - 1; + + record_asynch_buffer_change (); +} +#endif + +DEFUN ("recursive-edit", Frecursive_edit, Srecursive_edit, 0, 0, "", + doc: /* Invoke the editor command loop recursively. +To get out of the recursive edit, a command can throw to `exit' -- for +instance `(throw 'exit nil)'. +If you throw a value other than t, `recursive-edit' returns normally +to the function that called it. Throwing a t value causes +`recursive-edit' to quit, so that control returns to the command loop +one level up. + +This function is called by the editor initialization to begin editing. */) + (void) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object buffer; + + /* If we enter while input is blocked, don't lock up here. + This may happen through the debugger during redisplay. */ + if (input_blocked_p ()) + return Qnil; + + if (command_loop_level >= 0 + && current_buffer != XBUFFER (XWINDOW (selected_window)->contents)) + buffer = Fcurrent_buffer (); + else + buffer = Qnil; + + /* Don't do anything interesting between the increment and the + record_unwind_protect! Otherwise, we could get distracted and + never decrement the counter again. */ + command_loop_level++; + update_mode_lines = 17; + record_unwind_protect (recursive_edit_unwind, buffer); + + /* If we leave recursive_edit_1 below with a `throw' for instance, + like it is done in the splash screen display, we have to + make sure that we restore single_kboard as command_loop_1 + would have done if it were left normally. */ + if (command_loop_level > 0) + temporarily_switch_to_single_kboard (SELECTED_FRAME ()); + + recursive_edit_1 (); + return unbind_to (count, Qnil); +} + +void +recursive_edit_unwind (Lisp_Object buffer) +{ + if (BUFFERP (buffer)) + Fset_buffer (buffer); + + command_loop_level--; + update_mode_lines = 18; +} + + +#if 0 /* These two functions are now replaced with + temporarily_switch_to_single_kboard. */ +static void +any_kboard_state () +{ +#if 0 /* Theory: if there's anything in Vunread_command_events, + it will right away be read by read_key_sequence, + and then if we do switch KBOARDS, it will go into the side + queue then. So we don't need to do anything special here -- rms. */ + if (CONSP (Vunread_command_events)) + { + current_kboard->kbd_queue + = nconc2 (Vunread_command_events, current_kboard->kbd_queue); + current_kboard->kbd_queue_has_data = 1; + } + Vunread_command_events = Qnil; +#endif + single_kboard = 0; +} + +/* Switch to the single-kboard state, making current_kboard + the only KBOARD from which further input is accepted. */ + +void +single_kboard_state () +{ + single_kboard = 1; +} +#endif + +/* If we're in single_kboard state for kboard KBOARD, + get out of it. */ + +void +not_single_kboard_state (KBOARD *kboard) +{ + if (kboard == current_kboard) + single_kboard = 0; +} + +/* Maintain a stack of kboards, so other parts of Emacs + can switch temporarily to the kboard of a given frame + and then revert to the previous status. */ + +struct kboard_stack +{ + KBOARD *kboard; + struct kboard_stack *next; +}; + +static struct kboard_stack *kboard_stack; + +void +push_kboard (struct kboard *k) +{ + struct kboard_stack *p = xmalloc (sizeof *p); + + p->next = kboard_stack; + p->kboard = current_kboard; + kboard_stack = p; + + current_kboard = k; +} + +void +pop_kboard (void) +{ + struct terminal *t; + struct kboard_stack *p = kboard_stack; + bool found = 0; + for (t = terminal_list; t; t = t->next_terminal) + { + if (t->kboard == p->kboard) + { + current_kboard = p->kboard; + found = 1; + break; + } + } + if (!found) + { + /* The terminal we remembered has been deleted. */ + current_kboard = FRAME_KBOARD (SELECTED_FRAME ()); + single_kboard = 0; + } + kboard_stack = p->next; + xfree (p); +} + +/* Switch to single_kboard mode, making current_kboard the only KBOARD + from which further input is accepted. If F is non-nil, set its + KBOARD as the current keyboard. + + This function uses record_unwind_protect_int to return to the previous + state later. + + If Emacs is already in single_kboard mode, and F's keyboard is + locked, then this function will throw an error. */ + +void +temporarily_switch_to_single_kboard (struct frame *f) +{ + bool was_locked = single_kboard; + if (was_locked) + { + if (f != NULL && FRAME_KBOARD (f) != current_kboard) + /* We can not switch keyboards while in single_kboard mode. + In rare cases, Lisp code may call `recursive-edit' (or + `read-minibuffer' or `y-or-n-p') after it switched to a + locked frame. For example, this is likely to happen + when server.el connects to a new terminal while Emacs is in + single_kboard mode. It is best to throw an error instead + of presenting the user with a frozen screen. */ + error ("Terminal %d is locked, cannot read from it", + FRAME_TERMINAL (f)->id); + else + /* This call is unnecessary, but helps + `restore_kboard_configuration' discover if somebody changed + `current_kboard' behind our back. */ + push_kboard (current_kboard); + } + else if (f != NULL) + current_kboard = FRAME_KBOARD (f); + single_kboard = 1; + record_unwind_protect_int (restore_kboard_configuration, was_locked); +} + +#if 0 /* This function is not needed anymore. */ +void +record_single_kboard_state () +{ + if (single_kboard) + push_kboard (current_kboard); + record_unwind_protect_int (restore_kboard_configuration, single_kboard); +} +#endif + +static void +restore_kboard_configuration (int was_locked) +{ + single_kboard = was_locked; + if (was_locked) + { + struct kboard *prev = current_kboard; + pop_kboard (); + /* The pop should not change the kboard. */ + if (single_kboard && current_kboard != prev) + emacs_abort (); + } +} + + +/* Handle errors that are not handled at inner levels + by printing an error message and returning to the editor command loop. */ + +static Lisp_Object +cmd_error (Lisp_Object data) +{ + Lisp_Object old_level, old_length; + char macroerror[sizeof "After..kbd macro iterations: " + + INT_STRLEN_BOUND (EMACS_INT)]; + +#ifdef HAVE_WINDOW_SYSTEM + if (display_hourglass_p) + cancel_hourglass (); +#endif + + if (!NILP (executing_kbd_macro)) + { + if (executing_kbd_macro_iterations == 1) + sprintf (macroerror, "After 1 kbd macro iteration: "); + else + sprintf (macroerror, "After %"pI"d kbd macro iterations: ", + executing_kbd_macro_iterations); + } + else + *macroerror = 0; + + Vstandard_output = Qt; + Vstandard_input = Qt; + Vexecuting_kbd_macro = Qnil; + executing_kbd_macro = Qnil; + kset_prefix_arg (current_kboard, Qnil); + kset_last_prefix_arg (current_kboard, Qnil); + cancel_echoing (); + + /* Avoid unquittable loop if data contains a circular list. */ + old_level = Vprint_level; + old_length = Vprint_length; + XSETFASTINT (Vprint_level, 10); + XSETFASTINT (Vprint_length, 10); + cmd_error_internal (data, macroerror); + Vprint_level = old_level; + Vprint_length = old_length; + + Vquit_flag = Qnil; + Vinhibit_quit = Qnil; + + return make_number (0); +} + +/* Take actions on handling an error. DATA is the data that describes + the error. + + CONTEXT is a C-string containing ASCII characters only which + describes the context in which the error happened. If we need to + generalize CONTEXT to allow multibyte characters, make it a Lisp + string. */ + +void +cmd_error_internal (Lisp_Object data, const char *context) +{ + /* The immediate context is not interesting for Quits, + since they are asynchronous. */ + if (EQ (XCAR (data), Qquit)) + Vsignaling_function = Qnil; + + Vquit_flag = Qnil; + Vinhibit_quit = Qt; + + /* Use user's specified output function if any. */ + if (!NILP (Vcommand_error_function)) + call3 (Vcommand_error_function, data, + context ? build_string (context) : empty_unibyte_string, + Vsignaling_function); + + Vsignaling_function = Qnil; +} + +DEFUN ("command-error-default-function", Fcommand_error_default_function, + Scommand_error_default_function, 3, 3, 0, + doc: /* Produce default output for unhandled error message. +Default value of `command-error-function'. */) + (Lisp_Object data, Lisp_Object context, Lisp_Object signal) +{ + struct frame *sf = SELECTED_FRAME (); + + CHECK_STRING (context); + + /* If the window system or terminal frame hasn't been initialized + yet, or we're not interactive, write the message to stderr and exit. */ + if (!sf->glyphs_initialized_p + /* The initial frame is a special non-displaying frame. It + will be current in daemon mode when there are no frames + to display, and in non-daemon mode before the real frame + has finished initializing. If an error is thrown in the + latter case while creating the frame, then the frame + will never be displayed, so the safest thing to do is + write to stderr and quit. In daemon mode, there are + many other potential errors that do not prevent frames + from being created, so continuing as normal is better in + that case. */ + || (!IS_DAEMON && FRAME_INITIAL_P (sf)) + || noninteractive) + { + print_error_message (data, Qexternal_debugging_output, + SSDATA (context), signal); + Fterpri (Qexternal_debugging_output, Qnil); + Fkill_emacs (make_number (-1)); + } + else + { + clear_message (1, 0); + Fdiscard_input (); + message_log_maybe_newline (); + bitch_at_user (); + + print_error_message (data, Qt, SSDATA (context), signal); + } + return Qnil; +} + +static Lisp_Object command_loop_2 (Lisp_Object); +static Lisp_Object top_level_1 (Lisp_Object); + +/* Entry to editor-command-loop. + This level has the catches for exiting/returning to editor command loop. + It returns nil to exit recursive edit, t to abort it. */ + +Lisp_Object +command_loop (void) +{ +#ifdef HAVE_STACK_OVERFLOW_HANDLING + /* At least on GNU/Linux, saving signal mask is important here. */ + if (sigsetjmp (return_to_command_loop, 1) != 0) + { + /* Comes here from handle_sigsegv, see sysdep.c. */ + init_eval (); + Vinternal__top_level_message = recover_top_level_message; + } + else + Vinternal__top_level_message = regular_top_level_message; +#endif /* HAVE_STACK_OVERFLOW_HANDLING */ + if (command_loop_level > 0 || minibuf_level > 0) + { + Lisp_Object val; + val = internal_catch (Qexit, command_loop_2, Qnil); + executing_kbd_macro = Qnil; + return val; + } + else + while (1) + { + internal_catch (Qtop_level, top_level_1, Qnil); + internal_catch (Qtop_level, command_loop_2, Qnil); + executing_kbd_macro = Qnil; + + /* End of file in -batch run causes exit here. */ + if (noninteractive) + Fkill_emacs (Qt); + } +} + +/* Here we catch errors in execution of commands within the + editing loop, and reenter the editing loop. + When there is an error, cmd_error runs and returns a non-nil + value to us. A value of nil means that command_loop_1 itself + returned due to end of file (or end of kbd macro). */ + +static Lisp_Object +command_loop_2 (Lisp_Object ignore) +{ + register Lisp_Object val; + + do + val = internal_condition_case (command_loop_1, Qerror, cmd_error); + while (!NILP (val)); + + return Qnil; +} + +static Lisp_Object +top_level_2 (void) +{ + return Feval (Vtop_level, Qnil); +} + +static Lisp_Object +top_level_1 (Lisp_Object ignore) +{ + /* On entry to the outer level, run the startup file. */ + if (!NILP (Vtop_level)) + internal_condition_case (top_level_2, Qerror, cmd_error); + else if (!NILP (Vpurify_flag)) + message1 ("Bare impure Emacs (standard Lisp code not loaded)"); + else + message1 ("Bare Emacs (standard Lisp code not loaded)"); + return Qnil; +} + +DEFUN ("top-level", Ftop_level, Stop_level, 0, 0, "", + doc: /* Exit all recursive editing levels. +This also exits all active minibuffers. */ + attributes: noreturn) + (void) +{ +#ifdef HAVE_WINDOW_SYSTEM + if (display_hourglass_p) + cancel_hourglass (); +#endif + + /* Unblock input if we enter with input blocked. This may happen if + redisplay traps e.g. during tool-bar update with input blocked. */ + totally_unblock_input (); + + Fthrow (Qtop_level, Qnil); +} + +static _Noreturn void +user_error (const char *msg) +{ + xsignal1 (Quser_error, build_string (msg)); +} + +/* _Noreturn will be added to prototype by make-docfile. */ +DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0, "", + doc: /* Exit from the innermost recursive edit or minibuffer. */ + attributes: noreturn) + (void) +{ + if (command_loop_level > 0 || minibuf_level > 0) + Fthrow (Qexit, Qnil); + + user_error ("No recursive edit is in progress"); +} + +/* _Noreturn will be added to prototype by make-docfile. */ +DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit, 0, 0, "", + doc: /* Abort the command that requested this recursive edit or minibuffer input. */ + attributes: noreturn) + (void) +{ + if (command_loop_level > 0 || minibuf_level > 0) + Fthrow (Qexit, Qt); + + user_error ("No recursive edit is in progress"); +} + +/* Restore mouse tracking enablement. See Ftrack_mouse for the only use + of this function. */ + +static void +tracking_off (Lisp_Object old_value) +{ + do_mouse_tracking = old_value; + if (NILP (old_value)) + { + /* Redisplay may have been preempted because there was input + available, and it assumes it will be called again after the + input has been processed. If the only input available was + the sort that we have just disabled, then we need to call + redisplay. */ + if (!readable_events (READABLE_EVENTS_DO_TIMERS_NOW)) + { + redisplay_preserve_echo_area (6); + get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW); + } + } +} + +DEFUN ("internal--track-mouse", Ftrack_mouse, Strack_mouse, 1, 1, 0, + doc: /* Call BODYFUN with mouse movement events enabled. */) + (Lisp_Object bodyfun) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object val; + + record_unwind_protect (tracking_off, do_mouse_tracking); + + do_mouse_tracking = Qt; + + val = call0 (bodyfun); + return unbind_to (count, val); +} + +/* If mouse has moved on some frame, return one of those frames. + + Return 0 otherwise. + + If ignore_mouse_drag_p is non-zero, ignore (implicit) mouse movement + after resizing the tool-bar window. */ + +bool ignore_mouse_drag_p; + +static struct frame * +some_mouse_moved (void) +{ + Lisp_Object tail, frame; + + if (ignore_mouse_drag_p) + { + /* ignore_mouse_drag_p = 0; */ + return 0; + } + + FOR_EACH_FRAME (tail, frame) + { + if (XFRAME (frame)->mouse_moved) + return XFRAME (frame); + } + + return 0; +} + + +/* This is the actual command reading loop, + sans error-handling encapsulation. */ + +static int read_key_sequence (Lisp_Object *, int, Lisp_Object, + bool, bool, bool, bool); +static void adjust_point_for_property (ptrdiff_t, bool); + +/* The last boundary auto-added to buffer-undo-list. */ +Lisp_Object last_undo_boundary; + +/* FIXME: This is wrong rather than test window-system, we should call + a new set-selection, which will then dispatch to x-set-selection, or + tty-set-selection, or w32-set-selection, ... */ + +Lisp_Object +command_loop_1 (void) +{ + Lisp_Object cmd; + Lisp_Object keybuf[30]; + int i; + EMACS_INT prev_modiff = 0; + struct buffer *prev_buffer = NULL; + bool already_adjusted = 0; + + kset_prefix_arg (current_kboard, Qnil); + kset_last_prefix_arg (current_kboard, Qnil); + Vdeactivate_mark = Qnil; + waiting_for_input = 0; + cancel_echoing (); + + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + + if (NILP (Vmemory_full)) + { + /* Make sure this hook runs after commands that get errors and + throw to top level. */ + /* Note that the value cell will never directly contain nil + if the symbol is a local variable. */ + if (!NILP (Vpost_command_hook) && !NILP (Vrun_hooks)) + safe_run_hooks (Qpost_command_hook); + + /* If displaying a message, resize the echo area window to fit + that message's size exactly. */ + if (!NILP (echo_area_buffer[0])) + resize_echo_area_exactly (); + + /* If there are warnings waiting, process them. */ + if (!NILP (Vdelayed_warnings_list)) + safe_run_hooks (Qdelayed_warnings_hook); + + if (!NILP (Vdeferred_action_list)) + safe_run_hooks (Qdeferred_action_function); + } + + /* Do this after running Vpost_command_hook, for consistency. */ + kset_last_command (current_kboard, Vthis_command); + kset_real_last_command (current_kboard, Vreal_this_command); + if (!CONSP (last_command_event)) + kset_last_repeatable_command (current_kboard, Vreal_this_command); + + while (1) + { + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + + /* Make sure the current window's buffer is selected. */ + set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents)); + + /* Display any malloc warning that just came out. Use while because + displaying one warning can cause another. */ + + while (pending_malloc_warning) + display_malloc_warning (); + + Vdeactivate_mark = Qnil; + + /* Don't ignore mouse movements for more than a single command + loop. (This flag is set in xdisp.c whenever the tool bar is + resized, because the resize moves text up or down, and would + generate false mouse drag events if we don't ignore them.) */ + ignore_mouse_drag_p = 0; + + /* If minibuffer on and echo area in use, + wait a short time and redraw minibuffer. */ + + if (minibuf_level + && !NILP (echo_area_buffer[0]) + && EQ (minibuf_window, echo_area_window) + && NUMBERP (Vminibuffer_message_timeout)) + { + /* Bind inhibit-quit to t so that C-g gets read in + rather than quitting back to the minibuffer. */ + ptrdiff_t count = SPECPDL_INDEX (); + specbind (Qinhibit_quit, Qt); + + sit_for (Vminibuffer_message_timeout, 0, 2); + + /* Clear the echo area. */ + message1 (0); + safe_run_hooks (Qecho_area_clear_hook); + + unbind_to (count, Qnil); + + /* If a C-g came in before, treat it as input now. */ + if (!NILP (Vquit_flag)) + { + Vquit_flag = Qnil; + Vunread_command_events = list1 (make_number (quit_char)); + } + } + + /* If it has changed current-menubar from previous value, + really recompute the menubar from the value. */ + if (! NILP (Vlucid_menu_bar_dirty_flag) + && !NILP (Ffboundp (Qrecompute_lucid_menubar))) + call0 (Qrecompute_lucid_menubar); + + before_command_key_count = this_command_key_count; + before_command_echo_length = echo_length (); + + Vthis_command = Qnil; + Vreal_this_command = Qnil; + Vthis_original_command = Qnil; + Vthis_command_keys_shift_translated = Qnil; + + /* Read next key sequence; i gets its length. */ + i = read_key_sequence (keybuf, ARRAYELTS (keybuf), + Qnil, 0, 1, 1, 0); + + /* A filter may have run while we were reading the input. */ + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents)); + + ++num_input_keys; + + /* Now we have read a key sequence of length I, + or else I is 0 and we found end of file. */ + + if (i == 0) /* End of file -- happens only in */ + return Qnil; /* a kbd macro, at the end. */ + /* -1 means read_key_sequence got a menu that was rejected. + Just loop around and read another command. */ + if (i == -1) + { + cancel_echoing (); + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + goto finalize; + } + + last_command_event = keybuf[i - 1]; + + /* If the previous command tried to force a specific window-start, + forget about that, in case this command moves point far away + from that position. But also throw away beg_unchanged and + end_unchanged information in that case, so that redisplay will + update the whole window properly. */ + if (XWINDOW (selected_window)->force_start) + { + struct buffer *b; + XWINDOW (selected_window)->force_start = 0; + b = XBUFFER (XWINDOW (selected_window)->contents); + BUF_BEG_UNCHANGED (b) = BUF_END_UNCHANGED (b) = 0; + } + + cmd = read_key_sequence_cmd; + if (!NILP (Vexecuting_kbd_macro)) + { + if (!NILP (Vquit_flag)) + { + Vexecuting_kbd_macro = Qt; + QUIT; /* Make some noise. */ + /* Will return since macro now empty. */ + } + } + + /* Do redisplay processing after this command except in special + cases identified below. */ + prev_buffer = current_buffer; + prev_modiff = MODIFF; + last_point_position = PT; + + /* By default, we adjust point to a boundary of a region that + has such a property that should be treated intangible + (e.g. composition, display). But, some commands will set + this variable differently. */ + Vdisable_point_adjustment = Qnil; + + /* Process filters and timers may have messed with deactivate-mark. + reset it before we execute the command. */ + Vdeactivate_mark = Qnil; + + /* Remap command through active keymaps. */ + Vthis_original_command = cmd; + if (!NILP (read_key_sequence_remapped)) + cmd = read_key_sequence_remapped; + + /* Execute the command. */ + + { + total_keys += total_keys < NUM_RECENT_KEYS; + ASET (recent_keys, recent_keys_index, + Fcons (Qnil, cmd)); + if (++recent_keys_index >= NUM_RECENT_KEYS) + recent_keys_index = 0; + } + Vthis_command = cmd; + Vreal_this_command = cmd; + safe_run_hooks (Qpre_command_hook); + + already_adjusted = 0; + + if (NILP (Vthis_command)) + /* nil means key is undefined. */ + call0 (Qundefined); + else + { + /* Here for a command that isn't executed directly. */ + +#ifdef HAVE_WINDOW_SYSTEM + ptrdiff_t scount = SPECPDL_INDEX (); + + if (display_hourglass_p + && NILP (Vexecuting_kbd_macro)) + { + record_unwind_protect_void (cancel_hourglass); + start_hourglass (); + } +#endif + + if (NILP (KVAR (current_kboard, Vprefix_arg))) /* FIXME: Why? --Stef */ + { + Lisp_Object undo = BVAR (current_buffer, undo_list); + Fundo_boundary (); + last_undo_boundary + = (EQ (undo, BVAR (current_buffer, undo_list)) + ? Qnil : BVAR (current_buffer, undo_list)); + } + call1 (Qcommand_execute, Vthis_command); + +#ifdef HAVE_WINDOW_SYSTEM + /* Do not check display_hourglass_p here, because + `command-execute' could change it, but we should cancel + hourglass cursor anyway. + But don't cancel the hourglass within a macro + just because a command in the macro finishes. */ + if (NILP (Vexecuting_kbd_macro)) + unbind_to (scount, Qnil); +#endif + } + kset_last_prefix_arg (current_kboard, Vcurrent_prefix_arg); + + safe_run_hooks (Qpost_command_hook); + + /* If displaying a message, resize the echo area window to fit + that message's size exactly. */ + if (!NILP (echo_area_buffer[0])) + resize_echo_area_exactly (); + + /* If there are warnings waiting, process them. */ + if (!NILP (Vdelayed_warnings_list)) + safe_run_hooks (Qdelayed_warnings_hook); + + safe_run_hooks (Qdeferred_action_function); + + /* If there is a prefix argument, + 1) We don't want Vlast_command to be ``universal-argument'' + (that would be dumb), so don't set Vlast_command, + 2) we want to leave echoing on so that the prefix will be + echoed as part of this key sequence, so don't call + cancel_echoing, and + 3) we want to leave this_command_key_count non-zero, so that + read_char will realize that it is re-reading a character, and + not echo it a second time. + + If the command didn't actually create a prefix arg, + but is merely a frame event that is transparent to prefix args, + then the above doesn't apply. */ + if (NILP (KVAR (current_kboard, Vprefix_arg)) + || CONSP (last_command_event)) + { + kset_last_command (current_kboard, Vthis_command); + kset_real_last_command (current_kboard, Vreal_this_command); + if (!CONSP (last_command_event)) + kset_last_repeatable_command (current_kboard, Vreal_this_command); + cancel_echoing (); + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + } + + if (!NILP (BVAR (current_buffer, mark_active)) + && !NILP (Vrun_hooks)) + { + /* In Emacs 22, setting transient-mark-mode to `only' was a + way of turning it on for just one command. This usage is + obsolete, but support it anyway. */ + if (EQ (Vtransient_mark_mode, Qidentity)) + Vtransient_mark_mode = Qnil; + else if (EQ (Vtransient_mark_mode, Qonly)) + Vtransient_mark_mode = Qidentity; + + if (!NILP (Vdeactivate_mark)) + /* If `select-active-regions' is non-nil, this call to + `deactivate-mark' also sets the PRIMARY selection. */ + call0 (Qdeactivate_mark); + else + { + /* Even if not deactivating the mark, set PRIMARY if + `select-active-regions' is non-nil. */ + if (!NILP (Fwindow_system (Qnil)) + /* Even if mark_active is non-nil, the actual buffer + marker may not have been set yet (Bug#7044). */ + && XMARKER (BVAR (current_buffer, mark))->buffer + && (EQ (Vselect_active_regions, Qonly) + ? EQ (CAR_SAFE (Vtransient_mark_mode), Qonly) + : (!NILP (Vselect_active_regions) + && !NILP (Vtransient_mark_mode))) + && NILP (Fmemq (Vthis_command, + Vselection_inhibit_update_commands))) + { + Lisp_Object txt + = call1 (Fsymbol_value (Qregion_extract_function), Qnil); + if (XINT (Flength (txt)) > 0) + /* Don't set empty selections. */ + call2 (Qgui_set_selection, QPRIMARY, txt); + } + + if (current_buffer != prev_buffer || MODIFF != prev_modiff) + run_hook (intern ("activate-mark-hook")); + } + + Vsaved_region_selection = Qnil; + } + + finalize: + + if (current_buffer == prev_buffer + && last_point_position != PT + && NILP (Vdisable_point_adjustment) + && NILP (Vglobal_disable_point_adjustment)) + { + if (last_point_position > BEGV + && last_point_position < ZV + && (composition_adjust_point (last_point_position, + last_point_position) + != last_point_position)) + /* The last point was temporarily set within a grapheme + cluster to prevent automatic composition. To recover + the automatic composition, we must update the + display. */ + windows_or_buffers_changed = 21; + if (!already_adjusted) + adjust_point_for_property (last_point_position, + MODIFF != prev_modiff); + } + + /* Install chars successfully executed in kbd macro. */ + + if (!NILP (KVAR (current_kboard, defining_kbd_macro)) + && NILP (KVAR (current_kboard, Vprefix_arg))) + finalize_kbd_macro_chars (); + } +} + +Lisp_Object +read_menu_command (void) +{ + Lisp_Object keybuf[30]; + ptrdiff_t count = SPECPDL_INDEX (); + int i; + + /* We don't want to echo the keystrokes while navigating the + menus. */ + specbind (Qecho_keystrokes, make_number (0)); + + i = read_key_sequence (keybuf, ARRAYELTS (keybuf), + Qnil, 0, 1, 1, 1); + + unbind_to (count, Qnil); + + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + if (i == 0 || i == -1) + return Qt; + + return read_key_sequence_cmd; +} + +/* Adjust point to a boundary of a region that has such a property + that should be treated intangible. For the moment, we check + `composition', `display' and `invisible' properties. + LAST_PT is the last position of point. */ + +static void +adjust_point_for_property (ptrdiff_t last_pt, bool modified) +{ + ptrdiff_t beg, end; + Lisp_Object val, overlay, tmp; + /* When called after buffer modification, we should temporarily + suppress the point adjustment for automatic composition so that a + user can keep inserting another character at point or keep + deleting characters around point. */ + bool check_composition = ! modified, check_display = 1, check_invisible = 1; + ptrdiff_t orig_pt = PT; + + /* FIXME: cycling is probably not necessary because these properties + can't be usefully combined anyway. */ + while (check_composition || check_display || check_invisible) + { + /* FIXME: check `intangible'. */ + if (check_composition + && PT > BEGV && PT < ZV + && (beg = composition_adjust_point (last_pt, PT)) != PT) + { + SET_PT (beg); + check_display = check_invisible = 1; + } + check_composition = 0; + if (check_display + && PT > BEGV && PT < ZV + && !NILP (val = get_char_property_and_overlay + (make_number (PT), Qdisplay, Qnil, &overlay)) + && display_prop_intangible_p (val, overlay, PT, PT_BYTE) + && (!OVERLAYP (overlay) + ? get_property_and_range (PT, Qdisplay, &val, &beg, &end, Qnil) + : (beg = OVERLAY_POSITION (OVERLAY_START (overlay)), + end = OVERLAY_POSITION (OVERLAY_END (overlay)))) + && (beg < PT /* && end > PT <- It's always the case. */ + || (beg <= PT && STRINGP (val) && SCHARS (val) == 0))) + { + eassert (end > PT); + SET_PT (PT < last_pt + ? (STRINGP (val) && SCHARS (val) == 0 + ? max (beg - 1, BEGV) + : beg) + : end); + check_composition = check_invisible = 1; + } + check_display = 0; + if (check_invisible && PT > BEGV && PT < ZV) + { + int inv; + bool ellipsis = 0; + beg = end = PT; + + /* Find boundaries `beg' and `end' of the invisible area, if any. */ + while (end < ZV +#if 0 + /* FIXME: We should stop if we find a spot between + two runs of `invisible' where inserted text would + be visible. This is important when we have two + invisible boundaries that enclose an area: if the + area is empty, we need this test in order to make + it possible to place point in the middle rather + than skip both boundaries. However, this code + also stops anywhere in a non-sticky text-property, + which breaks (e.g.) Org mode. */ + && (val = Fget_pos_property (make_number (end), + Qinvisible, Qnil), + TEXT_PROP_MEANS_INVISIBLE (val)) +#endif + && !NILP (val = get_char_property_and_overlay + (make_number (end), Qinvisible, Qnil, &overlay)) + && (inv = TEXT_PROP_MEANS_INVISIBLE (val))) + { + ellipsis = ellipsis || inv > 1 + || (OVERLAYP (overlay) + && (!NILP (Foverlay_get (overlay, Qafter_string)) + || !NILP (Foverlay_get (overlay, Qbefore_string)))); + tmp = Fnext_single_char_property_change + (make_number (end), Qinvisible, Qnil, Qnil); + end = NATNUMP (tmp) ? XFASTINT (tmp) : ZV; + } + while (beg > BEGV +#if 0 + && (val = Fget_pos_property (make_number (beg), + Qinvisible, Qnil), + TEXT_PROP_MEANS_INVISIBLE (val)) +#endif + && !NILP (val = get_char_property_and_overlay + (make_number (beg - 1), Qinvisible, Qnil, &overlay)) + && (inv = TEXT_PROP_MEANS_INVISIBLE (val))) + { + ellipsis = ellipsis || inv > 1 + || (OVERLAYP (overlay) + && (!NILP (Foverlay_get (overlay, Qafter_string)) + || !NILP (Foverlay_get (overlay, Qbefore_string)))); + tmp = Fprevious_single_char_property_change + (make_number (beg), Qinvisible, Qnil, Qnil); + beg = NATNUMP (tmp) ? XFASTINT (tmp) : BEGV; + } + + /* Move away from the inside area. */ + if (beg < PT && end > PT) + { + SET_PT ((orig_pt == PT && (last_pt < beg || last_pt > end)) + /* We haven't moved yet (so we don't need to fear + infinite-looping) and we were outside the range + before (so either end of the range still corresponds + to a move in the right direction): pretend we moved + less than we actually did, so that we still have + more freedom below in choosing which end of the range + to go to. */ + ? (orig_pt = -1, PT < last_pt ? end : beg) + /* We either have moved already or the last point + was already in the range: we don't get to choose + which end of the range we have to go to. */ + : (PT < last_pt ? beg : end)); + check_composition = check_display = 1; + } +#if 0 /* This assertion isn't correct, because SET_PT may end up setting + the point to something other than its argument, due to + point-motion hooks, intangibility, etc. */ + eassert (PT == beg || PT == end); +#endif + + /* Pretend the area doesn't exist if the buffer is not + modified. */ + if (!modified && !ellipsis && beg < end) + { + if (last_pt == beg && PT == end && end < ZV) + (check_composition = check_display = 1, SET_PT (end + 1)); + else if (last_pt == end && PT == beg && beg > BEGV) + (check_composition = check_display = 1, SET_PT (beg - 1)); + else if (PT == ((PT < last_pt) ? beg : end)) + /* We've already moved as far as we can. Trying to go + to the other end would mean moving backwards and thus + could lead to an infinite loop. */ + ; + else if (val = Fget_pos_property (make_number (PT), + Qinvisible, Qnil), + TEXT_PROP_MEANS_INVISIBLE (val) + && (val = (Fget_pos_property + (make_number (PT == beg ? end : beg), + Qinvisible, Qnil)), + !TEXT_PROP_MEANS_INVISIBLE (val))) + (check_composition = check_display = 1, + SET_PT (PT == beg ? end : beg)); + } + } + check_invisible = 0; + } +} + +/* Subroutine for safe_run_hooks: run the hook, which is ARGS[1]. */ + +static Lisp_Object +safe_run_hooks_1 (ptrdiff_t nargs, Lisp_Object *args) +{ + eassert (nargs == 2); + return call0 (args[1]); +} + +/* Subroutine for safe_run_hooks: handle an error by clearing out the function + from the hook. */ + +static Lisp_Object +safe_run_hooks_error (Lisp_Object error, ptrdiff_t nargs, Lisp_Object *args) +{ + eassert (nargs == 2); + AUTO_STRING (format, "Error in %s (%S): %S"); + Lisp_Object hook = args[0]; + Lisp_Object fun = args[1]; + CALLN (Fmessage, format, hook, fun, error); + + if (SYMBOLP (hook)) + { + Lisp_Object val; + bool found = 0; + Lisp_Object newval = Qnil; + for (val = find_symbol_value (hook); CONSP (val); val = XCDR (val)) + if (EQ (fun, XCAR (val))) + found = 1; + else + newval = Fcons (XCAR (val), newval); + if (found) + return Fset (hook, Fnreverse (newval)); + /* Not found in the local part of the hook. Let's look at the global + part. */ + newval = Qnil; + for (val = (NILP (Fdefault_boundp (hook)) ? Qnil + : Fdefault_value (hook)); + CONSP (val); val = XCDR (val)) + if (EQ (fun, XCAR (val))) + found = 1; + else + newval = Fcons (XCAR (val), newval); + if (found) + return Fset_default (hook, Fnreverse (newval)); + } + return Qnil; +} + +static Lisp_Object +safe_run_hook_funcall (ptrdiff_t nargs, Lisp_Object *args) +{ + eassert (nargs == 2); + /* Yes, run_hook_with_args works with args in the other order. */ + internal_condition_case_n (safe_run_hooks_1, + 2, ((Lisp_Object []) {args[1], args[0]}), + Qt, safe_run_hooks_error); + return Qnil; +} + +/* If we get an error while running the hook, cause the hook variable + to be nil. Also inhibit quits, so that C-g won't cause the hook + to mysteriously evaporate. */ + +void +safe_run_hooks (Lisp_Object hook) +{ + struct gcpro gcpro1; + ptrdiff_t count = SPECPDL_INDEX (); + + GCPRO1 (hook); + specbind (Qinhibit_quit, Qt); + run_hook_with_args (2, ((Lisp_Object []) {hook, hook}), safe_run_hook_funcall); + unbind_to (count, Qnil); + UNGCPRO; +} + + +/* Nonzero means polling for input is temporarily suppressed. */ + +int poll_suppress_count; + + +#ifdef POLL_FOR_INPUT + +/* Asynchronous timer for polling. */ + +static struct atimer *poll_timer; + +/* Poll for input, so that we catch a C-g if it comes in. */ +void +poll_for_input_1 (void) +{ + if (! input_blocked_p () + && !waiting_for_input) + gobble_input (); +} + +/* Timer callback function for poll_timer. TIMER is equal to + poll_timer. */ + +static void +poll_for_input (struct atimer *timer) +{ + if (poll_suppress_count == 0) + pending_signals = 1; +} + +#endif /* POLL_FOR_INPUT */ + +/* Begin signals to poll for input, if they are appropriate. + This function is called unconditionally from various places. */ + +void +start_polling (void) +{ +#ifdef POLL_FOR_INPUT + /* XXX This condition was (read_socket_hook && !interrupt_input), + but read_socket_hook is not global anymore. Let's pretend that + it's always set. */ + if (!interrupt_input) + { + /* Turn alarm handling on unconditionally. It might have + been turned off in process.c. */ + turn_on_atimers (1); + + /* If poll timer doesn't exist, or we need one with + a different interval, start a new one. */ + if (poll_timer == NULL + || poll_timer->interval.tv_sec != polling_period) + { + time_t period = max (1, min (polling_period, TYPE_MAXIMUM (time_t))); + struct timespec interval = make_timespec (period, 0); + + if (poll_timer) + cancel_atimer (poll_timer); + + poll_timer = start_atimer (ATIMER_CONTINUOUS, interval, + poll_for_input, NULL); + } + + /* Let the timer's callback function poll for input + if this becomes zero. */ + --poll_suppress_count; + } +#endif +} + +/* True if we are using polling to handle input asynchronously. */ + +bool +input_polling_used (void) +{ +#ifdef POLL_FOR_INPUT + /* XXX This condition was (read_socket_hook && !interrupt_input), + but read_socket_hook is not global anymore. Let's pretend that + it's always set. */ + return !interrupt_input; +#else + return 0; +#endif +} + +/* Turn off polling. */ + +void +stop_polling (void) +{ +#ifdef POLL_FOR_INPUT + /* XXX This condition was (read_socket_hook && !interrupt_input), + but read_socket_hook is not global anymore. Let's pretend that + it's always set. */ + if (!interrupt_input) + ++poll_suppress_count; +#endif +} + +/* Set the value of poll_suppress_count to COUNT + and start or stop polling accordingly. */ + +void +set_poll_suppress_count (int count) +{ +#ifdef POLL_FOR_INPUT + if (count == 0 && poll_suppress_count != 0) + { + poll_suppress_count = 1; + start_polling (); + } + else if (count != 0 && poll_suppress_count == 0) + { + stop_polling (); + } + poll_suppress_count = count; +#endif +} + +/* Bind polling_period to a value at least N. + But don't decrease it. */ + +void +bind_polling_period (int n) +{ +#ifdef POLL_FOR_INPUT + EMACS_INT new = polling_period; + + if (n > new) + new = n; + + stop_other_atimers (poll_timer); + stop_polling (); + specbind (Qpolling_period, make_number (new)); + /* Start a new alarm with the new period. */ + start_polling (); +#endif +} + +/* Apply the control modifier to CHARACTER. */ + +int +make_ctrl_char (int c) +{ + /* Save the upper bits here. */ + int upper = c & ~0177; + + if (! ASCII_CHAR_P (c)) + return c |= ctrl_modifier; + + c &= 0177; + + /* Everything in the columns containing the upper-case letters + denotes a control character. */ + if (c >= 0100 && c < 0140) + { + int oc = c; + c &= ~0140; + /* Set the shift modifier for a control char + made from a shifted letter. But only for letters! */ + if (oc >= 'A' && oc <= 'Z') + c |= shift_modifier; + } + + /* The lower-case letters denote control characters too. */ + else if (c >= 'a' && c <= 'z') + c &= ~0140; + + /* Include the bits for control and shift + only if the basic ASCII code can't indicate them. */ + else if (c >= ' ') + c |= ctrl_modifier; + + /* Replace the high bits. */ + c |= (upper & ~ctrl_modifier); + + return c; +} + +/* Display the help-echo property of the character after the mouse pointer. + Either show it in the echo area, or call show-help-function to display + it by other means (maybe in a tooltip). + + If HELP is nil, that means clear the previous help echo. + + If HELP is a string, display that string. If HELP is a function, + call it with OBJECT and POS as arguments; the function should + return a help string or nil for none. For all other types of HELP, + evaluate it to obtain a string. + + WINDOW is the window in which the help was generated, if any. + It is nil if not in a window. + + If OBJECT is a buffer, POS is the position in the buffer where the + `help-echo' text property was found. + + If OBJECT is an overlay, that overlay has a `help-echo' property, + and POS is the position in the overlay's buffer under the mouse. + + If OBJECT is a string (an overlay string or a string displayed with + the `display' property). POS is the position in that string under + the mouse. + + Note: this function may only be called with HELP nil or a string + from X code running asynchronously. */ + +void +show_help_echo (Lisp_Object help, Lisp_Object window, Lisp_Object object, + Lisp_Object pos) +{ + if (!NILP (help) && !STRINGP (help)) + { + if (FUNCTIONP (help)) + help = safe_call (4, help, window, object, pos); + else + help = safe_eval (help); + + if (!STRINGP (help)) + return; + } + + if (!noninteractive && STRINGP (help)) + { + /* The mouse-fixup-help-message Lisp function can call + mouse_position_hook, which resets the mouse_moved flags. + This causes trouble if we are trying to read a mouse motion + event (i.e., if we are inside a `track-mouse' form), so we + restore the mouse_moved flag. */ + struct frame *f = NILP (do_mouse_tracking) ? NULL : some_mouse_moved (); + help = call1 (Qmouse_fixup_help_message, help); + if (f) + f->mouse_moved = 1; + } + + if (STRINGP (help) || NILP (help)) + { + if (!NILP (Vshow_help_function)) + call1 (Vshow_help_function, help); + help_echo_showing_p = STRINGP (help); + } +} + + + +/* Input of single characters from keyboard. */ + +static Lisp_Object kbd_buffer_get_event (KBOARD **kbp, bool *used_mouse_menu, + struct timespec *end_time); +static void record_char (Lisp_Object c); + +static Lisp_Object help_form_saved_window_configs; +static void +read_char_help_form_unwind (void) +{ + Lisp_Object window_config = XCAR (help_form_saved_window_configs); + help_form_saved_window_configs = XCDR (help_form_saved_window_configs); + if (!NILP (window_config)) + Fset_window_configuration (window_config); +} + +#define STOP_POLLING \ +do { if (! polling_stopped_here) stop_polling (); \ + polling_stopped_here = 1; } while (0) + +#define RESUME_POLLING \ +do { if (polling_stopped_here) start_polling (); \ + polling_stopped_here = 0; } while (0) + +static Lisp_Object +read_event_from_main_queue (struct timespec *end_time, + sys_jmp_buf local_getcjmp, + bool *used_mouse_menu) +{ + Lisp_Object c = Qnil; + sys_jmp_buf save_jump; + KBOARD *kb IF_LINT (= NULL); + + start: + + /* Read from the main queue, and if that gives us something we can't use yet, + we put it on the appropriate side queue and try again. */ + + if (end_time && timespec_cmp (*end_time, current_timespec ()) <= 0) + return c; + + /* Actually read a character, waiting if necessary. */ + save_getcjmp (save_jump); + restore_getcjmp (local_getcjmp); + if (!end_time) + timer_start_idle (); + c = kbd_buffer_get_event (&kb, used_mouse_menu, end_time); + restore_getcjmp (save_jump); + + if (! NILP (c) && (kb != current_kboard)) + { + Lisp_Object last = KVAR (kb, kbd_queue); + if (CONSP (last)) + { + while (CONSP (XCDR (last))) + last = XCDR (last); + if (!NILP (XCDR (last))) + emacs_abort (); + } + if (!CONSP (last)) + kset_kbd_queue (kb, list1 (c)); + else + XSETCDR (last, list1 (c)); + kb->kbd_queue_has_data = 1; + c = Qnil; + if (single_kboard) + goto start; + current_kboard = kb; + /* This is going to exit from read_char + so we had better get rid of this frame's stuff. */ + return make_number (-2); + } + + /* Terminate Emacs in batch mode if at eof. */ + if (noninteractive && INTEGERP (c) && XINT (c) < 0) + Fkill_emacs (make_number (1)); + + if (INTEGERP (c)) + { + /* Add in any extra modifiers, where appropriate. */ + if ((extra_keyboard_modifiers & CHAR_CTL) + || ((extra_keyboard_modifiers & 0177) < ' ' + && (extra_keyboard_modifiers & 0177) != 0)) + XSETINT (c, make_ctrl_char (XINT (c))); + + /* Transfer any other modifier bits directly from + extra_keyboard_modifiers to c. Ignore the actual character code + in the low 16 bits of extra_keyboard_modifiers. */ + XSETINT (c, XINT (c) | (extra_keyboard_modifiers & ~0xff7f & ~CHAR_CTL)); + } + + return c; +} + + + +/* Like `read_event_from_main_queue' but applies keyboard-coding-system + to tty input. */ +static Lisp_Object +read_decoded_event_from_main_queue (struct timespec *end_time, + sys_jmp_buf local_getcjmp, + Lisp_Object prev_event, + bool *used_mouse_menu) +{ +#define MAX_ENCODED_BYTES 16 +#ifndef WINDOWSNT + Lisp_Object events[MAX_ENCODED_BYTES]; + int n = 0; +#endif + while (true) + { + Lisp_Object nextevt + = read_event_from_main_queue (end_time, local_getcjmp, + used_mouse_menu); +#ifdef WINDOWSNT + /* w32_console already returns decoded events. It either reads + Unicode characters from the Windows keyboard input, or + converts characters encoded in the current codepage into + Unicode. See w32inevt.c:key_event, near its end. */ + return nextevt; +#else + struct frame *frame = XFRAME (selected_frame); + struct terminal *terminal = frame->terminal; + if (!((FRAME_TERMCAP_P (frame) || FRAME_MSDOS_P (frame)) + /* Don't apply decoding if we're just reading a raw event + (e.g. reading bytes sent by the xterm to specify the position + of a mouse click). */ + && (!EQ (prev_event, Qt)) + && (TERMINAL_KEYBOARD_CODING (terminal)->common_flags + & CODING_REQUIRE_DECODING_MASK))) + return nextevt; /* No decoding needed. */ + else + { + int meta_key = terminal->display_info.tty->meta_key; + eassert (n < MAX_ENCODED_BYTES); + events[n++] = nextevt; + if (NATNUMP (nextevt) + && XINT (nextevt) < (meta_key == 1 ? 0x80 : 0x100)) + { /* An encoded byte sequence, let's try to decode it. */ + struct coding_system *coding + = TERMINAL_KEYBOARD_CODING (terminal); + + if (raw_text_coding_system_p (coding)) + { + int i; + if (meta_key != 2) + for (i = 0; i < n; i++) + events[i] = make_number (XINT (events[i]) & ~0x80); + } + else + { + unsigned char src[MAX_ENCODED_BYTES]; + unsigned char dest[MAX_ENCODED_BYTES * MAX_MULTIBYTE_LENGTH]; + int i; + for (i = 0; i < n; i++) + src[i] = XINT (events[i]); + if (meta_key != 2) + for (i = 0; i < n; i++) + src[i] &= ~0x80; + coding->destination = dest; + coding->dst_bytes = sizeof dest; + decode_coding_c_string (coding, src, n, Qnil); + eassert (coding->produced_char <= n); + if (coding->produced_char == 0) + { /* The encoded sequence is incomplete. */ + if (n < MAX_ENCODED_BYTES) /* Avoid buffer overflow. */ + continue; /* Read on! */ + } + else + { + const unsigned char *p = coding->destination; + eassert (coding->carryover_bytes == 0); + n = 0; + while (n < coding->produced_char) + events[n++] = make_number (STRING_CHAR_ADVANCE (p)); + } + } + } + /* Now `events' should hold decoded events. + Normally, n should be equal to 1, but better not rely on it. + We can only return one event here, so return the first we + had and keep the others (if any) for later. */ + while (n > 1) + Vunread_command_events + = Fcons (events[--n], Vunread_command_events); + return events[0]; + } +#endif + } +} + +static bool +echo_keystrokes_p (void) +{ + return (FLOATP (Vecho_keystrokes) ? XFLOAT_DATA (Vecho_keystrokes) > 0.0 + : INTEGERP (Vecho_keystrokes) ? XINT (Vecho_keystrokes) > 0 : false); +} + +/* Read a character from the keyboard; call the redisplay if needed. */ +/* commandflag 0 means do not autosave, but do redisplay. + -1 means do not redisplay, but do autosave. + -2 means do neither. + 1 means do both. + + The argument MAP is a keymap for menu prompting. + + PREV_EVENT is the previous input event, or nil if we are reading + the first event of a key sequence (or not reading a key sequence). + If PREV_EVENT is t, that is a "magic" value that says + not to run input methods, but in other respects to act as if + not reading a key sequence. + + If USED_MOUSE_MENU is non-null, then set *USED_MOUSE_MENU to true + if we used a mouse menu to read the input, or false otherwise. If + USED_MOUSE_MENU is null, don't dereference it. + + Value is -2 when we find input on another keyboard. A second call + to read_char will read it. + + If END_TIME is non-null, it is a pointer to a struct timespec + specifying the maximum time to wait until. If no input arrives by + that time, stop waiting and return nil. + + Value is t if we showed a menu and the user rejected it. */ + +Lisp_Object +read_char (int commandflag, Lisp_Object map, + Lisp_Object prev_event, + bool *used_mouse_menu, struct timespec *end_time) +{ + Lisp_Object c; + ptrdiff_t jmpcount; + sys_jmp_buf local_getcjmp; + sys_jmp_buf save_jump; + Lisp_Object tem, save; + volatile Lisp_Object previous_echo_area_message; + volatile Lisp_Object also_record; + volatile bool reread; + struct gcpro gcpro1, gcpro2; + bool volatile polling_stopped_here = 0; + struct kboard *orig_kboard = current_kboard; + + also_record = Qnil; + +#if 0 /* This was commented out as part of fixing echo for C-u left. */ + before_command_key_count = this_command_key_count; + before_command_echo_length = echo_length (); +#endif + c = Qnil; + previous_echo_area_message = Qnil; + + GCPRO2 (c, previous_echo_area_message); + + retry: + + if (CONSP (Vunread_post_input_method_events)) + { + c = XCAR (Vunread_post_input_method_events); + Vunread_post_input_method_events + = XCDR (Vunread_post_input_method_events); + + /* Undo what read_char_x_menu_prompt did when it unread + additional keys returned by Fx_popup_menu. */ + if (CONSP (c) + && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c))) + && NILP (XCDR (c))) + c = XCAR (c); + + reread = true; + goto reread_first; + } + else + reread = false; + + + if (CONSP (Vunread_command_events)) + { + bool was_disabled = 0; + + c = XCAR (Vunread_command_events); + Vunread_command_events = XCDR (Vunread_command_events); + + /* Undo what sit-for did when it unread additional keys + inside universal-argument. */ + + if (CONSP (c) && EQ (XCAR (c), Qt)) + c = XCDR (c); + else + reread = true; + + /* Undo what read_char_x_menu_prompt did when it unread + additional keys returned by Fx_popup_menu. */ + if (CONSP (c) + && EQ (XCDR (c), Qdisabled) + && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c)))) + { + was_disabled = 1; + c = XCAR (c); + } + + /* If the queued event is something that used the mouse, + set used_mouse_menu accordingly. */ + if (used_mouse_menu + /* Also check was_disabled so last-nonmenu-event won't return + a bad value when submenus are involved. (Bug#447) */ + && (EQ (c, Qtool_bar) || EQ (c, Qmenu_bar) || was_disabled)) + *used_mouse_menu = 1; + + goto reread_for_input_method; + } + + if (CONSP (Vunread_input_method_events)) + { + c = XCAR (Vunread_input_method_events); + Vunread_input_method_events = XCDR (Vunread_input_method_events); + + /* Undo what read_char_x_menu_prompt did when it unread + additional keys returned by Fx_popup_menu. */ + if (CONSP (c) + && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c))) + && NILP (XCDR (c))) + c = XCAR (c); + reread = true; + goto reread_for_input_method; + } + + this_command_key_count_reset = 0; + + if (!NILP (Vexecuting_kbd_macro)) + { + /* We set this to Qmacro; since that's not a frame, nobody will + try to switch frames on us, and the selected window will + remain unchanged. + + Since this event came from a macro, it would be misleading to + leave internal_last_event_frame set to wherever the last + real event came from. Normally, a switch-frame event selects + internal_last_event_frame after each command is read, but + events read from a macro should never cause a new frame to be + selected. */ + Vlast_event_frame = internal_last_event_frame = Qmacro; + + /* Exit the macro if we are at the end. + Also, some things replace the macro with t + to force an early exit. */ + if (EQ (Vexecuting_kbd_macro, Qt) + || executing_kbd_macro_index >= XFASTINT (Flength (Vexecuting_kbd_macro))) + { + XSETINT (c, -1); + goto exit; + } + + c = Faref (Vexecuting_kbd_macro, make_number (executing_kbd_macro_index)); + if (STRINGP (Vexecuting_kbd_macro) + && (XFASTINT (c) & 0x80) && (XFASTINT (c) <= 0xff)) + XSETFASTINT (c, CHAR_META | (XFASTINT (c) & ~0x80)); + + executing_kbd_macro_index++; + + goto from_macro; + } + + if (!NILP (unread_switch_frame)) + { + c = unread_switch_frame; + unread_switch_frame = Qnil; + + /* This event should make it into this_command_keys, and get echoed + again, so we do not set `reread'. */ + goto reread_first; + } + + /* If redisplay was requested. */ + if (commandflag >= 0) + { + bool echo_current = EQ (echo_message_buffer, echo_area_buffer[0]); + + /* If there is pending input, process any events which are not + user-visible, such as X selection_request events. */ + if (input_pending + || detect_input_pending_run_timers (0)) + swallow_events (false); /* May clear input_pending. */ + + /* Redisplay if no pending input. */ + while (!(input_pending + && (input_was_pending || !redisplay_dont_pause))) + { + input_was_pending = input_pending; + if (help_echo_showing_p && !EQ (selected_window, minibuf_window)) + redisplay_preserve_echo_area (5); + else + redisplay (); + + if (!input_pending) + /* Normal case: no input arrived during redisplay. */ + break; + + /* Input arrived and pre-empted redisplay. + Process any events which are not user-visible. */ + swallow_events (false); + /* If that cleared input_pending, try again to redisplay. */ + } + + /* Prevent the redisplay we just did + from messing up echoing of the input after the prompt. */ + if (commandflag == 0 && echo_current) + echo_message_buffer = echo_area_buffer[0]; + + } + + /* Message turns off echoing unless more keystrokes turn it on again. + + The code in 20.x for the condition was + + 1. echo_area_glyphs && *echo_area_glyphs + 2. && echo_area_glyphs != current_kboard->echobuf + 3. && ok_to_echo_at_next_pause != echo_area_glyphs + + (1) means there's a current message displayed + + (2) means it's not the message from echoing from the current + kboard. + + (3) There's only one place in 20.x where ok_to_echo_at_next_pause + is set to a non-null value. This is done in read_char and it is + set to echo_area_glyphs after a call to echo_char. That means + ok_to_echo_at_next_pause is either null or + current_kboard->echobuf with the appropriate current_kboard at + that time. + + So, condition (3) means in clear text ok_to_echo_at_next_pause + must be either null, or the current message isn't from echoing at + all, or it's from echoing from a different kboard than the + current one. */ + + if (/* There currently is something in the echo area. */ + !NILP (echo_area_buffer[0]) + && (/* It's an echo from a different kboard. */ + echo_kboard != current_kboard + /* Or we explicitly allow overwriting whatever there is. */ + || ok_to_echo_at_next_pause == NULL)) + cancel_echoing (); + else + echo_dash (); + + /* Try reading a character via menu prompting in the minibuf. + Try this before the sit-for, because the sit-for + would do the wrong thing if we are supposed to do + menu prompting. If EVENT_HAS_PARAMETERS then we are reading + after a mouse event so don't try a minibuf menu. */ + c = Qnil; + if (KEYMAPP (map) && INTERACTIVE + && !NILP (prev_event) && ! EVENT_HAS_PARAMETERS (prev_event) + /* Don't bring up a menu if we already have another event. */ + && NILP (Vunread_command_events) + && !detect_input_pending_run_timers (0)) + { + c = read_char_minibuf_menu_prompt (commandflag, map); + + if (INTEGERP (c) && XINT (c) == -2) + return c; /* wrong_kboard_jmpbuf */ + + if (! NILP (c)) + goto exit; + } + + /* Make a longjmp point for quits to use, but don't alter getcjmp just yet. + We will do that below, temporarily for short sections of code, + when appropriate. local_getcjmp must be in effect + around any call to sit_for or kbd_buffer_get_event; + it *must not* be in effect when we call redisplay. */ + + jmpcount = SPECPDL_INDEX (); + if (sys_setjmp (local_getcjmp)) + { + /* Handle quits while reading the keyboard. */ + /* We must have saved the outer value of getcjmp here, + so restore it now. */ + restore_getcjmp (save_jump); + pthread_sigmask (SIG_SETMASK, &empty_mask, 0); + unbind_to (jmpcount, Qnil); + XSETINT (c, quit_char); + internal_last_event_frame = selected_frame; + Vlast_event_frame = internal_last_event_frame; + /* If we report the quit char as an event, + don't do so more than once. */ + if (!NILP (Vinhibit_quit)) + Vquit_flag = Qnil; + + { + KBOARD *kb = FRAME_KBOARD (XFRAME (selected_frame)); + if (kb != current_kboard) + { + Lisp_Object last = KVAR (kb, kbd_queue); + /* We shouldn't get here if we were in single-kboard mode! */ + if (single_kboard) + emacs_abort (); + if (CONSP (last)) + { + while (CONSP (XCDR (last))) + last = XCDR (last); + if (!NILP (XCDR (last))) + emacs_abort (); + } + if (!CONSP (last)) + kset_kbd_queue (kb, list1 (c)); + else + XSETCDR (last, list1 (c)); + kb->kbd_queue_has_data = 1; + current_kboard = kb; + /* This is going to exit from read_char + so we had better get rid of this frame's stuff. */ + UNGCPRO; + return make_number (-2); /* wrong_kboard_jmpbuf */ + } + } + goto non_reread; + } + + /* Start idle timers if no time limit is supplied. We don't do it + if a time limit is supplied to avoid an infinite recursion in the + situation where an idle timer calls `sit-for'. */ + + if (!end_time) + timer_start_idle (); + + /* If in middle of key sequence and minibuffer not active, + start echoing if enough time elapses. */ + + if (minibuf_level == 0 + && !end_time + && !current_kboard->immediate_echo + && this_command_key_count > 0 + && ! noninteractive + && echo_keystrokes_p () + && (/* No message. */ + NILP (echo_area_buffer[0]) + /* Or empty message. */ + || (BUF_BEG (XBUFFER (echo_area_buffer[0])) + == BUF_Z (XBUFFER (echo_area_buffer[0]))) + /* Or already echoing from same kboard. */ + || (echo_kboard && ok_to_echo_at_next_pause == echo_kboard) + /* Or not echoing before and echoing allowed. */ + || (!echo_kboard && ok_to_echo_at_next_pause))) + { + /* After a mouse event, start echoing right away. + This is because we are probably about to display a menu, + and we don't want to delay before doing so. */ + if (EVENT_HAS_PARAMETERS (prev_event)) + echo_now (); + else + { + Lisp_Object tem0; + + save_getcjmp (save_jump); + restore_getcjmp (local_getcjmp); + tem0 = sit_for (Vecho_keystrokes, 1, 1); + restore_getcjmp (save_jump); + if (EQ (tem0, Qt) + && ! CONSP (Vunread_command_events)) + echo_now (); + } + } + + /* Maybe auto save due to number of keystrokes. */ + + if (commandflag != 0 && commandflag != -2 + && auto_save_interval > 0 + && num_nonmacro_input_events - last_auto_save > max (auto_save_interval, 20) + && !detect_input_pending_run_timers (0)) + { + Fdo_auto_save (Qnil, Qnil); + /* Hooks can actually change some buffers in auto save. */ + redisplay (); + } + + /* Try reading using an X menu. + This is never confused with reading using the minibuf + because the recursive call of read_char in read_char_minibuf_menu_prompt + does not pass on any keymaps. */ + + if (KEYMAPP (map) && INTERACTIVE + && !NILP (prev_event) + && EVENT_HAS_PARAMETERS (prev_event) + && !EQ (XCAR (prev_event), Qmenu_bar) + && !EQ (XCAR (prev_event), Qtool_bar) + /* Don't bring up a menu if we already have another event. */ + && NILP (Vunread_command_events)) + { + c = read_char_x_menu_prompt (map, prev_event, used_mouse_menu); + + /* Now that we have read an event, Emacs is not idle. */ + if (!end_time) + timer_stop_idle (); + + goto exit; + } + + /* Maybe autosave and/or garbage collect due to idleness. */ + + if (INTERACTIVE && NILP (c)) + { + int delay_level; + ptrdiff_t buffer_size; + + /* Slow down auto saves logarithmically in size of current buffer, + and garbage collect while we're at it. */ + if (! MINI_WINDOW_P (XWINDOW (selected_window))) + last_non_minibuf_size = Z - BEG; + buffer_size = (last_non_minibuf_size >> 8) + 1; + delay_level = 0; + while (buffer_size > 64) + delay_level++, buffer_size -= buffer_size >> 2; + if (delay_level < 4) delay_level = 4; + /* delay_level is 4 for files under around 50k, 7 at 100k, + 9 at 200k, 11 at 300k, and 12 at 500k. It is 15 at 1 meg. */ + + /* Auto save if enough time goes by without input. */ + if (commandflag != 0 && commandflag != -2 + && num_nonmacro_input_events > last_auto_save + && INTEGERP (Vauto_save_timeout) + && XINT (Vauto_save_timeout) > 0) + { + Lisp_Object tem0; + EMACS_INT timeout = XFASTINT (Vauto_save_timeout); + + timeout = min (timeout, MOST_POSITIVE_FIXNUM / delay_level * 4); + timeout = delay_level * timeout / 4; + save_getcjmp (save_jump); + restore_getcjmp (local_getcjmp); + tem0 = sit_for (make_number (timeout), 1, 1); + restore_getcjmp (save_jump); + + if (EQ (tem0, Qt) + && ! CONSP (Vunread_command_events)) + { + Fdo_auto_save (Qnil, Qnil); + redisplay (); + } + } + + /* If there is still no input available, ask for GC. */ + if (!detect_input_pending_run_timers (0)) + maybe_gc (); + } + + /* Notify the caller if an autosave hook, or a timer, sentinel or + filter in the sit_for calls above have changed the current + kboard. This could happen if they use the minibuffer or start a + recursive edit, like the fancy splash screen in server.el's + filter. If this longjmp wasn't here, read_key_sequence would + interpret the next key sequence using the wrong translation + tables and function keymaps. */ + if (NILP (c) && current_kboard != orig_kboard) + { + UNGCPRO; + return make_number (-2); /* wrong_kboard_jmpbuf */ + } + + /* If this has become non-nil here, it has been set by a timer + or sentinel or filter. */ + if (CONSP (Vunread_command_events)) + { + c = XCAR (Vunread_command_events); + Vunread_command_events = XCDR (Vunread_command_events); + + if (CONSP (c) && EQ (XCAR (c), Qt)) + c = XCDR (c); + else + reread = true; + } + + /* Read something from current KBOARD's side queue, if possible. */ + + if (NILP (c)) + { + if (current_kboard->kbd_queue_has_data) + { + if (!CONSP (KVAR (current_kboard, kbd_queue))) + emacs_abort (); + c = XCAR (KVAR (current_kboard, kbd_queue)); + kset_kbd_queue (current_kboard, + XCDR (KVAR (current_kboard, kbd_queue))); + if (NILP (KVAR (current_kboard, kbd_queue))) + current_kboard->kbd_queue_has_data = 0; + input_pending = readable_events (0); + if (EVENT_HAS_PARAMETERS (c) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qswitch_frame)) + internal_last_event_frame = XCAR (XCDR (c)); + Vlast_event_frame = internal_last_event_frame; + } + } + + /* If current_kboard's side queue is empty check the other kboards. + If one of them has data that we have not yet seen here, + switch to it and process the data waiting for it. + + Note: if the events queued up for another kboard + have already been seen here, and therefore are not a complete command, + the kbd_queue_has_data field is 0, so we skip that kboard here. + That's to avoid an infinite loop switching between kboards here. */ + if (NILP (c) && !single_kboard) + { + KBOARD *kb; + for (kb = all_kboards; kb; kb = kb->next_kboard) + if (kb->kbd_queue_has_data) + { + current_kboard = kb; + /* This is going to exit from read_char + so we had better get rid of this frame's stuff. */ + UNGCPRO; + return make_number (-2); /* wrong_kboard_jmpbuf */ + } + } + + wrong_kboard: + + STOP_POLLING; + + if (NILP (c)) + { + c = read_decoded_event_from_main_queue (end_time, local_getcjmp, + prev_event, used_mouse_menu); + if (NILP (c) && end_time + && timespec_cmp (*end_time, current_timespec ()) <= 0) + { + goto exit; + } + + if (EQ (c, make_number (-2))) + { + /* This is going to exit from read_char + so we had better get rid of this frame's stuff. */ + UNGCPRO; + return c; + } + } + + non_reread: + + if (!end_time) + timer_stop_idle (); + RESUME_POLLING; + + if (NILP (c)) + { + if (commandflag >= 0 + && !input_pending && !detect_input_pending_run_timers (0)) + redisplay (); + + goto wrong_kboard; + } + + /* Buffer switch events are only for internal wakeups + so don't show them to the user. + Also, don't record a key if we already did. */ + if (BUFFERP (c)) + goto exit; + + /* Process special events within read_char + and loop around to read another event. */ + save = Vquit_flag; + Vquit_flag = Qnil; + tem = access_keymap (get_keymap (Vspecial_event_map, 0, 1), c, 0, 0, 1); + Vquit_flag = save; + + if (!NILP (tem)) + { + struct buffer *prev_buffer = current_buffer; + last_input_event = c; + call4 (Qcommand_execute, tem, Qnil, Fvector (1, &last_input_event), Qt); + + if (CONSP (c) && EQ (XCAR (c), Qselect_window) && !end_time) + /* We stopped being idle for this event; undo that. This + prevents automatic window selection (under + mouse_autoselect_window from acting as a real input event, for + example banishing the mouse under mouse-avoidance-mode. */ + timer_resume_idle (); + + if (current_buffer != prev_buffer) + { + /* The command may have changed the keymaps. Pretend there + is input in another keyboard and return. This will + recalculate keymaps. */ + c = make_number (-2); + goto exit; + } + else + goto retry; + } + + /* Handle things that only apply to characters. */ + if (INTEGERP (c)) + { + /* If kbd_buffer_get_event gave us an EOF, return that. */ + if (XINT (c) == -1) + goto exit; + + if ((STRINGP (KVAR (current_kboard, Vkeyboard_translate_table)) + && UNSIGNED_CMP (XFASTINT (c), <, + SCHARS (KVAR (current_kboard, + Vkeyboard_translate_table)))) + || (VECTORP (KVAR (current_kboard, Vkeyboard_translate_table)) + && UNSIGNED_CMP (XFASTINT (c), <, + ASIZE (KVAR (current_kboard, + Vkeyboard_translate_table)))) + || (CHAR_TABLE_P (KVAR (current_kboard, Vkeyboard_translate_table)) + && CHARACTERP (c))) + { + Lisp_Object d; + d = Faref (KVAR (current_kboard, Vkeyboard_translate_table), c); + /* nil in keyboard-translate-table means no translation. */ + if (!NILP (d)) + c = d; + } + } + + /* If this event is a mouse click in the menu bar, + return just menu-bar for now. Modify the mouse click event + so we won't do this twice, then queue it up. */ + if (EVENT_HAS_PARAMETERS (c) + && CONSP (XCDR (c)) + && CONSP (EVENT_START (c)) + && CONSP (XCDR (EVENT_START (c)))) + { + Lisp_Object posn; + + posn = POSN_POSN (EVENT_START (c)); + /* Handle menu-bar events: + insert the dummy prefix event `menu-bar'. */ + if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar)) + { + /* Change menu-bar to (menu-bar) as the event "position". */ + POSN_SET_POSN (EVENT_START (c), list1 (posn)); + + also_record = c; + Vunread_command_events = Fcons (c, Vunread_command_events); + c = posn; + } + } + + /* Store these characters into recent_keys, the dribble file if any, + and the keyboard macro being defined, if any. */ + record_char (c); + if (! NILP (also_record)) + record_char (also_record); + + /* Wipe the echo area. + But first, if we are about to use an input method, + save the echo area contents for it to refer to. */ + if (INTEGERP (c) + && ! NILP (Vinput_method_function) + && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127) + { + previous_echo_area_message = Fcurrent_message (); + Vinput_method_previous_message = previous_echo_area_message; + } + + /* Now wipe the echo area, except for help events which do their + own stuff with the echo area. */ + if (!CONSP (c) + || (!(EQ (Qhelp_echo, XCAR (c))) + && !(EQ (Qswitch_frame, XCAR (c))) + /* Don't wipe echo area for select window events: These might + get delayed via `mouse-autoselect-window' (Bug#11304). */ + && !(EQ (Qselect_window, XCAR (c))))) + { + if (!NILP (echo_area_buffer[0])) + { + safe_run_hooks (Qecho_area_clear_hook); + clear_message (1, 0); + } + } + + reread_for_input_method: + from_macro: + /* Pass this to the input method, if appropriate. */ + if (INTEGERP (c) + && ! NILP (Vinput_method_function) + /* Don't run the input method within a key sequence, + after the first event of the key sequence. */ + && NILP (prev_event) + && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127) + { + Lisp_Object keys; + ptrdiff_t key_count; + bool key_count_reset; + ptrdiff_t command_key_start; + struct gcpro gcpro1; + ptrdiff_t count = SPECPDL_INDEX (); + + /* Save the echo status. */ + bool saved_immediate_echo = current_kboard->immediate_echo; + struct kboard *saved_ok_to_echo = ok_to_echo_at_next_pause; + Lisp_Object saved_echo_string = KVAR (current_kboard, echo_string); + ptrdiff_t saved_echo_after_prompt = current_kboard->echo_after_prompt; + +#if 0 + if (before_command_restore_flag) + { + this_command_key_count = before_command_key_count_1; + if (this_command_key_count < this_single_command_key_start) + this_single_command_key_start = this_command_key_count; + echo_truncate (before_command_echo_length_1); + before_command_restore_flag = 0; + } +#endif + + /* Save the this_command_keys status. */ + key_count = this_command_key_count; + key_count_reset = this_command_key_count_reset; + command_key_start = this_single_command_key_start; + + if (key_count > 0) + keys = Fcopy_sequence (this_command_keys); + else + keys = Qnil; + GCPRO1 (keys); + + /* Clear out this_command_keys. */ + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + + /* Now wipe the echo area. */ + if (!NILP (echo_area_buffer[0])) + safe_run_hooks (Qecho_area_clear_hook); + clear_message (1, 0); + echo_truncate (0); + + /* If we are not reading a key sequence, + never use the echo area. */ + if (!KEYMAPP (map)) + { + specbind (Qinput_method_use_echo_area, Qt); + } + + /* Call the input method. */ + tem = call1 (Vinput_method_function, c); + + tem = unbind_to (count, tem); + + /* Restore the saved echoing state + and this_command_keys state. */ + this_command_key_count = key_count; + this_command_key_count_reset = key_count_reset; + this_single_command_key_start = command_key_start; + if (key_count > 0) + this_command_keys = keys; + + cancel_echoing (); + ok_to_echo_at_next_pause = saved_ok_to_echo; + /* Do not restore the echo area string when the user is + introducing a prefix argument. Otherwise we end with + repetitions of the partially introduced prefix + argument. (bug#19875) */ + if (NILP (intern ("prefix-arg"))) + { + kset_echo_string (current_kboard, saved_echo_string); + } + current_kboard->echo_after_prompt = saved_echo_after_prompt; + if (saved_immediate_echo) + echo_now (); + + UNGCPRO; + + /* The input method can return no events. */ + if (! CONSP (tem)) + { + /* Bring back the previous message, if any. */ + if (! NILP (previous_echo_area_message)) + message_with_string ("%s", previous_echo_area_message, 0); + goto retry; + } + /* It returned one event or more. */ + c = XCAR (tem); + Vunread_post_input_method_events + = nconc2 (XCDR (tem), Vunread_post_input_method_events); + } + + reread_first: + + /* Display help if not echoing. */ + if (CONSP (c) && EQ (XCAR (c), Qhelp_echo)) + { + /* (help-echo FRAME HELP WINDOW OBJECT POS). */ + Lisp_Object help, object, position, window, htem; + + htem = Fcdr (XCDR (c)); + help = Fcar (htem); + htem = Fcdr (htem); + window = Fcar (htem); + htem = Fcdr (htem); + object = Fcar (htem); + htem = Fcdr (htem); + position = Fcar (htem); + + show_help_echo (help, window, object, position); + + /* We stopped being idle for this event; undo that. */ + if (!end_time) + timer_resume_idle (); + goto retry; + } + + if ((! reread || this_command_key_count == 0 + || this_command_key_count_reset) + && !end_time) + { + + /* Don't echo mouse motion events. */ + if (echo_keystrokes_p () + && ! (EVENT_HAS_PARAMETERS (c) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_movement))) + { + echo_char (c); + if (! NILP (also_record)) + echo_char (also_record); + /* Once we reread a character, echoing can happen + the next time we pause to read a new one. */ + ok_to_echo_at_next_pause = current_kboard; + } + + /* Record this character as part of the current key. */ + add_command_key (c); + if (! NILP (also_record)) + add_command_key (also_record); + } + + last_input_event = c; + num_input_events++; + + /* Process the help character specially if enabled. */ + if (!NILP (Vhelp_form) && help_char_p (c)) + { + ptrdiff_t count = SPECPDL_INDEX (); + + help_form_saved_window_configs + = Fcons (Fcurrent_window_configuration (Qnil), + help_form_saved_window_configs); + record_unwind_protect_void (read_char_help_form_unwind); + call0 (Qhelp_form_show); + + cancel_echoing (); + do + { + c = read_char (0, Qnil, Qnil, 0, NULL); + if (EVENT_HAS_PARAMETERS (c) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_click)) + XSETCAR (help_form_saved_window_configs, Qnil); + } + while (BUFFERP (c)); + /* Remove the help from the frame. */ + unbind_to (count, Qnil); + + redisplay (); + if (EQ (c, make_number (040))) + { + cancel_echoing (); + do + c = read_char (0, Qnil, Qnil, 0, NULL); + while (BUFFERP (c)); + } + } + + exit: + RESUME_POLLING; + input_was_pending = input_pending; + RETURN_UNGCPRO (c); +} + +/* Record a key that came from a mouse menu. + Record it for echoing, for this-command-keys, and so on. */ + +static void +record_menu_key (Lisp_Object c) +{ + /* Wipe the echo area. */ + clear_message (1, 0); + + record_char (c); + +#if 0 + before_command_key_count = this_command_key_count; + before_command_echo_length = echo_length (); +#endif + + /* Don't echo mouse motion events. */ + if (echo_keystrokes_p ()) + { + echo_char (c); + + /* Once we reread a character, echoing can happen + the next time we pause to read a new one. */ + ok_to_echo_at_next_pause = 0; + } + + /* Record this character as part of the current key. */ + add_command_key (c); + + /* Re-reading in the middle of a command. */ + last_input_event = c; + num_input_events++; +} + +/* Return true if should recognize C as "the help character". */ + +static bool +help_char_p (Lisp_Object c) +{ + Lisp_Object tail; + + if (EQ (c, Vhelp_char)) + return 1; + for (tail = Vhelp_event_list; CONSP (tail); tail = XCDR (tail)) + if (EQ (c, XCAR (tail))) + return 1; + return 0; +} + +/* Record the input event C in various ways. */ + +static void +record_char (Lisp_Object c) +{ + int recorded = 0; + + if (CONSP (c) && (EQ (XCAR (c), Qhelp_echo) || EQ (XCAR (c), Qmouse_movement))) + { + /* To avoid filling recent_keys with help-echo and mouse-movement + events, we filter out repeated help-echo events, only store the + first and last in a series of mouse-movement events, and don't + store repeated help-echo events which are only separated by + mouse-movement events. */ + + Lisp_Object ev1, ev2, ev3; + int ix1, ix2, ix3; + + if ((ix1 = recent_keys_index - 1) < 0) + ix1 = NUM_RECENT_KEYS - 1; + ev1 = AREF (recent_keys, ix1); + + if ((ix2 = ix1 - 1) < 0) + ix2 = NUM_RECENT_KEYS - 1; + ev2 = AREF (recent_keys, ix2); + + if ((ix3 = ix2 - 1) < 0) + ix3 = NUM_RECENT_KEYS - 1; + ev3 = AREF (recent_keys, ix3); + + if (EQ (XCAR (c), Qhelp_echo)) + { + /* Don't record `help-echo' in recent_keys unless it shows some help + message, and a different help than the previously recorded + event. */ + Lisp_Object help, last_help; + + help = Fcar_safe (Fcdr_safe (XCDR (c))); + if (!STRINGP (help)) + recorded = 1; + else if (CONSP (ev1) && EQ (XCAR (ev1), Qhelp_echo) + && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev1))), EQ (last_help, help))) + recorded = 1; + else if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement) + && CONSP (ev2) && EQ (XCAR (ev2), Qhelp_echo) + && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev2))), EQ (last_help, help))) + recorded = -1; + else if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement) + && CONSP (ev2) && EQ (XCAR (ev2), Qmouse_movement) + && CONSP (ev3) && EQ (XCAR (ev3), Qhelp_echo) + && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev3))), EQ (last_help, help))) + recorded = -2; + } + else if (EQ (XCAR (c), Qmouse_movement)) + { + /* Only record one pair of `mouse-movement' on a window in recent_keys. + So additional mouse movement events replace the last element. */ + Lisp_Object last_window, window; + + window = Fcar_safe (Fcar_safe (XCDR (c))); + if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement) + && (last_window = Fcar_safe (Fcar_safe (XCDR (ev1))), EQ (last_window, window)) + && CONSP (ev2) && EQ (XCAR (ev2), Qmouse_movement) + && (last_window = Fcar_safe (Fcar_safe (XCDR (ev2))), EQ (last_window, window))) + { + ASET (recent_keys, ix1, c); + recorded = 1; + } + } + } + else + store_kbd_macro_char (c); + + if (!recorded) + { + total_keys += total_keys < NUM_RECENT_KEYS; + ASET (recent_keys, recent_keys_index, c); + if (++recent_keys_index >= NUM_RECENT_KEYS) + recent_keys_index = 0; + } + else if (recorded < 0) + { + /* We need to remove one or two events from recent_keys. + To do this, we simply put nil at those events and move the + recent_keys_index backwards over those events. Usually, + users will never see those nil events, as they will be + overwritten by the command keys entered to see recent_keys + (e.g. C-h l). */ + + while (recorded++ < 0 && total_keys > 0) + { + if (total_keys < NUM_RECENT_KEYS) + total_keys--; + if (--recent_keys_index < 0) + recent_keys_index = NUM_RECENT_KEYS - 1; + ASET (recent_keys, recent_keys_index, Qnil); + } + } + + num_nonmacro_input_events++; + + /* Write c to the dribble file. If c is a lispy event, write + the event's symbol to the dribble file, in <brackets>. Bleaugh. + If you, dear reader, have a better idea, you've got the source. :-) */ + if (dribble) + { + block_input (); + if (INTEGERP (c)) + { + if (XUINT (c) < 0x100) + putc (XUINT (c), dribble); + else + fprintf (dribble, " 0x%"pI"x", XUINT (c)); + } + else + { + Lisp_Object dribblee; + + /* If it's a structured event, take the event header. */ + dribblee = EVENT_HEAD (c); + + if (SYMBOLP (dribblee)) + { + putc ('<', dribble); + fwrite (SDATA (SYMBOL_NAME (dribblee)), sizeof (char), + SBYTES (SYMBOL_NAME (dribblee)), + dribble); + putc ('>', dribble); + } + } + + fflush (dribble); + unblock_input (); + } +} + +/* Copy out or in the info on where C-g should throw to. + This is used when running Lisp code from within get_char, + in case get_char is called recursively. + See read_process_output. */ + +static void +save_getcjmp (sys_jmp_buf temp) +{ + memcpy (temp, getcjmp, sizeof getcjmp); +} + +static void +restore_getcjmp (sys_jmp_buf temp) +{ + memcpy (getcjmp, temp, sizeof getcjmp); +} + +/* Low level keyboard/mouse input. + kbd_buffer_store_event places events in kbd_buffer, and + kbd_buffer_get_event retrieves them. */ + +/* Return true if there are any events in the queue that read-char + would return. If this returns false, a read-char would block. */ +static bool +readable_events (int flags) +{ + if (flags & READABLE_EVENTS_DO_TIMERS_NOW) + timer_check (); + + /* If the buffer contains only FOCUS_IN_EVENT events, and + READABLE_EVENTS_FILTER_EVENTS is set, report it as empty. */ + if (kbd_fetch_ptr != kbd_store_ptr) + { + if (flags & (READABLE_EVENTS_FILTER_EVENTS +#ifdef USE_TOOLKIT_SCROLL_BARS + | READABLE_EVENTS_IGNORE_SQUEEZABLES +#endif + )) + { + struct input_event *event; + + event = ((kbd_fetch_ptr < kbd_buffer + KBD_BUFFER_SIZE) + ? kbd_fetch_ptr + : kbd_buffer); + + do + { + if (!( +#ifdef USE_TOOLKIT_SCROLL_BARS + (flags & READABLE_EVENTS_FILTER_EVENTS) && +#endif + event->kind == FOCUS_IN_EVENT) +#ifdef USE_TOOLKIT_SCROLL_BARS + && !((flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) + && (event->kind == SCROLL_BAR_CLICK_EVENT + || event->kind == HORIZONTAL_SCROLL_BAR_CLICK_EVENT) + && event->part == scroll_bar_handle + && event->modifiers == 0) +#endif + && !((flags & READABLE_EVENTS_FILTER_EVENTS) + && event->kind == BUFFER_SWITCH_EVENT)) + return 1; + event++; + if (event == kbd_buffer + KBD_BUFFER_SIZE) + event = kbd_buffer; + } + while (event != kbd_store_ptr); + } + else + return 1; + } + + if (!(flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) + && !NILP (do_mouse_tracking) && some_mouse_moved ()) + return 1; + if (single_kboard) + { + if (current_kboard->kbd_queue_has_data) + return 1; + } + else + { + KBOARD *kb; + for (kb = all_kboards; kb; kb = kb->next_kboard) + if (kb->kbd_queue_has_data) + return 1; + } + return 0; +} + +/* Set this for debugging, to have a way to get out */ +int stop_character EXTERNALLY_VISIBLE; + +static KBOARD * +event_to_kboard (struct input_event *event) +{ + /* Not applicable for these special events. */ + if (event->kind == SELECTION_REQUEST_EVENT + || event->kind == SELECTION_CLEAR_EVENT) + return NULL; + else + { + Lisp_Object obj = event->frame_or_window; + /* There are some events that set this field to nil or string. */ + if (WINDOWP (obj)) + obj = WINDOW_FRAME (XWINDOW (obj)); + /* Also ignore dead frames here. */ + return ((FRAMEP (obj) && FRAME_LIVE_P (XFRAME (obj))) + ? FRAME_KBOARD (XFRAME (obj)) : NULL); + } +} + +#ifdef subprocesses +/* Return the number of slots occupied in kbd_buffer. */ + +static int +kbd_buffer_nr_stored (void) +{ + return kbd_fetch_ptr == kbd_store_ptr + ? 0 + : (kbd_fetch_ptr < kbd_store_ptr + ? kbd_store_ptr - kbd_fetch_ptr + : ((kbd_buffer + KBD_BUFFER_SIZE) - kbd_fetch_ptr + + (kbd_store_ptr - kbd_buffer))); +} +#endif /* Store an event obtained at interrupt level into kbd_buffer, fifo */ + +void +kbd_buffer_store_event (register struct input_event *event) +{ + kbd_buffer_store_event_hold (event, 0); +} + +/* Store EVENT obtained at interrupt level into kbd_buffer, fifo. + + If HOLD_QUIT is 0, just stuff EVENT into the fifo. + Else, if HOLD_QUIT.kind != NO_EVENT, discard EVENT. + Else, if EVENT is a quit event, store the quit event + in HOLD_QUIT, and return (thus ignoring further events). + + This is used to postpone the processing of the quit event until all + subsequent input events have been parsed (and discarded). */ + +void +kbd_buffer_store_event_hold (register struct input_event *event, + struct input_event *hold_quit) +{ + if (event->kind == NO_EVENT) + emacs_abort (); + + if (hold_quit && hold_quit->kind != NO_EVENT) + return; + + if (event->kind == ASCII_KEYSTROKE_EVENT) + { + register int c = event->code & 0377; + + if (event->modifiers & ctrl_modifier) + c = make_ctrl_char (c); + + c |= (event->modifiers + & (meta_modifier | alt_modifier + | hyper_modifier | super_modifier)); + + if (c == quit_char) + { + KBOARD *kb = FRAME_KBOARD (XFRAME (event->frame_or_window)); + struct input_event *sp; + + if (single_kboard && kb != current_kboard) + { + kset_kbd_queue + (kb, list2 (make_lispy_switch_frame (event->frame_or_window), + make_number (c))); + kb->kbd_queue_has_data = 1; + for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++) + { + if (sp == kbd_buffer + KBD_BUFFER_SIZE) + sp = kbd_buffer; + + if (event_to_kboard (sp) == kb) + { + sp->kind = NO_EVENT; + sp->frame_or_window = Qnil; + sp->arg = Qnil; + } + } + return; + } + + if (hold_quit) + { + *hold_quit = *event; + return; + } + + /* If this results in a quit_char being returned to Emacs as + input, set Vlast_event_frame properly. If this doesn't + get returned to Emacs as an event, the next event read + will set Vlast_event_frame again, so this is safe to do. */ + { + Lisp_Object focus; + + focus = FRAME_FOCUS_FRAME (XFRAME (event->frame_or_window)); + if (NILP (focus)) + focus = event->frame_or_window; + internal_last_event_frame = focus; + Vlast_event_frame = focus; + } + + handle_interrupt (0); + return; + } + + if (c && c == stop_character) + { + sys_suspend (); + return; + } + } + /* Don't insert two BUFFER_SWITCH_EVENT's in a row. + Just ignore the second one. */ + else if (event->kind == BUFFER_SWITCH_EVENT + && kbd_fetch_ptr != kbd_store_ptr + && ((kbd_store_ptr == kbd_buffer + ? kbd_buffer + KBD_BUFFER_SIZE - 1 + : kbd_store_ptr - 1)->kind) == BUFFER_SWITCH_EVENT) + return; + + if (kbd_store_ptr - kbd_buffer == KBD_BUFFER_SIZE) + kbd_store_ptr = kbd_buffer; + + /* Don't let the very last slot in the buffer become full, + since that would make the two pointers equal, + and that is indistinguishable from an empty buffer. + Discard the event if it would fill the last slot. */ + if (kbd_fetch_ptr - 1 != kbd_store_ptr) + { + *kbd_store_ptr = *event; + ++kbd_store_ptr; +#ifdef subprocesses + if (kbd_buffer_nr_stored () > KBD_BUFFER_SIZE / 2 + && ! kbd_on_hold_p ()) + { + /* Don't read keyboard input until we have processed kbd_buffer. + This happens when pasting text longer than KBD_BUFFER_SIZE/2. */ + hold_keyboard_input (); + if (!noninteractive) + ignore_sigio (); + stop_polling (); + } +#endif /* subprocesses */ + } + + /* If we're inside while-no-input, and this event qualifies + as input, set quit-flag to cause an interrupt. */ + if (!NILP (Vthrow_on_input) + && event->kind != FOCUS_IN_EVENT + && event->kind != FOCUS_OUT_EVENT + && event->kind != HELP_EVENT + && event->kind != ICONIFY_EVENT + && event->kind != DEICONIFY_EVENT) + { + Vquit_flag = Vthrow_on_input; + /* If we're inside a function that wants immediate quits, + do it now. */ + if (immediate_quit && NILP (Vinhibit_quit)) + { + immediate_quit = 0; + QUIT; + } + } +} + + +/* Put an input event back in the head of the event queue. */ + +void +kbd_buffer_unget_event (register struct input_event *event) +{ + if (kbd_fetch_ptr == kbd_buffer) + kbd_fetch_ptr = kbd_buffer + KBD_BUFFER_SIZE; + + /* Don't let the very last slot in the buffer become full, */ + if (kbd_fetch_ptr - 1 != kbd_store_ptr) + { + --kbd_fetch_ptr; + *kbd_fetch_ptr = *event; + } +} + +/* Limit help event positions to this range, to avoid overflow problems. */ +#define INPUT_EVENT_POS_MAX \ + ((ptrdiff_t) min (PTRDIFF_MAX, min (TYPE_MAXIMUM (Time) / 2, \ + MOST_POSITIVE_FIXNUM))) +#define INPUT_EVENT_POS_MIN (-1 - INPUT_EVENT_POS_MAX) + +/* Return a Time that encodes position POS. POS must be in range. */ + +static Time +position_to_Time (ptrdiff_t pos) +{ + eassert (INPUT_EVENT_POS_MIN <= pos && pos <= INPUT_EVENT_POS_MAX); + return pos; +} + +/* Return the position that ENCODED_POS encodes. + Avoid signed integer overflow. */ + +static ptrdiff_t +Time_to_position (Time encoded_pos) +{ + if (encoded_pos <= INPUT_EVENT_POS_MAX) + return encoded_pos; + Time encoded_pos_min = INPUT_EVENT_POS_MIN; + eassert (encoded_pos_min <= encoded_pos); + ptrdiff_t notpos = -1 - encoded_pos; + return -1 - notpos; +} + +/* Generate a HELP_EVENT input_event and store it in the keyboard + buffer. + + HELP is the help form. + + FRAME and WINDOW are the frame and window where the help is + generated. OBJECT is the Lisp object where the help was found (a + buffer, a string, an overlay, or nil if neither from a string nor + from a buffer). POS is the position within OBJECT where the help + was found. */ + +void +gen_help_event (Lisp_Object help, Lisp_Object frame, Lisp_Object window, + Lisp_Object object, ptrdiff_t pos) +{ + struct input_event event; + + event.kind = HELP_EVENT; + event.frame_or_window = frame; + event.arg = object; + event.x = WINDOWP (window) ? window : frame; + event.y = help; + event.timestamp = position_to_Time (pos); + kbd_buffer_store_event (&event); +} + + +/* Store HELP_EVENTs for HELP on FRAME in the input queue. */ + +void +kbd_buffer_store_help_event (Lisp_Object frame, Lisp_Object help) +{ + struct input_event event; + + event.kind = HELP_EVENT; + event.frame_or_window = frame; + event.arg = Qnil; + event.x = Qnil; + event.y = help; + event.timestamp = 0; + kbd_buffer_store_event (&event); +} + + +/* Discard any mouse events in the event buffer by setting them to + NO_EVENT. */ +void +discard_mouse_events (void) +{ + struct input_event *sp; + for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++) + { + if (sp == kbd_buffer + KBD_BUFFER_SIZE) + sp = kbd_buffer; + + if (sp->kind == MOUSE_CLICK_EVENT + || sp->kind == WHEEL_EVENT + || sp->kind == HORIZ_WHEEL_EVENT +#ifdef HAVE_GPM + || sp->kind == GPM_CLICK_EVENT +#endif + || sp->kind == SCROLL_BAR_CLICK_EVENT + || sp->kind == HORIZONTAL_SCROLL_BAR_CLICK_EVENT) + { + sp->kind = NO_EVENT; + } + } +} + + +/* Return true if there are any real events waiting in the event + buffer, not counting `NO_EVENT's. + + Discard NO_EVENT events at the front of the input queue, possibly + leaving the input queue empty if there are no real input events. */ + +bool +kbd_buffer_events_waiting (void) +{ + struct input_event *sp; + + for (sp = kbd_fetch_ptr; + sp != kbd_store_ptr && sp->kind == NO_EVENT; + ++sp) + { + if (sp == kbd_buffer + KBD_BUFFER_SIZE) + sp = kbd_buffer; + } + + kbd_fetch_ptr = sp; + return sp != kbd_store_ptr && sp->kind != NO_EVENT; +} + + +/* Clear input event EVENT. */ + +static void +clear_event (struct input_event *event) +{ + event->kind = NO_EVENT; +} + + +/* Read one event from the event buffer, waiting if necessary. + The value is a Lisp object representing the event. + The value is nil for an event that should be ignored, + or that was handled here. + We always read and discard one event. */ + +static Lisp_Object +kbd_buffer_get_event (KBOARD **kbp, + bool *used_mouse_menu, + struct timespec *end_time) +{ + Lisp_Object obj; + +#ifdef subprocesses + if (kbd_on_hold_p () && kbd_buffer_nr_stored () < KBD_BUFFER_SIZE / 4) + { + /* Start reading input again because we have processed enough to + be able to accept new events again. */ + unhold_keyboard_input (); + start_polling (); + } +#endif /* subprocesses */ + +#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY + if (noninteractive + /* In case we are running as a daemon, only do this before + detaching from the terminal. */ + || (IS_DAEMON && DAEMON_RUNNING)) + { + int c = getchar (); + XSETINT (obj, c); + *kbp = current_kboard; + return obj; + } +#endif /* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY */ + + /* Wait until there is input available. */ + for (;;) + { + /* Break loop if there's an unread command event. Needed in + moused window autoselection which uses a timer to insert such + events. */ + if (CONSP (Vunread_command_events)) + break; + + if (kbd_fetch_ptr != kbd_store_ptr) + break; + if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + break; + + /* If the quit flag is set, then read_char will return + quit_char, so that counts as "available input." */ + if (!NILP (Vquit_flag)) + quit_throw_to_read_char (0); + + /* One way or another, wait until input is available; then, if + interrupt handlers have not read it, read it now. */ + +#ifdef USABLE_SIGIO + gobble_input (); +#endif + if (kbd_fetch_ptr != kbd_store_ptr) + break; + if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + break; + if (end_time) + { + struct timespec now = current_timespec (); + if (timespec_cmp (*end_time, now) <= 0) + return Qnil; /* Finished waiting. */ + else + { + struct timespec duration = timespec_sub (*end_time, now); + wait_reading_process_output (min (duration.tv_sec, + WAIT_READING_MAX), + duration.tv_nsec, + -1, 1, Qnil, NULL, 0); + } + } + else + { + bool do_display = true; + + if (FRAME_TERMCAP_P (SELECTED_FRAME ())) + { + struct tty_display_info *tty = CURTTY (); + + /* When this TTY is displaying a menu, we must prevent + any redisplay, because we modify the frame's glyph + matrix behind the back of the display engine. */ + if (tty->showing_menu) + do_display = false; + } + + wait_reading_process_output (0, 0, -1, do_display, Qnil, NULL, 0); + } + + if (!interrupt_input && kbd_fetch_ptr == kbd_store_ptr) + gobble_input (); + } + + if (CONSP (Vunread_command_events)) + { + Lisp_Object first; + first = XCAR (Vunread_command_events); + Vunread_command_events = XCDR (Vunread_command_events); + *kbp = current_kboard; + return first; + } + + /* At this point, we know that there is a readable event available + somewhere. If the event queue is empty, then there must be a + mouse movement enabled and available. */ + if (kbd_fetch_ptr != kbd_store_ptr) + { + struct input_event *event; + + event = ((kbd_fetch_ptr < kbd_buffer + KBD_BUFFER_SIZE) + ? kbd_fetch_ptr + : kbd_buffer); + + *kbp = event_to_kboard (event); + if (*kbp == 0) + *kbp = current_kboard; /* Better than returning null ptr? */ + + obj = Qnil; + + /* These two kinds of events get special handling + and don't actually appear to the command loop. + We return nil for them. */ + if (event->kind == SELECTION_REQUEST_EVENT + || event->kind == SELECTION_CLEAR_EVENT) + { +#ifdef HAVE_X11 + struct input_event copy; + + /* Remove it from the buffer before processing it, + since otherwise swallow_events will see it + and process it again. */ + copy = *event; + kbd_fetch_ptr = event + 1; + input_pending = readable_events (0); + x_handle_selection_event (©); +#else + /* We're getting selection request events, but we don't have + a window system. */ + emacs_abort (); +#endif + } + +#if defined (HAVE_NS) + else if (event->kind == NS_TEXT_EVENT) + { + if (event->code == KEY_NS_PUT_WORKING_TEXT) + obj = list1 (intern ("ns-put-working-text")); + else + obj = list1 (intern ("ns-unput-working-text")); + kbd_fetch_ptr = event + 1; + if (used_mouse_menu) + *used_mouse_menu = 1; + } +#endif + +#if defined (HAVE_X11) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) + else if (event->kind == DELETE_WINDOW_EVENT) + { + /* Make an event (delete-frame (FRAME)). */ + obj = list2 (Qdelete_frame, list1 (event->frame_or_window)); + kbd_fetch_ptr = event + 1; + } +#endif +#if defined (HAVE_X11) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) + else if (event->kind == ICONIFY_EVENT) + { + /* Make an event (iconify-frame (FRAME)). */ + obj = list2 (Qiconify_frame, list1 (event->frame_or_window)); + kbd_fetch_ptr = event + 1; + } + else if (event->kind == DEICONIFY_EVENT) + { + /* Make an event (make-frame-visible (FRAME)). */ + obj = list2 (Qmake_frame_visible, list1 (event->frame_or_window)); + kbd_fetch_ptr = event + 1; + } +#endif + else if (event->kind == BUFFER_SWITCH_EVENT) + { + /* The value doesn't matter here; only the type is tested. */ + XSETBUFFER (obj, current_buffer); + kbd_fetch_ptr = event + 1; + } +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) || defined (USE_GTK) + else if (event->kind == MENU_BAR_ACTIVATE_EVENT) + { + kbd_fetch_ptr = event + 1; + input_pending = readable_events (0); + if (FRAME_LIVE_P (XFRAME (event->frame_or_window))) + x_activate_menubar (XFRAME (event->frame_or_window)); + } +#endif +#ifdef HAVE_NTGUI + else if (event->kind == LANGUAGE_CHANGE_EVENT) + { + /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID). */ + obj = list4 (Qlanguage_change, + event->frame_or_window, + make_number (event->code), + make_number (event->modifiers)); + kbd_fetch_ptr = event + 1; + } +#endif +#ifdef USE_FILE_NOTIFY + else if (event->kind == FILE_NOTIFY_EVENT) + { +#ifdef HAVE_W32NOTIFY + /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK). */ + obj = list3 (Qfile_notify, event->arg, event->frame_or_window); +#else + obj = make_lispy_event (event); +#endif + kbd_fetch_ptr = event + 1; + } +#endif /* USE_FILE_NOTIFY */ + else if (event->kind == SAVE_SESSION_EVENT) + { + obj = list2 (Qsave_session, event->arg); + kbd_fetch_ptr = event + 1; + } + /* Just discard these, by returning nil. + With MULTI_KBOARD, these events are used as placeholders + when we need to randomly delete events from the queue. + (They shouldn't otherwise be found in the buffer, + but on some machines it appears they do show up + even without MULTI_KBOARD.) */ + /* On Windows NT/9X, NO_EVENT is used to delete extraneous + mouse events during a popup-menu call. */ + else if (event->kind == NO_EVENT) + kbd_fetch_ptr = event + 1; + else if (event->kind == HELP_EVENT) + { + Lisp_Object object, position, help, frame, window; + + frame = event->frame_or_window; + object = event->arg; + position = make_number (Time_to_position (event->timestamp)); + window = event->x; + help = event->y; + clear_event (event); + + kbd_fetch_ptr = event + 1; + if (!WINDOWP (window)) + window = Qnil; + obj = Fcons (Qhelp_echo, + list5 (frame, help, window, object, position)); + } + else if (event->kind == FOCUS_IN_EVENT) + { + /* Notification of a FocusIn event. The frame receiving the + focus is in event->frame_or_window. Generate a + switch-frame event if necessary. */ + Lisp_Object frame, focus; + + frame = event->frame_or_window; + focus = FRAME_FOCUS_FRAME (XFRAME (frame)); + if (FRAMEP (focus)) + frame = focus; + + if ( +#ifdef HAVE_X11 + ! NILP (event->arg) + && +#endif + !EQ (frame, internal_last_event_frame) + && !EQ (frame, selected_frame)) + obj = make_lispy_switch_frame (frame); + else + obj = make_lispy_focus_in (frame); + + internal_last_event_frame = frame; + kbd_fetch_ptr = event + 1; + } + else if (event->kind == FOCUS_OUT_EVENT) + { +#ifdef HAVE_WINDOW_SYSTEM + + Display_Info *di; + Lisp_Object frame = event->frame_or_window; + bool focused = false; + + for (di = x_display_list; di && ! focused; di = di->next) + focused = di->x_highlight_frame != 0; + + if (!focused) + obj = make_lispy_focus_out (frame); + +#endif /* HAVE_WINDOW_SYSTEM */ + + kbd_fetch_ptr = event + 1; + } +#ifdef HAVE_DBUS + else if (event->kind == DBUS_EVENT) + { + obj = make_lispy_event (event); + kbd_fetch_ptr = event + 1; + } +#endif + else if (event->kind == CONFIG_CHANGED_EVENT) + { + obj = make_lispy_event (event); + kbd_fetch_ptr = event + 1; + } + else + { + /* If this event is on a different frame, return a switch-frame this + time, and leave the event in the queue for next time. */ + Lisp_Object frame; + Lisp_Object focus; + + frame = event->frame_or_window; + if (CONSP (frame)) + frame = XCAR (frame); + else if (WINDOWP (frame)) + frame = WINDOW_FRAME (XWINDOW (frame)); + + focus = FRAME_FOCUS_FRAME (XFRAME (frame)); + if (! NILP (focus)) + frame = focus; + + if (! EQ (frame, internal_last_event_frame) + && !EQ (frame, selected_frame)) + obj = make_lispy_switch_frame (frame); + internal_last_event_frame = frame; + + /* If we didn't decide to make a switch-frame event, go ahead + and build a real event from the queue entry. */ + + if (NILP (obj)) + { + obj = make_lispy_event (event); + +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) || defined (USE_GTK) + /* If this was a menu selection, then set the flag to inhibit + writing to last_nonmenu_event. Don't do this if the event + we're returning is (menu-bar), though; that indicates the + beginning of the menu sequence, and we might as well leave + that as the `event with parameters' for this selection. */ + if (used_mouse_menu + && !EQ (event->frame_or_window, event->arg) + && (event->kind == MENU_BAR_EVENT + || event->kind == TOOL_BAR_EVENT)) + *used_mouse_menu = 1; +#endif +#ifdef HAVE_NS + /* Certain system events are non-key events. */ + if (used_mouse_menu + && event->kind == NS_NONKEY_EVENT) + *used_mouse_menu = 1; +#endif + + /* Wipe out this event, to catch bugs. */ + clear_event (event); + kbd_fetch_ptr = event + 1; + } + } + } + /* Try generating a mouse motion event. */ + else if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + { + struct frame *f = some_mouse_moved (); + Lisp_Object bar_window; + enum scroll_bar_part part; + Lisp_Object x, y; + Time t; + + *kbp = current_kboard; + /* Note that this uses F to determine which terminal to look at. + If there is no valid info, it does not store anything + so x remains nil. */ + x = Qnil; + + /* XXX Can f or mouse_position_hook be NULL here? */ + if (f && FRAME_TERMINAL (f)->mouse_position_hook) + (*FRAME_TERMINAL (f)->mouse_position_hook) (&f, 0, &bar_window, + &part, &x, &y, &t); + + obj = Qnil; + + /* Decide if we should generate a switch-frame event. Don't + generate switch-frame events for motion outside of all Emacs + frames. */ + if (!NILP (x) && f) + { + Lisp_Object frame; + + frame = FRAME_FOCUS_FRAME (f); + if (NILP (frame)) + XSETFRAME (frame, f); + + if (! EQ (frame, internal_last_event_frame) + && !EQ (frame, selected_frame)) + obj = make_lispy_switch_frame (frame); + internal_last_event_frame = frame; + } + + /* If we didn't decide to make a switch-frame event, go ahead and + return a mouse-motion event. */ + if (!NILP (x) && NILP (obj)) + obj = make_lispy_movement (f, bar_window, part, x, y, t); + } + else + /* We were promised by the above while loop that there was + something for us to read! */ + emacs_abort (); + + input_pending = readable_events (0); + + Vlast_event_frame = internal_last_event_frame; + + return (obj); +} + +/* Process any non-user-visible events (currently X selection events), + without reading any user-visible events. */ + +static void +process_special_events (void) +{ + struct input_event *event; + + for (event = kbd_fetch_ptr; event != kbd_store_ptr; ++event) + { + if (event == kbd_buffer + KBD_BUFFER_SIZE) + { + event = kbd_buffer; + if (event == kbd_store_ptr) + break; + } + + /* If we find a stored X selection request, handle it now. */ + if (event->kind == SELECTION_REQUEST_EVENT + || event->kind == SELECTION_CLEAR_EVENT) + { +#ifdef HAVE_X11 + + /* Remove the event from the fifo buffer before processing; + otherwise swallow_events called recursively could see it + and process it again. To do this, we move the events + between kbd_fetch_ptr and EVENT one slot to the right, + cyclically. */ + + struct input_event copy = *event; + struct input_event *beg + = (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) + ? kbd_buffer : kbd_fetch_ptr; + + if (event > beg) + memmove (beg + 1, beg, (event - beg) * sizeof (struct input_event)); + else if (event < beg) + { + if (event > kbd_buffer) + memmove (kbd_buffer + 1, kbd_buffer, + (event - kbd_buffer) * sizeof (struct input_event)); + *kbd_buffer = *(kbd_buffer + KBD_BUFFER_SIZE - 1); + if (beg < kbd_buffer + KBD_BUFFER_SIZE - 1) + memmove (beg + 1, beg, + (kbd_buffer + KBD_BUFFER_SIZE - 1 - beg) + * sizeof (struct input_event)); + } + + if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) + kbd_fetch_ptr = kbd_buffer + 1; + else + kbd_fetch_ptr++; + + input_pending = readable_events (0); + x_handle_selection_event (©); +#else + /* We're getting selection request events, but we don't have + a window system. */ + emacs_abort (); +#endif + } + } +} + +/* Process any events that are not user-visible, run timer events that + are ripe, and return, without reading any user-visible events. */ + +void +swallow_events (bool do_display) +{ + unsigned old_timers_run; + + process_special_events (); + + old_timers_run = timers_run; + get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW); + + if (!input_pending && timers_run != old_timers_run && do_display) + redisplay_preserve_echo_area (7); +} + +/* Record the start of when Emacs is idle, + for the sake of running idle-time timers. */ + +static void +timer_start_idle (void) +{ + /* If we are already in the idle state, do nothing. */ + if (timespec_valid_p (timer_idleness_start_time)) + return; + + timer_idleness_start_time = current_timespec (); + timer_last_idleness_start_time = timer_idleness_start_time; + + /* Mark all idle-time timers as once again candidates for running. */ + call0 (intern ("internal-timer-start-idle")); +} + +/* Record that Emacs is no longer idle, so stop running idle-time timers. */ + +static void +timer_stop_idle (void) +{ + timer_idleness_start_time = invalid_timespec (); +} + +/* Resume idle timer from last idle start time. */ + +static void +timer_resume_idle (void) +{ + if (timespec_valid_p (timer_idleness_start_time)) + return; + + timer_idleness_start_time = timer_last_idleness_start_time; +} + +/* This is only for debugging. */ +struct input_event last_timer_event EXTERNALLY_VISIBLE; + +/* List of elisp functions to call, delayed because they were generated in + a context where Elisp could not be safely run (e.g. redisplay, signal, + ...). Each element has the form (FUN . ARGS). */ +Lisp_Object pending_funcalls; + +/* Return true if TIMER is a valid timer, placing its value into *RESULT. */ +static bool +decode_timer (Lisp_Object timer, struct timespec *result) +{ + Lisp_Object *vec; + + if (! (VECTORP (timer) && ASIZE (timer) == 9)) + return 0; + vec = XVECTOR (timer)->contents; + if (! NILP (vec[0])) + return 0; + if (! INTEGERP (vec[2])) + return false; + + struct lisp_time t; + if (decode_time_components (vec[1], vec[2], vec[3], vec[8], &t, 0) <= 0) + return false; + *result = lisp_to_timespec (t); + return timespec_valid_p (*result); +} + + +/* Check whether a timer has fired. To prevent larger problems we simply + disregard elements that are not proper timers. Do not make a circular + timer list for the time being. + + Returns the time to wait until the next timer fires. If a + timer is triggering now, return zero. + If no timer is active, return -1. + + If a timer is ripe, we run it, with quitting turned off. + In that case we return 0 to indicate that a new timer_check_2 call + should be done. */ + +static struct timespec +timer_check_2 (Lisp_Object timers, Lisp_Object idle_timers) +{ + struct timespec nexttime; + struct timespec now; + struct timespec idleness_now; + Lisp_Object chosen_timer; + struct gcpro gcpro1; + + nexttime = invalid_timespec (); + + chosen_timer = Qnil; + GCPRO1 (chosen_timer); + + /* First run the code that was delayed. */ + while (CONSP (pending_funcalls)) + { + Lisp_Object funcall = XCAR (pending_funcalls); + pending_funcalls = XCDR (pending_funcalls); + safe_call2 (Qapply, XCAR (funcall), XCDR (funcall)); + } + + if (CONSP (timers) || CONSP (idle_timers)) + { + now = current_timespec (); + idleness_now = (timespec_valid_p (timer_idleness_start_time) + ? timespec_sub (now, timer_idleness_start_time) + : make_timespec (0, 0)); + } + + while (CONSP (timers) || CONSP (idle_timers)) + { + Lisp_Object timer = Qnil, idle_timer = Qnil; + struct timespec timer_time, idle_timer_time; + struct timespec difference; + struct timespec timer_difference = invalid_timespec (); + struct timespec idle_timer_difference = invalid_timespec (); + bool ripe, timer_ripe = 0, idle_timer_ripe = 0; + + /* Set TIMER and TIMER_DIFFERENCE + based on the next ordinary timer. + TIMER_DIFFERENCE is the distance in time from NOW to when + this timer becomes ripe. + Skip past invalid timers and timers already handled. */ + if (CONSP (timers)) + { + timer = XCAR (timers); + if (! decode_timer (timer, &timer_time)) + { + timers = XCDR (timers); + continue; + } + + timer_ripe = timespec_cmp (timer_time, now) <= 0; + timer_difference = (timer_ripe + ? timespec_sub (now, timer_time) + : timespec_sub (timer_time, now)); + } + + /* Likewise for IDLE_TIMER and IDLE_TIMER_DIFFERENCE + based on the next idle timer. */ + if (CONSP (idle_timers)) + { + idle_timer = XCAR (idle_timers); + if (! decode_timer (idle_timer, &idle_timer_time)) + { + idle_timers = XCDR (idle_timers); + continue; + } + + idle_timer_ripe = timespec_cmp (idle_timer_time, idleness_now) <= 0; + idle_timer_difference + = (idle_timer_ripe + ? timespec_sub (idleness_now, idle_timer_time) + : timespec_sub (idle_timer_time, idleness_now)); + } + + /* Decide which timer is the next timer, + and set CHOSEN_TIMER, DIFFERENCE, and RIPE accordingly. + Also step down the list where we found that timer. */ + + if (timespec_valid_p (timer_difference) + && (! timespec_valid_p (idle_timer_difference) + || idle_timer_ripe < timer_ripe + || (idle_timer_ripe == timer_ripe + && ((timer_ripe + ? timespec_cmp (idle_timer_difference, + timer_difference) + : timespec_cmp (timer_difference, + idle_timer_difference)) + < 0)))) + { + chosen_timer = timer; + timers = XCDR (timers); + difference = timer_difference; + ripe = timer_ripe; + } + else + { + chosen_timer = idle_timer; + idle_timers = XCDR (idle_timers); + difference = idle_timer_difference; + ripe = idle_timer_ripe; + } + + /* If timer is ripe, run it if it hasn't been run. */ + if (ripe) + { + if (NILP (AREF (chosen_timer, 0))) + { + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object old_deactivate_mark = Vdeactivate_mark; + + /* Mark the timer as triggered to prevent problems if the lisp + code fails to reschedule it right. */ + ASET (chosen_timer, 0, Qt); + + specbind (Qinhibit_quit, Qt); + + call1 (Qtimer_event_handler, chosen_timer); + Vdeactivate_mark = old_deactivate_mark; + timers_run++; + unbind_to (count, Qnil); + + /* Since we have handled the event, + we don't need to tell the caller to wake up and do it. */ + /* But the caller must still wait for the next timer, so + return 0 to indicate that. */ + } + + nexttime = make_timespec (0, 0); + break; + } + else + /* When we encounter a timer that is still waiting, + return the amount of time to wait before it is ripe. */ + { + UNGCPRO; + return difference; + } + } + + /* No timers are pending in the future. */ + /* Return 0 if we generated an event, and -1 if not. */ + UNGCPRO; + return nexttime; +} + + +/* Check whether a timer has fired. To prevent larger problems we simply + disregard elements that are not proper timers. Do not make a circular + timer list for the time being. + + Returns the time to wait until the next timer fires. + If no timer is active, return an invalid value. + + As long as any timer is ripe, we run it. */ + +struct timespec +timer_check (void) +{ + struct timespec nexttime; + Lisp_Object timers, idle_timers; + struct gcpro gcpro1, gcpro2; + + Lisp_Object tem = Vinhibit_quit; + Vinhibit_quit = Qt; + + /* We use copies of the timers' lists to allow a timer to add itself + again, without locking up Emacs if the newly added timer is + already ripe when added. */ + + /* Always consider the ordinary timers. */ + timers = Fcopy_sequence (Vtimer_list); + /* Consider the idle timers only if Emacs is idle. */ + if (timespec_valid_p (timer_idleness_start_time)) + idle_timers = Fcopy_sequence (Vtimer_idle_list); + else + idle_timers = Qnil; + + Vinhibit_quit = tem; + + GCPRO2 (timers, idle_timers); + + do + { + nexttime = timer_check_2 (timers, idle_timers); + } + while (nexttime.tv_sec == 0 && nexttime.tv_nsec == 0); + + UNGCPRO; + return nexttime; +} + +DEFUN ("current-idle-time", Fcurrent_idle_time, Scurrent_idle_time, 0, 0, 0, + doc: /* Return the current length of Emacs idleness, or nil. +The value when Emacs is idle is a list of four integers (HIGH LOW USEC PSEC) +in the same style as (current-time). + +The value when Emacs is not idle is nil. + +PSEC is a multiple of the system clock resolution. */) + (void) +{ + if (timespec_valid_p (timer_idleness_start_time)) + return make_lisp_time (timespec_sub (current_timespec (), + timer_idleness_start_time)); + + return Qnil; +} + +/* Caches for modify_event_symbol. */ +static Lisp_Object accent_key_syms; +static Lisp_Object func_key_syms; +static Lisp_Object mouse_syms; +static Lisp_Object wheel_syms; +static Lisp_Object drag_n_drop_syms; + +/* This is a list of keysym codes for special "accent" characters. + It parallels lispy_accent_keys. */ + +static const int lispy_accent_codes[] = +{ +#ifdef XK_dead_circumflex + XK_dead_circumflex, +#else + 0, +#endif +#ifdef XK_dead_grave + XK_dead_grave, +#else + 0, +#endif +#ifdef XK_dead_tilde + XK_dead_tilde, +#else + 0, +#endif +#ifdef XK_dead_diaeresis + XK_dead_diaeresis, +#else + 0, +#endif +#ifdef XK_dead_macron + XK_dead_macron, +#else + 0, +#endif +#ifdef XK_dead_degree + XK_dead_degree, +#else + 0, +#endif +#ifdef XK_dead_acute + XK_dead_acute, +#else + 0, +#endif +#ifdef XK_dead_cedilla + XK_dead_cedilla, +#else + 0, +#endif +#ifdef XK_dead_breve + XK_dead_breve, +#else + 0, +#endif +#ifdef XK_dead_ogonek + XK_dead_ogonek, +#else + 0, +#endif +#ifdef XK_dead_caron + XK_dead_caron, +#else + 0, +#endif +#ifdef XK_dead_doubleacute + XK_dead_doubleacute, +#else + 0, +#endif +#ifdef XK_dead_abovedot + XK_dead_abovedot, +#else + 0, +#endif +#ifdef XK_dead_abovering + XK_dead_abovering, +#else + 0, +#endif +#ifdef XK_dead_iota + XK_dead_iota, +#else + 0, +#endif +#ifdef XK_dead_belowdot + XK_dead_belowdot, +#else + 0, +#endif +#ifdef XK_dead_voiced_sound + XK_dead_voiced_sound, +#else + 0, +#endif +#ifdef XK_dead_semivoiced_sound + XK_dead_semivoiced_sound, +#else + 0, +#endif +#ifdef XK_dead_hook + XK_dead_hook, +#else + 0, +#endif +#ifdef XK_dead_horn + XK_dead_horn, +#else + 0, +#endif +}; + +/* This is a list of Lisp names for special "accent" characters. + It parallels lispy_accent_codes. */ + +static const char *const lispy_accent_keys[] = +{ + "dead-circumflex", + "dead-grave", + "dead-tilde", + "dead-diaeresis", + "dead-macron", + "dead-degree", + "dead-acute", + "dead-cedilla", + "dead-breve", + "dead-ogonek", + "dead-caron", + "dead-doubleacute", + "dead-abovedot", + "dead-abovering", + "dead-iota", + "dead-belowdot", + "dead-voiced-sound", + "dead-semivoiced-sound", + "dead-hook", + "dead-horn", +}; + +#ifdef HAVE_NTGUI +#define FUNCTION_KEY_OFFSET 0x0 + +const char *const lispy_function_keys[] = + { + 0, /* 0 */ + + 0, /* VK_LBUTTON 0x01 */ + 0, /* VK_RBUTTON 0x02 */ + "cancel", /* VK_CANCEL 0x03 */ + 0, /* VK_MBUTTON 0x04 */ + + 0, 0, 0, /* 0x05 .. 0x07 */ + + "backspace", /* VK_BACK 0x08 */ + "tab", /* VK_TAB 0x09 */ + + 0, 0, /* 0x0A .. 0x0B */ + + "clear", /* VK_CLEAR 0x0C */ + "return", /* VK_RETURN 0x0D */ + + 0, 0, /* 0x0E .. 0x0F */ + + 0, /* VK_SHIFT 0x10 */ + 0, /* VK_CONTROL 0x11 */ + 0, /* VK_MENU 0x12 */ + "pause", /* VK_PAUSE 0x13 */ + "capslock", /* VK_CAPITAL 0x14 */ + "kana", /* VK_KANA/VK_HANGUL 0x15 */ + 0, /* 0x16 */ + "junja", /* VK_JUNJA 0x17 */ + "final", /* VK_FINAL 0x18 */ + "kanji", /* VK_KANJI/VK_HANJA 0x19 */ + 0, /* 0x1A */ + "escape", /* VK_ESCAPE 0x1B */ + "convert", /* VK_CONVERT 0x1C */ + "non-convert", /* VK_NONCONVERT 0x1D */ + "accept", /* VK_ACCEPT 0x1E */ + "mode-change", /* VK_MODECHANGE 0x1F */ + 0, /* VK_SPACE 0x20 */ + "prior", /* VK_PRIOR 0x21 */ + "next", /* VK_NEXT 0x22 */ + "end", /* VK_END 0x23 */ + "home", /* VK_HOME 0x24 */ + "left", /* VK_LEFT 0x25 */ + "up", /* VK_UP 0x26 */ + "right", /* VK_RIGHT 0x27 */ + "down", /* VK_DOWN 0x28 */ + "select", /* VK_SELECT 0x29 */ + "print", /* VK_PRINT 0x2A */ + "execute", /* VK_EXECUTE 0x2B */ + "snapshot", /* VK_SNAPSHOT 0x2C */ + "insert", /* VK_INSERT 0x2D */ + "delete", /* VK_DELETE 0x2E */ + "help", /* VK_HELP 0x2F */ + + /* VK_0 thru VK_9 are the same as ASCII '0' thru '9' (0x30 - 0x39) */ + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, /* 0x3A .. 0x40 */ + + /* VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' (0x41 - 0x5A) */ + + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + + "lwindow", /* VK_LWIN 0x5B */ + "rwindow", /* VK_RWIN 0x5C */ + "apps", /* VK_APPS 0x5D */ + 0, /* 0x5E */ + "sleep", + "kp-0", /* VK_NUMPAD0 0x60 */ + "kp-1", /* VK_NUMPAD1 0x61 */ + "kp-2", /* VK_NUMPAD2 0x62 */ + "kp-3", /* VK_NUMPAD3 0x63 */ + "kp-4", /* VK_NUMPAD4 0x64 */ + "kp-5", /* VK_NUMPAD5 0x65 */ + "kp-6", /* VK_NUMPAD6 0x66 */ + "kp-7", /* VK_NUMPAD7 0x67 */ + "kp-8", /* VK_NUMPAD8 0x68 */ + "kp-9", /* VK_NUMPAD9 0x69 */ + "kp-multiply", /* VK_MULTIPLY 0x6A */ + "kp-add", /* VK_ADD 0x6B */ + "kp-separator", /* VK_SEPARATOR 0x6C */ + "kp-subtract", /* VK_SUBTRACT 0x6D */ + "kp-decimal", /* VK_DECIMAL 0x6E */ + "kp-divide", /* VK_DIVIDE 0x6F */ + "f1", /* VK_F1 0x70 */ + "f2", /* VK_F2 0x71 */ + "f3", /* VK_F3 0x72 */ + "f4", /* VK_F4 0x73 */ + "f5", /* VK_F5 0x74 */ + "f6", /* VK_F6 0x75 */ + "f7", /* VK_F7 0x76 */ + "f8", /* VK_F8 0x77 */ + "f9", /* VK_F9 0x78 */ + "f10", /* VK_F10 0x79 */ + "f11", /* VK_F11 0x7A */ + "f12", /* VK_F12 0x7B */ + "f13", /* VK_F13 0x7C */ + "f14", /* VK_F14 0x7D */ + "f15", /* VK_F15 0x7E */ + "f16", /* VK_F16 0x7F */ + "f17", /* VK_F17 0x80 */ + "f18", /* VK_F18 0x81 */ + "f19", /* VK_F19 0x82 */ + "f20", /* VK_F20 0x83 */ + "f21", /* VK_F21 0x84 */ + "f22", /* VK_F22 0x85 */ + "f23", /* VK_F23 0x86 */ + "f24", /* VK_F24 0x87 */ + + 0, 0, 0, 0, /* 0x88 .. 0x8B */ + 0, 0, 0, 0, /* 0x8C .. 0x8F */ + + "kp-numlock", /* VK_NUMLOCK 0x90 */ + "scroll", /* VK_SCROLL 0x91 */ + /* Not sure where the following block comes from. + Windows headers have NEC and Fujitsu specific keys in + this block, but nothing generic. */ + "kp-space", /* VK_NUMPAD_CLEAR 0x92 */ + "kp-enter", /* VK_NUMPAD_ENTER 0x93 */ + "kp-prior", /* VK_NUMPAD_PRIOR 0x94 */ + "kp-next", /* VK_NUMPAD_NEXT 0x95 */ + "kp-end", /* VK_NUMPAD_END 0x96 */ + "kp-home", /* VK_NUMPAD_HOME 0x97 */ + "kp-left", /* VK_NUMPAD_LEFT 0x98 */ + "kp-up", /* VK_NUMPAD_UP 0x99 */ + "kp-right", /* VK_NUMPAD_RIGHT 0x9A */ + "kp-down", /* VK_NUMPAD_DOWN 0x9B */ + "kp-insert", /* VK_NUMPAD_INSERT 0x9C */ + "kp-delete", /* VK_NUMPAD_DELETE 0x9D */ + + 0, 0, /* 0x9E .. 0x9F */ + + /* + * VK_L* & VK_R* - left and right Alt, Ctrl and Shift virtual keys. + * Used only as parameters to GetAsyncKeyState and GetKeyState. + * No other API or message will distinguish left and right keys this way. + * 0xA0 .. 0xA5 + */ + 0, 0, 0, 0, 0, 0, + + /* Multimedia keys. These are handled as WM_APPCOMMAND, which allows us + to enable them selectively, and gives access to a few more functions. + See lispy_multimedia_keys below. */ + 0, 0, 0, 0, 0, 0, 0, /* 0xA6 .. 0xAC Browser */ + 0, 0, 0, /* 0xAD .. 0xAF Volume */ + 0, 0, 0, 0, /* 0xB0 .. 0xB3 Media */ + 0, 0, 0, 0, /* 0xB4 .. 0xB7 Apps */ + + /* 0xB8 .. 0xC0 "OEM" keys - all seem to be punctuation. */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, + + /* 0xC1 - 0xDA unallocated, 0xDB-0xDF more OEM keys */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, /* 0xE0 */ + "ax", /* VK_OEM_AX 0xE1 */ + 0, /* VK_OEM_102 0xE2 */ + "ico-help", /* VK_ICO_HELP 0xE3 */ + "ico-00", /* VK_ICO_00 0xE4 */ + 0, /* VK_PROCESSKEY 0xE5 - used by IME */ + "ico-clear", /* VK_ICO_CLEAR 0xE6 */ + 0, /* VK_PACKET 0xE7 - used to pass Unicode chars */ + 0, /* 0xE8 */ + "reset", /* VK_OEM_RESET 0xE9 */ + "jump", /* VK_OEM_JUMP 0xEA */ + "oem-pa1", /* VK_OEM_PA1 0xEB */ + "oem-pa2", /* VK_OEM_PA2 0xEC */ + "oem-pa3", /* VK_OEM_PA3 0xED */ + "wsctrl", /* VK_OEM_WSCTRL 0xEE */ + "cusel", /* VK_OEM_CUSEL 0xEF */ + "oem-attn", /* VK_OEM_ATTN 0xF0 */ + "finish", /* VK_OEM_FINISH 0xF1 */ + "copy", /* VK_OEM_COPY 0xF2 */ + "auto", /* VK_OEM_AUTO 0xF3 */ + "enlw", /* VK_OEM_ENLW 0xF4 */ + "backtab", /* VK_OEM_BACKTAB 0xF5 */ + "attn", /* VK_ATTN 0xF6 */ + "crsel", /* VK_CRSEL 0xF7 */ + "exsel", /* VK_EXSEL 0xF8 */ + "ereof", /* VK_EREOF 0xF9 */ + "play", /* VK_PLAY 0xFA */ + "zoom", /* VK_ZOOM 0xFB */ + "noname", /* VK_NONAME 0xFC */ + "pa1", /* VK_PA1 0xFD */ + "oem_clear", /* VK_OEM_CLEAR 0xFE */ + 0 /* 0xFF */ + }; + +/* Some of these duplicate the "Media keys" on newer keyboards, + but they are delivered to the application in a different way. */ +static const char *const lispy_multimedia_keys[] = + { + 0, + "browser-back", + "browser-forward", + "browser-refresh", + "browser-stop", + "browser-search", + "browser-favorites", + "browser-home", + "volume-mute", + "volume-down", + "volume-up", + "media-next", + "media-previous", + "media-stop", + "media-play-pause", + "mail", + "media-select", + "app-1", + "app-2", + "bass-down", + "bass-boost", + "bass-up", + "treble-down", + "treble-up", + "mic-volume-mute", + "mic-volume-down", + "mic-volume-up", + "help", + "find", + "new", + "open", + "close", + "save", + "print", + "undo", + "redo", + "copy", + "cut", + "paste", + "mail-reply", + "mail-forward", + "mail-send", + "spell-check", + "toggle-dictate-command", + "mic-toggle", + "correction-list", + "media-play", + "media-pause", + "media-record", + "media-fast-forward", + "media-rewind", + "media-channel-up", + "media-channel-down" + }; + +#else /* not HAVE_NTGUI */ + +/* This should be dealt with in XTread_socket now, and that doesn't + depend on the client system having the Kana syms defined. See also + the XK_kana_A case below. */ +#if 0 +#ifdef XK_kana_A +static const char *const lispy_kana_keys[] = + { + /* X Keysym value */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x400 .. 0x40f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x410 .. 0x41f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x420 .. 0x42f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x430 .. 0x43f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x440 .. 0x44f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x450 .. 0x45f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x460 .. 0x46f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,"overline",0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x480 .. 0x48f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x490 .. 0x49f */ + 0, "kana-fullstop", "kana-openingbracket", "kana-closingbracket", + "kana-comma", "kana-conjunctive", "kana-WO", "kana-a", + "kana-i", "kana-u", "kana-e", "kana-o", + "kana-ya", "kana-yu", "kana-yo", "kana-tsu", + "prolongedsound", "kana-A", "kana-I", "kana-U", + "kana-E", "kana-O", "kana-KA", "kana-KI", + "kana-KU", "kana-KE", "kana-KO", "kana-SA", + "kana-SHI", "kana-SU", "kana-SE", "kana-SO", + "kana-TA", "kana-CHI", "kana-TSU", "kana-TE", + "kana-TO", "kana-NA", "kana-NI", "kana-NU", + "kana-NE", "kana-NO", "kana-HA", "kana-HI", + "kana-FU", "kana-HE", "kana-HO", "kana-MA", + "kana-MI", "kana-MU", "kana-ME", "kana-MO", + "kana-YA", "kana-YU", "kana-YO", "kana-RA", + "kana-RI", "kana-RU", "kana-RE", "kana-RO", + "kana-WA", "kana-N", "voicedsound", "semivoicedsound", + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x4e0 .. 0x4ef */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x4f0 .. 0x4ff */ + }; +#endif /* XK_kana_A */ +#endif /* 0 */ + +#define FUNCTION_KEY_OFFSET 0xff00 + +/* You'll notice that this table is arranged to be conveniently + indexed by X Windows keysym values. */ +static const char *const lispy_function_keys[] = + { + /* X Keysym value */ + + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xff00...0f */ + "backspace", "tab", "linefeed", "clear", + 0, "return", 0, 0, + 0, 0, 0, "pause", /* 0xff10...1f */ + 0, 0, 0, 0, 0, 0, 0, "escape", + 0, 0, 0, 0, + 0, "kanji", "muhenkan", "henkan", /* 0xff20...2f */ + "romaji", "hiragana", "katakana", "hiragana-katakana", + "zenkaku", "hankaku", "zenkaku-hankaku", "touroku", + "massyo", "kana-lock", "kana-shift", "eisu-shift", + "eisu-toggle", /* 0xff30...3f */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0xff40...4f */ + + "home", "left", "up", "right", /* 0xff50 */ /* IsCursorKey */ + "down", "prior", "next", "end", + "begin", 0, 0, 0, 0, 0, 0, 0, + "select", /* 0xff60 */ /* IsMiscFunctionKey */ + "print", + "execute", + "insert", + 0, /* 0xff64 */ + "undo", + "redo", + "menu", + "find", + "cancel", + "help", + "break", /* 0xff6b */ + + 0, 0, 0, 0, + 0, 0, 0, 0, "backtab", 0, 0, 0, /* 0xff70... */ + 0, 0, 0, 0, 0, 0, 0, "kp-numlock", /* 0xff78... */ + "kp-space", /* 0xff80 */ /* IsKeypadKey */ + 0, 0, 0, 0, 0, 0, 0, 0, + "kp-tab", /* 0xff89 */ + 0, 0, 0, + "kp-enter", /* 0xff8d */ + 0, 0, 0, + "kp-f1", /* 0xff91 */ + "kp-f2", + "kp-f3", + "kp-f4", + "kp-home", /* 0xff95 */ + "kp-left", + "kp-up", + "kp-right", + "kp-down", + "kp-prior", /* kp-page-up */ + "kp-next", /* kp-page-down */ + "kp-end", + "kp-begin", + "kp-insert", + "kp-delete", + 0, /* 0xffa0 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, + "kp-multiply", /* 0xffaa */ + "kp-add", + "kp-separator", + "kp-subtract", + "kp-decimal", + "kp-divide", /* 0xffaf */ + "kp-0", /* 0xffb0 */ + "kp-1", "kp-2", "kp-3", "kp-4", "kp-5", "kp-6", "kp-7", "kp-8", "kp-9", + 0, /* 0xffba */ + 0, 0, + "kp-equal", /* 0xffbd */ + "f1", /* 0xffbe */ /* IsFunctionKey */ + "f2", + "f3", "f4", "f5", "f6", "f7", "f8", "f9", "f10", /* 0xffc0 */ + "f11", "f12", "f13", "f14", "f15", "f16", "f17", "f18", + "f19", "f20", "f21", "f22", "f23", "f24", "f25", "f26", /* 0xffd0 */ + "f27", "f28", "f29", "f30", "f31", "f32", "f33", "f34", + "f35", 0, 0, 0, 0, 0, 0, 0, /* 0xffe0 */ + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfff0 */ + 0, 0, 0, 0, 0, 0, 0, "delete" + }; + +/* ISO 9995 Function and Modifier Keys; the first byte is 0xFE. */ +#define ISO_FUNCTION_KEY_OFFSET 0xfe00 + +static const char *const iso_lispy_function_keys[] = + { + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfe00 */ + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfe08 */ + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfe10 */ + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfe18 */ + "iso-lefttab", /* 0xfe20 */ + "iso-move-line-up", "iso-move-line-down", + "iso-partial-line-up", "iso-partial-line-down", + "iso-partial-space-left", "iso-partial-space-right", + "iso-set-margin-left", "iso-set-margin-right", /* 0xffe27, 28 */ + "iso-release-margin-left", "iso-release-margin-right", + "iso-release-both-margins", + "iso-fast-cursor-left", "iso-fast-cursor-right", + "iso-fast-cursor-up", "iso-fast-cursor-down", + "iso-continuous-underline", "iso-discontinuous-underline", /* 0xfe30, 31 */ + "iso-emphasize", "iso-center-object", "iso-enter", /* ... 0xfe34 */ + }; + +#endif /* not HAVE_NTGUI */ + +static Lisp_Object Vlispy_mouse_stem; + +static const char *const lispy_wheel_names[] = +{ + "wheel-up", "wheel-down", "wheel-left", "wheel-right" +}; + +/* drag-n-drop events are generated when a set of selected files are + dragged from another application and dropped onto an Emacs window. */ +static const char *const lispy_drag_n_drop_names[] = +{ + "drag-n-drop" +}; + +/* An array of symbol indexes of scroll bar parts, indexed by an enum + scroll_bar_part value. Note that Qnil corresponds to + scroll_bar_nowhere and should not appear in Lisp events. */ +static short const scroll_bar_parts[] = { + SYMBOL_INDEX (Qnil), SYMBOL_INDEX (Qabove_handle), SYMBOL_INDEX (Qhandle), + SYMBOL_INDEX (Qbelow_handle), SYMBOL_INDEX (Qup), SYMBOL_INDEX (Qdown), + SYMBOL_INDEX (Qtop), SYMBOL_INDEX (Qbottom), SYMBOL_INDEX (Qend_scroll), + SYMBOL_INDEX (Qratio), SYMBOL_INDEX (Qbefore_handle), + SYMBOL_INDEX (Qhorizontal_handle), SYMBOL_INDEX (Qafter_handle), + SYMBOL_INDEX (Qleft), SYMBOL_INDEX (Qright), SYMBOL_INDEX (Qleftmost), + SYMBOL_INDEX (Qrightmost), SYMBOL_INDEX (Qend_scroll), SYMBOL_INDEX (Qratio) +}; + +/* A vector, indexed by button number, giving the down-going location + of currently depressed buttons, both scroll bar and non-scroll bar. + + The elements have the form + (BUTTON-NUMBER MODIFIER-MASK . REST) + where REST is the cdr of a position as it would be reported in the event. + + The make_lispy_event function stores positions here to tell the + difference between click and drag events, and to store the starting + location to be included in drag events. */ + +static Lisp_Object button_down_location; + +/* Information about the most recent up-going button event: Which + button, what location, and what time. */ + +static int last_mouse_button; +static int last_mouse_x; +static int last_mouse_y; +static Time button_down_time; + +/* The number of clicks in this multiple-click. */ + +static int double_click_count; + +/* X and Y are frame-relative coordinates for a click or wheel event. + Return a Lisp-style event list. */ + +static Lisp_Object +make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, + Time t) +{ + enum window_part part; + Lisp_Object posn = Qnil; + Lisp_Object extra_info = Qnil; + /* Coordinate pixel positions to return. */ + int xret = 0, yret = 0; + /* The window under frame pixel coordinates (x,y) */ + Lisp_Object window = f + ? window_from_coordinates (f, XINT (x), XINT (y), &part, 0) + : Qnil; + + if (WINDOWP (window)) + { + /* It's a click in window WINDOW at frame coordinates (X,Y) */ + struct window *w = XWINDOW (window); + Lisp_Object string_info = Qnil; + ptrdiff_t textpos = 0; + int col = -1, row = -1; + int dx = -1, dy = -1; + int width = -1, height = -1; + Lisp_Object object = Qnil; + + /* Pixel coordinates relative to the window corner. */ + int wx = XINT (x) - WINDOW_LEFT_EDGE_X (w); + int wy = XINT (y) - WINDOW_TOP_EDGE_Y (w); + + /* For text area clicks, return X, Y relative to the corner of + this text area. Note that dX, dY etc are set below, by + buffer_posn_from_coords. */ + if (part == ON_TEXT) + { + xret = XINT (x) - window_box_left (w, TEXT_AREA); + yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); + } + /* For mode line and header line clicks, return X, Y relative to + the left window edge. Use mode_line_string to look for a + string on the click position. */ + else if (part == ON_MODE_LINE || part == ON_HEADER_LINE) + { + Lisp_Object string; + ptrdiff_t charpos; + + posn = (part == ON_MODE_LINE) ? Qmode_line : Qheader_line; + /* Note that mode_line_string takes COL, ROW as pixels and + converts them to characters. */ + col = wx; + row = wy; + string = mode_line_string (w, part, &col, &row, &charpos, + &object, &dx, &dy, &width, &height); + if (STRINGP (string)) + string_info = Fcons (string, make_number (charpos)); + textpos = -1; + + xret = wx; + yret = wy; + } + /* For fringes and margins, Y is relative to the area's (and the + window's) top edge, while X is meaningless. */ + else if (part == ON_LEFT_MARGIN || part == ON_RIGHT_MARGIN) + { + Lisp_Object string; + ptrdiff_t charpos; + + posn = (part == ON_LEFT_MARGIN) ? Qleft_margin : Qright_margin; + col = wx; + row = wy; + string = marginal_area_string (w, part, &col, &row, &charpos, + &object, &dx, &dy, &width, &height); + if (STRINGP (string)) + string_info = Fcons (string, make_number (charpos)); + xret = wx; + yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); + } + else if (part == ON_LEFT_FRINGE) + { + posn = Qleft_fringe; + col = 0; + xret = wx; + dx = wx + - (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (w) + ? 0 : window_box_width (w, LEFT_MARGIN_AREA)); + dy = yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); + } + else if (part == ON_RIGHT_FRINGE) + { + posn = Qright_fringe; + col = 0; + xret = wx; + dx = wx + - window_box_width (w, LEFT_MARGIN_AREA) + - window_box_width (w, TEXT_AREA) + - (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (w) + ? window_box_width (w, RIGHT_MARGIN_AREA) + : 0); + dy = yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); + } + else if (part == ON_VERTICAL_BORDER) + { + posn = Qvertical_line; + width = 1; + dx = 0; + xret = wx; + dy = yret = wy; + } + else if (part == ON_VERTICAL_SCROLL_BAR) + { + posn = Qvertical_scroll_bar; + width = WINDOW_SCROLL_BAR_AREA_WIDTH (w); + dx = xret = wx; + dy = yret = wy; + } + else if (part == ON_HORIZONTAL_SCROLL_BAR) + { + posn = Qhorizontal_scroll_bar; + width = WINDOW_SCROLL_BAR_AREA_HEIGHT (w); + dx = xret = wx; + dy = yret = wy; + } + else if (part == ON_RIGHT_DIVIDER) + { + posn = Qright_divider; + width = WINDOW_RIGHT_DIVIDER_WIDTH (w); + dx = xret = wx; + dy = yret = wy; + } + else if (part == ON_BOTTOM_DIVIDER) + { + posn = Qbottom_divider; + width = WINDOW_BOTTOM_DIVIDER_WIDTH (w); + dx = xret = wx; + dy = yret = wy; + } + + /* For clicks in the text area, fringes, margins, or vertical + scroll bar, call buffer_posn_from_coords to extract TEXTPOS, + the buffer position nearest to the click. */ + if (!textpos) + { + Lisp_Object string2, object2 = Qnil; + struct display_pos p; + int dx2, dy2; + int width2, height2; + /* The pixel X coordinate passed to buffer_posn_from_coords + is the X coordinate relative to the text area for clicks + in text-area, right-margin/fringe and right-side vertical + scroll bar, zero otherwise. */ + int x2 + = (part == ON_TEXT) ? xret + : (part == ON_RIGHT_FRINGE || part == ON_RIGHT_MARGIN + || (part == ON_VERTICAL_SCROLL_BAR + && WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_RIGHT (w))) + ? (XINT (x) - window_box_left (w, TEXT_AREA)) + : 0; + int y2 = wy; + + string2 = buffer_posn_from_coords (w, &x2, &y2, &p, + &object2, &dx2, &dy2, + &width2, &height2); + textpos = CHARPOS (p.pos); + if (col < 0) col = x2; + if (row < 0) row = y2; + if (dx < 0) dx = dx2; + if (dy < 0) dy = dy2; + if (width < 0) width = width2; + if (height < 0) height = height2; + + if (NILP (posn)) + { + posn = make_number (textpos); + if (STRINGP (string2)) + string_info = Fcons (string2, + make_number (CHARPOS (p.string_pos))); + } + if (NILP (object)) + object = object2; + } + +#ifdef HAVE_WINDOW_SYSTEM + if (IMAGEP (object)) + { + Lisp_Object image_map, hotspot; + if ((image_map = Fplist_get (XCDR (object), QCmap), + !NILP (image_map)) + && (hotspot = find_hot_spot (image_map, dx, dy), + CONSP (hotspot)) + && (hotspot = XCDR (hotspot), CONSP (hotspot))) + posn = XCAR (hotspot); + } +#endif + + /* Object info. */ + extra_info + = list3 (object, + Fcons (make_number (dx), make_number (dy)), + Fcons (make_number (width), make_number (height))); + + /* String info. */ + extra_info = Fcons (string_info, + Fcons (textpos < 0 ? Qnil : make_number (textpos), + Fcons (Fcons (make_number (col), + make_number (row)), + extra_info))); + } + else if (f != 0) + { + /* Return mouse pixel coordinates here. */ + XSETFRAME (window, f); + xret = XINT (x); + yret = XINT (y); + } + else + window = Qnil; + + return Fcons (window, + Fcons (posn, + Fcons (Fcons (make_number (xret), + make_number (yret)), + Fcons (make_number (t), + extra_info)))); +} + +/* Return non-zero if F is a GUI frame that uses some toolkit-managed + menu bar. This really means that Emacs draws and manages the menu + bar as part of its normal display, and therefore can compute its + geometry. */ +static bool +toolkit_menubar_in_use (struct frame *f) +{ +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (HAVE_NTGUI) + return !(!FRAME_WINDOW_P (f)); +#else + return false; +#endif +} + +/* Build the part of Lisp event which represents scroll bar state from + EV. TYPE is one of Qvertical_scroll_bar or Qhorizontal_scroll_bar. */ + +static Lisp_Object +make_scroll_bar_position (struct input_event *ev, Lisp_Object type) +{ + return list5 (ev->frame_or_window, type, Fcons (ev->x, ev->y), + make_number (ev->timestamp), + builtin_lisp_symbol (scroll_bar_parts[ev->part])); +} + +/* Given a struct input_event, build the lisp event which represents + it. If EVENT is 0, build a mouse movement event from the mouse + movement buffer, which should have a movement event in it. + + Note that events must be passed to this function in the order they + are received; this function stores the location of button presses + in order to build drag events when the button is released. */ + +static Lisp_Object +make_lispy_event (struct input_event *event) +{ + int i; + + switch (event->kind) + { + /* A simple keystroke. */ + case ASCII_KEYSTROKE_EVENT: + case MULTIBYTE_CHAR_KEYSTROKE_EVENT: + { + Lisp_Object lispy_c; + EMACS_INT c = event->code; + if (event->kind == ASCII_KEYSTROKE_EVENT) + { + c &= 0377; + eassert (c == event->code); + /* Turn ASCII characters into control characters + when proper. */ + if (event->modifiers & ctrl_modifier) + { + c = make_ctrl_char (c); + event->modifiers &= ~ctrl_modifier; + } + } + + /* Add in the other modifier bits. The shift key was taken care + of by the X code. */ + c |= (event->modifiers + & (meta_modifier | alt_modifier + | hyper_modifier | super_modifier | ctrl_modifier)); + /* Distinguish Shift-SPC from SPC. */ + if ((event->code) == 040 + && event->modifiers & shift_modifier) + c |= shift_modifier; + button_down_time = 0; + XSETFASTINT (lispy_c, c); + return lispy_c; + } + +#ifdef HAVE_NS + /* NS_NONKEY_EVENTs are just like NON_ASCII_KEYSTROKE_EVENTs, + except that they are non-key events (last-nonmenu-event is nil). */ + case NS_NONKEY_EVENT: +#endif + + /* A function key. The symbol may need to have modifier prefixes + tacked onto it. */ + case NON_ASCII_KEYSTROKE_EVENT: + button_down_time = 0; + + for (i = 0; i < ARRAYELTS (lispy_accent_codes); i++) + if (event->code == lispy_accent_codes[i]) + return modify_event_symbol (i, + event->modifiers, + Qfunction_key, Qnil, + lispy_accent_keys, &accent_key_syms, + ARRAYELTS (lispy_accent_keys)); + +#if 0 +#ifdef XK_kana_A + if (event->code >= 0x400 && event->code < 0x500) + return modify_event_symbol (event->code - 0x400, + event->modifiers & ~shift_modifier, + Qfunction_key, Qnil, + lispy_kana_keys, &func_key_syms, + ARRAYELTS (lispy_kana_keys)); +#endif /* XK_kana_A */ +#endif /* 0 */ + +#ifdef ISO_FUNCTION_KEY_OFFSET + if (event->code < FUNCTION_KEY_OFFSET + && event->code >= ISO_FUNCTION_KEY_OFFSET) + return modify_event_symbol (event->code - ISO_FUNCTION_KEY_OFFSET, + event->modifiers, + Qfunction_key, Qnil, + iso_lispy_function_keys, &func_key_syms, + ARRAYELTS (iso_lispy_function_keys)); +#endif + + if ((FUNCTION_KEY_OFFSET <= event->code + && (event->code + < FUNCTION_KEY_OFFSET + ARRAYELTS (lispy_function_keys))) + && lispy_function_keys[event->code - FUNCTION_KEY_OFFSET]) + return modify_event_symbol (event->code - FUNCTION_KEY_OFFSET, + event->modifiers, + Qfunction_key, Qnil, + lispy_function_keys, &func_key_syms, + ARRAYELTS (lispy_function_keys)); + + /* Handle system-specific or unknown keysyms. + We need to use an alist rather than a vector as the cache + since we can't make a vector long enough. */ + if (NILP (KVAR (current_kboard, system_key_syms))) + kset_system_key_syms (current_kboard, Fcons (Qnil, Qnil)); + return modify_event_symbol (event->code, + event->modifiers, + Qfunction_key, + KVAR (current_kboard, Vsystem_key_alist), + 0, &KVAR (current_kboard, system_key_syms), + PTRDIFF_MAX); + +#ifdef HAVE_NTGUI + case MULTIMEDIA_KEY_EVENT: + if (event->code < ARRAYELTS (lispy_multimedia_keys) + && event->code > 0 && lispy_multimedia_keys[event->code]) + { + return modify_event_symbol (event->code, event->modifiers, + Qfunction_key, Qnil, + lispy_multimedia_keys, &func_key_syms, + ARRAYELTS (lispy_multimedia_keys)); + } + return Qnil; +#endif + + /* A mouse click. Figure out where it is, decide whether it's + a press, click or drag, and build the appropriate structure. */ + case MOUSE_CLICK_EVENT: +#ifdef HAVE_GPM + case GPM_CLICK_EVENT: +#endif +#ifndef USE_TOOLKIT_SCROLL_BARS + case SCROLL_BAR_CLICK_EVENT: + case HORIZONTAL_SCROLL_BAR_CLICK_EVENT: +#endif + { + int button = event->code; + bool is_double; + Lisp_Object position; + Lisp_Object *start_pos_ptr; + Lisp_Object start_pos; + + position = Qnil; + + /* Build the position as appropriate for this mouse click. */ + if (event->kind == MOUSE_CLICK_EVENT +#ifdef HAVE_GPM + || event->kind == GPM_CLICK_EVENT +#endif + ) + { + struct frame *f = XFRAME (event->frame_or_window); + int row, column; + + /* Ignore mouse events that were made on frame that + have been deleted. */ + if (! FRAME_LIVE_P (f)) + return Qnil; + + /* EVENT->x and EVENT->y are frame-relative pixel + coordinates at this place. Under old redisplay, COLUMN + and ROW are set to frame relative glyph coordinates + which are then used to determine whether this click is + in a menu (non-toolkit version). */ + if (!toolkit_menubar_in_use (f)) + { + pixel_to_glyph_coords (f, XINT (event->x), XINT (event->y), + &column, &row, NULL, 1); + + /* In the non-toolkit version, clicks on the menu bar + are ordinary button events in the event buffer. + Distinguish them, and invoke the menu. + + (In the toolkit version, the toolkit handles the + menu bar and Emacs doesn't know about it until + after the user makes a selection.) */ + if (row >= 0 && row < FRAME_MENU_BAR_LINES (f) + && (event->modifiers & down_modifier)) + { + Lisp_Object items, item; + + /* Find the menu bar item under `column'. */ + item = Qnil; + items = FRAME_MENU_BAR_ITEMS (f); + for (i = 0; i < ASIZE (items); i += 4) + { + Lisp_Object pos, string; + string = AREF (items, i + 1); + pos = AREF (items, i + 3); + if (NILP (string)) + break; + if (column >= XINT (pos) + && column < XINT (pos) + SCHARS (string)) + { + item = AREF (items, i); + break; + } + } + + /* ELisp manual 2.4b says (x y) are window + relative but code says they are + frame-relative. */ + position = list4 (event->frame_or_window, + Qmenu_bar, + Fcons (event->x, event->y), + make_number (event->timestamp)); + + return list2 (item, position); + } + } + + position = make_lispy_position (f, event->x, event->y, + event->timestamp); + } +#ifndef USE_TOOLKIT_SCROLL_BARS + else + /* It's a scrollbar click. */ + position = make_scroll_bar_position (event, Qvertical_scroll_bar); +#endif /* not USE_TOOLKIT_SCROLL_BARS */ + + if (button >= ASIZE (button_down_location)) + { + ptrdiff_t incr = button - ASIZE (button_down_location) + 1; + button_down_location = larger_vector (button_down_location, + incr, -1); + mouse_syms = larger_vector (mouse_syms, incr, -1); + } + + start_pos_ptr = aref_addr (button_down_location, button); + start_pos = *start_pos_ptr; + *start_pos_ptr = Qnil; + + { + /* On window-system frames, use the value of + double-click-fuzz as is. On other frames, interpret it + as a multiple of 1/8 characters. */ + struct frame *f; + int fuzz; + + if (WINDOWP (event->frame_or_window)) + f = XFRAME (XWINDOW (event->frame_or_window)->frame); + else if (FRAMEP (event->frame_or_window)) + f = XFRAME (event->frame_or_window); + else + emacs_abort (); + + if (FRAME_WINDOW_P (f)) + fuzz = double_click_fuzz; + else + fuzz = double_click_fuzz / 8; + + is_double = (button == last_mouse_button + && (eabs (XINT (event->x) - last_mouse_x) <= fuzz) + && (eabs (XINT (event->y) - last_mouse_y) <= fuzz) + && button_down_time != 0 + && (EQ (Vdouble_click_time, Qt) + || (NATNUMP (Vdouble_click_time) + && (event->timestamp - button_down_time + < XFASTINT (Vdouble_click_time))))); + } + + last_mouse_button = button; + last_mouse_x = XINT (event->x); + last_mouse_y = XINT (event->y); + + /* If this is a button press, squirrel away the location, so + we can decide later whether it was a click or a drag. */ + if (event->modifiers & down_modifier) + { + if (is_double) + { + double_click_count++; + event->modifiers |= ((double_click_count > 2) + ? triple_modifier + : double_modifier); + } + else + double_click_count = 1; + button_down_time = event->timestamp; + *start_pos_ptr = Fcopy_alist (position); + ignore_mouse_drag_p = 0; + } + + /* Now we're releasing a button - check the co-ordinates to + see if this was a click or a drag. */ + else if (event->modifiers & up_modifier) + { + /* If we did not see a down before this up, ignore the up. + Probably this happened because the down event chose a + menu item. It would be an annoyance to treat the + release of the button that chose the menu item as a + separate event. */ + + if (!CONSP (start_pos)) + return Qnil; + + event->modifiers &= ~up_modifier; + + { + Lisp_Object new_down, down; + EMACS_INT xdiff = double_click_fuzz, ydiff = double_click_fuzz; + + /* The third element of every position + should be the (x,y) pair. */ + down = Fcar (Fcdr (Fcdr (start_pos))); + new_down = Fcar (Fcdr (Fcdr (position))); + + if (CONSP (down) + && INTEGERP (XCAR (down)) && INTEGERP (XCDR (down))) + { + xdiff = XINT (XCAR (new_down)) - XINT (XCAR (down)); + ydiff = XINT (XCDR (new_down)) - XINT (XCDR (down)); + } + + if (ignore_mouse_drag_p) + { + event->modifiers |= click_modifier; + ignore_mouse_drag_p = 0; + } + else if (xdiff < double_click_fuzz && xdiff > - double_click_fuzz + && ydiff < double_click_fuzz && ydiff > - double_click_fuzz + /* Maybe the mouse has moved a lot, caused scrolling, and + eventually ended up at the same screen position (but + not buffer position) in which case it is a drag, not + a click. */ + /* FIXME: OTOH if the buffer position has changed + because of a timer or process filter rather than + because of mouse movement, it should be considered as + a click. But mouse-drag-region completely ignores + this case and it hasn't caused any real problem, so + it's probably OK to ignore it as well. */ + && EQ (Fcar (Fcdr (start_pos)), Fcar (Fcdr (position)))) + /* Mouse hasn't moved (much). */ + event->modifiers |= click_modifier; + else + { + button_down_time = 0; + event->modifiers |= drag_modifier; + } + + /* Don't check is_double; treat this as multiple + if the down-event was multiple. */ + if (double_click_count > 1) + event->modifiers |= ((double_click_count > 2) + ? triple_modifier + : double_modifier); + } + } + else + /* Every mouse event should either have the down_modifier or + the up_modifier set. */ + emacs_abort (); + + { + /* Get the symbol we should use for the mouse click. */ + Lisp_Object head; + + head = modify_event_symbol (button, + event->modifiers, + Qmouse_click, Vlispy_mouse_stem, + NULL, + &mouse_syms, + ASIZE (mouse_syms)); + if (event->modifiers & drag_modifier) + return list3 (head, start_pos, position); + else if (event->modifiers & (double_modifier | triple_modifier)) + return list3 (head, position, make_number (double_click_count)); + else + return list2 (head, position); + } + } + + case WHEEL_EVENT: + case HORIZ_WHEEL_EVENT: + { + Lisp_Object position; + Lisp_Object head; + + /* Build the position as appropriate for this mouse click. */ + struct frame *f = XFRAME (event->frame_or_window); + + /* Ignore wheel events that were made on frame that have been + deleted. */ + if (! FRAME_LIVE_P (f)) + return Qnil; + + position = make_lispy_position (f, event->x, event->y, + event->timestamp); + + /* Set double or triple modifiers to indicate the wheel speed. */ + { + /* On window-system frames, use the value of + double-click-fuzz as is. On other frames, interpret it + as a multiple of 1/8 characters. */ + struct frame *fr; + int fuzz; + int symbol_num; + bool is_double; + + if (WINDOWP (event->frame_or_window)) + fr = XFRAME (XWINDOW (event->frame_or_window)->frame); + else if (FRAMEP (event->frame_or_window)) + fr = XFRAME (event->frame_or_window); + else + emacs_abort (); + + fuzz = FRAME_WINDOW_P (fr) + ? double_click_fuzz : double_click_fuzz / 8; + + if (event->modifiers & up_modifier) + { + /* Emit a wheel-up event. */ + event->modifiers &= ~up_modifier; + symbol_num = 0; + } + else if (event->modifiers & down_modifier) + { + /* Emit a wheel-down event. */ + event->modifiers &= ~down_modifier; + symbol_num = 1; + } + else + /* Every wheel event should either have the down_modifier or + the up_modifier set. */ + emacs_abort (); + + if (event->kind == HORIZ_WHEEL_EVENT) + symbol_num += 2; + + is_double = (last_mouse_button == - (1 + symbol_num) + && (eabs (XINT (event->x) - last_mouse_x) <= fuzz) + && (eabs (XINT (event->y) - last_mouse_y) <= fuzz) + && button_down_time != 0 + && (EQ (Vdouble_click_time, Qt) + || (NATNUMP (Vdouble_click_time) + && (event->timestamp - button_down_time + < XFASTINT (Vdouble_click_time))))); + if (is_double) + { + double_click_count++; + event->modifiers |= ((double_click_count > 2) + ? triple_modifier + : double_modifier); + } + else + { + double_click_count = 1; + event->modifiers |= click_modifier; + } + + button_down_time = event->timestamp; + /* Use a negative value to distinguish wheel from mouse button. */ + last_mouse_button = - (1 + symbol_num); + last_mouse_x = XINT (event->x); + last_mouse_y = XINT (event->y); + + /* Get the symbol we should use for the wheel event. */ + head = modify_event_symbol (symbol_num, + event->modifiers, + Qmouse_click, + Qnil, + lispy_wheel_names, + &wheel_syms, + ASIZE (wheel_syms)); + } + + if (event->modifiers & (double_modifier | triple_modifier)) + return list3 (head, position, make_number (double_click_count)); + else + return list2 (head, position); + } + + +#ifdef USE_TOOLKIT_SCROLL_BARS + + /* We don't have down and up events if using toolkit scroll bars, + so make this always a click event. Store in the `part' of + the Lisp event a symbol which maps to the following actions: + + `above_handle' page up + `below_handle' page down + `up' line up + `down' line down + `top' top of buffer + `bottom' bottom of buffer + `handle' thumb has been dragged. + `end-scroll' end of interaction with scroll bar + + The incoming input_event contains in its `part' member an + index of type `enum scroll_bar_part' which we can use as an + index in scroll_bar_parts to get the appropriate symbol. */ + + case SCROLL_BAR_CLICK_EVENT: + { + Lisp_Object position, head; + + position = make_scroll_bar_position (event, Qvertical_scroll_bar); + + /* Always treat scroll bar events as clicks. */ + event->modifiers |= click_modifier; + event->modifiers &= ~up_modifier; + + if (event->code >= ASIZE (mouse_syms)) + mouse_syms = larger_vector (mouse_syms, + event->code - ASIZE (mouse_syms) + 1, + -1); + + /* Get the symbol we should use for the mouse click. */ + head = modify_event_symbol (event->code, + event->modifiers, + Qmouse_click, + Vlispy_mouse_stem, + NULL, &mouse_syms, + ASIZE (mouse_syms)); + return list2 (head, position); + } + + case HORIZONTAL_SCROLL_BAR_CLICK_EVENT: + { + Lisp_Object position, head; + + position = make_scroll_bar_position (event, Qhorizontal_scroll_bar); + + /* Always treat scroll bar events as clicks. */ + event->modifiers |= click_modifier; + event->modifiers &= ~up_modifier; + + if (event->code >= ASIZE (mouse_syms)) + mouse_syms = larger_vector (mouse_syms, + event->code - ASIZE (mouse_syms) + 1, + -1); + + /* Get the symbol we should use for the mouse click. */ + head = modify_event_symbol (event->code, + event->modifiers, + Qmouse_click, + Vlispy_mouse_stem, + NULL, &mouse_syms, + ASIZE (mouse_syms)); + return list2 (head, position); + } + +#endif /* USE_TOOLKIT_SCROLL_BARS */ + + case DRAG_N_DROP_EVENT: + { + struct frame *f; + Lisp_Object head, position; + Lisp_Object files; + + f = XFRAME (event->frame_or_window); + files = event->arg; + + /* Ignore mouse events that were made on frames that + have been deleted. */ + if (! FRAME_LIVE_P (f)) + return Qnil; + + position = make_lispy_position (f, event->x, event->y, + event->timestamp); + + head = modify_event_symbol (0, event->modifiers, + Qdrag_n_drop, Qnil, + lispy_drag_n_drop_names, + &drag_n_drop_syms, 1); + return list3 (head, position, files); + } + +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) || defined (USE_GTK) + case MENU_BAR_EVENT: + if (EQ (event->arg, event->frame_or_window)) + /* This is the prefix key. We translate this to + `(menu_bar)' because the code in keyboard.c for menu + events, which we use, relies on this. */ + return list1 (Qmenu_bar); + return event->arg; +#endif + + case SELECT_WINDOW_EVENT: + /* Make an event (select-window (WINDOW)). */ + return list2 (Qselect_window, list1 (event->frame_or_window)); + + case TOOL_BAR_EVENT: + if (EQ (event->arg, event->frame_or_window)) + /* This is the prefix key. We translate this to + `(tool_bar)' because the code in keyboard.c for tool bar + events, which we use, relies on this. */ + return list1 (Qtool_bar); + else if (SYMBOLP (event->arg)) + return apply_modifiers (event->modifiers, event->arg); + return event->arg; + + case USER_SIGNAL_EVENT: + /* A user signal. */ + { + char *name = find_user_signal_name (event->code); + if (!name) + emacs_abort (); + return intern (name); + } + + case SAVE_SESSION_EVENT: + return Qsave_session; + +#ifdef HAVE_DBUS + case DBUS_EVENT: + { + return Fcons (Qdbus_event, event->arg); + } +#endif /* HAVE_DBUS */ + +#if defined HAVE_GFILENOTIFY || defined HAVE_INOTIFY + case FILE_NOTIFY_EVENT: + { + return Fcons (Qfile_notify, event->arg); + } +#endif /* defined HAVE_GFILENOTIFY || defined HAVE_INOTIFY */ + + case CONFIG_CHANGED_EVENT: + return list3 (Qconfig_changed_event, + event->arg, event->frame_or_window); + + /* The 'kind' field of the event is something we don't recognize. */ + default: + emacs_abort (); + } +} + +static Lisp_Object +make_lispy_movement (struct frame *frame, Lisp_Object bar_window, enum scroll_bar_part part, + Lisp_Object x, Lisp_Object y, Time t) +{ + /* Is it a scroll bar movement? */ + if (frame && ! NILP (bar_window)) + { + Lisp_Object part_sym; + + part_sym = builtin_lisp_symbol (scroll_bar_parts[part]); + return list2 (Qscroll_bar_movement, + list5 (bar_window, + Qvertical_scroll_bar, + Fcons (x, y), + make_number (t), + part_sym)); + } + /* Or is it an ordinary mouse movement? */ + else + { + Lisp_Object position; + position = make_lispy_position (frame, x, y, t); + return list2 (Qmouse_movement, position); + } +} + +/* Construct a switch frame event. */ +static Lisp_Object +make_lispy_switch_frame (Lisp_Object frame) +{ + return list2 (Qswitch_frame, frame); +} + +static Lisp_Object +make_lispy_focus_in (Lisp_Object frame) +{ + return list2 (Qfocus_in, frame); +} + +#ifdef HAVE_WINDOW_SYSTEM + +static Lisp_Object +make_lispy_focus_out (Lisp_Object frame) +{ + return list2 (Qfocus_out, frame); +} + +#endif /* HAVE_WINDOW_SYSTEM */ + +/* Manipulating modifiers. */ + +/* Parse the name of SYMBOL, and return the set of modifiers it contains. + + If MODIFIER_END is non-zero, set *MODIFIER_END to the position in + SYMBOL's name of the end of the modifiers; the string from this + position is the unmodified symbol name. + + This doesn't use any caches. */ + +static int +parse_modifiers_uncached (Lisp_Object symbol, ptrdiff_t *modifier_end) +{ + Lisp_Object name; + ptrdiff_t i; + int modifiers; + + CHECK_SYMBOL (symbol); + + modifiers = 0; + name = SYMBOL_NAME (symbol); + + for (i = 0; i < SBYTES (name) - 1; ) + { + ptrdiff_t this_mod_end = 0; + int this_mod = 0; + + /* See if the name continues with a modifier word. + Check that the word appears, but don't check what follows it. + Set this_mod and this_mod_end to record what we find. */ + + switch (SREF (name, i)) + { +#define SINGLE_LETTER_MOD(BIT) \ + (this_mod_end = i + 1, this_mod = BIT) + + case 'A': + SINGLE_LETTER_MOD (alt_modifier); + break; + + case 'C': + SINGLE_LETTER_MOD (ctrl_modifier); + break; + + case 'H': + SINGLE_LETTER_MOD (hyper_modifier); + break; + + case 'M': + SINGLE_LETTER_MOD (meta_modifier); + break; + + case 'S': + SINGLE_LETTER_MOD (shift_modifier); + break; + + case 's': + SINGLE_LETTER_MOD (super_modifier); + break; + +#undef SINGLE_LETTER_MOD + +#define MULTI_LETTER_MOD(BIT, NAME, LEN) \ + if (i + LEN + 1 <= SBYTES (name) \ + && ! memcmp (SDATA (name) + i, NAME, LEN)) \ + { \ + this_mod_end = i + LEN; \ + this_mod = BIT; \ + } + + case 'd': + MULTI_LETTER_MOD (drag_modifier, "drag", 4); + MULTI_LETTER_MOD (down_modifier, "down", 4); + MULTI_LETTER_MOD (double_modifier, "double", 6); + break; + + case 't': + MULTI_LETTER_MOD (triple_modifier, "triple", 6); + break; +#undef MULTI_LETTER_MOD + + } + + /* If we found no modifier, stop looking for them. */ + if (this_mod_end == 0) + break; + + /* Check there is a dash after the modifier, so that it + really is a modifier. */ + if (this_mod_end >= SBYTES (name) + || SREF (name, this_mod_end) != '-') + break; + + /* This modifier is real; look for another. */ + modifiers |= this_mod; + i = this_mod_end + 1; + } + + /* Should we include the `click' modifier? */ + if (! (modifiers & (down_modifier | drag_modifier + | double_modifier | triple_modifier)) + && i + 7 == SBYTES (name) + && memcmp (SDATA (name) + i, "mouse-", 6) == 0 + && ('0' <= SREF (name, i + 6) && SREF (name, i + 6) <= '9')) + modifiers |= click_modifier; + + if (! (modifiers & (double_modifier | triple_modifier)) + && i + 6 < SBYTES (name) + && memcmp (SDATA (name) + i, "wheel-", 6) == 0) + modifiers |= click_modifier; + + if (modifier_end) + *modifier_end = i; + + return modifiers; +} + +/* Return a symbol whose name is the modifier prefixes for MODIFIERS + prepended to the string BASE[0..BASE_LEN-1]. + This doesn't use any caches. */ +static Lisp_Object +apply_modifiers_uncached (int modifiers, char *base, int base_len, int base_len_byte) +{ + /* Since BASE could contain nulls, we can't use intern here; we have + to use Fintern, which expects a genuine Lisp_String, and keeps a + reference to it. */ + char new_mods[sizeof "A-C-H-M-S-s-down-drag-double-triple-"]; + int mod_len; + + { + char *p = new_mods; + + /* Only the event queue may use the `up' modifier; it should always + be turned into a click or drag event before presented to lisp code. */ + if (modifiers & up_modifier) + emacs_abort (); + + if (modifiers & alt_modifier) { *p++ = 'A'; *p++ = '-'; } + if (modifiers & ctrl_modifier) { *p++ = 'C'; *p++ = '-'; } + if (modifiers & hyper_modifier) { *p++ = 'H'; *p++ = '-'; } + if (modifiers & meta_modifier) { *p++ = 'M'; *p++ = '-'; } + if (modifiers & shift_modifier) { *p++ = 'S'; *p++ = '-'; } + if (modifiers & super_modifier) { *p++ = 's'; *p++ = '-'; } + if (modifiers & double_modifier) p = stpcpy (p, "double-"); + if (modifiers & triple_modifier) p = stpcpy (p, "triple-"); + if (modifiers & down_modifier) p = stpcpy (p, "down-"); + if (modifiers & drag_modifier) p = stpcpy (p, "drag-"); + /* The click modifier is denoted by the absence of other modifiers. */ + + *p = '\0'; + + mod_len = p - new_mods; + } + + { + Lisp_Object new_name; + + new_name = make_uninit_multibyte_string (mod_len + base_len, + mod_len + base_len_byte); + memcpy (SDATA (new_name), new_mods, mod_len); + memcpy (SDATA (new_name) + mod_len, base, base_len_byte); + + return Fintern (new_name, Qnil); + } +} + + +static const char *const modifier_names[] = +{ + "up", "down", "drag", "click", "double", "triple", 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, "alt", "super", "hyper", "shift", "control", "meta" +}; +#define NUM_MOD_NAMES ARRAYELTS (modifier_names) + +static Lisp_Object modifier_symbols; + +/* Return the list of modifier symbols corresponding to the mask MODIFIERS. */ +static Lisp_Object +lispy_modifier_list (int modifiers) +{ + Lisp_Object modifier_list; + int i; + + modifier_list = Qnil; + for (i = 0; (1<<i) <= modifiers && i < NUM_MOD_NAMES; i++) + if (modifiers & (1<<i)) + modifier_list = Fcons (AREF (modifier_symbols, i), + modifier_list); + + return modifier_list; +} + + +/* Parse the modifiers on SYMBOL, and return a list like (UNMODIFIED MASK), + where UNMODIFIED is the unmodified form of SYMBOL, + MASK is the set of modifiers present in SYMBOL's name. + This is similar to parse_modifiers_uncached, but uses the cache in + SYMBOL's Qevent_symbol_element_mask property, and maintains the + Qevent_symbol_elements property. */ + +#define KEY_TO_CHAR(k) (XINT (k) & ((1 << CHARACTERBITS) - 1)) + +Lisp_Object +parse_modifiers (Lisp_Object symbol) +{ + Lisp_Object elements; + + if (INTEGERP (symbol)) + return list2i (KEY_TO_CHAR (symbol), XINT (symbol) & CHAR_MODIFIER_MASK); + else if (!SYMBOLP (symbol)) + return Qnil; + + elements = Fget (symbol, Qevent_symbol_element_mask); + if (CONSP (elements)) + return elements; + else + { + ptrdiff_t end; + int modifiers = parse_modifiers_uncached (symbol, &end); + Lisp_Object unmodified; + Lisp_Object mask; + + unmodified = Fintern (make_string (SSDATA (SYMBOL_NAME (symbol)) + end, + SBYTES (SYMBOL_NAME (symbol)) - end), + Qnil); + + if (modifiers & ~INTMASK) + emacs_abort (); + XSETFASTINT (mask, modifiers); + elements = list2 (unmodified, mask); + + /* Cache the parsing results on SYMBOL. */ + Fput (symbol, Qevent_symbol_element_mask, + elements); + Fput (symbol, Qevent_symbol_elements, + Fcons (unmodified, lispy_modifier_list (modifiers))); + + /* Since we know that SYMBOL is modifiers applied to unmodified, + it would be nice to put that in unmodified's cache. + But we can't, since we're not sure that parse_modifiers is + canonical. */ + + return elements; + } +} + +DEFUN ("internal-event-symbol-parse-modifiers", Fevent_symbol_parse_modifiers, + Sevent_symbol_parse_modifiers, 1, 1, 0, + doc: /* Parse the event symbol. For internal use. */) + (Lisp_Object symbol) +{ + /* Fill the cache if needed. */ + parse_modifiers (symbol); + /* Ignore the result (which is stored on Qevent_symbol_element_mask) + and use the Lispier representation stored on Qevent_symbol_elements + instead. */ + return Fget (symbol, Qevent_symbol_elements); +} + +/* Apply the modifiers MODIFIERS to the symbol BASE. + BASE must be unmodified. + + This is like apply_modifiers_uncached, but uses BASE's + Qmodifier_cache property, if present. It also builds + Qevent_symbol_elements properties, since it has that info anyway. + + apply_modifiers copies the value of BASE's Qevent_kind property to + the modified symbol. */ +static Lisp_Object +apply_modifiers (int modifiers, Lisp_Object base) +{ + Lisp_Object cache, idx, entry, new_symbol; + + /* Mask out upper bits. We don't know where this value's been. */ + modifiers &= INTMASK; + + if (INTEGERP (base)) + return make_number (XINT (base) | modifiers); + + /* The click modifier never figures into cache indices. */ + cache = Fget (base, Qmodifier_cache); + XSETFASTINT (idx, (modifiers & ~click_modifier)); + entry = assq_no_quit (idx, cache); + + if (CONSP (entry)) + new_symbol = XCDR (entry); + else + { + /* We have to create the symbol ourselves. */ + new_symbol = apply_modifiers_uncached (modifiers, + SSDATA (SYMBOL_NAME (base)), + SCHARS (SYMBOL_NAME (base)), + SBYTES (SYMBOL_NAME (base))); + + /* Add the new symbol to the base's cache. */ + entry = Fcons (idx, new_symbol); + Fput (base, Qmodifier_cache, Fcons (entry, cache)); + + /* We have the parsing info now for free, so we could add it to + the caches: + XSETFASTINT (idx, modifiers); + Fput (new_symbol, Qevent_symbol_element_mask, + list2 (base, idx)); + Fput (new_symbol, Qevent_symbol_elements, + Fcons (base, lispy_modifier_list (modifiers))); + Sadly, this is only correct if `base' is indeed a base event, + which is not necessarily the case. -stef */ + } + + /* Make sure this symbol is of the same kind as BASE. + + You'd think we could just set this once and for all when we + intern the symbol above, but reorder_modifiers may call us when + BASE's property isn't set right; we can't assume that just + because it has a Qmodifier_cache property it must have its + Qevent_kind set right as well. */ + if (NILP (Fget (new_symbol, Qevent_kind))) + { + Lisp_Object kind; + + kind = Fget (base, Qevent_kind); + if (! NILP (kind)) + Fput (new_symbol, Qevent_kind, kind); + } + + return new_symbol; +} + + +/* Given a symbol whose name begins with modifiers ("C-", "M-", etc), + return a symbol with the modifiers placed in the canonical order. + Canonical order is alphabetical, except for down and drag, which + always come last. The 'click' modifier is never written out. + + Fdefine_key calls this to make sure that (for example) C-M-foo + and M-C-foo end up being equivalent in the keymap. */ + +Lisp_Object +reorder_modifiers (Lisp_Object symbol) +{ + /* It's hopefully okay to write the code this way, since everything + will soon be in caches, and no consing will be done at all. */ + Lisp_Object parsed; + + parsed = parse_modifiers (symbol); + return apply_modifiers (XFASTINT (XCAR (XCDR (parsed))), + XCAR (parsed)); +} + + +/* For handling events, we often want to produce a symbol whose name + is a series of modifier key prefixes ("M-", "C-", etcetera) attached + to some base, like the name of a function key or mouse button. + modify_event_symbol produces symbols of this sort. + + NAME_TABLE should point to an array of strings, such that NAME_TABLE[i] + is the name of the i'th symbol. TABLE_SIZE is the number of elements + in the table. + + Alternatively, NAME_ALIST_OR_STEM is either an alist mapping codes + into symbol names, or a string specifying a name stem used to + construct a symbol name or the form `STEM-N', where N is the decimal + representation of SYMBOL_NUM. NAME_ALIST_OR_STEM is used if it is + non-nil; otherwise NAME_TABLE is used. + + SYMBOL_TABLE should be a pointer to a Lisp_Object whose value will + persist between calls to modify_event_symbol that it can use to + store a cache of the symbols it's generated for this NAME_TABLE + before. The object stored there may be a vector or an alist. + + SYMBOL_NUM is the number of the base name we want from NAME_TABLE. + + MODIFIERS is a set of modifier bits (as given in struct input_events) + whose prefixes should be applied to the symbol name. + + SYMBOL_KIND is the value to be placed in the event_kind property of + the returned symbol. + + The symbols we create are supposed to have an + `event-symbol-elements' property, which lists the modifiers present + in the symbol's name. */ + +static Lisp_Object +modify_event_symbol (ptrdiff_t symbol_num, int modifiers, Lisp_Object symbol_kind, + Lisp_Object name_alist_or_stem, const char *const *name_table, + Lisp_Object *symbol_table, ptrdiff_t table_size) +{ + Lisp_Object value; + Lisp_Object symbol_int; + + /* Get rid of the "vendor-specific" bit here. */ + XSETINT (symbol_int, symbol_num & 0xffffff); + + /* Is this a request for a valid symbol? */ + if (symbol_num < 0 || symbol_num >= table_size) + return Qnil; + + if (CONSP (*symbol_table)) + value = Fcdr (assq_no_quit (symbol_int, *symbol_table)); + + /* If *symbol_table doesn't seem to be initialized properly, fix that. + *symbol_table should be a lisp vector TABLE_SIZE elements long, + where the Nth element is the symbol for NAME_TABLE[N], or nil if + we've never used that symbol before. */ + else + { + if (! VECTORP (*symbol_table) + || ASIZE (*symbol_table) != table_size) + { + Lisp_Object size; + + XSETFASTINT (size, table_size); + *symbol_table = Fmake_vector (size, Qnil); + } + + value = AREF (*symbol_table, symbol_num); + } + + /* Have we already used this symbol before? */ + if (NILP (value)) + { + /* No; let's create it. */ + if (CONSP (name_alist_or_stem)) + value = Fcdr_safe (Fassq (symbol_int, name_alist_or_stem)); + else if (STRINGP (name_alist_or_stem)) + { + char *buf; + ptrdiff_t len = (SBYTES (name_alist_or_stem) + + sizeof "-" + INT_STRLEN_BOUND (EMACS_INT)); + USE_SAFE_ALLOCA; + buf = SAFE_ALLOCA (len); + esprintf (buf, "%s-%"pI"d", SDATA (name_alist_or_stem), + XINT (symbol_int) + 1); + value = intern (buf); + SAFE_FREE (); + } + else if (name_table != 0 && name_table[symbol_num]) + value = intern (name_table[symbol_num]); + +#ifdef HAVE_WINDOW_SYSTEM + if (NILP (value)) + { + char *name = x_get_keysym_name (symbol_num); + if (name) + value = intern (name); + } +#endif + + if (NILP (value)) + { + char buf[sizeof "key-" + INT_STRLEN_BOUND (EMACS_INT)]; + sprintf (buf, "key-%"pD"d", symbol_num); + value = intern (buf); + } + + if (CONSP (*symbol_table)) + *symbol_table = Fcons (Fcons (symbol_int, value), *symbol_table); + else + ASET (*symbol_table, symbol_num, value); + + /* Fill in the cache entries for this symbol; this also + builds the Qevent_symbol_elements property, which the user + cares about. */ + apply_modifiers (modifiers & click_modifier, value); + Fput (value, Qevent_kind, symbol_kind); + } + + /* Apply modifiers to that symbol. */ + return apply_modifiers (modifiers, value); +} + +/* Convert a list that represents an event type, + such as (ctrl meta backspace), into the usual representation of that + event type as a number or a symbol. */ + +DEFUN ("event-convert-list", Fevent_convert_list, Sevent_convert_list, 1, 1, 0, + doc: /* Convert the event description list EVENT-DESC to an event type. +EVENT-DESC should contain one base event type (a character or symbol) +and zero or more modifier names (control, meta, hyper, super, shift, alt, +drag, down, double or triple). The base must be last. +The return value is an event type (a character or symbol) which +has the same base event type and all the specified modifiers. */) + (Lisp_Object event_desc) +{ + Lisp_Object base; + int modifiers = 0; + Lisp_Object rest; + + base = Qnil; + rest = event_desc; + while (CONSP (rest)) + { + Lisp_Object elt; + int this = 0; + + elt = XCAR (rest); + rest = XCDR (rest); + + /* Given a symbol, see if it is a modifier name. */ + if (SYMBOLP (elt) && CONSP (rest)) + this = parse_solitary_modifier (elt); + + if (this != 0) + modifiers |= this; + else if (!NILP (base)) + error ("Two bases given in one event"); + else + base = elt; + + } + + /* Let the symbol A refer to the character A. */ + if (SYMBOLP (base) && SCHARS (SYMBOL_NAME (base)) == 1) + XSETINT (base, SREF (SYMBOL_NAME (base), 0)); + + if (INTEGERP (base)) + { + /* Turn (shift a) into A. */ + if ((modifiers & shift_modifier) != 0 + && (XINT (base) >= 'a' && XINT (base) <= 'z')) + { + XSETINT (base, XINT (base) - ('a' - 'A')); + modifiers &= ~shift_modifier; + } + + /* Turn (control a) into C-a. */ + if (modifiers & ctrl_modifier) + return make_number ((modifiers & ~ctrl_modifier) + | make_ctrl_char (XINT (base))); + else + return make_number (modifiers | XINT (base)); + } + else if (SYMBOLP (base)) + return apply_modifiers (modifiers, base); + else + error ("Invalid base event"); +} + +/* Try to recognize SYMBOL as a modifier name. + Return the modifier flag bit, or 0 if not recognized. */ + +int +parse_solitary_modifier (Lisp_Object symbol) +{ + Lisp_Object name = SYMBOL_NAME (symbol); + + switch (SREF (name, 0)) + { +#define SINGLE_LETTER_MOD(BIT) \ + if (SBYTES (name) == 1) \ + return BIT; + +#define MULTI_LETTER_MOD(BIT, NAME, LEN) \ + if (LEN == SBYTES (name) \ + && ! memcmp (SDATA (name), NAME, LEN)) \ + return BIT; + + case 'A': + SINGLE_LETTER_MOD (alt_modifier); + break; + + case 'a': + MULTI_LETTER_MOD (alt_modifier, "alt", 3); + break; + + case 'C': + SINGLE_LETTER_MOD (ctrl_modifier); + break; + + case 'c': + MULTI_LETTER_MOD (ctrl_modifier, "ctrl", 4); + MULTI_LETTER_MOD (ctrl_modifier, "control", 7); + break; + + case 'H': + SINGLE_LETTER_MOD (hyper_modifier); + break; + + case 'h': + MULTI_LETTER_MOD (hyper_modifier, "hyper", 5); + break; + + case 'M': + SINGLE_LETTER_MOD (meta_modifier); + break; + + case 'm': + MULTI_LETTER_MOD (meta_modifier, "meta", 4); + break; + + case 'S': + SINGLE_LETTER_MOD (shift_modifier); + break; + + case 's': + MULTI_LETTER_MOD (shift_modifier, "shift", 5); + MULTI_LETTER_MOD (super_modifier, "super", 5); + SINGLE_LETTER_MOD (super_modifier); + break; + + case 'd': + MULTI_LETTER_MOD (drag_modifier, "drag", 4); + MULTI_LETTER_MOD (down_modifier, "down", 4); + MULTI_LETTER_MOD (double_modifier, "double", 6); + break; + + case 't': + MULTI_LETTER_MOD (triple_modifier, "triple", 6); + break; + +#undef SINGLE_LETTER_MOD +#undef MULTI_LETTER_MOD + } + + return 0; +} + +/* Return true if EVENT is a list whose elements are all integers or symbols. + Such a list is not valid as an event, + but it can be a Lucid-style event type list. */ + +bool +lucid_event_type_list_p (Lisp_Object object) +{ + Lisp_Object tail; + + if (! CONSP (object)) + return 0; + + if (EQ (XCAR (object), Qhelp_echo) + || EQ (XCAR (object), Qvertical_line) + || EQ (XCAR (object), Qmode_line) + || EQ (XCAR (object), Qheader_line)) + return 0; + + for (tail = object; CONSP (tail); tail = XCDR (tail)) + { + Lisp_Object elt; + elt = XCAR (tail); + if (! (INTEGERP (elt) || SYMBOLP (elt))) + return 0; + } + + return NILP (tail); +} + +/* Return true if terminal input chars are available. + Also, store the return value into INPUT_PENDING. + + Serves the purpose of ioctl (0, FIONREAD, ...) + but works even if FIONREAD does not exist. + (In fact, this may actually read some input.) + + If READABLE_EVENTS_DO_TIMERS_NOW is set in FLAGS, actually run + timer events that are ripe. + If READABLE_EVENTS_FILTER_EVENTS is set in FLAGS, ignore internal + events (FOCUS_IN_EVENT). + If READABLE_EVENTS_IGNORE_SQUEEZABLES is set in FLAGS, ignore mouse + movements and toolkit scroll bar thumb drags. */ + +static bool +get_input_pending (int flags) +{ + /* First of all, have we already counted some input? */ + input_pending = (!NILP (Vquit_flag) || readable_events (flags)); + + /* If input is being read as it arrives, and we have none, there is none. */ + if (!input_pending && (!interrupt_input || interrupts_deferred)) + { + /* Try to read some input and see how much we get. */ + gobble_input (); + input_pending = (!NILP (Vquit_flag) || readable_events (flags)); + } + + return input_pending; +} + +/* Put a BUFFER_SWITCH_EVENT in the buffer + so that read_key_sequence will notice the new current buffer. */ + +void +record_asynch_buffer_change (void) +{ + /* We don't need a buffer-switch event unless Emacs is waiting for input. + The purpose of the event is to make read_key_sequence look up the + keymaps again. If we aren't in read_key_sequence, we don't need one, + and the event could cause trouble by messing up (input-pending-p). + Note: Fwaiting_for_user_input_p always returns nil when async + subprocesses aren't supported. */ + if (!NILP (Fwaiting_for_user_input_p ())) + { + struct input_event event; + + EVENT_INIT (event); + event.kind = BUFFER_SWITCH_EVENT; + event.frame_or_window = Qnil; + event.arg = Qnil; + + /* Make sure no interrupt happens while storing the event. */ +#ifdef USABLE_SIGIO + if (interrupt_input) + kbd_buffer_store_event (&event); + else +#endif + { + stop_polling (); + kbd_buffer_store_event (&event); + start_polling (); + } + } +} + +/* Read any terminal input already buffered up by the system + into the kbd_buffer, but do not wait. + + Return the number of keyboard chars read, or -1 meaning + this is a bad time to try to read input. */ + +int +gobble_input (void) +{ + int nread = 0; + bool err = 0; + struct terminal *t; + + /* Store pending user signal events, if any. */ + store_user_signal_events (); + + /* Loop through the available terminals, and call their input hooks. */ + t = terminal_list; + while (t) + { + struct terminal *next = t->next_terminal; + + if (t->read_socket_hook) + { + int nr; + struct input_event hold_quit; + + if (input_blocked_p ()) + { + pending_signals = 1; + break; + } + + EVENT_INIT (hold_quit); + hold_quit.kind = NO_EVENT; + + /* No need for FIONREAD or fcntl; just say don't wait. */ + while ((nr = (*t->read_socket_hook) (t, &hold_quit)) > 0) + nread += nr; + + if (nr == -1) /* Not OK to read input now. */ + { + err = 1; + } + else if (nr == -2) /* Non-transient error. */ + { + /* The terminal device terminated; it should be closed. */ + + /* Kill Emacs if this was our last terminal. */ + if (!terminal_list->next_terminal) + /* Formerly simply reported no input, but that + sometimes led to a failure of Emacs to terminate. + SIGHUP seems appropriate if we can't reach the + terminal. */ + /* ??? Is it really right to send the signal just to + this process rather than to the whole process + group? Perhaps on systems with FIONREAD Emacs is + alone in its group. */ + terminate_due_to_signal (SIGHUP, 10); + + /* XXX Is calling delete_terminal safe here? It calls delete_frame. */ + { + Lisp_Object tmp; + XSETTERMINAL (tmp, t); + Fdelete_terminal (tmp, Qnoelisp); + } + } + + /* If there was no error, make sure the pointer + is visible for all frames on this terminal. */ + if (nr >= 0) + { + Lisp_Object tail, frame; + + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); + if (FRAME_TERMINAL (f) == t) + frame_make_pointer_visible (f); + } + } + + if (hold_quit.kind != NO_EVENT) + kbd_buffer_store_event (&hold_quit); + } + + t = next; + } + + if (err && !nread) + nread = -1; + + return nread; +} + +/* This is the tty way of reading available input. + + Note that each terminal device has its own `struct terminal' object, + and so this function is called once for each individual termcap + terminal. The first parameter indicates which terminal to read from. */ + +int +tty_read_avail_input (struct terminal *terminal, + struct input_event *hold_quit) +{ + /* Using KBD_BUFFER_SIZE - 1 here avoids reading more than + the kbd_buffer can really hold. That may prevent loss + of characters on some systems when input is stuffed at us. */ + unsigned char cbuf[KBD_BUFFER_SIZE - 1]; + int n_to_read, i; + struct tty_display_info *tty = terminal->display_info.tty; + int nread = 0; +#ifdef subprocesses + int buffer_free = KBD_BUFFER_SIZE - kbd_buffer_nr_stored () - 1; + + if (kbd_on_hold_p () || buffer_free <= 0) + return 0; +#endif /* subprocesses */ + + if (!terminal->name) /* Don't read from a dead terminal. */ + return 0; + + if (terminal->type != output_termcap + && terminal->type != output_msdos_raw) + emacs_abort (); + + /* XXX I think the following code should be moved to separate hook + functions in system-dependent files. */ +#ifdef WINDOWSNT + /* FIXME: AFAIK, tty_read_avail_input is not used under w32 since the non-GUI + code sets read_socket_hook to w32_console_read_socket instead! */ + return 0; +#else /* not WINDOWSNT */ + if (! tty->term_initted) /* In case we get called during bootstrap. */ + return 0; + + if (! tty->input) + return 0; /* The terminal is suspended. */ + +#ifdef MSDOS + n_to_read = dos_keysns (); + if (n_to_read == 0) + return 0; + + cbuf[0] = dos_keyread (); + nread = 1; + +#else /* not MSDOS */ +#ifdef HAVE_GPM + if (gpm_tty == tty) + { + Gpm_Event event; + struct input_event gpm_hold_quit; + int gpm, fd = gpm_fd; + + EVENT_INIT (gpm_hold_quit); + gpm_hold_quit.kind = NO_EVENT; + + /* gpm==1 if event received. + gpm==0 if the GPM daemon has closed the connection, in which case + Gpm_GetEvent closes gpm_fd and clears it to -1, which is why + we save it in `fd' so close_gpm can remove it from the + select masks. + gpm==-1 if a protocol error or EWOULDBLOCK; the latter is normal. */ + while (gpm = Gpm_GetEvent (&event), gpm == 1) { + nread += handle_one_term_event (tty, &event, &gpm_hold_quit); + } + if (gpm == 0) + /* Presumably the GPM daemon has closed the connection. */ + close_gpm (fd); + if (gpm_hold_quit.kind != NO_EVENT) + kbd_buffer_store_event (&gpm_hold_quit); + if (nread) + return nread; + } +#endif /* HAVE_GPM */ + +/* Determine how many characters we should *try* to read. */ +#ifdef USABLE_FIONREAD + /* Find out how much input is available. */ + if (ioctl (fileno (tty->input), FIONREAD, &n_to_read) < 0) + { + if (! noninteractive) + return -2; /* Close this terminal. */ + else + n_to_read = 0; + } + if (n_to_read == 0) + return 0; + if (n_to_read > sizeof cbuf) + n_to_read = sizeof cbuf; +#elif defined USG || defined CYGWIN + /* Read some input if available, but don't wait. */ + n_to_read = sizeof cbuf; + fcntl (fileno (tty->input), F_SETFL, O_NONBLOCK); +#else +# error "Cannot read without possibly delaying" +#endif + +#ifdef subprocesses + /* Don't read more than we can store. */ + if (n_to_read > buffer_free) + n_to_read = buffer_free; +#endif /* subprocesses */ + + /* Now read; for one reason or another, this will not block. + NREAD is set to the number of chars read. */ + do + { + nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read); + /* POSIX infers that processes which are not in the session leader's + process group won't get SIGHUPs at logout time. BSDI adheres to + this part standard and returns -1 from read (0) with errno==EIO + when the control tty is taken away. + Jeffrey Honig <jch@bsdi.com> says this is generally safe. */ + if (nread == -1 && errno == EIO) + return -2; /* Close this terminal. */ +#if defined (AIX) && defined (_BSD) + /* The kernel sometimes fails to deliver SIGHUP for ptys. + This looks incorrect, but it isn't, because _BSD causes + O_NDELAY to be defined in fcntl.h as O_NONBLOCK, + and that causes a value other than 0 when there is no input. */ + if (nread == 0) + return -2; /* Close this terminal. */ +#endif + } + while ( + /* We used to retry the read if it was interrupted. + But this does the wrong thing when O_NONBLOCK causes + an EAGAIN error. Does anybody know of a situation + where a retry is actually needed? */ +#if 0 + nread < 0 && (errno == EAGAIN || errno == EFAULT +#ifdef EBADSLT + || errno == EBADSLT +#endif + ) +#else + 0 +#endif + ); + +#ifndef USABLE_FIONREAD +#if defined (USG) || defined (CYGWIN) + fcntl (fileno (tty->input), F_SETFL, 0); +#endif /* USG or CYGWIN */ +#endif /* no FIONREAD */ + + if (nread <= 0) + return nread; + +#endif /* not MSDOS */ +#endif /* not WINDOWSNT */ + + for (i = 0; i < nread; i++) + { + struct input_event buf; + EVENT_INIT (buf); + buf.kind = ASCII_KEYSTROKE_EVENT; + buf.modifiers = 0; + if (tty->meta_key == 1 && (cbuf[i] & 0x80)) + buf.modifiers = meta_modifier; + if (tty->meta_key != 2) + cbuf[i] &= ~0x80; + + buf.code = cbuf[i]; + /* Set the frame corresponding to the active tty. Note that the + value of selected_frame is not reliable here, redisplay tends + to temporarily change it. */ + buf.frame_or_window = tty->top_frame; + buf.arg = Qnil; + + kbd_buffer_store_event (&buf); + /* Don't look at input that follows a C-g too closely. + This reduces lossage due to autorepeat on C-g. */ + if (buf.kind == ASCII_KEYSTROKE_EVENT + && buf.code == quit_char) + break; + } + + return nread; +} + +static void +handle_async_input (void) +{ +#ifdef USABLE_SIGIO + while (1) + { + int nread = gobble_input (); + /* -1 means it's not ok to read the input now. + UNBLOCK_INPUT will read it later; now, avoid infinite loop. + 0 means there was no keyboard input available. */ + if (nread <= 0) + break; + } +#endif +} + +void +process_pending_signals (void) +{ + pending_signals = 0; + handle_async_input (); + do_pending_atimers (); +} + +/* Undo any number of BLOCK_INPUT calls down to level LEVEL, + and reinvoke any pending signal if the level is now 0 and + a fatal error is not already in progress. */ + +void +unblock_input_to (int level) +{ + interrupt_input_blocked = level; + if (level == 0) + { + if (pending_signals && !fatal_error_in_progress) + process_pending_signals (); + } + else if (level < 0) + emacs_abort (); +} + +/* End critical section. + + If doing signal-driven input, and a signal came in when input was + blocked, reinvoke the signal handler now to deal with it. + + It will also process queued input, if it was not read before. + When a longer code sequence does not use block/unblock input + at all, the whole input gathered up to the next call to + unblock_input will be processed inside that call. */ + +void +unblock_input (void) +{ + unblock_input_to (interrupt_input_blocked - 1); +} + +/* Undo any number of BLOCK_INPUT calls, + and also reinvoke any pending signal. */ + +void +totally_unblock_input (void) +{ + unblock_input_to (0); +} + +#ifdef USABLE_SIGIO + +void +handle_input_available_signal (int sig) +{ + pending_signals = 1; + + if (input_available_clear_time) + *input_available_clear_time = make_timespec (0, 0); +} + +static void +deliver_input_available_signal (int sig) +{ + deliver_process_signal (sig, handle_input_available_signal); +} +#endif /* USABLE_SIGIO */ + + +/* User signal events. */ + +struct user_signal_info +{ + /* Signal number. */ + int sig; + + /* Name of the signal. */ + char *name; + + /* Number of pending signals. */ + int npending; + + struct user_signal_info *next; +}; + +/* List of user signals. */ +static struct user_signal_info *user_signals = NULL; + +void +add_user_signal (int sig, const char *name) +{ + struct sigaction action; + struct user_signal_info *p; + + for (p = user_signals; p; p = p->next) + if (p->sig == sig) + /* Already added. */ + return; + + p = xmalloc (sizeof *p); + p->sig = sig; + p->name = xstrdup (name); + p->npending = 0; + p->next = user_signals; + user_signals = p; + + emacs_sigaction_init (&action, deliver_user_signal); + sigaction (sig, &action, 0); +} + +static void +handle_user_signal (int sig) +{ + struct user_signal_info *p; + const char *special_event_name = NULL; + + if (SYMBOLP (Vdebug_on_event)) + special_event_name = SSDATA (SYMBOL_NAME (Vdebug_on_event)); + + for (p = user_signals; p; p = p->next) + if (p->sig == sig) + { + if (special_event_name + && strcmp (special_event_name, p->name) == 0) + { + /* Enter the debugger in many ways. */ + debug_on_next_call = 1; + debug_on_quit = 1; + Vquit_flag = Qt; + Vinhibit_quit = Qnil; + + /* Eat the event. */ + break; + } + + p->npending++; +#ifdef USABLE_SIGIO + if (interrupt_input) + handle_input_available_signal (sig); + else +#endif + { + /* Tell wait_reading_process_output that it needs to wake + up and look around. */ + if (input_available_clear_time) + *input_available_clear_time = make_timespec (0, 0); + } + break; + } +} + +static void +deliver_user_signal (int sig) +{ + deliver_process_signal (sig, handle_user_signal); +} + +static char * +find_user_signal_name (int sig) +{ + struct user_signal_info *p; + + for (p = user_signals; p; p = p->next) + if (p->sig == sig) + return p->name; + + return NULL; +} + +static void +store_user_signal_events (void) +{ + struct user_signal_info *p; + struct input_event buf; + bool buf_initialized = 0; + + for (p = user_signals; p; p = p->next) + if (p->npending > 0) + { + if (! buf_initialized) + { + memset (&buf, 0, sizeof buf); + buf.kind = USER_SIGNAL_EVENT; + buf.frame_or_window = selected_frame; + buf_initialized = 1; + } + + do + { + buf.code = p->sig; + kbd_buffer_store_event (&buf); + p->npending--; + } + while (p->npending > 0); + } +} + + +static void menu_bar_item (Lisp_Object, Lisp_Object, Lisp_Object, void *); +static Lisp_Object menu_bar_one_keymap_changed_items; + +/* These variables hold the vector under construction within + menu_bar_items and its subroutines, and the current index + for storing into that vector. */ +static Lisp_Object menu_bar_items_vector; +static int menu_bar_items_index; + + +static const char *separator_names[] = { + "space", + "no-line", + "single-line", + "double-line", + "single-dashed-line", + "double-dashed-line", + "shadow-etched-in", + "shadow-etched-out", + "shadow-etched-in-dash", + "shadow-etched-out-dash", + "shadow-double-etched-in", + "shadow-double-etched-out", + "shadow-double-etched-in-dash", + "shadow-double-etched-out-dash", + 0, +}; + +/* Return true if LABEL specifies a separator. */ + +bool +menu_separator_name_p (const char *label) +{ + if (!label) + return 0; + else if (strlen (label) > 3 + && memcmp (label, "--", 2) == 0 + && label[2] != '-') + { + int i; + label += 2; + for (i = 0; separator_names[i]; ++i) + if (strcmp (label, separator_names[i]) == 0) + return 1; + } + else + { + /* It's a separator if it contains only dashes. */ + while (*label == '-') + ++label; + return (*label == 0); + } + + return 0; +} + + +/* Return a vector of menu items for a menu bar, appropriate + to the current buffer. Each item has three elements in the vector: + KEY STRING MAPLIST. + + OLD is an old vector we can optionally reuse, or nil. */ + +Lisp_Object +menu_bar_items (Lisp_Object old) +{ + /* The number of keymaps we're scanning right now, and the number of + keymaps we have allocated space for. */ + ptrdiff_t nmaps; + + /* maps[0..nmaps-1] are the prefix definitions of KEYBUF[0..t-1] + in the current keymaps, or nil where it is not a prefix. */ + Lisp_Object *maps; + + Lisp_Object mapsbuf[3]; + Lisp_Object def, tail; + + ptrdiff_t mapno; + Lisp_Object oquit; + + USE_SAFE_ALLOCA; + + /* In order to build the menus, we need to call the keymap + accessors. They all call QUIT. But this function is called + during redisplay, during which a quit is fatal. So inhibit + quitting while building the menus. + We do this instead of specbind because (1) errors will clear it anyway + and (2) this avoids risk of specpdl overflow. */ + oquit = Vinhibit_quit; + Vinhibit_quit = Qt; + + if (!NILP (old)) + menu_bar_items_vector = old; + else + menu_bar_items_vector = Fmake_vector (make_number (24), Qnil); + menu_bar_items_index = 0; + + /* Build our list of keymaps. + If we recognize a function key and replace its escape sequence in + keybuf with its symbol, or if the sequence starts with a mouse + click and we need to switch buffers, we jump back here to rebuild + the initial keymaps from the current buffer. */ + { + Lisp_Object *tmaps; + + /* Should overriding-terminal-local-map and overriding-local-map apply? */ + if (!NILP (Voverriding_local_map_menu_flag) + && !NILP (Voverriding_local_map)) + { + /* Yes, use them (if non-nil) as well as the global map. */ + maps = mapsbuf; + nmaps = 0; + if (!NILP (KVAR (current_kboard, Voverriding_terminal_local_map))) + maps[nmaps++] = KVAR (current_kboard, Voverriding_terminal_local_map); + if (!NILP (Voverriding_local_map)) + maps[nmaps++] = Voverriding_local_map; + } + else + { + /* No, so use major and minor mode keymaps and keymap property. + Note that menu-bar bindings in the local-map and keymap + properties may not work reliable, as they are only + recognized when the menu-bar (or mode-line) is updated, + which does not normally happen after every command. */ + Lisp_Object tem; + ptrdiff_t nminor; + nminor = current_minor_maps (NULL, &tmaps); + SAFE_NALLOCA (maps, 1, nminor + 4); + nmaps = 0; + tem = KVAR (current_kboard, Voverriding_terminal_local_map); + if (!NILP (tem) && !NILP (Voverriding_local_map_menu_flag)) + maps[nmaps++] = tem; + if (tem = get_local_map (PT, current_buffer, Qkeymap), !NILP (tem)) + maps[nmaps++] = tem; + memcpy (maps + nmaps, tmaps, nminor * sizeof (maps[0])); + nmaps += nminor; + maps[nmaps++] = get_local_map (PT, current_buffer, Qlocal_map); + } + maps[nmaps++] = current_global_map; + } + + /* Look up in each map the dummy prefix key `menu-bar'. */ + + for (mapno = nmaps - 1; mapno >= 0; mapno--) + if (!NILP (maps[mapno])) + { + def = get_keymap (access_keymap (maps[mapno], Qmenu_bar, 1, 0, 1), + 0, 1); + if (CONSP (def)) + { + menu_bar_one_keymap_changed_items = Qnil; + map_keymap_canonical (def, menu_bar_item, Qnil, NULL); + } + } + + /* Move to the end those items that should be at the end. */ + + for (tail = Vmenu_bar_final_items; CONSP (tail); tail = XCDR (tail)) + { + int i; + int end = menu_bar_items_index; + + for (i = 0; i < end; i += 4) + if (EQ (XCAR (tail), AREF (menu_bar_items_vector, i))) + { + Lisp_Object tem0, tem1, tem2, tem3; + /* Move the item at index I to the end, + shifting all the others forward. */ + tem0 = AREF (menu_bar_items_vector, i + 0); + tem1 = AREF (menu_bar_items_vector, i + 1); + tem2 = AREF (menu_bar_items_vector, i + 2); + tem3 = AREF (menu_bar_items_vector, i + 3); + if (end > i + 4) + memmove (aref_addr (menu_bar_items_vector, i), + aref_addr (menu_bar_items_vector, i + 4), + (end - i - 4) * word_size); + ASET (menu_bar_items_vector, end - 4, tem0); + ASET (menu_bar_items_vector, end - 3, tem1); + ASET (menu_bar_items_vector, end - 2, tem2); + ASET (menu_bar_items_vector, end - 1, tem3); + break; + } + } + + /* Add nil, nil, nil, nil at the end. */ + { + int i = menu_bar_items_index; + if (i + 4 > ASIZE (menu_bar_items_vector)) + menu_bar_items_vector + = larger_vector (menu_bar_items_vector, 4, -1); + /* Add this item. */ + ASET (menu_bar_items_vector, i, Qnil); i++; + ASET (menu_bar_items_vector, i, Qnil); i++; + ASET (menu_bar_items_vector, i, Qnil); i++; + ASET (menu_bar_items_vector, i, Qnil); i++; + menu_bar_items_index = i; + } + + Vinhibit_quit = oquit; + SAFE_FREE (); + return menu_bar_items_vector; +} + +/* Add one item to menu_bar_items_vector, for KEY, ITEM_STRING and DEF. + If there's already an item for KEY, add this DEF to it. */ + +Lisp_Object item_properties; + +static void +menu_bar_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy1, void *dummy2) +{ + struct gcpro gcpro1; + int i; + bool parsed; + Lisp_Object tem; + + if (EQ (item, Qundefined)) + { + /* If a map has an explicit `undefined' as definition, + discard any previously made menu bar item. */ + + for (i = 0; i < menu_bar_items_index; i += 4) + if (EQ (key, AREF (menu_bar_items_vector, i))) + { + if (menu_bar_items_index > i + 4) + memmove (aref_addr (menu_bar_items_vector, i), + aref_addr (menu_bar_items_vector, i + 4), + (menu_bar_items_index - i - 4) * word_size); + menu_bar_items_index -= 4; + } + } + + /* If this keymap has already contributed to this KEY, + don't contribute to it a second time. */ + tem = Fmemq (key, menu_bar_one_keymap_changed_items); + if (!NILP (tem) || NILP (item)) + return; + + menu_bar_one_keymap_changed_items + = Fcons (key, menu_bar_one_keymap_changed_items); + + /* We add to menu_bar_one_keymap_changed_items before doing the + parse_menu_item, so that if it turns out it wasn't a menu item, + it still correctly hides any further menu item. */ + GCPRO1 (key); + parsed = parse_menu_item (item, 1); + UNGCPRO; + if (!parsed) + return; + + item = AREF (item_properties, ITEM_PROPERTY_DEF); + + /* Find any existing item for this KEY. */ + for (i = 0; i < menu_bar_items_index; i += 4) + if (EQ (key, AREF (menu_bar_items_vector, i))) + break; + + /* If we did not find this KEY, add it at the end. */ + if (i == menu_bar_items_index) + { + /* If vector is too small, get a bigger one. */ + if (i + 4 > ASIZE (menu_bar_items_vector)) + menu_bar_items_vector = larger_vector (menu_bar_items_vector, 4, -1); + /* Add this item. */ + ASET (menu_bar_items_vector, i, key); i++; + ASET (menu_bar_items_vector, i, + AREF (item_properties, ITEM_PROPERTY_NAME)); i++; + ASET (menu_bar_items_vector, i, list1 (item)); i++; + ASET (menu_bar_items_vector, i, make_number (0)); i++; + menu_bar_items_index = i; + } + /* We did find an item for this KEY. Add ITEM to its list of maps. */ + else + { + Lisp_Object old; + old = AREF (menu_bar_items_vector, i + 2); + /* If the new and the old items are not both keymaps, + the lookup will only find `item'. */ + item = Fcons (item, KEYMAPP (item) && KEYMAPP (XCAR (old)) ? old : Qnil); + ASET (menu_bar_items_vector, i + 2, item); + } +} + + /* This is used as the handler when calling menu_item_eval_property. */ +static Lisp_Object +menu_item_eval_property_1 (Lisp_Object arg) +{ + /* If we got a quit from within the menu computation, + quit all the way out of it. This takes care of C-] in the debugger. */ + if (CONSP (arg) && EQ (XCAR (arg), Qquit)) + Fsignal (Qquit, Qnil); + + return Qnil; +} + +static Lisp_Object +eval_dyn (Lisp_Object form) +{ + return Feval (form, Qnil); +} + +/* Evaluate an expression and return the result (or nil if something + went wrong). Used to evaluate dynamic parts of menu items. */ +Lisp_Object +menu_item_eval_property (Lisp_Object sexpr) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object val; + specbind (Qinhibit_redisplay, Qt); + val = internal_condition_case_1 (eval_dyn, sexpr, Qerror, + menu_item_eval_property_1); + return unbind_to (count, val); +} + +/* This function parses a menu item and leaves the result in the + vector item_properties. + ITEM is a key binding, a possible menu item. + INMENUBAR is > 0 when this is considered for an entry in a menu bar + top level. + INMENUBAR is < 0 when this is considered for an entry in a keyboard menu. + parse_menu_item returns true if the item is a menu item and false + otherwise. */ + +bool +parse_menu_item (Lisp_Object item, int inmenubar) +{ + Lisp_Object def, tem, item_string, start; + Lisp_Object filter; + Lisp_Object keyhint; + int i; + + filter = Qnil; + keyhint = Qnil; + + if (!CONSP (item)) + return 0; + + /* Create item_properties vector if necessary. */ + if (NILP (item_properties)) + item_properties + = Fmake_vector (make_number (ITEM_PROPERTY_ENABLE + 1), Qnil); + + /* Initialize optional entries. */ + for (i = ITEM_PROPERTY_DEF; i < ITEM_PROPERTY_ENABLE; i++) + ASET (item_properties, i, Qnil); + ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt); + + /* Save the item here to protect it from GC. */ + ASET (item_properties, ITEM_PROPERTY_ITEM, item); + + item_string = XCAR (item); + + start = item; + item = XCDR (item); + if (STRINGP (item_string)) + { + /* Old format menu item. */ + ASET (item_properties, ITEM_PROPERTY_NAME, item_string); + + /* Maybe help string. */ + if (CONSP (item) && STRINGP (XCAR (item))) + { + ASET (item_properties, ITEM_PROPERTY_HELP, XCAR (item)); + start = item; + item = XCDR (item); + } + + /* Maybe an obsolete key binding cache. */ + if (CONSP (item) && CONSP (XCAR (item)) + && (NILP (XCAR (XCAR (item))) + || VECTORP (XCAR (XCAR (item))))) + item = XCDR (item); + + /* This is the real definition--the function to run. */ + ASET (item_properties, ITEM_PROPERTY_DEF, item); + + /* Get enable property, if any. */ + if (SYMBOLP (item)) + { + tem = Fget (item, Qmenu_enable); + if (!NILP (Venable_disabled_menus_and_buttons)) + ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt); + else if (!NILP (tem)) + ASET (item_properties, ITEM_PROPERTY_ENABLE, tem); + } + } + else if (EQ (item_string, Qmenu_item) && CONSP (item)) + { + /* New format menu item. */ + ASET (item_properties, ITEM_PROPERTY_NAME, XCAR (item)); + start = XCDR (item); + if (CONSP (start)) + { + /* We have a real binding. */ + ASET (item_properties, ITEM_PROPERTY_DEF, XCAR (start)); + + item = XCDR (start); + /* Is there an obsolete cache list with key equivalences. */ + if (CONSP (item) && CONSP (XCAR (item))) + item = XCDR (item); + + /* Parse properties. */ + while (CONSP (item) && CONSP (XCDR (item))) + { + tem = XCAR (item); + item = XCDR (item); + + if (EQ (tem, QCenable)) + { + if (!NILP (Venable_disabled_menus_and_buttons)) + ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt); + else + ASET (item_properties, ITEM_PROPERTY_ENABLE, XCAR (item)); + } + else if (EQ (tem, QCvisible)) + { + /* If got a visible property and that evaluates to nil + then ignore this item. */ + tem = menu_item_eval_property (XCAR (item)); + if (NILP (tem)) + return 0; + } + else if (EQ (tem, QChelp)) + ASET (item_properties, ITEM_PROPERTY_HELP, XCAR (item)); + else if (EQ (tem, QCfilter)) + filter = item; + else if (EQ (tem, QCkey_sequence)) + { + tem = XCAR (item); + if (SYMBOLP (tem) || STRINGP (tem) || VECTORP (tem)) + /* Be GC protected. Set keyhint to item instead of tem. */ + keyhint = item; + } + else if (EQ (tem, QCkeys)) + { + tem = XCAR (item); + if (CONSP (tem) || STRINGP (tem)) + ASET (item_properties, ITEM_PROPERTY_KEYEQ, tem); + } + else if (EQ (tem, QCbutton) && CONSP (XCAR (item))) + { + Lisp_Object type; + tem = XCAR (item); + type = XCAR (tem); + if (EQ (type, QCtoggle) || EQ (type, QCradio)) + { + ASET (item_properties, ITEM_PROPERTY_SELECTED, + XCDR (tem)); + ASET (item_properties, ITEM_PROPERTY_TYPE, type); + } + } + item = XCDR (item); + } + } + else if (inmenubar || !NILP (start)) + return 0; + } + else + return 0; /* not a menu item */ + + /* If item string is not a string, evaluate it to get string. + If we don't get a string, skip this item. */ + item_string = AREF (item_properties, ITEM_PROPERTY_NAME); + if (!(STRINGP (item_string))) + { + item_string = menu_item_eval_property (item_string); + if (!STRINGP (item_string)) + return 0; + ASET (item_properties, ITEM_PROPERTY_NAME, item_string); + } + + /* If got a filter apply it on definition. */ + def = AREF (item_properties, ITEM_PROPERTY_DEF); + if (!NILP (filter)) + { + def = menu_item_eval_property (list2 (XCAR (filter), + list2 (Qquote, def))); + + ASET (item_properties, ITEM_PROPERTY_DEF, def); + } + + /* Enable or disable selection of item. */ + tem = AREF (item_properties, ITEM_PROPERTY_ENABLE); + if (!EQ (tem, Qt)) + { + tem = menu_item_eval_property (tem); + if (inmenubar && NILP (tem)) + return 0; /* Ignore disabled items in menu bar. */ + ASET (item_properties, ITEM_PROPERTY_ENABLE, tem); + } + + /* If we got no definition, this item is just unselectable text which + is OK in a submenu but not in the menubar. */ + if (NILP (def)) + return (!inmenubar); + + /* See if this is a separate pane or a submenu. */ + def = AREF (item_properties, ITEM_PROPERTY_DEF); + tem = get_keymap (def, 0, 1); + /* For a subkeymap, just record its details and exit. */ + if (CONSP (tem)) + { + ASET (item_properties, ITEM_PROPERTY_MAP, tem); + ASET (item_properties, ITEM_PROPERTY_DEF, tem); + return 1; + } + + /* At the top level in the menu bar, do likewise for commands also. + The menu bar does not display equivalent key bindings anyway. + ITEM_PROPERTY_DEF is already set up properly. */ + if (inmenubar > 0) + return 1; + + { /* This is a command. See if there is an equivalent key binding. */ + Lisp_Object keyeq = AREF (item_properties, ITEM_PROPERTY_KEYEQ); + AUTO_STRING (space_space, " "); + + /* The previous code preferred :key-sequence to :keys, so we + preserve this behavior. */ + if (STRINGP (keyeq) && !CONSP (keyhint)) + keyeq = concat2 (space_space, Fsubstitute_command_keys (keyeq)); + else + { + Lisp_Object prefix = keyeq; + Lisp_Object keys = Qnil; + + if (CONSP (prefix)) + { + def = XCAR (prefix); + prefix = XCDR (prefix); + } + else + def = AREF (item_properties, ITEM_PROPERTY_DEF); + + if (CONSP (keyhint) && !NILP (XCAR (keyhint))) + { + keys = XCAR (keyhint); + tem = Fkey_binding (keys, Qnil, Qnil, Qnil); + + /* We have a suggested key. Is it bound to the command? */ + if (NILP (tem) + || (!EQ (tem, def) + /* If the command is an alias for another + (such as lmenu.el set it up), check if the + original command matches the cached command. */ + && !(SYMBOLP (def) + && EQ (tem, XSYMBOL (def)->function)))) + keys = Qnil; + } + + if (NILP (keys)) + keys = Fwhere_is_internal (def, Qnil, Qt, Qnil, Qnil); + + if (!NILP (keys)) + { + tem = Fkey_description (keys, Qnil); + if (CONSP (prefix)) + { + if (STRINGP (XCAR (prefix))) + tem = concat2 (XCAR (prefix), tem); + if (STRINGP (XCDR (prefix))) + tem = concat2 (tem, XCDR (prefix)); + } + keyeq = concat2 (space_space, tem); + } + else + keyeq = Qnil; + } + + /* If we have an equivalent key binding, use that. */ + ASET (item_properties, ITEM_PROPERTY_KEYEQ, keyeq); + } + + /* Include this when menu help is implemented. + tem = XVECTOR (item_properties)->contents[ITEM_PROPERTY_HELP]; + if (!(NILP (tem) || STRINGP (tem))) + { + tem = menu_item_eval_property (tem); + if (!STRINGP (tem)) + tem = Qnil; + XVECTOR (item_properties)->contents[ITEM_PROPERTY_HELP] = tem; + } + */ + + /* Handle radio buttons or toggle boxes. */ + tem = AREF (item_properties, ITEM_PROPERTY_SELECTED); + if (!NILP (tem)) + ASET (item_properties, ITEM_PROPERTY_SELECTED, + menu_item_eval_property (tem)); + + return 1; +} + + + +/*********************************************************************** + Tool-bars + ***********************************************************************/ + +/* A vector holding tool bar items while they are parsed in function + tool_bar_items. Each item occupies TOOL_BAR_ITEM_NSCLOTS elements + in the vector. */ + +static Lisp_Object tool_bar_items_vector; + +/* A vector holding the result of parse_tool_bar_item. Layout is like + the one for a single item in tool_bar_items_vector. */ + +static Lisp_Object tool_bar_item_properties; + +/* Next free index in tool_bar_items_vector. */ + +static int ntool_bar_items; + +/* Function prototypes. */ + +static void init_tool_bar_items (Lisp_Object); +static void process_tool_bar_item (Lisp_Object, Lisp_Object, Lisp_Object, + void *); +static bool parse_tool_bar_item (Lisp_Object, Lisp_Object); +static void append_tool_bar_item (void); + + +/* Return a vector of tool bar items for keymaps currently in effect. + Reuse vector REUSE if non-nil. Return in *NITEMS the number of + tool bar items found. */ + +Lisp_Object +tool_bar_items (Lisp_Object reuse, int *nitems) +{ + Lisp_Object *maps; + Lisp_Object mapsbuf[3]; + ptrdiff_t nmaps, i; + Lisp_Object oquit; + Lisp_Object *tmaps; + USE_SAFE_ALLOCA; + + *nitems = 0; + + /* In order to build the menus, we need to call the keymap + accessors. They all call QUIT. But this function is called + during redisplay, during which a quit is fatal. So inhibit + quitting while building the menus. We do this instead of + specbind because (1) errors will clear it anyway and (2) this + avoids risk of specpdl overflow. */ + oquit = Vinhibit_quit; + Vinhibit_quit = Qt; + + /* Initialize tool_bar_items_vector and protect it from GC. */ + init_tool_bar_items (reuse); + + /* Build list of keymaps in maps. Set nmaps to the number of maps + to process. */ + + /* Should overriding-terminal-local-map and overriding-local-map apply? */ + if (!NILP (Voverriding_local_map_menu_flag) + && !NILP (Voverriding_local_map)) + { + /* Yes, use them (if non-nil) as well as the global map. */ + maps = mapsbuf; + nmaps = 0; + if (!NILP (KVAR (current_kboard, Voverriding_terminal_local_map))) + maps[nmaps++] = KVAR (current_kboard, Voverriding_terminal_local_map); + if (!NILP (Voverriding_local_map)) + maps[nmaps++] = Voverriding_local_map; + } + else + { + /* No, so use major and minor mode keymaps and keymap property. + Note that tool-bar bindings in the local-map and keymap + properties may not work reliable, as they are only + recognized when the tool-bar (or mode-line) is updated, + which does not normally happen after every command. */ + Lisp_Object tem; + ptrdiff_t nminor; + nminor = current_minor_maps (NULL, &tmaps); + SAFE_NALLOCA (maps, 1, nminor + 4); + nmaps = 0; + tem = KVAR (current_kboard, Voverriding_terminal_local_map); + if (!NILP (tem) && !NILP (Voverriding_local_map_menu_flag)) + maps[nmaps++] = tem; + if (tem = get_local_map (PT, current_buffer, Qkeymap), !NILP (tem)) + maps[nmaps++] = tem; + memcpy (maps + nmaps, tmaps, nminor * sizeof (maps[0])); + nmaps += nminor; + maps[nmaps++] = get_local_map (PT, current_buffer, Qlocal_map); + } + + /* Add global keymap at the end. */ + maps[nmaps++] = current_global_map; + + /* Process maps in reverse order and look up in each map the prefix + key `tool-bar'. */ + for (i = nmaps - 1; i >= 0; --i) + if (!NILP (maps[i])) + { + Lisp_Object keymap; + + keymap = get_keymap (access_keymap (maps[i], Qtool_bar, 1, 0, 1), 0, 1); + if (CONSP (keymap)) + map_keymap (keymap, process_tool_bar_item, Qnil, NULL, 1); + } + + Vinhibit_quit = oquit; + *nitems = ntool_bar_items / TOOL_BAR_ITEM_NSLOTS; + SAFE_FREE (); + return tool_bar_items_vector; +} + + +/* Process the definition of KEY which is DEF. */ + +static void +process_tool_bar_item (Lisp_Object key, Lisp_Object def, Lisp_Object data, void *args) +{ + int i; + struct gcpro gcpro1, gcpro2; + + /* Protect KEY and DEF from GC because parse_tool_bar_item may call + eval. */ + GCPRO2 (key, def); + + if (EQ (def, Qundefined)) + { + /* If a map has an explicit `undefined' as definition, + discard any previously made item. */ + for (i = 0; i < ntool_bar_items; i += TOOL_BAR_ITEM_NSLOTS) + { + Lisp_Object *v = XVECTOR (tool_bar_items_vector)->contents + i; + + if (EQ (key, v[TOOL_BAR_ITEM_KEY])) + { + if (ntool_bar_items > i + TOOL_BAR_ITEM_NSLOTS) + memmove (v, v + TOOL_BAR_ITEM_NSLOTS, + ((ntool_bar_items - i - TOOL_BAR_ITEM_NSLOTS) + * word_size)); + ntool_bar_items -= TOOL_BAR_ITEM_NSLOTS; + break; + } + } + } + else if (parse_tool_bar_item (key, def)) + /* Append a new tool bar item to tool_bar_items_vector. Accept + more than one definition for the same key. */ + append_tool_bar_item (); + + UNGCPRO; +} + +/* Access slot with index IDX of vector tool_bar_item_properties. */ +#define PROP(IDX) AREF (tool_bar_item_properties, (IDX)) +static void +set_prop (ptrdiff_t idx, Lisp_Object val) +{ + ASET (tool_bar_item_properties, idx, val); +} + + +/* Parse a tool bar item specification ITEM for key KEY and return the + result in tool_bar_item_properties. Value is false if ITEM is + invalid. + + ITEM is a list `(menu-item CAPTION BINDING PROPS...)'. + + CAPTION is the caption of the item, If it's not a string, it is + evaluated to get a string. + + BINDING is the tool bar item's binding. Tool-bar items with keymaps + as binding are currently ignored. + + The following properties are recognized: + + - `:enable FORM'. + + FORM is evaluated and specifies whether the tool bar item is + enabled or disabled. + + - `:visible FORM' + + FORM is evaluated and specifies whether the tool bar item is visible. + + - `:filter FUNCTION' + + FUNCTION is invoked with one parameter `(quote BINDING)'. Its + result is stored as the new binding. + + - `:button (TYPE SELECTED)' + + TYPE must be one of `:radio' or `:toggle'. SELECTED is evaluated + and specifies whether the button is selected (pressed) or not. + + - `:image IMAGES' + + IMAGES is either a single image specification or a vector of four + image specifications. See enum tool_bar_item_images. + + - `:help HELP-STRING'. + + Gives a help string to display for the tool bar item. + + - `:label LABEL-STRING'. + + A text label to show with the tool bar button if labels are enabled. */ + +static bool +parse_tool_bar_item (Lisp_Object key, Lisp_Object item) +{ + Lisp_Object filter = Qnil; + Lisp_Object caption; + int i; + bool have_label = 0; + + /* Definition looks like `(menu-item CAPTION BINDING PROPS...)'. + Rule out items that aren't lists, don't start with + `menu-item' or whose rest following `tool-bar-item' is not a + list. */ + if (!CONSP (item)) + return 0; + + /* As an exception, allow old-style menu separators. */ + if (STRINGP (XCAR (item))) + item = list1 (XCAR (item)); + else if (!EQ (XCAR (item), Qmenu_item) + || (item = XCDR (item), !CONSP (item))) + return 0; + + /* Create tool_bar_item_properties vector if necessary. Reset it to + defaults. */ + if (VECTORP (tool_bar_item_properties)) + { + for (i = 0; i < TOOL_BAR_ITEM_NSLOTS; ++i) + set_prop (i, Qnil); + } + else + tool_bar_item_properties + = Fmake_vector (make_number (TOOL_BAR_ITEM_NSLOTS), Qnil); + + /* Set defaults. */ + set_prop (TOOL_BAR_ITEM_KEY, key); + set_prop (TOOL_BAR_ITEM_ENABLED_P, Qt); + + /* Get the caption of the item. If the caption is not a string, + evaluate it to get a string. If we don't get a string, skip this + item. */ + caption = XCAR (item); + if (!STRINGP (caption)) + { + caption = menu_item_eval_property (caption); + if (!STRINGP (caption)) + return 0; + } + set_prop (TOOL_BAR_ITEM_CAPTION, caption); + + /* If the rest following the caption is not a list, the menu item is + either a separator, or invalid. */ + item = XCDR (item); + if (!CONSP (item)) + { + if (menu_separator_name_p (SSDATA (caption))) + { + set_prop (TOOL_BAR_ITEM_TYPE, Qt); +#if !defined (USE_GTK) && !defined (HAVE_NS) + /* If we use build_desired_tool_bar_string to render the + tool bar, the separator is rendered as an image. */ + set_prop (TOOL_BAR_ITEM_IMAGES, + (menu_item_eval_property + (Vtool_bar_separator_image_expression))); + set_prop (TOOL_BAR_ITEM_ENABLED_P, Qnil); + set_prop (TOOL_BAR_ITEM_SELECTED_P, Qnil); + set_prop (TOOL_BAR_ITEM_CAPTION, Qnil); +#endif + return 1; + } + return 0; + } + + /* Store the binding. */ + set_prop (TOOL_BAR_ITEM_BINDING, XCAR (item)); + item = XCDR (item); + + /* Ignore cached key binding, if any. */ + if (CONSP (item) && CONSP (XCAR (item))) + item = XCDR (item); + + /* Process the rest of the properties. */ + for (; CONSP (item) && CONSP (XCDR (item)); item = XCDR (XCDR (item))) + { + Lisp_Object ikey, value; + + ikey = XCAR (item); + value = XCAR (XCDR (item)); + + if (EQ (ikey, QCenable)) + { + /* `:enable FORM'. */ + if (!NILP (Venable_disabled_menus_and_buttons)) + set_prop (TOOL_BAR_ITEM_ENABLED_P, Qt); + else + set_prop (TOOL_BAR_ITEM_ENABLED_P, value); + } + else if (EQ (ikey, QCvisible)) + { + /* `:visible FORM'. If got a visible property and that + evaluates to nil then ignore this item. */ + if (NILP (menu_item_eval_property (value))) + return 0; + } + else if (EQ (ikey, QChelp)) + /* `:help HELP-STRING'. */ + set_prop (TOOL_BAR_ITEM_HELP, value); + else if (EQ (ikey, QCvert_only)) + /* `:vert-only t/nil'. */ + set_prop (TOOL_BAR_ITEM_VERT_ONLY, value); + else if (EQ (ikey, QClabel)) + { + const char *bad_label = "!!?GARBLED ITEM?!!"; + /* `:label LABEL-STRING'. */ + set_prop (TOOL_BAR_ITEM_LABEL, + STRINGP (value) ? value : build_string (bad_label)); + have_label = 1; + } + else if (EQ (ikey, QCfilter)) + /* ':filter FORM'. */ + filter = value; + else if (EQ (ikey, QCbutton) && CONSP (value)) + { + /* `:button (TYPE . SELECTED)'. */ + Lisp_Object type, selected; + + type = XCAR (value); + selected = XCDR (value); + if (EQ (type, QCtoggle) || EQ (type, QCradio)) + { + set_prop (TOOL_BAR_ITEM_SELECTED_P, selected); + set_prop (TOOL_BAR_ITEM_TYPE, type); + } + } + else if (EQ (ikey, QCimage) + && (CONSP (value) + || (VECTORP (value) && ASIZE (value) == 4))) + /* Value is either a single image specification or a vector + of 4 such specifications for the different button states. */ + set_prop (TOOL_BAR_ITEM_IMAGES, value); + else if (EQ (ikey, QCrtl)) + /* ':rtl STRING' */ + set_prop (TOOL_BAR_ITEM_RTL_IMAGE, value); + } + + + if (!have_label) + { + /* Try to make one from caption and key. */ + Lisp_Object tkey = PROP (TOOL_BAR_ITEM_KEY); + Lisp_Object tcapt = PROP (TOOL_BAR_ITEM_CAPTION); + const char *label = SYMBOLP (tkey) ? SSDATA (SYMBOL_NAME (tkey)) : ""; + const char *capt = STRINGP (tcapt) ? SSDATA (tcapt) : ""; + ptrdiff_t max_lbl = + 2 * max (0, min (tool_bar_max_label_size, STRING_BYTES_BOUND / 2)); + char *buf = xmalloc (max_lbl + 1); + Lisp_Object new_lbl; + ptrdiff_t caption_len = strlen (capt); + + if (caption_len <= max_lbl && capt[0] != '\0') + { + strcpy (buf, capt); + while (caption_len > 0 && buf[caption_len - 1] == '.') + caption_len--; + buf[caption_len] = '\0'; + label = capt = buf; + } + + if (strlen (label) <= max_lbl && label[0] != '\0') + { + ptrdiff_t j; + if (label != buf) + strcpy (buf, label); + + for (j = 0; buf[j] != '\0'; ++j) + if (buf[j] == '-') + buf[j] = ' '; + label = buf; + } + else + label = ""; + + new_lbl = Fupcase_initials (build_string (label)); + if (SCHARS (new_lbl) <= tool_bar_max_label_size) + set_prop (TOOL_BAR_ITEM_LABEL, new_lbl); + else + set_prop (TOOL_BAR_ITEM_LABEL, empty_unibyte_string); + xfree (buf); + } + + /* If got a filter apply it on binding. */ + if (!NILP (filter)) + set_prop (TOOL_BAR_ITEM_BINDING, + (menu_item_eval_property + (list2 (filter, + list2 (Qquote, + PROP (TOOL_BAR_ITEM_BINDING)))))); + + /* See if the binding is a keymap. Give up if it is. */ + if (CONSP (get_keymap (PROP (TOOL_BAR_ITEM_BINDING), 0, 1))) + return 0; + + /* Enable or disable selection of item. */ + if (!EQ (PROP (TOOL_BAR_ITEM_ENABLED_P), Qt)) + set_prop (TOOL_BAR_ITEM_ENABLED_P, + menu_item_eval_property (PROP (TOOL_BAR_ITEM_ENABLED_P))); + + /* Handle radio buttons or toggle boxes. */ + if (!NILP (PROP (TOOL_BAR_ITEM_SELECTED_P))) + set_prop (TOOL_BAR_ITEM_SELECTED_P, + menu_item_eval_property (PROP (TOOL_BAR_ITEM_SELECTED_P))); + + return 1; + +#undef PROP +} + + +/* Initialize tool_bar_items_vector. REUSE, if non-nil, is a vector + that can be reused. */ + +static void +init_tool_bar_items (Lisp_Object reuse) +{ + if (VECTORP (reuse)) + tool_bar_items_vector = reuse; + else + tool_bar_items_vector = Fmake_vector (make_number (64), Qnil); + ntool_bar_items = 0; +} + + +/* Append parsed tool bar item properties from + tool_bar_item_properties */ + +static void +append_tool_bar_item (void) +{ + ptrdiff_t incr + = (ntool_bar_items + - (ASIZE (tool_bar_items_vector) - TOOL_BAR_ITEM_NSLOTS)); + + /* Enlarge tool_bar_items_vector if necessary. */ + if (incr > 0) + tool_bar_items_vector = larger_vector (tool_bar_items_vector, incr, -1); + + /* Append entries from tool_bar_item_properties to the end of + tool_bar_items_vector. */ + vcopy (tool_bar_items_vector, ntool_bar_items, + XVECTOR (tool_bar_item_properties)->contents, TOOL_BAR_ITEM_NSLOTS); + ntool_bar_items += TOOL_BAR_ITEM_NSLOTS; +} + + + + + +/* Read a character using menus based on the keymap MAP. + Return nil if there are no menus in the maps. + Return t if we displayed a menu but the user rejected it. + + PREV_EVENT is the previous input event, or nil if we are reading + the first event of a key sequence. + + If USED_MOUSE_MENU is non-null, set *USED_MOUSE_MENU to true + if we used a mouse menu to read the input, or false otherwise. If + USED_MOUSE_MENU is null, don't dereference it. + + The prompting is done based on the prompt-string of the map + and the strings associated with various map elements. + + This can be done with X menus or with menus put in the minibuf. + These are done in different ways, depending on how the input will be read. + Menus using X are done after auto-saving in read-char, getting the input + event from Fx_popup_menu; menus using the minibuf use read_char recursively + and do auto-saving in the inner call of read_char. */ + +static Lisp_Object +read_char_x_menu_prompt (Lisp_Object map, + Lisp_Object prev_event, bool *used_mouse_menu) +{ + if (used_mouse_menu) + *used_mouse_menu = 0; + + /* Use local over global Menu maps. */ + + if (! menu_prompting) + return Qnil; + + /* If we got to this point via a mouse click, + use a real menu for mouse selection. */ + if (EVENT_HAS_PARAMETERS (prev_event) + && !EQ (XCAR (prev_event), Qmenu_bar) + && !EQ (XCAR (prev_event), Qtool_bar)) + { + /* Display the menu and get the selection. */ + Lisp_Object value; + + value = Fx_popup_menu (prev_event, get_keymap (map, 0, 1)); + if (CONSP (value)) + { + Lisp_Object tem; + + record_menu_key (XCAR (value)); + + /* If we got multiple events, unread all but + the first. + There is no way to prevent those unread events + from showing up later in last_nonmenu_event. + So turn symbol and integer events into lists, + to indicate that they came from a mouse menu, + so that when present in last_nonmenu_event + they won't confuse things. */ + for (tem = XCDR (value); CONSP (tem); tem = XCDR (tem)) + { + record_menu_key (XCAR (tem)); + if (SYMBOLP (XCAR (tem)) + || INTEGERP (XCAR (tem))) + XSETCAR (tem, Fcons (XCAR (tem), Qdisabled)); + } + + /* If we got more than one event, put all but the first + onto this list to be read later. + Return just the first event now. */ + Vunread_command_events + = nconc2 (XCDR (value), Vunread_command_events); + value = XCAR (value); + } + else if (NILP (value)) + value = Qt; + if (used_mouse_menu) + *used_mouse_menu = 1; + return value; + } + return Qnil ; +} + +static Lisp_Object +read_char_minibuf_menu_prompt (int commandflag, + Lisp_Object map) +{ + Lisp_Object name; + ptrdiff_t nlength; + /* FIXME: Use the minibuffer's frame width. */ + ptrdiff_t width = FRAME_COLS (SELECTED_FRAME ()) - 4; + ptrdiff_t idx = -1; + bool nobindings = 1; + Lisp_Object rest, vector; + Lisp_Object prompt_strings = Qnil; + + vector = Qnil; + + if (! menu_prompting) + return Qnil; + + map = get_keymap (map, 0, 1); + name = Fkeymap_prompt (map); + + /* If we don't have any menus, just read a character normally. */ + if (!STRINGP (name)) + return Qnil; + +#define PUSH_C_STR(str, listvar) \ + listvar = Fcons (build_unibyte_string (str), listvar) + + /* Prompt string always starts with map's prompt, and a space. */ + prompt_strings = Fcons (name, prompt_strings); + PUSH_C_STR (": ", prompt_strings); + nlength = SCHARS (name) + 2; + + rest = map; + + /* Present the documented bindings, a line at a time. */ + while (1) + { + bool notfirst = 0; + Lisp_Object menu_strings = prompt_strings; + ptrdiff_t i = nlength; + Lisp_Object obj; + Lisp_Object orig_defn_macro; + + /* Loop over elements of map. */ + while (i < width) + { + Lisp_Object elt; + + /* FIXME: Use map_keymap to handle new keymap formats. */ + + /* At end of map, wrap around if just starting, + or end this line if already have something on it. */ + if (NILP (rest)) + { + if (notfirst || nobindings) + break; + else + rest = map; + } + + /* Look at the next element of the map. */ + if (idx >= 0) + elt = AREF (vector, idx); + else + elt = Fcar_safe (rest); + + if (idx < 0 && VECTORP (elt)) + { + /* If we found a dense table in the keymap, + advanced past it, but start scanning its contents. */ + rest = Fcdr_safe (rest); + vector = elt; + idx = 0; + } + else + { + /* An ordinary element. */ + Lisp_Object event, tem; + + if (idx < 0) + { + event = Fcar_safe (elt); /* alist */ + elt = Fcdr_safe (elt); + } + else + { + XSETINT (event, idx); /* vector */ + } + + /* Ignore the element if it has no prompt string. */ + if (INTEGERP (event) && parse_menu_item (elt, -1)) + { + /* True if the char to type matches the string. */ + bool char_matches; + Lisp_Object upcased_event, downcased_event; + Lisp_Object desc = Qnil; + Lisp_Object s + = AREF (item_properties, ITEM_PROPERTY_NAME); + + upcased_event = Fupcase (event); + downcased_event = Fdowncase (event); + char_matches = (XINT (upcased_event) == SREF (s, 0) + || XINT (downcased_event) == SREF (s, 0)); + if (! char_matches) + desc = Fsingle_key_description (event, Qnil); + +#if 0 /* It is redundant to list the equivalent key bindings because + the prefix is what the user has already typed. */ + tem + = XVECTOR (item_properties)->contents[ITEM_PROPERTY_KEYEQ]; + if (!NILP (tem)) + /* Insert equivalent keybinding. */ + s = concat2 (s, tem); +#endif + tem + = AREF (item_properties, ITEM_PROPERTY_TYPE); + if (EQ (tem, QCradio) || EQ (tem, QCtoggle)) + { + /* Insert button prefix. */ + Lisp_Object selected + = AREF (item_properties, ITEM_PROPERTY_SELECTED); + AUTO_STRING (radio_yes, "(*) "); + AUTO_STRING (radio_no , "( ) "); + AUTO_STRING (check_yes, "[X] "); + AUTO_STRING (check_no , "[ ] "); + if (EQ (tem, QCradio)) + tem = NILP (selected) ? radio_yes : radio_no; + else + tem = NILP (selected) ? check_yes : check_no; + s = concat2 (tem, s); + } + + + /* If we have room for the prompt string, add it to this line. + If this is the first on the line, always add it. */ + if ((SCHARS (s) + i + 2 + + (char_matches ? 0 : SCHARS (desc) + 3)) + < width + || !notfirst) + { + ptrdiff_t thiswidth; + + /* Punctuate between strings. */ + if (notfirst) + { + PUSH_C_STR (", ", menu_strings); + i += 2; + } + notfirst = 1; + nobindings = 0; + + /* If the char to type doesn't match the string's + first char, explicitly show what char to type. */ + if (! char_matches) + { + /* Add as much of string as fits. */ + thiswidth = min (SCHARS (desc), width - i); + menu_strings + = Fcons (Fsubstring (desc, make_number (0), + make_number (thiswidth)), + menu_strings); + i += thiswidth; + PUSH_C_STR (" = ", menu_strings); + i += 3; + } + + /* Add as much of string as fits. */ + thiswidth = min (SCHARS (s), width - i); + menu_strings + = Fcons (Fsubstring (s, make_number (0), + make_number (thiswidth)), + menu_strings); + i += thiswidth; + } + else + { + /* If this element does not fit, end the line now, + and save the element for the next line. */ + PUSH_C_STR ("...", menu_strings); + break; + } + } + + /* Move past this element. */ + if (idx >= 0 && idx + 1 >= ASIZE (vector)) + /* Handle reaching end of dense table. */ + idx = -1; + if (idx >= 0) + idx++; + else + rest = Fcdr_safe (rest); + } + } + + /* Prompt with that and read response. */ + message3_nolog (apply1 (intern ("concat"), Fnreverse (menu_strings))); + + /* Make believe it's not a keyboard macro in case the help char + is pressed. Help characters are not recorded because menu prompting + is not used on replay. */ + orig_defn_macro = KVAR (current_kboard, defining_kbd_macro); + kset_defining_kbd_macro (current_kboard, Qnil); + do + obj = read_char (commandflag, Qnil, Qt, 0, NULL); + while (BUFFERP (obj)); + kset_defining_kbd_macro (current_kboard, orig_defn_macro); + + if (!INTEGERP (obj) || XINT (obj) == -2 + || (! EQ (obj, menu_prompt_more_char) + && (!INTEGERP (menu_prompt_more_char) + || ! EQ (obj, make_number (Ctl (XINT (menu_prompt_more_char))))))) + { + if (!NILP (KVAR (current_kboard, defining_kbd_macro))) + store_kbd_macro_char (obj); + return obj; + } + /* Help char - go round again. */ + } +} + +/* Reading key sequences. */ + +static Lisp_Object +follow_key (Lisp_Object keymap, Lisp_Object key) +{ + return access_keymap (get_keymap (keymap, 0, 1), + key, 1, 0, 1); +} + +static Lisp_Object +active_maps (Lisp_Object first_event) +{ + Lisp_Object position + = CONSP (first_event) ? CAR_SAFE (XCDR (first_event)) : Qnil; + return Fcons (Qkeymap, Fcurrent_active_maps (Qt, position)); +} + +/* Structure used to keep track of partial application of key remapping + such as Vfunction_key_map and Vkey_translation_map. */ +typedef struct keyremap +{ + /* This is the map originally specified for this use. */ + Lisp_Object parent; + /* This is a submap reached by looking up, in PARENT, + the events from START to END. */ + Lisp_Object map; + /* Positions [START, END) in the key sequence buffer + are the key that we have scanned so far. + Those events are the ones that we will replace + if PARENT maps them into a key sequence. */ + int start, end; +} keyremap; + +/* Lookup KEY in MAP. + MAP is a keymap mapping keys to key vectors or functions. + If the mapping is a function and DO_FUNCALL is true, + the function is called with PROMPT as parameter and its return + value is used as the return value of this function (after checking + that it is indeed a vector). */ + +static Lisp_Object +access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt, + bool do_funcall) +{ + Lisp_Object next; + + next = access_keymap (map, key, 1, 0, 1); + + /* Handle a symbol whose function definition is a keymap + or an array. */ + if (SYMBOLP (next) && !NILP (Ffboundp (next)) + && (ARRAYP (XSYMBOL (next)->function) + || KEYMAPP (XSYMBOL (next)->function))) + next = Fautoload_do_load (XSYMBOL (next)->function, next, Qnil); + + /* If the keymap gives a function, not an + array, then call the function with one arg and use + its value instead. */ + if (do_funcall && FUNCTIONP (next)) + { + Lisp_Object tem; + tem = next; + + next = call1 (next, prompt); + /* If the function returned something invalid, + barf--don't ignore it. + (To ignore it safely, we would need to gcpro a bunch of + other variables.) */ + if (! (NILP (next) || VECTORP (next) || STRINGP (next))) + error ("Function %s returns invalid key sequence", + SSDATA (SYMBOL_NAME (tem))); + } + return next; +} + +/* Do one step of the key remapping used for function-key-map and + key-translation-map: + KEYBUF is the buffer holding the input events. + BUFSIZE is its maximum size. + FKEY is a pointer to the keyremap structure to use. + INPUT is the index of the last element in KEYBUF. + DOIT if true says that the remapping can actually take place. + DIFF is used to return the number of keys added/removed by the remapping. + PARENT is the root of the keymap. + PROMPT is the prompt to use if the remapping happens through a function. + Return true if the remapping actually took place. */ + +static bool +keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey, + int input, bool doit, int *diff, Lisp_Object prompt) +{ + Lisp_Object next, key; + + key = keybuf[fkey->end++]; + + if (KEYMAPP (fkey->parent)) + next = access_keymap_keyremap (fkey->map, key, prompt, doit); + else + next = Qnil; + + /* If keybuf[fkey->start..fkey->end] is bound in the + map and we're in a position to do the key remapping, replace it with + the binding and restart with fkey->start at the end. */ + if ((VECTORP (next) || STRINGP (next)) && doit) + { + int len = XFASTINT (Flength (next)); + int i; + + *diff = len - (fkey->end - fkey->start); + + if (bufsize - input <= *diff) + error ("Key sequence too long"); + + /* Shift the keys that follow fkey->end. */ + if (*diff < 0) + for (i = fkey->end; i < input; i++) + keybuf[i + *diff] = keybuf[i]; + else if (*diff > 0) + for (i = input - 1; i >= fkey->end; i--) + keybuf[i + *diff] = keybuf[i]; + /* Overwrite the old keys with the new ones. */ + for (i = 0; i < len; i++) + keybuf[fkey->start + i] + = Faref (next, make_number (i)); + + fkey->start = fkey->end += *diff; + fkey->map = fkey->parent; + + return 1; + } + + fkey->map = get_keymap (next, 0, 1); + + /* If we no longer have a bound suffix, try a new position for + fkey->start. */ + if (!CONSP (fkey->map)) + { + fkey->end = ++fkey->start; + fkey->map = fkey->parent; + } + return 0; +} + +static bool +test_undefined (Lisp_Object binding) +{ + return (NILP (binding) + || EQ (binding, Qundefined) + || (SYMBOLP (binding) + && EQ (Fcommand_remapping (binding, Qnil, Qnil), Qundefined))); +} + +/* Read a sequence of keys that ends with a non prefix character, + storing it in KEYBUF, a buffer of size BUFSIZE. + Prompt with PROMPT. + Return the length of the key sequence stored. + Return -1 if the user rejected a command menu. + + Echo starting immediately unless `prompt' is 0. + + If PREVENT_REDISPLAY is non-zero, avoid redisplay by calling + read_char with a suitable COMMANDFLAG argument. + + Where a key sequence ends depends on the currently active keymaps. + These include any minor mode keymaps active in the current buffer, + the current buffer's local map, and the global map. + + If a key sequence has no other bindings, we check Vfunction_key_map + to see if some trailing subsequence might be the beginning of a + function key's sequence. If so, we try to read the whole function + key, and substitute its symbolic name into the key sequence. + + We ignore unbound `down-' mouse clicks. We turn unbound `drag-' and + `double-' events into similar click events, if that would make them + bound. We try to turn `triple-' events first into `double-' events, + then into clicks. + + If we get a mouse click in a mode line, vertical divider, or other + non-text area, we treat the click as if it were prefixed by the + symbol denoting that area - `mode-line', `vertical-line', or + whatever. + + If the sequence starts with a mouse click, we read the key sequence + with respect to the buffer clicked on, not the current buffer. + + If the user switches frames in the midst of a key sequence, we put + off the switch-frame event until later; the next call to + read_char will return it. + + If FIX_CURRENT_BUFFER, we restore current_buffer + from the selected window's buffer. */ + +static int +read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, + bool dont_downcase_last, bool can_return_switch_frame, + bool fix_current_buffer, bool prevent_redisplay) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + /* How many keys there are in the current key sequence. */ + int t; + + /* The length of the echo buffer when we started reading, and + the length of this_command_keys when we started reading. */ + ptrdiff_t echo_start IF_LINT (= 0); + ptrdiff_t keys_start; + + Lisp_Object current_binding = Qnil; + Lisp_Object first_event = Qnil; + + /* Index of the first key that has no binding. + It is useless to try fkey.start larger than that. */ + int first_unbound; + + /* If t < mock_input, then KEYBUF[t] should be read as the next + input key. + + We use this to recover after recognizing a function key. Once we + realize that a suffix of the current key sequence is actually a + function key's escape sequence, we replace the suffix with the + function key's binding from Vfunction_key_map. Now keybuf + contains a new and different key sequence, so the echo area, + this_command_keys, and the submaps and defs arrays are wrong. In + this situation, we set mock_input to t, set t to 0, and jump to + restart_sequence; the loop will read keys from keybuf up until + mock_input, thus rebuilding the state; and then it will resume + reading characters from the keyboard. */ + int mock_input = 0; + + /* If the sequence is unbound in submaps[], then + keybuf[fkey.start..fkey.end-1] is a prefix in Vfunction_key_map, + and fkey.map is its binding. + + These might be > t, indicating that all function key scanning + should hold off until t reaches them. We do this when we've just + recognized a function key, to avoid searching for the function + key's again in Vfunction_key_map. */ + keyremap fkey; + + /* Likewise, for key_translation_map and input-decode-map. */ + keyremap keytran, indec; + + /* True if we are trying to map a key by changing an upper-case + letter to lower case, or a shifted function key to an unshifted + one. */ + bool shift_translated = 0; + + /* If we receive a `switch-frame' or `select-window' event in the middle of + a key sequence, we put it off for later. + While we're reading, we keep the event here. */ + Lisp_Object delayed_switch_frame; + + Lisp_Object original_uppercase IF_LINT (= Qnil); + int original_uppercase_position = -1; + + /* Gets around Microsoft compiler limitations. */ + bool dummyflag = 0; + + struct buffer *starting_buffer; + + /* List of events for which a fake prefix key has been generated. */ + Lisp_Object fake_prefixed_keys = Qnil; + + struct gcpro gcpro1; + + GCPRO1 (fake_prefixed_keys); + raw_keybuf_count = 0; + + last_nonmenu_event = Qnil; + + delayed_switch_frame = Qnil; + + if (INTERACTIVE) + { + if (!NILP (prompt)) + { + /* Install the string PROMPT as the beginning of the string + of echoing, so that it serves as a prompt for the next + character. */ + kset_echo_string (current_kboard, prompt); + current_kboard->echo_after_prompt = SCHARS (prompt); + echo_now (); + } + else if (cursor_in_echo_area + && echo_keystrokes_p ()) + /* This doesn't put in a dash if the echo buffer is empty, so + you don't always see a dash hanging out in the minibuffer. */ + echo_dash (); + } + + /* Record the initial state of the echo area and this_command_keys; + we will need to restore them if we replay a key sequence. */ + if (INTERACTIVE) + echo_start = echo_length (); + keys_start = this_command_key_count; + this_single_command_key_start = keys_start; + + /* We jump here when we need to reinitialize fkey and keytran; this + happens if we switch keyboards between rescans. */ + replay_entire_sequence: + + indec.map = indec.parent = KVAR (current_kboard, Vinput_decode_map); + fkey.map = fkey.parent = KVAR (current_kboard, Vlocal_function_key_map); + keytran.map = keytran.parent = Vkey_translation_map; + indec.start = indec.end = 0; + fkey.start = fkey.end = 0; + keytran.start = keytran.end = 0; + + /* We jump here when the key sequence has been thoroughly changed, and + we need to rescan it starting from the beginning. When we jump here, + keybuf[0..mock_input] holds the sequence we should reread. */ + replay_sequence: + + starting_buffer = current_buffer; + first_unbound = bufsize + 1; + + /* Build our list of keymaps. + If we recognize a function key and replace its escape sequence in + keybuf with its symbol, or if the sequence starts with a mouse + click and we need to switch buffers, we jump back here to rebuild + the initial keymaps from the current buffer. */ + current_binding = active_maps (first_event); + + /* Start from the beginning in keybuf. */ + t = 0; + + /* These are no-ops the first time through, but if we restart, they + revert the echo area and this_command_keys to their original state. */ + this_command_key_count = keys_start; + if (INTERACTIVE && t < mock_input) + echo_truncate (echo_start); + + /* If the best binding for the current key sequence is a keymap, or + we may be looking at a function key's escape sequence, keep on + reading. */ + while (!NILP (current_binding) + /* Keep reading as long as there's a prefix binding. */ + ? KEYMAPP (current_binding) + /* Don't return in the middle of a possible function key sequence, + if the only bindings we found were via case conversion. + Thus, if ESC O a has a function-key-map translation + and ESC o has a binding, don't return after ESC O, + so that we can translate ESC O plus the next character. */ + : (/* indec.start < t || fkey.start < t || */ keytran.start < t)) + { + Lisp_Object key; + bool used_mouse_menu = 0; + + /* Where the last real key started. If we need to throw away a + key that has expanded into more than one element of keybuf + (say, a mouse click on the mode line which is being treated + as [mode-line (mouse-...)], then we backtrack to this point + of keybuf. */ + int last_real_key_start; + + /* These variables are analogous to echo_start and keys_start; + while those allow us to restart the entire key sequence, + echo_local_start and keys_local_start allow us to throw away + just one key. */ + ptrdiff_t echo_local_start IF_LINT (= 0); + int keys_local_start; + Lisp_Object new_binding; + + eassert (indec.end == t || (indec.end > t && indec.end <= mock_input)); + eassert (indec.start <= indec.end); + eassert (fkey.start <= fkey.end); + eassert (keytran.start <= keytran.end); + /* key-translation-map is applied *after* function-key-map + which is itself applied *after* input-decode-map. */ + eassert (fkey.end <= indec.start); + eassert (keytran.end <= fkey.start); + + if (/* first_unbound < indec.start && first_unbound < fkey.start && */ + first_unbound < keytran.start) + { /* The prefix upto first_unbound has no binding and has + no translation left to do either, so we know it's unbound. + If we don't stop now, we risk staying here indefinitely + (if the user keeps entering fkey or keytran prefixes + like C-c ESC ESC ESC ESC ...) */ + int i; + for (i = first_unbound + 1; i < t; i++) + keybuf[i - first_unbound - 1] = keybuf[i]; + mock_input = t - first_unbound - 1; + indec.end = indec.start -= first_unbound + 1; + indec.map = indec.parent; + fkey.end = fkey.start -= first_unbound + 1; + fkey.map = fkey.parent; + keytran.end = keytran.start -= first_unbound + 1; + keytran.map = keytran.parent; + goto replay_sequence; + } + + if (t >= bufsize) + error ("Key sequence too long"); + + if (INTERACTIVE) + echo_local_start = echo_length (); + keys_local_start = this_command_key_count; + + replay_key: + /* These are no-ops, unless we throw away a keystroke below and + jumped back up to replay_key; in that case, these restore the + variables to their original state, allowing us to replay the + loop. */ + if (INTERACTIVE && t < mock_input) + echo_truncate (echo_local_start); + this_command_key_count = keys_local_start; + + /* By default, assume each event is "real". */ + last_real_key_start = t; + + /* Does mock_input indicate that we are re-reading a key sequence? */ + if (t < mock_input) + { + key = keybuf[t]; + add_command_key (key); + if (echo_keystrokes_p () + && current_kboard->immediate_echo) + { + echo_add_key (key); + echo_dash (); + } + } + + /* If not, we should actually read a character. */ + else + { + { + KBOARD *interrupted_kboard = current_kboard; + struct frame *interrupted_frame = SELECTED_FRAME (); + /* Calling read_char with COMMANDFLAG = -2 avoids + redisplay in read_char and its subroutines. */ + key = read_char (prevent_redisplay ? -2 : NILP (prompt), + current_binding, last_nonmenu_event, + &used_mouse_menu, NULL); + if ((INTEGERP (key) && XINT (key) == -2) /* wrong_kboard_jmpbuf */ + /* When switching to a new tty (with a new keyboard), + read_char returns the new buffer, rather than -2 + (Bug#5095). This is because `terminal-init-xterm' + calls read-char, which eats the wrong_kboard_jmpbuf + return. Any better way to fix this? -- cyd */ + || (interrupted_kboard != current_kboard)) + { + bool found = 0; + struct kboard *k; + + for (k = all_kboards; k; k = k->next_kboard) + if (k == interrupted_kboard) + found = 1; + + if (!found) + { + /* Don't touch interrupted_kboard when it's been + deleted. */ + delayed_switch_frame = Qnil; + goto replay_entire_sequence; + } + + if (!NILP (delayed_switch_frame)) + { + kset_kbd_queue + (interrupted_kboard, + Fcons (delayed_switch_frame, + KVAR (interrupted_kboard, kbd_queue))); + delayed_switch_frame = Qnil; + } + + while (t > 0) + kset_kbd_queue + (interrupted_kboard, + Fcons (keybuf[--t], KVAR (interrupted_kboard, kbd_queue))); + + /* If the side queue is non-empty, ensure it begins with a + switch-frame, so we'll replay it in the right context. */ + if (CONSP (KVAR (interrupted_kboard, kbd_queue)) + && (key = XCAR (KVAR (interrupted_kboard, kbd_queue)), + !(EVENT_HAS_PARAMETERS (key) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (key)), + Qswitch_frame)))) + { + Lisp_Object frame; + XSETFRAME (frame, interrupted_frame); + kset_kbd_queue + (interrupted_kboard, + Fcons (make_lispy_switch_frame (frame), + KVAR (interrupted_kboard, kbd_queue))); + } + mock_input = 0; + goto replay_entire_sequence; + } + } + + /* read_char returns t when it shows a menu and the user rejects it. + Just return -1. */ + if (EQ (key, Qt)) + { + unbind_to (count, Qnil); + UNGCPRO; + return -1; + } + + /* read_char returns -1 at the end of a macro. + Emacs 18 handles this by returning immediately with a + zero, so that's what we'll do. */ + if (INTEGERP (key) && XINT (key) == -1) + { + t = 0; + /* The Microsoft C compiler can't handle the goto that + would go here. */ + dummyflag = 1; + break; + } + + /* If the current buffer has been changed from under us, the + keymap may have changed, so replay the sequence. */ + if (BUFFERP (key)) + { + timer_resume_idle (); + + mock_input = t; + /* Reset the current buffer from the selected window + in case something changed the former and not the latter. + This is to be more consistent with the behavior + of the command_loop_1. */ + if (fix_current_buffer) + { + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + if (XBUFFER (XWINDOW (selected_window)->contents) + != current_buffer) + Fset_buffer (XWINDOW (selected_window)->contents); + } + + goto replay_sequence; + } + + /* If we have a quit that was typed in another frame, and + quit_throw_to_read_char switched buffers, + replay to get the right keymap. */ + if (INTEGERP (key) + && XINT (key) == quit_char + && current_buffer != starting_buffer) + { + GROW_RAW_KEYBUF; + ASET (raw_keybuf, raw_keybuf_count, key); + raw_keybuf_count++; + keybuf[t++] = key; + mock_input = t; + Vquit_flag = Qnil; + goto replay_sequence; + } + + Vquit_flag = Qnil; + + if (EVENT_HAS_PARAMETERS (key) + /* Either a `switch-frame' or a `select-window' event. */ + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (key)), Qswitch_frame)) + { + /* If we're at the beginning of a key sequence, and the caller + says it's okay, go ahead and return this event. If we're + in the midst of a key sequence, delay it until the end. */ + if (t > 0 || !can_return_switch_frame) + { + delayed_switch_frame = key; + goto replay_key; + } + } + + if (NILP (first_event)) + { + first_event = key; + /* Even if first_event does not specify a particular + window/position, it's important to recompute the maps here + since a long time might have passed since we entered + read_key_sequence, and a timer (or process-filter or + special-event-map, ...) might have switched the current buffer + or the selected window from under us in the mean time. */ + if (fix_current_buffer + && (XBUFFER (XWINDOW (selected_window)->contents) + != current_buffer)) + Fset_buffer (XWINDOW (selected_window)->contents); + current_binding = active_maps (first_event); + } + + GROW_RAW_KEYBUF; + ASET (raw_keybuf, raw_keybuf_count, key); + raw_keybuf_count++; + } + + /* Clicks in non-text areas get prefixed by the symbol + in their CHAR-ADDRESS field. For example, a click on + the mode line is prefixed by the symbol `mode-line'. + + Furthermore, key sequences beginning with mouse clicks + are read using the keymaps of the buffer clicked on, not + the current buffer. So we may have to switch the buffer + here. + + When we turn one event into two events, we must make sure + that neither of the two looks like the original--so that, + if we replay the events, they won't be expanded again. + If not for this, such reexpansion could happen either here + or when user programs play with this-command-keys. */ + if (EVENT_HAS_PARAMETERS (key)) + { + Lisp_Object kind = EVENT_HEAD_KIND (EVENT_HEAD (key)); + if (EQ (kind, Qmouse_click)) + { + Lisp_Object window = POSN_WINDOW (EVENT_START (key)); + Lisp_Object posn = POSN_POSN (EVENT_START (key)); + + if (CONSP (posn) + || (!NILP (fake_prefixed_keys) + && !NILP (Fmemq (key, fake_prefixed_keys)))) + { + /* We're looking a second time at an event for which + we generated a fake prefix key. Set + last_real_key_start appropriately. */ + if (t > 0) + last_real_key_start = t - 1; + } + + if (last_real_key_start == 0) + { + /* Key sequences beginning with mouse clicks are + read using the keymaps in the buffer clicked on, + not the current buffer. If we're at the + beginning of a key sequence, switch buffers. */ + if (WINDOWP (window) + && BUFFERP (XWINDOW (window)->contents) + && XBUFFER (XWINDOW (window)->contents) != current_buffer) + { + ASET (raw_keybuf, raw_keybuf_count, key); + raw_keybuf_count++; + keybuf[t] = key; + mock_input = t + 1; + + /* Arrange to go back to the original buffer once we're + done reading the key sequence. Note that we can't + use save_excursion_{save,restore} here, because they + save point as well as the current buffer; we don't + want to save point, because redisplay may change it, + to accommodate a Fset_window_start or something. We + don't want to do this at the top of the function, + because we may get input from a subprocess which + wants to change the selected window and stuff (say, + emacsclient). */ + record_unwind_current_buffer (); + + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + set_buffer_internal (XBUFFER (XWINDOW (window)->contents)); + goto replay_sequence; + } + } + + /* Expand mode-line and scroll-bar events into two events: + use posn as a fake prefix key. */ + if (SYMBOLP (posn) + && (NILP (fake_prefixed_keys) + || NILP (Fmemq (key, fake_prefixed_keys)))) + { + if (bufsize - t <= 1) + error ("Key sequence too long"); + + keybuf[t] = posn; + keybuf[t + 1] = key; + mock_input = t + 2; + + /* Record that a fake prefix key has been generated + for KEY. Don't modify the event; this would + prevent proper action when the event is pushed + back into unread-command-events. */ + fake_prefixed_keys = Fcons (key, fake_prefixed_keys); + goto replay_key; + } + } + else if (CONSP (XCDR (key)) + && CONSP (EVENT_START (key)) + && CONSP (XCDR (EVENT_START (key)))) + { + Lisp_Object posn; + + posn = POSN_POSN (EVENT_START (key)); + /* Handle menu-bar events: + insert the dummy prefix event `menu-bar'. */ + if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar)) + { + if (bufsize - t <= 1) + error ("Key sequence too long"); + keybuf[t] = posn; + keybuf[t + 1] = key; + + /* Zap the position in key, so we know that we've + expanded it, and don't try to do so again. */ + POSN_SET_POSN (EVENT_START (key), list1 (posn)); + + mock_input = t + 2; + goto replay_sequence; + } + else if (CONSP (posn)) + { + /* We're looking at the second event of a + sequence which we expanded before. Set + last_real_key_start appropriately. */ + if (last_real_key_start == t && t > 0) + last_real_key_start = t - 1; + } + } + } + + /* We have finally decided that KEY is something we might want + to look up. */ + new_binding = follow_key (current_binding, key); + + /* If KEY wasn't bound, we'll try some fallbacks. */ + if (!NILP (new_binding)) + /* This is needed for the following scenario: + event 0: a down-event that gets dropped by calling replay_key. + event 1: some normal prefix like C-h. + After event 0, first_unbound is 0, after event 1 indec.start, + fkey.start, and keytran.start are all 1, so when we see that + C-h is bound, we need to update first_unbound. */ + first_unbound = max (t + 1, first_unbound); + else + { + Lisp_Object head; + + /* Remember the position to put an upper bound on indec.start. */ + first_unbound = min (t, first_unbound); + + head = EVENT_HEAD (key); + + if (SYMBOLP (head)) + { + Lisp_Object breakdown; + int modifiers; + + breakdown = parse_modifiers (head); + modifiers = XINT (XCAR (XCDR (breakdown))); + /* Attempt to reduce an unbound mouse event to a simpler + event that is bound: + Drags reduce to clicks. + Double-clicks reduce to clicks. + Triple-clicks reduce to double-clicks, then to clicks. + Down-clicks are eliminated. + Double-downs reduce to downs, then are eliminated. + Triple-downs reduce to double-downs, then to downs, + then are eliminated. */ + if (modifiers & (down_modifier | drag_modifier + | double_modifier | triple_modifier)) + { + while (modifiers & (down_modifier | drag_modifier + | double_modifier | triple_modifier)) + { + Lisp_Object new_head, new_click; + if (modifiers & triple_modifier) + modifiers ^= (double_modifier | triple_modifier); + else if (modifiers & double_modifier) + modifiers &= ~double_modifier; + else if (modifiers & drag_modifier) + modifiers &= ~drag_modifier; + else + { + /* Dispose of this `down' event by simply jumping + back to replay_key, to get another event. + + Note that if this event came from mock input, + then just jumping back to replay_key will just + hand it to us again. So we have to wipe out any + mock input. + + We could delete keybuf[t] and shift everything + after that to the left by one spot, but we'd also + have to fix up any variable that points into + keybuf, and shifting isn't really necessary + anyway. + + Adding prefixes for non-textual mouse clicks + creates two characters of mock input, and both + must be thrown away. If we're only looking at + the prefix now, we can just jump back to + replay_key. On the other hand, if we've already + processed the prefix, and now the actual click + itself is giving us trouble, then we've lost the + state of the keymaps we want to backtrack to, and + we need to replay the whole sequence to rebuild + it. + + Beyond that, only function key expansion could + create more than two keys, but that should never + generate mouse events, so it's okay to zero + mock_input in that case too. + + FIXME: The above paragraph seems just plain + wrong, if you consider things like + xterm-mouse-mode. -stef + + Isn't this just the most wonderful code ever? */ + + /* If mock_input > t + 1, the above simplification + will actually end up dropping keys on the floor. + This is probably OK for now, but even + if mock_input <= t + 1, we need to adjust indec, + fkey, and keytran. + Typical case [header-line down-mouse-N]: + mock_input = 2, t = 1, fkey.end = 1, + last_real_key_start = 0. */ + if (indec.end > last_real_key_start) + { + indec.end = indec.start + = min (last_real_key_start, indec.start); + indec.map = indec.parent; + if (fkey.end > last_real_key_start) + { + fkey.end = fkey.start + = min (last_real_key_start, fkey.start); + fkey.map = fkey.parent; + if (keytran.end > last_real_key_start) + { + keytran.end = keytran.start + = min (last_real_key_start, keytran.start); + keytran.map = keytran.parent; + } + } + } + if (t == last_real_key_start) + { + mock_input = 0; + goto replay_key; + } + else + { + mock_input = last_real_key_start; + goto replay_sequence; + } + } + + new_head + = apply_modifiers (modifiers, XCAR (breakdown)); + new_click = list2 (new_head, EVENT_START (key)); + + /* Look for a binding for this new key. */ + new_binding = follow_key (current_binding, new_click); + + /* If that click is bound, go for it. */ + if (!NILP (new_binding)) + { + current_binding = new_binding; + key = new_click; + break; + } + /* Otherwise, we'll leave key set to the drag event. */ + } + } + } + } + current_binding = new_binding; + + keybuf[t++] = key; + /* Normally, last_nonmenu_event gets the previous key we read. + But when a mouse popup menu is being used, + we don't update last_nonmenu_event; it continues to hold the mouse + event that preceded the first level of menu. */ + if (!used_mouse_menu) + last_nonmenu_event = key; + + /* Record what part of this_command_keys is the current key sequence. */ + this_single_command_key_start = this_command_key_count - t; + /* When 'input-method-function' called above causes events to be + put on 'unread-post-input-method-events', and as result + 'reread' is set to 'true', the value of 't' can become larger + than 'this_command_key_count', because 'add_command_key' is + not called to update 'this_command_key_count'. If this + happens, 'this_single_command_key_start' will become negative + above, and any call to 'this-single-command-keys' will return + a garbled vector. See bug #20223 for one such situation. + Here we force 'this_single_command_key_start' to never become + negative, to avoid that. */ + if (this_single_command_key_start < 0) + this_single_command_key_start = 0; + + /* Look for this sequence in input-decode-map. + Scan from indec.end until we find a bound suffix. */ + while (indec.end < t) + { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + bool done; + int diff; + + GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame); + done = keyremap_step (keybuf, bufsize, &indec, max (t, mock_input), + 1, &diff, prompt); + UNGCPRO; + if (done) + { + mock_input = diff + max (t, mock_input); + goto replay_sequence; + } + } + + if (!KEYMAPP (current_binding) + && !test_undefined (current_binding) + && indec.start >= t) + /* There is a binding and it's not a prefix. + (and it doesn't have any input-decode-map translation pending). + There is thus no function-key in this sequence. + Moving fkey.start is important in this case to allow keytran.start + to go over the sequence before we return (since we keep the + invariant that keytran.end <= fkey.start). */ + { + if (fkey.start < t) + (fkey.start = fkey.end = t, fkey.map = fkey.parent); + } + else + /* If the sequence is unbound, see if we can hang a function key + off the end of it. */ + /* Continue scan from fkey.end until we find a bound suffix. */ + while (fkey.end < indec.start) + { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + bool done; + int diff; + + GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame); + done = keyremap_step (keybuf, bufsize, &fkey, + max (t, mock_input), + /* If there's a binding (i.e. + first_binding >= nmaps) we don't want + to apply this function-key-mapping. */ + fkey.end + 1 == t + && (test_undefined (current_binding)), + &diff, prompt); + UNGCPRO; + if (done) + { + mock_input = diff + max (t, mock_input); + /* Adjust the input-decode-map counters. */ + indec.end += diff; + indec.start += diff; + + goto replay_sequence; + } + } + + /* Look for this sequence in key-translation-map. + Scan from keytran.end until we find a bound suffix. */ + while (keytran.end < fkey.start) + { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + bool done; + int diff; + + GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame); + done = keyremap_step (keybuf, bufsize, &keytran, max (t, mock_input), + 1, &diff, prompt); + UNGCPRO; + if (done) + { + mock_input = diff + max (t, mock_input); + /* Adjust the function-key-map and input-decode-map counters. */ + indec.end += diff; + indec.start += diff; + fkey.end += diff; + fkey.start += diff; + + goto replay_sequence; + } + } + + /* If KEY is not defined in any of the keymaps, + and cannot be part of a function key or translation, + and is an upper case letter + use the corresponding lower-case letter instead. */ + if (NILP (current_binding) + && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t + && INTEGERP (key) + && ((CHARACTERP (make_number (XINT (key) & ~CHAR_MODIFIER_MASK)) + && uppercasep (XINT (key) & ~CHAR_MODIFIER_MASK)) + || (XINT (key) & shift_modifier))) + { + Lisp_Object new_key; + + original_uppercase = key; + original_uppercase_position = t - 1; + + if (XINT (key) & shift_modifier) + XSETINT (new_key, XINT (key) & ~shift_modifier); + else + XSETINT (new_key, (downcase (XINT (key) & ~CHAR_MODIFIER_MASK) + | (XINT (key) & CHAR_MODIFIER_MASK))); + + /* We have to do this unconditionally, regardless of whether + the lower-case char is defined in the keymaps, because they + might get translated through function-key-map. */ + keybuf[t - 1] = new_key; + mock_input = max (t, mock_input); + shift_translated = 1; + + goto replay_sequence; + } + + if (NILP (current_binding) + && help_char_p (EVENT_HEAD (key)) && t > 1) + { + read_key_sequence_cmd = Vprefix_help_command; + /* The Microsoft C compiler can't handle the goto that + would go here. */ + dummyflag = 1; + break; + } + + /* If KEY is not defined in any of the keymaps, + and cannot be part of a function key or translation, + and is a shifted function key, + use the corresponding unshifted function key instead. */ + if (NILP (current_binding) + && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t) + { + Lisp_Object breakdown = parse_modifiers (key); + int modifiers + = CONSP (breakdown) ? (XINT (XCAR (XCDR (breakdown)))) : 0; + + if (modifiers & shift_modifier + /* Treat uppercase keys as shifted. */ + || (INTEGERP (key) + && (KEY_TO_CHAR (key) + < XCHAR_TABLE (BVAR (current_buffer, downcase_table))->header.size) + && uppercasep (KEY_TO_CHAR (key)))) + { + Lisp_Object new_key + = (modifiers & shift_modifier + ? apply_modifiers (modifiers & ~shift_modifier, + XCAR (breakdown)) + : make_number (downcase (KEY_TO_CHAR (key)) | modifiers)); + + original_uppercase = key; + original_uppercase_position = t - 1; + + /* We have to do this unconditionally, regardless of whether + the lower-case char is defined in the keymaps, because they + might get translated through function-key-map. */ + keybuf[t - 1] = new_key; + mock_input = max (t, mock_input); + /* Reset fkey (and consequently keytran) to apply + function-key-map on the result, so that S-backspace is + correctly mapped to DEL (via backspace). OTOH, + input-decode-map doesn't need to go through it again. */ + fkey.start = fkey.end = 0; + keytran.start = keytran.end = 0; + shift_translated = 1; + + goto replay_sequence; + } + } + } + if (!dummyflag) + read_key_sequence_cmd = current_binding; + read_key_sequence_remapped + /* Remap command through active keymaps. + Do the remapping here, before the unbind_to so it uses the keymaps + of the appropriate buffer. */ + = SYMBOLP (read_key_sequence_cmd) + ? Fcommand_remapping (read_key_sequence_cmd, Qnil, Qnil) + : Qnil; + + unread_switch_frame = delayed_switch_frame; + unbind_to (count, Qnil); + + /* Don't downcase the last character if the caller says don't. + Don't downcase it if the result is undefined, either. */ + if ((dont_downcase_last || NILP (current_binding)) + && t > 0 + && t - 1 == original_uppercase_position) + { + keybuf[t - 1] = original_uppercase; + shift_translated = 0; + } + + if (shift_translated) + Vthis_command_keys_shift_translated = Qt; + + /* Occasionally we fabricate events, perhaps by expanding something + according to function-key-map, or by adding a prefix symbol to a + mouse click in the scroll bar or modeline. In this cases, return + the entire generated key sequence, even if we hit an unbound + prefix or a definition before the end. This means that you will + be able to push back the event properly, and also means that + read-key-sequence will always return a logical unit. + + Better ideas? */ + for (; t < mock_input; t++) + { + if (echo_keystrokes_p ()) + echo_char (keybuf[t]); + add_command_key (keybuf[t]); + } + + UNGCPRO; + return t; +} + +static Lisp_Object +read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo, + Lisp_Object dont_downcase_last, + Lisp_Object can_return_switch_frame, + Lisp_Object cmd_loop, bool allow_string) +{ + Lisp_Object keybuf[30]; + register int i; + struct gcpro gcpro1; + ptrdiff_t count = SPECPDL_INDEX (); + + if (!NILP (prompt)) + CHECK_STRING (prompt); + QUIT; + + specbind (Qinput_method_exit_on_first_char, + (NILP (cmd_loop) ? Qt : Qnil)); + specbind (Qinput_method_use_echo_area, + (NILP (cmd_loop) ? Qt : Qnil)); + + memset (keybuf, 0, sizeof keybuf); + GCPRO1 (keybuf[0]); + gcpro1.nvars = ARRAYELTS (keybuf); + + if (NILP (continue_echo)) + { + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + } + +#ifdef HAVE_WINDOW_SYSTEM + if (display_hourglass_p) + cancel_hourglass (); +#endif + + i = read_key_sequence (keybuf, ARRAYELTS (keybuf), + prompt, ! NILP (dont_downcase_last), + ! NILP (can_return_switch_frame), 0, 0); + +#if 0 /* The following is fine for code reading a key sequence and + then proceeding with a lengthy computation, but it's not good + for code reading keys in a loop, like an input method. */ +#ifdef HAVE_WINDOW_SYSTEM + if (display_hourglass_p) + start_hourglass (); +#endif +#endif + + if (i == -1) + { + Vquit_flag = Qt; + QUIT; + } + UNGCPRO; + return unbind_to (count, + ((allow_string ? make_event_array : Fvector) + (i, keybuf))); +} + +DEFUN ("read-key-sequence", Fread_key_sequence, Sread_key_sequence, 1, 5, 0, + doc: /* Read a sequence of keystrokes and return as a string or vector. +The sequence is sufficient to specify a non-prefix command in the +current local and global maps. + +First arg PROMPT is a prompt string. If nil, do not prompt specially. +Second (optional) arg CONTINUE-ECHO, if non-nil, means this key echos +as a continuation of the previous key. + +The third (optional) arg DONT-DOWNCASE-LAST, if non-nil, means do not +convert the last event to lower case. (Normally any upper case event +is converted to lower case if the original event is undefined and the lower +case equivalent is defined.) A non-nil value is appropriate for reading +a key sequence to be defined. + +A C-g typed while in this function is treated like any other character, +and `quit-flag' is not set. + +If the key sequence starts with a mouse click, then the sequence is read +using the keymaps of the buffer of the window clicked in, not the buffer +of the selected window as normal. + +`read-key-sequence' drops unbound button-down events, since you normally +only care about the click or drag events which follow them. If a drag +or multi-click event is unbound, but the corresponding click event would +be bound, `read-key-sequence' turns the event into a click event at the +drag's starting position. This means that you don't have to distinguish +between click and drag, double, or triple events unless you want to. + +`read-key-sequence' prefixes mouse events on mode lines, the vertical +lines separating windows, and scroll bars with imaginary keys +`mode-line', `vertical-line', and `vertical-scroll-bar'. + +Optional fourth argument CAN-RETURN-SWITCH-FRAME non-nil means that this +function will process a switch-frame event if the user switches frames +before typing anything. If the user switches frames in the middle of a +key sequence, or at the start of the sequence but CAN-RETURN-SWITCH-FRAME +is nil, then the event will be put off until after the current key sequence. + +`read-key-sequence' checks `function-key-map' for function key +sequences, where they wouldn't conflict with ordinary bindings. See +`function-key-map' for more details. + +The optional fifth argument CMD-LOOP, if non-nil, means +that this key sequence is being read by something that will +read commands one after another. It should be nil if the caller +will read just one key sequence. */) + (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop) +{ + return read_key_sequence_vs (prompt, continue_echo, dont_downcase_last, + can_return_switch_frame, cmd_loop, true); +} + +DEFUN ("read-key-sequence-vector", Fread_key_sequence_vector, + Sread_key_sequence_vector, 1, 5, 0, + doc: /* Like `read-key-sequence' but always return a vector. */) + (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop) +{ + return read_key_sequence_vs (prompt, continue_echo, dont_downcase_last, + can_return_switch_frame, cmd_loop, false); +} + +/* Return true if input events are pending. */ + +bool +detect_input_pending (void) +{ + return input_pending || get_input_pending (0); +} + +/* Return true if input events other than mouse movements are + pending. */ + +bool +detect_input_pending_ignore_squeezables (void) +{ + return input_pending || get_input_pending (READABLE_EVENTS_IGNORE_SQUEEZABLES); +} + +/* Return true if input events are pending, and run any pending timers. */ + +bool +detect_input_pending_run_timers (bool do_display) +{ + unsigned old_timers_run = timers_run; + + if (!input_pending) + get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW); + + if (old_timers_run != timers_run && do_display) + redisplay_preserve_echo_area (8); + + return input_pending; +} + +/* This is called in some cases before a possible quit. + It cases the next call to detect_input_pending to recompute input_pending. + So calling this function unnecessarily can't do any harm. */ + +void +clear_input_pending (void) +{ + input_pending = 0; +} + +/* Return true if there are pending requeued events. + This isn't used yet. The hope is to make wait_reading_process_output + call it, and return if it runs Lisp code that unreads something. + The problem is, kbd_buffer_get_event needs to be fixed to know what + to do in that case. It isn't trivial. */ + +bool +requeued_events_pending_p (void) +{ + return (!NILP (Vunread_command_events)); +} + +DEFUN ("input-pending-p", Finput_pending_p, Sinput_pending_p, 0, 1, 0, + doc: /* Return t if command input is currently available with no wait. +Actually, the value is nil only if we can be sure that no input is available; +if there is a doubt, the value is t. + +If CHECK-TIMERS is non-nil, timers that are ready to run will do so. */) + (Lisp_Object check_timers) +{ + if (!NILP (Vunread_command_events) + || !NILP (Vunread_post_input_method_events) + || !NILP (Vunread_input_method_events)) + return (Qt); + + /* Process non-user-visible events (Bug#10195). */ + process_special_events (); + + return (get_input_pending ((NILP (check_timers) + ? 0 : READABLE_EVENTS_DO_TIMERS_NOW) + | READABLE_EVENTS_FILTER_EVENTS) + ? Qt : Qnil); +} + +DEFUN ("recent-keys", Frecent_keys, Srecent_keys, 0, 1, 0, + doc: /* Return vector of last few events, not counting those from keyboard macros. +If INCLUDE-CMDS is non-nil, include the commands that were run, +represented as events of the form (nil . COMMAND). */) + (Lisp_Object include_cmds) +{ + bool cmds = !NILP (include_cmds); + + if (!total_keys + || (cmds && total_keys < NUM_RECENT_KEYS)) + return Fvector (total_keys, + XVECTOR (recent_keys)->contents); + else + { + Lisp_Object es = Qnil; + int i = (total_keys < NUM_RECENT_KEYS + ? 0 : recent_keys_index); + eassert (recent_keys_index < NUM_RECENT_KEYS); + do + { + Lisp_Object e = AREF (recent_keys, i); + if (cmds || !CONSP (e) || !NILP (XCAR (e))) + es = Fcons (e, es); + if (++i >= NUM_RECENT_KEYS) + i = 0; + } while (i != recent_keys_index); + es = Fnreverse (es); + return Fvconcat (1, &es); + } +} + +DEFUN ("this-command-keys", Fthis_command_keys, Sthis_command_keys, 0, 0, 0, + doc: /* Return the key sequence that invoked this command. +However, if the command has called `read-key-sequence', it returns +the last key sequence that has been read. +The value is a string or a vector. + +See also `this-command-keys-vector'. */) + (void) +{ + return make_event_array (this_command_key_count, + XVECTOR (this_command_keys)->contents); +} + +DEFUN ("this-command-keys-vector", Fthis_command_keys_vector, Sthis_command_keys_vector, 0, 0, 0, + doc: /* Return the key sequence that invoked this command, as a vector. +However, if the command has called `read-key-sequence', it returns +the last key sequence that has been read. + +See also `this-command-keys'. */) + (void) +{ + return Fvector (this_command_key_count, + XVECTOR (this_command_keys)->contents); +} + +DEFUN ("this-single-command-keys", Fthis_single_command_keys, + Sthis_single_command_keys, 0, 0, 0, + doc: /* Return the key sequence that invoked this command. +More generally, it returns the last key sequence read, either by +the command loop or by `read-key-sequence'. +Unlike `this-command-keys', this function's value +does not include prefix arguments. +The value is always a vector. */) + (void) +{ + return Fvector (this_command_key_count + - this_single_command_key_start, + (XVECTOR (this_command_keys)->contents + + this_single_command_key_start)); +} + +DEFUN ("this-single-command-raw-keys", Fthis_single_command_raw_keys, + Sthis_single_command_raw_keys, 0, 0, 0, + doc: /* Return the raw events that were read for this command. +More generally, it returns the last key sequence read, either by +the command loop or by `read-key-sequence'. +Unlike `this-single-command-keys', this function's value +shows the events before all translations (except for input methods). +The value is always a vector. */) + (void) +{ + return Fvector (raw_keybuf_count, XVECTOR (raw_keybuf)->contents); +} + +DEFUN ("reset-this-command-lengths", Freset_this_command_lengths, + Sreset_this_command_lengths, 0, 0, 0, + doc: /* Make the unread events replace the last command and echo. +Used in `universal-argument-other-key'. + +`universal-argument-other-key' rereads the event just typed. +It then gets translated through `function-key-map'. +The translated event has to replace the real events, +both in the value of (this-command-keys) and in echoing. +To achieve this, `universal-argument-other-key' calls +`reset-this-command-lengths', which discards the record of reading +these events the first time. */) + (void) +{ + this_command_key_count = before_command_key_count; + if (this_command_key_count < this_single_command_key_start) + this_single_command_key_start = this_command_key_count; + + echo_truncate (before_command_echo_length); + + /* Cause whatever we put into unread-command-events + to echo as if it were being freshly read from the keyboard. */ + this_command_key_count_reset = 1; + + return Qnil; +} + +DEFUN ("clear-this-command-keys", Fclear_this_command_keys, + Sclear_this_command_keys, 0, 1, 0, + doc: /* Clear out the vector that `this-command-keys' returns. +Also clear the record of the last 100 events, unless optional arg +KEEP-RECORD is non-nil. */) + (Lisp_Object keep_record) +{ + int i; + + this_command_key_count = 0; + this_command_key_count_reset = 0; + + if (NILP (keep_record)) + { + for (i = 0; i < ASIZE (recent_keys); ++i) + ASET (recent_keys, i, Qnil); + total_keys = 0; + recent_keys_index = 0; + } + return Qnil; +} + +DEFUN ("recursion-depth", Frecursion_depth, Srecursion_depth, 0, 0, 0, + doc: /* Return the current depth in recursive edits. */) + (void) +{ + Lisp_Object temp; + /* Wrap around reliably on integer overflow. */ + EMACS_INT sum = (command_loop_level & INTMASK) + (minibuf_level & INTMASK); + XSETINT (temp, sum); + return temp; +} + +DEFUN ("open-dribble-file", Fopen_dribble_file, Sopen_dribble_file, 1, 1, + "FOpen dribble file: ", + doc: /* Start writing all keyboard characters to a dribble file called FILE. +If FILE is nil, close any open dribble file. +The file will be closed when Emacs exits. + +Be aware that this records ALL characters you type! +This may include sensitive information such as passwords. */) + (Lisp_Object file) +{ + if (dribble) + { + block_input (); + fclose (dribble); + unblock_input (); + dribble = 0; + } + if (!NILP (file)) + { + int fd; + Lisp_Object encfile; + + file = Fexpand_file_name (file, Qnil); + encfile = ENCODE_FILE (file); + fd = emacs_open (SSDATA (encfile), O_WRONLY | O_CREAT | O_EXCL, 0600); + if (fd < 0 && errno == EEXIST && unlink (SSDATA (encfile)) == 0) + fd = emacs_open (SSDATA (encfile), O_WRONLY | O_CREAT | O_EXCL, 0600); + dribble = fd < 0 ? 0 : fdopen (fd, "w"); + if (dribble == 0) + report_file_error ("Opening dribble", file); + } + return Qnil; +} + +DEFUN ("discard-input", Fdiscard_input, Sdiscard_input, 0, 0, 0, + doc: /* Discard the contents of the terminal input buffer. +Also end any kbd macro being defined. */) + (void) +{ + if (!NILP (KVAR (current_kboard, defining_kbd_macro))) + { + /* Discard the last command from the macro. */ + Fcancel_kbd_macro_events (); + end_kbd_macro (); + } + + Vunread_command_events = Qnil; + + discard_tty_input (); + + kbd_fetch_ptr = kbd_store_ptr; + input_pending = 0; + + return Qnil; +} + +DEFUN ("suspend-emacs", Fsuspend_emacs, Ssuspend_emacs, 0, 1, "", + doc: /* Stop Emacs and return to superior process. You can resume later. +If `cannot-suspend' is non-nil, or if the system doesn't support job +control, run a subshell instead. + +If optional arg STUFFSTRING is non-nil, its characters are stuffed +to be read as terminal input by Emacs's parent, after suspension. + +Before suspending, run the normal hook `suspend-hook'. +After resumption run the normal hook `suspend-resume-hook'. + +Some operating systems cannot stop the Emacs process and resume it later. +On such systems, Emacs starts a subshell instead of suspending. */) + (Lisp_Object stuffstring) +{ + ptrdiff_t count = SPECPDL_INDEX (); + int old_height, old_width; + int width, height; + struct gcpro gcpro1; + + if (tty_list && tty_list->next) + error ("There are other tty frames open; close them before suspending Emacs"); + + if (!NILP (stuffstring)) + CHECK_STRING (stuffstring); + + run_hook (intern ("suspend-hook")); + + GCPRO1 (stuffstring); + get_tty_size (fileno (CURTTY ()->input), &old_width, &old_height); + reset_all_sys_modes (); + /* sys_suspend can get an error if it tries to fork a subshell + and the system resources aren't available for that. */ + record_unwind_protect_void (init_all_sys_modes); + stuff_buffered_input (stuffstring); + if (cannot_suspend) + sys_subshell (); + else + sys_suspend (); + unbind_to (count, Qnil); + + /* Check if terminal/window size has changed. + Note that this is not useful when we are running directly + with a window system; but suspend should be disabled in that case. */ + get_tty_size (fileno (CURTTY ()->input), &width, &height); + if (width != old_width || height != old_height) + change_frame_size (SELECTED_FRAME (), width, + height - FRAME_MENU_BAR_LINES (SELECTED_FRAME ()), + 0, 0, 0, 0); + + run_hook (intern ("suspend-resume-hook")); + + UNGCPRO; + return Qnil; +} + +/* If STUFFSTRING is a string, stuff its contents as pending terminal input. + Then in any case stuff anything Emacs has read ahead and not used. */ + +void +stuff_buffered_input (Lisp_Object stuffstring) +{ +#ifdef SIGTSTP /* stuff_char is defined if SIGTSTP. */ + register unsigned char *p; + + if (STRINGP (stuffstring)) + { + register ptrdiff_t count; + + p = SDATA (stuffstring); + count = SBYTES (stuffstring); + while (count-- > 0) + stuff_char (*p++); + stuff_char ('\n'); + } + + /* Anything we have read ahead, put back for the shell to read. */ + /* ?? What should this do when we have multiple keyboards?? + Should we ignore anything that was typed in at the "wrong" kboard? + + rms: we should stuff everything back into the kboard + it came from. */ + for (; kbd_fetch_ptr != kbd_store_ptr; kbd_fetch_ptr++) + { + + if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) + kbd_fetch_ptr = kbd_buffer; + if (kbd_fetch_ptr->kind == ASCII_KEYSTROKE_EVENT) + stuff_char (kbd_fetch_ptr->code); + + clear_event (kbd_fetch_ptr); + } + + input_pending = 0; +#endif /* SIGTSTP */ +} + +void +set_waiting_for_input (struct timespec *time_to_clear) +{ + input_available_clear_time = time_to_clear; + + /* Tell handle_interrupt to throw back to read_char, */ + waiting_for_input = 1; + + /* If handle_interrupt was called before and buffered a C-g, + make it run again now, to avoid timing error. */ + if (!NILP (Vquit_flag)) + quit_throw_to_read_char (0); +} + +void +clear_waiting_for_input (void) +{ + /* Tell handle_interrupt not to throw back to read_char, */ + waiting_for_input = 0; + input_available_clear_time = 0; +} + +/* The SIGINT handler. + + If we have a frame on the controlling tty, we assume that the + SIGINT was generated by C-g, so we call handle_interrupt. + Otherwise, tell QUIT to kill Emacs. */ + +static void +handle_interrupt_signal (int sig) +{ + /* See if we have an active terminal on our controlling tty. */ + struct terminal *terminal = get_named_terminal ("/dev/tty"); + if (!terminal) + { + /* If there are no frames there, let's pretend that we are a + well-behaving UN*X program and quit. We must not call Lisp + in a signal handler, so tell QUIT to exit when it is + safe. */ + Vquit_flag = Qkill_emacs; + } + else + { + /* Otherwise, the SIGINT was probably generated by C-g. */ + + /* Set internal_last_event_frame to the top frame of the + controlling tty, if we have a frame there. We disable the + interrupt key on secondary ttys, so the SIGINT must have come + from the controlling tty. */ + internal_last_event_frame = terminal->display_info.tty->top_frame; + + handle_interrupt (1); + } +} + +static void +deliver_interrupt_signal (int sig) +{ + deliver_process_signal (sig, handle_interrupt_signal); +} + + +/* If Emacs is stuck because `inhibit-quit' is true, then keep track + of the number of times C-g has been requested. If C-g is pressed + enough times, then quit anyway. See bug#6585. */ +static int volatile force_quit_count; + +/* This routine is called at interrupt level in response to C-g. + + It is called from the SIGINT handler or kbd_buffer_store_event. + + If `waiting_for_input' is non zero, then unless `echoing' is + nonzero, immediately throw back to read_char. + + Otherwise it sets the Lisp variable quit-flag not-nil. This causes + eval to throw, when it gets a chance. If quit-flag is already + non-nil, it stops the job right away. */ + +static void +handle_interrupt (bool in_signal_handler) +{ + char c; + + cancel_echoing (); + + /* XXX This code needs to be revised for multi-tty support. */ + if (!NILP (Vquit_flag) && get_named_terminal ("/dev/tty")) + { + if (! in_signal_handler) + { + /* If SIGINT isn't blocked, don't let us be interrupted by + a SIGINT. It might be harmful due to non-reentrancy + in I/O functions. */ + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGINT); + pthread_sigmask (SIG_BLOCK, &blocked, 0); + } + + fflush (stdout); + reset_all_sys_modes (); + +#ifdef SIGTSTP +/* + * On systems which can suspend the current process and return to the original + * shell, this command causes the user to end up back at the shell. + * The "Auto-save" and "Abort" questions are not asked until + * the user elects to return to emacs, at which point he can save the current + * job and either dump core or continue. + */ + sys_suspend (); +#else + /* Perhaps should really fork an inferior shell? + But that would not provide any way to get back + to the original shell, ever. */ + printf ("No support for stopping a process on this operating system;\n"); + printf ("you can continue or abort.\n"); +#endif /* not SIGTSTP */ +#ifdef MSDOS + /* We must remain inside the screen area when the internal terminal + is used. Note that [Enter] is not echoed by dos. */ + cursor_to (SELECTED_FRAME (), 0, 0); +#endif + /* It doesn't work to autosave while GC is in progress; + the code used for auto-saving doesn't cope with the mark bit. */ + if (!gc_in_progress) + { + printf ("Auto-save? (y or n) "); + fflush (stdout); + if (((c = getchar ()) & ~040) == 'Y') + { + Fdo_auto_save (Qt, Qnil); +#ifdef MSDOS + printf ("\r\nAuto-save done"); +#else /* not MSDOS */ + printf ("Auto-save done\n"); +#endif /* not MSDOS */ + } + while (c != '\n') c = getchar (); + } + else + { + /* During GC, it must be safe to reenable quitting again. */ + Vinhibit_quit = Qnil; +#ifdef MSDOS + printf ("\r\n"); +#endif /* not MSDOS */ + printf ("Garbage collection in progress; cannot auto-save now\r\n"); + printf ("but will instead do a real quit after garbage collection ends\r\n"); + fflush (stdout); + } + +#ifdef MSDOS + printf ("\r\nAbort? (y or n) "); +#else /* not MSDOS */ + printf ("Abort (and dump core)? (y or n) "); +#endif /* not MSDOS */ + fflush (stdout); + if (((c = getchar ()) & ~040) == 'Y') + emacs_abort (); + while (c != '\n') c = getchar (); +#ifdef MSDOS + printf ("\r\nContinuing...\r\n"); +#else /* not MSDOS */ + printf ("Continuing...\n"); +#endif /* not MSDOS */ + fflush (stdout); + init_all_sys_modes (); + } + else + { + /* If executing a function that wants to be interrupted out of + and the user has not deferred quitting by binding `inhibit-quit' + then quit right away. */ + if (immediate_quit && NILP (Vinhibit_quit)) + { + struct gl_state_s saved; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + immediate_quit = 0; + pthread_sigmask (SIG_SETMASK, &empty_mask, 0); + saved = gl_state; + GCPRO4 (saved.object, saved.global_code, + saved.current_syntax_table, saved.old_prop); + Fsignal (Qquit, Qnil); + gl_state = saved; + UNGCPRO; + } + else + { /* Else request quit when it's safe. */ + int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1; + force_quit_count = count; + if (count == 3) + { + immediate_quit = 1; + Vinhibit_quit = Qnil; + } + Vquit_flag = Qt; + } + } + + pthread_sigmask (SIG_SETMASK, &empty_mask, 0); + +/* TODO: The longjmp in this call throws the NS event loop integration off, + and it seems to do fine without this. Probably some attention + needs to be paid to the setting of waiting_for_input in + wait_reading_process_output() under HAVE_NS because of the call + to ns_select there (needed because otherwise events aren't picked up + outside of polling since we don't get SIGIO like X and we don't have a + separate event loop thread like W32. */ +#ifndef HAVE_NS + if (waiting_for_input && !echoing) + quit_throw_to_read_char (in_signal_handler); +#endif +} + +/* Handle a C-g by making read_char return C-g. */ + +static void +quit_throw_to_read_char (bool from_signal) +{ + /* When not called from a signal handler it is safe to call + Lisp. */ + if (!from_signal && EQ (Vquit_flag, Qkill_emacs)) + Fkill_emacs (Qnil); + + /* Prevent another signal from doing this before we finish. */ + clear_waiting_for_input (); + input_pending = 0; + + Vunread_command_events = Qnil; + + if (FRAMEP (internal_last_event_frame) + && !EQ (internal_last_event_frame, selected_frame)) + do_switch_frame (make_lispy_switch_frame (internal_last_event_frame), + 0, 0, Qnil); + + sys_longjmp (getcjmp, 1); +} + +DEFUN ("set-input-interrupt-mode", Fset_input_interrupt_mode, + Sset_input_interrupt_mode, 1, 1, 0, + doc: /* Set interrupt mode of reading keyboard input. +If INTERRUPT is non-nil, Emacs will use input interrupts; +otherwise Emacs uses CBREAK mode. + +See also `current-input-mode'. */) + (Lisp_Object interrupt) +{ + bool new_interrupt_input; +#ifdef USABLE_SIGIO +#ifdef HAVE_X_WINDOWS + if (x_display_list != NULL) + { + /* When using X, don't give the user a real choice, + because we haven't implemented the mechanisms to support it. */ + new_interrupt_input = 1; + } + else +#endif /* HAVE_X_WINDOWS */ + new_interrupt_input = !NILP (interrupt); +#else /* not USABLE_SIGIO */ + new_interrupt_input = 0; +#endif /* not USABLE_SIGIO */ + + if (new_interrupt_input != interrupt_input) + { +#ifdef POLL_FOR_INPUT + stop_polling (); +#endif +#ifndef DOS_NT + /* this causes startup screen to be restored and messes with the mouse */ + reset_all_sys_modes (); + interrupt_input = new_interrupt_input; + init_all_sys_modes (); +#else + interrupt_input = new_interrupt_input; +#endif + +#ifdef POLL_FOR_INPUT + poll_suppress_count = 1; + start_polling (); +#endif + } + return Qnil; +} + +DEFUN ("set-output-flow-control", Fset_output_flow_control, Sset_output_flow_control, 1, 2, 0, + doc: /* Enable or disable ^S/^Q flow control for output to TERMINAL. +If FLOW is non-nil, flow control is enabled and you cannot use C-s or +C-q in key sequences. + +This setting only has an effect on tty terminals and only when +Emacs reads input in CBREAK mode; see `set-input-interrupt-mode'. + +See also `current-input-mode'. */) + (Lisp_Object flow, Lisp_Object terminal) +{ + struct terminal *t = decode_tty_terminal (terminal); + struct tty_display_info *tty; + + if (!t) + return Qnil; + tty = t->display_info.tty; + + if (tty->flow_control != !NILP (flow)) + { +#ifndef DOS_NT + /* This causes startup screen to be restored and messes with the mouse. */ + reset_sys_modes (tty); +#endif + + tty->flow_control = !NILP (flow); + +#ifndef DOS_NT + init_sys_modes (tty); +#endif + } + return Qnil; +} + +DEFUN ("set-input-meta-mode", Fset_input_meta_mode, Sset_input_meta_mode, 1, 2, 0, + doc: /* Enable or disable 8-bit input on TERMINAL. +If META is t, Emacs will accept 8-bit input, and interpret the 8th +bit as the Meta modifier. + +If META is nil, Emacs will ignore the top bit, on the assumption it is +parity. + +Otherwise, Emacs will accept and pass through 8-bit input without +specially interpreting the top bit. + +This setting only has an effect on tty terminal devices. + +Optional parameter TERMINAL specifies the tty terminal device to use. +It may be a terminal object, a frame, or nil for the terminal used by +the currently selected frame. + +See also `current-input-mode'. */) + (Lisp_Object meta, Lisp_Object terminal) +{ + struct terminal *t = decode_tty_terminal (terminal); + struct tty_display_info *tty; + int new_meta; + + if (!t) + return Qnil; + tty = t->display_info.tty; + + if (NILP (meta)) + new_meta = 0; + else if (EQ (meta, Qt)) + new_meta = 1; + else + new_meta = 2; + + if (tty->meta_key != new_meta) + { +#ifndef DOS_NT + /* this causes startup screen to be restored and messes with the mouse */ + reset_sys_modes (tty); +#endif + + tty->meta_key = new_meta; + +#ifndef DOS_NT + init_sys_modes (tty); +#endif + } + return Qnil; +} + +DEFUN ("set-quit-char", Fset_quit_char, Sset_quit_char, 1, 1, 0, + doc: /* Specify character used for quitting. +QUIT must be an ASCII character. + +This function only has an effect on the controlling tty of the Emacs +process. + +See also `current-input-mode'. */) + (Lisp_Object quit) +{ + struct terminal *t = get_named_terminal ("/dev/tty"); + struct tty_display_info *tty; + + if (!t) + return Qnil; + tty = t->display_info.tty; + + if (NILP (quit) || !INTEGERP (quit) || XINT (quit) < 0 || XINT (quit) > 0400) + error ("QUIT must be an ASCII character"); + +#ifndef DOS_NT + /* this causes startup screen to be restored and messes with the mouse */ + reset_sys_modes (tty); +#endif + + /* Don't let this value be out of range. */ + quit_char = XINT (quit) & (tty->meta_key == 0 ? 0177 : 0377); + +#ifndef DOS_NT + init_sys_modes (tty); +#endif + + return Qnil; +} + +DEFUN ("set-input-mode", Fset_input_mode, Sset_input_mode, 3, 4, 0, + doc: /* Set mode of reading keyboard input. +First arg INTERRUPT non-nil means use input interrupts; + nil means use CBREAK mode. +Second arg FLOW non-nil means use ^S/^Q flow control for output to terminal + (no effect except in CBREAK mode). +Third arg META t means accept 8-bit input (for a Meta key). + META nil means ignore the top bit, on the assumption it is parity. + Otherwise, accept 8-bit input and don't use the top bit for Meta. +Optional fourth arg QUIT if non-nil specifies character to use for quitting. +See also `current-input-mode'. */) + (Lisp_Object interrupt, Lisp_Object flow, Lisp_Object meta, Lisp_Object quit) +{ + Fset_input_interrupt_mode (interrupt); + Fset_output_flow_control (flow, Qnil); + Fset_input_meta_mode (meta, Qnil); + if (!NILP (quit)) + Fset_quit_char (quit); + return Qnil; +} + +DEFUN ("current-input-mode", Fcurrent_input_mode, Scurrent_input_mode, 0, 0, 0, + doc: /* Return information about the way Emacs currently reads keyboard input. +The value is a list of the form (INTERRUPT FLOW META QUIT), where + INTERRUPT is non-nil if Emacs is using interrupt-driven input; if + nil, Emacs is using CBREAK mode. + FLOW is non-nil if Emacs uses ^S/^Q flow control for output to the + terminal; this does not apply if Emacs uses interrupt-driven input. + META is t if accepting 8-bit input with 8th bit as Meta flag. + META nil means ignoring the top bit, on the assumption it is parity. + META is neither t nor nil if accepting 8-bit input and using + all 8 bits as the character code. + QUIT is the character Emacs currently uses to quit. +The elements of this list correspond to the arguments of +`set-input-mode'. */) + (void) +{ + struct frame *sf = XFRAME (selected_frame); + + Lisp_Object interrupt = interrupt_input ? Qt : Qnil; + Lisp_Object flow, meta; + if (FRAME_TERMCAP_P (sf) || FRAME_MSDOS_P (sf)) + { + flow = FRAME_TTY (sf)->flow_control ? Qt : Qnil; + meta = (FRAME_TTY (sf)->meta_key == 2 + ? make_number (0) + : (CURTTY ()->meta_key == 1 ? Qt : Qnil)); + } + else + { + flow = Qnil; + meta = Qt; + } + Lisp_Object quit = make_number (quit_char); + + return list4 (interrupt, flow, meta, quit); +} + +DEFUN ("posn-at-x-y", Fposn_at_x_y, Sposn_at_x_y, 2, 4, 0, + doc: /* Return position information for pixel coordinates X and Y. +By default, X and Y are relative to text area of the selected window. +Optional third arg FRAME-OR-WINDOW non-nil specifies frame or window. +If optional fourth arg WHOLE is non-nil, X is relative to the left +edge of the window. + +The return value is similar to a mouse click position: + (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW) + IMAGE (DX . DY) (WIDTH . HEIGHT)) +The `posn-' functions access elements of such lists. */) + (Lisp_Object x, Lisp_Object y, Lisp_Object frame_or_window, Lisp_Object whole) +{ + CHECK_NATNUM (x); + CHECK_NATNUM (y); + + if (NILP (frame_or_window)) + frame_or_window = selected_window; + + if (WINDOWP (frame_or_window)) + { + struct window *w = decode_live_window (frame_or_window); + + XSETINT (x, (XINT (x) + + WINDOW_LEFT_EDGE_X (w) + + (NILP (whole) + ? window_box_left_offset (w, TEXT_AREA) + : 0))); + XSETINT (y, WINDOW_TO_FRAME_PIXEL_Y (w, XINT (y))); + frame_or_window = w->frame; + } + + CHECK_LIVE_FRAME (frame_or_window); + + return make_lispy_position (XFRAME (frame_or_window), x, y, 0); +} + +DEFUN ("posn-at-point", Fposn_at_point, Sposn_at_point, 0, 2, 0, + doc: /* Return position information for buffer POS in WINDOW. +POS defaults to point in WINDOW; WINDOW defaults to the selected window. + +Return nil if position is not visible in window. Otherwise, +the return value is similar to that returned by `event-start' for +a mouse click at the upper left corner of the glyph corresponding +to the given buffer position: + (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW) + IMAGE (DX . DY) (WIDTH . HEIGHT)) +The `posn-' functions access elements of such lists. */) + (Lisp_Object pos, Lisp_Object window) +{ + Lisp_Object tem; + + if (NILP (window)) + window = selected_window; + + tem = Fpos_visible_in_window_p (pos, window, Qt); + if (!NILP (tem)) + { + Lisp_Object x = XCAR (tem); + Lisp_Object y = XCAR (XCDR (tem)); + + /* Point invisible due to hscrolling? */ + if (XINT (x) < 0) + return Qnil; + tem = Fposn_at_x_y (x, y, window, Qnil); + } + + return tem; +} + +/* Set up a new kboard object with reasonable initial values. + TYPE is a window system for which this keyboard is used. */ + +static void +init_kboard (KBOARD *kb, Lisp_Object type) +{ + kset_overriding_terminal_local_map (kb, Qnil); + kset_last_command (kb, Qnil); + kset_real_last_command (kb, Qnil); + kset_keyboard_translate_table (kb, Qnil); + kset_last_repeatable_command (kb, Qnil); + kset_prefix_arg (kb, Qnil); + kset_last_prefix_arg (kb, Qnil); + kset_kbd_queue (kb, Qnil); + kb->kbd_queue_has_data = 0; + kb->immediate_echo = 0; + kset_echo_string (kb, Qnil); + kb->echo_after_prompt = -1; + kb->kbd_macro_buffer = 0; + kb->kbd_macro_bufsize = 0; + kset_defining_kbd_macro (kb, Qnil); + kset_last_kbd_macro (kb, Qnil); + kb->reference_count = 0; + kset_system_key_alist (kb, Qnil); + kset_system_key_syms (kb, Qnil); + kset_window_system (kb, type); + kset_input_decode_map (kb, Fmake_sparse_keymap (Qnil)); + kset_local_function_key_map (kb, Fmake_sparse_keymap (Qnil)); + Fset_keymap_parent (KVAR (kb, Vlocal_function_key_map), Vfunction_key_map); + kset_default_minibuffer_frame (kb, Qnil); +} + +/* Allocate and basically initialize keyboard + object to use with window system TYPE. */ + +KBOARD * +allocate_kboard (Lisp_Object type) +{ + KBOARD *kb = xmalloc (sizeof *kb); + + init_kboard (kb, type); + kb->next_kboard = all_kboards; + all_kboards = kb; + return kb; +} + +/* + * Destroy the contents of a kboard object, but not the object itself. + * We use this just before deleting it, or if we're going to initialize + * it a second time. + */ +static void +wipe_kboard (KBOARD *kb) +{ + xfree (kb->kbd_macro_buffer); +} + +/* Free KB and memory referenced from it. */ + +void +delete_kboard (KBOARD *kb) +{ + KBOARD **kbp; + + for (kbp = &all_kboards; *kbp != kb; kbp = &(*kbp)->next_kboard) + if (*kbp == NULL) + emacs_abort (); + *kbp = kb->next_kboard; + + /* Prevent a dangling reference to KB. */ + if (kb == current_kboard + && FRAMEP (selected_frame) + && FRAME_LIVE_P (XFRAME (selected_frame))) + { + current_kboard = FRAME_KBOARD (XFRAME (selected_frame)); + single_kboard = 0; + if (current_kboard == kb) + emacs_abort (); + } + + wipe_kboard (kb); + xfree (kb); +} + +void +init_keyboard (void) +{ + /* This is correct before outermost invocation of the editor loop. */ + command_loop_level = -1; + immediate_quit = 0; + quit_char = Ctl ('g'); + Vunread_command_events = Qnil; + timer_idleness_start_time = invalid_timespec (); + total_keys = 0; + recent_keys_index = 0; + kbd_fetch_ptr = kbd_buffer; + kbd_store_ptr = kbd_buffer; + do_mouse_tracking = Qnil; + input_pending = 0; + interrupt_input_blocked = 0; + pending_signals = 0; + + /* This means that command_loop_1 won't try to select anything the first + time through. */ + internal_last_event_frame = Qnil; + Vlast_event_frame = internal_last_event_frame; + + current_kboard = initial_kboard; + /* Re-initialize the keyboard again. */ + wipe_kboard (current_kboard); + /* A value of nil for Vwindow_system normally means a tty, but we also use + it for the initial terminal since there is no window system there. */ + init_kboard (current_kboard, Qnil); + + if (!noninteractive) + { + /* Before multi-tty support, these handlers used to be installed + only if the current session was a tty session. Now an Emacs + session may have multiple display types, so we always handle + SIGINT. There is special code in handle_interrupt_signal to exit + Emacs on SIGINT when there are no termcap frames on the + controlling terminal. */ + struct sigaction action; + emacs_sigaction_init (&action, deliver_interrupt_signal); + sigaction (SIGINT, &action, 0); +#ifndef DOS_NT + /* For systems with SysV TERMIO, C-g is set up for both SIGINT and + SIGQUIT and we can't tell which one it will give us. */ + sigaction (SIGQUIT, &action, 0); +#endif /* not DOS_NT */ + } +#ifdef USABLE_SIGIO + if (!noninteractive) + { + struct sigaction action; + emacs_sigaction_init (&action, deliver_input_available_signal); + sigaction (SIGIO, &action, 0); + } +#endif + +/* Use interrupt input by default, if it works and noninterrupt input + has deficiencies. */ + +#ifdef INTERRUPT_INPUT + interrupt_input = 1; +#else + interrupt_input = 0; +#endif + + pthread_sigmask (SIG_SETMASK, &empty_mask, 0); + dribble = 0; + + if (keyboard_init_hook) + (*keyboard_init_hook) (); + +#ifdef POLL_FOR_INPUT + poll_timer = NULL; + poll_suppress_count = 1; + start_polling (); +#endif +} + +/* This type's only use is in syms_of_keyboard, to put properties on the + event header symbols. */ +struct event_head +{ + short var; + short kind; +}; + +static const struct event_head head_table[] = { + {SYMBOL_INDEX (Qmouse_movement), SYMBOL_INDEX (Qmouse_movement)}, + {SYMBOL_INDEX (Qscroll_bar_movement), SYMBOL_INDEX (Qmouse_movement)}, + + /* Some of the event heads. */ + {SYMBOL_INDEX (Qswitch_frame), SYMBOL_INDEX (Qswitch_frame)}, + + {SYMBOL_INDEX (Qfocus_in), SYMBOL_INDEX (Qfocus_in)}, + {SYMBOL_INDEX (Qfocus_out), SYMBOL_INDEX (Qfocus_out)}, + {SYMBOL_INDEX (Qdelete_frame), SYMBOL_INDEX (Qdelete_frame)}, + {SYMBOL_INDEX (Qiconify_frame), SYMBOL_INDEX (Qiconify_frame)}, + {SYMBOL_INDEX (Qmake_frame_visible), SYMBOL_INDEX (Qmake_frame_visible)}, + /* `select-window' should be handled just like `switch-frame' + in read_key_sequence. */ + {SYMBOL_INDEX (Qselect_window), SYMBOL_INDEX (Qswitch_frame)} +}; + +void +syms_of_keyboard (void) +{ + pending_funcalls = Qnil; + staticpro (&pending_funcalls); + + Vlispy_mouse_stem = build_pure_c_string ("mouse"); + staticpro (&Vlispy_mouse_stem); + + regular_top_level_message = build_pure_c_string ("Back to top level"); +#ifdef HAVE_STACK_OVERFLOW_HANDLING + recover_top_level_message + = build_pure_c_string ("Re-entering top level after C stack overflow"); +#endif + DEFVAR_LISP ("internal--top-level-message", Vinternal__top_level_message, + doc: /* Message displayed by `normal-top-level'. */); + Vinternal__top_level_message = regular_top_level_message; + + /* Tool-bars. */ + DEFSYM (QCimage, ":image"); + DEFSYM (Qhelp_echo, "help-echo"); + DEFSYM (QCrtl, ":rtl"); + + staticpro (&item_properties); + item_properties = Qnil; + + staticpro (&tool_bar_item_properties); + tool_bar_item_properties = Qnil; + staticpro (&tool_bar_items_vector); + tool_bar_items_vector = Qnil; + + DEFSYM (Qtimer_event_handler, "timer-event-handler"); + DEFSYM (Qdisabled_command_function, "disabled-command-function"); + DEFSYM (Qself_insert_command, "self-insert-command"); + DEFSYM (Qforward_char, "forward-char"); + DEFSYM (Qbackward_char, "backward-char"); + + /* Non-nil disable property on a command means do not execute it; + call disabled-command-function's value instead. */ + DEFSYM (Qdisabled, "disabled"); + + DEFSYM (Qundefined, "undefined"); + + /* Hooks to run before and after each command. */ + DEFSYM (Qpre_command_hook, "pre-command-hook"); + DEFSYM (Qpost_command_hook, "post-command-hook"); + + DEFSYM (Qdeferred_action_function, "deferred-action-function"); + DEFSYM (Qdelayed_warnings_hook, "delayed-warnings-hook"); + DEFSYM (Qfunction_key, "function-key"); + + /* The values of Qevent_kind properties. */ + DEFSYM (Qmouse_click, "mouse-click"); + + DEFSYM (Qdrag_n_drop, "drag-n-drop"); + DEFSYM (Qsave_session, "save-session"); + DEFSYM (Qconfig_changed_event, "config-changed-event"); + + /* Menu and tool bar item parts. */ + DEFSYM (Qmenu_enable, "menu-enable"); + +#ifdef HAVE_NTGUI + DEFSYM (Qlanguage_change, "language-change"); +#endif + +#ifdef HAVE_DBUS + DEFSYM (Qdbus_event, "dbus-event"); +#endif + +#ifdef USE_FILE_NOTIFY + DEFSYM (Qfile_notify, "file-notify"); +#endif /* USE_FILE_NOTIFY */ + + /* Menu and tool bar item parts. */ + DEFSYM (QCenable, ":enable"); + DEFSYM (QCvisible, ":visible"); + DEFSYM (QChelp, ":help"); + DEFSYM (QCfilter, ":filter"); + DEFSYM (QCbutton, ":button"); + DEFSYM (QCkeys, ":keys"); + DEFSYM (QCkey_sequence, ":key-sequence"); + + /* Non-nil disable property on a command means + do not execute it; call disabled-command-function's value instead. */ + DEFSYM (QCtoggle, ":toggle"); + DEFSYM (QCradio, ":radio"); + DEFSYM (QClabel, ":label"); + DEFSYM (QCvert_only, ":vert-only"); + + /* Symbols to use for parts of windows. */ + DEFSYM (Qvertical_line, "vertical-line"); + DEFSYM (Qright_divider, "right-divider"); + DEFSYM (Qbottom_divider, "bottom-divider"); + + DEFSYM (Qmouse_fixup_help_message, "mouse-fixup-help-message"); + + DEFSYM (Qabove_handle, "above-handle"); + DEFSYM (Qhandle, "handle"); + DEFSYM (Qbelow_handle, "below-handle"); + DEFSYM (Qup, "up"); + DEFSYM (Qdown, "down"); + DEFSYM (Qtop, "top"); + DEFSYM (Qbottom, "bottom"); + DEFSYM (Qend_scroll, "end-scroll"); + DEFSYM (Qratio, "ratio"); + DEFSYM (Qbefore_handle, "before-handle"); + DEFSYM (Qhorizontal_handle, "horizontal-handle"); + DEFSYM (Qafter_handle, "after-handle"); + DEFSYM (Qleft, "left"); + DEFSYM (Qright, "right"); + DEFSYM (Qleftmost, "leftmost"); + DEFSYM (Qrightmost, "rightmost"); + + /* Properties of event headers. */ + DEFSYM (Qevent_kind, "event-kind"); + DEFSYM (Qevent_symbol_elements, "event-symbol-elements"); + + /* An event header symbol HEAD may have a property named + Qevent_symbol_element_mask, which is of the form (BASE MODIFIERS); + BASE is the base, unmodified version of HEAD, and MODIFIERS is the + mask of modifiers applied to it. If present, this is used to help + speed up parse_modifiers. */ + DEFSYM (Qevent_symbol_element_mask, "event-symbol-element-mask"); + + /* An unmodified event header BASE may have a property named + Qmodifier_cache, which is an alist mapping modifier masks onto + modified versions of BASE. If present, this helps speed up + apply_modifiers. */ + DEFSYM (Qmodifier_cache, "modifier-cache"); + + DEFSYM (Qrecompute_lucid_menubar, "recompute-lucid-menubar"); + DEFSYM (Qactivate_menubar_hook, "activate-menubar-hook"); + + DEFSYM (Qpolling_period, "polling-period"); + + DEFSYM (Qgui_set_selection, "gui-set-selection"); + + /* The primary selection. */ + DEFSYM (QPRIMARY, "PRIMARY"); + + DEFSYM (Qhandle_switch_frame, "handle-switch-frame"); + DEFSYM (Qhandle_select_window, "handle-select-window"); + + DEFSYM (Qinput_method_function, "input-method-function"); + DEFSYM (Qinput_method_exit_on_first_char, "input-method-exit-on-first-char"); + DEFSYM (Qinput_method_use_echo_area, "input-method-use-echo-area"); + + DEFSYM (Qhelp_form_show, "help-form-show"); + + DEFSYM (Qecho_keystrokes, "echo-keystrokes"); + + Fset (Qinput_method_exit_on_first_char, Qnil); + Fset (Qinput_method_use_echo_area, Qnil); + + /* Symbols to head events. */ + DEFSYM (Qmouse_movement, "mouse-movement"); + DEFSYM (Qscroll_bar_movement, "scroll-bar-movement"); + DEFSYM (Qswitch_frame, "switch-frame"); + DEFSYM (Qfocus_in, "focus-in"); + DEFSYM (Qfocus_out, "focus-out"); + DEFSYM (Qdelete_frame, "delete-frame"); + DEFSYM (Qiconify_frame, "iconify-frame"); + DEFSYM (Qmake_frame_visible, "make-frame-visible"); + DEFSYM (Qselect_window, "select-window"); + { + int i; + + for (i = 0; i < ARRAYELTS (head_table); i++) + { + const struct event_head *p = &head_table[i]; + Lisp_Object var = builtin_lisp_symbol (p->var); + Lisp_Object kind = builtin_lisp_symbol (p->kind); + Fput (var, Qevent_kind, kind); + Fput (var, Qevent_symbol_elements, list1 (var)); + } + } + + button_down_location = Fmake_vector (make_number (5), Qnil); + staticpro (&button_down_location); + mouse_syms = Fmake_vector (make_number (5), Qnil); + staticpro (&mouse_syms); + wheel_syms = Fmake_vector (make_number (ARRAYELTS (lispy_wheel_names)), + Qnil); + staticpro (&wheel_syms); + + { + int i; + int len = ARRAYELTS (modifier_names); + + modifier_symbols = Fmake_vector (make_number (len), Qnil); + for (i = 0; i < len; i++) + if (modifier_names[i]) + ASET (modifier_symbols, i, intern_c_string (modifier_names[i])); + staticpro (&modifier_symbols); + } + + recent_keys = Fmake_vector (make_number (NUM_RECENT_KEYS), Qnil); + staticpro (&recent_keys); + + this_command_keys = Fmake_vector (make_number (40), Qnil); + staticpro (&this_command_keys); + + raw_keybuf = Fmake_vector (make_number (30), Qnil); + staticpro (&raw_keybuf); + + DEFSYM (Qcommand_execute, "command-execute"); + + accent_key_syms = Qnil; + staticpro (&accent_key_syms); + + func_key_syms = Qnil; + staticpro (&func_key_syms); + + drag_n_drop_syms = Qnil; + staticpro (&drag_n_drop_syms); + + unread_switch_frame = Qnil; + staticpro (&unread_switch_frame); + + internal_last_event_frame = Qnil; + staticpro (&internal_last_event_frame); + + read_key_sequence_cmd = Qnil; + staticpro (&read_key_sequence_cmd); + read_key_sequence_remapped = Qnil; + staticpro (&read_key_sequence_remapped); + + menu_bar_one_keymap_changed_items = Qnil; + staticpro (&menu_bar_one_keymap_changed_items); + + menu_bar_items_vector = Qnil; + staticpro (&menu_bar_items_vector); + + help_form_saved_window_configs = Qnil; + staticpro (&help_form_saved_window_configs); + + defsubr (&Scurrent_idle_time); + defsubr (&Sevent_symbol_parse_modifiers); + defsubr (&Sevent_convert_list); + defsubr (&Sread_key_sequence); + defsubr (&Sread_key_sequence_vector); + defsubr (&Srecursive_edit); + defsubr (&Strack_mouse); + defsubr (&Sinput_pending_p); + defsubr (&Srecent_keys); + defsubr (&Sthis_command_keys); + defsubr (&Sthis_command_keys_vector); + defsubr (&Sthis_single_command_keys); + defsubr (&Sthis_single_command_raw_keys); + defsubr (&Sreset_this_command_lengths); + defsubr (&Sclear_this_command_keys); + defsubr (&Ssuspend_emacs); + defsubr (&Sabort_recursive_edit); + defsubr (&Sexit_recursive_edit); + defsubr (&Srecursion_depth); + defsubr (&Scommand_error_default_function); + defsubr (&Stop_level); + defsubr (&Sdiscard_input); + defsubr (&Sopen_dribble_file); + defsubr (&Sset_input_interrupt_mode); + defsubr (&Sset_output_flow_control); + defsubr (&Sset_input_meta_mode); + defsubr (&Sset_quit_char); + defsubr (&Sset_input_mode); + defsubr (&Scurrent_input_mode); + defsubr (&Sposn_at_point); + defsubr (&Sposn_at_x_y); + + DEFVAR_LISP ("last-command-event", last_command_event, + doc: /* Last input event that was part of a command. */); + + DEFVAR_LISP ("last-nonmenu-event", last_nonmenu_event, + doc: /* Last input event in a command, except for mouse menu events. +Mouse menus give back keys that don't look like mouse events; +this variable holds the actual mouse event that led to the menu, +so that you can determine whether the command was run by mouse or not. */); + + DEFVAR_LISP ("last-input-event", last_input_event, + doc: /* Last input event. */); + + DEFVAR_LISP ("unread-command-events", Vunread_command_events, + doc: /* List of events to be read as the command input. +These events are processed first, before actual keyboard input. +Events read from this list are not normally added to `this-command-keys', +as they will already have been added once as they were read for the first time. +An element of the form (t . EVENT) forces EVENT to be added to that list. */); + Vunread_command_events = Qnil; + + DEFVAR_LISP ("unread-post-input-method-events", Vunread_post_input_method_events, + doc: /* List of events to be processed as input by input methods. +These events are processed before `unread-command-events' +and actual keyboard input, but are not given to `input-method-function'. */); + Vunread_post_input_method_events = Qnil; + + DEFVAR_LISP ("unread-input-method-events", Vunread_input_method_events, + doc: /* List of events to be processed as input by input methods. +These events are processed after `unread-command-events', but +before actual keyboard input. +If there's an active input method, the events are given to +`input-method-function'. */); + Vunread_input_method_events = Qnil; + + DEFVAR_LISP ("meta-prefix-char", meta_prefix_char, + doc: /* Meta-prefix character code. +Meta-foo as command input turns into this character followed by foo. */); + XSETINT (meta_prefix_char, 033); + + DEFVAR_KBOARD ("last-command", Vlast_command, + doc: /* The last command executed. +Normally a symbol with a function definition, but can be whatever was found +in the keymap, or whatever the variable `this-command' was set to by that +command. + +The value `mode-exit' is special; it means that the previous command +read an event that told it to exit, and it did so and unread that event. +In other words, the present command is the event that made the previous +command exit. + +The value `kill-region' is special; it means that the previous command +was a kill command. + +`last-command' has a separate binding for each terminal device. +See Info node `(elisp)Multiple Terminals'. */); + + DEFVAR_KBOARD ("real-last-command", Vreal_last_command, + doc: /* Same as `last-command', but never altered by Lisp code. +Taken from the previous value of `real-this-command'. */); + + DEFVAR_KBOARD ("last-repeatable-command", Vlast_repeatable_command, + doc: /* Last command that may be repeated. +The last command executed that was not bound to an input event. +This is the command `repeat' will try to repeat. +Taken from a previous value of `real-this-command'. */); + + DEFVAR_LISP ("this-command", Vthis_command, + doc: /* The command now being executed. +The command can set this variable; whatever is put here +will be in `last-command' during the following command. */); + Vthis_command = Qnil; + + DEFVAR_LISP ("real-this-command", Vreal_this_command, + doc: /* This is like `this-command', except that commands should never modify it. */); + Vreal_this_command = Qnil; + + DEFVAR_LISP ("this-command-keys-shift-translated", + Vthis_command_keys_shift_translated, + doc: /* Non-nil if the key sequence activating this command was shift-translated. +Shift-translation occurs when there is no binding for the key sequence +as entered, but a binding was found by changing an upper-case letter +to lower-case, or a shifted function key to an unshifted one. */); + Vthis_command_keys_shift_translated = Qnil; + + DEFVAR_LISP ("this-original-command", Vthis_original_command, + doc: /* The command bound to the current key sequence before remapping. +It equals `this-command' if the original command was not remapped through +any of the active keymaps. Otherwise, the value of `this-command' is the +result of looking up the original command in the active keymaps. */); + Vthis_original_command = Qnil; + + DEFVAR_INT ("auto-save-interval", auto_save_interval, + doc: /* Number of input events between auto-saves. +Zero means disable autosaving due to number of characters typed. */); + auto_save_interval = 300; + + DEFVAR_LISP ("auto-save-timeout", Vauto_save_timeout, + doc: /* Number of seconds idle time before auto-save. +Zero or nil means disable auto-saving due to idleness. +After auto-saving due to this many seconds of idle time, +Emacs also does a garbage collection if that seems to be warranted. */); + XSETFASTINT (Vauto_save_timeout, 30); + + DEFVAR_LISP ("echo-keystrokes", Vecho_keystrokes, + doc: /* Nonzero means echo unfinished commands after this many seconds of pause. +The value may be integer or floating point. +If the value is zero, don't echo at all. */); + Vecho_keystrokes = make_number (1); + + DEFVAR_INT ("polling-period", polling_period, + doc: /* Interval between polling for input during Lisp execution. +The reason for polling is to make C-g work to stop a running program. +Polling is needed only when using X windows and SIGIO does not work. +Polling is automatically disabled in all other cases. */); + polling_period = 2; + + DEFVAR_LISP ("double-click-time", Vdouble_click_time, + doc: /* Maximum time between mouse clicks to make a double-click. +Measured in milliseconds. The value nil means disable double-click +recognition; t means double-clicks have no time limit and are detected +by position only. */); + Vdouble_click_time = make_number (500); + + DEFVAR_INT ("double-click-fuzz", double_click_fuzz, + doc: /* Maximum mouse movement between clicks to make a double-click. +On window-system frames, value is the number of pixels the mouse may have +moved horizontally or vertically between two clicks to make a double-click. +On non window-system frames, value is interpreted in units of 1/8 characters +instead of pixels. + +This variable is also the threshold for motion of the mouse +to count as a drag. */); + double_click_fuzz = 3; + + DEFVAR_INT ("num-input-keys", num_input_keys, + doc: /* Number of complete key sequences read as input so far. +This includes key sequences read from keyboard macros. +The number is effectively the number of interactive command invocations. */); + num_input_keys = 0; + + DEFVAR_INT ("num-nonmacro-input-events", num_nonmacro_input_events, + doc: /* Number of input events read from the keyboard so far. +This does not include events generated by keyboard macros. */); + num_nonmacro_input_events = 0; + + DEFVAR_LISP ("last-event-frame", Vlast_event_frame, + doc: /* The frame in which the most recently read event occurred. +If the last event came from a keyboard macro, this is set to `macro'. */); + Vlast_event_frame = Qnil; + + /* This variable is set up in sysdep.c. */ + DEFVAR_LISP ("tty-erase-char", Vtty_erase_char, + doc: /* The ERASE character as set by the user with stty. */); + + DEFVAR_LISP ("help-char", Vhelp_char, + doc: /* Character to recognize as meaning Help. +When it is read, do `(eval help-form)', and display result if it's a string. +If the value of `help-form' is nil, this char can be read normally. */); + XSETINT (Vhelp_char, Ctl ('H')); + + DEFVAR_LISP ("help-event-list", Vhelp_event_list, + doc: /* List of input events to recognize as meaning Help. +These work just like the value of `help-char' (see that). */); + Vhelp_event_list = Qnil; + + DEFVAR_LISP ("help-form", Vhelp_form, + doc: /* Form to execute when character `help-char' is read. +If the form returns a string, that string is displayed. +If `help-form' is nil, the help char is not recognized. */); + Vhelp_form = Qnil; + + DEFVAR_LISP ("prefix-help-command", Vprefix_help_command, + doc: /* Command to run when `help-char' character follows a prefix key. +This command is used only when there is no actual binding +for that character after that prefix key. */); + Vprefix_help_command = Qnil; + + DEFVAR_LISP ("top-level", Vtop_level, + doc: /* Form to evaluate when Emacs starts up. +Useful to set before you dump a modified Emacs. */); + Vtop_level = Qnil; + XSYMBOL (Qtop_level)->declared_special = false; + + DEFVAR_KBOARD ("keyboard-translate-table", Vkeyboard_translate_table, + doc: /* Translate table for local keyboard input, or nil. +If non-nil, the value should be a char-table. Each character read +from the keyboard is looked up in this char-table. If the value found +there is non-nil, then it is used instead of the actual input character. + +The value can also be a string or vector, but this is considered obsolete. +If it is a string or vector of length N, character codes N and up are left +untranslated. In a vector, an element which is nil means "no translation". + +This is applied to the characters supplied to input methods, not their +output. See also `translation-table-for-input'. + +This variable has a separate binding for each terminal. +See Info node `(elisp)Multiple Terminals'. */); + + DEFVAR_BOOL ("cannot-suspend", cannot_suspend, + doc: /* Non-nil means to always spawn a subshell instead of suspending. +\(Even if the operating system has support for stopping a process.\) */); + cannot_suspend = 0; + + DEFVAR_BOOL ("menu-prompting", menu_prompting, + doc: /* Non-nil means prompt with menus when appropriate. +This is done when reading from a keymap that has a prompt string, +for elements that have prompt strings. +The menu is displayed on the screen +if X menus were enabled at configuration +time and the previous event was a mouse click prefix key. +Otherwise, menu prompting uses the echo area. */); + menu_prompting = 1; + + DEFVAR_LISP ("menu-prompt-more-char", menu_prompt_more_char, + doc: /* Character to see next line of menu prompt. +Type this character while in a menu prompt to rotate around the lines of it. */); + XSETINT (menu_prompt_more_char, ' '); + + DEFVAR_INT ("extra-keyboard-modifiers", extra_keyboard_modifiers, + doc: /* A mask of additional modifier keys to use with every keyboard character. +Emacs applies the modifiers of the character stored here to each keyboard +character it reads. For example, after evaluating the expression + (setq extra-keyboard-modifiers ?\\C-x) +all input characters will have the control modifier applied to them. + +Note that the character ?\\C-@, equivalent to the integer zero, does +not count as a control character; rather, it counts as a character +with no modifiers; thus, setting `extra-keyboard-modifiers' to zero +cancels any modification. */); + extra_keyboard_modifiers = 0; + + DEFSYM (Qdeactivate_mark, "deactivate-mark"); + DEFVAR_LISP ("deactivate-mark", Vdeactivate_mark, + doc: /* If an editing command sets this to t, deactivate the mark afterward. +The command loop sets this to nil before each command, +and tests the value when the command returns. +Buffer modification stores t in this variable. */); + Vdeactivate_mark = Qnil; + Fmake_variable_buffer_local (Qdeactivate_mark); + + DEFVAR_LISP ("pre-command-hook", Vpre_command_hook, + doc: /* Normal hook run before each command is executed. +If an unhandled error happens in running this hook, +the function in which the error occurred is unconditionally removed, since +otherwise the error might happen repeatedly and make Emacs nonfunctional. */); + Vpre_command_hook = Qnil; + + DEFVAR_LISP ("post-command-hook", Vpost_command_hook, + doc: /* Normal hook run after each command is executed. +If an unhandled error happens in running this hook, +the function in which the error occurred is unconditionally removed, since +otherwise the error might happen repeatedly and make Emacs nonfunctional. */); + Vpost_command_hook = Qnil; + +#if 0 + DEFVAR_LISP ("echo-area-clear-hook", ..., + doc: /* Normal hook run when clearing the echo area. */); +#endif + DEFSYM (Qecho_area_clear_hook, "echo-area-clear-hook"); + Fset (Qecho_area_clear_hook, Qnil); + + DEFVAR_LISP ("lucid-menu-bar-dirty-flag", Vlucid_menu_bar_dirty_flag, + doc: /* Non-nil means menu bar, specified Lucid style, needs to be recomputed. */); + Vlucid_menu_bar_dirty_flag = Qnil; + + DEFVAR_LISP ("menu-bar-final-items", Vmenu_bar_final_items, + doc: /* List of menu bar items to move to the end of the menu bar. +The elements of the list are event types that may have menu bar bindings. */); + Vmenu_bar_final_items = Qnil; + + DEFVAR_LISP ("tool-bar-separator-image-expression", Vtool_bar_separator_image_expression, + doc: /* Expression evaluating to the image spec for a tool-bar separator. +This is used internally by graphical displays that do not render +tool-bar separators natively. Otherwise it is unused (e.g. on GTK). */); + Vtool_bar_separator_image_expression = Qnil; + + DEFVAR_KBOARD ("overriding-terminal-local-map", + Voverriding_terminal_local_map, + doc: /* Per-terminal keymap that takes precedence over all other keymaps. +This variable is intended to let commands such as `universal-argument' +set up a different keymap for reading the next command. + +`overriding-terminal-local-map' has a separate binding for each +terminal device. See Info node `(elisp)Multiple Terminals'. */); + + DEFVAR_LISP ("overriding-local-map", Voverriding_local_map, + doc: /* Keymap that replaces (overrides) local keymaps. +If this variable is non-nil, Emacs looks up key bindings in this +keymap INSTEAD OF the keymap char property, minor mode maps, and the +buffer's local map. Hence, the only active keymaps would be +`overriding-terminal-local-map', this keymap, and `global-keymap', in +order of precedence. */); + Voverriding_local_map = Qnil; + + DEFVAR_LISP ("overriding-local-map-menu-flag", Voverriding_local_map_menu_flag, + doc: /* Non-nil means `overriding-local-map' applies to the menu bar. +Otherwise, the menu bar continues to reflect the buffer's local map +and the minor mode maps regardless of `overriding-local-map'. */); + Voverriding_local_map_menu_flag = Qnil; + + DEFVAR_LISP ("special-event-map", Vspecial_event_map, + doc: /* Keymap defining bindings for special events to execute at low level. */); + Vspecial_event_map = list1 (Qkeymap); + + DEFVAR_LISP ("track-mouse", do_mouse_tracking, + doc: /* Non-nil means generate motion events for mouse motion. */); + + DEFVAR_KBOARD ("system-key-alist", Vsystem_key_alist, + doc: /* Alist of system-specific X windows key symbols. +Each element should have the form (N . SYMBOL) where N is the +numeric keysym code (sans the \"system-specific\" bit 1<<28) +and SYMBOL is its name. + +`system-key-alist' has a separate binding for each terminal device. +See Info node `(elisp)Multiple Terminals'. */); + + DEFVAR_KBOARD ("local-function-key-map", Vlocal_function_key_map, + doc: /* Keymap that translates key sequences to key sequences during input. +This is used mainly for mapping key sequences into some preferred +key events (symbols). + +The `read-key-sequence' function replaces any subsequence bound by +`local-function-key-map' with its binding. More precisely, when the +active keymaps have no binding for the current key sequence but +`local-function-key-map' binds a suffix of the sequence to a vector or +string, `read-key-sequence' replaces the matching suffix with its +binding, and continues with the new sequence. + +If the binding is a function, it is called with one argument (the prompt) +and its return value (a key sequence) is used. + +The events that come from bindings in `local-function-key-map' are not +themselves looked up in `local-function-key-map'. + +For example, suppose `local-function-key-map' binds `ESC O P' to [f1]. +Typing `ESC O P' to `read-key-sequence' would return [f1]. Typing +`C-x ESC O P' would return [?\\C-x f1]. If [f1] were a prefix key, +typing `ESC O P x' would return [f1 x]. + +`local-function-key-map' has a separate binding for each terminal +device. See Info node `(elisp)Multiple Terminals'. If you need to +define a binding on all terminals, change `function-key-map' +instead. Initially, `local-function-key-map' is an empty keymap that +has `function-key-map' as its parent on all terminal devices. */); + + DEFVAR_KBOARD ("input-decode-map", Vinput_decode_map, + doc: /* Keymap that decodes input escape sequences. +This is used mainly for mapping ASCII function key sequences into +real Emacs function key events (symbols). + +The `read-key-sequence' function replaces any subsequence bound by +`input-decode-map' with its binding. Contrary to `function-key-map', +this map applies its rebinding regardless of the presence of an ordinary +binding. So it is more like `key-translation-map' except that it applies +before `function-key-map' rather than after. + +If the binding is a function, it is called with one argument (the prompt) +and its return value (a key sequence) is used. + +The events that come from bindings in `input-decode-map' are not +themselves looked up in `input-decode-map'. */); + + DEFVAR_LISP ("function-key-map", Vfunction_key_map, + doc: /* The parent keymap of all `local-function-key-map' instances. +Function key definitions that apply to all terminal devices should go +here. If a mapping is defined in both the current +`local-function-key-map' binding and this variable, then the local +definition will take precedence. */); + Vfunction_key_map = Fmake_sparse_keymap (Qnil); + + DEFVAR_LISP ("key-translation-map", Vkey_translation_map, + doc: /* Keymap of key translations that can override keymaps. +This keymap works like `input-decode-map', but comes after `function-key-map'. +Another difference is that it is global rather than terminal-local. */); + Vkey_translation_map = Fmake_sparse_keymap (Qnil); + + DEFVAR_LISP ("deferred-action-list", Vdeferred_action_list, + doc: /* List of deferred actions to be performed at a later time. +The precise format isn't relevant here; we just check whether it is nil. */); + Vdeferred_action_list = Qnil; + + DEFVAR_LISP ("deferred-action-function", Vdeferred_action_function, + doc: /* Function to call to handle deferred actions, after each command. +This function is called with no arguments after each command +whenever `deferred-action-list' is non-nil. */); + Vdeferred_action_function = Qnil; + + DEFVAR_LISP ("delayed-warnings-list", Vdelayed_warnings_list, + doc: /* List of warnings to be displayed after this command. +Each element must be a list (TYPE MESSAGE [LEVEL [BUFFER-NAME]]), +as per the args of `display-warning' (which see). +If this variable is non-nil, `delayed-warnings-hook' will be run +immediately after running `post-command-hook'. */); + Vdelayed_warnings_list = Qnil; + + DEFVAR_LISP ("timer-list", Vtimer_list, + doc: /* List of active absolute time timers in order of increasing time. */); + Vtimer_list = Qnil; + + DEFVAR_LISP ("timer-idle-list", Vtimer_idle_list, + doc: /* List of active idle-time timers in order of increasing time. */); + Vtimer_idle_list = Qnil; + + DEFVAR_LISP ("input-method-function", Vinput_method_function, + doc: /* If non-nil, the function that implements the current input method. +It's called with one argument, a printing character that was just read. +\(That means a character with code 040...0176.) +Typically this function uses `read-event' to read additional events. +When it does so, it should first bind `input-method-function' to nil +so it will not be called recursively. + +The function should return a list of zero or more events +to be used as input. If it wants to put back some events +to be reconsidered, separately, by the input method, +it can add them to the beginning of `unread-command-events'. + +The input method function can find in `input-method-previous-message' +the previous echo area message. + +The input method function should refer to the variables +`input-method-use-echo-area' and `input-method-exit-on-first-char' +for guidance on what to do. */); + Vinput_method_function = Qlist; + + DEFVAR_LISP ("input-method-previous-message", + Vinput_method_previous_message, + doc: /* When `input-method-function' is called, hold the previous echo area message. +This variable exists because `read-event' clears the echo area +before running the input method. It is nil if there was no message. */); + Vinput_method_previous_message = Qnil; + + DEFVAR_LISP ("show-help-function", Vshow_help_function, + doc: /* If non-nil, the function that implements the display of help. +It's called with one argument, the help string to display. */); + Vshow_help_function = Qnil; + + DEFVAR_LISP ("disable-point-adjustment", Vdisable_point_adjustment, + doc: /* If non-nil, suppress point adjustment after executing a command. + +After a command is executed, if point is moved into a region that has +special properties (e.g. composition, display), we adjust point to +the boundary of the region. But, when a command sets this variable to +non-nil, we suppress the point adjustment. + +This variable is set to nil before reading a command, and is checked +just after executing the command. */); + Vdisable_point_adjustment = Qnil; + + DEFVAR_LISP ("global-disable-point-adjustment", + Vglobal_disable_point_adjustment, + doc: /* If non-nil, always suppress point adjustment. + +The default value is nil, in which case, point adjustment are +suppressed only after special commands that set +`disable-point-adjustment' (which see) to non-nil. */); + Vglobal_disable_point_adjustment = Qnil; + + DEFVAR_LISP ("minibuffer-message-timeout", Vminibuffer_message_timeout, + doc: /* How long to display an echo-area message when the minibuffer is active. +If the value is not a number, such messages don't time out. */); + Vminibuffer_message_timeout = make_number (2); + + DEFVAR_LISP ("throw-on-input", Vthrow_on_input, + doc: /* If non-nil, any keyboard input throws to this symbol. +The value of that variable is passed to `quit-flag' and later causes a +peculiar kind of quitting. */); + Vthrow_on_input = Qnil; + + DEFVAR_LISP ("command-error-function", Vcommand_error_function, + doc: /* Function to output error messages. +Called with three arguments: +- the error data, a list of the form (SIGNALED-CONDITION . SIGNAL-DATA) + such as what `condition-case' would bind its variable to, +- the context (a string which normally goes at the start of the message), +- the Lisp function within which the error was signaled. */); + Vcommand_error_function = intern ("command-error-default-function"); + + DEFVAR_LISP ("enable-disabled-menus-and-buttons", + Venable_disabled_menus_and_buttons, + doc: /* If non-nil, don't ignore events produced by disabled menu items and tool-bar. + +Help functions bind this to allow help on disabled menu items +and tool-bar buttons. */); + Venable_disabled_menus_and_buttons = Qnil; + + DEFVAR_LISP ("select-active-regions", + Vselect_active_regions, + doc: /* If non-nil, an active region automatically sets the primary selection. +If the value is `only', only temporarily active regions (usually made +by mouse-dragging or shift-selection) set the window selection. + +This takes effect only when Transient Mark mode is enabled. */); + Vselect_active_regions = Qt; + + DEFVAR_LISP ("saved-region-selection", + Vsaved_region_selection, + doc: /* Contents of active region prior to buffer modification. +If `select-active-regions' is non-nil, Emacs sets this to the +text in the region before modifying the buffer. The next call to +the function `deactivate-mark' uses this to set the window selection. */); + Vsaved_region_selection = Qnil; + + DEFVAR_LISP ("selection-inhibit-update-commands", + Vselection_inhibit_update_commands, + doc: /* List of commands which should not update the selection. +Normally, if `select-active-regions' is non-nil and the mark remains +active after a command (i.e. the mark was not deactivated), the Emacs +command loop sets the selection to the text in the region. However, +if the command is in this list, the selection is not updated. */); + Vselection_inhibit_update_commands + = list2 (Qhandle_switch_frame, Qhandle_select_window); + + DEFVAR_LISP ("debug-on-event", + Vdebug_on_event, + doc: /* Enter debugger on this event. When Emacs +receives the special event specified by this variable, it will try to +break into the debugger as soon as possible instead of processing the +event normally through `special-event-map'. + +Currently, the only supported values for this +variable are `sigusr1' and `sigusr2'. */); + Vdebug_on_event = intern_c_string ("sigusr2"); + + /* Create the initial keyboard. Qt means 'unset'. */ + initial_kboard = allocate_kboard (Qt); +} + +void +keys_of_keyboard (void) +{ + initial_define_key (global_map, Ctl ('Z'), "suspend-emacs"); + initial_define_key (control_x_map, Ctl ('Z'), "suspend-emacs"); + initial_define_key (meta_map, Ctl ('C'), "exit-recursive-edit"); + initial_define_key (global_map, Ctl (']'), "abort-recursive-edit"); + initial_define_key (meta_map, 'x', "execute-extended-command"); + + initial_define_lispy_key (Vspecial_event_map, "delete-frame", + "handle-delete-frame"); + initial_define_lispy_key (Vspecial_event_map, "ns-put-working-text", + "ns-put-working-text"); + initial_define_lispy_key (Vspecial_event_map, "ns-unput-working-text", + "ns-unput-working-text"); + /* Here we used to use `ignore-event' which would simple set prefix-arg to + current-prefix-arg, as is done in `handle-switch-frame'. + But `handle-switch-frame is not run from the special-map. + Commands from that map are run in a special way that automatically + preserves the prefix-arg. Restoring the prefix arg here is not just + redundant but harmful: + - C-u C-x v = + - current-prefix-arg is set to non-nil, prefix-arg is set to nil. + - after the first prompt, the exit-minibuffer-hook is run which may + iconify a frame and thus push a `iconify-frame' event. + - after running exit-minibuffer-hook, current-prefix-arg is + restored to the non-nil value it had before the prompt. + - we enter the second prompt. + current-prefix-arg is non-nil, prefix-arg is nil. + - before running the first real event, we run the special iconify-frame + event, but we pass the `special' arg to command-execute so + current-prefix-arg and prefix-arg are left untouched. + - here we foolishly copy the non-nil current-prefix-arg to prefix-arg. + - the next key event will have a spuriously non-nil current-prefix-arg. */ + initial_define_lispy_key (Vspecial_event_map, "iconify-frame", + "ignore"); + initial_define_lispy_key (Vspecial_event_map, "make-frame-visible", + "ignore"); + /* Handling it at such a low-level causes read_key_sequence to get + * confused because it doesn't realize that the current_buffer was + * changed by read_char. + * + * initial_define_lispy_key (Vspecial_event_map, "select-window", + * "handle-select-window"); */ + initial_define_lispy_key (Vspecial_event_map, "save-session", + "handle-save-session"); + +#ifdef HAVE_DBUS + /* Define a special event which is raised for dbus callback + functions. */ + initial_define_lispy_key (Vspecial_event_map, "dbus-event", + "dbus-handle-event"); +#endif + +#ifdef USE_FILE_NOTIFY + /* Define a special event which is raised for notification callback + functions. */ + initial_define_lispy_key (Vspecial_event_map, "file-notify", + "file-notify-handle-event"); +#endif /* USE_FILE_NOTIFY */ + + initial_define_lispy_key (Vspecial_event_map, "config-changed-event", + "ignore"); +#if defined (WINDOWSNT) + initial_define_lispy_key (Vspecial_event_map, "language-change", + "ignore"); +#endif + initial_define_lispy_key (Vspecial_event_map, "focus-in", + "handle-focus-in"); + initial_define_lispy_key (Vspecial_event_map, "focus-out", + "handle-focus-out"); +} + +/* Mark the pointers in the kboard objects. + Called by Fgarbage_collect. */ +void +mark_kboards (void) +{ + KBOARD *kb; + Lisp_Object *p; + for (kb = all_kboards; kb; kb = kb->next_kboard) + { + if (kb->kbd_macro_buffer) + for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++) + mark_object (*p); + mark_object (KVAR (kb, Voverriding_terminal_local_map)); + mark_object (KVAR (kb, Vlast_command)); + mark_object (KVAR (kb, Vreal_last_command)); + mark_object (KVAR (kb, Vkeyboard_translate_table)); + mark_object (KVAR (kb, Vlast_repeatable_command)); + mark_object (KVAR (kb, Vprefix_arg)); + mark_object (KVAR (kb, Vlast_prefix_arg)); + mark_object (KVAR (kb, kbd_queue)); + mark_object (KVAR (kb, defining_kbd_macro)); + mark_object (KVAR (kb, Vlast_kbd_macro)); + mark_object (KVAR (kb, Vsystem_key_alist)); + mark_object (KVAR (kb, system_key_syms)); + mark_object (KVAR (kb, Vwindow_system)); + mark_object (KVAR (kb, Vinput_decode_map)); + mark_object (KVAR (kb, Vlocal_function_key_map)); + mark_object (KVAR (kb, Vdefault_minibuffer_frame)); + mark_object (KVAR (kb, echo_string)); + } + { + struct input_event *event; + for (event = kbd_fetch_ptr; event != kbd_store_ptr; event++) + { + if (event == kbd_buffer + KBD_BUFFER_SIZE) + event = kbd_buffer; + /* These two special event types has no Lisp_Objects to mark. */ + if (event->kind != SELECTION_REQUEST_EVENT + && event->kind != SELECTION_CLEAR_EVENT) + { + mark_object (event->x); + mark_object (event->y); + mark_object (event->frame_or_window); + mark_object (event->arg); + } + } + } +} diff --git a/test/manual/etags/c-src/emacs/src/lisp.h b/test/manual/etags/c-src/emacs/src/lisp.h new file mode 100644 index 00000000000..6d34ce3b052 --- /dev/null +++ b/test/manual/etags/c-src/emacs/src/lisp.h @@ -0,0 +1,4817 @@ +/* Fundamental definitions for GNU Emacs Lisp interpreter. + +Copyright (C) 1985-1987, 1993-1995, 1997-2015 Free Software Foundation, +Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#ifndef EMACS_LISP_H +#define EMACS_LISP_H + +#include <setjmp.h> +#include <stdalign.h> +#include <stdarg.h> +#include <stddef.h> +#include <float.h> +#include <inttypes.h> +#include <limits.h> + +#include <intprops.h> +#include <verify.h> + +INLINE_HEADER_BEGIN + +/* Define a TYPE constant ID as an externally visible name. Use like this: + + DEFINE_GDB_SYMBOL_BEGIN (TYPE, ID) + # define ID (some integer preprocessor expression of type TYPE) + DEFINE_GDB_SYMBOL_END (ID) + + This hack is for the benefit of compilers that do not make macro + definitions or enums visible to the debugger. It's used for symbols + that .gdbinit needs. */ + +#define DECLARE_GDB_SYM(type, id) type const id EXTERNALLY_VISIBLE +#ifdef MAIN_PROGRAM +# define DEFINE_GDB_SYMBOL_BEGIN(type, id) DECLARE_GDB_SYM (type, id) +# define DEFINE_GDB_SYMBOL_END(id) = id; +#else +# define DEFINE_GDB_SYMBOL_BEGIN(type, id) extern DECLARE_GDB_SYM (type, id) +# define DEFINE_GDB_SYMBOL_END(val) ; +#endif + +/* The ubiquitous max and min macros. */ +#undef min +#undef max +#define max(a, b) ((a) > (b) ? (a) : (b)) +#define min(a, b) ((a) < (b) ? (a) : (b)) + +/* Number of elements in an array. */ +#define ARRAYELTS(arr) (sizeof (arr) / sizeof (arr)[0]) + +/* Number of bits in a Lisp_Object tag. */ +DEFINE_GDB_SYMBOL_BEGIN (int, GCTYPEBITS) +#define GCTYPEBITS 3 +DEFINE_GDB_SYMBOL_END (GCTYPEBITS) + +/* The number of bits needed in an EMACS_INT over and above the number + of bits in a pointer. This is 0 on systems where: + 1. We can specify multiple-of-8 alignment on static variables. + 2. We know malloc returns a multiple of 8. */ +#if (defined alignas \ + && (defined GNU_MALLOC || defined DOUG_LEA_MALLOC || defined __GLIBC__ \ + || defined DARWIN_OS || defined __sun || defined __MINGW32__ \ + || defined CYGWIN)) +# define NONPOINTER_BITS 0 +#else +# define NONPOINTER_BITS GCTYPEBITS +#endif + +/* EMACS_INT - signed integer wide enough to hold an Emacs value + EMACS_INT_MAX - maximum value of EMACS_INT; can be used in #if + pI - printf length modifier for EMACS_INT + EMACS_UINT - unsigned variant of EMACS_INT */ +#ifndef EMACS_INT_MAX +# if INTPTR_MAX <= 0 +# error "INTPTR_MAX misconfigured" +# elif INTPTR_MAX <= INT_MAX >> NONPOINTER_BITS && !defined WIDE_EMACS_INT +typedef int EMACS_INT; +typedef unsigned int EMACS_UINT; +# define EMACS_INT_MAX INT_MAX +# define pI "" +# elif INTPTR_MAX <= LONG_MAX >> NONPOINTER_BITS && !defined WIDE_EMACS_INT +typedef long int EMACS_INT; +typedef unsigned long EMACS_UINT; +# define EMACS_INT_MAX LONG_MAX +# define pI "l" +/* Check versus LLONG_MAX, not LLONG_MAX >> NONPOINTER_BITS. + In theory this is not safe, but in practice it seems to be OK. */ +# elif INTPTR_MAX <= LLONG_MAX +typedef long long int EMACS_INT; +typedef unsigned long long int EMACS_UINT; +# define EMACS_INT_MAX LLONG_MAX +# define pI "ll" +# else +# error "INTPTR_MAX too large" +# endif +#endif + +/* Number of bits to put in each character in the internal representation + of bool vectors. This should not vary across implementations. */ +enum { BOOL_VECTOR_BITS_PER_CHAR = +#define BOOL_VECTOR_BITS_PER_CHAR 8 + BOOL_VECTOR_BITS_PER_CHAR +}; + +/* An unsigned integer type representing a fixed-length bit sequence, + suitable for bool vector words, GC mark bits, etc. Normally it is size_t + for speed, but it is unsigned char on weird platforms. */ +#if BOOL_VECTOR_BITS_PER_CHAR == CHAR_BIT +typedef size_t bits_word; +# define BITS_WORD_MAX SIZE_MAX +enum { BITS_PER_BITS_WORD = CHAR_BIT * sizeof (bits_word) }; +#else +typedef unsigned char bits_word; +# define BITS_WORD_MAX ((1u << BOOL_VECTOR_BITS_PER_CHAR) - 1) +enum { BITS_PER_BITS_WORD = BOOL_VECTOR_BITS_PER_CHAR }; +#endif +verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1); + +/* Number of bits in some machine integer types. */ +enum + { + BITS_PER_CHAR = CHAR_BIT, + BITS_PER_SHORT = CHAR_BIT * sizeof (short), + BITS_PER_LONG = CHAR_BIT * sizeof (long int), + BITS_PER_EMACS_INT = CHAR_BIT * sizeof (EMACS_INT) + }; + +/* printmax_t and uprintmax_t are types for printing large integers. + These are the widest integers that are supported for printing. + pMd etc. are conversions for printing them. + On C99 hosts, there's no problem, as even the widest integers work. + Fall back on EMACS_INT on pre-C99 hosts. */ +#ifdef PRIdMAX +typedef intmax_t printmax_t; +typedef uintmax_t uprintmax_t; +# define pMd PRIdMAX +# define pMu PRIuMAX +#else +typedef EMACS_INT printmax_t; +typedef EMACS_UINT uprintmax_t; +# define pMd pI"d" +# define pMu pI"u" +#endif + +/* Use pD to format ptrdiff_t values, which suffice for indexes into + buffers and strings. Emacs never allocates objects larger than + PTRDIFF_MAX bytes, as they cause problems with pointer subtraction. + In C99, pD can always be "t"; configure it here for the sake of + pre-C99 libraries such as glibc 2.0 and Solaris 8. */ +#if PTRDIFF_MAX == INT_MAX +# define pD "" +#elif PTRDIFF_MAX == LONG_MAX +# define pD "l" +#elif PTRDIFF_MAX == LLONG_MAX +# define pD "ll" +#else +# define pD "t" +#endif + +/* Extra internal type checking? */ + +/* Define Emacs versions of <assert.h>'s 'assert (COND)' and <verify.h>'s + 'assume (COND)'. COND should be free of side effects, as it may or + may not be evaluated. + + 'eassert (COND)' checks COND at runtime if ENABLE_CHECKING is + defined and suppress_checking is false, and does nothing otherwise. + Emacs dies if COND is checked and is false. The suppress_checking + variable is initialized to 0 in alloc.c. Set it to 1 using a + debugger to temporarily disable aborting on detected internal + inconsistencies or error conditions. + + In some cases, a good compiler may be able to optimize away the + eassert macro even if ENABLE_CHECKING is true, e.g., if XSTRING (x) + uses eassert to test STRINGP (x), but a particular use of XSTRING + is invoked only after testing that STRINGP (x) is true, making the + test redundant. + + eassume is like eassert except that it also causes the compiler to + assume that COND is true afterwards, regardless of whether runtime + checking is enabled. This can improve performance in some cases, + though it can degrade performance in others. It's often suboptimal + for COND to call external functions or access volatile storage. */ + +#ifndef ENABLE_CHECKING +# define eassert(cond) ((void) (false && (cond))) /* Check COND compiles. */ +# define eassume(cond) assume (cond) +#else /* ENABLE_CHECKING */ + +extern _Noreturn void die (const char *, const char *, int); + +extern bool suppress_checking EXTERNALLY_VISIBLE; + +# define eassert(cond) \ + (suppress_checking || (cond) \ + ? (void) 0 \ + : die (# cond, __FILE__, __LINE__)) +# define eassume(cond) \ + (suppress_checking \ + ? assume (cond) \ + : (cond) \ + ? (void) 0 \ + : die (# cond, __FILE__, __LINE__)) +#endif /* ENABLE_CHECKING */ + + +/* Use the configure flag --enable-check-lisp-object-type to make + Lisp_Object use a struct type instead of the default int. The flag + causes CHECK_LISP_OBJECT_TYPE to be defined. */ + +/***** Select the tagging scheme. *****/ +/* The following option controls the tagging scheme: + - USE_LSB_TAG means that we can assume the least 3 bits of pointers are + always 0, and we can thus use them to hold tag bits, without + restricting our addressing space. + + If ! USE_LSB_TAG, then use the top 3 bits for tagging, thus + restricting our possible address range. + + USE_LSB_TAG not only requires the least 3 bits of pointers returned by + malloc to be 0 but also needs to be able to impose a mult-of-8 alignment + on the few static Lisp_Objects used: lispsym, all the defsubr, and + the two special buffers buffer_defaults and buffer_local_symbols. */ + +enum Lisp_Bits + { + /* 2**GCTYPEBITS. This must be a macro that expands to a literal + integer constant, for MSVC. */ +#define GCALIGNMENT 8 + + /* Number of bits in a Lisp_Object value, not counting the tag. */ + VALBITS = BITS_PER_EMACS_INT - GCTYPEBITS, + + /* Number of bits in a Lisp fixnum tag. */ + INTTYPEBITS = GCTYPEBITS - 1, + + /* Number of bits in a Lisp fixnum value, not counting the tag. */ + FIXNUM_BITS = VALBITS + 1 + }; + +#if GCALIGNMENT != 1 << GCTYPEBITS +# error "GCALIGNMENT and GCTYPEBITS are inconsistent" +#endif + +/* The maximum value that can be stored in a EMACS_INT, assuming all + bits other than the type bits contribute to a nonnegative signed value. + This can be used in #if, e.g., '#if USB_TAG' below expands to an + expression involving VAL_MAX. */ +#define VAL_MAX (EMACS_INT_MAX >> (GCTYPEBITS - 1)) + +/* Whether the least-significant bits of an EMACS_INT contain the tag. + On hosts where pointers-as-ints do not exceed VAL_MAX / 2, USE_LSB_TAG is: + a. unnecessary, because the top bits of an EMACS_INT are unused, and + b. slower, because it typically requires extra masking. + So, USE_LSB_TAG is true only on hosts where it might be useful. */ +DEFINE_GDB_SYMBOL_BEGIN (bool, USE_LSB_TAG) +#define USE_LSB_TAG (VAL_MAX / 2 < INTPTR_MAX) +DEFINE_GDB_SYMBOL_END (USE_LSB_TAG) + +#if !USE_LSB_TAG && !defined WIDE_EMACS_INT +# error "USE_LSB_TAG not supported on this platform; please report this." \ + "Try 'configure --with-wide-int' to work around the problem." +error !; +#endif + +#ifndef alignas +# define alignas(alignment) /* empty */ +# if USE_LSB_TAG +# error "USE_LSB_TAG requires alignas" +# endif +#endif + +#ifdef HAVE_STRUCT_ATTRIBUTE_ALIGNED +# define GCALIGNED __attribute__ ((aligned (GCALIGNMENT))) +#else +# define GCALIGNED /* empty */ +#endif + +/* Some operations are so commonly executed that they are implemented + as macros, not functions, because otherwise runtime performance would + suffer too much when compiling with GCC without optimization. + There's no need to inline everything, just the operations that + would otherwise cause a serious performance problem. + + For each such operation OP, define a macro lisp_h_OP that contains + the operation's implementation. That way, OP can be implemented + via a macro definition like this: + + #define OP(x) lisp_h_OP (x) + + and/or via a function definition like this: + + LISP_MACRO_DEFUN (OP, Lisp_Object, (Lisp_Object x), (x)) + + which macro-expands to this: + + Lisp_Object (OP) (Lisp_Object x) { return lisp_h_OP (x); } + + without worrying about the implementations diverging, since + lisp_h_OP defines the actual implementation. The lisp_h_OP macros + are intended to be private to this include file, and should not be + used elsewhere. + + FIXME: Remove the lisp_h_OP macros, and define just the inline OP + functions, once most developers have access to GCC 4.8 or later and + can use "gcc -Og" to debug. Maybe in the year 2016. See + Bug#11935. + + Commentary for these macros can be found near their corresponding + functions, below. */ + +#if CHECK_LISP_OBJECT_TYPE +# define lisp_h_XLI(o) ((o).i) +# define lisp_h_XIL(i) ((Lisp_Object) { i }) +#else +# define lisp_h_XLI(o) (o) +# define lisp_h_XIL(i) (i) +#endif +#define lisp_h_CHECK_LIST_CONS(x, y) CHECK_TYPE (CONSP (x), Qlistp, y) +#define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x) +#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) +#define lisp_h_CHECK_TYPE(ok, predicate, x) \ + ((ok) ? (void) 0 : (void) wrong_type_argument (predicate, x)) +#define lisp_h_CONSP(x) (XTYPE (x) == Lisp_Cons) +#define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) +#define lisp_h_FLOATP(x) (XTYPE (x) == Lisp_Float) +#define lisp_h_INTEGERP(x) ((XTYPE (x) & (Lisp_Int0 | ~Lisp_Int1)) == Lisp_Int0) +#define lisp_h_MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker) +#define lisp_h_MISCP(x) (XTYPE (x) == Lisp_Misc) +#define lisp_h_NILP(x) EQ (x, Qnil) +#define lisp_h_SET_SYMBOL_VAL(sym, v) \ + (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value = (v)) +#define lisp_h_SYMBOL_CONSTANT_P(sym) (XSYMBOL (sym)->constant) +#define lisp_h_SYMBOL_VAL(sym) \ + (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value) +#define lisp_h_SYMBOLP(x) (XTYPE (x) == Lisp_Symbol) +#define lisp_h_VECTORLIKEP(x) (XTYPE (x) == Lisp_Vectorlike) +#define lisp_h_XCAR(c) XCONS (c)->car +#define lisp_h_XCDR(c) XCONS (c)->u.cdr +#define lisp_h_XCONS(a) \ + (eassert (CONSP (a)), (struct Lisp_Cons *) XUNTAG (a, Lisp_Cons)) +#define lisp_h_XHASH(a) XUINT (a) +#define lisp_h_XPNTR(a) \ + (SYMBOLP (a) ? XSYMBOL (a) : (void *) ((intptr_t) (XLI (a) & VALMASK))) +#ifndef GC_CHECK_CONS_LIST +# define lisp_h_check_cons_list() ((void) 0) +#endif +#if USE_LSB_TAG +# define lisp_h_make_number(n) \ + XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0)) +# define lisp_h_XFASTINT(a) XINT (a) +# define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS) +# define lisp_h_XSYMBOL(a) \ + (eassert (SYMBOLP (a)), \ + (struct Lisp_Symbol *) ((uintptr_t) XLI (a) - Lisp_Symbol \ + + (char *) lispsym)) +# define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) +# define lisp_h_XUNTAG(a, type) ((void *) (intptr_t) (XLI (a) - (type))) +#endif + +/* When compiling via gcc -O0, define the key operations as macros, as + Emacs is too slow otherwise. To disable this optimization, compile + with -DINLINING=false. */ +#if (defined __NO_INLINE__ \ + && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__ \ + && ! (defined INLINING && ! INLINING)) +# define XLI(o) lisp_h_XLI (o) +# define XIL(i) lisp_h_XIL (i) +# define CHECK_LIST_CONS(x, y) lisp_h_CHECK_LIST_CONS (x, y) +# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x) +# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) +# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) +# define CONSP(x) lisp_h_CONSP (x) +# define EQ(x, y) lisp_h_EQ (x, y) +# define FLOATP(x) lisp_h_FLOATP (x) +# define INTEGERP(x) lisp_h_INTEGERP (x) +# define MARKERP(x) lisp_h_MARKERP (x) +# define MISCP(x) lisp_h_MISCP (x) +# define NILP(x) lisp_h_NILP (x) +# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v) +# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) +# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) +# define SYMBOLP(x) lisp_h_SYMBOLP (x) +# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) +# define XCAR(c) lisp_h_XCAR (c) +# define XCDR(c) lisp_h_XCDR (c) +# define XCONS(a) lisp_h_XCONS (a) +# define XHASH(a) lisp_h_XHASH (a) +# define XPNTR(a) lisp_h_XPNTR (a) +# ifndef GC_CHECK_CONS_LIST +# define check_cons_list() lisp_h_check_cons_list () +# endif +# if USE_LSB_TAG +# define make_number(n) lisp_h_make_number (n) +# define XFASTINT(a) lisp_h_XFASTINT (a) +# define XINT(a) lisp_h_XINT (a) +# define XSYMBOL(a) lisp_h_XSYMBOL (a) +# define XTYPE(a) lisp_h_XTYPE (a) +# define XUNTAG(a, type) lisp_h_XUNTAG (a, type) +# endif +#endif + +/* Define NAME as a lisp.h inline function that returns TYPE and has + arguments declared as ARGDECLS and passed as ARGS. ARGDECLS and + ARGS should be parenthesized. Implement the function by calling + lisp_h_NAME ARGS. */ +#define LISP_MACRO_DEFUN(name, type, argdecls, args) \ + INLINE type (name) argdecls { return lisp_h_##name args; } + +/* like LISP_MACRO_DEFUN, except NAME returns void. */ +#define LISP_MACRO_DEFUN_VOID(name, argdecls, args) \ + INLINE void (name) argdecls { lisp_h_##name args; } + + +/* Define the fundamental Lisp data structures. */ + +/* This is the set of Lisp data types. If you want to define a new + data type, read the comments after Lisp_Fwd_Type definition + below. */ + +/* Lisp integers use 2 tags, to give them one extra bit, thus + extending their range from, e.g., -2^28..2^28-1 to -2^29..2^29-1. */ +#define INTMASK (EMACS_INT_MAX >> (INTTYPEBITS - 1)) +#define case_Lisp_Int case Lisp_Int0: case Lisp_Int1 + +/* Idea stolen from GDB. Pedantic GCC complains about enum bitfields, + MSVC doesn't support them, and xlc and Oracle Studio c99 complain + vociferously about them. */ +#if (defined __STRICT_ANSI__ || defined _MSC_VER || defined __IBMC__ \ + || (defined __SUNPRO_C && __STDC__)) +#define ENUM_BF(TYPE) unsigned int +#else +#define ENUM_BF(TYPE) enum TYPE +#endif + + +enum Lisp_Type + { + /* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */ + Lisp_Symbol = 0, + + /* Miscellaneous. XMISC (object) points to a union Lisp_Misc, + whose first member indicates the subtype. */ + Lisp_Misc = 1, + + /* Integer. XINT (obj) is the integer value. */ + Lisp_Int0 = 2, + Lisp_Int1 = USE_LSB_TAG ? 6 : 3, + + /* String. XSTRING (object) points to a struct Lisp_String. + The length of the string, and its contents, are stored therein. */ + Lisp_String = 4, + + /* Vector of Lisp objects, or something resembling it. + XVECTOR (object) points to a struct Lisp_Vector, which contains + the size and contents. The size field also contains the type + information, if it's not a real vector object. */ + Lisp_Vectorlike = 5, + + /* Cons. XCONS (object) points to a struct Lisp_Cons. */ + Lisp_Cons = USE_LSB_TAG ? 3 : 6, + + Lisp_Float = 7 + }; + +/* This is the set of data types that share a common structure. + The first member of the structure is a type code from this set. + The enum values are arbitrary, but we'll use large numbers to make it + more likely that we'll spot the error if a random word in memory is + mistakenly interpreted as a Lisp_Misc. */ +enum Lisp_Misc_Type + { + Lisp_Misc_Free = 0x5eab, + Lisp_Misc_Marker, + Lisp_Misc_Overlay, + Lisp_Misc_Save_Value, + Lisp_Misc_Finalizer, + /* Currently floats are not a misc type, + but let's define this in case we want to change that. */ + Lisp_Misc_Float, + /* This is not a type code. It is for range checking. */ + Lisp_Misc_Limit + }; + +/* These are the types of forwarding objects used in the value slot + of symbols for special built-in variables whose value is stored in + C variables. */ +enum Lisp_Fwd_Type + { + Lisp_Fwd_Int, /* Fwd to a C `int' variable. */ + Lisp_Fwd_Bool, /* Fwd to a C boolean var. */ + Lisp_Fwd_Obj, /* Fwd to a C Lisp_Object variable. */ + Lisp_Fwd_Buffer_Obj, /* Fwd to a Lisp_Object field of buffers. */ + Lisp_Fwd_Kboard_Obj /* Fwd to a Lisp_Object field of kboards. */ + }; + +/* If you want to define a new Lisp data type, here are some + instructions. See the thread at + http://lists.gnu.org/archive/html/emacs-devel/2012-10/msg00561.html + for more info. + + First, there are already a couple of Lisp types that can be used if + your new type does not need to be exposed to Lisp programs nor + displayed to users. These are Lisp_Save_Value, a Lisp_Misc + subtype; and PVEC_OTHER, a kind of vectorlike object. The former + is suitable for temporarily stashing away pointers and integers in + a Lisp object. The latter is useful for vector-like Lisp objects + that need to be used as part of other objects, but which are never + shown to users or Lisp code (search for PVEC_OTHER in xterm.c for + an example). + + These two types don't look pretty when printed, so they are + unsuitable for Lisp objects that can be exposed to users. + + To define a new data type, add one more Lisp_Misc subtype or one + more pseudovector subtype. Pseudovectors are more suitable for + objects with several slots that need to support fast random access, + while Lisp_Misc types are for everything else. A pseudovector object + provides one or more slots for Lisp objects, followed by struct + members that are accessible only from C. A Lisp_Misc object is a + wrapper for a C struct that can contain anything you like. + + Explicit freeing is discouraged for Lisp objects in general. But if + you really need to exploit this, use Lisp_Misc (check free_misc in + alloc.c to see why). There is no way to free a vectorlike object. + + To add a new pseudovector type, extend the pvec_type enumeration; + to add a new Lisp_Misc, extend the Lisp_Misc_Type enumeration. + + For a Lisp_Misc, you will also need to add your entry to union + Lisp_Misc (but make sure the first word has the same structure as + the others, starting with a 16-bit member of the Lisp_Misc_Type + enumeration and a 1-bit GC markbit) and make sure the overall size + of the union is not increased by your addition. + + For a new pseudovector, it's highly desirable to limit the size + of your data type by VBLOCK_BYTES_MAX bytes (defined in alloc.c). + Otherwise you will need to change sweep_vectors (also in alloc.c). + + Then you will need to add switch branches in print.c (in + print_object, to print your object, and possibly also in + print_preprocess) and to alloc.c, to mark your object (in + mark_object) and to free it (in gc_sweep). The latter is also the + right place to call any code specific to your data type that needs + to run when the object is recycled -- e.g., free any additional + resources allocated for it that are not Lisp objects. You can even + make a pointer to the function that frees the resources a slot in + your object -- this way, the same object could be used to represent + several disparate C structures. */ + +#ifdef CHECK_LISP_OBJECT_TYPE + +typedef struct { EMACS_INT i; } Lisp_Object; + +#define LISP_INITIALLY(i) {i} + +#undef CHECK_LISP_OBJECT_TYPE +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; +#else /* CHECK_LISP_OBJECT_TYPE */ + +/* If a struct type is not wanted, define Lisp_Object as just a number. */ + +typedef EMACS_INT Lisp_Object; +#define LISP_INITIALLY(i) (i) +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false }; +#endif /* CHECK_LISP_OBJECT_TYPE */ + +#define LISP_INITIALLY_ZERO LISP_INITIALLY (0) + +/* Forward declarations. */ + +/* Defined in this file. */ +union Lisp_Fwd; +INLINE bool BOOL_VECTOR_P (Lisp_Object); +INLINE bool BUFFER_OBJFWDP (union Lisp_Fwd *); +INLINE bool BUFFERP (Lisp_Object); +INLINE bool CHAR_TABLE_P (Lisp_Object); +INLINE Lisp_Object CHAR_TABLE_REF_ASCII (Lisp_Object, ptrdiff_t); +INLINE bool (CONSP) (Lisp_Object); +INLINE bool (FLOATP) (Lisp_Object); +INLINE bool functionp (Lisp_Object); +INLINE bool (INTEGERP) (Lisp_Object); +INLINE bool (MARKERP) (Lisp_Object); +INLINE bool (MISCP) (Lisp_Object); +INLINE bool (NILP) (Lisp_Object); +INLINE bool OVERLAYP (Lisp_Object); +INLINE bool PROCESSP (Lisp_Object); +INLINE bool PSEUDOVECTORP (Lisp_Object, int); +INLINE bool SAVE_VALUEP (Lisp_Object); +INLINE bool FINALIZERP (Lisp_Object); +INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t, + Lisp_Object); +INLINE bool STRINGP (Lisp_Object); +INLINE bool SUB_CHAR_TABLE_P (Lisp_Object); +INLINE bool SUBRP (Lisp_Object); +INLINE bool (SYMBOLP) (Lisp_Object); +INLINE bool (VECTORLIKEP) (Lisp_Object); +INLINE bool WINDOWP (Lisp_Object); +INLINE bool TERMINALP (Lisp_Object); +INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object); +INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object); +INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object); +INLINE void *(XUNTAG) (Lisp_Object, int); + +/* Defined in chartab.c. */ +extern Lisp_Object char_table_ref (Lisp_Object, int); +extern void char_table_set (Lisp_Object, int, Lisp_Object); + +/* Defined in data.c. */ +extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object); +extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object); + +/* Defined in emacs.c. */ +extern bool might_dump; +/* True means Emacs has already been initialized. + Used during startup to detect startup of dumped Emacs. */ +extern bool initialized; + +/* Defined in floatfns.c. */ +extern double extract_float (Lisp_Object); + + +/* Interned state of a symbol. */ + +enum symbol_interned +{ + SYMBOL_UNINTERNED = 0, + SYMBOL_INTERNED = 1, + SYMBOL_INTERNED_IN_INITIAL_OBARRAY = 2 +}; + +enum symbol_redirect +{ + SYMBOL_PLAINVAL = 4, + SYMBOL_VARALIAS = 1, + SYMBOL_LOCALIZED = 2, + SYMBOL_FORWARDED = 3 +}; + +struct Lisp_Symbol +{ + bool_bf gcmarkbit : 1; + + /* Indicates where the value can be found: + 0 : it's a plain var, the value is in the `value' field. + 1 : it's a varalias, the value is really in the `alias' symbol. + 2 : it's a localized var, the value is in the `blv' object. + 3 : it's a forwarding variable, the value is in `forward'. */ + ENUM_BF (symbol_redirect) redirect : 3; + + /* Non-zero means symbol is constant, i.e. changing its value + should signal an error. If the value is 3, then the var + can be changed, but only by `defconst'. */ + unsigned constant : 2; + + /* Interned state of the symbol. This is an enumerator from + enum symbol_interned. */ + unsigned interned : 2; + + /* True means that this variable has been explicitly declared + special (with `defvar' etc), and shouldn't be lexically bound. */ + bool_bf declared_special : 1; + + /* True if pointed to from purespace and hence can't be GC'd. */ + bool_bf pinned : 1; + + /* The symbol's name, as a Lisp string. */ + Lisp_Object name; + + /* Value of the symbol or Qunbound if unbound. Which alternative of the + union is used depends on the `redirect' field above. */ + union { + Lisp_Object value; + struct Lisp_Symbol *alias; + struct Lisp_Buffer_Local_Value *blv; + union Lisp_Fwd *fwd; + } val; + + /* Function value of the symbol or Qnil if not fboundp. */ + Lisp_Object function; + + /* The symbol's property list. */ + Lisp_Object plist; + + /* Next symbol in obarray bucket, if the symbol is interned. */ + struct Lisp_Symbol *next; +}; + +/* Declare a Lisp-callable function. The MAXARGS parameter has the same + meaning as in the DEFUN macro, and is used to construct a prototype. */ +/* We can use the same trick as in the DEFUN macro to generate the + appropriate prototype. */ +#define EXFUN(fnname, maxargs) \ + extern Lisp_Object fnname DEFUN_ARGS_ ## maxargs + +/* Note that the weird token-substitution semantics of ANSI C makes + this work for MANY and UNEVALLED. */ +#define DEFUN_ARGS_MANY (ptrdiff_t, Lisp_Object *) +#define DEFUN_ARGS_UNEVALLED (Lisp_Object) +#define DEFUN_ARGS_0 (void) +#define DEFUN_ARGS_1 (Lisp_Object) +#define DEFUN_ARGS_2 (Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_3 (Lisp_Object, Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ + Lisp_Object) +#define DEFUN_ARGS_6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ + Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ + Lisp_Object, Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ + Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) + +/* Yield an integer that contains TAG along with PTR. */ +#define TAG_PTR(tag, ptr) \ + ((USE_LSB_TAG ? (tag) : (EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr)) + +/* Yield an integer that contains a symbol tag along with OFFSET. + OFFSET should be the offset in bytes from 'lispsym' to the symbol. */ +#define TAG_SYMOFFSET(offset) \ + TAG_PTR (Lisp_Symbol, \ + ((uintptr_t) (offset) >> (USE_LSB_TAG ? 0 : GCTYPEBITS))) + +/* XLI_BUILTIN_LISPSYM (iQwhatever) is equivalent to + XLI (builtin_lisp_symbol (Qwhatever)), + except the former expands to an integer constant expression. */ +#define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym) + +/* Declare extern constants for Lisp symbols. These can be helpful + when using a debugger like GDB, on older platforms where the debug + format does not represent C macros. */ +#define DEFINE_LISP_SYMBOL(name) \ + DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ + DEFINE_GDB_SYMBOL_END (LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name))) + +/* By default, define macros for Qt, etc., as this leads to a bit + better performance in the core Emacs interpreter. A plugin can + define DEFINE_NON_NIL_Q_SYMBOL_MACROS to be false, to be portable to + other Emacs instances that assign different values to Qt, etc. */ +#ifndef DEFINE_NON_NIL_Q_SYMBOL_MACROS +# define DEFINE_NON_NIL_Q_SYMBOL_MACROS true +#endif + +#include "globals.h" + +/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. + At the machine level, these operations are no-ops. */ +LISP_MACRO_DEFUN (XLI, EMACS_INT, (Lisp_Object o), (o)) +LISP_MACRO_DEFUN (XIL, Lisp_Object, (EMACS_INT i), (i)) + +/* In the size word of a vector, this bit means the vector has been marked. */ + +DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, ARRAY_MARK_FLAG) +# define ARRAY_MARK_FLAG PTRDIFF_MIN +DEFINE_GDB_SYMBOL_END (ARRAY_MARK_FLAG) + +/* In the size word of a struct Lisp_Vector, this bit means it's really + some other vector-like object. */ +DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, PSEUDOVECTOR_FLAG) +# define PSEUDOVECTOR_FLAG (PTRDIFF_MAX - PTRDIFF_MAX / 2) +DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) + +/* In a pseudovector, the size field actually contains a word with one + PSEUDOVECTOR_FLAG bit set, and one of the following values extracted + with PVEC_TYPE_MASK to indicate the actual type. */ +enum pvec_type +{ + PVEC_NORMAL_VECTOR, + PVEC_FREE, + PVEC_PROCESS, + PVEC_FRAME, + PVEC_WINDOW, + PVEC_BOOL_VECTOR, + PVEC_BUFFER, + PVEC_HASH_TABLE, + PVEC_TERMINAL, + PVEC_WINDOW_CONFIGURATION, + PVEC_SUBR, + PVEC_OTHER, + /* These should be last, check internal_equal to see why. */ + PVEC_COMPILED, + PVEC_CHAR_TABLE, + PVEC_SUB_CHAR_TABLE, + PVEC_FONT /* Should be last because it's used for range checking. */ +}; + +enum More_Lisp_Bits + { + /* For convenience, we also store the number of elements in these bits. + Note that this size is not necessarily the memory-footprint size, but + only the number of Lisp_Object fields (that need to be traced by GC). + The distinction is used, e.g., by Lisp_Process, which places extra + non-Lisp_Object fields at the end of the structure. */ + PSEUDOVECTOR_SIZE_BITS = 12, + PSEUDOVECTOR_SIZE_MASK = (1 << PSEUDOVECTOR_SIZE_BITS) - 1, + + /* To calculate the memory footprint of the pseudovector, it's useful + to store the size of non-Lisp area in word_size units here. */ + PSEUDOVECTOR_REST_BITS = 12, + PSEUDOVECTOR_REST_MASK = (((1 << PSEUDOVECTOR_REST_BITS) - 1) + << PSEUDOVECTOR_SIZE_BITS), + + /* Used to extract pseudovector subtype information. */ + PSEUDOVECTOR_AREA_BITS = PSEUDOVECTOR_SIZE_BITS + PSEUDOVECTOR_REST_BITS, + PVEC_TYPE_MASK = 0x3f << PSEUDOVECTOR_AREA_BITS + }; + +/* These functions extract various sorts of values from a Lisp_Object. + For example, if tem is a Lisp_Object whose type is Lisp_Cons, + XCONS (tem) is the struct Lisp_Cons * pointing to the memory for + that cons. */ + +/* Mask for the value (as opposed to the type bits) of a Lisp object. */ +DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK) +# define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX) +DEFINE_GDB_SYMBOL_END (VALMASK) + +/* Largest and smallest representable fixnum values. These are the C + values. They are macros for use in static initializers. */ +#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) +#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) + +#if USE_LSB_TAG + +LISP_MACRO_DEFUN (make_number, Lisp_Object, (EMACS_INT n), (n)) +LISP_MACRO_DEFUN (XINT, EMACS_INT, (Lisp_Object a), (a)) +LISP_MACRO_DEFUN (XFASTINT, EMACS_INT, (Lisp_Object a), (a)) +LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a)) +LISP_MACRO_DEFUN (XTYPE, enum Lisp_Type, (Lisp_Object a), (a)) +LISP_MACRO_DEFUN (XUNTAG, void *, (Lisp_Object a, int type), (a, type)) + +#else /* ! USE_LSB_TAG */ + +/* Although compiled only if ! USE_LSB_TAG, the following functions + also work when USE_LSB_TAG; this is to aid future maintenance when + the lisp_h_* macros are eventually removed. */ + +/* Make a Lisp integer representing the value of the low order + bits of N. */ +INLINE Lisp_Object +make_number (EMACS_INT n) +{ + EMACS_INT int0 = Lisp_Int0; + if (USE_LSB_TAG) + { + EMACS_UINT u = n; + n = u << INTTYPEBITS; + n += int0; + } + else + { + n &= INTMASK; + n += (int0 << VALBITS); + } + return XIL (n); +} + +/* Extract A's value as a signed integer. */ +INLINE EMACS_INT +XINT (Lisp_Object a) +{ + EMACS_INT i = XLI (a); + if (! USE_LSB_TAG) + { + EMACS_UINT u = i; + i = u << INTTYPEBITS; + } + return i >> INTTYPEBITS; +} + +/* Like XINT (A), but may be faster. A must be nonnegative. + If ! USE_LSB_TAG, this takes advantage of the fact that Lisp + integers have zero-bits in their tags. */ +INLINE EMACS_INT +XFASTINT (Lisp_Object a) +{ + EMACS_INT int0 = Lisp_Int0; + EMACS_INT n = USE_LSB_TAG ? XINT (a) : XLI (a) - (int0 << VALBITS); + eassert (0 <= n); + return n; +} + +/* Extract A's value as a symbol. */ +INLINE struct Lisp_Symbol * +XSYMBOL (Lisp_Object a) +{ + uintptr_t i = (uintptr_t) XUNTAG (a, Lisp_Symbol); + if (! USE_LSB_TAG) + i <<= GCTYPEBITS; + void *p = (char *) lispsym + i; + return p; +} + +/* Extract A's type. */ +INLINE enum Lisp_Type +XTYPE (Lisp_Object a) +{ + EMACS_UINT i = XLI (a); + return USE_LSB_TAG ? i & ~VALMASK : i >> VALBITS; +} + +/* Extract A's pointer value, assuming A's type is TYPE. */ +INLINE void * +XUNTAG (Lisp_Object a, int type) +{ + intptr_t i = USE_LSB_TAG ? XLI (a) - type : XLI (a) & VALMASK; + return (void *) i; +} + +#endif /* ! USE_LSB_TAG */ + +/* Extract the pointer hidden within A. */ +LISP_MACRO_DEFUN (XPNTR, void *, (Lisp_Object a), (a)) + +/* Extract A's value as an unsigned integer. */ +INLINE EMACS_UINT +XUINT (Lisp_Object a) +{ + EMACS_UINT i = XLI (a); + return USE_LSB_TAG ? i >> INTTYPEBITS : i & INTMASK; +} + +/* Return A's (Lisp-integer sized) hash. Happens to be like XUINT + right now, but XUINT should only be applied to objects we know are + integers. */ +LISP_MACRO_DEFUN (XHASH, EMACS_INT, (Lisp_Object a), (a)) + +/* Like make_number (N), but may be faster. N must be in nonnegative range. */ +INLINE Lisp_Object +make_natnum (EMACS_INT n) +{ + eassert (0 <= n && n <= MOST_POSITIVE_FIXNUM); + EMACS_INT int0 = Lisp_Int0; + return USE_LSB_TAG ? make_number (n) : XIL (n + (int0 << VALBITS)); +} + +/* Return true if X and Y are the same object. */ +LISP_MACRO_DEFUN (EQ, bool, (Lisp_Object x, Lisp_Object y), (x, y)) + +/* Value is true if I doesn't fit into a Lisp fixnum. It is + written this way so that it also works if I is of unsigned + type or if I is a NaN. */ + +#define FIXNUM_OVERFLOW_P(i) \ + (! ((0 <= (i) || MOST_NEGATIVE_FIXNUM <= (i)) && (i) <= MOST_POSITIVE_FIXNUM)) + +INLINE ptrdiff_t +clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) +{ + return num < lower ? lower : num <= upper ? num : upper; +} + + +/* Extract a value or address from a Lisp_Object. */ + +LISP_MACRO_DEFUN (XCONS, struct Lisp_Cons *, (Lisp_Object a), (a)) + +INLINE struct Lisp_Vector * +XVECTOR (Lisp_Object a) +{ + eassert (VECTORLIKEP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_String * +XSTRING (Lisp_Object a) +{ + eassert (STRINGP (a)); + return XUNTAG (a, Lisp_String); +} + +/* The index of the C-defined Lisp symbol SYM. + This can be used in a static initializer. */ +#define SYMBOL_INDEX(sym) i##sym + +INLINE struct Lisp_Float * +XFLOAT (Lisp_Object a) +{ + eassert (FLOATP (a)); + return XUNTAG (a, Lisp_Float); +} + +/* Pseudovector types. */ + +INLINE struct Lisp_Process * +XPROCESS (Lisp_Object a) +{ + eassert (PROCESSP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct window * +XWINDOW (Lisp_Object a) +{ + eassert (WINDOWP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct terminal * +XTERMINAL (Lisp_Object a) +{ + eassert (TERMINALP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_Subr * +XSUBR (Lisp_Object a) +{ + eassert (SUBRP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct buffer * +XBUFFER (Lisp_Object a) +{ + eassert (BUFFERP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_Char_Table * +XCHAR_TABLE (Lisp_Object a) +{ + eassert (CHAR_TABLE_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_Sub_Char_Table * +XSUB_CHAR_TABLE (Lisp_Object a) +{ + eassert (SUB_CHAR_TABLE_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_Bool_Vector * +XBOOL_VECTOR (Lisp_Object a) +{ + eassert (BOOL_VECTOR_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +/* Construct a Lisp_Object from a value or address. */ + +INLINE Lisp_Object +make_lisp_ptr (void *ptr, enum Lisp_Type type) +{ + Lisp_Object a = XIL (TAG_PTR (type, ptr)); + eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr); + return a; +} + +INLINE Lisp_Object +make_lisp_symbol (struct Lisp_Symbol *sym) +{ + Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym)); + eassert (XSYMBOL (a) == sym); + return a; +} + +INLINE Lisp_Object +builtin_lisp_symbol (int index) +{ + return make_lisp_symbol (lispsym + index); +} + +#define XSETINT(a, b) ((a) = make_number (b)) +#define XSETFASTINT(a, b) ((a) = make_natnum (b)) +#define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons)) +#define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike)) +#define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String)) +#define XSETSYMBOL(a, b) ((a) = make_lisp_symbol (b)) +#define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float)) +#define XSETMISC(a, b) ((a) = make_lisp_ptr (b, Lisp_Misc)) + +/* Pseudovector types. */ + +#define XSETPVECTYPE(v, code) \ + ((v)->header.size |= PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS)) +#define XSETPVECTYPESIZE(v, code, lispsize, restsize) \ + ((v)->header.size = (PSEUDOVECTOR_FLAG \ + | ((code) << PSEUDOVECTOR_AREA_BITS) \ + | ((restsize) << PSEUDOVECTOR_SIZE_BITS) \ + | (lispsize))) + +/* The cast to struct vectorlike_header * avoids aliasing issues. */ +#define XSETPSEUDOVECTOR(a, b, code) \ + XSETTYPED_PSEUDOVECTOR (a, b, \ + (((struct vectorlike_header *) \ + XUNTAG (a, Lisp_Vectorlike)) \ + ->size), \ + code) +#define XSETTYPED_PSEUDOVECTOR(a, b, size, code) \ + (XSETVECTOR (a, b), \ + eassert ((size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \ + == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)))) + +#define XSETWINDOW_CONFIGURATION(a, b) \ + (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW_CONFIGURATION)) +#define XSETPROCESS(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_PROCESS)) +#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) +#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) +#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) +#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) +#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) +#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) +#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) +#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) + +/* Efficiently convert a pointer to a Lisp object and back. The + pointer is represented as a Lisp integer, so the garbage collector + does not know about it. The pointer should not have both Lisp_Int1 + bits set, which makes this conversion inherently unportable. */ + +INLINE void * +XINTPTR (Lisp_Object a) +{ + return XUNTAG (a, Lisp_Int0); +} + +INLINE Lisp_Object +make_pointer_integer (void *p) +{ + Lisp_Object a = XIL (TAG_PTR (Lisp_Int0, p)); + eassert (INTEGERP (a) && XINTPTR (a) == p); + return a; +} + +/* Type checking. */ + +LISP_MACRO_DEFUN_VOID (CHECK_TYPE, + (int ok, Lisp_Object predicate, Lisp_Object x), + (ok, predicate, x)) + +/* See the macros in intervals.h. */ + +typedef struct interval *INTERVAL; + +struct GCALIGNED Lisp_Cons + { + /* Car of this cons cell. */ + Lisp_Object car; + + union + { + /* Cdr of this cons cell. */ + Lisp_Object cdr; + + /* Used to chain conses on a free list. */ + struct Lisp_Cons *chain; + } u; + }; + +/* Take the car or cdr of something known to be a cons cell. */ +/* The _addr functions shouldn't be used outside of the minimal set + of code that has to know what a cons cell looks like. Other code not + part of the basic lisp implementation should assume that the car and cdr + fields are not accessible. (What if we want to switch to + a copying collector someday? Cached cons cell field addresses may be + invalidated at arbitrary points.) */ +INLINE Lisp_Object * +xcar_addr (Lisp_Object c) +{ + return &XCONS (c)->car; +} +INLINE Lisp_Object * +xcdr_addr (Lisp_Object c) +{ + return &XCONS (c)->u.cdr; +} + +/* Use these from normal code. */ +LISP_MACRO_DEFUN (XCAR, Lisp_Object, (Lisp_Object c), (c)) +LISP_MACRO_DEFUN (XCDR, Lisp_Object, (Lisp_Object c), (c)) + +/* Use these to set the fields of a cons cell. + + Note that both arguments may refer to the same object, so 'n' + should not be read after 'c' is first modified. */ +INLINE void +XSETCAR (Lisp_Object c, Lisp_Object n) +{ + *xcar_addr (c) = n; +} +INLINE void +XSETCDR (Lisp_Object c, Lisp_Object n) +{ + *xcdr_addr (c) = n; +} + +/* Take the car or cdr of something whose type is not known. */ +INLINE Lisp_Object +CAR (Lisp_Object c) +{ + return (CONSP (c) ? XCAR (c) + : NILP (c) ? Qnil + : wrong_type_argument (Qlistp, c)); +} +INLINE Lisp_Object +CDR (Lisp_Object c) +{ + return (CONSP (c) ? XCDR (c) + : NILP (c) ? Qnil + : wrong_type_argument (Qlistp, c)); +} + +/* Take the car or cdr of something whose type is not known. */ +INLINE Lisp_Object +CAR_SAFE (Lisp_Object c) +{ + return CONSP (c) ? XCAR (c) : Qnil; +} +INLINE Lisp_Object +CDR_SAFE (Lisp_Object c) +{ + return CONSP (c) ? XCDR (c) : Qnil; +} + +/* In a string or vector, the sign bit of the `size' is the gc mark bit. */ + +struct GCALIGNED Lisp_String + { + ptrdiff_t size; + ptrdiff_t size_byte; + INTERVAL intervals; /* Text properties in this string. */ + unsigned char *data; + }; + +/* True if STR is a multibyte string. */ +INLINE bool +STRING_MULTIBYTE (Lisp_Object str) +{ + return 0 <= XSTRING (str)->size_byte; +} + +/* An upper bound on the number of bytes in a Lisp string, not + counting the terminating null. This a tight enough bound to + prevent integer overflow errors that would otherwise occur during + string size calculations. A string cannot contain more bytes than + a fixnum can represent, nor can it be so long that C pointer + arithmetic stops working on the string plus its terminating null. + Although the actual size limit (see STRING_BYTES_MAX in alloc.c) + may be a bit smaller than STRING_BYTES_BOUND, calculating it here + would expose alloc.c internal details that we'd rather keep + private. + + This is a macro for use in static initializers. The cast to + ptrdiff_t ensures that the macro is signed. */ +#define STRING_BYTES_BOUND \ + ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, min (SIZE_MAX, PTRDIFF_MAX) - 1)) + +/* Mark STR as a unibyte string. */ +#define STRING_SET_UNIBYTE(STR) \ + do { \ + if (EQ (STR, empty_multibyte_string)) \ + (STR) = empty_unibyte_string; \ + else \ + XSTRING (STR)->size_byte = -1; \ + } while (false) + +/* Mark STR as a multibyte string. Assure that STR contains only + ASCII characters in advance. */ +#define STRING_SET_MULTIBYTE(STR) \ + do { \ + if (EQ (STR, empty_unibyte_string)) \ + (STR) = empty_multibyte_string; \ + else \ + XSTRING (STR)->size_byte = XSTRING (STR)->size; \ + } while (false) + +/* Convenience functions for dealing with Lisp strings. */ + +INLINE unsigned char * +SDATA (Lisp_Object string) +{ + return XSTRING (string)->data; +} +INLINE char * +SSDATA (Lisp_Object string) +{ + /* Avoid "differ in sign" warnings. */ + return (char *) SDATA (string); +} +INLINE unsigned char +SREF (Lisp_Object string, ptrdiff_t index) +{ + return SDATA (string)[index]; +} +INLINE void +SSET (Lisp_Object string, ptrdiff_t index, unsigned char new) +{ + SDATA (string)[index] = new; +} +INLINE ptrdiff_t +SCHARS (Lisp_Object string) +{ + return XSTRING (string)->size; +} + +#ifdef GC_CHECK_STRING_BYTES +extern ptrdiff_t string_bytes (struct Lisp_String *); +#endif +INLINE ptrdiff_t +STRING_BYTES (struct Lisp_String *s) +{ +#ifdef GC_CHECK_STRING_BYTES + return string_bytes (s); +#else + return s->size_byte < 0 ? s->size : s->size_byte; +#endif +} + +INLINE ptrdiff_t +SBYTES (Lisp_Object string) +{ + return STRING_BYTES (XSTRING (string)); +} +INLINE void +STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize) +{ + XSTRING (string)->size = newsize; +} + +/* Header of vector-like objects. This documents the layout constraints on + vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents + compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR + and PSEUDOVECTORP cast their pointers to struct vectorlike_header *, + because when two such pointers potentially alias, a compiler won't + incorrectly reorder loads and stores to their size fields. See + Bug#8546. */ +struct vectorlike_header + { + /* The only field contains various pieces of information: + - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit. + - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain + vector (0) or a pseudovector (1). + - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number + of slots) of the vector. + - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields: + - a) pseudovector subtype held in PVEC_TYPE_MASK field; + - b) number of Lisp_Objects slots at the beginning of the object + held in PSEUDOVECTOR_SIZE_MASK field. These objects are always + traced by the GC; + - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and + measured in word_size units. Rest fields may also include + Lisp_Objects, but these objects usually needs some special treatment + during GC. + There are some exceptions. For PVEC_FREE, b) is always zero. For + PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero. + Current layout limits the pseudovectors to 63 PVEC_xxx subtypes, + 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */ + ptrdiff_t size; + }; + +/* A regular vector is just a header plus an array of Lisp_Objects. */ + +struct Lisp_Vector + { + struct vectorlike_header header; + Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER]; + }; + +/* C11 prohibits alignof (struct Lisp_Vector), so compute it manually. */ +enum + { + ALIGNOF_STRUCT_LISP_VECTOR + = alignof (union { struct vectorlike_header a; Lisp_Object b; }) + }; + +/* A boolvector is a kind of vectorlike, with contents like a string. */ + +struct Lisp_Bool_Vector + { + /* HEADER.SIZE is the vector's size field. It doesn't have the real size, + just the subtype information. */ + struct vectorlike_header header; + /* This is the size in bits. */ + EMACS_INT size; + /* The actual bits, packed into bytes. + Zeros fill out the last word if needed. + The bits are in little-endian order in the bytes, and + the bytes are in little-endian order in the words. */ + bits_word data[FLEXIBLE_ARRAY_MEMBER]; + }; + +INLINE EMACS_INT +bool_vector_size (Lisp_Object a) +{ + EMACS_INT size = XBOOL_VECTOR (a)->size; + eassume (0 <= size); + return size; +} + +INLINE bits_word * +bool_vector_data (Lisp_Object a) +{ + return XBOOL_VECTOR (a)->data; +} + +INLINE unsigned char * +bool_vector_uchar_data (Lisp_Object a) +{ + return (unsigned char *) bool_vector_data (a); +} + +/* The number of data words and bytes in a bool vector with SIZE bits. */ + +INLINE EMACS_INT +bool_vector_words (EMACS_INT size) +{ + eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1)); + return (size + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD; +} + +INLINE EMACS_INT +bool_vector_bytes (EMACS_INT size) +{ + eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1)); + return (size + BOOL_VECTOR_BITS_PER_CHAR - 1) / BOOL_VECTOR_BITS_PER_CHAR; +} + +/* True if A's Ith bit is set. */ + +INLINE bool +bool_vector_bitref (Lisp_Object a, EMACS_INT i) +{ + eassume (0 <= i && i < bool_vector_size (a)); + return !! (bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR] + & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))); +} + +INLINE Lisp_Object +bool_vector_ref (Lisp_Object a, EMACS_INT i) +{ + return bool_vector_bitref (a, i) ? Qt : Qnil; +} + +/* Set A's Ith bit to B. */ + +INLINE void +bool_vector_set (Lisp_Object a, EMACS_INT i, bool b) +{ + unsigned char *addr; + + eassume (0 <= i && i < bool_vector_size (a)); + addr = &bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR]; + + if (b) + *addr |= 1 << (i % BOOL_VECTOR_BITS_PER_CHAR); + else + *addr &= ~ (1 << (i % BOOL_VECTOR_BITS_PER_CHAR)); +} + +/* Some handy constants for calculating sizes + and offsets, mostly of vectorlike objects. */ + +enum + { + header_size = offsetof (struct Lisp_Vector, contents), + bool_header_size = offsetof (struct Lisp_Bool_Vector, data), + word_size = sizeof (Lisp_Object) + }; + +/* Conveniences for dealing with Lisp arrays. */ + +INLINE Lisp_Object +AREF (Lisp_Object array, ptrdiff_t idx) +{ + return XVECTOR (array)->contents[idx]; +} + +INLINE Lisp_Object * +aref_addr (Lisp_Object array, ptrdiff_t idx) +{ + return & XVECTOR (array)->contents[idx]; +} + +INLINE ptrdiff_t +ASIZE (Lisp_Object array) +{ + return XVECTOR (array)->header.size; +} + +INLINE void +ASET (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) +{ + eassert (0 <= idx && idx < ASIZE (array)); + XVECTOR (array)->contents[idx] = val; +} + +INLINE void +gc_aset (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) +{ + /* Like ASET, but also can be used in the garbage collector: + sweep_weak_table calls set_hash_key etc. while the table is marked. */ + eassert (0 <= idx && idx < (ASIZE (array) & ~ARRAY_MARK_FLAG)); + XVECTOR (array)->contents[idx] = val; +} + +/* True, since Qnil's representation is zero. Every place in the code + that assumes Qnil is zero should verify (NIL_IS_ZERO), to make it easy + to find such assumptions later if we change Qnil to be nonzero. */ +enum { NIL_IS_ZERO = XLI_BUILTIN_LISPSYM (iQnil) == 0 }; + +/* Clear the object addressed by P, with size NBYTES, so that all its + bytes are zero and all its Lisp values are nil. */ +INLINE void +memclear (void *p, ptrdiff_t nbytes) +{ + eassert (0 <= nbytes); + verify (NIL_IS_ZERO); + /* Since Qnil is zero, memset suffices. */ + memset (p, 0, nbytes); +} + +/* If a struct is made to look like a vector, this macro returns the length + of the shortest vector that would hold that struct. */ + +#define VECSIZE(type) \ + ((sizeof (type) - header_size + word_size - 1) / word_size) + +/* Like VECSIZE, but used when the pseudo-vector has non-Lisp_Object fields + at the end and we need to compute the number of Lisp_Object fields (the + ones that the GC needs to trace). */ + +#define PSEUDOVECSIZE(type, nonlispfield) \ + ((offsetof (type, nonlispfield) - header_size) / word_size) + +/* Compute A OP B, using the unsigned comparison operator OP. A and B + should be integer expressions. This is not the same as + mathematical comparison; for example, UNSIGNED_CMP (0, <, -1) + returns true. For efficiency, prefer plain unsigned comparison if A + and B's sizes both fit (after integer promotion). */ +#define UNSIGNED_CMP(a, op, b) \ + (max (sizeof ((a) + 0), sizeof ((b) + 0)) <= sizeof (unsigned) \ + ? ((a) + (unsigned) 0) op ((b) + (unsigned) 0) \ + : ((a) + (uintmax_t) 0) op ((b) + (uintmax_t) 0)) + +/* True iff C is an ASCII character. */ +#define ASCII_CHAR_P(c) UNSIGNED_CMP (c, <, 0x80) + +/* A char-table is a kind of vectorlike, with contents are like a + vector but with a few other slots. For some purposes, it makes + sense to handle a char-table with type struct Lisp_Vector. An + element of a char table can be any Lisp objects, but if it is a sub + char-table, we treat it a table that contains information of a + specific range of characters. A sub char-table is like a vector but + with two integer fields between the header and Lisp data, which means + that it has to be marked with some precautions (see mark_char_table + in alloc.c). A sub char-table appears only in an element of a char-table, + and there's no way to access it directly from Emacs Lisp program. */ + +enum CHARTAB_SIZE_BITS + { + CHARTAB_SIZE_BITS_0 = 6, + CHARTAB_SIZE_BITS_1 = 4, + CHARTAB_SIZE_BITS_2 = 5, + CHARTAB_SIZE_BITS_3 = 7 + }; + +extern const int chartab_size[4]; + +struct Lisp_Char_Table + { + /* HEADER.SIZE is the vector's size field, which also holds the + pseudovector type information. It holds the size, too. + The size counts the defalt, parent, purpose, ascii, + contents, and extras slots. */ + struct vectorlike_header header; + + /* This holds a default value, + which is used whenever the value for a specific character is nil. */ + Lisp_Object defalt; + + /* This points to another char table, which we inherit from when the + value for a specific character is nil. The `defalt' slot takes + precedence over this. */ + Lisp_Object parent; + + /* This is a symbol which says what kind of use this char-table is + meant for. */ + Lisp_Object purpose; + + /* The bottom sub char-table for characters of the range 0..127. It + is nil if none of ASCII character has a specific value. */ + Lisp_Object ascii; + + Lisp_Object contents[(1 << CHARTAB_SIZE_BITS_0)]; + + /* These hold additional data. It is a vector. */ + Lisp_Object extras[FLEXIBLE_ARRAY_MEMBER]; + }; + +struct Lisp_Sub_Char_Table + { + /* HEADER.SIZE is the vector's size field, which also holds the + pseudovector type information. It holds the size, too. */ + struct vectorlike_header header; + + /* Depth of this sub char-table. It should be 1, 2, or 3. A sub + char-table of depth 1 contains 16 elements, and each element + covers 4096 (128*32) characters. A sub char-table of depth 2 + contains 32 elements, and each element covers 128 characters. A + sub char-table of depth 3 contains 128 elements, and each element + is for one character. */ + int depth; + + /* Minimum character covered by the sub char-table. */ + int min_char; + + /* Use set_sub_char_table_contents to set this. */ + Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER]; + }; + +INLINE Lisp_Object +CHAR_TABLE_REF_ASCII (Lisp_Object ct, ptrdiff_t idx) +{ + struct Lisp_Char_Table *tbl = NULL; + Lisp_Object val; + do + { + tbl = tbl ? XCHAR_TABLE (tbl->parent) : XCHAR_TABLE (ct); + val = (! SUB_CHAR_TABLE_P (tbl->ascii) ? tbl->ascii + : XSUB_CHAR_TABLE (tbl->ascii)->contents[idx]); + if (NILP (val)) + val = tbl->defalt; + } + while (NILP (val) && ! NILP (tbl->parent)); + + return val; +} + +/* Almost equivalent to Faref (CT, IDX) with optimization for ASCII + characters. Do not check validity of CT. */ +INLINE Lisp_Object +CHAR_TABLE_REF (Lisp_Object ct, int idx) +{ + return (ASCII_CHAR_P (idx) + ? CHAR_TABLE_REF_ASCII (ct, idx) + : char_table_ref (ct, idx)); +} + +/* Equivalent to Faset (CT, IDX, VAL) with optimization for ASCII and + 8-bit European characters. Do not check validity of CT. */ +INLINE void +CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) +{ + if (ASCII_CHAR_P (idx) && SUB_CHAR_TABLE_P (XCHAR_TABLE (ct)->ascii)) + set_sub_char_table_contents (XCHAR_TABLE (ct)->ascii, idx, val); + else + char_table_set (ct, idx, val); +} + +/* This structure describes a built-in function. + It is generated by the DEFUN macro only. + defsubr makes it into a Lisp object. */ + +struct Lisp_Subr + { + struct vectorlike_header header; + union { + Lisp_Object (*a0) (void); + Lisp_Object (*a1) (Lisp_Object); + Lisp_Object (*a2) (Lisp_Object, Lisp_Object); + Lisp_Object (*a3) (Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a4) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a5) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a6) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a7) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a8) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*aUNEVALLED) (Lisp_Object args); + Lisp_Object (*aMANY) (ptrdiff_t, Lisp_Object *); + } function; + short min_args, max_args; + const char *symbol_name; + const char *intspec; + const char *doc; + }; + +enum char_table_specials + { + /* This is the number of slots that every char table must have. This + counts the ordinary slots and the top, defalt, parent, and purpose + slots. */ + CHAR_TABLE_STANDARD_SLOTS = PSEUDOVECSIZE (struct Lisp_Char_Table, extras), + + /* This is an index of first Lisp_Object field in Lisp_Sub_Char_Table + when the latter is treated as an ordinary Lisp_Vector. */ + SUB_CHAR_TABLE_OFFSET = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) + }; + +/* Return the number of "extra" slots in the char table CT. */ + +INLINE int +CHAR_TABLE_EXTRA_SLOTS (struct Lisp_Char_Table *ct) +{ + return ((ct->header.size & PSEUDOVECTOR_SIZE_MASK) + - CHAR_TABLE_STANDARD_SLOTS); +} + +/* Make sure that sub char-table contents slot is where we think it is. */ +verify (offsetof (struct Lisp_Sub_Char_Table, contents) + == offsetof (struct Lisp_Vector, contents[SUB_CHAR_TABLE_OFFSET])); + +/*********************************************************************** + Symbols + ***********************************************************************/ + +/* Value is name of symbol. */ + +LISP_MACRO_DEFUN (SYMBOL_VAL, Lisp_Object, (struct Lisp_Symbol *sym), (sym)) + +INLINE struct Lisp_Symbol * +SYMBOL_ALIAS (struct Lisp_Symbol *sym) +{ + eassert (sym->redirect == SYMBOL_VARALIAS); + return sym->val.alias; +} +INLINE struct Lisp_Buffer_Local_Value * +SYMBOL_BLV (struct Lisp_Symbol *sym) +{ + eassert (sym->redirect == SYMBOL_LOCALIZED); + return sym->val.blv; +} +INLINE union Lisp_Fwd * +SYMBOL_FWD (struct Lisp_Symbol *sym) +{ + eassert (sym->redirect == SYMBOL_FORWARDED); + return sym->val.fwd; +} + +LISP_MACRO_DEFUN_VOID (SET_SYMBOL_VAL, + (struct Lisp_Symbol *sym, Lisp_Object v), (sym, v)) + +INLINE void +SET_SYMBOL_ALIAS (struct Lisp_Symbol *sym, struct Lisp_Symbol *v) +{ + eassert (sym->redirect == SYMBOL_VARALIAS); + sym->val.alias = v; +} +INLINE void +SET_SYMBOL_BLV (struct Lisp_Symbol *sym, struct Lisp_Buffer_Local_Value *v) +{ + eassert (sym->redirect == SYMBOL_LOCALIZED); + sym->val.blv = v; +} +INLINE void +SET_SYMBOL_FWD (struct Lisp_Symbol *sym, union Lisp_Fwd *v) +{ + eassert (sym->redirect == SYMBOL_FORWARDED); + sym->val.fwd = v; +} + +INLINE Lisp_Object +SYMBOL_NAME (Lisp_Object sym) +{ + return XSYMBOL (sym)->name; +} + +/* Value is true if SYM is an interned symbol. */ + +INLINE bool +SYMBOL_INTERNED_P (Lisp_Object sym) +{ + return XSYMBOL (sym)->interned != SYMBOL_UNINTERNED; +} + +/* Value is true if SYM is interned in initial_obarray. */ + +INLINE bool +SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym) +{ + return XSYMBOL (sym)->interned == SYMBOL_INTERNED_IN_INITIAL_OBARRAY; +} + +/* Value is non-zero if symbol is considered a constant, i.e. its + value cannot be changed (there is an exception for keyword symbols, + whose value can be set to the keyword symbol itself). */ + +LISP_MACRO_DEFUN (SYMBOL_CONSTANT_P, int, (Lisp_Object sym), (sym)) + +/* Placeholder for make-docfile to process. The actual symbol + definition is done by lread.c's defsym. */ +#define DEFSYM(sym, name) /* empty */ + + +/*********************************************************************** + Hash Tables + ***********************************************************************/ + +/* The structure of a Lisp hash table. */ + +struct hash_table_test +{ + /* Name of the function used to compare keys. */ + Lisp_Object name; + + /* User-supplied hash function, or nil. */ + Lisp_Object user_hash_function; + + /* User-supplied key comparison function, or nil. */ + Lisp_Object user_cmp_function; + + /* C function to compare two keys. */ + bool (*cmpfn) (struct hash_table_test *t, Lisp_Object, Lisp_Object); + + /* C function to compute hash code. */ + EMACS_UINT (*hashfn) (struct hash_table_test *t, Lisp_Object); +}; + +struct Lisp_Hash_Table +{ + /* This is for Lisp; the hash table code does not refer to it. */ + struct vectorlike_header header; + + /* Nil if table is non-weak. Otherwise a symbol describing the + weakness of the table. */ + Lisp_Object weak; + + /* When the table is resized, and this is an integer, compute the + new size by adding this to the old size. If a float, compute the + new size by multiplying the old size with this factor. */ + Lisp_Object rehash_size; + + /* Resize hash table when number of entries/ table size is >= this + ratio, a float. */ + Lisp_Object rehash_threshold; + + /* Vector of hash codes. If hash[I] is nil, this means that the + I-th entry is unused. */ + Lisp_Object hash; + + /* Vector used to chain entries. If entry I is free, next[I] is the + entry number of the next free item. If entry I is non-free, + next[I] is the index of the next entry in the collision chain. */ + Lisp_Object next; + + /* Index of first free entry in free list. */ + Lisp_Object next_free; + + /* Bucket vector. A non-nil entry is the index of the first item in + a collision chain. This vector's size can be larger than the + hash table size to reduce collisions. */ + Lisp_Object index; + + /* Only the fields above are traced normally by the GC. The ones below + `count' are special and are either ignored by the GC or traced in + a special way (e.g. because of weakness). */ + + /* Number of key/value entries in the table. */ + ptrdiff_t count; + + /* Vector of keys and values. The key of item I is found at index + 2 * I, the value is found at index 2 * I + 1. + This is gc_marked specially if the table is weak. */ + Lisp_Object key_and_value; + + /* The comparison and hash functions. */ + struct hash_table_test test; + + /* Next weak hash table if this is a weak hash table. The head + of the list is in weak_hash_tables. */ + struct Lisp_Hash_Table *next_weak; +}; + + +INLINE struct Lisp_Hash_Table * +XHASH_TABLE (Lisp_Object a) +{ + return XUNTAG (a, Lisp_Vectorlike); +} + +#define XSET_HASH_TABLE(VAR, PTR) \ + (XSETPSEUDOVECTOR (VAR, PTR, PVEC_HASH_TABLE)) + +INLINE bool +HASH_TABLE_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_HASH_TABLE); +} + +/* Value is the key part of entry IDX in hash table H. */ +INLINE Lisp_Object +HASH_KEY (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->key_and_value, 2 * idx); +} + +/* Value is the value part of entry IDX in hash table H. */ +INLINE Lisp_Object +HASH_VALUE (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->key_and_value, 2 * idx + 1); +} + +/* Value is the index of the next entry following the one at IDX + in hash table H. */ +INLINE Lisp_Object +HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->next, idx); +} + +/* Value is the hash code computed for entry IDX in hash table H. */ +INLINE Lisp_Object +HASH_HASH (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->hash, idx); +} + +/* Value is the index of the element in hash table H that is the + start of the collision list at index IDX in the index vector of H. */ +INLINE Lisp_Object +HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->index, idx); +} + +/* Value is the size of hash table H. */ +INLINE ptrdiff_t +HASH_TABLE_SIZE (struct Lisp_Hash_Table *h) +{ + return ASIZE (h->next); +} + +/* Default size for hash tables if not specified. */ + +enum DEFAULT_HASH_SIZE { DEFAULT_HASH_SIZE = 65 }; + +/* Default threshold specifying when to resize a hash table. The + value gives the ratio of current entries in the hash table and the + size of the hash table. */ + +static double const DEFAULT_REHASH_THRESHOLD = 0.8; + +/* Default factor by which to increase the size of a hash table. */ + +static double const DEFAULT_REHASH_SIZE = 1.5; + +/* Combine two integers X and Y for hashing. The result might not fit + into a Lisp integer. */ + +INLINE EMACS_UINT +sxhash_combine (EMACS_UINT x, EMACS_UINT y) +{ + return (x << 4) + (x >> (BITS_PER_EMACS_INT - 4)) + y; +} + +/* Hash X, returning a value that fits into a fixnum. */ + +INLINE EMACS_UINT +SXHASH_REDUCE (EMACS_UINT x) +{ + return (x ^ x >> (BITS_PER_EMACS_INT - FIXNUM_BITS)) & INTMASK; +} + +/* These structures are used for various misc types. */ + +struct Lisp_Misc_Any /* Supertype of all Misc types. */ +{ + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_??? */ + bool_bf gcmarkbit : 1; + unsigned spacer : 15; +}; + +struct Lisp_Marker +{ + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Marker */ + bool_bf gcmarkbit : 1; + unsigned spacer : 13; + /* This flag is temporarily used in the functions + decode/encode_coding_object to record that the marker position + must be adjusted after the conversion. */ + bool_bf need_adjustment : 1; + /* True means normal insertion at the marker's position + leaves the marker after the inserted text. */ + bool_bf insertion_type : 1; + /* This is the buffer that the marker points into, or 0 if it points nowhere. + Note: a chain of markers can contain markers pointing into different + buffers (the chain is per buffer_text rather than per buffer, so it's + shared between indirect buffers). */ + /* This is used for (other than NULL-checking): + - Fmarker_buffer + - Fset_marker: check eq(oldbuf, newbuf) to avoid unchain+rechain. + - unchain_marker: to find the list from which to unchain. + - Fkill_buffer: to only unchain the markers of current indirect buffer. + */ + struct buffer *buffer; + + /* The remaining fields are meaningless in a marker that + does not point anywhere. */ + + /* For markers that point somewhere, + this is used to chain of all the markers in a given buffer. */ + /* We could remove it and use an array in buffer_text instead. + That would also allow to preserve it ordered. */ + struct Lisp_Marker *next; + /* This is the char position where the marker points. */ + ptrdiff_t charpos; + /* This is the byte position. + It's mostly used as a charpos<->bytepos cache (i.e. it's not directly + used to implement the functionality of markers, but rather to (ab)use + markers as a cache for char<->byte mappings). */ + ptrdiff_t bytepos; +}; + +/* START and END are markers in the overlay's buffer, and + PLIST is the overlay's property list. */ +struct Lisp_Overlay +/* An overlay's real data content is: + - plist + - buffer (really there are two buffer pointers, one per marker, + and both points to the same buffer) + - insertion type of both ends (per-marker fields) + - start & start byte (of start marker) + - end & end byte (of end marker) + - next (singly linked list of overlays) + - next fields of start and end markers (singly linked list of markers). + I.e. 9words plus 2 bits, 3words of which are for external linked lists. +*/ + { + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Overlay */ + bool_bf gcmarkbit : 1; + unsigned spacer : 15; + struct Lisp_Overlay *next; + Lisp_Object start; + Lisp_Object end; + Lisp_Object plist; + }; + +/* Types of data which may be saved in a Lisp_Save_Value. */ + +enum + { + SAVE_UNUSED, + SAVE_INTEGER, + SAVE_FUNCPOINTER, + SAVE_POINTER, + SAVE_OBJECT + }; + +/* Number of bits needed to store one of the above values. */ +enum { SAVE_SLOT_BITS = 3 }; + +/* Number of slots in a save value where save_type is nonzero. */ +enum { SAVE_VALUE_SLOTS = 4 }; + +/* Bit-width and values for struct Lisp_Save_Value's save_type member. */ + +enum { SAVE_TYPE_BITS = SAVE_VALUE_SLOTS * SAVE_SLOT_BITS + 1 }; + +enum Lisp_Save_Type + { + SAVE_TYPE_INT_INT = SAVE_INTEGER + (SAVE_INTEGER << SAVE_SLOT_BITS), + SAVE_TYPE_INT_INT_INT + = (SAVE_INTEGER + (SAVE_TYPE_INT_INT << SAVE_SLOT_BITS)), + SAVE_TYPE_OBJ_OBJ = SAVE_OBJECT + (SAVE_OBJECT << SAVE_SLOT_BITS), + SAVE_TYPE_OBJ_OBJ_OBJ = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ << SAVE_SLOT_BITS), + SAVE_TYPE_OBJ_OBJ_OBJ_OBJ + = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ_OBJ << SAVE_SLOT_BITS), + SAVE_TYPE_PTR_INT = SAVE_POINTER + (SAVE_INTEGER << SAVE_SLOT_BITS), + SAVE_TYPE_PTR_OBJ = SAVE_POINTER + (SAVE_OBJECT << SAVE_SLOT_BITS), + SAVE_TYPE_PTR_PTR = SAVE_POINTER + (SAVE_POINTER << SAVE_SLOT_BITS), + SAVE_TYPE_FUNCPTR_PTR_OBJ + = SAVE_FUNCPOINTER + (SAVE_TYPE_PTR_OBJ << SAVE_SLOT_BITS), + + /* This has an extra bit indicating it's raw memory. */ + SAVE_TYPE_MEMORY = SAVE_TYPE_PTR_INT + (1 << (SAVE_TYPE_BITS - 1)) + }; + +/* Special object used to hold a different values for later use. + + This is mostly used to package C integers and pointers to call + record_unwind_protect when two or more values need to be saved. + For example: + + ... + struct my_data *md = get_my_data (); + ptrdiff_t mi = get_my_integer (); + record_unwind_protect (my_unwind, make_save_ptr_int (md, mi)); + ... + + Lisp_Object my_unwind (Lisp_Object arg) + { + struct my_data *md = XSAVE_POINTER (arg, 0); + ptrdiff_t mi = XSAVE_INTEGER (arg, 1); + ... + } + + If ENABLE_CHECKING is in effect, XSAVE_xxx macros do type checking of the + saved objects and raise eassert if type of the saved object doesn't match + the type which is extracted. In the example above, XSAVE_INTEGER (arg, 2) + and XSAVE_OBJECT (arg, 0) are wrong because nothing was saved in slot 2 and + slot 0 is a pointer. */ + +typedef void (*voidfuncptr) (void); + +struct Lisp_Save_Value + { + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Save_Value */ + bool_bf gcmarkbit : 1; + unsigned spacer : 32 - (16 + 1 + SAVE_TYPE_BITS); + + /* V->data may hold up to SAVE_VALUE_SLOTS entries. The type of + V's data entries are determined by V->save_type. E.g., if + V->save_type == SAVE_TYPE_PTR_OBJ, V->data[0] is a pointer, + V->data[1] is an integer, and V's other data entries are unused. + + If V->save_type == SAVE_TYPE_MEMORY, V->data[0].pointer is the address of + a memory area containing V->data[1].integer potential Lisp_Objects. */ + ENUM_BF (Lisp_Save_Type) save_type : SAVE_TYPE_BITS; + union { + void *pointer; + voidfuncptr funcpointer; + ptrdiff_t integer; + Lisp_Object object; + } data[SAVE_VALUE_SLOTS]; + }; + +/* Return the type of V's Nth saved value. */ +INLINE int +save_type (struct Lisp_Save_Value *v, int n) +{ + eassert (0 <= n && n < SAVE_VALUE_SLOTS); + return (v->save_type >> (SAVE_SLOT_BITS * n) & ((1 << SAVE_SLOT_BITS) - 1)); +} + +/* Get and set the Nth saved pointer. */ + +INLINE void * +XSAVE_POINTER (Lisp_Object obj, int n) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER); + return XSAVE_VALUE (obj)->data[n].pointer; +} +INLINE void +set_save_pointer (Lisp_Object obj, int n, void *val) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER); + XSAVE_VALUE (obj)->data[n].pointer = val; +} +INLINE voidfuncptr +XSAVE_FUNCPOINTER (Lisp_Object obj, int n) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_FUNCPOINTER); + return XSAVE_VALUE (obj)->data[n].funcpointer; +} + +/* Likewise for the saved integer. */ + +INLINE ptrdiff_t +XSAVE_INTEGER (Lisp_Object obj, int n) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER); + return XSAVE_VALUE (obj)->data[n].integer; +} +INLINE void +set_save_integer (Lisp_Object obj, int n, ptrdiff_t val) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER); + XSAVE_VALUE (obj)->data[n].integer = val; +} + +/* Extract Nth saved object. */ + +INLINE Lisp_Object +XSAVE_OBJECT (Lisp_Object obj, int n) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_OBJECT); + return XSAVE_VALUE (obj)->data[n].object; +} + +/* A finalizer sentinel. */ +struct Lisp_Finalizer + { + struct Lisp_Misc_Any base; + + /* Circular list of all active weak references. */ + struct Lisp_Finalizer *prev; + struct Lisp_Finalizer *next; + + /* Call FUNCTION when the finalizer becomes unreachable, even if + FUNCTION contains a reference to the finalizer; i.e., call + FUNCTION when it is reachable _only_ through finalizers. */ + Lisp_Object function; + }; + +/* A miscellaneous object, when it's on the free list. */ +struct Lisp_Free + { + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Free */ + bool_bf gcmarkbit : 1; + unsigned spacer : 15; + union Lisp_Misc *chain; + }; + +/* To get the type field of a union Lisp_Misc, use XMISCTYPE. + It uses one of these struct subtypes to get the type field. */ + +union Lisp_Misc + { + struct Lisp_Misc_Any u_any; /* Supertype of all Misc types. */ + struct Lisp_Free u_free; + struct Lisp_Marker u_marker; + struct Lisp_Overlay u_overlay; + struct Lisp_Save_Value u_save_value; + struct Lisp_Finalizer u_finalizer; + }; + +INLINE union Lisp_Misc * +XMISC (Lisp_Object a) +{ + return XUNTAG (a, Lisp_Misc); +} + +INLINE struct Lisp_Misc_Any * +XMISCANY (Lisp_Object a) +{ + eassert (MISCP (a)); + return & XMISC (a)->u_any; +} + +INLINE enum Lisp_Misc_Type +XMISCTYPE (Lisp_Object a) +{ + return XMISCANY (a)->type; +} + +INLINE struct Lisp_Marker * +XMARKER (Lisp_Object a) +{ + eassert (MARKERP (a)); + return & XMISC (a)->u_marker; +} + +INLINE struct Lisp_Overlay * +XOVERLAY (Lisp_Object a) +{ + eassert (OVERLAYP (a)); + return & XMISC (a)->u_overlay; +} + +INLINE struct Lisp_Save_Value * +XSAVE_VALUE (Lisp_Object a) +{ + eassert (SAVE_VALUEP (a)); + return & XMISC (a)->u_save_value; +} + +INLINE struct Lisp_Finalizer * +XFINALIZER (Lisp_Object a) +{ + eassert (FINALIZERP (a)); + return & XMISC (a)->u_finalizer; +} + + +/* Forwarding pointer to an int variable. + This is allowed only in the value cell of a symbol, + and it means that the symbol's value really lives in the + specified int variable. */ +struct Lisp_Intfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Int */ + EMACS_INT *intvar; + }; + +/* Boolean forwarding pointer to an int variable. + This is like Lisp_Intfwd except that the ostensible + "value" of the symbol is t if the bool variable is true, + nil if it is false. */ +struct Lisp_Boolfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Bool */ + bool *boolvar; + }; + +/* Forwarding pointer to a Lisp_Object variable. + This is allowed only in the value cell of a symbol, + and it means that the symbol's value really lives in the + specified variable. */ +struct Lisp_Objfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Obj */ + Lisp_Object *objvar; + }; + +/* Like Lisp_Objfwd except that value lives in a slot in the + current buffer. Value is byte index of slot within buffer. */ +struct Lisp_Buffer_Objfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Buffer_Obj */ + int offset; + /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp or Qnumberp. */ + Lisp_Object predicate; + }; + +/* struct Lisp_Buffer_Local_Value is used in a symbol value cell when + the symbol has buffer-local or frame-local bindings. (Exception: + some buffer-local variables are built-in, with their values stored + in the buffer structure itself. They are handled differently, + using struct Lisp_Buffer_Objfwd.) + + The `realvalue' slot holds the variable's current value, or a + forwarding pointer to where that value is kept. This value is the + one that corresponds to the loaded binding. To read or set the + variable, you must first make sure the right binding is loaded; + then you can access the value in (or through) `realvalue'. + + `buffer' and `frame' are the buffer and frame for which the loaded + binding was found. If those have changed, to make sure the right + binding is loaded it is necessary to find which binding goes with + the current buffer and selected frame, then load it. To load it, + first unload the previous binding, then copy the value of the new + binding into `realvalue' (or through it). Also update + LOADED-BINDING to point to the newly loaded binding. + + `local_if_set' indicates that merely setting the variable creates a + local binding for the current buffer. Otherwise the latter, setting + the variable does not do that; only make-local-variable does that. */ + +struct Lisp_Buffer_Local_Value + { + /* True means that merely setting the variable creates a local + binding for the current buffer. */ + bool_bf local_if_set : 1; + /* True means this variable can have frame-local bindings, otherwise, it is + can have buffer-local bindings. The two cannot be combined. */ + bool_bf frame_local : 1; + /* True means that the binding now loaded was found. + Presumably equivalent to (defcell!=valcell). */ + bool_bf found : 1; + /* If non-NULL, a forwarding to the C var where it should also be set. */ + union Lisp_Fwd *fwd; /* Should never be (Buffer|Kboard)_Objfwd. */ + /* The buffer or frame for which the loaded binding was found. */ + Lisp_Object where; + /* A cons cell that holds the default value. It has the form + (SYMBOL . DEFAULT-VALUE). */ + Lisp_Object defcell; + /* The cons cell from `where's parameter alist. + It always has the form (SYMBOL . VALUE) + Note that if `forward' is non-nil, VALUE may be out of date. + Also if the currently loaded binding is the default binding, then + this is `eq'ual to defcell. */ + Lisp_Object valcell; + }; + +/* Like Lisp_Objfwd except that value lives in a slot in the + current kboard. */ +struct Lisp_Kboard_Objfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Kboard_Obj */ + int offset; + }; + +union Lisp_Fwd + { + struct Lisp_Intfwd u_intfwd; + struct Lisp_Boolfwd u_boolfwd; + struct Lisp_Objfwd u_objfwd; + struct Lisp_Buffer_Objfwd u_buffer_objfwd; + struct Lisp_Kboard_Objfwd u_kboard_objfwd; + }; + +INLINE enum Lisp_Fwd_Type +XFWDTYPE (union Lisp_Fwd *a) +{ + return a->u_intfwd.type; +} + +INLINE struct Lisp_Buffer_Objfwd * +XBUFFER_OBJFWD (union Lisp_Fwd *a) +{ + eassert (BUFFER_OBJFWDP (a)); + return &a->u_buffer_objfwd; +} + +/* Lisp floating point type. */ +struct Lisp_Float + { + union + { + double data; + struct Lisp_Float *chain; + } u; + }; + +INLINE double +XFLOAT_DATA (Lisp_Object f) +{ + return XFLOAT (f)->u.data; +} + +/* Most hosts nowadays use IEEE floating point, so they use IEC 60559 + representations, have infinities and NaNs, and do not trap on + exceptions. Define IEEE_FLOATING_POINT if this host is one of the + typical ones. The C11 macro __STDC_IEC_559__ is close to what is + wanted here, but is not quite right because Emacs does not require + all the features of C11 Annex F (and does not require C11 at all, + for that matter). */ +enum + { + IEEE_FLOATING_POINT + = (FLT_RADIX == 2 && FLT_MANT_DIG == 24 + && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) + }; + +/* A character, declared with the following typedef, is a member + of some character set associated with the current buffer. */ +#ifndef _UCHAR_T /* Protect against something in ctab.h on AIX. */ +#define _UCHAR_T +typedef unsigned char UCHAR; +#endif + +/* Meanings of slots in a Lisp_Compiled: */ + +enum Lisp_Compiled + { + COMPILED_ARGLIST = 0, + COMPILED_BYTECODE = 1, + COMPILED_CONSTANTS = 2, + COMPILED_STACK_DEPTH = 3, + COMPILED_DOC_STRING = 4, + COMPILED_INTERACTIVE = 5 + }; + +/* Flag bits in a character. These also get used in termhooks.h. + Richard Stallman <rms@gnu.ai.mit.edu> thinks that MULE + (MUlti-Lingual Emacs) might need 22 bits for the character value + itself, so we probably shouldn't use any bits lower than 0x0400000. */ +enum char_bits + { + CHAR_ALT = 0x0400000, + CHAR_SUPER = 0x0800000, + CHAR_HYPER = 0x1000000, + CHAR_SHIFT = 0x2000000, + CHAR_CTL = 0x4000000, + CHAR_META = 0x8000000, + + CHAR_MODIFIER_MASK = + CHAR_ALT | CHAR_SUPER | CHAR_HYPER | CHAR_SHIFT | CHAR_CTL | CHAR_META, + + /* Actually, the current Emacs uses 22 bits for the character value + itself. */ + CHARACTERBITS = 22 + }; + +/* Data type checking. */ + +LISP_MACRO_DEFUN (NILP, bool, (Lisp_Object x), (x)) + +INLINE bool +NUMBERP (Lisp_Object x) +{ + return INTEGERP (x) || FLOATP (x); +} +INLINE bool +NATNUMP (Lisp_Object x) +{ + return INTEGERP (x) && 0 <= XINT (x); +} + +INLINE bool +RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t hi) +{ + return INTEGERP (x) && lo <= XINT (x) && XINT (x) <= hi; +} + +#define TYPE_RANGED_INTEGERP(type, x) \ + (INTEGERP (x) \ + && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XINT (x) : 0 <= XINT (x)) \ + && XINT (x) <= TYPE_MAXIMUM (type)) + +LISP_MACRO_DEFUN (CONSP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (FLOATP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (MISCP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (SYMBOLP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (INTEGERP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (VECTORLIKEP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (MARKERP, bool, (Lisp_Object x), (x)) + +INLINE bool +STRINGP (Lisp_Object x) +{ + return XTYPE (x) == Lisp_String; +} +INLINE bool +VECTORP (Lisp_Object x) +{ + return VECTORLIKEP (x) && ! (ASIZE (x) & PSEUDOVECTOR_FLAG); +} +INLINE bool +OVERLAYP (Lisp_Object x) +{ + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay; +} +INLINE bool +SAVE_VALUEP (Lisp_Object x) +{ + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value; +} + +INLINE bool +FINALIZERP (Lisp_Object x) +{ + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer; +} + +INLINE bool +AUTOLOADP (Lisp_Object x) +{ + return CONSP (x) && EQ (Qautoload, XCAR (x)); +} + +INLINE bool +BUFFER_OBJFWDP (union Lisp_Fwd *a) +{ + return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj; +} + +INLINE bool +PSEUDOVECTOR_TYPEP (struct vectorlike_header *a, int code) +{ + return ((a->size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) + == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); +} + +/* True if A is a pseudovector whose code is CODE. */ +INLINE bool +PSEUDOVECTORP (Lisp_Object a, int code) +{ + if (! VECTORLIKEP (a)) + return false; + else + { + /* Converting to struct vectorlike_header * avoids aliasing issues. */ + struct vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike); + return PSEUDOVECTOR_TYPEP (h, code); + } +} + + +/* Test for specific pseudovector types. */ + +INLINE bool +WINDOW_CONFIGURATIONP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_WINDOW_CONFIGURATION); +} + +INLINE bool +PROCESSP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_PROCESS); +} + +INLINE bool +WINDOWP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_WINDOW); +} + +INLINE bool +TERMINALP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_TERMINAL); +} + +INLINE bool +SUBRP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_SUBR); +} + +INLINE bool +COMPILEDP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_COMPILED); +} + +INLINE bool +BUFFERP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_BUFFER); +} + +INLINE bool +CHAR_TABLE_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_CHAR_TABLE); +} + +INLINE bool +SUB_CHAR_TABLE_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_SUB_CHAR_TABLE); +} + +INLINE bool +BOOL_VECTOR_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_BOOL_VECTOR); +} + +INLINE bool +FRAMEP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_FRAME); +} + +/* Test for image (image . spec) */ +INLINE bool +IMAGEP (Lisp_Object x) +{ + return CONSP (x) && EQ (XCAR (x), Qimage); +} + +/* Array types. */ +INLINE bool +ARRAYP (Lisp_Object x) +{ + return VECTORP (x) || STRINGP (x) || CHAR_TABLE_P (x) || BOOL_VECTOR_P (x); +} + +INLINE void +CHECK_LIST (Lisp_Object x) +{ + CHECK_TYPE (CONSP (x) || NILP (x), Qlistp, x); +} + +LISP_MACRO_DEFUN_VOID (CHECK_LIST_CONS, (Lisp_Object x, Lisp_Object y), (x, y)) +LISP_MACRO_DEFUN_VOID (CHECK_SYMBOL, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN_VOID (CHECK_NUMBER, (Lisp_Object x), (x)) + +INLINE void +CHECK_STRING (Lisp_Object x) +{ + CHECK_TYPE (STRINGP (x), Qstringp, x); +} +INLINE void +CHECK_STRING_CAR (Lisp_Object x) +{ + CHECK_TYPE (STRINGP (XCAR (x)), Qstringp, XCAR (x)); +} +INLINE void +CHECK_CONS (Lisp_Object x) +{ + CHECK_TYPE (CONSP (x), Qconsp, x); +} +INLINE void +CHECK_VECTOR (Lisp_Object x) +{ + CHECK_TYPE (VECTORP (x), Qvectorp, x); +} +INLINE void +CHECK_BOOL_VECTOR (Lisp_Object x) +{ + CHECK_TYPE (BOOL_VECTOR_P (x), Qbool_vector_p, x); +} +/* This is a bit special because we always need size afterwards. */ +INLINE ptrdiff_t +CHECK_VECTOR_OR_STRING (Lisp_Object x) +{ + if (VECTORP (x)) + return ASIZE (x); + if (STRINGP (x)) + return SCHARS (x); + wrong_type_argument (Qarrayp, x); +} +INLINE void +CHECK_ARRAY (Lisp_Object x, Lisp_Object predicate) +{ + CHECK_TYPE (ARRAYP (x), predicate, x); +} +INLINE void +CHECK_BUFFER (Lisp_Object x) +{ + CHECK_TYPE (BUFFERP (x), Qbufferp, x); +} +INLINE void +CHECK_WINDOW (Lisp_Object x) +{ + CHECK_TYPE (WINDOWP (x), Qwindowp, x); +} +#ifdef subprocesses +INLINE void +CHECK_PROCESS (Lisp_Object x) +{ + CHECK_TYPE (PROCESSP (x), Qprocessp, x); +} +#endif +INLINE void +CHECK_NATNUM (Lisp_Object x) +{ + CHECK_TYPE (NATNUMP (x), Qwholenump, x); +} + +#define CHECK_RANGED_INTEGER(x, lo, hi) \ + do { \ + CHECK_NUMBER (x); \ + if (! ((lo) <= XINT (x) && XINT (x) <= (hi))) \ + args_out_of_range_3 \ + (x, \ + make_number ((lo) < 0 && (lo) < MOST_NEGATIVE_FIXNUM \ + ? MOST_NEGATIVE_FIXNUM \ + : (lo)), \ + make_number (min (hi, MOST_POSITIVE_FIXNUM))); \ + } while (false) +#define CHECK_TYPE_RANGED_INTEGER(type, x) \ + do { \ + if (TYPE_SIGNED (type)) \ + CHECK_RANGED_INTEGER (x, TYPE_MINIMUM (type), TYPE_MAXIMUM (type)); \ + else \ + CHECK_RANGED_INTEGER (x, 0, TYPE_MAXIMUM (type)); \ + } while (false) + +#define CHECK_NUMBER_COERCE_MARKER(x) \ + do { \ + if (MARKERP ((x))) \ + XSETFASTINT (x, marker_position (x)); \ + else \ + CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x); \ + } while (false) + +INLINE double +XFLOATINT (Lisp_Object n) +{ + return extract_float (n); +} + +INLINE void +CHECK_NUMBER_OR_FLOAT (Lisp_Object x) +{ + CHECK_TYPE (FLOATP (x) || INTEGERP (x), Qnumberp, x); +} + +#define CHECK_NUMBER_OR_FLOAT_COERCE_MARKER(x) \ + do { \ + if (MARKERP (x)) \ + XSETFASTINT (x, marker_position (x)); \ + else \ + CHECK_TYPE (INTEGERP (x) || FLOATP (x), Qnumber_or_marker_p, x); \ + } while (false) + +/* Since we can't assign directly to the CAR or CDR fields of a cons + cell, use these when checking that those fields contain numbers. */ +INLINE void +CHECK_NUMBER_CAR (Lisp_Object x) +{ + Lisp_Object tmp = XCAR (x); + CHECK_NUMBER (tmp); + XSETCAR (x, tmp); +} + +INLINE void +CHECK_NUMBER_CDR (Lisp_Object x) +{ + Lisp_Object tmp = XCDR (x); + CHECK_NUMBER (tmp); + XSETCDR (x, tmp); +} + +/* Define a built-in function for calling from Lisp. + `lname' should be the name to give the function in Lisp, + as a null-terminated C string. + `fnname' should be the name of the function in C. + By convention, it starts with F. + `sname' should be the name for the C constant structure + that records information on this function for internal use. + By convention, it should be the same as `fnname' but with S instead of F. + It's too bad that C macros can't compute this from `fnname'. + `minargs' should be a number, the minimum number of arguments allowed. + `maxargs' should be a number, the maximum number of arguments allowed, + or else MANY or UNEVALLED. + MANY means pass a vector of evaluated arguments, + in the form of an integer number-of-arguments + followed by the address of a vector of Lisp_Objects + which contains the argument values. + UNEVALLED means pass the list of unevaluated arguments + `intspec' says how interactive arguments are to be fetched. + If the string starts with a `(', `intspec' is evaluated and the resulting + list is the list of arguments. + If it's a string that doesn't start with `(', the value should follow + the one of the doc string for `interactive'. + A null string means call interactively with no arguments. + `doc' is documentation for the user. */ + +/* This version of DEFUN declares a function prototype with the right + arguments, so we can catch errors with maxargs at compile-time. */ +#ifdef _MSC_VER +#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ + Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \ + static struct Lisp_Subr alignas (GCALIGNMENT) sname = \ + { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \ + | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \ + { (Lisp_Object (__cdecl *)(void))fnname }, \ + minargs, maxargs, lname, intspec, 0}; \ + Lisp_Object fnname +#else /* not _MSC_VER */ +#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ + static struct Lisp_Subr alignas (GCALIGNMENT) sname = \ + { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ + { .a ## maxargs = fnname }, \ + minargs, maxargs, lname, intspec, 0}; \ + Lisp_Object fnname +#endif + +/* True if OBJ is a Lisp function. */ +INLINE bool +FUNCTIONP (Lisp_Object obj) +{ + return functionp (obj); +} + +/* defsubr (Sname); + is how we define the symbol for function `name' at start-up time. */ +extern void defsubr (struct Lisp_Subr *); + +enum maxargs + { + MANY = -2, + UNEVALLED = -1 + }; + +/* Call a function F that accepts many args, passing it ARRAY's elements. */ +#define CALLMANY(f, array) (f) (ARRAYELTS (array), array) + +/* Call a function F that accepts many args, passing it the remaining args, + E.g., 'return CALLN (Fformat, fmt, text);' is less error-prone than + '{ Lisp_Object a[2]; a[0] = fmt; a[1] = text; return Fformat (2, a); }'. + CALLN is overkill for simple usages like 'Finsert (1, &text);'. */ +#define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__})) + +extern void defvar_lisp (struct Lisp_Objfwd *, const char *, Lisp_Object *); +extern void defvar_lisp_nopro (struct Lisp_Objfwd *, const char *, Lisp_Object *); +extern void defvar_bool (struct Lisp_Boolfwd *, const char *, bool *); +extern void defvar_int (struct Lisp_Intfwd *, const char *, EMACS_INT *); +extern void defvar_kboard (struct Lisp_Kboard_Objfwd *, const char *, int); + +/* Macros we use to define forwarded Lisp variables. + These are used in the syms_of_FILENAME functions. + + An ordinary (not in buffer_defaults, per-buffer, or per-keyboard) + lisp variable is actually a field in `struct emacs_globals'. The + field's name begins with "f_", which is a convention enforced by + these macros. Each such global has a corresponding #define in + globals.h; the plain name should be used in the code. + + E.g., the global "cons_cells_consed" is declared as "int + f_cons_cells_consed" in globals.h, but there is a define: + + #define cons_cells_consed globals.f_cons_cells_consed + + All C code uses the `cons_cells_consed' name. This is all done + this way to support indirection for multi-threaded Emacs. */ + +#define DEFVAR_LISP(lname, vname, doc) \ + do { \ + static struct Lisp_Objfwd o_fwd; \ + defvar_lisp (&o_fwd, lname, &globals.f_ ## vname); \ + } while (false) +#define DEFVAR_LISP_NOPRO(lname, vname, doc) \ + do { \ + static struct Lisp_Objfwd o_fwd; \ + defvar_lisp_nopro (&o_fwd, lname, &globals.f_ ## vname); \ + } while (false) +#define DEFVAR_BOOL(lname, vname, doc) \ + do { \ + static struct Lisp_Boolfwd b_fwd; \ + defvar_bool (&b_fwd, lname, &globals.f_ ## vname); \ + } while (false) +#define DEFVAR_INT(lname, vname, doc) \ + do { \ + static struct Lisp_Intfwd i_fwd; \ + defvar_int (&i_fwd, lname, &globals.f_ ## vname); \ + } while (false) + +#define DEFVAR_BUFFER_DEFAULTS(lname, vname, doc) \ + do { \ + static struct Lisp_Objfwd o_fwd; \ + defvar_lisp_nopro (&o_fwd, lname, &BVAR (&buffer_defaults, vname)); \ + } while (false) + +#define DEFVAR_KBOARD(lname, vname, doc) \ + do { \ + static struct Lisp_Kboard_Objfwd ko_fwd; \ + defvar_kboard (&ko_fwd, lname, offsetof (KBOARD, vname ## _)); \ + } while (false) + +/* Save and restore the instruction and environment pointers, + without affecting the signal mask. */ + +#ifdef HAVE__SETJMP +typedef jmp_buf sys_jmp_buf; +# define sys_setjmp(j) _setjmp (j) +# define sys_longjmp(j, v) _longjmp (j, v) +#elif defined HAVE_SIGSETJMP +typedef sigjmp_buf sys_jmp_buf; +# define sys_setjmp(j) sigsetjmp (j, 0) +# define sys_longjmp(j, v) siglongjmp (j, v) +#else +/* A platform that uses neither _longjmp nor siglongjmp; assume + longjmp does not affect the sigmask. */ +typedef jmp_buf sys_jmp_buf; +# define sys_setjmp(j) setjmp (j) +# define sys_longjmp(j, v) longjmp (j, v) +#endif + + +/* Elisp uses several stacks: + - the C stack. + - the bytecode stack: used internally by the bytecode interpreter. + Allocated from the C stack. + - The specpdl stack: keeps track of active unwind-protect and + dynamic-let-bindings. Allocated from the `specpdl' array, a manually + managed stack. + - The handler stack: keeps track of active catch tags and condition-case + handlers. Allocated in a manually managed stack implemented by a + doubly-linked list allocated via xmalloc and never freed. */ + +/* Structure for recording Lisp call stack for backtrace purposes. */ + +/* The special binding stack holds the outer values of variables while + they are bound by a function application or a let form, stores the + code to be executed for unwind-protect forms. + + NOTE: The specbinding union is defined here, because SPECPDL_INDEX is + used all over the place, needs to be fast, and needs to know the size of + union specbinding. But only eval.c should access it. */ + +enum specbind_tag { + SPECPDL_UNWIND, /* An unwind_protect function on Lisp_Object. */ + SPECPDL_UNWIND_PTR, /* Likewise, on void *. */ + SPECPDL_UNWIND_INT, /* Likewise, on int. */ + SPECPDL_UNWIND_VOID, /* Likewise, with no arg. */ + SPECPDL_BACKTRACE, /* An element of the backtrace. */ + SPECPDL_LET, /* A plain and simple dynamic let-binding. */ + /* Tags greater than SPECPDL_LET must be "subkinds" of LET. */ + SPECPDL_LET_LOCAL, /* A buffer-local let-binding. */ + SPECPDL_LET_DEFAULT /* A global binding for a localized var. */ +}; + +union specbinding + { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + void (*func) (Lisp_Object); + Lisp_Object arg; + } unwind; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + void (*func) (void *); + void *arg; + } unwind_ptr; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + void (*func) (int); + int arg; + } unwind_int; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + void (*func) (void); + } unwind_void; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + /* `where' is not used in the case of SPECPDL_LET. */ + Lisp_Object symbol, old_value, where; + } let; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + bool_bf debug_on_exit : 1; + Lisp_Object function; + Lisp_Object *args; + ptrdiff_t nargs; + } bt; + }; + +extern union specbinding *specpdl; +extern union specbinding *specpdl_ptr; +extern ptrdiff_t specpdl_size; + +INLINE ptrdiff_t +SPECPDL_INDEX (void) +{ + return specpdl_ptr - specpdl; +} + +/* This structure helps implement the `catch/throw' and `condition-case/signal' + control structures. A struct handler contains all the information needed to + restore the state of the interpreter after a non-local jump. + + handler structures are chained together in a doubly linked list; the `next' + member points to the next outer catchtag and the `nextfree' member points in + the other direction to the next inner element (which is typically the next + free element since we mostly use it on the deepest handler). + + A call like (throw TAG VAL) searches for a catchtag whose `tag_or_ch' + member is TAG, and then unbinds to it. The `val' member is used to + hold VAL while the stack is unwound; `val' is returned as the value + of the catch form. + + All the other members are concerned with restoring the interpreter + state. + + Members are volatile if their values need to survive _longjmp when + a 'struct handler' is a local variable. */ + +enum handlertype { CATCHER, CONDITION_CASE }; + +struct handler +{ + enum handlertype type; + Lisp_Object tag_or_ch; + Lisp_Object val; + struct handler *next; + struct handler *nextfree; + + /* The bytecode interpreter can have several handlers active at the same + time, so when we longjmp to one of them, it needs to know which handler + this was and what was the corresponding internal state. This is stored + here, and when we longjmp we make sure that handlerlist points to the + proper handler. */ + Lisp_Object *bytecode_top; + int bytecode_dest; + + /* Most global vars are reset to their value via the specpdl mechanism, + but a few others are handled by storing their value here. */ +#if true /* GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS, but defined later. */ + struct gcpro *gcpro; +#endif + sys_jmp_buf jmp; + EMACS_INT lisp_eval_depth; + ptrdiff_t pdlcount; + int poll_suppress_count; + int interrupt_input_blocked; + struct byte_stack *byte_stack; +}; + +/* Fill in the components of c, and put it on the list. */ +#define PUSH_HANDLER(c, tag_ch_val, handlertype) \ + if (handlerlist->nextfree) \ + (c) = handlerlist->nextfree; \ + else \ + { \ + (c) = xmalloc (sizeof (struct handler)); \ + (c)->nextfree = NULL; \ + handlerlist->nextfree = (c); \ + } \ + (c)->type = (handlertype); \ + (c)->tag_or_ch = (tag_ch_val); \ + (c)->val = Qnil; \ + (c)->next = handlerlist; \ + (c)->lisp_eval_depth = lisp_eval_depth; \ + (c)->pdlcount = SPECPDL_INDEX (); \ + (c)->poll_suppress_count = poll_suppress_count; \ + (c)->interrupt_input_blocked = interrupt_input_blocked;\ + (c)->gcpro = gcprolist; \ + (c)->byte_stack = byte_stack_list; \ + handlerlist = (c); + + +extern Lisp_Object memory_signal_data; + +/* An address near the bottom of the stack. + Tells GC how to save a copy of the stack. */ +extern char *stack_bottom; + +/* Check quit-flag and quit if it is non-nil. + Typing C-g does not directly cause a quit; it only sets Vquit_flag. + So the program needs to do QUIT at times when it is safe to quit. + Every loop that might run for a long time or might not exit + ought to do QUIT at least once, at a safe place. + Unless that is impossible, of course. + But it is very desirable to avoid creating loops where QUIT is impossible. + + Exception: if you set immediate_quit to true, + then the handler that responds to the C-g does the quit itself. + This is a good thing to do around a loop that has no side effects + and (in particular) cannot call arbitrary Lisp code. + + If quit-flag is set to `kill-emacs' the SIGINT handler has received + a request to exit Emacs when it is safe to do. */ + +extern void process_pending_signals (void); +extern bool volatile pending_signals; + +extern void process_quit_flag (void); +#define QUIT \ + do { \ + if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \ + process_quit_flag (); \ + else if (pending_signals) \ + process_pending_signals (); \ + } while (false) + + +/* True if ought to quit now. */ + +#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) + +extern Lisp_Object Vascii_downcase_table; +extern Lisp_Object Vascii_canon_table; + +/* Structure for recording stack slots that need marking. */ + +/* This is a chain of structures, each of which points at a Lisp_Object + variable whose value should be marked in garbage collection. + Normally every link of the chain is an automatic variable of a function, + and its `val' points to some argument or local variable of the function. + On exit to the function, the chain is set back to the value it had on entry. + This way, no link remains in the chain when the stack frame containing the + link disappears. + + Every function that can call Feval must protect in this fashion all + Lisp_Object variables whose contents will be used again. */ + +extern struct gcpro *gcprolist; + +struct gcpro +{ + struct gcpro *next; + + /* Address of first protected variable. */ + volatile Lisp_Object *var; + + /* Number of consecutive protected variables. */ + ptrdiff_t nvars; + +#ifdef DEBUG_GCPRO + /* File name where this record is used. */ + const char *name; + + /* Line number in this file. */ + int lineno; + + /* Index in the local chain of records. */ + int idx; + + /* Nesting level. */ + int level; +#endif +}; + +/* Values of GC_MARK_STACK during compilation: + + 0 Use GCPRO as before + 1 Do the real thing, make GCPROs and UNGCPRO no-ops. + 2 Mark the stack, and check that everything GCPRO'd is + marked. + 3 Mark using GCPRO's, mark stack last, and count how many + dead objects are kept alive. + + Formerly, method 0 was used. Currently, method 1 is used unless + otherwise specified by hand when building, e.g., + "make CPPFLAGS='-DGC_MARK_STACK=GC_USE_GCPROS_AS_BEFORE'". + Methods 2 and 3 are present mainly to debug the transition from 0 to 1. */ + +#define GC_USE_GCPROS_AS_BEFORE 0 +#define GC_MAKE_GCPROS_NOOPS 1 +#define GC_MARK_STACK_CHECK_GCPROS 2 +#define GC_USE_GCPROS_CHECK_ZOMBIES 3 + +#ifndef GC_MARK_STACK +#define GC_MARK_STACK GC_MAKE_GCPROS_NOOPS +#endif + +/* Whether we do the stack marking manually. */ +#define BYTE_MARK_STACK !(GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) + + +#if GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS + +/* Do something silly with gcproN vars just so gcc shuts up. */ +/* You get warnings from MIPSPro... */ + +#define GCPRO1(varname) ((void) gcpro1) +#define GCPRO2(varname1, varname2) ((void) gcpro2, (void) gcpro1) +#define GCPRO3(varname1, varname2, varname3) \ + ((void) gcpro3, (void) gcpro2, (void) gcpro1) +#define GCPRO4(varname1, varname2, varname3, varname4) \ + ((void) gcpro4, (void) gcpro3, (void) gcpro2, (void) gcpro1) +#define GCPRO5(varname1, varname2, varname3, varname4, varname5) \ + ((void) gcpro5, (void) gcpro4, (void) gcpro3, (void) gcpro2, (void) gcpro1) +#define GCPRO6(varname1, varname2, varname3, varname4, varname5, varname6) \ + ((void) gcpro6, (void) gcpro5, (void) gcpro4, (void) gcpro3, (void) gcpro2, \ + (void) gcpro1) +#define GCPRO7(a, b, c, d, e, f, g) (GCPRO6 (a, b, c, d, e, f), (void) gcpro7) +#define UNGCPRO ((void) 0) + +#else /* GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS */ + +#ifndef DEBUG_GCPRO + +#define GCPRO1(a) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcprolist = &gcpro1; } + +#define GCPRO2(a, b) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcprolist = &gcpro2; } + +#define GCPRO3(a, b, c) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcprolist = &gcpro3; } + +#define GCPRO4(a, b, c, d) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcprolist = &gcpro4; } + +#define GCPRO5(a, b, c, d, e) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcprolist = &gcpro5; } + +#define GCPRO6(a, b, c, d, e, f) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1; \ + gcprolist = &gcpro6; } + +#define GCPRO7(a, b, c, d, e, f, g) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1; \ + gcpro7.next = &gcpro6; gcpro7.var = &(g); gcpro7.nvars = 1; \ + gcprolist = &gcpro7; } + +#define UNGCPRO (gcprolist = gcpro1.next) + +#else /* !DEBUG_GCPRO */ + +extern int gcpro_level; + +#define GCPRO1(a) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level++; \ + gcprolist = &gcpro1; } + +#define GCPRO2(a, b) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro2.level = gcpro_level++; \ + gcprolist = &gcpro2; } + +#define GCPRO3(a, b, c) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro3.level = gcpro_level++; \ + gcprolist = &gcpro3; } + +#define GCPRO4(a, b, c, d) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4; \ + gcpro4.level = gcpro_level++; \ + gcprolist = &gcpro4; } + +#define GCPRO5(a, b, c, d, e) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5; \ + gcpro5.level = gcpro_level++; \ + gcprolist = &gcpro5; } + +#define GCPRO6(a, b, c, d, e, f) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5; \ + gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1; \ + gcpro6.name = __FILE__; gcpro6.lineno = __LINE__; gcpro6.idx = 6; \ + gcpro6.level = gcpro_level++; \ + gcprolist = &gcpro6; } + +#define GCPRO7(a, b, c, d, e, f, g) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5; \ + gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1; \ + gcpro6.name = __FILE__; gcpro6.lineno = __LINE__; gcpro6.idx = 6; \ + gcpro7.next = &gcpro6; gcpro7.var = &(g); gcpro7.nvars = 1; \ + gcpro7.name = __FILE__; gcpro7.lineno = __LINE__; gcpro7.idx = 7; \ + gcpro7.level = gcpro_level++; \ + gcprolist = &gcpro7; } + +#define UNGCPRO \ + (--gcpro_level != gcpro1.level \ + ? emacs_abort () \ + : (void) (gcprolist = gcpro1.next)) + +#endif /* DEBUG_GCPRO */ +#endif /* GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS */ + + +/* Evaluate expr, UNGCPRO, and then return the value of expr. */ +#define RETURN_UNGCPRO(expr) \ + do \ + { \ + Lisp_Object ret_ungc_val; \ + ret_ungc_val = (expr); \ + UNGCPRO; \ + return ret_ungc_val; \ + } \ + while (false) + +/* Call staticpro (&var) to protect static variable `var'. */ + +void staticpro (Lisp_Object *); + +/* Forward declarations for prototypes. */ +struct window; +struct frame; + +/* Copy COUNT Lisp_Objects from ARGS to contents of V starting from OFFSET. */ + +INLINE void +vcopy (Lisp_Object v, ptrdiff_t offset, Lisp_Object *args, ptrdiff_t count) +{ + eassert (0 <= offset && 0 <= count && offset + count <= ASIZE (v)); + memcpy (XVECTOR (v)->contents + offset, args, count * sizeof *args); +} + +/* Functions to modify hash tables. */ + +INLINE void +set_hash_key_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val) +{ + gc_aset (h->key_and_value, 2 * idx, val); +} + +INLINE void +set_hash_value_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val) +{ + gc_aset (h->key_and_value, 2 * idx + 1, val); +} + +/* Use these functions to set Lisp_Object + or pointer slots of struct Lisp_Symbol. */ + +INLINE void +set_symbol_function (Lisp_Object sym, Lisp_Object function) +{ + XSYMBOL (sym)->function = function; +} + +INLINE void +set_symbol_plist (Lisp_Object sym, Lisp_Object plist) +{ + XSYMBOL (sym)->plist = plist; +} + +INLINE void +set_symbol_next (Lisp_Object sym, struct Lisp_Symbol *next) +{ + XSYMBOL (sym)->next = next; +} + +/* Buffer-local (also frame-local) variable access functions. */ + +INLINE int +blv_found (struct Lisp_Buffer_Local_Value *blv) +{ + eassert (blv->found == !EQ (blv->defcell, blv->valcell)); + return blv->found; +} + +/* Set overlay's property list. */ + +INLINE void +set_overlay_plist (Lisp_Object overlay, Lisp_Object plist) +{ + XOVERLAY (overlay)->plist = plist; +} + +/* Get text properties of S. */ + +INLINE INTERVAL +string_intervals (Lisp_Object s) +{ + return XSTRING (s)->intervals; +} + +/* Set text properties of S to I. */ + +INLINE void +set_string_intervals (Lisp_Object s, INTERVAL i) +{ + XSTRING (s)->intervals = i; +} + +/* Set a Lisp slot in TABLE to VAL. Most code should use this instead + of setting slots directly. */ + +INLINE void +set_char_table_defalt (Lisp_Object table, Lisp_Object val) +{ + XCHAR_TABLE (table)->defalt = val; +} +INLINE void +set_char_table_purpose (Lisp_Object table, Lisp_Object val) +{ + XCHAR_TABLE (table)->purpose = val; +} + +/* Set different slots in (sub)character tables. */ + +INLINE void +set_char_table_extras (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) +{ + eassert (0 <= idx && idx < CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (table))); + XCHAR_TABLE (table)->extras[idx] = val; +} + +INLINE void +set_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) +{ + eassert (0 <= idx && idx < (1 << CHARTAB_SIZE_BITS_0)); + XCHAR_TABLE (table)->contents[idx] = val; +} + +INLINE void +set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) +{ + XSUB_CHAR_TABLE (table)->contents[idx] = val; +} + +/* Defined in data.c. */ +extern Lisp_Object indirect_function (Lisp_Object); +extern Lisp_Object find_symbol_value (Lisp_Object); +enum Arith_Comparison { + ARITH_EQUAL, + ARITH_NOTEQUAL, + ARITH_LESS, + ARITH_GRTR, + ARITH_LESS_OR_EQUAL, + ARITH_GRTR_OR_EQUAL +}; +extern Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2, + enum Arith_Comparison comparison); + +/* Convert the integer I to an Emacs representation, either the integer + itself, or a cons of two or three integers, or if all else fails a float. + I should not have side effects. */ +#define INTEGER_TO_CONS(i) \ + (! FIXNUM_OVERFLOW_P (i) \ + ? make_number (i) \ + : ! ((FIXNUM_OVERFLOW_P (INTMAX_MIN >> 16) \ + || FIXNUM_OVERFLOW_P (UINTMAX_MAX >> 16)) \ + && FIXNUM_OVERFLOW_P ((i) >> 16)) \ + ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \ + : ! ((FIXNUM_OVERFLOW_P (INTMAX_MIN >> 16 >> 24) \ + || FIXNUM_OVERFLOW_P (UINTMAX_MAX >> 16 >> 24)) \ + && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \ + ? Fcons (make_number ((i) >> 16 >> 24), \ + Fcons (make_number ((i) >> 16 & 0xffffff), \ + make_number ((i) & 0xffff))) \ + : make_float (i)) + +/* Convert the Emacs representation CONS back to an integer of type + TYPE, storing the result the variable VAR. Signal an error if CONS + is not a valid representation or is out of range for TYPE. */ +#define CONS_TO_INTEGER(cons, type, var) \ + (TYPE_SIGNED (type) \ + ? ((var) = cons_to_signed (cons, TYPE_MINIMUM (type), TYPE_MAXIMUM (type))) \ + : ((var) = cons_to_unsigned (cons, TYPE_MAXIMUM (type)))) +extern intmax_t cons_to_signed (Lisp_Object, intmax_t, intmax_t); +extern uintmax_t cons_to_unsigned (Lisp_Object, uintmax_t); + +extern struct Lisp_Symbol *indirect_variable (struct Lisp_Symbol *); +extern _Noreturn void args_out_of_range (Lisp_Object, Lisp_Object); +extern _Noreturn void args_out_of_range_3 (Lisp_Object, Lisp_Object, + Lisp_Object); +extern Lisp_Object do_symval_forwarding (union Lisp_Fwd *); +extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object, bool); +extern void syms_of_data (void); +extern void swap_in_global_binding (struct Lisp_Symbol *); + +/* Defined in cmds.c */ +extern void syms_of_cmds (void); +extern void keys_of_cmds (void); + +/* Defined in coding.c. */ +extern Lisp_Object detect_coding_system (const unsigned char *, ptrdiff_t, + ptrdiff_t, bool, bool, Lisp_Object); +extern void init_coding (void); +extern void init_coding_once (void); +extern void syms_of_coding (void); + +/* Defined in character.c. */ +extern ptrdiff_t chars_in_text (const unsigned char *, ptrdiff_t); +extern ptrdiff_t multibyte_chars_in_text (const unsigned char *, ptrdiff_t); +extern void syms_of_character (void); + +/* Defined in charset.c. */ +extern void init_charset (void); +extern void init_charset_once (void); +extern void syms_of_charset (void); +/* Structure forward declarations. */ +struct charset; + +/* Defined in syntax.c. */ +extern void init_syntax_once (void); +extern void syms_of_syntax (void); + +/* Defined in fns.c. */ +enum { NEXT_ALMOST_PRIME_LIMIT = 11 }; +extern EMACS_INT next_almost_prime (EMACS_INT) ATTRIBUTE_CONST; +extern Lisp_Object larger_vector (Lisp_Object, ptrdiff_t, ptrdiff_t); +extern void sweep_weak_hash_tables (void); +EMACS_UINT hash_string (char const *, ptrdiff_t); +EMACS_UINT sxhash (Lisp_Object, int); +Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); +ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *); +ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object, + EMACS_UINT); +extern struct hash_table_test hashtest_eql, hashtest_equal; +extern void validate_subarray (Lisp_Object, Lisp_Object, Lisp_Object, + ptrdiff_t, ptrdiff_t *, ptrdiff_t *); +extern Lisp_Object substring_both (Lisp_Object, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t); +extern Lisp_Object merge (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object do_yes_or_no_p (Lisp_Object); +extern Lisp_Object concat2 (Lisp_Object, Lisp_Object); +extern Lisp_Object concat3 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object nconc2 (Lisp_Object, Lisp_Object); +extern Lisp_Object assq_no_quit (Lisp_Object, Lisp_Object); +extern Lisp_Object assoc_no_quit (Lisp_Object, Lisp_Object); +extern void clear_string_char_byte_cache (void); +extern ptrdiff_t string_char_to_byte (Lisp_Object, ptrdiff_t); +extern ptrdiff_t string_byte_to_char (Lisp_Object, ptrdiff_t); +extern Lisp_Object string_to_multibyte (Lisp_Object); +extern Lisp_Object string_make_unibyte (Lisp_Object); +extern void syms_of_fns (void); + +/* Defined in floatfns.c. */ +extern void syms_of_floatfns (void); +extern Lisp_Object fmod_float (Lisp_Object x, Lisp_Object y); + +/* Defined in fringe.c. */ +extern void syms_of_fringe (void); +extern void init_fringe (void); +#ifdef HAVE_WINDOW_SYSTEM +extern void mark_fringe_data (void); +extern void init_fringe_once (void); +#endif /* HAVE_WINDOW_SYSTEM */ + +/* Defined in image.c. */ +extern int x_bitmap_mask (struct frame *, ptrdiff_t); +extern void reset_image_types (void); +extern void syms_of_image (void); + +/* Defined in insdel.c. */ +extern void move_gap_both (ptrdiff_t, ptrdiff_t); +extern _Noreturn void buffer_overflow (void); +extern void make_gap (ptrdiff_t); +extern void make_gap_1 (struct buffer *, ptrdiff_t); +extern ptrdiff_t copy_text (const unsigned char *, unsigned char *, + ptrdiff_t, bool, bool); +extern int count_combining_before (const unsigned char *, + ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern int count_combining_after (const unsigned char *, + ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern void insert (const char *, ptrdiff_t); +extern void insert_and_inherit (const char *, ptrdiff_t); +extern void insert_1_both (const char *, ptrdiff_t, ptrdiff_t, + bool, bool, bool); +extern void insert_from_gap (ptrdiff_t, ptrdiff_t, bool text_at_gap_tail); +extern void insert_from_string (Lisp_Object, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t, bool); +extern void insert_from_buffer (struct buffer *, ptrdiff_t, ptrdiff_t, bool); +extern void insert_char (int); +extern void insert_string (const char *); +extern void insert_before_markers (const char *, ptrdiff_t); +extern void insert_before_markers_and_inherit (const char *, ptrdiff_t); +extern void insert_from_string_before_markers (Lisp_Object, ptrdiff_t, + ptrdiff_t, ptrdiff_t, + ptrdiff_t, bool); +extern void del_range (ptrdiff_t, ptrdiff_t); +extern Lisp_Object del_range_1 (ptrdiff_t, ptrdiff_t, bool, bool); +extern void del_range_byte (ptrdiff_t, ptrdiff_t, bool); +extern void del_range_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool); +extern Lisp_Object del_range_2 (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t, bool); +extern void modify_text (ptrdiff_t, ptrdiff_t); +extern void prepare_to_modify_buffer (ptrdiff_t, ptrdiff_t, ptrdiff_t *); +extern void prepare_to_modify_buffer_1 (ptrdiff_t, ptrdiff_t, ptrdiff_t *); +extern void invalidate_buffer_caches (struct buffer *, ptrdiff_t, ptrdiff_t); +extern void signal_after_change (ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern void adjust_after_insert (ptrdiff_t, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t); +extern void adjust_markers_for_delete (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t); +extern void replace_range (ptrdiff_t, ptrdiff_t, Lisp_Object, bool, bool, bool); +extern void replace_range_2 (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, + const char *, ptrdiff_t, ptrdiff_t, bool); +extern void syms_of_insdel (void); + +/* Defined in dispnew.c. */ +#if (defined PROFILING \ + && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__)) +_Noreturn void __executable_start (void); +#endif +extern Lisp_Object Vwindow_system; +extern Lisp_Object sit_for (Lisp_Object, bool, int); + +/* Defined in xdisp.c. */ +extern bool noninteractive_need_newline; +extern Lisp_Object echo_area_buffer[2]; +extern void add_to_log (const char *, Lisp_Object, Lisp_Object); +extern void check_message_stack (void); +extern void setup_echo_area_for_printing (bool); +extern bool push_message (void); +extern void pop_message_unwind (void); +extern Lisp_Object restore_message_unwind (Lisp_Object); +extern void restore_message (void); +extern Lisp_Object current_message (void); +extern void clear_message (bool, bool); +extern void message (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); +extern void message1 (const char *); +extern void message1_nolog (const char *); +extern void message3 (Lisp_Object); +extern void message3_nolog (Lisp_Object); +extern void message_dolog (const char *, ptrdiff_t, bool, bool); +extern void message_with_string (const char *, Lisp_Object, bool); +extern void message_log_maybe_newline (void); +extern void update_echo_area (void); +extern void truncate_echo_area (ptrdiff_t); +extern void redisplay (void); + +void set_frame_cursor_types (struct frame *, Lisp_Object); +extern void syms_of_xdisp (void); +extern void init_xdisp (void); +extern Lisp_Object safe_eval (Lisp_Object); +extern bool pos_visible_p (struct window *, ptrdiff_t, int *, + int *, int *, int *, int *, int *); + +/* Defined in xsettings.c. */ +extern void syms_of_xsettings (void); + +/* Defined in vm-limit.c. */ +extern void memory_warnings (void *, void (*warnfun) (const char *)); + +/* Defined in character.c. */ +extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t, + ptrdiff_t *, ptrdiff_t *); + +/* Defined in alloc.c. */ +extern void check_pure_size (void); +extern void free_misc (Lisp_Object); +extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT); +extern void malloc_warning (const char *); +extern _Noreturn void memory_full (size_t); +extern _Noreturn void buffer_memory_full (ptrdiff_t); +extern bool survives_gc_p (Lisp_Object); +extern void mark_object (Lisp_Object); +#if defined REL_ALLOC && !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC +extern void refill_memory_reserve (void); +#endif +extern const char *pending_malloc_warning; +extern Lisp_Object zero_vector; +extern Lisp_Object *stack_base; +extern EMACS_INT consing_since_gc; +extern EMACS_INT gc_relative_threshold; +extern EMACS_INT memory_full_cons_threshold; +extern Lisp_Object list1 (Lisp_Object); +extern Lisp_Object list2 (Lisp_Object, Lisp_Object); +extern Lisp_Object list3 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object list4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object list5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object); +enum constype {CONSTYPE_HEAP, CONSTYPE_PURE}; +extern Lisp_Object listn (enum constype, ptrdiff_t, Lisp_Object, ...); + +/* Build a frequently used 2/3/4-integer lists. */ + +INLINE Lisp_Object +list2i (EMACS_INT x, EMACS_INT y) +{ + return list2 (make_number (x), make_number (y)); +} + +INLINE Lisp_Object +list3i (EMACS_INT x, EMACS_INT y, EMACS_INT w) +{ + return list3 (make_number (x), make_number (y), make_number (w)); +} + +INLINE Lisp_Object +list4i (EMACS_INT x, EMACS_INT y, EMACS_INT w, EMACS_INT h) +{ + return list4 (make_number (x), make_number (y), + make_number (w), make_number (h)); +} + +extern Lisp_Object make_uninit_bool_vector (EMACS_INT); +extern Lisp_Object bool_vector_fill (Lisp_Object, Lisp_Object); +extern _Noreturn void string_overflow (void); +extern Lisp_Object make_string (const char *, ptrdiff_t); +extern Lisp_Object make_formatted_string (char *, const char *, ...) + ATTRIBUTE_FORMAT_PRINTF (2, 3); +extern Lisp_Object make_unibyte_string (const char *, ptrdiff_t); + +/* Make unibyte string from C string when the length isn't known. */ + +INLINE Lisp_Object +build_unibyte_string (const char *str) +{ + return make_unibyte_string (str, strlen (str)); +} + +extern Lisp_Object make_multibyte_string (const char *, ptrdiff_t, ptrdiff_t); +extern Lisp_Object make_event_array (ptrdiff_t, Lisp_Object *); +extern Lisp_Object make_uninit_string (EMACS_INT); +extern Lisp_Object make_uninit_multibyte_string (EMACS_INT, EMACS_INT); +extern Lisp_Object make_string_from_bytes (const char *, ptrdiff_t, ptrdiff_t); +extern Lisp_Object make_specified_string (const char *, + ptrdiff_t, ptrdiff_t, bool); +extern Lisp_Object make_pure_string (const char *, ptrdiff_t, ptrdiff_t, bool); +extern Lisp_Object make_pure_c_string (const char *, ptrdiff_t); + +/* Make a string allocated in pure space, use STR as string data. */ + +INLINE Lisp_Object +build_pure_c_string (const char *str) +{ + return make_pure_c_string (str, strlen (str)); +} + +/* Make a string from the data at STR, treating it as multibyte if the + data warrants. */ + +INLINE Lisp_Object +build_string (const char *str) +{ + return make_string (str, strlen (str)); +} + +extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); +extern void make_byte_code (struct Lisp_Vector *); +extern struct Lisp_Vector *allocate_vector (EMACS_INT); + +/* Make an uninitialized vector for SIZE objects. NOTE: you must + be sure that GC cannot happen until the vector is completely + initialized. E.g. the following code is likely to crash: + + v = make_uninit_vector (3); + ASET (v, 0, obj0); + ASET (v, 1, Ffunction_can_gc ()); + ASET (v, 2, obj1); */ + +INLINE Lisp_Object +make_uninit_vector (ptrdiff_t size) +{ + Lisp_Object v; + struct Lisp_Vector *p; + + p = allocate_vector (size); + XSETVECTOR (v, p); + return v; +} + +/* Like above, but special for sub char-tables. */ + +INLINE Lisp_Object +make_uninit_sub_char_table (int depth, int min_char) +{ + int slots = SUB_CHAR_TABLE_OFFSET + chartab_size[depth]; + Lisp_Object v = make_uninit_vector (slots); + + XSETPVECTYPE (XVECTOR (v), PVEC_SUB_CHAR_TABLE); + XSUB_CHAR_TABLE (v)->depth = depth; + XSUB_CHAR_TABLE (v)->min_char = min_char; + return v; +} + +extern struct Lisp_Vector *allocate_pseudovector (int, int, int, + enum pvec_type); + +/* Allocate partially initialized pseudovector where all Lisp_Object + slots are set to Qnil but the rest (if any) is left uninitialized. */ + +#define ALLOCATE_PSEUDOVECTOR(type, field, tag) \ + ((type *) allocate_pseudovector (VECSIZE (type), \ + PSEUDOVECSIZE (type, field), \ + PSEUDOVECSIZE (type, field), tag)) + +/* Allocate fully initialized pseudovector where all Lisp_Object + slots are set to Qnil and the rest (if any) is zeroed. */ + +#define ALLOCATE_ZEROED_PSEUDOVECTOR(type, field, tag) \ + ((type *) allocate_pseudovector (VECSIZE (type), \ + PSEUDOVECSIZE (type, field), \ + VECSIZE (type), tag)) + +extern bool gc_in_progress; +extern bool abort_on_gc; +extern Lisp_Object make_float (double); +extern void display_malloc_warning (void); +extern ptrdiff_t inhibit_garbage_collection (void); +extern Lisp_Object make_save_int_int_int (ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern Lisp_Object make_save_obj_obj_obj_obj (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); +extern Lisp_Object make_save_ptr (void *); +extern Lisp_Object make_save_ptr_int (void *, ptrdiff_t); +extern Lisp_Object make_save_ptr_ptr (void *, void *); +extern Lisp_Object make_save_funcptr_ptr_obj (void (*) (void), void *, + Lisp_Object); +extern Lisp_Object make_save_memory (Lisp_Object *, ptrdiff_t); +extern void free_save_value (Lisp_Object); +extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); +extern void free_marker (Lisp_Object); +extern void free_cons (struct Lisp_Cons *); +extern void init_alloc_once (void); +extern void init_alloc (void); +extern void syms_of_alloc (void); +extern struct buffer * allocate_buffer (void); +extern int valid_lisp_object_p (Lisp_Object); +extern int relocatable_string_data_p (const char *); +#ifdef GC_CHECK_CONS_LIST +extern void check_cons_list (void); +#else +INLINE void (check_cons_list) (void) { lisp_h_check_cons_list (); } +#endif + +#ifdef REL_ALLOC +/* Defined in ralloc.c. */ +extern void *r_alloc (void **, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); +extern void r_alloc_free (void **); +extern void *r_re_alloc (void **, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); +extern void r_alloc_reset_variable (void **, void **); +extern void r_alloc_inhibit_buffer_relocation (int); +#endif + +/* Defined in chartab.c. */ +extern Lisp_Object copy_char_table (Lisp_Object); +extern Lisp_Object char_table_ref_and_range (Lisp_Object, int, + int *, int *); +extern void char_table_set_range (Lisp_Object, int, int, Lisp_Object); +extern void map_char_table (void (*) (Lisp_Object, Lisp_Object, + Lisp_Object), + Lisp_Object, Lisp_Object, Lisp_Object); +extern void map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object), + Lisp_Object, Lisp_Object, + Lisp_Object, struct charset *, + unsigned, unsigned); +extern Lisp_Object uniprop_table (Lisp_Object); +extern void syms_of_chartab (void); + +/* Defined in print.c. */ +extern Lisp_Object Vprin1_to_string_buffer; +extern void debug_print (Lisp_Object) EXTERNALLY_VISIBLE; +extern void temp_output_buffer_setup (const char *); +extern int print_level; +extern void write_string (const char *); +extern void print_error_message (Lisp_Object, Lisp_Object, const char *, + Lisp_Object); +extern Lisp_Object internal_with_output_to_temp_buffer + (const char *, Lisp_Object (*) (Lisp_Object), Lisp_Object); +#define FLOAT_TO_STRING_BUFSIZE 350 +extern int float_to_string (char *, double); +extern void init_print_once (void); +extern void syms_of_print (void); + +/* Defined in doprnt.c. */ +extern ptrdiff_t doprnt (char *, ptrdiff_t, const char *, const char *, + va_list); +extern ptrdiff_t esprintf (char *, char const *, ...) + ATTRIBUTE_FORMAT_PRINTF (2, 3); +extern ptrdiff_t exprintf (char **, ptrdiff_t *, char const *, ptrdiff_t, + char const *, ...) + ATTRIBUTE_FORMAT_PRINTF (5, 6); +extern ptrdiff_t evxprintf (char **, ptrdiff_t *, char const *, ptrdiff_t, + char const *, va_list) + ATTRIBUTE_FORMAT_PRINTF (5, 0); + +/* Defined in lread.c. */ +extern Lisp_Object check_obarray (Lisp_Object); +extern Lisp_Object intern_1 (const char *, ptrdiff_t); +extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t); +extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object); +extern void init_symbol (Lisp_Object, Lisp_Object); +extern Lisp_Object oblookup (Lisp_Object, const char *, ptrdiff_t, ptrdiff_t); +INLINE void +LOADHIST_ATTACH (Lisp_Object x) +{ + if (initialized) + Vcurrent_load_list = Fcons (x, Vcurrent_load_list); +} +extern int openp (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object *, Lisp_Object, bool); +extern Lisp_Object string_to_number (char const *, int, bool); +extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object), + Lisp_Object); +extern void dir_warning (const char *, Lisp_Object); +extern void init_obarray (void); +extern void init_lread (void); +extern void syms_of_lread (void); + +INLINE Lisp_Object +intern (const char *str) +{ + return intern_1 (str, strlen (str)); +} + +INLINE Lisp_Object +intern_c_string (const char *str) +{ + return intern_c_string_1 (str, strlen (str)); +} + +/* Defined in eval.c. */ +extern EMACS_INT lisp_eval_depth; +extern Lisp_Object Vautoload_queue; +extern Lisp_Object Vrun_hooks; +extern Lisp_Object Vsignaling_function; +extern Lisp_Object inhibit_lisp_code; +extern struct handler *handlerlist; + +/* To run a normal hook, use the appropriate function from the list below. + The calling convention: + + if (!NILP (Vrun_hooks)) + call1 (Vrun_hooks, Qmy_funny_hook); + + should no longer be used. */ +extern void run_hook (Lisp_Object); +extern void run_hook_with_args_2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args, + Lisp_Object (*funcall) + (ptrdiff_t nargs, Lisp_Object *args)); +extern _Noreturn void xsignal (Lisp_Object, Lisp_Object); +extern _Noreturn void xsignal0 (Lisp_Object); +extern _Noreturn void xsignal1 (Lisp_Object, Lisp_Object); +extern _Noreturn void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern _Noreturn void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object); +extern _Noreturn void signal_error (const char *, Lisp_Object); +extern Lisp_Object eval_sub (Lisp_Object form); +extern Lisp_Object apply1 (Lisp_Object, Lisp_Object); +extern Lisp_Object call0 (Lisp_Object); +extern Lisp_Object call1 (Lisp_Object, Lisp_Object); +extern Lisp_Object call2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object); +extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_n + (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, + Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); +extern void specbind (Lisp_Object, Lisp_Object); +extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object); +extern void record_unwind_protect_ptr (void (*) (void *), void *); +extern void record_unwind_protect_int (void (*) (int), int); +extern void record_unwind_protect_void (void (*) (void)); +extern void record_unwind_protect_nothing (void); +extern void clear_unwind_protect (ptrdiff_t); +extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); +extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *); +extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); +extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); +extern _Noreturn void verror (const char *, va_list) + ATTRIBUTE_FORMAT_PRINTF (1, 0); +extern void un_autoload (Lisp_Object); +extern Lisp_Object call_debugger (Lisp_Object arg); +extern void init_eval_once (void); +extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...); +extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object); +extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern void init_eval (void); +extern void syms_of_eval (void); +extern void unwind_body (Lisp_Object); +extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t); +extern void mark_specpdl (void); +extern void get_backtrace (Lisp_Object array); +Lisp_Object backtrace_top_function (void); +extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol); +extern bool let_shadows_global_binding_p (Lisp_Object symbol); + + +/* Defined in editfns.c. */ +extern void insert1 (Lisp_Object); +extern Lisp_Object format2 (const char *, Lisp_Object, Lisp_Object); +extern Lisp_Object save_excursion_save (void); +extern Lisp_Object save_restriction_save (void); +extern void save_excursion_restore (Lisp_Object); +extern void save_restriction_restore (Lisp_Object); +extern _Noreturn void time_overflow (void); +extern Lisp_Object make_buffer_string (ptrdiff_t, ptrdiff_t, bool); +extern Lisp_Object make_buffer_string_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, + ptrdiff_t, bool); +extern void init_editfns (void); +extern void syms_of_editfns (void); + +/* Defined in buffer.c. */ +extern bool mouse_face_overlay_overlaps (Lisp_Object); +extern _Noreturn void nsberror (Lisp_Object); +extern void adjust_overlays_for_insert (ptrdiff_t, ptrdiff_t); +extern void adjust_overlays_for_delete (ptrdiff_t, ptrdiff_t); +extern void fix_start_end_in_overlays (ptrdiff_t, ptrdiff_t); +extern void report_overlay_modification (Lisp_Object, Lisp_Object, bool, + Lisp_Object, Lisp_Object, Lisp_Object); +extern bool overlay_touches_p (ptrdiff_t); +extern Lisp_Object other_buffer_safely (Lisp_Object); +extern Lisp_Object get_truename_buffer (Lisp_Object); +extern void init_buffer_once (void); +extern void init_buffer (int); +extern void syms_of_buffer (void); +extern void keys_of_buffer (void); + +/* Defined in marker.c. */ + +extern ptrdiff_t marker_position (Lisp_Object); +extern ptrdiff_t marker_byte_position (Lisp_Object); +extern void clear_charpos_cache (struct buffer *); +extern ptrdiff_t buf_charpos_to_bytepos (struct buffer *, ptrdiff_t); +extern ptrdiff_t buf_bytepos_to_charpos (struct buffer *, ptrdiff_t); +extern void unchain_marker (struct Lisp_Marker *marker); +extern Lisp_Object set_marker_restricted (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object set_marker_both (Lisp_Object, Lisp_Object, ptrdiff_t, ptrdiff_t); +extern Lisp_Object set_marker_restricted_both (Lisp_Object, Lisp_Object, + ptrdiff_t, ptrdiff_t); +extern Lisp_Object build_marker (struct buffer *, ptrdiff_t, ptrdiff_t); +extern void syms_of_marker (void); + +/* Defined in fileio.c. */ + +extern Lisp_Object expand_and_dir_to_file (Lisp_Object, Lisp_Object); +extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, int); +extern void close_file_unwind (int); +extern void fclose_unwind (void *); +extern void restore_point_unwind (Lisp_Object); +extern _Noreturn void report_file_errno (const char *, Lisp_Object, int); +extern _Noreturn void report_file_error (const char *, Lisp_Object); +extern bool internal_delete_file (Lisp_Object); +extern Lisp_Object emacs_readlinkat (int, const char *); +extern bool file_directory_p (const char *); +extern bool file_accessible_directory_p (Lisp_Object); +extern void init_fileio (void); +extern void syms_of_fileio (void); +extern Lisp_Object make_temp_name (Lisp_Object, bool); + +/* Defined in search.c. */ +extern void shrink_regexp_cache (void); +extern void restore_search_regs (void); +extern void record_unwind_save_match_data (void); +struct re_registers; +extern struct re_pattern_buffer *compile_pattern (Lisp_Object, + struct re_registers *, + Lisp_Object, bool, bool); +extern ptrdiff_t fast_string_match_internal (Lisp_Object, Lisp_Object, + Lisp_Object); + +INLINE ptrdiff_t +fast_string_match (Lisp_Object regexp, Lisp_Object string) +{ + return fast_string_match_internal (regexp, string, Qnil); +} + +INLINE ptrdiff_t +fast_string_match_ignore_case (Lisp_Object regexp, Lisp_Object string) +{ + return fast_string_match_internal (regexp, string, Vascii_canon_table); +} + +extern ptrdiff_t fast_c_string_match_ignore_case (Lisp_Object, const char *, + ptrdiff_t); +extern ptrdiff_t fast_looking_at (Lisp_Object, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t, Lisp_Object); +extern ptrdiff_t find_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t *, ptrdiff_t *, bool); +extern ptrdiff_t scan_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, + ptrdiff_t, bool); +extern ptrdiff_t scan_newline_from_point (ptrdiff_t, ptrdiff_t *, ptrdiff_t *); +extern ptrdiff_t find_newline_no_quit (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t *); +extern ptrdiff_t find_before_next_newline (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t *); +extern void syms_of_search (void); +extern void clear_regexp_cache (void); + +/* Defined in minibuf.c. */ + +extern Lisp_Object Vminibuffer_list; +extern Lisp_Object last_minibuf_string; +extern Lisp_Object get_minibuffer (EMACS_INT); +extern void init_minibuf_once (void); +extern void syms_of_minibuf (void); + +/* Defined in callint.c. */ + +extern void syms_of_callint (void); + +/* Defined in casefiddle.c. */ + +extern void syms_of_casefiddle (void); +extern void keys_of_casefiddle (void); + +/* Defined in casetab.c. */ + +extern void init_casetab_once (void); +extern void syms_of_casetab (void); + +/* Defined in keyboard.c. */ + +extern Lisp_Object echo_message_buffer; +extern struct kboard *echo_kboard; +extern void cancel_echoing (void); +extern Lisp_Object last_undo_boundary; +extern bool input_pending; +#ifdef HAVE_STACK_OVERFLOW_HANDLING +extern sigjmp_buf return_to_command_loop; +#endif +extern Lisp_Object menu_bar_items (Lisp_Object); +extern Lisp_Object tool_bar_items (Lisp_Object, int *); +extern void discard_mouse_events (void); +#ifdef USABLE_SIGIO +void handle_input_available_signal (int); +#endif +extern Lisp_Object pending_funcalls; +extern bool detect_input_pending (void); +extern bool detect_input_pending_ignore_squeezables (void); +extern bool detect_input_pending_run_timers (bool); +extern void safe_run_hooks (Lisp_Object); +extern void cmd_error_internal (Lisp_Object, const char *); +extern Lisp_Object command_loop_1 (void); +extern Lisp_Object read_menu_command (void); +extern Lisp_Object recursive_edit_1 (void); +extern void record_auto_save (void); +extern void force_auto_save_soon (void); +extern void init_keyboard (void); +extern void syms_of_keyboard (void); +extern void keys_of_keyboard (void); + +/* Defined in indent.c. */ +extern ptrdiff_t current_column (void); +extern void invalidate_current_column (void); +extern bool indented_beyond_p (ptrdiff_t, ptrdiff_t, EMACS_INT); +extern void syms_of_indent (void); + +/* Defined in frame.c. */ +extern void store_frame_param (struct frame *, Lisp_Object, Lisp_Object); +extern void store_in_alist (Lisp_Object *, Lisp_Object, Lisp_Object); +extern Lisp_Object do_switch_frame (Lisp_Object, int, int, Lisp_Object); +extern Lisp_Object get_frame_param (struct frame *, Lisp_Object); +extern void frames_discard_buffer (Lisp_Object); +extern void syms_of_frame (void); + +/* Defined in emacs.c. */ +extern char **initial_argv; +extern int initial_argc; +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NS) +extern bool display_arg; +#endif +extern Lisp_Object decode_env_path (const char *, const char *, bool); +extern Lisp_Object empty_unibyte_string, empty_multibyte_string; +extern _Noreturn void terminate_due_to_signal (int, int); +#ifdef WINDOWSNT +extern Lisp_Object Vlibrary_cache; +#endif +#if HAVE_SETLOCALE +void fixup_locale (void); +void synchronize_system_messages_locale (void); +void synchronize_system_time_locale (void); +#else +INLINE void fixup_locale (void) {} +INLINE void synchronize_system_messages_locale (void) {} +INLINE void synchronize_system_time_locale (void) {} +#endif +extern void shut_down_emacs (int, Lisp_Object); + +/* True means don't do interactive redisplay and don't change tty modes. */ +extern bool noninteractive; + +/* True means remove site-lisp directories from load-path. */ +extern bool no_site_lisp; + +/* Pipe used to send exit notification to the daemon parent at + startup. On Windows, we use a kernel event instead. */ +#ifndef WINDOWSNT +extern int daemon_pipe[2]; +#define IS_DAEMON (daemon_pipe[1] != 0) +#define DAEMON_RUNNING (daemon_pipe[1] >= 0) +#else /* WINDOWSNT */ +extern void *w32_daemon_event; +#define IS_DAEMON (w32_daemon_event != NULL) +#define DAEMON_RUNNING (w32_daemon_event != INVALID_HANDLE_VALUE) +#endif + +/* True if handling a fatal error already. */ +extern bool fatal_error_in_progress; + +/* True means don't do use window-system-specific display code. */ +extern bool inhibit_window_system; +/* True means that a filter or a sentinel is running. */ +extern bool running_asynch_code; + +/* Defined in process.c. */ +extern void kill_buffer_processes (Lisp_Object); +extern int wait_reading_process_output (intmax_t, int, int, bool, Lisp_Object, + struct Lisp_Process *, int); +/* Max value for the first argument of wait_reading_process_output. */ +#if __GNUC__ == 3 || (__GNUC__ == 4 && __GNUC_MINOR__ <= 5) +/* Work around a bug in GCC 3.4.2, known to be fixed in GCC 4.6.3. + The bug merely causes a bogus warning, but the warning is annoying. */ +# define WAIT_READING_MAX min (TYPE_MAXIMUM (time_t), INTMAX_MAX) +#else +# define WAIT_READING_MAX INTMAX_MAX +#endif +#ifdef HAVE_TIMERFD +extern void add_timer_wait_descriptor (int); +#endif +extern void add_keyboard_wait_descriptor (int); +extern void delete_keyboard_wait_descriptor (int); +#ifdef HAVE_GPM +extern void add_gpm_wait_descriptor (int); +extern void delete_gpm_wait_descriptor (int); +#endif +extern void init_process_emacs (void); +extern void syms_of_process (void); +extern void setup_process_coding_systems (Lisp_Object); + +/* Defined in callproc.c. */ +#ifndef DOS_NT + _Noreturn +#endif +extern int child_setup (int, int, int, char **, bool, Lisp_Object); +extern void init_callproc_1 (void); +extern void init_callproc (void); +extern void set_initial_environment (void); +extern void syms_of_callproc (void); + +/* Defined in doc.c. */ +extern Lisp_Object read_doc_string (Lisp_Object); +extern Lisp_Object get_doc_string (Lisp_Object, bool, bool); +extern void syms_of_doc (void); +extern int read_bytecode_char (bool); + +/* Defined in bytecode.c. */ +extern void syms_of_bytecode (void); +extern struct byte_stack *byte_stack_list; +#if BYTE_MARK_STACK +extern void mark_byte_stack (void); +#endif +extern void unmark_byte_stack (void); +extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, ptrdiff_t, Lisp_Object *); + +/* Defined in macros.c. */ +extern void init_macros (void); +extern void syms_of_macros (void); + +/* Defined in undo.c. */ +extern void truncate_undo_list (struct buffer *); +extern void record_insert (ptrdiff_t, ptrdiff_t); +extern void record_delete (ptrdiff_t, Lisp_Object, bool); +extern void record_first_change (void); +extern void record_change (ptrdiff_t, ptrdiff_t); +extern void record_property_change (ptrdiff_t, ptrdiff_t, + Lisp_Object, Lisp_Object, + Lisp_Object); +extern void syms_of_undo (void); + +/* Defined in textprop.c. */ +extern void report_interval_modification (Lisp_Object, Lisp_Object); + +/* Defined in menu.c. */ +extern void syms_of_menu (void); + +/* Defined in xmenu.c. */ +extern void syms_of_xmenu (void); + +/* Defined in termchar.h. */ +struct tty_display_info; + +/* Defined in termhooks.h. */ +struct terminal; + +/* Defined in sysdep.c. */ +#ifndef HAVE_GET_CURRENT_DIR_NAME +extern char *get_current_dir_name (void); +#endif +extern void stuff_char (char c); +extern void init_foreground_group (void); +extern void sys_subshell (void); +extern void sys_suspend (void); +extern void discard_tty_input (void); +extern void init_sys_modes (struct tty_display_info *); +extern void reset_sys_modes (struct tty_display_info *); +extern void init_all_sys_modes (void); +extern void reset_all_sys_modes (void); +extern void child_setup_tty (int); +extern void setup_pty (int); +extern int set_window_size (int, int, int); +extern EMACS_INT get_random (void); +extern void seed_random (void *, ptrdiff_t); +extern void init_random (void); +extern void emacs_backtrace (int); +extern _Noreturn void emacs_abort (void) NO_INLINE; +extern int emacs_open (const char *, int, int); +extern int emacs_pipe (int[2]); +extern int emacs_close (int); +extern ptrdiff_t emacs_read (int, void *, ptrdiff_t); +extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t); +extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t); +extern void emacs_perror (char const *); + +extern void unlock_all_files (void); +extern void lock_file (Lisp_Object); +extern void unlock_file (Lisp_Object); +extern void unlock_buffer (struct buffer *); +extern void syms_of_filelock (void); +extern int str_collate (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + +/* Defined in sound.c. */ +extern void syms_of_sound (void); + +/* Defined in category.c. */ +extern void init_category_once (void); +extern Lisp_Object char_category_set (int); +extern void syms_of_category (void); + +/* Defined in ccl.c. */ +extern void syms_of_ccl (void); + +/* Defined in dired.c. */ +extern void syms_of_dired (void); +extern Lisp_Object directory_files_internal (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object, + bool, Lisp_Object); + +/* Defined in term.c. */ +extern int *char_ins_del_vector; +extern void syms_of_term (void); +extern _Noreturn void fatal (const char *msgid, ...) + ATTRIBUTE_FORMAT_PRINTF (1, 2); + +/* Defined in terminal.c. */ +extern void syms_of_terminal (void); + +/* Defined in font.c. */ +extern void syms_of_font (void); +extern void init_font (void); + +#ifdef HAVE_WINDOW_SYSTEM +/* Defined in fontset.c. */ +extern void syms_of_fontset (void); +#endif + +/* Defined in gfilenotify.c */ +#ifdef HAVE_GFILENOTIFY +extern void globals_of_gfilenotify (void); +extern void syms_of_gfilenotify (void); +#endif + +/* Defined in inotify.c */ +#ifdef HAVE_INOTIFY +extern void syms_of_inotify (void); +#endif + +#ifdef HAVE_W32NOTIFY +/* Defined on w32notify.c. */ +extern void syms_of_w32notify (void); +#endif + +/* Defined in xfaces.c. */ +extern Lisp_Object Vface_alternative_font_family_alist; +extern Lisp_Object Vface_alternative_font_registry_alist; +extern void syms_of_xfaces (void); + +#ifdef HAVE_X_WINDOWS +/* Defined in xfns.c. */ +extern void syms_of_xfns (void); + +/* Defined in xsmfns.c. */ +extern void syms_of_xsmfns (void); + +/* Defined in xselect.c. */ +extern void syms_of_xselect (void); + +/* Defined in xterm.c. */ +extern void init_xterm (void); +extern void syms_of_xterm (void); +#endif /* HAVE_X_WINDOWS */ + +#ifdef HAVE_WINDOW_SYSTEM +/* Defined in xterm.c, nsterm.m, w32term.c. */ +extern char *x_get_keysym_name (int); +#endif /* HAVE_WINDOW_SYSTEM */ + +#ifdef HAVE_LIBXML2 +/* Defined in xml.c. */ +extern void syms_of_xml (void); +extern void xml_cleanup_parser (void); +#endif + +#ifdef HAVE_ZLIB +/* Defined in decompress.c. */ +extern void syms_of_decompress (void); +#endif + +#ifdef HAVE_DBUS +/* Defined in dbusbind.c. */ +void init_dbusbind (void); +void syms_of_dbusbind (void); +#endif + + +/* Defined in profiler.c. */ +extern bool profiler_memory_running; +extern void malloc_probe (size_t); +extern void syms_of_profiler (void); + + +#ifdef DOS_NT +/* Defined in msdos.c, w32.c. */ +extern char *emacs_root_dir (void); +#endif /* DOS_NT */ + +/* Defined in lastfile.c. */ +extern char my_edata[]; +extern char my_endbss[]; +extern char *my_endbss_static; + +/* True means ^G can quit instantly. */ +extern bool immediate_quit; + +extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); +extern void xfree (void *); +extern void *xnmalloc (ptrdiff_t, ptrdiff_t) ATTRIBUTE_MALLOC_SIZE ((1,2)); +extern void *xnrealloc (void *, ptrdiff_t, ptrdiff_t) + ATTRIBUTE_ALLOC_SIZE ((2,3)); +extern void *xpalloc (void *, ptrdiff_t *, ptrdiff_t, ptrdiff_t, ptrdiff_t); + +extern char *xstrdup (const char *) ATTRIBUTE_MALLOC; +extern char *xlispstrdup (Lisp_Object) ATTRIBUTE_MALLOC; +extern void dupstring (char **, char const *); + +/* Make DEST a copy of STRING's data. Return a pointer to DEST's terminating + null byte. This is like stpcpy, except the source is a Lisp string. */ + +INLINE char * +lispstpcpy (char *dest, Lisp_Object string) +{ + ptrdiff_t len = SBYTES (string); + memcpy (dest, SDATA (string), len + 1); + return dest + len; +} + +extern void xputenv (const char *); + +extern char *egetenv_internal (const char *, ptrdiff_t); + +INLINE char * +egetenv (const char *var) +{ + /* When VAR is a string literal, strlen can be optimized away. */ + return egetenv_internal (var, strlen (var)); +} + +/* Set up the name of the machine we're running on. */ +extern void init_system_name (void); + +/* Return the absolute value of X. X should be a signed integer + expression without side effects, and X's absolute value should not + exceed the maximum for its promoted type. This is called 'eabs' + because 'abs' is reserved by the C standard. */ +#define eabs(x) ((x) < 0 ? -(x) : (x)) + +/* Return a fixnum or float, depending on whether VAL fits in a Lisp + fixnum. */ + +#define make_fixnum_or_float(val) \ + (FIXNUM_OVERFLOW_P (val) ? make_float (val) : make_number (val)) + +/* SAFE_ALLOCA normally allocates memory on the stack, but if size is + larger than MAX_ALLOCA, use xmalloc to avoid overflowing the stack. */ + +enum MAX_ALLOCA { MAX_ALLOCA = 16 * 1024 }; + +extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); + +#define USE_SAFE_ALLOCA \ + ptrdiff_t sa_avail = MAX_ALLOCA; \ + ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false + +#define AVAIL_ALLOCA(size) (sa_avail -= (size), alloca (size)) + +/* SAFE_ALLOCA allocates a simple buffer. */ + +#define SAFE_ALLOCA(size) ((size) <= sa_avail \ + ? AVAIL_ALLOCA (size) \ + : (sa_must_free = true, record_xmalloc (size))) + +/* SAFE_NALLOCA sets BUF to a newly allocated array of MULTIPLIER * + NITEMS items, each of the same type as *BUF. MULTIPLIER must + positive. The code is tuned for MULTIPLIER being a constant. */ + +#define SAFE_NALLOCA(buf, multiplier, nitems) \ + do { \ + if ((nitems) <= sa_avail / sizeof *(buf) / (multiplier)) \ + (buf) = AVAIL_ALLOCA (sizeof *(buf) * (multiplier) * (nitems)); \ + else \ + { \ + (buf) = xnmalloc (nitems, sizeof *(buf) * (multiplier)); \ + sa_must_free = true; \ + record_unwind_protect_ptr (xfree, buf); \ + } \ + } while (false) + +/* SAFE_ALLOCA_STRING allocates a C copy of a Lisp string. */ + +#define SAFE_ALLOCA_STRING(ptr, string) \ + do { \ + (ptr) = SAFE_ALLOCA (SBYTES (string) + 1); \ + memcpy (ptr, SDATA (string), SBYTES (string) + 1); \ + } while (false) + +/* SAFE_FREE frees xmalloced memory and enables GC as needed. */ + +#define SAFE_FREE() \ + do { \ + if (sa_must_free) { \ + sa_must_free = false; \ + unbind_to (sa_count, Qnil); \ + } \ + } while (false) + + +/* Return floor (NBYTES / WORD_SIZE). */ + +INLINE ptrdiff_t +lisp_word_count (ptrdiff_t nbytes) +{ + if (-1 >> 1 == -1) + switch (word_size) + { + case 2: return nbytes >> 1; + case 4: return nbytes >> 2; + case 8: return nbytes >> 3; + case 16: return nbytes >> 4; + } + return nbytes / word_size - (nbytes % word_size < 0); +} + +/* SAFE_ALLOCA_LISP allocates an array of Lisp_Objects. */ + +#define SAFE_ALLOCA_LISP(buf, nelt) \ + do { \ + if ((nelt) <= lisp_word_count (sa_avail)) \ + (buf) = AVAIL_ALLOCA ((nelt) * word_size); \ + else if ((nelt) <= min (PTRDIFF_MAX, SIZE_MAX) / word_size) \ + { \ + Lisp_Object arg_; \ + (buf) = xmalloc ((nelt) * word_size); \ + arg_ = make_save_memory (buf, nelt); \ + sa_must_free = true; \ + record_unwind_protect (free_save_value, arg_); \ + } \ + else \ + memory_full (SIZE_MAX); \ + } while (false) + + +/* If USE_STACK_LISP_OBJECTS, define macros that and functions that allocate + block-scoped conses and strings. These objects are not + managed by the garbage collector, so they are dangerous: passing them + out of their scope (e.g., to user code) results in undefined behavior. + Conversely, they have better performance because GC is not involved. + + This feature is experimental and requires careful debugging. + Build with CPPFLAGS='-DUSE_STACK_LISP_OBJECTS=0' to disable it. */ + +#ifndef USE_STACK_LISP_OBJECTS +# define USE_STACK_LISP_OBJECTS true +#endif + +/* USE_STACK_LISP_OBJECTS requires GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS. */ + +#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS +# undef USE_STACK_LISP_OBJECTS +# define USE_STACK_LISP_OBJECTS false +#endif + +#ifdef GC_CHECK_STRING_BYTES +enum { defined_GC_CHECK_STRING_BYTES = true }; +#else +enum { defined_GC_CHECK_STRING_BYTES = false }; +#endif + +/* Struct inside unions that are typically no larger and aligned enough. */ + +union Aligned_Cons +{ + struct Lisp_Cons s; + double d; intmax_t i; void *p; +}; + +union Aligned_String +{ + struct Lisp_String s; + double d; intmax_t i; void *p; +}; + +/* True for stack-based cons and string implementations, respectively. + Use stack-based strings only if stack-based cons also works. + Otherwise, STACK_CONS would create heap-based cons cells that + could point to stack-based strings, which is a no-no. */ + +enum + { + USE_STACK_CONS = (USE_STACK_LISP_OBJECTS + && alignof (union Aligned_Cons) % GCALIGNMENT == 0), + USE_STACK_STRING = (USE_STACK_CONS + && !defined_GC_CHECK_STRING_BYTES + && alignof (union Aligned_String) % GCALIGNMENT == 0) + }; + +/* Auxiliary macros used for auto allocation of Lisp objects. Please + use these only in macros like AUTO_CONS that declare a local + variable whose lifetime will be clear to the programmer. */ +#define STACK_CONS(a, b) \ + make_lisp_ptr (&(union Aligned_Cons) { { a, { b } } }.s, Lisp_Cons) +#define AUTO_CONS_EXPR(a, b) \ + (USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b)) + +/* Declare NAME as an auto Lisp cons or short list if possible, a + GC-based one otherwise. This is in the sense of the C keyword + 'auto'; i.e., the object has the lifetime of the containing block. + The resulting object should not be made visible to user Lisp code. */ + +#define AUTO_CONS(name, a, b) Lisp_Object name = AUTO_CONS_EXPR (a, b) +#define AUTO_LIST1(name, a) \ + Lisp_Object name = (USE_STACK_CONS ? STACK_CONS (a, Qnil) : list1 (a)) +#define AUTO_LIST2(name, a, b) \ + Lisp_Object name = (USE_STACK_CONS \ + ? STACK_CONS (a, STACK_CONS (b, Qnil)) \ + : list2 (a, b)) +#define AUTO_LIST3(name, a, b, c) \ + Lisp_Object name = (USE_STACK_CONS \ + ? STACK_CONS (a, STACK_CONS (b, STACK_CONS (c, Qnil))) \ + : list3 (a, b, c)) +#define AUTO_LIST4(name, a, b, c, d) \ + Lisp_Object name \ + = (USE_STACK_CONS \ + ? STACK_CONS (a, STACK_CONS (b, STACK_CONS (c, \ + STACK_CONS (d, Qnil)))) \ + : list4 (a, b, c, d)) + +/* Check whether stack-allocated strings are ASCII-only. */ + +#if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS +extern const char *verify_ascii (const char *); +#else +# define verify_ascii(str) (str) +#endif + +/* Declare NAME as an auto Lisp string if possible, a GC-based one if not. + Take its value from STR. STR is not necessarily copied and should + contain only ASCII characters. The resulting Lisp string should + not be modified or made visible to user code. */ + +#define AUTO_STRING(name, str) \ + Lisp_Object name = \ + (USE_STACK_STRING \ + ? (make_lisp_ptr \ + ((&(union Aligned_String) \ + {{strlen (str), -1, 0, (unsigned char *) verify_ascii (str)}}.s), \ + Lisp_String)) \ + : build_string (verify_ascii (str))) + +/* Loop over all tails of a list, checking for cycles. + FIXME: Make tortoise and n internal declarations. + FIXME: Unroll the loop body so we don't need `n'. */ +#define FOR_EACH_TAIL(hare, list, tortoise, n) \ + for ((tortoise) = (hare) = (list), (n) = true; \ + CONSP (hare); \ + (hare = XCDR (hare), (n) = !(n), \ + ((n) \ + ? (EQ (hare, tortoise) \ + ? xsignal1 (Qcircular_list, list) \ + : (void) 0) \ + /* Move tortoise before the next iteration, in case */ \ + /* the next iteration does an Fsetcdr. */ \ + : (void) ((tortoise) = XCDR (tortoise))))) + +/* Do a `for' loop over alist values. */ + +#define FOR_EACH_ALIST_VALUE(head_var, list_var, value_var) \ + for ((list_var) = (head_var); \ + (CONSP (list_var) && ((value_var) = XCDR (XCAR (list_var)), true)); \ + (list_var) = XCDR (list_var)) + +/* Check whether it's time for GC, and run it if so. */ + +INLINE void +maybe_gc (void) +{ + if ((consing_since_gc > gc_cons_threshold + && consing_since_gc > gc_relative_threshold) + || (!NILP (Vmemory_full) + && consing_since_gc > memory_full_cons_threshold)) + Fgarbage_collect (); +} + +INLINE bool +functionp (Lisp_Object object) +{ + if (SYMBOLP (object) && !NILP (Ffboundp (object))) + { + object = Findirect_function (object, Qt); + + if (CONSP (object) && EQ (XCAR (object), Qautoload)) + { + /* Autoloaded symbols are functions, except if they load + macros or keymaps. */ + int i; + for (i = 0; i < 4 && CONSP (object); i++) + object = XCDR (object); + + return ! (CONSP (object) && !NILP (XCAR (object))); + } + } + + if (SUBRP (object)) + return XSUBR (object)->max_args != UNEVALLED; + else if (COMPILEDP (object)) + return true; + else if (CONSP (object)) + { + Lisp_Object car = XCAR (object); + return EQ (car, Qlambda) || EQ (car, Qclosure); + } + else + return false; +} + +INLINE_HEADER_END + +#endif /* EMACS_LISP_H */ diff --git a/test/manual/etags/c-src/emacs/src/regex.h b/test/manual/etags/c-src/emacs/src/regex.h new file mode 100644 index 00000000000..3dfecf0a7e5 --- /dev/null +++ b/test/manual/etags/c-src/emacs/src/regex.h @@ -0,0 +1,630 @@ +/* Definitions for data structures and routines for the regular + expression library, version 0.12. + + Copyright (C) 1985, 1989-1993, 1995, 2000-2015 Free Software + Foundation, Inc. + + This program 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, or (at your option) + any later version. + + This program 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 this program. If not, see <http://www.gnu.org/licenses/>. */ + +#ifndef _REGEX_H +#define _REGEX_H 1 + +/* Allow the use in C++ code. */ +#ifdef __cplusplus +extern "C" { +#endif + +/* POSIX says that <sys/types.h> must be included (by the caller) before + <regex.h>. */ + +#if !defined _POSIX_C_SOURCE && !defined _POSIX_SOURCE && defined VMS +/* VMS doesn't have `size_t' in <sys/types.h>, even though POSIX says it + should be there. */ +# include <stddef.h> +#endif + +/* The following bits are used to determine the regexp syntax we + recognize. The set/not-set meanings where historically chosen so + that Emacs syntax had the value 0. + The bits are given in alphabetical order, and + the definitions shifted by one from the previous bit; thus, when we + add or remove a bit, only one other definition need change. */ +typedef unsigned long reg_syntax_t; + +/* If this bit is not set, then \ inside a bracket expression is literal. + If set, then such a \ quotes the following character. */ +#define RE_BACKSLASH_ESCAPE_IN_LISTS ((unsigned long int) 1) + +/* If this bit is not set, then + and ? are operators, and \+ and \? are + literals. + If set, then \+ and \? are operators and + and ? are literals. */ +#define RE_BK_PLUS_QM (RE_BACKSLASH_ESCAPE_IN_LISTS << 1) + +/* If this bit is set, then character classes are supported. They are: + [:alpha:], [:upper:], [:lower:], [:digit:], [:alnum:], [:xdigit:], + [:space:], [:print:], [:punct:], [:graph:], and [:cntrl:]. + If not set, then character classes are not supported. */ +#define RE_CHAR_CLASSES (RE_BK_PLUS_QM << 1) + +/* If this bit is set, then ^ and $ are always anchors (outside bracket + expressions, of course). + If this bit is not set, then it depends: + ^ is an anchor if it is at the beginning of a regular + expression or after an open-group or an alternation operator; + $ is an anchor if it is at the end of a regular expression, or + before a close-group or an alternation operator. + + This bit could be (re)combined with RE_CONTEXT_INDEP_OPS, because + POSIX draft 11.2 says that * etc. in leading positions is undefined. + We already implemented a previous draft which made those constructs + invalid, though, so we haven't changed the code back. */ +#define RE_CONTEXT_INDEP_ANCHORS (RE_CHAR_CLASSES << 1) + +/* If this bit is set, then special characters are always special + regardless of where they are in the pattern. + If this bit is not set, then special characters are special only in + some contexts; otherwise they are ordinary. Specifically, + * + ? and intervals are only special when not after the beginning, + open-group, or alternation operator. */ +#define RE_CONTEXT_INDEP_OPS (RE_CONTEXT_INDEP_ANCHORS << 1) + +/* If this bit is set, then *, +, ?, and { cannot be first in an re or + immediately after an alternation or begin-group operator. */ +#define RE_CONTEXT_INVALID_OPS (RE_CONTEXT_INDEP_OPS << 1) + +/* If this bit is set, then . matches newline. + If not set, then it doesn't. */ +#define RE_DOT_NEWLINE (RE_CONTEXT_INVALID_OPS << 1) + +/* If this bit is set, then . doesn't match NUL. + If not set, then it does. */ +#define RE_DOT_NOT_NULL (RE_DOT_NEWLINE << 1) + +/* If this bit is set, nonmatching lists [^...] do not match newline. + If not set, they do. */ +#define RE_HAT_LISTS_NOT_NEWLINE (RE_DOT_NOT_NULL << 1) + +/* If this bit is set, either \{...\} or {...} defines an + interval, depending on RE_NO_BK_BRACES. + If not set, \{, \}, {, and } are literals. */ +#define RE_INTERVALS (RE_HAT_LISTS_NOT_NEWLINE << 1) + +/* If this bit is set, +, ? and | aren't recognized as operators. + If not set, they are. */ +#define RE_LIMITED_OPS (RE_INTERVALS << 1) + +/* If this bit is set, newline is an alternation operator. + If not set, newline is literal. */ +#define RE_NEWLINE_ALT (RE_LIMITED_OPS << 1) + +/* If this bit is set, then `{...}' defines an interval, and \{ and \} + are literals. + If not set, then `\{...\}' defines an interval. */ +#define RE_NO_BK_BRACES (RE_NEWLINE_ALT << 1) + +/* If this bit is set, (...) defines a group, and \( and \) are literals. + If not set, \(...\) defines a group, and ( and ) are literals. */ +#define RE_NO_BK_PARENS (RE_NO_BK_BRACES << 1) + +/* If this bit is set, then \<digit> matches <digit>. + If not set, then \<digit> is a back-reference. */ +#define RE_NO_BK_REFS (RE_NO_BK_PARENS << 1) + +/* If this bit is set, then | is an alternation operator, and \| is literal. + If not set, then \| is an alternation operator, and | is literal. */ +#define RE_NO_BK_VBAR (RE_NO_BK_REFS << 1) + +/* If this bit is set, then an ending range point collating higher + than the starting range point, as in [z-a], is invalid. + If not set, then when ending range point collates higher than the + starting range point, the range is ignored. */ +#define RE_NO_EMPTY_RANGES (RE_NO_BK_VBAR << 1) + +/* If this bit is set, then an unmatched ) is ordinary. + If not set, then an unmatched ) is invalid. */ +#define RE_UNMATCHED_RIGHT_PAREN_ORD (RE_NO_EMPTY_RANGES << 1) + +/* If this bit is set, succeed as soon as we match the whole pattern, + without further backtracking. */ +#define RE_NO_POSIX_BACKTRACKING (RE_UNMATCHED_RIGHT_PAREN_ORD << 1) + +/* If this bit is set, do not process the GNU regex operators. + If not set, then the GNU regex operators are recognized. */ +#define RE_NO_GNU_OPS (RE_NO_POSIX_BACKTRACKING << 1) + +/* If this bit is set, then *?, +? and ?? match non greedily. */ +#define RE_FRUGAL (RE_NO_GNU_OPS << 1) + +/* If this bit is set, then (?:...) is treated as a shy group. */ +#define RE_SHY_GROUPS (RE_FRUGAL << 1) + +/* If this bit is set, ^ and $ only match at beg/end of buffer. */ +#define RE_NO_NEWLINE_ANCHOR (RE_SHY_GROUPS << 1) + +/* If this bit is set, turn on internal regex debugging. + If not set, and debugging was on, turn it off. + This only works if regex.c is compiled -DDEBUG. + We define this bit always, so that all that's needed to turn on + debugging is to recompile regex.c; the calling code can always have + this bit set, and it won't affect anything in the normal case. */ +#define RE_DEBUG (RE_NO_NEWLINE_ANCHOR << 1) + +/* This global variable defines the particular regexp syntax to use (for + some interfaces). When a regexp is compiled, the syntax used is + stored in the pattern buffer, so changing this does not affect + already-compiled regexps. */ +extern reg_syntax_t re_syntax_options; + +#ifdef emacs +/* In Emacs, this is the string or buffer in which we + are matching. It is used for looking up syntax properties. */ +extern Lisp_Object re_match_object; +#endif + +/* Roughly the maximum number of failure points on the stack. */ +extern size_t re_max_failures; + + +/* Define combinations of the above bits for the standard possibilities. + (The [[[ comments delimit what gets put into the Texinfo file, so + don't delete them!) */ +/* [[[begin syntaxes]]] */ +#define RE_SYNTAX_EMACS \ + (RE_CHAR_CLASSES | RE_INTERVALS | RE_SHY_GROUPS | RE_FRUGAL) + +#define RE_SYNTAX_AWK \ + (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DOT_NOT_NULL \ + | RE_NO_BK_PARENS | RE_NO_BK_REFS \ + | RE_NO_BK_VBAR | RE_NO_EMPTY_RANGES \ + | RE_DOT_NEWLINE | RE_CONTEXT_INDEP_ANCHORS \ + | RE_UNMATCHED_RIGHT_PAREN_ORD | RE_NO_GNU_OPS) + +#define RE_SYNTAX_GNU_AWK \ + ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DEBUG) \ + & ~(RE_DOT_NOT_NULL | RE_INTERVALS | RE_CONTEXT_INDEP_OPS)) + +#define RE_SYNTAX_POSIX_AWK \ + (RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \ + | RE_INTERVALS | RE_NO_GNU_OPS) + +#define RE_SYNTAX_GREP \ + (RE_BK_PLUS_QM | RE_CHAR_CLASSES \ + | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS \ + | RE_NEWLINE_ALT) + +#define RE_SYNTAX_EGREP \ + (RE_CHAR_CLASSES | RE_CONTEXT_INDEP_ANCHORS \ + | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE \ + | RE_NEWLINE_ALT | RE_NO_BK_PARENS \ + | RE_NO_BK_VBAR) + +#define RE_SYNTAX_POSIX_EGREP \ + (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES) + +/* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */ +#define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC + +#define RE_SYNTAX_SED RE_SYNTAX_POSIX_BASIC + +/* Syntax bits common to both basic and extended POSIX regex syntax. */ +#define _RE_SYNTAX_POSIX_COMMON \ + (RE_CHAR_CLASSES | RE_DOT_NEWLINE | RE_DOT_NOT_NULL \ + | RE_INTERVALS | RE_NO_EMPTY_RANGES) + +#define RE_SYNTAX_POSIX_BASIC \ + (_RE_SYNTAX_POSIX_COMMON | RE_BK_PLUS_QM) + +/* Differs from ..._POSIX_BASIC only in that RE_BK_PLUS_QM becomes + RE_LIMITED_OPS, i.e., \? \+ \| are not recognized. Actually, this + isn't minimal, since other operators, such as \`, aren't disabled. */ +#define RE_SYNTAX_POSIX_MINIMAL_BASIC \ + (_RE_SYNTAX_POSIX_COMMON | RE_LIMITED_OPS) + +#define RE_SYNTAX_POSIX_EXTENDED \ + (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \ + | RE_CONTEXT_INDEP_OPS | RE_NO_BK_BRACES \ + | RE_NO_BK_PARENS | RE_NO_BK_VBAR \ + | RE_CONTEXT_INVALID_OPS | RE_UNMATCHED_RIGHT_PAREN_ORD) + +/* Differs from ..._POSIX_EXTENDED in that RE_CONTEXT_INDEP_OPS is + removed and RE_NO_BK_REFS is added. */ +#define RE_SYNTAX_POSIX_MINIMAL_EXTENDED \ + (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \ + | RE_CONTEXT_INVALID_OPS | RE_NO_BK_BRACES \ + | RE_NO_BK_PARENS | RE_NO_BK_REFS \ + | RE_NO_BK_VBAR | RE_UNMATCHED_RIGHT_PAREN_ORD) +/* [[[end syntaxes]]] */ + +/* Maximum number of duplicates an interval can allow. Some systems + (erroneously) define this in other header files, but we want our + value, so remove any previous define. */ +#ifdef RE_DUP_MAX +# undef RE_DUP_MAX +#endif +/* If sizeof(int) == 2, then ((1 << 15) - 1) overflows. */ +#define RE_DUP_MAX (0x7fff) + + +/* POSIX `cflags' bits (i.e., information for `regcomp'). */ + +/* If this bit is set, then use extended regular expression syntax. + If not set, then use basic regular expression syntax. */ +#define REG_EXTENDED 1 + +/* If this bit is set, then ignore case when matching. + If not set, then case is significant. */ +#define REG_ICASE (REG_EXTENDED << 1) + +/* If this bit is set, then anchors do not match at newline + characters in the string. + If not set, then anchors do match at newlines. */ +#define REG_NEWLINE (REG_ICASE << 1) + +/* If this bit is set, then report only success or fail in regexec. + If not set, then returns differ between not matching and errors. */ +#define REG_NOSUB (REG_NEWLINE << 1) + + +/* POSIX `eflags' bits (i.e., information for regexec). */ + +/* If this bit is set, then the beginning-of-line operator doesn't match + the beginning of the string (presumably because it's not the + beginning of a line). + If not set, then the beginning-of-line operator does match the + beginning of the string. */ +#define REG_NOTBOL 1 + +/* Like REG_NOTBOL, except for the end-of-line. */ +#define REG_NOTEOL (1 << 1) + + +/* If any error codes are removed, changed, or added, update the + `re_error_msg' table in regex.c. */ +typedef enum +{ +#ifdef _XOPEN_SOURCE + REG_ENOSYS = -1, /* This will never happen for this implementation. */ +#endif + + REG_NOERROR = 0, /* Success. */ + REG_NOMATCH, /* Didn't find a match (for regexec). */ + + /* POSIX regcomp return error codes. (In the order listed in the + standard.) */ + REG_BADPAT, /* Invalid pattern. */ + REG_ECOLLATE, /* Not implemented. */ + REG_ECTYPE, /* Invalid character class name. */ + REG_EESCAPE, /* Trailing backslash. */ + REG_ESUBREG, /* Invalid back reference. */ + REG_EBRACK, /* Unmatched left bracket. */ + REG_EPAREN, /* Parenthesis imbalance. */ + REG_EBRACE, /* Unmatched \{. */ + REG_BADBR, /* Invalid contents of \{\}. */ + REG_ERANGE, /* Invalid range end. */ + REG_ESPACE, /* Ran out of memory. */ + REG_BADRPT, /* No preceding re for repetition op. */ + + /* Error codes we've added. */ + REG_EEND, /* Premature end. */ + REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */ + REG_ERPAREN, /* Unmatched ) or \); not returned from regcomp. */ + REG_ERANGEX /* Range striding over charsets. */ +} reg_errcode_t; + +/* This data structure represents a compiled pattern. Before calling + the pattern compiler, the fields `buffer', `allocated', `fastmap', + `translate', and `no_sub' can be set. After the pattern has been + compiled, the `re_nsub' field is available. All other fields are + private to the regex routines. */ + +#ifndef RE_TRANSLATE_TYPE +# define RE_TRANSLATE_TYPE char * +#endif + +struct re_pattern_buffer +{ +/* [[[begin pattern_buffer]]] */ + /* Space that holds the compiled pattern. It is declared as + `unsigned char *' because its elements are + sometimes used as array indexes. */ + unsigned char *buffer; + + /* Number of bytes to which `buffer' points. */ + size_t allocated; + + /* Number of bytes actually used in `buffer'. */ + size_t used; + + /* Syntax setting with which the pattern was compiled. */ + reg_syntax_t syntax; + + /* Pointer to a fastmap, if any, otherwise zero. re_search uses + the fastmap, if there is one, to skip over impossible + starting points for matches. */ + char *fastmap; + + /* Either a translate table to apply to all characters before + comparing them, or zero for no translation. The translation + is applied to a pattern when it is compiled and to a string + when it is matched. */ + RE_TRANSLATE_TYPE translate; + + /* Number of subexpressions found by the compiler. */ + size_t re_nsub; + + /* Zero if this pattern cannot match the empty string, one else. + Well, in truth it's used only in `re_search_2', to see + whether or not we should use the fastmap, so we don't set + this absolutely perfectly; see `re_compile_fastmap'. */ + unsigned can_be_null : 1; + + /* If REGS_UNALLOCATED, allocate space in the `regs' structure + for `max (RE_NREGS, re_nsub + 1)' groups. + If REGS_REALLOCATE, reallocate space if necessary. + If REGS_FIXED, use what's there. */ +#define REGS_UNALLOCATED 0 +#define REGS_REALLOCATE 1 +#define REGS_FIXED 2 + unsigned regs_allocated : 2; + + /* Set to zero when `regex_compile' compiles a pattern; set to one + by `re_compile_fastmap' if it updates the fastmap. */ + unsigned fastmap_accurate : 1; + + /* If set, `re_match_2' does not return information about + subexpressions. */ + unsigned no_sub : 1; + + /* If set, a beginning-of-line anchor doesn't match at the + beginning of the string. */ + unsigned not_bol : 1; + + /* Similarly for an end-of-line anchor. */ + unsigned not_eol : 1; + + /* If true, the compilation of the pattern had to look up the syntax table, + so the compiled pattern is only valid for the current syntax table. */ + unsigned used_syntax : 1; + +#ifdef emacs + /* If true, multi-byte form in the regexp pattern should be + recognized as a multibyte character. */ + unsigned multibyte : 1; + + /* If true, multi-byte form in the target of match should be + recognized as a multibyte character. */ + unsigned target_multibyte : 1; + + /* Charset of unibyte characters at compiling time. */ + int charset_unibyte; +#endif + +/* [[[end pattern_buffer]]] */ +}; + +typedef struct re_pattern_buffer regex_t; + +/* Type for byte offsets within the string. POSIX mandates this to be an int, + but the Open Group has signaled its intention to change the requirement to + be that regoff_t be at least as wide as ptrdiff_t and ssize_t. Current + gnulib sources also use ssize_t, and we need this for supporting buffers and + strings > 2GB on 64-bit hosts. */ +typedef ssize_t regoff_t; + + +/* This is the structure we store register match data in. See + regex.texinfo for a full description of what registers match. */ +struct re_registers +{ + unsigned num_regs; + regoff_t *start; + regoff_t *end; +}; + + +/* If `regs_allocated' is REGS_UNALLOCATED in the pattern buffer, + `re_match_2' returns information about at least this many registers + the first time a `regs' structure is passed. */ +#ifndef RE_NREGS +# define RE_NREGS 30 +#endif + + +/* POSIX specification for registers. Aside from the different names than + `re_registers', POSIX uses an array of structures, instead of a + structure of arrays. */ +typedef struct +{ + regoff_t rm_so; /* Byte offset from string's start to substring's start. */ + regoff_t rm_eo; /* Byte offset from string's start to substring's end. */ +} regmatch_t; + +/* Declarations for routines. */ + +/* Sets the current default syntax to SYNTAX, and return the old syntax. + You can also simply assign to the `re_syntax_options' variable. */ +extern reg_syntax_t re_set_syntax (reg_syntax_t __syntax); + +/* Compile the regular expression PATTERN, with length LENGTH + and syntax given by the global `re_syntax_options', into the buffer + BUFFER. Return NULL if successful, and an error string if not. */ +extern const char *re_compile_pattern (const char *__pattern, size_t __length, + struct re_pattern_buffer *__buffer); + + +/* Compile a fastmap for the compiled pattern in BUFFER; used to + accelerate searches. Return 0 if successful and -2 if was an + internal error. */ +extern int re_compile_fastmap (struct re_pattern_buffer *__buffer); + + +/* Search in the string STRING (with length LENGTH) for the pattern + compiled into BUFFER. Start searching at position START, for RANGE + characters. Return the starting position of the match, -1 for no + match, or -2 for an internal error. Also return register + information in REGS (if REGS and BUFFER->no_sub are nonzero). */ +extern regoff_t re_search (struct re_pattern_buffer *__buffer, + const char *__string, size_t __length, + ssize_t __start, ssize_t __range, + struct re_registers *__regs); + + +/* Like `re_search', but search in the concatenation of STRING1 and + STRING2. Also, stop searching at index START + STOP. */ +extern regoff_t re_search_2 (struct re_pattern_buffer *__buffer, + const char *__string1, size_t __length1, + const char *__string2, size_t __length2, + ssize_t __start, ssize_t __range, + struct re_registers *__regs, + ssize_t __stop); + + +/* Like `re_search', but return how many characters in STRING the regexp + in BUFFER matched, starting at position START. */ +extern regoff_t re_match (struct re_pattern_buffer *__buffer, + const char *__string, size_t __length, + ssize_t __start, struct re_registers *__regs); + + +/* Relates to `re_match' as `re_search_2' relates to `re_search'. */ +extern regoff_t re_match_2 (struct re_pattern_buffer *__buffer, + const char *__string1, size_t __length1, + const char *__string2, size_t __length2, + ssize_t __start, struct re_registers *__regs, + ssize_t __stop); + + +/* Set REGS to hold NUM_REGS registers, storing them in STARTS and + ENDS. Subsequent matches using BUFFER and REGS will use this memory + for recording register information. STARTS and ENDS must be + allocated with malloc, and must each be at least `NUM_REGS * sizeof + (regoff_t)' bytes long. + + If NUM_REGS == 0, then subsequent matches should allocate their own + register data. + + Unless this function is called, the first search or match using + PATTERN_BUFFER will allocate its own register data, without + freeing the old data. */ +extern void re_set_registers (struct re_pattern_buffer *__buffer, + struct re_registers *__regs, + unsigned __num_regs, + regoff_t *__starts, regoff_t *__ends); + +#if defined _REGEX_RE_COMP || defined _LIBC +# ifndef _CRAY +/* 4.2 bsd compatibility. */ +extern char *re_comp (const char *); +extern int re_exec (const char *); +# endif +#endif + +/* GCC 2.95 and later have "__restrict"; C99 compilers have + "restrict", and "configure" may have defined "restrict". + Other compilers use __restrict, __restrict__, and _Restrict, and + 'configure' might #define 'restrict' to those words, so pick a + different name. */ +#ifndef _Restrict_ +# if 199901L <= __STDC_VERSION__ +# define _Restrict_ restrict +# elif 2 < __GNUC__ || (2 == __GNUC__ && 95 <= __GNUC_MINOR__) +# define _Restrict_ __restrict +# else +# define _Restrict_ +# endif +#endif +/* gcc 3.1 and up support the [restrict] syntax. Don't trust + sys/cdefs.h's definition of __restrict_arr, though, as it + mishandles gcc -ansi -pedantic. */ +#ifndef _Restrict_arr_ +# if ((199901L <= __STDC_VERSION__ \ + || ((3 < __GNUC__ || (3 == __GNUC__ && 1 <= __GNUC_MINOR__)) \ + && !defined __STRICT_ANSI__)) \ + && !defined __GNUG__) +# define _Restrict_arr_ _Restrict_ +# else +# define _Restrict_arr_ +# endif +#endif + +/* POSIX compatibility. */ +extern reg_errcode_t regcomp (regex_t *_Restrict_ __preg, + const char *_Restrict_ __pattern, + int __cflags); + +extern reg_errcode_t regexec (const regex_t *_Restrict_ __preg, + const char *_Restrict_ __string, size_t __nmatch, + regmatch_t __pmatch[_Restrict_arr_], + int __eflags); + +extern size_t regerror (int __errcode, const regex_t * __preg, + char *__errbuf, size_t __errbuf_size); + +extern void regfree (regex_t *__preg); + + +#ifdef __cplusplus +} +#endif /* C++ */ + +/* For platform which support the ISO C amendment 1 functionality we + support user defined character classes. */ +#if WIDE_CHAR_SUPPORT +/* Solaris 2.5 has a bug: <wchar.h> must be included before <wctype.h>. */ +# include <wchar.h> +# include <wctype.h> +#endif + +#if WIDE_CHAR_SUPPORT +/* The GNU C library provides support for user-defined character classes + and the functions from ISO C amendment 1. */ +# ifdef CHARCLASS_NAME_MAX +# define CHAR_CLASS_MAX_LENGTH CHARCLASS_NAME_MAX +# else +/* This shouldn't happen but some implementation might still have this + problem. Use a reasonable default value. */ +# define CHAR_CLASS_MAX_LENGTH 256 +# endif +typedef wctype_t re_wctype_t; +typedef wchar_t re_wchar_t; +# define re_wctype wctype +# define re_iswctype iswctype +# define re_wctype_to_bit(cc) 0 +#else +# define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */ +# define btowc(c) c + +/* Character classes. */ +typedef enum { RECC_ERROR = 0, + RECC_ALNUM, RECC_ALPHA, RECC_WORD, + RECC_GRAPH, RECC_PRINT, + RECC_LOWER, RECC_UPPER, + RECC_PUNCT, RECC_CNTRL, + RECC_DIGIT, RECC_XDIGIT, + RECC_BLANK, RECC_SPACE, + RECC_MULTIBYTE, RECC_NONASCII, + RECC_ASCII, RECC_UNIBYTE +} re_wctype_t; + +extern char re_iswctype (int ch, re_wctype_t cc); +extern re_wctype_t re_wctype (const unsigned char* str); + +typedef int re_wchar_t; + +extern void re_set_whitespace_regexp (const char *regexp); + +#endif /* not WIDE_CHAR_SUPPORT */ + +#endif /* regex.h */ + |