--- /dev/null
- That would also allow to preserve it ordered. */
+/* Fundamental definitions for GNU Emacs Lisp interpreter.
+
+Copyright (C) 1985-1987, 1993-1995, 1997-2016 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 */
+
+\f
+/* 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)
+\f
+/* 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);
+
+\f
+/* 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
+ };
+\f
+/* 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;
+}
+\f
+
+/* 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 */
+
+\f
+/***********************************************************************
+ 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 us 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;
+}
+
+\f
+/* 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;
+}
+\f
+/* 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
+ };
+\f
+/* 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);
+}
+\f
+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);
+}
+\f
+/* 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)
+\f
+/* 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
+
+\f
+/* 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))
+\f
+extern Lisp_Object Vascii_downcase_table;
+extern Lisp_Object Vascii_canon_table;
+\f
+/* 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 *);
+\f
+/* 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 */
--- /dev/null
- ;; This emulates the behaviour of `find-tag-in-order' but instead of
+;;; etags.el --- etags facility for Emacs -*- lexical-binding: t -*-
+
+;; Copyright (C) 1985-1986, 1988-1989, 1992-1996, 1998, 2000-2016 Free
+;; Software Foundation, Inc.
+
+;; Author: Roland McGrath <roland@gnu.org>
+;; Maintainer: emacs-devel@gnu.org
+;; Keywords: tools
+
+;; 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/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ring)
+(require 'button)
+(require 'xref)
+
+;;;###autoload
+(defvar tags-file-name nil
+ "File name of tags table.
+To switch to a new tags table, setting this variable is sufficient.
+If you set this variable, do not also set `tags-table-list'.
+Use the `etags' program to make a tags table file.")
+;; Make M-x set-variable tags-file-name like M-x visit-tags-table.
+;;;###autoload (put 'tags-file-name 'variable-interactive (purecopy "fVisit tags table: "))
+;;;###autoload (put 'tags-file-name 'safe-local-variable 'stringp)
+
+(defgroup etags nil "Tags tables."
+ :group 'tools)
+
+;;;###autoload
+(defcustom tags-case-fold-search 'default
+ "Whether tags operations should be case-sensitive.
+A value of t means case-insensitive, a value of nil means case-sensitive.
+Any other value means use the setting of `case-fold-search'."
+ :group 'etags
+ :type '(choice (const :tag "Case-sensitive" nil)
+ (const :tag "Case-insensitive" t)
+ (other :tag "Use default" default))
+ :version "21.1")
+
+;;;###autoload
+;; Use `visit-tags-table-buffer' to cycle through tags tables in this list.
+(defcustom tags-table-list nil
+ "List of file names of tags tables to search.
+An element that is a directory means the file \"TAGS\" in that directory.
+To switch to a new list of tags tables, setting this variable is sufficient.
+If you set this variable, do not also set `tags-file-name'.
+Use the `etags' program to make a tags table file."
+ :group 'etags
+ :type '(repeat file))
+
+;;;###autoload
+(defcustom tags-compression-info-list
+ (purecopy '("" ".Z" ".bz2" ".gz" ".xz" ".tgz"))
+ "List of extensions tried by etags when `auto-compression-mode' is on.
+An empty string means search the non-compressed file."
+ :version "24.1" ; added xz
+ :type '(repeat string)
+ :group 'etags)
+
+;; !!! tags-compression-info-list should probably be replaced by access
+;; to directory list and matching jka-compr-compression-info-list. Currently,
+;; this implementation forces each modification of
+;; jka-compr-compression-info-list to be reflected in this var.
+;; An alternative could be to say that introducing a special
+;; element in this list (e.g. t) means : try at this point
+;; using directory listing and regexp matching using
+;; jka-compr-compression-info-list.
+
+
+;;;###autoload
+(defcustom tags-add-tables 'ask-user
+ "Control whether to add a new tags table to the current list.
+t means do; nil means don't (always start a new list).
+Any other value means ask the user whether to add a new tags table
+to the current list (as opposed to starting a new list)."
+ :group 'etags
+ :type '(choice (const :tag "Do" t)
+ (const :tag "Don't" nil)
+ (other :tag "Ask" ask-user)))
+
+(defcustom tags-revert-without-query nil
+ "Non-nil means reread a TAGS table without querying, if it has changed."
+ :group 'etags
+ :type 'boolean)
+
+(defvar tags-table-computed-list nil
+ "List of tags tables to search, computed from `tags-table-list'.
+This includes tables implicitly included by other tables. The list is not
+always complete: the included tables of a table are not known until that
+table is read into core. An element that is t is a placeholder
+indicating that the preceding element is a table that has not been read
+into core and might contain included tables to search.
+See `tags-table-check-computed-list'.")
+
+(defvar tags-table-computed-list-for nil
+ "Value of `tags-table-list' that `tags-table-computed-list' corresponds to.
+If `tags-table-list' changes, `tags-table-computed-list' is thrown away and
+recomputed; see `tags-table-check-computed-list'.")
+
+(defvar tags-table-list-pointer nil
+ "Pointer into `tags-table-computed-list' for the current state of searching.
+Use `visit-tags-table-buffer' to cycle through tags tables in this list.")
+
+(defvar tags-table-list-started-at nil
+ "Pointer into `tags-table-computed-list', where the current search started.")
+
+(defvar tags-table-set-list nil
+ "List of sets of tags table which have been used together in the past.
+Each element is a list of strings which are file names.")
+
+;;;###autoload
+(defcustom find-tag-hook nil
+ "Hook to be run by \\[find-tag] after finding a tag. See `run-hooks'.
+The value in the buffer in which \\[find-tag] is done is used,
+not the value in the buffer \\[find-tag] goes to."
+ :group 'etags
+ :type 'hook)
+
+;;;###autoload
+(defcustom find-tag-default-function nil
+ "A function of no arguments used by \\[find-tag] to pick a default tag.
+If nil, and the symbol that is the value of `major-mode'
+has a `find-tag-default-function' property (see `put'), that is used.
+Otherwise, `find-tag-default' is used."
+ :group 'etags
+ :type '(choice (const nil) function))
+
+(define-obsolete-variable-alias 'find-tag-marker-ring-length
+ 'xref-marker-ring-length "25.1")
+
+(defcustom tags-tag-face 'default
+ "Face for tags in the output of `tags-apropos'."
+ :group 'etags
+ :type 'face
+ :version "21.1")
+
+(defcustom tags-apropos-verbose nil
+ "If non-nil, print the name of the tags file in the *Tags List* buffer."
+ :group 'etags
+ :type 'boolean
+ :version "21.1")
+
+(defcustom tags-apropos-additional-actions nil
+ "Specify additional actions for `tags-apropos'.
+
+If non-nil, value should be a list of triples (TITLE FUNCTION
+TO-SEARCH). For each triple, `tags-apropos' processes TO-SEARCH and
+lists tags from it. TO-SEARCH should be an alist, obarray, or symbol.
+If it is a symbol, the symbol's value is used.
+TITLE, a string, is a title used to label the additional list of tags.
+FUNCTION is a function to call when a symbol is selected in the
+*Tags List* buffer. It will be called with one argument SYMBOL which
+is the symbol being selected.
+
+Example value:
+
+ '((\"Emacs Lisp\" Info-goto-emacs-command-node obarray)
+ (\"Common Lisp\" common-lisp-hyperspec common-lisp-hyperspec-obarray)
+ (\"SCWM\" scwm-documentation scwm-obarray))"
+ :group 'etags
+ :type '(repeat (list (string :tag "Title")
+ function
+ (sexp :tag "Tags to search")))
+ :version "21.1")
+
+(defvaralias 'find-tag-marker-ring 'xref--marker-ring)
+(make-obsolete-variable
+ 'find-tag-marker-ring
+ "use `xref-push-marker-stack' or `xref-pop-marker-stack' instead."
+ "25.1")
+
+(defvar default-tags-table-function nil
+ "If non-nil, a function to choose a default tags file for a buffer.
+This function receives no arguments and should return the default
+tags table file to use for the current buffer.")
+
+(defvar tags-location-ring (make-ring xref-marker-ring-length)
+ "Ring of markers which are locations visited by \\[find-tag].
+Pop back to the last location with \\[negative-argument] \\[find-tag].")
+\f
+;; Tags table state.
+;; These variables are local in tags table buffers.
+
+(defvar tags-table-files nil
+ "List of file names covered by current tags table.
+nil means it has not yet been computed;
+use function `tags-table-files' to do so.")
+
+(defvar tags-completion-table nil
+ "Obarray of tag names defined in current tags table.")
+
+(defvar tags-included-tables nil
+ "List of tags tables included by the current tags table.")
+
+(defvar next-file-list nil
+ "List of files for \\[next-file] to process.")
+\f
+;; Hooks for file formats.
+
+(defvar tags-table-format-functions '(etags-recognize-tags-table
+ tags-recognize-empty-tags-table)
+ "Hook to be called in a tags table buffer to identify the type of tags table.
+The functions are called in order, with no arguments,
+until one returns non-nil. The function should make buffer-local bindings
+of the format-parsing tags function variables if successful.")
+
+(defvar file-of-tag-function nil
+ "Function to do the work of `file-of-tag' (which see).
+One optional argument, a boolean specifying to return complete path (nil) or
+relative path (non-nil).")
+(defvar tags-table-files-function nil
+ "Function to do the work of function `tags-table-files' (which see).")
+(defvar tags-completion-table-function nil
+ "Function to build the `tags-completion-table'.")
+(defvar snarf-tag-function nil
+ "Function to get info about a matched tag for `goto-tag-location-function'.
+One optional argument, specifying to use explicit tag (non-nil) or not (nil).
+The default is nil.")
+(defvar goto-tag-location-function nil
+ "Function of to go to the location in the buffer specified by a tag.
+One argument, the tag info returned by `snarf-tag-function'.")
+(defvar find-tag-regexp-search-function nil
+ "Search function passed to `find-tag-in-order' for finding a regexp tag.")
+(defvar find-tag-regexp-tag-order nil
+ "Tag order passed to `find-tag-in-order' for finding a regexp tag.")
+(defvar find-tag-regexp-next-line-after-failure-p nil
+ "Flag passed to `find-tag-in-order' for finding a regexp tag.")
+(defvar find-tag-search-function nil
+ "Search function passed to `find-tag-in-order' for finding a tag.")
+(defvar find-tag-tag-order nil
+ "Tag order passed to `find-tag-in-order' for finding a tag.")
+(defvar find-tag-next-line-after-failure-p nil
+ "Flag passed to `find-tag-in-order' for finding a tag.")
+(defvar list-tags-function nil
+ "Function to do the work of `list-tags' (which see).")
+(defvar tags-apropos-function nil
+ "Function to do the work of `tags-apropos' (which see).")
+(defvar tags-included-tables-function nil
+ "Function to do the work of function `tags-included-tables' (which see).")
+(defvar verify-tags-table-function nil
+ "Function to return t if current buffer contains valid tags file.")
+\f
+(defun initialize-new-tags-table ()
+ "Initialize the tags table in the current buffer.
+Return non-nil if it is a valid tags table, and
+in that case, also make the tags table state variables
+buffer-local and set them to nil."
+ (set (make-local-variable 'tags-table-files) nil)
+ (set (make-local-variable 'tags-completion-table) nil)
+ (set (make-local-variable 'tags-included-tables) nil)
+ ;; We used to initialize find-tag-marker-ring and tags-location-ring
+ ;; here, to new empty rings. But that is wrong, because those
+ ;; are global.
+
+ ;; Value is t if we have found a valid tags table buffer.
+ (run-hook-with-args-until-success 'tags-table-format-functions))
+
+;;;###autoload
+(defun tags-table-mode ()
+ "Major mode for tags table file buffers."
+ (interactive)
+ (setq major-mode 'tags-table-mode ;FIXME: Use define-derived-mode.
+ mode-name "Tags Table"
+ buffer-undo-list t)
+ (initialize-new-tags-table))
+
+;;;###autoload
+(defun visit-tags-table (file &optional local)
+ "Tell tags commands to use tags table file FILE.
+FILE should be the name of a file created with the `etags' program.
+A directory name is ok too; it means file TAGS in that directory.
+
+Normally \\[visit-tags-table] sets the global value of `tags-file-name'.
+With a prefix arg, set the buffer-local value instead.
+When you find a tag with \\[find-tag], the buffer it finds the tag
+in is given a local value of this variable which is the name of the tags
+file the tag was in."
+ (interactive (list (read-file-name "Visit tags table (default TAGS): "
+ default-directory
+ (expand-file-name "TAGS"
+ default-directory)
+ t)
+ current-prefix-arg))
+ (or (stringp file) (signal 'wrong-type-argument (list 'stringp file)))
+ ;; Bind tags-file-name so we can control below whether the local or
+ ;; global value gets set.
+ ;; Calling visit-tags-table-buffer with tags-file-name set to FILE will
+ ;; initialize a buffer for FILE and set tags-file-name to the
+ ;; fully-expanded name.
+ (let ((tags-file-name file))
+ (save-excursion
+ (or (visit-tags-table-buffer file)
+ (signal 'file-error (list "Visiting tags table"
+ "No such file or directory"
+ file)))
+ ;; Set FILE to the expanded name.
+ (setq file tags-file-name)))
+ (if local
+ ;; Set the local value of tags-file-name.
+ (set (make-local-variable 'tags-file-name) file)
+ ;; Set the global value of tags-file-name.
+ (setq-default tags-file-name file)))
+
+(defun tags-table-check-computed-list ()
+ "Compute `tags-table-computed-list' from `tags-table-list' if necessary."
+ (let ((expanded-list (mapcar 'tags-expand-table-name tags-table-list)))
+ (or (equal tags-table-computed-list-for expanded-list)
+ ;; The list (or default-directory) has changed since last computed.
+ (let* ((compute-for (mapcar 'copy-sequence expanded-list))
+ (tables (copy-sequence compute-for)) ;Mutated in the loop.
+ (computed nil)
+ table-buffer)
+
+ (while tables
+ (setq computed (cons (car tables) computed)
+ table-buffer (get-file-buffer (car tables)))
+ (if (and table-buffer
+ ;; There is a buffer visiting the file. Now make sure
+ ;; it is initialized as a tag table buffer.
+ (save-excursion
+ (tags-verify-table (buffer-file-name table-buffer))))
+ (with-current-buffer table-buffer
+ ;; Needed so long as etags-tags-included-tables
+ ;; does not save-excursion.
+ (save-excursion
+ (if (tags-included-tables)
+ ;; Insert the included tables into the list we
+ ;; are processing.
+ (setcdr tables (nconc (mapcar 'tags-expand-table-name
+ (tags-included-tables))
+ (cdr tables))))))
+ ;; This table is not in core yet. Insert a placeholder
+ ;; saying we must read it into core to check for included
+ ;; tables before searching the next table in the list.
+ (setq computed (cons t computed)))
+ (setq tables (cdr tables)))
+
+ ;; Record the tags-table-list value (and the context of the
+ ;; current directory) we computed from.
+ (setq tags-table-computed-list-for compute-for
+ tags-table-computed-list (nreverse computed))))))
+
+(defun tags-table-extend-computed-list ()
+ "Extend `tags-table-computed-list' to remove the first t placeholder.
+
+An element of the list that is t is a placeholder indicating that the
+preceding element is a table that has not been read in and might
+contain included tables to search. This function reads in the first
+such table and puts its included tables into the list."
+ (let ((list tags-table-computed-list))
+ (while (not (eq (nth 1 list) t))
+ (setq list (cdr list)))
+ (save-excursion
+ (if (tags-verify-table (car list))
+ ;; We are now in the buffer visiting (car LIST). Extract its
+ ;; list of included tables and insert it into the computed list.
+ (let ((tables (tags-included-tables))
+ (computed nil)
+ table-buffer)
+ (while tables
+ (setq computed (cons (car tables) computed)
+ table-buffer (get-file-buffer (car tables)))
+ (if table-buffer
+ (with-current-buffer table-buffer
+ (if (tags-included-tables)
+ ;; Insert the included tables into the list we
+ ;; are processing.
+ (setcdr tables (append (tags-included-tables)
+ tables))))
+ ;; This table is not in core yet. Insert a placeholder
+ ;; saying we must read it into core to check for included
+ ;; tables before searching the next table in the list.
+ (setq computed (cons t computed)))
+ (setq tables (cdr tables)))
+ (setq computed (nreverse computed))
+ ;; COMPUTED now contains the list of included tables (and
+ ;; tables included by them, etc.). Now splice this into the
+ ;; current list.
+ (setcdr list (nconc computed (cdr (cdr list)))))
+ ;; It was not a valid table, so just remove the following placeholder.
+ (setcdr list (cdr (cdr list)))))))
+
+(defun tags-expand-table-name (file)
+ "Expand tags table name FILE into a complete file name."
+ (setq file (expand-file-name file))
+ (if (file-directory-p file)
+ (expand-file-name "TAGS" file)
+ file))
+
+;; Like member, but comparison is done after tags-expand-table-name on both
+;; sides and elements of LIST that are t are skipped.
+(defun tags-table-list-member (file list)
+ "Like (member FILE LIST) after applying `tags-expand-table-name'.
+More precisely, apply `tags-expand-table-name' to FILE
+and each element of LIST, returning the link whose car is the first match.
+If an element of LIST is t, ignore it."
+ (setq file (tags-expand-table-name file))
+ (while (and list
+ (or (eq (car list) t)
+ (not (string= file (tags-expand-table-name (car list))))))
+ (setq list (cdr list)))
+ list)
+
+(defun tags-verify-table (file)
+ "Read FILE into a buffer and verify that it is a valid tags table.
+Sets the current buffer to one visiting FILE (if it exists).
+Returns non-nil if it is a valid table."
+ (if (get-file-buffer file)
+ ;; The file is already in a buffer. Check for the visited file
+ ;; having changed since we last used it.
+ (progn
+ (set-buffer (get-file-buffer file))
+ (or verify-tags-table-function (tags-table-mode))
+ (if (or (verify-visited-file-modtime (current-buffer))
+ ;; Decide whether to revert the file.
+ ;; revert-without-query can say to revert
+ ;; or the user can say to revert.
+ (not (or (let ((tail revert-without-query)
+ (found nil))
+ (while tail
+ (if (string-match (car tail) buffer-file-name)
+ (setq found t))
+ (setq tail (cdr tail)))
+ found)
+ tags-revert-without-query
+ (yes-or-no-p
+ (format "Tags file %s has changed, read new contents? "
+ file)))))
+ (and verify-tags-table-function
+ (funcall verify-tags-table-function))
+ (revert-buffer t t)
+ (tags-table-mode)))
+ (when (file-exists-p file)
+ (let* ((buf (find-file-noselect file))
+ (newfile (buffer-file-name buf)))
+ (unless (string= file newfile)
+ ;; find-file-noselect has changed the file name.
+ ;; Propagate the change to tags-file-name and tags-table-list.
+ (let ((tail (member file tags-table-list)))
+ (if tail (setcar tail newfile)))
+ (if (eq file tags-file-name) (setq tags-file-name newfile)))
+ ;; Only change buffer now that we're done using potentially
+ ;; buffer-local variables.
+ (set-buffer buf)
+ (tags-table-mode)))))
+
+;; Subroutine of visit-tags-table-buffer. Search the current tags tables
+;; for one that has tags for THIS-FILE (or that includes a table that
+;; does). Return the name of the first table listing THIS-FILE; if
+;; the table is one included by another table, it is the master table that
+;; we return. If CORE-ONLY is non-nil, check only tags tables that are
+;; already in buffers--don't visit any new files.
+(defun tags-table-including (this-file core-only)
+ "Search current tags tables for tags for THIS-FILE.
+Subroutine of `visit-tags-table-buffer'.
+Looks for a tags table that has such tags or that includes a table
+that has them. Returns the name of the first such table.
+Non-nil CORE-ONLY means check only tags tables that are already in
+buffers. If CORE-ONLY is nil, it is ignored."
+ (let ((tables tags-table-computed-list)
+ (found nil))
+ ;; Loop over the list, looking for a table containing tags for THIS-FILE.
+ (while (and (not found)
+ tables)
+
+ (if core-only
+ ;; Skip tables not in core.
+ (while (eq (nth 1 tables) t)
+ (setq tables (cdr (cdr tables))))
+ (if (eq (nth 1 tables) t)
+ ;; This table has not been read into core yet. Read it in now.
+ (tags-table-extend-computed-list)))
+
+ (if tables
+ ;; Select the tags table buffer and get the file list up to date.
+ (let ((tags-file-name (car tables)))
+ (visit-tags-table-buffer 'same)
+ (if (member this-file (mapcar 'expand-file-name
+ (tags-table-files)))
+ ;; Found it.
+ (setq found tables))))
+ (setq tables (cdr tables)))
+ (if found
+ ;; Now determine if the table we found was one included by another
+ ;; table, not explicitly listed. We do this by checking each
+ ;; element of the computed list to see if it appears in the user's
+ ;; explicit list; the last element we will check is FOUND itself.
+ ;; Then we return the last one which did in fact appear in
+ ;; tags-table-list.
+ (let ((could-be nil)
+ (elt tags-table-computed-list))
+ (while (not (eq elt (cdr found)))
+ (if (tags-table-list-member (car elt) tags-table-list)
+ ;; This table appears in the user's list, so it could be
+ ;; the one which includes the table we found.
+ (setq could-be (car elt)))
+ (setq elt (cdr elt))
+ (if (eq t (car elt))
+ (setq elt (cdr elt))))
+ ;; The last element we found in the computed list before FOUND
+ ;; that appears in the user's list will be the table that
+ ;; included the one we found.
+ could-be))))
+
+(defun tags-next-table ()
+ "Move `tags-table-list-pointer' along and set `tags-file-name'.
+Subroutine of `visit-tags-table-buffer'.\
+Returns nil when out of tables."
+ ;; If there is a placeholder element next, compute the list to replace it.
+ (while (eq (nth 1 tags-table-list-pointer) t)
+ (tags-table-extend-computed-list))
+
+ ;; Go to the next table in the list.
+ (setq tags-table-list-pointer (cdr tags-table-list-pointer))
+ (or tags-table-list-pointer
+ ;; Wrap around.
+ (setq tags-table-list-pointer tags-table-computed-list))
+
+ (if (eq tags-table-list-pointer tags-table-list-started-at)
+ ;; We have come full circle. No more tables.
+ (setq tags-table-list-pointer nil)
+ ;; Set tags-file-name to the name from the list. It is already expanded.
+ (setq tags-file-name (car tags-table-list-pointer))))
+
+;;;###autoload
+(defun visit-tags-table-buffer (&optional cont)
+ "Select the buffer containing the current tags table.
+If optional arg is a string, visit that file as a tags table.
+If optional arg is t, visit the next table in `tags-table-list'.
+If optional arg is the atom `same', don't look for a new table;
+ just select the buffer visiting `tags-file-name'.
+If arg is nil or absent, choose a first buffer from information in
+ `tags-file-name', `tags-table-list', `tags-table-list-pointer'.
+Returns t if it visits a tags table, or nil if there are no more in the list."
+
+ ;; Set tags-file-name to the tags table file we want to visit.
+ (cond ((eq cont 'same)
+ ;; Use the ambient value of tags-file-name.
+ (or tags-file-name
+ (user-error "%s"
+ (substitute-command-keys
+ (concat "No tags table in use; "
+ "use \\[visit-tags-table] to select one")))))
+ ((eq t cont)
+ ;; Find the next table.
+ (if (tags-next-table)
+ ;; Skip over nonexistent files.
+ (while (and (not (or (get-file-buffer tags-file-name)
+ (file-exists-p tags-file-name)))
+ (tags-next-table)))))
+ (t
+ ;; Pick a table out of our hat.
+ (tags-table-check-computed-list) ;Get it up to date, we might use it.
+ (setq tags-file-name
+ (or
+ ;; If passed a string, use that.
+ (if (stringp cont)
+ (prog1 cont
+ (setq cont nil)))
+ ;; First, try a local variable.
+ (cdr (assq 'tags-file-name (buffer-local-variables)))
+ ;; Second, try a user-specified function to guess.
+ (and default-tags-table-function
+ (funcall default-tags-table-function))
+ ;; Third, look for a tags table that contains tags for the
+ ;; current buffer's file. If one is found, the lists will
+ ;; be frobnicated, and CONT will be set non-nil so we don't
+ ;; do it below.
+ (and buffer-file-name
+ (or
+ ;; First check only tables already in buffers.
+ (tags-table-including buffer-file-name t)
+ ;; Since that didn't find any, now do the
+ ;; expensive version: reading new files.
+ (tags-table-including buffer-file-name nil)))
+ ;; Fourth, use the user variable tags-file-name, if it is
+ ;; not already in the current list.
+ (and tags-file-name
+ (not (tags-table-list-member tags-file-name
+ tags-table-computed-list))
+ tags-file-name)
+ ;; Fifth, use the user variable giving the table list.
+ ;; Find the first element of the list that actually exists.
+ (let ((list tags-table-list)
+ file)
+ (while (and list
+ (setq file (tags-expand-table-name (car list)))
+ (not (get-file-buffer file))
+ (not (file-exists-p file)))
+ (setq list (cdr list)))
+ (car list))
+ ;; Finally, prompt the user for a file name.
+ (expand-file-name
+ (read-file-name "Visit tags table (default TAGS): "
+ default-directory
+ "TAGS"
+ t))))))
+
+ ;; Expand the table name into a full file name.
+ (setq tags-file-name (tags-expand-table-name tags-file-name))
+
+ (unless (and (eq cont t) (null tags-table-list-pointer))
+ ;; Verify that tags-file-name names a valid tags table.
+ ;; Bind another variable with the value of tags-file-name
+ ;; before we switch buffers, in case tags-file-name is buffer-local.
+ (let ((curbuf (current-buffer))
+ (local-tags-file-name tags-file-name))
+ (if (tags-verify-table local-tags-file-name)
+
+ ;; We have a valid tags table.
+ (progn
+ ;; Bury the tags table buffer so it
+ ;; doesn't get in the user's way.
+ (bury-buffer (current-buffer))
+
+ ;; If this was a new table selection (CONT is nil), make
+ ;; sure tags-table-list includes the chosen table, and
+ ;; update the list pointer variables.
+ (or cont
+ ;; Look in the list for the table we chose.
+ (let ((found (tags-table-list-member
+ local-tags-file-name
+ tags-table-computed-list)))
+ (if found
+ ;; There it is. Just switch to it.
+ (setq tags-table-list-pointer found
+ tags-table-list-started-at found)
+
+ ;; The table is not in the current set.
+ ;; Try to find it in another previously used set.
+ (let ((sets tags-table-set-list))
+ (while (and sets
+ (not (tags-table-list-member
+ local-tags-file-name
+ (car sets))))
+ (setq sets (cdr sets)))
+ (if sets
+ ;; Found in some other set. Switch to that set.
+ (progn
+ (or (memq tags-table-list tags-table-set-list)
+ ;; Save the current list.
+ (setq tags-table-set-list
+ (cons tags-table-list
+ tags-table-set-list)))
+ (setq tags-table-list (car sets)))
+
+ ;; Not found in any existing set.
+ (if (and tags-table-list
+ (or (eq t tags-add-tables)
+ (and tags-add-tables
+ (y-or-n-p
+ (concat "Keep current list of "
+ "tags tables also? ")))))
+ ;; Add it to the current list.
+ (setq tags-table-list (cons local-tags-file-name
+ tags-table-list))
+
+ ;; Make a fresh list, and store the old one.
+ (message "Starting a new list of tags tables")
+ (or (null tags-table-list)
+ (memq tags-table-list tags-table-set-list)
+ (setq tags-table-set-list
+ (cons tags-table-list
+ tags-table-set-list)))
+ ;; Clear out buffers holding old tables.
+ (dolist (table tags-table-list)
+ ;; The list can contain items t.
+ (if (stringp table)
+ (let ((buffer (find-buffer-visiting table)))
+ (if buffer
+ (kill-buffer buffer)))))
+ (setq tags-table-list (list local-tags-file-name))))
+
+ ;; Recompute tags-table-computed-list.
+ (tags-table-check-computed-list)
+ ;; Set the tags table list state variables to start
+ ;; over from tags-table-computed-list.
+ (setq tags-table-list-started-at tags-table-computed-list
+ tags-table-list-pointer
+ tags-table-computed-list)))))
+
+ ;; Return of t says the tags table is valid.
+ t)
+
+ ;; The buffer was not valid. Don't use it again.
+ (set-buffer curbuf)
+ (kill-local-variable 'tags-file-name)
+ (if (eq local-tags-file-name tags-file-name)
+ (setq tags-file-name nil))
+ (user-error (if (file-exists-p local-tags-file-name)
+ "File %s is not a valid tags table"
+ "File %s does not exist")
+ local-tags-file-name)))))
+
+(defun tags-reset-tags-tables ()
+ "Reset tags state to cancel effect of any previous \\[visit-tags-table] or \\[find-tag]."
+ (interactive)
+ ;; Clear out the markers we are throwing away.
+ (let ((i 0))
+ (while (< i xref-marker-ring-length)
+ (if (aref (cddr tags-location-ring) i)
+ (set-marker (aref (cddr tags-location-ring) i) nil))
+ (setq i (1+ i))))
+ (xref-clear-marker-stack)
+ (setq tags-file-name nil
+ tags-location-ring (make-ring xref-marker-ring-length)
+ tags-table-list nil
+ tags-table-computed-list nil
+ tags-table-computed-list-for nil
+ tags-table-list-pointer nil
+ tags-table-list-started-at nil
+ tags-table-set-list nil))
+\f
+(defun file-of-tag (&optional relative)
+ "Return the file name of the file whose tags point is within.
+Assumes the tags table is the current buffer.
+If RELATIVE is non-nil, file name returned is relative to tags
+table file's directory. If RELATIVE is nil, file name returned
+is complete."
+ (funcall file-of-tag-function relative))
+
+;;;###autoload
+(defun tags-table-files ()
+ "Return a list of files in the current tags table.
+Assumes the tags table is the current buffer. The file names are returned
+as they appeared in the `etags' command that created the table, usually
+without directory names."
+ (or tags-table-files
+ (setq tags-table-files
+ (funcall tags-table-files-function))))
+
+(defun tags-included-tables ()
+ "Return a list of tags tables included by the current table.
+Assumes the tags table is the current buffer."
+ (or tags-included-tables
+ (setq tags-included-tables (funcall tags-included-tables-function))))
+\f
+(defun tags-completion-table ()
+ "Build `tags-completion-table' on demand.
+The tags included in the completion table are those in the current
+tags table and its (recursively) included tags tables."
+ (or tags-completion-table
+ ;; No cached value for this buffer.
+ (condition-case ()
+ (let (current-table combined-table)
+ (message "Making tags completion table for %s..." buffer-file-name)
+ (save-excursion
+ ;; Iterate over the current list of tags tables.
+ (while (visit-tags-table-buffer (and combined-table t))
+ ;; Find possible completions in this table.
+ (setq current-table (funcall tags-completion-table-function))
+ ;; Merge this buffer's completions into the combined table.
+ (if combined-table
+ (mapatoms
+ (lambda (sym) (intern (symbol-name sym) combined-table))
+ current-table)
+ (setq combined-table current-table))))
+ (message "Making tags completion table for %s...done"
+ buffer-file-name)
+ ;; Cache the result in a buffer-local variable.
+ (setq tags-completion-table combined-table))
+ (quit (message "Tags completion table construction aborted.")
+ (setq tags-completion-table nil)))))
+
+;;;###autoload
+(defun tags-lazy-completion-table ()
+ (let ((buf (current-buffer)))
+ (lambda (string pred action)
+ (with-current-buffer buf
+ (save-excursion
+ ;; If we need to ask for the tag table, allow that.
+ (let ((enable-recursive-minibuffers t))
+ (visit-tags-table-buffer))
+ (complete-with-action action (tags-completion-table) string pred))))))
+
+;;;###autoload (defun tags-completion-at-point-function ()
+;;;###autoload (if (or tags-table-list tags-file-name)
+;;;###autoload (progn
+;;;###autoload (load "etags")
+;;;###autoload (tags-completion-at-point-function))))
+
+(defun tags-completion-at-point-function ()
+ "Using tags, return a completion table for the text around point.
+If no tags table is loaded, do nothing and return nil."
+ (when (or tags-table-list tags-file-name)
+ (let ((completion-ignore-case (if (memq tags-case-fold-search '(t nil))
+ tags-case-fold-search
+ case-fold-search))
+ (pattern (funcall (or find-tag-default-function
+ (get major-mode 'find-tag-default-function)
+ 'find-tag-default)))
+ beg)
+ (when pattern
+ (save-excursion
+ (forward-char (1- (length pattern)))
+ (search-backward pattern)
+ (setq beg (point))
+ (forward-char (length pattern))
+ (list beg (point) (tags-lazy-completion-table) :exclusive 'no))))))
+\f
+(defun find-tag-tag (string)
+ "Read a tag name, with defaulting and completion."
+ (let* ((completion-ignore-case (if (memq tags-case-fold-search '(t nil))
+ tags-case-fold-search
+ case-fold-search))
+ (default (funcall (or find-tag-default-function
+ (get major-mode 'find-tag-default-function)
+ 'find-tag-default)))
+ (spec (completing-read (if default
+ (format "%s (default %s): "
+ (substring string 0 (string-match "[ :]+\\'" string))
+ default)
+ string)
+ (tags-lazy-completion-table)
+ nil nil nil nil default)))
+ (if (equal spec "")
+ (or default (user-error "There is no default tag"))
+ spec)))
+
+(defvar last-tag nil
+ "Last tag found by \\[find-tag].")
+
+(defun find-tag-interactive (prompt &optional no-default)
+ "Get interactive arguments for tag functions.
+The functions using this are `find-tag-noselect',
+`find-tag-other-window', and `find-tag-regexp'."
+ (if (and current-prefix-arg last-tag)
+ (list nil (if (< (prefix-numeric-value current-prefix-arg) 0)
+ '-
+ t))
+ (list (if no-default
+ (read-string prompt)
+ (find-tag-tag prompt)))))
+
+(defvar find-tag-history nil) ; Doc string?
+
+;; Dynamic bondage:
+(defvar etags-case-fold-search)
+(defvar etags-syntax-table)
+(defvar local-find-tag-hook)
+
+;;;###autoload
+(defun find-tag-noselect (tagname &optional next-p regexp-p)
+ "Find tag (in current tags table) whose name contains TAGNAME.
+Returns the buffer containing the tag's definition and moves its point there,
+but does not select the buffer.
+The default for TAGNAME is the expression in the buffer near point.
+
+If second arg NEXT-P is t (interactively, with prefix arg), search for
+another tag that matches the last tagname or regexp used. When there are
+multiple matches for a tag, more exact matches are found first. If NEXT-P
+is the atom `-' (interactively, with prefix arg that is a negative number
+or just \\[negative-argument]), pop back to the previous tag gone to.
+
+If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
+
+A marker representing the point when this command is invoked is pushed
+onto a ring and may be popped back to with \\[pop-tag-mark].
+Contrast this with the ring of marks gone to by the command.
+
+See documentation of variable `tags-file-name'."
+ (interactive (find-tag-interactive "Find tag: "))
+
+ (setq find-tag-history (cons tagname find-tag-history))
+ ;; Save the current buffer's value of `find-tag-hook' before
+ ;; selecting the tags table buffer. For the same reason, save value
+ ;; of `tags-file-name' in case it has a buffer-local value.
+ (let ((local-find-tag-hook find-tag-hook))
+ (if (eq '- next-p)
+ ;; Pop back to a previous location.
+ (if (ring-empty-p tags-location-ring)
+ (user-error "No previous tag locations")
+ (let ((marker (ring-remove tags-location-ring 0)))
+ (prog1
+ ;; Move to the saved location.
+ (set-buffer (or (marker-buffer marker)
+ (error "The marked buffer has been deleted")))
+ (goto-char (marker-position marker))
+ ;; Kill that marker so it doesn't slow down editing.
+ (set-marker marker nil nil)
+ ;; Run the user's hook. Do we really want to do this for pop?
+ (run-hooks 'local-find-tag-hook))))
+ ;; Record whence we came.
+ (xref-push-marker-stack)
+ (if (and next-p last-tag)
+ ;; Find the same table we last used.
+ (visit-tags-table-buffer 'same)
+ ;; Pick a table to use.
+ (visit-tags-table-buffer)
+ ;; Record TAGNAME for a future call with NEXT-P non-nil.
+ (setq last-tag tagname))
+ ;; Record the location so we can pop back to it later.
+ (let ((marker (make-marker)))
+ (with-current-buffer
+ ;; find-tag-in-order does the real work.
+ (find-tag-in-order
+ (if (and next-p last-tag) last-tag tagname)
+ (if regexp-p
+ find-tag-regexp-search-function
+ find-tag-search-function)
+ (if regexp-p
+ find-tag-regexp-tag-order
+ find-tag-tag-order)
+ (if regexp-p
+ find-tag-regexp-next-line-after-failure-p
+ find-tag-next-line-after-failure-p)
+ (if regexp-p "matching" "containing")
+ (or (not next-p) (not last-tag)))
+ (set-marker marker (point))
+ (run-hooks 'local-find-tag-hook)
+ (ring-insert tags-location-ring marker)
+ (current-buffer))))))
+
+;;;###autoload
+(defun find-tag (tagname &optional next-p regexp-p)
+ "Find tag (in current tags table) whose name contains TAGNAME.
+Select the buffer containing the tag's definition, and move point there.
+The default for TAGNAME is the expression in the buffer around or before point.
+
+If second arg NEXT-P is t (interactively, with prefix arg), search for
+another tag that matches the last tagname or regexp used. When there are
+multiple matches for a tag, more exact matches are found first. If NEXT-P
+is the atom `-' (interactively, with prefix arg that is a negative number
+or just \\[negative-argument]), pop back to the previous tag gone to.
+
+If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
+
+A marker representing the point when this command is invoked is pushed
+onto a ring and may be popped back to with \\[pop-tag-mark].
+Contrast this with the ring of marks gone to by the command.
+
+See documentation of variable `tags-file-name'."
+ (interactive (find-tag-interactive "Find tag: "))
+ (let* ((buf (find-tag-noselect tagname next-p regexp-p))
+ (pos (with-current-buffer buf (point))))
+ (condition-case nil
+ (switch-to-buffer buf)
+ (error (pop-to-buffer buf)))
+ (goto-char pos)))
+
+;;;###autoload
+(defun find-tag-other-window (tagname &optional next-p regexp-p)
+ "Find tag (in current tags table) whose name contains TAGNAME.
+Select the buffer containing the tag's definition in another window, and
+move point there. The default for TAGNAME is the expression in the buffer
+around or before point.
+
+If second arg NEXT-P is t (interactively, with prefix arg), search for
+another tag that matches the last tagname or regexp used. When there are
+multiple matches for a tag, more exact matches are found first. If NEXT-P
+is negative (interactively, with prefix arg that is a negative number or
+just \\[negative-argument]), pop back to the previous tag gone to.
+
+If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
+
+A marker representing the point when this command is invoked is pushed
+onto a ring and may be popped back to with \\[pop-tag-mark].
+Contrast this with the ring of marks gone to by the command.
+
+See documentation of variable `tags-file-name'."
+ (declare (obsolete xref-find-definitions-other-window "25.1"))
+ (interactive (find-tag-interactive "Find tag other window: "))
+
+ ;; This hair is to deal with the case where the tag is found in the
+ ;; selected window's buffer; without the hair, point is moved in both
+ ;; windows. To prevent this, we save the selected window's point before
+ ;; doing find-tag-noselect, and restore it after.
+ (let* ((window-point (window-point))
+ (tagbuf (find-tag-noselect tagname next-p regexp-p))
+ (tagpoint (progn (set-buffer tagbuf) (point))))
+ (set-window-point (prog1
+ (selected-window)
+ (switch-to-buffer-other-window tagbuf)
+ ;; We have to set this new window's point; it
+ ;; might already have been displaying a
+ ;; different portion of tagbuf, in which case
+ ;; switch-to-buffer-other-window doesn't set
+ ;; the window's point from the buffer.
+ (set-window-point (selected-window) tagpoint))
+ window-point)))
+
+;;;###autoload
+(defun find-tag-other-frame (tagname &optional next-p)
+ "Find tag (in current tags table) whose name contains TAGNAME.
+Select the buffer containing the tag's definition in another frame, and
+move point there. The default for TAGNAME is the expression in the buffer
+around or before point.
+
+If second arg NEXT-P is t (interactively, with prefix arg), search for
+another tag that matches the last tagname or regexp used. When there are
+multiple matches for a tag, more exact matches are found first. If NEXT-P
+is negative (interactively, with prefix arg that is a negative number or
+just \\[negative-argument]), pop back to the previous tag gone to.
+
+If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
+
+A marker representing the point when this command is invoked is pushed
+onto a ring and may be popped back to with \\[pop-tag-mark].
+Contrast this with the ring of marks gone to by the command.
+
+See documentation of variable `tags-file-name'."
+ (declare (obsolete xref-find-definitions-other-frame "25.1"))
+ (interactive (find-tag-interactive "Find tag other frame: "))
+ (let ((pop-up-frames t))
+ (find-tag-other-window tagname next-p)))
+
+;;;###autoload
+(defun find-tag-regexp (regexp &optional next-p other-window)
+ "Find tag (in current tags table) whose name matches REGEXP.
+Select the buffer containing the tag's definition and move point there.
+
+If second arg NEXT-P is t (interactively, with prefix arg), search for
+another tag that matches the last tagname or regexp used. When there are
+multiple matches for a tag, more exact matches are found first. If NEXT-P
+is negative (interactively, with prefix arg that is a negative number or
+just \\[negative-argument]), pop back to the previous tag gone to.
+
+If third arg OTHER-WINDOW is non-nil, select the buffer in another window.
+
+A marker representing the point when this command is invoked is pushed
+onto a ring and may be popped back to with \\[pop-tag-mark].
+Contrast this with the ring of marks gone to by the command.
+
+See documentation of variable `tags-file-name'."
+ (declare (obsolete xref-find-apropos "25.1"))
+ (interactive (find-tag-interactive "Find tag regexp: " t))
+ ;; We go through find-tag-other-window to do all the display hair there.
+ (funcall (if other-window 'find-tag-other-window 'find-tag)
+ regexp next-p t))
+
+;;;###autoload
+(defalias 'pop-tag-mark 'xref-pop-marker-stack)
+
+\f
+(defvar tag-lines-already-matched nil
+ "Matches remembered between calls.") ; Doc string: calls to what?
+
+(defun find-tag-in-order (pattern
+ search-forward-func
+ order
+ next-line-after-failure-p
+ matching
+ first-search)
+ "Internal tag-finding function.
+PATTERN is a string to pass to arg SEARCH-FORWARD-FUNC, and to any
+member of the function list ORDER. If ORDER is nil, use saved state
+to continue a previous search.
+
+Arg NEXT-LINE-AFTER-FAILURE-P is non-nil if after a failed match,
+point should be moved to the next line.
+
+Arg MATCHING is a string, an English `-ing' word, to be used in an
+error message."
+;; Algorithm is as follows:
+;; For each qualifier-func in ORDER, go to beginning of tags file, and
+;; perform inner loop: for each naive match for PATTERN found using
+;; SEARCH-FORWARD-FUNC, qualify the naive match using qualifier-func. If
+;; it qualifies, go to the specified line in the specified source file
+;; and return. Qualified matches are remembered to avoid repetition.
+;; State is saved so that the loop can be continued.
+ (let (file ;name of file containing tag
+ tag-info ;where to find the tag in FILE
+ (first-table t)
+ (tag-order order)
+ (match-marker (make-marker))
+ goto-func
+ (case-fold-search (if (memq tags-case-fold-search '(nil t))
+ tags-case-fold-search
+ case-fold-search))
+ )
+ (save-excursion
+
+ (if first-search
+ ;; This is the start of a search for a fresh tag.
+ ;; Clear the list of tags matched by the previous search.
+ ;; find-tag-noselect has already put us in the first tags table
+ ;; buffer before we got called.
+ (setq tag-lines-already-matched nil)
+ ;; Continuing to search for the tag specified last time.
+ ;; tag-lines-already-matched lists locations matched in previous
+ ;; calls so we don't visit the same tag twice if it matches twice
+ ;; during two passes with different qualification predicates.
+ ;; Switch to the current tags table buffer.
+ (visit-tags-table-buffer 'same))
+
+ ;; Get a qualified match.
+ (catch 'qualified-match-found
+
+ ;; Iterate over the list of tags tables.
+ (while (or first-table
+ (visit-tags-table-buffer t))
+
+ (and first-search first-table
+ ;; Start at beginning of tags file.
+ (goto-char (point-min)))
+
+ (setq first-table nil)
+
+ ;; Iterate over the list of ordering predicates.
+ (while order
+ (while (funcall search-forward-func pattern nil t)
+ ;; Naive match found. Qualify the match.
+ (and (funcall (car order) pattern)
+ ;; Make sure it is not a previous qualified match.
+ (not (member (set-marker match-marker (point-at-bol))
+ tag-lines-already-matched))
+ (throw 'qualified-match-found nil))
+ (if next-line-after-failure-p
+ (forward-line 1)))
+ ;; Try the next flavor of match.
+ (setq order (cdr order))
+ (goto-char (point-min)))
+ (setq order tag-order))
+ ;; We throw out on match, so only get here if there were no matches.
+ ;; Clear out the markers we use to avoid duplicate matches so they
+ ;; don't slow down editing and are immediately available for GC.
+ (while tag-lines-already-matched
+ (set-marker (car tag-lines-already-matched) nil nil)
+ (setq tag-lines-already-matched (cdr tag-lines-already-matched)))
+ (set-marker match-marker nil nil)
+ (user-error "No %stags %s %s" (if first-search "" "more ")
+ matching pattern))
+
+ ;; Found a tag; extract location info.
+ (beginning-of-line)
+ (setq tag-lines-already-matched (cons match-marker
+ tag-lines-already-matched))
+ ;; Expand the filename, using the tags table buffer's default-directory.
+ ;; We should be able to search for file-name backwards in file-of-tag:
+ ;; the beginning-of-line is ok except when positioned on a "file-name" tag.
+ (setq file (expand-file-name
+ (if (memq (car order) '(tag-exact-file-name-match-p
+ tag-file-name-match-p
+ tag-partial-file-name-match-p))
+ (save-excursion (forward-line 1)
+ (file-of-tag))
+ (file-of-tag)))
+ tag-info (funcall snarf-tag-function))
+
+ ;; Get the local value in the tags table buffer before switching buffers.
+ (setq goto-func goto-tag-location-function)
+ (tag-find-file-of-tag-noselect file)
+ (widen)
+ (push-mark)
+ (funcall goto-func tag-info)
+
+ ;; Return the buffer where the tag was found.
+ (current-buffer))))
+
+(defun tag-find-file-of-tag-noselect (file)
+ "Find the right line in the specified FILE."
+ ;; If interested in compressed-files, search files with extensions.
+ ;; Otherwise, search only the real file.
+ (let* ((buffer-search-extensions (if auto-compression-mode
+ tags-compression-info-list
+ '("")))
+ the-buffer
+ (file-search-extensions buffer-search-extensions))
+ ;; search a buffer visiting the file with each possible extension
+ ;; Note: there is a small inefficiency in find-buffer-visiting :
+ ;; truename is computed even if not needed. Not too sure about this
+ ;; but I suspect truename computation accesses the disk.
+ ;; It is maybe a good idea to optimize this find-buffer-visiting.
+ ;; An alternative would be to use only get-file-buffer
+ ;; but this looks less "sure" to find the buffer for the file.
+ (while (and (not the-buffer) buffer-search-extensions)
+ (setq the-buffer (find-buffer-visiting (concat file (car buffer-search-extensions))))
+ (setq buffer-search-extensions (cdr buffer-search-extensions)))
+ ;; if found a buffer but file modified, ensure we re-read !
+ (if (and the-buffer (not (verify-visited-file-modtime the-buffer)))
+ (find-file-noselect (buffer-file-name the-buffer)))
+ ;; if no buffer found, search for files with possible extensions on disk
+ (while (and (not the-buffer) file-search-extensions)
+ (if (not (file-exists-p (concat file (car file-search-extensions))))
+ (setq file-search-extensions (cdr file-search-extensions))
+ (setq the-buffer (find-file-noselect (concat file (car file-search-extensions))))))
+ (if (not the-buffer)
+ (if auto-compression-mode
+ (error "File %s (with or without extensions %s) not found" file tags-compression-info-list)
+ (error "File %s not found" file))
+ (set-buffer the-buffer))))
+
+(defun tag-find-file-of-tag (file) ; Doc string?
+ (let ((buf (tag-find-file-of-tag-noselect file)))
+ (condition-case nil
+ (switch-to-buffer buf)
+ (error (pop-to-buffer buf)))))
+\f
+;; `etags' TAGS file format support.
+
+(defun etags-recognize-tags-table ()
+ "If `etags-verify-tags-table', make buffer-local format variables.
+If current buffer is a valid etags TAGS file, then give it
+buffer-local values of tags table format variables."
+ (and (etags-verify-tags-table)
+ ;; It is annoying to flash messages on the screen briefly,
+ ;; and this message is not useful. -- rms
+ ;; (message "%s is an `etags' TAGS file" buffer-file-name)
+ (mapc (lambda (elt) (set (make-local-variable (car elt)) (cdr elt)))
+ '((file-of-tag-function . etags-file-of-tag)
+ (tags-table-files-function . etags-tags-table-files)
+ (tags-completion-table-function . etags-tags-completion-table)
+ (snarf-tag-function . etags-snarf-tag)
+ (goto-tag-location-function . etags-goto-tag-location)
+ (find-tag-regexp-search-function . re-search-forward)
+ (find-tag-regexp-tag-order . (tag-re-match-p))
+ (find-tag-regexp-next-line-after-failure-p . t)
+ (find-tag-search-function . search-forward)
+ (find-tag-tag-order . (tag-exact-file-name-match-p
+ tag-file-name-match-p
+ tag-exact-match-p
+ tag-implicit-name-match-p
+ tag-symbol-match-p
+ tag-word-match-p
+ tag-partial-file-name-match-p
+ tag-any-match-p))
+ (find-tag-next-line-after-failure-p . nil)
+ (list-tags-function . etags-list-tags)
+ (tags-apropos-function . etags-tags-apropos)
+ (tags-included-tables-function . etags-tags-included-tables)
+ (verify-tags-table-function . etags-verify-tags-table)
+ ))))
+
+(defun etags-verify-tags-table ()
+ "Return non-nil if the current buffer is a valid etags TAGS file."
+ ;; Use eq instead of = in case char-after returns nil.
+ (eq (char-after (point-min)) ?\f))
+
+(defun etags-file-of-tag (&optional relative) ; Doc string?
+ (save-excursion
+ (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n")
+ (let ((str (convert-standard-filename
+ (buffer-substring (match-beginning 1) (match-end 1)))))
+ (if relative
+ str
+ (expand-file-name str (file-truename default-directory))))))
+
+
+(defun etags-tags-completion-table () ; Doc string?
+ (let ((table (make-vector 511 0))
+ (progress-reporter
+ (make-progress-reporter
+ (format "Making tags completion table for %s..." buffer-file-name)
+ (point-min) (point-max))))
+ (save-excursion
+ (goto-char (point-min))
+ ;; This monster regexp matches an etags tag line.
+ ;; \1 is the string to match;
+ ;; \2 is not interesting;
+ ;; \3 is the guessed tag name; XXX guess should be better eg DEFUN
+ ;; \4 is not interesting;
+ ;; \5 is the explicitly-specified tag name.
+ ;; \6 is the line to start searching at;
+ ;; \7 is the char to start searching at.
+ (while (re-search-forward
+ "^\\(\\([^\177]+[^-a-zA-Z0-9_+*$:\177]+\\)?\
+\\([-a-zA-Z0-9_+*$?:]+\\)[^-a-zA-Z0-9_+*$?:\177]*\\)\177\
+\\(\\([^\n\001]+\\)\001\\)?\\([0-9]+\\)?,\\([0-9]+\\)?\n"
+ nil t)
+ (intern (prog1 (if (match-beginning 5)
+ ;; There is an explicit tag name.
+ (buffer-substring (match-beginning 5) (match-end 5))
+ ;; No explicit tag name. Best guess.
+ (buffer-substring (match-beginning 3) (match-end 3)))
+ (progress-reporter-update progress-reporter (point)))
+ table)))
+ table))
+
+(defun etags-snarf-tag (&optional use-explicit) ; Doc string?
+ (let (tag-text line startpos explicit-start)
+ (if (save-excursion
+ (forward-line -1)
+ (looking-at "\f\n"))
+ ;; The match was for a source file name, not any tag within a file.
+ ;; Give text of t, meaning to go exactly to the location we specify,
+ ;; the beginning of the file.
+ (setq tag-text t
+ line nil
+ startpos (point-min))
+
+ ;; Find the end of the tag and record the whole tag text.
+ (search-forward "\177")
+ (setq tag-text (buffer-substring (1- (point)) (point-at-bol)))
+ ;; If use-explicit is non nil and explicit tag is present, use it as part of
+ ;; return value. Else just skip it.
+ (setq explicit-start (point))
+ (when (and (search-forward "\001" (point-at-bol 2) t)
+ use-explicit)
+ (setq tag-text (buffer-substring explicit-start (1- (point)))))
+
+
+ (if (looking-at "[0-9]")
+ (setq line (string-to-number (buffer-substring
+ (point)
+ (progn (skip-chars-forward "0-9")
+ (point))))))
+ (search-forward ",")
+ (if (looking-at "[0-9]")
+ (setq startpos (string-to-number (buffer-substring
+ (point)
+ (progn (skip-chars-forward "0-9")
+ (point)))))))
+ ;; Leave point on the next line of the tags file.
+ (forward-line 1)
+ (cons tag-text (cons line startpos))))
+
+(defun etags-goto-tag-location (tag-info)
+ "Go to location of tag specified by TAG-INFO.
+TAG-INFO is a cons (TEXT LINE . POSITION).
+TEXT is the initial part of a line containing the tag.
+LINE is the line number.
+POSITION is the (one-based) char position of TEXT within the file.
+
+If TEXT is t, it means the tag refers to exactly LINE or POSITION,
+whichever is present, LINE having preference, no searching.
+Either LINE or POSITION can be nil. POSITION is used if present.
+
+If the tag isn't exactly at the given position, then look near that
+position using a search window that expands progressively until it
+hits the start of file."
+ (let ((startpos (cdr (cdr tag-info)))
+ (line (car (cdr tag-info)))
+ offset found pat)
+ (if (eq (car tag-info) t)
+ ;; Direct file tag.
+ (cond (line (progn (goto-char (point-min))
+ (forward-line (1- line))))
+ (startpos (goto-char startpos))
+ (t (error "etags.el BUG: bogus direct file tag")))
+ ;; This constant is 1/2 the initial search window.
+ ;; There is no sense in making it too small,
+ ;; since just going around the loop once probably
+ ;; costs about as much as searching 2000 chars.
+ (setq offset 1000
+ found nil
+ pat (concat (if (eq selective-display t)
+ "\\(^\\|\^m\\)" "^")
+ (regexp-quote (car tag-info))))
+ ;; The character position in the tags table is 0-origin.
+ ;; Convert it to a 1-origin Emacs character position.
+ (if startpos (setq startpos (1+ startpos)))
+ ;; If no char pos was given, try the given line number.
+ (or startpos
+ (if line
+ (setq startpos (progn (goto-char (point-min))
+ (forward-line (1- line))
+ (point)))))
+ (or startpos
+ (setq startpos (point-min)))
+ ;; First see if the tag is right at the specified location.
+ (goto-char startpos)
+ (setq found (looking-at pat))
+ (while (and (not found)
+ (progn
+ (goto-char (- startpos offset))
+ (not (bobp))))
+ (setq found
+ (re-search-forward pat (+ startpos offset) t)
+ offset (* 3 offset))) ; expand search window
+ (or found
+ (re-search-forward pat nil t)
+ (user-error "Rerun etags: `%s' not found in %s"
+ pat buffer-file-name)))
+ ;; Position point at the right place
+ ;; if the search string matched an extra Ctrl-m at the beginning.
+ (and (eq selective-display t)
+ (looking-at "\^m")
+ (forward-char 1))
+ (beginning-of-line)))
+
+(defun etags-list-tags (file) ; Doc string?
+ (goto-char (point-min))
+ (when (re-search-forward (concat "\f\n" "\\(" file "\\)" ",") nil t)
+ (let ((path (save-excursion (forward-line 1) (file-of-tag)))
+ ;; Get the local value in the tags table
+ ;; buffer before switching buffers.
+ (goto-func goto-tag-location-function)
+ tag tag-info pt)
+ (forward-line 1)
+ (while (not (or (eobp) (looking-at "\f")))
+ ;; We used to use explicit tags when available, but the current goto-func
+ ;; can only handle implicit tags.
+ (setq tag-info (save-excursion (funcall snarf-tag-function nil))
+ tag (car tag-info)
+ pt (with-current-buffer standard-output (point)))
+ (princ tag)
+ (when (= (aref tag 0) ?\() (princ " ...)"))
+ (with-current-buffer standard-output
+ (make-text-button pt (point)
+ 'tag-info tag-info
+ 'file-path path
+ 'goto-func goto-func
+ 'action (lambda (button)
+ (let ((tag-info (button-get button 'tag-info))
+ (goto-func (button-get button 'goto-func)))
+ (tag-find-file-of-tag (button-get button 'file-path))
+ (widen)
+ (funcall goto-func tag-info)))
+ 'follow-link t
+ 'face tags-tag-face
+ 'type 'button))
+ (terpri)
+ (forward-line 1))
+ t)))
+
+(defmacro tags-with-face (face &rest body)
+ "Execute BODY, give output to `standard-output' face FACE."
+ (let ((pp (make-symbol "start")))
+ `(let ((,pp (with-current-buffer standard-output (point))))
+ ,@body
+ (put-text-property ,pp (with-current-buffer standard-output (point))
+ 'face ,face standard-output))))
+
+(defun etags-tags-apropos-additional (regexp)
+ "Display tags matching REGEXP from `tags-apropos-additional-actions'."
+ (with-current-buffer standard-output
+ (dolist (oba tags-apropos-additional-actions)
+ (princ "\n\n")
+ (tags-with-face 'highlight (princ (car oba)))
+ (princ":\n\n")
+ (let* ((beg (point))
+ (symbs (car (cddr oba)))
+ (ins-symb (lambda (sy)
+ (let ((sn (symbol-name sy)))
+ (when (string-match regexp sn)
+ (make-text-button (point)
+ (progn (princ sy) (point))
+ 'action-internal(cadr oba)
+ 'action (lambda (button) (funcall
+ (button-get button 'action-internal)
+ (button-get button 'item)))
+ 'item sn
+ 'face tags-tag-face
+ 'follow-link t
+ 'type 'button)
+ (terpri))))))
+ (when (symbolp symbs)
+ (if (boundp symbs)
+ (setq symbs (symbol-value symbs))
+ (insert "symbol `" (symbol-name symbs) "' has no value\n")
+ (setq symbs nil)))
+ (if (vectorp symbs)
+ (mapatoms ins-symb symbs)
+ (dolist (sy symbs)
+ (funcall ins-symb (car sy))))
+ (sort-lines nil beg (point))))))
+
+(defun etags-tags-apropos (string) ; Doc string?
+ (when tags-apropos-verbose
+ (princ "Tags in file `")
+ (tags-with-face 'highlight (princ buffer-file-name))
+ (princ "':\n\n"))
+ (goto-char (point-min))
+ (let ((progress-reporter (make-progress-reporter
+ (format "Making tags apropos buffer for `%s'..."
+ string)
+ (point-min) (point-max))))
+ (while (re-search-forward string nil t)
+ (progress-reporter-update progress-reporter (point))
+ (beginning-of-line)
+
+ (let* ( ;; Get the local value in the tags table
+ ;; buffer before switching buffers.
+ (goto-func goto-tag-location-function)
+ (tag-info (save-excursion (funcall snarf-tag-function)))
+ (tag (if (eq t (car tag-info)) nil (car tag-info)))
+ (file-path (save-excursion (if tag (file-of-tag)
+ (save-excursion (forward-line 1)
+ (file-of-tag)))))
+ (file-label (if tag (file-of-tag t)
+ (save-excursion (forward-line 1)
+ (file-of-tag t))))
+ (pt (with-current-buffer standard-output (point))))
+ (if tag
+ (progn
+ (princ (format "[%s]: " file-label))
+ (princ tag)
+ (when (= (aref tag 0) ?\() (princ " ...)"))
+ (with-current-buffer standard-output
+ (make-text-button pt (point)
+ 'tag-info tag-info
+ 'file-path file-path
+ 'goto-func goto-func
+ 'action (lambda (button)
+ (let ((tag-info (button-get button 'tag-info))
+ (goto-func (button-get button 'goto-func)))
+ (tag-find-file-of-tag (button-get button 'file-path))
+ (widen)
+ (funcall goto-func tag-info)))
+ 'follow-link t
+ 'face tags-tag-face
+ 'type 'button)))
+ (princ (format "- %s" file-label))
+ (with-current-buffer standard-output
+ (make-text-button pt (point)
+ 'file-path file-path
+ 'action (lambda (button)
+ (tag-find-file-of-tag (button-get button 'file-path))
+ ;; Get the local value in the tags table
+ ;; buffer before switching buffers.
+ (goto-char (point-min)))
+ 'follow-link t
+ 'face tags-tag-face
+ 'type 'button))))
+ (terpri)
+ (forward-line 1))
+ (message nil))
+ (when tags-apropos-verbose (princ "\n")))
+
+(defun etags-tags-table-files () ; Doc string?
+ (let ((files nil)
+ beg)
+ (goto-char (point-min))
+ (while (search-forward "\f\n" nil t)
+ (setq beg (point))
+ (end-of-line)
+ (skip-chars-backward "^," beg)
+ (or (looking-at "include$")
+ (push (convert-standard-filename
+ (buffer-substring beg (1- (point))))
+ files)))
+ (nreverse files)))
+
+;; FIXME? Should this save-excursion?
+(defun etags-tags-included-tables () ; Doc string?
+ (let ((files nil)
+ beg)
+ (goto-char (point-min))
+ (while (search-forward "\f\n" nil t)
+ (setq beg (point))
+ (end-of-line)
+ (skip-chars-backward "^," beg)
+ (when (looking-at "include$")
+ ;; Expand in the default-directory of the tags table buffer.
+ (push (expand-file-name (convert-standard-filename
+ (buffer-substring beg (1- (point)))))
+ files)))
+ (nreverse files)))
+\f
+;; Empty tags file support.
+
+(defun tags-recognize-empty-tags-table ()
+ "Return non-nil if current buffer is empty.
+If empty, make buffer-local values of the tags table format variables
+that do nothing."
+ (and (zerop (buffer-size))
+ (mapc (lambda (sym) (set (make-local-variable sym) 'ignore))
+ '(tags-table-files-function
+ tags-completion-table-function
+ find-tag-regexp-search-function
+ find-tag-search-function
+ tags-apropos-function
+ tags-included-tables-function))
+ (set (make-local-variable 'verify-tags-table-function)
+ (lambda () (zerop (buffer-size))))))
+\f
+;; Match qualifier functions for tagnames.
+;; These functions assume the etags file format defined in etc/ETAGS.EBNF.
+
+;; This might be a neat idea, but it's too hairy at the moment.
+;;(defmacro tags-with-syntax (&rest body)
+;; `(with-syntax-table
+;; (with-current-buffer (find-file-noselect (file-of-tag))
+;; (syntax-table))
+;; ,@body))
+;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form))
+
+;; exact file name match, i.e. searched tag must match complete file
+;; name including directories parts if there are some.
+(defun tag-exact-file-name-match-p (tag)
+ "Return non-nil if TAG matches complete file name.
+Any directory part of the file name is also matched."
+ (and (looking-at ",[0-9\n]")
+ (save-excursion (backward-char (+ 2 (length tag)))
+ (looking-at "\f\n"))))
+
+;; file name match as above, but searched tag must match the file
+;; name not including the directories if there are some.
+(defun tag-file-name-match-p (tag)
+ "Return non-nil if TAG matches file name, excluding directory part."
+ (and (looking-at ",[0-9\n]")
+ (save-excursion (backward-char (1+ (length tag)))
+ (looking-at "/"))))
+
+;; this / to detect we are after a directory separator is ok for unix,
+;; is there a variable that contains the regexp for directory separator
+;; on whatever operating system ?
+;; Looks like ms-win will lose here :).
+
+;; t if point is at a tag line that matches TAG exactly.
+;; point should be just after a string that matches TAG.
+(defun tag-exact-match-p (tag)
+ "Return non-nil if current tag line matches TAG exactly.
+Point should be just after a string that matches TAG."
+ ;; The match is really exact if there is an explicit tag name.
+ (or (and (eq (char-after (point)) ?\001)
+ (eq (char-after (- (point) (length tag) 1)) ?\177))
+ ;; We are not on the explicit tag name, but perhaps it follows.
+ (looking-at (concat "[^\177\n]*\177" (regexp-quote tag) "\001"))))
+
+;; t if point is at a tag line that has an implicit name.
+;; point should be just after a string that matches TAG.
+(defun tag-implicit-name-match-p (tag)
+ "Return non-nil if current tag line has an implicit name.
+Point should be just after a string that matches TAG."
+ ;; Look at the comment of the make_tag function in lib-src/etags.c for
+ ;; a textual description of the four rules.
+ (and (string-match "^[^ \t()=,;]+$" tag) ;rule #1
+ (looking-at "[ \t()=,;]?\177") ;rules #2 and #4
+ (save-excursion
+ (backward-char (1+ (length tag)))
+ (looking-at "[\n \t()=,;]")))) ;rule #3
+
+;; t if point is at a tag line that matches TAG as a symbol.
+;; point should be just after a string that matches TAG.
+(defun tag-symbol-match-p (tag)
+ "Return non-nil if current tag line matches TAG as a symbol.
+Point should be just after a string that matches TAG."
+ (and (looking-at "\\Sw.*\177") (looking-at "\\S_.*\177")
+ (save-excursion
+ (backward-char (1+ (length tag)))
+ (and (looking-at "\\Sw") (looking-at "\\S_")))))
+
+;; t if point is at a tag line that matches TAG as a word.
+;; point should be just after a string that matches TAG.
+(defun tag-word-match-p (tag)
+ "Return non-nil if current tag line matches TAG as a word.
+Point should be just after a string that matches TAG."
+ (and (looking-at "\\b.*\177")
+ (save-excursion (backward-char (length tag))
+ (looking-at "\\b"))))
+
+;; partial file name match, i.e. searched tag must match a substring
+;; of the file name (potentially including a directory separator).
+(defun tag-partial-file-name-match-p (_tag)
+ "Return non-nil if current tag matches file name.
+This is a substring match, and it can include directory separators.
+Point should be just after a string that matches TAG."
+ (and (looking-at ".*,[0-9\n]")
+ (save-excursion (beginning-of-line)
+ (backward-char 2)
+ (looking-at "\f\n"))))
+
+;; t if point is in a tag line with a tag containing TAG as a substring.
+(defun tag-any-match-p (_tag)
+ "Return non-nil if current tag line contains TAG as a substring."
+ (looking-at ".*\177"))
+
+;; t if point is at a tag line that matches RE as a regexp.
+(defun tag-re-match-p (re)
+ "Return non-nil if current tag line matches regexp RE."
+ (save-excursion
+ (beginning-of-line)
+ (let ((bol (point)))
+ (and (search-forward "\177" (line-end-position) t)
+ (re-search-backward re bol t)))))
+\f
+(defcustom tags-loop-revert-buffers nil
+ "Non-nil means tags-scanning loops should offer to reread changed files.
+These loops normally read each file into Emacs, but when a file
+is already visited, they use the existing buffer.
+When this flag is non-nil, they offer to revert the existing buffer
+in the case where the file has changed since you visited it."
+ :type 'boolean
+ :group 'etags)
+
+;;;###autoload
+(defun next-file (&optional initialize novisit)
+ "Select next file among files in current tags table.
+
+A first argument of t (prefix arg, if interactive) initializes to the
+beginning of the list of files in the tags table. If the argument is
+neither nil nor t, it is evalled to initialize the list of files.
+
+Non-nil second argument NOVISIT means use a temporary buffer
+ to save time and avoid uninteresting warnings.
+
+Value is nil if the file was already visited;
+if the file was newly read in, the value is the filename."
+ ;; Make the interactive arg t if there was any prefix arg.
+ (interactive (list (if current-prefix-arg t)))
+ (cond ((not initialize)
+ ;; Not the first run.
+ )
+ ((eq initialize t)
+ ;; Initialize the list from the tags table.
+ (save-excursion
+ ;; Visit the tags table buffer to get its list of files.
+ (visit-tags-table-buffer)
+ ;; Copy the list so we can setcdr below, and expand the file
+ ;; names while we are at it, in this buffer's default directory.
+ (setq next-file-list (mapcar 'expand-file-name (tags-table-files)))
+ ;; Iterate over all the tags table files, collecting
+ ;; a complete list of referenced file names.
+ (while (visit-tags-table-buffer t)
+ ;; Find the tail of the working list and chain on the new
+ ;; sublist for this tags table.
+ (let ((tail next-file-list))
+ (while (cdr tail)
+ (setq tail (cdr tail)))
+ ;; Use a copy so the next loop iteration will not modify the
+ ;; list later returned by (tags-table-files).
+ (if tail
+ (setcdr tail (mapcar 'expand-file-name (tags-table-files)))
+ (setq next-file-list (mapcar 'expand-file-name
+ (tags-table-files))))))))
+ (t
+ ;; Initialize the list by evalling the argument.
+ (setq next-file-list (eval initialize))))
+ (unless next-file-list
+ (and novisit
+ (get-buffer " *next-file*")
+ (kill-buffer " *next-file*"))
+ (user-error "All files processed"))
+ (let* ((next (car next-file-list))
+ (buffer (get-file-buffer next))
+ (new (not buffer)))
+ ;; Advance the list before trying to find the file.
+ ;; If we get an error finding the file, don't get stuck on it.
+ (setq next-file-list (cdr next-file-list))
+ ;; Optionally offer to revert buffers
+ ;; if the files have changed on disk.
+ (and buffer tags-loop-revert-buffers
+ (not (verify-visited-file-modtime buffer))
+ (y-or-n-p
+ (format
+ (if (buffer-modified-p buffer)
+ "File %s changed on disk. Discard your edits? "
+ "File %s changed on disk. Reread from disk? ")
+ next))
+ (with-current-buffer buffer
+ (revert-buffer t t)))
+ (if (not (and new novisit))
+ (find-file next novisit)
+ ;; Like find-file, but avoids random warning messages.
+ (switch-to-buffer (get-buffer-create " *next-file*"))
+ (kill-all-local-variables)
+ (erase-buffer)
+ (setq new next)
+ (insert-file-contents new nil))
+ new))
+
+(defvar tags-loop-operate nil
+ "Form for `tags-loop-continue' to eval to change one file.")
+
+(defvar tags-loop-scan
+ '(user-error "%s"
+ (substitute-command-keys
+ "No \\[tags-search] or \\[tags-query-replace] in progress"))
+ "Form for `tags-loop-continue' to eval to scan one file.
+If it returns non-nil, this file needs processing by evalling
+`tags-loop-operate'. Otherwise, move on to the next file.")
+
+(defun tags-loop-eval (form)
+ "Evaluate FORM and return its result.
+Bind `case-fold-search' during the evaluation, depending on the value of
+`tags-case-fold-search'."
+ (let ((case-fold-search (if (memq tags-case-fold-search '(t nil))
+ tags-case-fold-search
+ case-fold-search)))
+ (eval form)))
+
+
+;;;###autoload
+(defun tags-loop-continue (&optional first-time)
+ "Continue last \\[tags-search] or \\[tags-query-replace] command.
+Used noninteractively with non-nil argument to begin such a command (the
+argument is passed to `next-file', which see).
+
+Two variables control the processing we do on each file: the value of
+`tags-loop-scan' is a form to be executed on each file to see if it is
+interesting (it returns non-nil if so) and `tags-loop-operate' is a form to
+evaluate to operate on an interesting file. If the latter evaluates to
+nil, we exit; otherwise we scan the next file."
+ (declare (obsolete "use `xref-find-definitions' interface instead." "25.1"))
+ (interactive)
+ (let (new
+ ;; Non-nil means we have finished one file
+ ;; and should not scan it again.
+ file-finished
+ original-point
+ (messaged nil))
+ (while
+ (progn
+ ;; Scan files quickly for the first or next interesting one.
+ ;; This starts at point in the current buffer.
+ (while (or first-time file-finished
+ (save-restriction
+ (widen)
+ (not (tags-loop-eval tags-loop-scan))))
+ ;; If nothing was found in the previous file, and
+ ;; that file isn't in a temp buffer, restore point to
+ ;; where it was.
+ (when original-point
+ (goto-char original-point))
+
+ (setq file-finished nil)
+ (setq new (next-file first-time t))
+
+ ;; If NEW is non-nil, we got a temp buffer,
+ ;; and NEW is the file name.
+ (when (or messaged
+ (and (not first-time)
+ (> baud-rate search-slow-speed)
+ (setq messaged t)))
+ (message "Scanning file %s..." (or new buffer-file-name)))
+
+ (setq first-time nil)
+ (setq original-point (if new nil (point)))
+ (goto-char (point-min)))
+
+ ;; If we visited it in a temp buffer, visit it now for real.
+ (if new
+ (let ((pos (point)))
+ (erase-buffer)
+ (set-buffer (find-file-noselect new))
+ (setq new nil) ;No longer in a temp buffer.
+ (widen)
+ (goto-char pos))
+ (push-mark original-point t))
+
+ (switch-to-buffer (current-buffer))
+
+ ;; Now operate on the file.
+ ;; If value is non-nil, continue to scan the next file.
+ (tags-loop-eval tags-loop-operate))
+ (setq file-finished t))
+ (and messaged
+ (null tags-loop-operate)
+ (message "Scanning file %s...found" buffer-file-name))))
+
+;;;###autoload
+(defun tags-search (regexp &optional file-list-form)
+ "Search through all files listed in tags table for match for REGEXP.
+Stops when a match is found.
+To continue searching for next match, use command \\[tags-loop-continue].
+
+If FILE-LIST-FORM is non-nil, it should be a form that, when
+evaluated, will return a list of file names. The search will be
+restricted to these files.
+
+Also see the documentation of the `tags-file-name' variable."
+ (interactive "sTags search (regexp): ")
+ (if (and (equal regexp "")
+ (eq (car tags-loop-scan) 're-search-forward)
+ (null tags-loop-operate))
+ ;; Continue last tags-search as if by M-,.
+ (tags-loop-continue nil)
+ (setq tags-loop-scan `(re-search-forward ',regexp nil t)
+ tags-loop-operate nil)
+ (tags-loop-continue (or file-list-form t))))
+
+;;;###autoload
+(defun tags-query-replace (from to &optional delimited file-list-form)
+ "Do `query-replace-regexp' of FROM with TO on all files listed in tags table.
+Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
+If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
+with the command \\[tags-loop-continue].
+Fourth arg FILE-LIST-FORM non-nil means initialize the replacement loop.
+Fifth and sixth arguments START and END are accepted, for compatibility
+with `query-replace-regexp', and ignored.
+
+If FILE-LIST-FORM is non-nil, it is a form to evaluate to
+produce the list of files to search.
+
+See also the documentation of the variable `tags-file-name'."
+ (interactive (query-replace-read-args "Tags query replace (regexp)" t t))
+ (setq tags-loop-scan `(let ,(unless (equal from (downcase from))
+ '((case-fold-search nil)))
+ (if (re-search-forward ',from nil t)
+ ;; When we find a match, move back
+ ;; to the beginning of it so perform-replace
+ ;; will see it.
+ (goto-char (match-beginning 0))))
+ tags-loop-operate `(perform-replace ',from ',to t t ',delimited
+ nil multi-query-replace-map))
+ (tags-loop-continue (or file-list-form t)))
+\f
+(defun tags-complete-tags-table-file (string predicate what) ; Doc string?
+ (save-excursion
+ ;; If we need to ask for the tag table, allow that.
+ (let ((enable-recursive-minibuffers t))
+ (visit-tags-table-buffer))
+ (if (eq what t)
+ (all-completions string (tags-table-files) predicate)
+ (try-completion string (tags-table-files) predicate))))
+
+;;;###autoload
+(defun list-tags (file &optional _next-match)
+ "Display list of tags in file FILE.
+This searches only the first table in the list, and no included tables.
+FILE should be as it appeared in the `etags' command, usually without a
+directory specification."
+ (interactive (list (completing-read "List tags in file: "
+ 'tags-complete-tags-table-file
+ nil t nil)))
+ (with-output-to-temp-buffer "*Tags List*"
+ (princ "Tags in file `")
+ (tags-with-face 'highlight (princ file))
+ (princ "':\n\n")
+ (save-excursion
+ (let ((first-time t)
+ (gotany nil))
+ (while (visit-tags-table-buffer (not first-time))
+ (setq first-time nil)
+ (if (funcall list-tags-function file)
+ (setq gotany t)))
+ (or gotany
+ (user-error "File %s not in current tags tables" file)))))
+ (with-current-buffer "*Tags List*"
+ (require 'apropos)
+ (with-no-warnings
+ (apropos-mode))
+ (setq buffer-read-only t)))
+
+;;;###autoload
+(defun tags-apropos (regexp)
+ "Display list of all tags in tags table REGEXP matches."
+ (declare (obsolete xref-find-apropos "25.1"))
+ (interactive "sTags apropos (regexp): ")
+ (with-output-to-temp-buffer "*Tags List*"
+ (princ "Click mouse-2 to follow tags.\n\nTags matching regexp `")
+ (tags-with-face 'highlight (princ regexp))
+ (princ "':\n\n")
+ (save-excursion
+ (let ((first-time t))
+ (while (visit-tags-table-buffer (not first-time))
+ (setq first-time nil)
+ (funcall tags-apropos-function regexp))))
+ (etags-tags-apropos-additional regexp))
+ (with-current-buffer "*Tags List*"
+ (eval-and-compile (require 'apropos))
+ (apropos-mode)
+ ;; apropos-mode is derived from fundamental-mode and it kills
+ ;; all local variables.
+ (setq buffer-read-only t)))
+\f
+;; XXX Kludge interface.
+
+(define-button-type 'tags-select-tags-table
+ 'action 'select-tags-table-select
+ 'follow-link t
+ 'help-echo "RET, t or mouse-2: select tags table")
+
+;; XXX If a file is in multiple tables, selection may get the wrong one.
+;;;###autoload
+(defun select-tags-table ()
+ "Select a tags table file from a menu of those you have already used.
+The list of tags tables to select from is stored in `tags-table-set-list';
+see the doc of that variable if you want to add names to the list."
+ (interactive)
+ (pop-to-buffer "*Tags Table List*")
+ (setq buffer-read-only nil
+ buffer-undo-list t)
+ (erase-buffer)
+ (let ((set-list tags-table-set-list)
+ (desired-point nil)
+ b)
+ (when tags-table-list
+ (setq desired-point (point-marker))
+ (setq b (point))
+ (princ (mapcar 'abbreviate-file-name tags-table-list) (current-buffer))
+ (make-text-button b (point) 'type 'tags-select-tags-table
+ 'etags-table (car tags-table-list))
+ (insert "\n"))
+ (while set-list
+ (unless (eq (car set-list) tags-table-list)
+ (setq b (point))
+ (princ (mapcar 'abbreviate-file-name (car set-list)) (current-buffer))
+ (make-text-button b (point) 'type 'tags-select-tags-table
+ 'etags-table (car (car set-list)))
+ (insert "\n"))
+ (setq set-list (cdr set-list)))
+ (when tags-file-name
+ (or desired-point
+ (setq desired-point (point-marker)))
+ (setq b (point))
+ (insert (abbreviate-file-name tags-file-name))
+ (make-text-button b (point) 'type 'tags-select-tags-table
+ 'etags-table tags-file-name)
+ (insert "\n"))
+ (setq set-list (delete tags-file-name
+ (apply 'nconc (cons (copy-sequence tags-table-list)
+ (mapcar 'copy-sequence
+ tags-table-set-list)))))
+ (while set-list
+ (setq b (point))
+ (insert (abbreviate-file-name (car set-list)))
+ (make-text-button b (point) 'type 'tags-select-tags-table
+ 'etags-table (car set-list))
+ (insert "\n")
+ (setq set-list (delete (car set-list) set-list)))
+ (goto-char (point-min))
+ (insert-before-markers
+ "Type `t' to select a tags table or set of tags tables:\n\n")
+ (if desired-point
+ (goto-char desired-point))
+ (set-window-start (selected-window) 1 t))
+ (set-buffer-modified-p nil)
+ (select-tags-table-mode))
+
+(defvar select-tags-table-mode-map ; Doc string?
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map button-buffer-map)
+ (define-key map "t" 'push-button)
+ (define-key map " " 'next-line)
+ (define-key map "\^?" 'previous-line)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "q" 'select-tags-table-quit)
+ map))
+
+(define-derived-mode select-tags-table-mode special-mode "Select Tags Table"
+ "Major mode for choosing a current tags table among those already loaded."
+ (setq buffer-read-only t))
+
+(defun select-tags-table-select (button)
+ "Select the tags table named on this line."
+ (interactive (list (or (button-at (line-beginning-position))
+ (error "No tags table on current line"))))
+ (let ((name (button-get button 'etags-table)))
+ (visit-tags-table name)
+ (select-tags-table-quit)
+ (message "Tags table now %s" name)))
+
+(defun select-tags-table-quit ()
+ "Kill the buffer and delete the selected window."
+ (interactive)
+ (quit-window t (selected-window)))
+\f
+;;;###autoload
+(defun complete-tag ()
+ "Perform tags completion on the text around point.
+Completes to the set of names listed in the current tags table.
+The string to complete is chosen in the same way as the default
+for \\[find-tag] (which see)."
+ (interactive)
+ (or tags-table-list
+ tags-file-name
+ (user-error "%s"
+ (substitute-command-keys
+ "No tags table loaded; try \\[visit-tags-table]")))
+ (let ((comp-data (tags-completion-at-point-function)))
+ (if (null comp-data)
+ (user-error "Nothing to complete")
+ (completion-in-region (car comp-data) (cadr comp-data)
+ (nth 2 comp-data)
+ (plist-get (nthcdr 3 comp-data) :predicate)))))
+
+\f
+;;; Xref backend
+
+;; Stop searching if we find more than xref-limit matches, as the xref
+;; infrastructure is not designed to handle very long lists.
+;; Switching to some kind of lazy list might be better, but hopefully
+;; we hit the limit rarely.
+(defconst etags--xref-limit 1000)
+
+(defvar etags-xref-find-definitions-tag-order '(tag-exact-match-p
+ tag-implicit-name-match-p
+ tag-symbol-match-p)
+ "Tag order used in `etags-xref-find' to look for definitions.")
+
+;;;###autoload
+(defun etags-xref-find (action id)
+ (pcase action
+ (`definitions (etags--xref-find-definitions id))
+ (`references
+ (let ((dirs (if tags-table-list
+ (mapcar #'file-name-directory tags-table-list)
+ ;; If no tags files are loaded, prompt for the dir.
+ (list (read-directory-name "In directory: " nil nil t)))))
+ (cl-mapcan
+ (lambda (dir)
+ (xref-collect-references id dir))
+ dirs)))
+ (`apropos (etags--xref-find-definitions id t))))
+
+(defun etags--xref-find-definitions (pattern &optional regexp?)
++ ;; This emulates the behavior of `find-tag-in-order' but instead of
+ ;; returning one match at a time all matches are returned as list.
+ ;; NOTE: find-tag-tag-order is typically a buffer-local variable.
+ (let* ((xrefs '())
+ (first-time t)
+ (search-fun (if regexp? #'re-search-forward #'search-forward))
+ (marks (make-hash-table :test 'equal))
+ (case-fold-search (if (memq tags-case-fold-search '(nil t))
+ tags-case-fold-search
+ case-fold-search)))
+ (save-excursion
+ (while (visit-tags-table-buffer (not first-time))
+ (setq first-time nil)
+ (dolist (order-fun (cond (regexp? find-tag-regexp-tag-order)
+ (t etags-xref-find-definitions-tag-order)))
+ (goto-char (point-min))
+ (while (and (funcall search-fun pattern nil t)
+ (< (hash-table-count marks) etags--xref-limit))
+ (when (funcall order-fun pattern)
+ (beginning-of-line)
+ (pcase-let* ((tag-info (etags-snarf-tag))
+ (`(,hint ,line . _) tag-info))
+ (unless (eq hint t) ; hint==t if we are in a filename line
+ (let* ((file (file-of-tag))
+ (mark-key (cons file line)))
+ (unless (gethash mark-key marks)
+ (let ((loc (xref-make-etags-location
+ tag-info (expand-file-name file))))
+ (push (xref-make hint loc) xrefs)
+ (puthash mark-key t marks)))))))))))
+ (nreverse xrefs)))
+
+(defclass xref-etags-location (xref-location)
+ ((tag-info :type list :initarg :tag-info)
+ (file :type string :initarg :file
+ :reader xref-location-group))
+ :documentation "Location of an etags tag.")
+
+(defun xref-make-etags-location (tag-info file)
+ (make-instance 'xref-etags-location :tag-info tag-info
+ :file (expand-file-name file)))
+
+(cl-defmethod xref-location-marker ((l xref-etags-location))
+ (with-slots (tag-info file) l
+ (let ((buffer (find-file-noselect file)))
+ (with-current-buffer buffer
+ (etags-goto-tag-location tag-info)
+ (point-marker)))))
+
+(cl-defmethod xref-location-line ((l xref-etags-location))
+ (with-slots (tag-info) l
+ (nth 1 tag-info)))
+
+\f
+(provide 'etags)
+
+;;; etags.el ends here
projects / emacs.git / commitdiff