#include <float.h>
#include <inttypes.h>
#include <limits.h>
-
#include <intprops.h>
#include <verify.h>
+#include <libguile.h>
INLINE_HEADER_BEGIN
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
+
+typedef scm_t_signed_bits EMACS_INT;
+typedef scm_t_bits EMACS_UINT;
+#define EMACS_INT_MAX SCM_T_SIGNED_BITS_MAX
+
+#if INTPTR_MAX == INT_MAX
+#define pI ""
+#elif INTPTR_MAX == LONG_MAX
+#define pI "l"
+#elif INTPTR_MAX == LLONG_MAX
+#define pI "ll"
+#elif INTPTR_MAX == INTMAX_MAX
+#define pI "j"
+#else
+#error "Cannot determine length modifier for EMACS_INT"
#endif
/* Number of bits to put in each character in the internal representation
#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: all the defsubr as well
- as 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
+ FIXNUM_BITS = SCM_I_FIXNUM_BIT
};
#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 VAL_MAX < UINTPTR_MAX' below. */
-#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, 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 (EMACS_INT_MAX >> GCTYPEBITS < INTPTR_MAX)
+#define USE_LSB_TAG 1
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
# endif
#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.
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 SMOB_PTR(a) ((void *) SCM_SMOB_DATA (a))
+#define SMOB_TYPEP(x, tag) (x && SCM_SMOB_PREDICATE (tag, x))
+#define lisp_h_XLI(o) (SCM_UNPACK (o))
+#define lisp_h_XIL(i) (SCM_PACK (i))
#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_Int1) == 0)
+#define lisp_h_CONSP(x) (x && scm_is_pair (x))
+#define lisp_h_EQ(x, y) (scm_is_eq (x, y))
+#define lisp_h_FLOATP(x) (x && SCM_INEXACTP (x))
+#define lisp_h_INTEGERP(x) (SCM_I_INUMP (x))
#define lisp_h_MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker)
-#define lisp_h_MISCP(x) (XTYPE (x) == Lisp_Misc)
+#define lisp_h_MISCP(x) (SMOB_TYPEP (x, lisp_misc_tag))
#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) ((void *) (intptr_t) (XLI (a) & VALMASK))
+#define lisp_h_SYMBOLP(x) (SMOB_TYPEP (x, lisp_symbol_tag))
+#define lisp_h_VECTORLIKEP(x) (SMOB_TYPEP (x, lisp_vectorlike_tag))
+#define lisp_h_XCAR(c) (scm_car (c))
+#define lisp_h_XCDR(c) (scm_cdr (c))
+#define lisp_h_XHASH(a) (SCM_UNPACK (a))
#define lisp_h_XSYMBOL(a) \
- (eassert (SYMBOLP (a)), (struct Lisp_Symbol *) XUNTAG (a, Lisp_Symbol))
-#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))
-# define lisp_h_XFASTINT(a) XINT (a)
-# define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS)
-# define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK))
-# define lisp_h_XUNTAG(a, type) ((void *) (XLI (a) - (type)))
-#endif
+ (eassert (SYMBOLP (a)), (struct Lisp_Symbol *) SMOB_PTR (a))
/* 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 0
#if (defined __NO_INLINE__ \
&& ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__ \
&& ! (defined INLINING && ! INLINING))
# 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)
# define XSYMBOL(a) lisp_h_XSYMBOL (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 XTYPE(a) lisp_h_XTYPE (a)
-# define XUNTAG(a, type) lisp_h_XUNTAG (a, type)
-# endif
+#endif
#endif
/* Define NAME as a lisp.h inline function that returns TYPE and has
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
+#define INTMASK SCM_MOST_POSITIVE_FIXNUM
+#define case_Lisp_Int case Lisp_Int
/* Idea stolen from GDB. Pedantic GCC complains about enum bitfields,
MSVC doesn't support them, and xlc and Oracle Studio c99 complain
#define ENUM_BF(TYPE) enum TYPE
#endif
+scm_t_bits lisp_symbol_tag;
+scm_t_bits lisp_misc_tag;
+scm_t_bits lisp_string_tag;
+scm_t_bits lisp_vectorlike_tag;
enum Lisp_Type
{
+ Lisp_Other,
+
/* Integer. XINT (obj) is the integer value. */
- Lisp_Int0 = 0,
- Lisp_Int1 = USE_LSB_TAG ? 1 << INTTYPEBITS : 1,
+ Lisp_Int,
/* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */
- Lisp_Symbol = 2,
+ Lisp_Symbol,
/* Miscellaneous. XMISC (object) points to a union Lisp_Misc,
whose first member indicates the subtype. */
- Lisp_Misc = 3,
+ Lisp_Misc,
/* String. XSTRING (object) points to a struct Lisp_String.
The length of the string, and its contents, are stored therein. */
- Lisp_String = USE_LSB_TAG ? 1 : 1 << INTTYPEBITS,
+ Lisp_String,
/* 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,
+ Lisp_Vectorlike,
/* Cons. XCONS (object) points to a struct Lisp_Cons. */
- Lisp_Cons = 6,
+ Lisp_Cons,
- Lisp_Float = 7
+ Lisp_Float
};
/* This is the set of data types that share a common structure.
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_ZERO {0}
-
-#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_ZERO 0
-enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false };
-#endif /* CHECK_LISP_OBJECT_TYPE */
+typedef SCM Lisp_Object;
+
+#define LISP_INITIALLY_ZERO SCM_INUM0
/* 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 ARRAY_MARK_FLAG_val PTRDIFF_MIN
-#if ENUMABLE (ARRAY_MARK_FLAG_val)
-DEFINE_GDB_SYMBOL_ENUM (ARRAY_MARK_FLAG)
-#else
-DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, ARRAY_MARK_FLAG)
-# define ARRAY_MARK_FLAG ARRAY_MARK_FLAG_val
-DEFINE_GDB_SYMBOL_END (ARRAY_MARK_FLAG)
-#endif
-
/* In the size word of a struct Lisp_Vector, this bit means it's really
some other vector-like object. */
#define PSEUDOVECTOR_FLAG_val (PTRDIFF_MAX - PTRDIFF_MAX / 2)
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 VALMASK_val (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX)
-#if ENUMABLE (VALMASK_val)
-DEFINE_GDB_SYMBOL_ENUM (VALMASK)
-#else
-DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK)
-# define VALMASK VALMASK_val
-DEFINE_GDB_SYMBOL_END (VALMASK)
-#endif
-
/* 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)
-
-/* Extract the pointer hidden within A. */
-LISP_MACRO_DEFUN (XPNTR, void *, (Lisp_Object a), (a))
-
-#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 (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. */
+#define MOST_POSITIVE_FIXNUM SCM_MOST_POSITIVE_FIXNUM
+#define MOST_NEGATIVE_FIXNUM SCM_MOST_NEGATIVE_FIXNUM
/* Make a Lisp integer representing the value of the low order
bits of N. */
INLINE Lisp_Object
make_number (EMACS_INT n)
{
- if (USE_LSB_TAG)
- {
- EMACS_UINT u = n;
- n = u << INTTYPEBITS;
- }
- else
- n &= INTMASK;
- return XIL (n);
+ return SCM_I_MAKINUM (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;
+ return SCM_I_INUM (a);
}
/* Like XINT (A), but may be faster. A must be nonnegative.
INLINE EMACS_INT
XFASTINT (Lisp_Object a)
{
- EMACS_INT n = USE_LSB_TAG ? XINT (a) : XLI (a);
+ EMACS_INT n = XINT (a);
eassert (0 <= n);
return n;
}
-/* 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)
-{
- if (USE_LSB_TAG)
- {
- intptr_t i = XLI (a) - type;
- return (void *) i;
- }
- return XPNTR (a);
-}
-
-#endif /* ! USE_LSB_TAG */
-
/* 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 SCM_I_INUM (a);
}
/* Return A's (Lisp-integer sized) hash. Happens to be like XUINT
make_natnum (EMACS_INT n)
{
eassert (0 <= n && n <= MOST_POSITIVE_FIXNUM);
- return USE_LSB_TAG ? make_number (n) : XIL (n);
+ return make_number (n);
}
/* Return true if X and Y are the same object. */
/* Defined in xdisp.c. */
extern Lisp_Object Qimage;
\f
+/* Extract A's type. */
+INLINE enum Lisp_Type
+XTYPE (Lisp_Object o)
+{
+ if (INTEGERP (o))
+ return Lisp_Int;
+ else if (SYMBOLP (o))
+ return Lisp_Symbol;
+ else if (MISCP (o))
+ return Lisp_Misc;
+ else if (STRINGP (o))
+ return Lisp_String;
+ else if (VECTORLIKEP (o))
+ return Lisp_Vectorlike;
+ else if (CONSP (o))
+ return Lisp_Cons;
+ else if (FLOATP (o))
+ return Lisp_Float;
+ else
+ return Lisp_Other;
+}
/* 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);
+ return SMOB_PTR (a);
}
INLINE struct Lisp_String *
XSTRING (Lisp_Object a)
{
eassert (STRINGP (a));
- return XUNTAG (a, Lisp_String);
+ return SMOB_PTR (a);
}
LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a))
-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);
+ return SMOB_PTR (a);
}
INLINE struct window *
XWINDOW (Lisp_Object a)
{
eassert (WINDOWP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return SMOB_PTR (a);
}
INLINE struct terminal *
XTERMINAL (Lisp_Object a)
{
- return XUNTAG (a, Lisp_Vectorlike);
+ return SMOB_PTR (a);
}
INLINE struct Lisp_Subr *
XSUBR (Lisp_Object a)
{
eassert (SUBRP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return SMOB_PTR (a);
}
INLINE struct buffer *
XBUFFER (Lisp_Object a)
{
eassert (BUFFERP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return SMOB_PTR (a);
}
INLINE struct Lisp_Char_Table *
XCHAR_TABLE (Lisp_Object a)
{
eassert (CHAR_TABLE_P (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return SMOB_PTR (a);
}
INLINE struct Lisp_Sub_Char_Table *
XSUB_CHAR_TABLE (Lisp_Object a)
{
eassert (SUB_CHAR_TABLE_P (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return SMOB_PTR (a);
}
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)
-{
- EMACS_UINT utype = type;
- EMACS_UINT typebits = USE_LSB_TAG ? type : utype << VALBITS;
- Lisp_Object a = XIL (typebits | (uintptr_t) ptr);
- eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr);
- return a;
+ return SMOB_PTR (a);
}
INLINE Lisp_Object
make_lisp_proc (struct Lisp_Process *p)
{
- return make_lisp_ptr (p, Lisp_Vectorlike);
+ return scm_new_smob (lisp_vectorlike_tag, (scm_t_bits) p);
}
#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_ptr (b, Lisp_Symbol))
-#define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float))
-#define XSETMISC(a, b) ((a) = make_lisp_ptr (b, Lisp_Misc))
+#define XSETVECTOR(a, b) ((a) = (b)->header.self)
+#define XSETSTRING(a, b) ((a) = (b)->self)
+#define XSETSYMBOL(a, b) ((a) = (b)->self)
+#define XSETMISC(a, b) (a) = ((union Lisp_Misc *) (b))->u_any.self
/* Pseudovector types. */
#define XSETPSEUDOVECTOR(a, b, code) \
XSETTYPED_PSEUDOVECTOR (a, b, \
(((struct vectorlike_header *) \
- XUNTAG (a, Lisp_Vectorlike)) \
+ SCM_SMOB_DATA (a)) \
->size), \
code)
#define XSETTYPED_PSEUDOVECTOR(a, b, size, code) \
typedef struct interval *INTERVAL;
-struct 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))
INLINE void
XSETCAR (Lisp_Object c, Lisp_Object n)
{
- *xcar_addr (c) = n;
+ scm_set_car_x (c, n);
}
INLINE void
XSETCDR (Lisp_Object c, Lisp_Object n)
{
- *xcdr_addr (c) = n;
+ scm_set_cdr_x (c, n);
}
/* Take the car or cdr of something whose type is not known. */
struct Lisp_String
{
+ Lisp_Object self;
ptrdiff_t size;
ptrdiff_t size_byte;
INTERVAL intervals; /* Text properties in this 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
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
+ Lisp_Object self;
+
+ /* This field contains various pieces of information:
+ - The second 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.
{
/* 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));
+ eassert (0 <= idx && idx < (ASIZE (array)));
XVECTOR (array)->contents[idx] = val;
}
struct Lisp_Symbol
{
- bool_bf gcmarkbit : 1;
+ Lisp_Object self;
/* Indicates where the value can be found:
0 : it's a plain var, the value is in the `value' field.
INLINE struct Lisp_Hash_Table *
XHASH_TABLE (Lisp_Object a)
{
- return XUNTAG (a, Lisp_Vectorlike);
+ return SMOB_PTR (a);
}
#define XSET_HASH_TABLE(VAR, PTR) \
INLINE EMACS_UINT
SXHASH_REDUCE (EMACS_UINT x)
{
- return (x ^ x >> (BITS_PER_EMACS_INT - FIXNUM_BITS)) & INTMASK;
+ return (x ^ x >> (BITS_PER_EMACS_INT - FIXNUM_BITS + 1)) & INTMASK;
}
/* These structures are used for various misc types. */
struct Lisp_Misc_Any /* Supertype of all Misc types. */
{
+ Lisp_Object self;
ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_??? */
- bool_bf gcmarkbit : 1;
- unsigned spacer : 15;
};
struct Lisp_Marker
{
+ Lisp_Object self;
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. */
I.e. 9words plus 2 bits, 3words of which are for external linked lists.
*/
{
+ Lisp_Object self;
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;
struct Lisp_Save_Value
{
+ Lisp_Object self;
ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Save_Value */
- bool_bf gcmarkbit : 1;
- unsigned spacer : 32 - (16 + 1 + SAVE_TYPE_BITS);
+ unsigned spacer : 32 - (16 + 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
return XSAVE_VALUE (obj)->data[n].object;
}
-/* 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;
INLINE union Lisp_Misc *
XMISC (Lisp_Object a)
{
- return XUNTAG (a, Lisp_Misc);
+ return SMOB_PTR (a);
}
INLINE struct Lisp_Misc_Any *
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;
-}
+#define XFLOAT_DATA(f) (scm_to_double (f))
/* Most hosts nowadays use IEEE floating point, so they use IEC 60559
representations, have infinities and NaNs, and do not trap on
INLINE bool
STRINGP (Lisp_Object x)
{
- return XTYPE (x) == Lisp_String;
+ return SMOB_TYPEP (x, lisp_string_tag);
}
INLINE bool
VECTORP (Lisp_Object x)
else
{
/* Converting to struct vectorlike_header * avoids aliasing issues. */
- struct vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike);
+ struct vectorlike_header *h = SMOB_PTR (a);
return PSEUDOVECTOR_TYPEP (h, code);
}
}
-
/* Test for specific pseudovector types. */
INLINE bool
arguments, so we can catch errors with maxargs at compile-time. */
#ifdef _MSC_VER
#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \
+ SCM_SNARF_INIT (defsubr (&sname);) \
Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \
static struct Lisp_Subr alignas (GCALIGNMENT) sname = \
- { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \
+ { { NULL, \
+ (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \
| (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \
- { (Lisp_Object (__cdecl *)(void))fnname }, \
- minargs, maxargs, lname, intspec, 0}; \
+ { (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) \
+ SCM_SNARF_INIT (defsubr (&sname);) \
+ Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \
static struct Lisp_Subr alignas (GCALIGNMENT) sname = \
- { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \
- { .a ## maxargs = fnname }, \
- minargs, maxargs, lname, intspec, 0}; \
+ { { .self = NULL, \
+ .size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \
+ { .a ## maxargs = fnname }, \
+ minargs, maxargs, lname, intspec, 0}; \
Lisp_Object fnname
#endif
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. */
ENUM_BF (specbind_tag) kind : CHAR_BIT;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ } frame;
+ struct {
+ ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ bool wind_explicitly;
void (*func) (Lisp_Object);
Lisp_Object arg;
} unwind;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ bool wind_explicitly;
void (*func) (void *);
void *arg;
} unwind_ptr;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ bool wind_explicitly;
void (*func) (int);
int arg;
} unwind_int;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ bool wind_explicitly;
void (*func) (void);
} unwind_void;
struct {
struct handler
{
enum handlertype type;
+ Lisp_Object ptag;
Lisp_Object tag_or_ch;
Lisp_Object val;
+ Lisp_Object var;
+ Lisp_Object body;
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.
#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 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(varname) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname; gcpro1.nvars = 1; \
- gcprolist = &gcpro1; }
-
-#define GCPRO2(varname1, varname2) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcprolist = &gcpro2; }
-
-#define GCPRO3(varname1, varname2, varname3) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcprolist = &gcpro3; }
-
-#define GCPRO4(varname1, varname2, varname3, varname4) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \
- gcprolist = &gcpro4; }
-
-#define GCPRO5(varname1, varname2, varname3, varname4, varname5) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \
- gcpro5.next = &gcpro4; gcpro5.var = &varname5; gcpro5.nvars = 1; \
- gcprolist = &gcpro5; }
-
-#define GCPRO6(varname1, varname2, varname3, varname4, varname5, varname6) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \
- gcpro5.next = &gcpro4; gcpro5.var = &varname5; gcpro5.nvars = 1; \
- gcpro6.next = &gcpro5; gcpro6.var = &varname6; 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
-
-extern int gcpro_level;
-
-#define GCPRO1(varname) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname; gcpro1.nvars = 1; \
- gcpro1.level = gcpro_level++; \
- gcprolist = &gcpro1; }
-
-#define GCPRO2(varname1, varname2) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro1.level = gcpro_level; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro2.level = gcpro_level++; \
- gcprolist = &gcpro2; }
-
-#define GCPRO3(varname1, varname2, varname3) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro1.level = gcpro_level; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro3.level = gcpro_level++; \
- gcprolist = &gcpro3; }
-
-#define GCPRO4(varname1, varname2, varname3, varname4) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro1.level = gcpro_level; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \
- gcpro4.level = gcpro_level++; \
- gcprolist = &gcpro4; }
-
-#define GCPRO5(varname1, varname2, varname3, varname4, varname5) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro1.level = gcpro_level; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \
- gcpro5.next = &gcpro4; gcpro5.var = &varname5; gcpro5.nvars = 1; \
- gcpro5.level = gcpro_level++; \
- gcprolist = &gcpro5; }
-
-#define GCPRO6(varname1, varname2, varname3, varname4, varname5, varname6) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro1.level = gcpro_level; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \
- gcpro5.next = &gcpro4; gcpro5.var = &varname5; gcpro5.nvars = 1; \
- gcpro6.next = &gcpro5; gcpro6.var = &varname6; gcpro6.nvars = 1; \
- 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.level = gcpro_level; \
- 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; \
- 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 \
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 init_fns_once (void);
extern void syms_of_fns (void);
/* Defined in floatfns.c. */
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
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 pure_cons (Lisp_Object, Lisp_Object);
extern void make_byte_code (struct Lisp_Vector *);
-extern Lisp_Object Qautomatic_gc;
extern Lisp_Object Qchar_table_extra_slots;
extern struct Lisp_Vector *allocate_vector (EMACS_INT);
extern struct frame *allocate_frame (void);
extern struct Lisp_Process *allocate_process (void);
extern struct terminal *allocate_terminal (void);
-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_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. */
Lisp_Object);
extern _Noreturn void signal_error (const char *, Lisp_Object);
extern Lisp_Object eval_sub (Lisp_Object form);
+extern Lisp_Object Ffuncall (ptrdiff_t nargs, Lisp_Object *args);
extern Lisp_Object apply1 (Lisp_Object, Lisp_Object);
extern Lisp_Object call0 (Lisp_Object);
extern Lisp_Object call1 (Lisp_Object, Lisp_Object);
(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_1 (void (*) (Lisp_Object), Lisp_Object, bool);
extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object);
+extern void record_unwind_protect_ptr_1 (void (*) (void *), void *, bool);
extern void record_unwind_protect_ptr (void (*) (void *), void *);
+extern void record_unwind_protect_int_1 (void (*) (int), int, bool);
extern void record_unwind_protect_int (void (*) (int), int);
+extern void record_unwind_protect_void_1 (void (*) (void), bool);
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 void dynwind_begin (void);
+extern void dynwind_end (void);
extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
extern _Noreturn void verror (const char *, va_list)
ATTRIBUTE_FORMAT_PRINTF (1, 0);
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);
+extern _Noreturn SCM abort_to_prompt (SCM, SCM);
+extern SCM call_with_prompt (SCM, SCM, SCM);
+extern SCM make_prompt_tag (void);
/* Defined in editfns.c. */
Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, int);
extern void close_file_unwind (int);
+extern void close_file_ptr_unwind (void *);
extern void fclose_unwind (void *);
+extern void fclose_ptr_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);
/* 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 *);
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 *xmalloc_uncollectable (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
+extern void *xmalloc_unsafe (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
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 void *xmalloc_atomic (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
+extern void *xzalloc_atomic (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
+extern void *xmalloc_atomic_unsafe (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
+extern void *xnmalloc_atomic (ptrdiff_t, ptrdiff_t) ATTRIBUTE_MALLOC_SIZE ((1,2));
extern char *xstrdup (const char *) ATTRIBUTE_MALLOC;
extern char *xlispstrdup (Lisp_Object) ATTRIBUTE_MALLOC;
enum MAX_ALLOCA { MAX_ALLOCA = 16 * 1024 };
-extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
-
-#define USE_SAFE_ALLOCA \
- ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false
+#define USE_SAFE_ALLOCA ((void) 0)
/* SAFE_ALLOCA allocates a simple buffer. */
#define SAFE_ALLOCA(size) ((size) < MAX_ALLOCA \
? alloca (size) \
- : (sa_must_free = true, record_xmalloc (size)))
+ : xmalloc (size))
/* SAFE_NALLOCA sets BUF to a newly allocated array of MULTIPLIER *
NITEMS items, each of the same type as *BUF. MULTIPLIER must
if ((nitems) <= MAX_ALLOCA / sizeof *(buf) / (multiplier)) \
(buf) = alloca (sizeof *(buf) * (multiplier) * (nitems)); \
else \
- { \
- (buf) = xnmalloc (nitems, sizeof *(buf) * (multiplier)); \
- sa_must_free = true; \
- record_unwind_protect_ptr (xfree, buf); \
- } \
- } while (false)
+ (buf) = xnmalloc (nitems, sizeof *(buf) * (multiplier)); \
+ } while (0)
/* 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)
-
+#define SAFE_FREE() ((void) 0)
/* SAFE_ALLOCA_LISP allocates an array of Lisp_Objects. */
if ((nelt) < MAX_ALLOCA / word_size) \
(buf) = 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_); \
- } \
+ buf = xmalloc ((nelt) * word_size); \
else \
memory_full (SIZE_MAX); \
} while (false)
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 ();
+ return;
}
INLINE bool
}
INLINE_HEADER_END
-
#endif /* EMACS_LISP_H */
HCoop / bpt / emacs.git / blobdiff