+/* Return a multibyte Lisp_String set up to hold NCHARS characters
+ which occupy NBYTES bytes. */
+
+Lisp_Object
+make_uninit_multibyte_string (nchars, nbytes)
+ int nchars, nbytes;
+{
+ Lisp_Object string;
+ struct Lisp_String *s;
+
+ if (nchars < 0)
+ abort ();
+
+ s = allocate_string ();
+ allocate_string_data (s, nchars, nbytes);
+ XSETSTRING (string, s);
+ string_chars_consed += nbytes;
+ return string;
+}
+
+
+\f
+/***********************************************************************
+ Float Allocation
+ ***********************************************************************/
+
+/* We store float cells inside of float_blocks, allocating a new
+ float_block with malloc whenever necessary. Float cells reclaimed
+ by GC are put on a free list to be reallocated before allocating
+ any new float cells from the latest float_block.
+
+ Each float_block is just under 1020 bytes long, since malloc really
+ allocates in units of powers of two and uses 4 bytes for its own
+ overhead. */
+
+#define FLOAT_BLOCK_SIZE \
+ ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
+
+struct float_block
+{
+ struct float_block *next;
+ struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
+};
+
+/* Current float_block. */
+
+struct float_block *float_block;
+
+/* Index of first unused Lisp_Float in the current float_block. */
+
+int float_block_index;
+
+/* Total number of float blocks now in use. */
+
+int n_float_blocks;
+
+/* Free-list of Lisp_Floats. */
+
+struct Lisp_Float *float_free_list;
+
+
+/* Initialze float allocation. */
+
+void
+init_float ()
+{
+ float_block = (struct float_block *) lisp_malloc (sizeof *float_block,
+ MEM_TYPE_FLOAT);
+ float_block->next = 0;
+ bzero ((char *) float_block->floats, sizeof float_block->floats);
+ float_block_index = 0;
+ float_free_list = 0;
+ n_float_blocks = 1;
+}
+
+
+/* Explicitly free a float cell by putting it on the free-list. */
+
+void
+free_float (ptr)
+ struct Lisp_Float *ptr;
+{
+ *(struct Lisp_Float **)&ptr->data = float_free_list;
+#if GC_MARK_STACK
+ ptr->type = Vdead;
+#endif
+ float_free_list = ptr;
+}
+
+
+/* Return a new float object with value FLOAT_VALUE. */
+
+Lisp_Object
+make_float (float_value)
+ double float_value;
+{
+ register Lisp_Object val;
+
+ if (float_free_list)
+ {
+ /* We use the data field for chaining the free list
+ so that we won't use the same field that has the mark bit. */
+ XSETFLOAT (val, float_free_list);
+ float_free_list = *(struct Lisp_Float **)&float_free_list->data;
+ }
+ else
+ {
+ if (float_block_index == FLOAT_BLOCK_SIZE)
+ {
+ register struct float_block *new;
+
+ new = (struct float_block *) lisp_malloc (sizeof *new,
+ MEM_TYPE_FLOAT);
+ VALIDATE_LISP_STORAGE (new, sizeof *new);
+ new->next = float_block;
+ float_block = new;
+ float_block_index = 0;
+ n_float_blocks++;
+ }
+ XSETFLOAT (val, &float_block->floats[float_block_index++]);
+ }
+
+ XFLOAT_DATA (val) = float_value;
+ XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */
+ consing_since_gc += sizeof (struct Lisp_Float);
+ floats_consed++;
+ return val;
+}
+
+
+\f
+/***********************************************************************
+ Cons Allocation
+ ***********************************************************************/
+
+/* We store cons cells inside of cons_blocks, allocating a new
+ cons_block with malloc whenever necessary. Cons cells reclaimed by
+ GC are put on a free list to be reallocated before allocating
+ any new cons cells from the latest cons_block.
+
+ Each cons_block is just under 1020 bytes long,
+ since malloc really allocates in units of powers of two
+ and uses 4 bytes for its own overhead. */
+
+#define CONS_BLOCK_SIZE \
+ ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
+
+struct cons_block
+{
+ struct cons_block *next;
+ struct Lisp_Cons conses[CONS_BLOCK_SIZE];
+};
+
+/* Current cons_block. */
+
+struct cons_block *cons_block;
+
+/* Index of first unused Lisp_Cons in the current block. */
+
+int cons_block_index;
+
+/* Free-list of Lisp_Cons structures. */
+
+struct Lisp_Cons *cons_free_list;
+
+/* Total number of cons blocks now in use. */
+
+int n_cons_blocks;
+
+
+/* Initialize cons allocation. */
+
+void
+init_cons ()
+{
+ cons_block = (struct cons_block *) lisp_malloc (sizeof *cons_block,
+ MEM_TYPE_CONS);
+ cons_block->next = 0;
+ bzero ((char *) cons_block->conses, sizeof cons_block->conses);
+ cons_block_index = 0;
+ cons_free_list = 0;
+ n_cons_blocks = 1;
+}
+
+
+/* Explicitly free a cons cell by putting it on the free-list. */
+
+void
+free_cons (ptr)
+ struct Lisp_Cons *ptr;
+{
+ *(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
+#if GC_MARK_STACK
+ ptr->car = Vdead;
+#endif
+ cons_free_list = ptr;
+}
+
+
+DEFUN ("cons", Fcons, Scons, 2, 2, 0,
+ "Create a new cons, give it CAR and CDR as components, and return it.")
+ (car, cdr)
+ Lisp_Object car, cdr;
+{
+ register Lisp_Object val;
+
+ if (cons_free_list)
+ {
+ /* We use the cdr for chaining the free list
+ so that we won't use the same field that has the mark bit. */
+ XSETCONS (val, cons_free_list);
+ cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr;
+ }
+ else
+ {
+ if (cons_block_index == CONS_BLOCK_SIZE)
+ {
+ register struct cons_block *new;
+ new = (struct cons_block *) lisp_malloc (sizeof *new,
+ MEM_TYPE_CONS);
+ VALIDATE_LISP_STORAGE (new, sizeof *new);
+ new->next = cons_block;
+ cons_block = new;
+ cons_block_index = 0;
+ n_cons_blocks++;
+ }
+ XSETCONS (val, &cons_block->conses[cons_block_index++]);
+ }
+
+ XCAR (val) = car;
+ XCDR (val) = cdr;
+ consing_since_gc += sizeof (struct Lisp_Cons);
+ cons_cells_consed++;
+ return val;
+}
+
+
+/* Make a list of 2, 3, 4 or 5 specified objects. */
+
+Lisp_Object
+list2 (arg1, arg2)
+ Lisp_Object arg1, arg2;
+{
+ return Fcons (arg1, Fcons (arg2, Qnil));
+}
+
+
+Lisp_Object
+list3 (arg1, arg2, arg3)
+ Lisp_Object arg1, arg2, arg3;
+{
+ return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
+}
+
+
+Lisp_Object
+list4 (arg1, arg2, arg3, arg4)
+ Lisp_Object arg1, arg2, arg3, arg4;
+{
+ return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
+}
+
+
+Lisp_Object
+list5 (arg1, arg2, arg3, arg4, arg5)
+ Lisp_Object arg1, arg2, arg3, arg4, arg5;
+{
+ return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
+ Fcons (arg5, Qnil)))));
+}
+
+
+DEFUN ("list", Flist, Slist, 0, MANY, 0,
+ "Return a newly created list with specified arguments as elements.\n\
+Any number of arguments, even zero arguments, are allowed.")
+ (nargs, args)
+ int nargs;
+ register Lisp_Object *args;
+{
+ register Lisp_Object val;
+ val = Qnil;
+
+ while (nargs > 0)
+ {
+ nargs--;
+ val = Fcons (args[nargs], val);
+ }
+ return val;
+}
+
+
+DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
+ "Return a newly created list of length LENGTH, with each element being INIT.")
+ (length, init)
+ register Lisp_Object length, init;
+{
+ register Lisp_Object val;
+ register int size;
+
+ CHECK_NATNUM (length, 0);
+ size = XFASTINT (length);
+
+ val = Qnil;
+ while (size-- > 0)
+ val = Fcons (init, val);
+ return val;
+}
+
+
+\f
+/***********************************************************************
+ Vector Allocation
+ ***********************************************************************/
+
+/* Singly-linked list of all vectors. */
+
+struct Lisp_Vector *all_vectors;
+
+/* Total number of vector-like objects now in use. */
+
+int n_vectors;
+
+
+/* Value is a pointer to a newly allocated Lisp_Vector structure
+ with room for LEN Lisp_Objects. */
+
+struct Lisp_Vector *
+allocate_vectorlike (len)
+ EMACS_INT len;
+{
+ struct Lisp_Vector *p;
+ size_t nbytes;
+
+#ifdef DOUG_LEA_MALLOC
+ /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
+ because mapped region contents are not preserved in
+ a dumped Emacs. */
+ mallopt (M_MMAP_MAX, 0);
+#endif
+
+ nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
+ p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTOR);
+
+#ifdef DOUG_LEA_MALLOC
+ /* Back to a reasonable maximum of mmap'ed areas. */
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+#endif
+
+ VALIDATE_LISP_STORAGE (p, 0);
+ consing_since_gc += nbytes;
+ vector_cells_consed += len;
+
+ p->next = all_vectors;
+ all_vectors = p;
+ ++n_vectors;
+ return p;
+}
+
+
+DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
+ "Return a newly created vector of length LENGTH, with each element being INIT.\n\
+See also the function `vector'.")
+ (length, init)
+ register Lisp_Object length, init;
+{
+ Lisp_Object vector;
+ register EMACS_INT sizei;
+ register int index;
+ register struct Lisp_Vector *p;
+
+ CHECK_NATNUM (length, 0);
+ sizei = XFASTINT (length);
+
+ p = allocate_vectorlike (sizei);
+ p->size = sizei;
+ for (index = 0; index < sizei; index++)
+ p->contents[index] = init;
+
+ XSETVECTOR (vector, p);
+ return vector;
+}
+
+
+DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
+ "Return a newly created char-table, with purpose PURPOSE.\n\
+Each element is initialized to INIT, which defaults to nil.\n\
+PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
+The property's value should be an integer between 0 and 10.")
+ (purpose, init)
+ register Lisp_Object purpose, init;
+{
+ Lisp_Object vector;
+ Lisp_Object n;
+ CHECK_SYMBOL (purpose, 1);
+ n = Fget (purpose, Qchar_table_extra_slots);
+ CHECK_NUMBER (n, 0);
+ if (XINT (n) < 0 || XINT (n) > 10)
+ args_out_of_range (n, Qnil);
+ /* Add 2 to the size for the defalt and parent slots. */
+ vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)),
+ init);
+ XCHAR_TABLE (vector)->top = Qt;
+ XCHAR_TABLE (vector)->parent = Qnil;
+ XCHAR_TABLE (vector)->purpose = purpose;
+ XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
+ return vector;
+}
+
+
+/* Return a newly created sub char table with default value DEFALT.
+ Since a sub char table does not appear as a top level Emacs Lisp
+ object, we don't need a Lisp interface to make it. */
+
+Lisp_Object
+make_sub_char_table (defalt)
+ Lisp_Object defalt;
+{
+ Lisp_Object vector
+ = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), Qnil);
+ XCHAR_TABLE (vector)->top = Qnil;
+ XCHAR_TABLE (vector)->defalt = defalt;
+ XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
+ return vector;
+}
+
+
+DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
+ "Return a newly created vector with specified arguments as elements.\n\
+Any number of arguments, even zero arguments, are allowed.")
+ (nargs, args)
+ register int nargs;
+ Lisp_Object *args;
+{
+ register Lisp_Object len, val;
+ register int index;
+ register struct Lisp_Vector *p;
+
+ XSETFASTINT (len, nargs);
+ val = Fmake_vector (len, Qnil);
+ p = XVECTOR (val);
+ for (index = 0; index < nargs; index++)
+ p->contents[index] = args[index];
+ return val;
+}
+
+
+DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
+ "Create a byte-code object with specified arguments as elements.\n\
+The arguments should be the arglist, bytecode-string, constant vector,\n\
+stack size, (optional) doc string, and (optional) interactive spec.\n\
+The first four arguments are required; at most six have any\n\
+significance.")
+ (nargs, args)
+ register int nargs;
+ Lisp_Object *args;
+{
+ register Lisp_Object len, val;
+ register int index;
+ register struct Lisp_Vector *p;
+
+ XSETFASTINT (len, nargs);
+ if (!NILP (Vpurify_flag))
+ val = make_pure_vector ((EMACS_INT) nargs);
+ else
+ val = Fmake_vector (len, Qnil);
+
+ if (STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
+ /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
+ earlier because they produced a raw 8-bit string for byte-code
+ and now such a byte-code string is loaded as multibyte while
+ raw 8-bit characters converted to multibyte form. Thus, now we
+ must convert them back to the original unibyte form. */
+ args[1] = Fstring_as_unibyte (args[1]);
+
+ p = XVECTOR (val);
+ for (index = 0; index < nargs; index++)
+ {
+ if (!NILP (Vpurify_flag))
+ args[index] = Fpurecopy (args[index]);
+ p->contents[index] = args[index];
+ }
+ XSETCOMPILED (val, p);
+ return val;
+}
+
+
+\f
+/***********************************************************************
+ Symbol Allocation
+ ***********************************************************************/
+
+/* Each symbol_block is just under 1020 bytes long, since malloc
+ really allocates in units of powers of two and uses 4 bytes for its
+ own overhead. */
+
+#define SYMBOL_BLOCK_SIZE \
+ ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
+
+struct symbol_block
+{
+ struct symbol_block *next;
+ struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
+};
+
+/* Current symbol block and index of first unused Lisp_Symbol
+ structure in it. */
+
+struct symbol_block *symbol_block;
+int symbol_block_index;
+
+/* List of free symbols. */
+
+struct Lisp_Symbol *symbol_free_list;
+
+/* Total number of symbol blocks now in use. */
+
+int n_symbol_blocks;
+
+
+/* Initialize symbol allocation. */
+
+void
+init_symbol ()
+{
+ symbol_block = (struct symbol_block *) lisp_malloc (sizeof *symbol_block,
+ MEM_TYPE_SYMBOL);
+ symbol_block->next = 0;
+ bzero ((char *) symbol_block->symbols, sizeof symbol_block->symbols);
+ symbol_block_index = 0;
+ symbol_free_list = 0;
+ n_symbol_blocks = 1;
+}
+
+
+DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
+ "Return a newly allocated uninterned symbol whose name is NAME.\n\
+Its value and function definition are void, and its property list is nil.")
+ (name)
+ Lisp_Object name;
+{
+ register Lisp_Object val;
+ register struct Lisp_Symbol *p;
+
+ CHECK_STRING (name, 0);
+
+ if (symbol_free_list)
+ {
+ XSETSYMBOL (val, symbol_free_list);
+ symbol_free_list = *(struct Lisp_Symbol **)&symbol_free_list->value;
+ }
+ else
+ {
+ if (symbol_block_index == SYMBOL_BLOCK_SIZE)
+ {
+ struct symbol_block *new;
+ new = (struct symbol_block *) lisp_malloc (sizeof *new,
+ MEM_TYPE_SYMBOL);
+ VALIDATE_LISP_STORAGE (new, sizeof *new);
+ new->next = symbol_block;
+ symbol_block = new;
+ symbol_block_index = 0;
+ n_symbol_blocks++;
+ }
+ XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
+ }
+
+ p = XSYMBOL (val);
+ p->name = XSTRING (name);
+ p->obarray = Qnil;
+ p->plist = Qnil;
+ p->value = Qunbound;
+ p->function = Qunbound;
+ p->next = 0;
+ consing_since_gc += sizeof (struct Lisp_Symbol);
+ symbols_consed++;
+ return val;
+}
+
+
+\f
+/***********************************************************************
+ Marker (Misc) Allocation
+ ***********************************************************************/
+
+/* Allocation of markers and other objects that share that structure.
+ Works like allocation of conses. */
+
+#define MARKER_BLOCK_SIZE \
+ ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
+
+struct marker_block
+{
+ struct marker_block *next;
+ union Lisp_Misc markers[MARKER_BLOCK_SIZE];
+};
+
+struct marker_block *marker_block;
+int marker_block_index;
+
+union Lisp_Misc *marker_free_list;
+
+/* Total number of marker blocks now in use. */
+
+int n_marker_blocks;
+
+void
+init_marker ()
+{
+ marker_block = (struct marker_block *) lisp_malloc (sizeof *marker_block,
+ MEM_TYPE_MISC);
+ marker_block->next = 0;
+ bzero ((char *) marker_block->markers, sizeof marker_block->markers);
+ marker_block_index = 0;
+ marker_free_list = 0;
+ n_marker_blocks = 1;
+}
+
+/* Return a newly allocated Lisp_Misc object, with no substructure. */
+
+Lisp_Object
+allocate_misc ()
+{
+ Lisp_Object val;
+
+ if (marker_free_list)
+ {
+ XSETMISC (val, marker_free_list);
+ marker_free_list = marker_free_list->u_free.chain;
+ }
+ else
+ {
+ if (marker_block_index == MARKER_BLOCK_SIZE)
+ {
+ struct marker_block *new;
+ new = (struct marker_block *) lisp_malloc (sizeof *new,
+ MEM_TYPE_MISC);
+ VALIDATE_LISP_STORAGE (new, sizeof *new);
+ new->next = marker_block;
+ marker_block = new;
+ marker_block_index = 0;
+ n_marker_blocks++;
+ }
+ XSETMISC (val, &marker_block->markers[marker_block_index++]);
+ }
+
+ consing_since_gc += sizeof (union Lisp_Misc);
+ misc_objects_consed++;
+ return val;
+}
+
+DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
+ "Return a newly allocated marker which does not point at any place.")
+ ()
+{
+ register Lisp_Object val;
+ register struct Lisp_Marker *p;
+
+ val = allocate_misc ();
+ XMISCTYPE (val) = Lisp_Misc_Marker;
+ p = XMARKER (val);
+ p->buffer = 0;
+ p->bytepos = 0;
+ p->charpos = 0;
+ p->chain = Qnil;
+ p->insertion_type = 0;
+ return val;
+}
+
+/* Put MARKER back on the free list after using it temporarily. */
+
+void
+free_marker (marker)
+ Lisp_Object marker;
+{
+ unchain_marker (marker);
+
+ XMISC (marker)->u_marker.type = Lisp_Misc_Free;
+ XMISC (marker)->u_free.chain = marker_free_list;
+ marker_free_list = XMISC (marker);
+
+ total_free_markers++;
+}
+
+\f
+/* Return a newly created vector or string with specified arguments as
+ elements. If all the arguments are characters that can fit
+ in a string of events, make a string; otherwise, make a vector.
+
+ Any number of arguments, even zero arguments, are allowed. */
+
+Lisp_Object
+make_event_array (nargs, args)
+ register int nargs;
+ Lisp_Object *args;
+{
+ int i;
+
+ for (i = 0; i < nargs; i++)
+ /* The things that fit in a string
+ are characters that are in 0...127,
+ after discarding the meta bit and all the bits above it. */
+ if (!INTEGERP (args[i])
+ || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
+ return Fvector (nargs, args);
+
+ /* Since the loop exited, we know that all the things in it are
+ characters, so we can make a string. */
+ {
+ Lisp_Object result;
+
+ result = Fmake_string (make_number (nargs), make_number (0));
+ for (i = 0; i < nargs; i++)
+ {
+ XSTRING (result)->data[i] = XINT (args[i]);
+ /* Move the meta bit to the right place for a string char. */
+ if (XINT (args[i]) & CHAR_META)
+ XSTRING (result)->data[i] |= 0x80;
+ }
+
+ return result;
+ }
+}
+
+
+\f
+/************************************************************************
+ C Stack Marking
+ ************************************************************************/
+
+#if GC_MARK_STACK
+
+
+/* Base address of stack. Set in main. */
+
+Lisp_Object *stack_base;
+
+/* A node in the red-black tree describing allocated memory containing
+ Lisp data. Each such block is recorded with its start and end
+ address when it is allocated, and removed from the tree when it
+ is freed.
+
+ A red-black tree is a balanced binary tree with the following
+ properties:
+
+ 1. Every node is either red or black.
+ 2. Every leaf is black.
+ 3. If a node is red, then both of its children are black.
+ 4. Every simple path from a node to a descendant leaf contains
+ the same number of black nodes.
+ 5. The root is always black.
+
+ When nodes are inserted into the tree, or deleted from the tree,
+ the tree is "fixed" so that these properties are always true.
+
+ A red-black tree with N internal nodes has height at most 2
+ log(N+1). Searches, insertions and deletions are done in O(log N).
+ Please see a text book about data structures for a detailed
+ description of red-black trees. Any book worth its salt should
+ describe them. */
+
+struct mem_node
+{
+ struct mem_node *left, *right, *parent;
+
+ /* Start and end of allocated region. */
+ void *start, *end;
+
+ /* Node color. */
+ enum {MEM_BLACK, MEM_RED} color;
+
+ /* Memory type. */
+ enum mem_type type;
+};
+
+/* Root of the tree describing allocated Lisp memory. */
+
+static struct mem_node *mem_root;
+
+/* Sentinel node of the tree. */
+
+static struct mem_node mem_z;
+#define MEM_NIL &mem_z
+
+
+/* Initialize this part of alloc.c. */
+
+static void
+mem_init ()
+{
+ mem_z.left = mem_z.right = MEM_NIL;
+ mem_z.parent = NULL;
+ mem_z.color = MEM_BLACK;
+ mem_z.start = mem_z.end = NULL;
+ mem_root = MEM_NIL;
+}
+
+
+/* Value is a pointer to the mem_node containing START. Value is
+ MEM_NIL if there is no node in the tree containing START. */
+
+static INLINE struct mem_node *
+mem_find (start)
+ void *start;
+{
+ struct mem_node *p;
+
+ /* Make the search always successful to speed up the loop below. */
+ mem_z.start = start;
+ mem_z.end = (char *) start + 1;
+
+ p = mem_root;
+ while (start < p->start || start >= p->end)
+ p = start < p->start ? p->left : p->right;
+ return p;
+}
+
+
+/* Insert a new node into the tree for a block of memory with start
+ address START, end address END, and type TYPE. Value is a
+ pointer to the node that was inserted. */
+
+static struct mem_node *
+mem_insert (start, end, type)
+ void *start, *end;
+ enum mem_type type;
+{
+ struct mem_node *c, *parent, *x;
+
+ /* See where in the tree a node for START belongs. In this
+ particular application, it shouldn't happen that a node is already
+ present. For debugging purposes, let's check that. */
+ c = mem_root;
+ parent = NULL;
+
+#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
+
+ while (c != MEM_NIL)
+ {
+ if (start >= c->start && start < c->end)
+ abort ();
+ parent = c;
+ c = start < c->start ? c->left : c->right;
+ }
+
+#else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
+
+ while (c != MEM_NIL)
+ {
+ parent = c;
+ c = start < c->start ? c->left : c->right;
+ }
+
+#endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
+
+ /* Create a new node. */
+ x = (struct mem_node *) xmalloc (sizeof *x);
+ x->start = start;
+ x->end = end;
+ x->type = type;
+ x->parent = parent;
+ x->left = x->right = MEM_NIL;
+ x->color = MEM_RED;
+
+ /* Insert it as child of PARENT or install it as root. */
+ if (parent)
+ {
+ if (start < parent->start)
+ parent->left = x;
+ else
+ parent->right = x;
+ }
+ else
+ mem_root = x;
+
+ /* Re-establish red-black tree properties. */
+ mem_insert_fixup (x);
+ return x;
+}
+
+
+/* Re-establish the red-black properties of the tree, and thereby
+ balance the tree, after node X has been inserted; X is always red. */
+
+static void
+mem_insert_fixup (x)
+ struct mem_node *x;
+{
+ while (x != mem_root && x->parent->color == MEM_RED)
+ {
+ /* X is red and its parent is red. This is a violation of
+ red-black tree property #3. */
+
+ if (x->parent == x->parent->parent->left)
+ {
+ /* We're on the left side of our grandparent, and Y is our
+ "uncle". */
+ struct mem_node *y = x->parent->parent->right;
+
+ if (y->color == MEM_RED)
+ {
+ /* Uncle and parent are red but should be black because
+ X is red. Change the colors accordingly and proceed
+ with the grandparent. */
+ x->parent->color = MEM_BLACK;
+ y->color = MEM_BLACK;
+ x->parent->parent->color = MEM_RED;
+ x = x->parent->parent;
+ }
+ else
+ {
+ /* Parent and uncle have different colors; parent is
+ red, uncle is black. */
+ if (x == x->parent->right)
+ {
+ x = x->parent;
+ mem_rotate_left (x);
+ }
+
+ x->parent->color = MEM_BLACK;
+ x->parent->parent->color = MEM_RED;
+ mem_rotate_right (x->parent->parent);
+ }
+ }
+ else
+ {
+ /* This is the symmetrical case of above. */
+ struct mem_node *y = x->parent->parent->left;
+
+ if (y->color == MEM_RED)
+ {
+ x->parent->color = MEM_BLACK;
+ y->color = MEM_BLACK;
+ x->parent->parent->color = MEM_RED;
+ x = x->parent->parent;
+ }
+ else
+ {
+ if (x == x->parent->left)
+ {
+ x = x->parent;
+ mem_rotate_right (x);
+ }
+
+ x->parent->color = MEM_BLACK;
+ x->parent->parent->color = MEM_RED;
+ mem_rotate_left (x->parent->parent);
+ }
+ }
+ }
+
+ /* The root may have been changed to red due to the algorithm. Set
+ it to black so that property #5 is satisfied. */
+ mem_root->color = MEM_BLACK;
+}
+
+
+/* (x) (y)
+ / \ / \
+ a (y) ===> (x) c
+ / \ / \
+ b c a b */
+
+static void
+mem_rotate_left (x)
+ struct mem_node *x;
+{
+ struct mem_node *y;
+
+ /* Turn y's left sub-tree into x's right sub-tree. */
+ y = x->right;
+ x->right = y->left;
+ if (y->left != MEM_NIL)
+ y->left->parent = x;
+
+ /* Y's parent was x's parent. */
+ if (y != MEM_NIL)
+ y->parent = x->parent;
+
+ /* Get the parent to point to y instead of x. */
+ if (x->parent)
+ {
+ if (x == x->parent->left)
+ x->parent->left = y;
+ else
+ x->parent->right = y;
+ }
+ else
+ mem_root = y;
+
+ /* Put x on y's left. */
+ y->left = x;
+ if (x != MEM_NIL)
+ x->parent = y;
+}
+
+
+/* (x) (Y)
+ / \ / \
+ (y) c ===> a (x)
+ / \ / \
+ a b b c */
+
+static void
+mem_rotate_right (x)
+ struct mem_node *x;
+{
+ struct mem_node *y = x->left;
+
+ x->left = y->right;
+ if (y->right != MEM_NIL)
+ y->right->parent = x;
+
+ if (y != MEM_NIL)
+ y->parent = x->parent;
+ if (x->parent)
+ {
+ if (x == x->parent->right)
+ x->parent->right = y;
+ else
+ x->parent->left = y;
+ }
+ else
+ mem_root = y;
+
+ y->right = x;
+ if (x != MEM_NIL)
+ x->parent = y;
+}
+
+
+/* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
+
+static void
+mem_delete (z)
+ struct mem_node *z;
+{
+ struct mem_node *x, *y;
+
+ if (!z || z == MEM_NIL)
+ return;
+
+ if (z->left == MEM_NIL || z->right == MEM_NIL)
+ y = z;
+ else
+ {
+ y = z->right;
+ while (y->left != MEM_NIL)
+ y = y->left;
+ }
+
+ if (y->left != MEM_NIL)
+ x = y->left;
+ else
+ x = y->right;
+
+ x->parent = y->parent;
+ if (y->parent)
+ {
+ if (y == y->parent->left)
+ y->parent->left = x;
+ else
+ y->parent->right = x;
+ }
+ else
+ mem_root = x;
+
+ if (y != z)
+ {
+ z->start = y->start;
+ z->end = y->end;
+ z->type = y->type;
+ }
+
+ if (y->color == MEM_BLACK)
+ mem_delete_fixup (x);
+ xfree (y);
+}
+
+
+/* Re-establish the red-black properties of the tree, after a
+ deletion. */
+
+static void
+mem_delete_fixup (x)
+ struct mem_node *x;
+{
+ while (x != mem_root && x->color == MEM_BLACK)
+ {
+ if (x == x->parent->left)
+ {
+ struct mem_node *w = x->parent->right;
+
+ if (w->color == MEM_RED)
+ {
+ w->color = MEM_BLACK;
+ x->parent->color = MEM_RED;
+ mem_rotate_left (x->parent);
+ w = x->parent->right;
+ }
+
+ if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
+ {
+ w->color = MEM_RED;
+ x = x->parent;
+ }
+ else
+ {
+ if (w->right->color == MEM_BLACK)
+ {
+ w->left->color = MEM_BLACK;
+ w->color = MEM_RED;
+ mem_rotate_right (w);
+ w = x->parent->right;
+ }
+ w->color = x->parent->color;
+ x->parent->color = MEM_BLACK;
+ w->right->color = MEM_BLACK;
+ mem_rotate_left (x->parent);
+ x = mem_root;
+ }
+ }
+ else
+ {
+ struct mem_node *w = x->parent->left;
+
+ if (w->color == MEM_RED)
+ {
+ w->color = MEM_BLACK;
+ x->parent->color = MEM_RED;
+ mem_rotate_right (x->parent);
+ w = x->parent->left;
+ }
+
+ if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
+ {
+ w->color = MEM_RED;
+ x = x->parent;
+ }
+ else
+ {
+ if (w->left->color == MEM_BLACK)
+ {
+ w->right->color = MEM_BLACK;
+ w->color = MEM_RED;
+ mem_rotate_left (w);
+ w = x->parent->left;
+ }
+
+ w->color = x->parent->color;
+ x->parent->color = MEM_BLACK;
+ w->left->color = MEM_BLACK;
+ mem_rotate_right (x->parent);
+ x = mem_root;
+ }
+ }
+ }
+
+ x->color = MEM_BLACK;
+}
+
+
+/* Value is non-zero if P is a pointer to a live Lisp string on
+ the heap. M is a pointer to the mem_block for P. */