+ 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. */
+
+static INLINE int
+live_string_p (m, p)
+ struct mem_node *m;
+ void *p;
+{
+ if (m->type == MEM_TYPE_STRING)
+ {
+ struct string_block *b = (struct string_block *) m->start;
+ int offset = (char *) p - (char *) &b->strings[0];
+
+ /* P must point to the start of a Lisp_String structure, and it
+ must not be on the free-list. */
+ return (offset % sizeof b->strings[0] == 0
+ && ((struct Lisp_String *) p)->data != NULL);
+ }
+ else
+ return 0;
+}
+
+
+/* Value is non-zero if P is a pointer to a live Lisp cons on
+ the heap. M is a pointer to the mem_block for P. */
+
+static INLINE int
+live_cons_p (m, p)
+ struct mem_node *m;
+ void *p;
+{
+ if (m->type == MEM_TYPE_CONS)
+ {
+ struct cons_block *b = (struct cons_block *) m->start;
+ int offset = (char *) p - (char *) &b->conses[0];
+
+ /* P must point to the start of a Lisp_Cons, not be
+ one of the unused cells in the current cons block,
+ and not be on the free-list. */
+ return (offset % sizeof b->conses[0] == 0
+ && (b != cons_block
+ || offset / sizeof b->conses[0] < cons_block_index)
+ && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
+ }
+ else
+ return 0;
+}
+
+
+/* Value is non-zero if P is a pointer to a live Lisp symbol on
+ the heap. M is a pointer to the mem_block for P. */
+
+static INLINE int
+live_symbol_p (m, p)
+ struct mem_node *m;
+ void *p;
+{
+ if (m->type == MEM_TYPE_SYMBOL)
+ {
+ struct symbol_block *b = (struct symbol_block *) m->start;
+ int offset = (char *) p - (char *) &b->symbols[0];
+
+ /* P must point to the start of a Lisp_Symbol, not be
+ one of the unused cells in the current symbol block,
+ and not be on the free-list. */
+ return (offset % sizeof b->symbols[0] == 0
+ && (b != symbol_block
+ || offset / sizeof b->symbols[0] < symbol_block_index)
+ && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
+ }
+ else
+ return 0;
+}
+
+
+/* Value is non-zero if P is a pointer to a live Lisp float on
+ the heap. M is a pointer to the mem_block for P. */
+
+static INLINE int
+live_float_p (m, p)
+ struct mem_node *m;
+ void *p;
+{
+ if (m->type == MEM_TYPE_FLOAT)
+ {
+ struct float_block *b = (struct float_block *) m->start;
+ int offset = (char *) p - (char *) &b->floats[0];
+
+ /* P must point to the start of a Lisp_Float, not be
+ one of the unused cells in the current float block,
+ and not be on the free-list. */
+ return (offset % sizeof b->floats[0] == 0
+ && (b != float_block
+ || offset / sizeof b->floats[0] < float_block_index)
+ && !EQ (((struct Lisp_Float *) p)->type, Vdead));
+ }
+ else
+ return 0;
+}
+
+
+/* Value is non-zero if P is a pointer to a live Lisp Misc on
+ the heap. M is a pointer to the mem_block for P. */
+
+static INLINE int
+live_misc_p (m, p)
+ struct mem_node *m;
+ void *p;
+{
+ if (m->type == MEM_TYPE_MISC)
+ {
+ struct marker_block *b = (struct marker_block *) m->start;
+ int offset = (char *) p - (char *) &b->markers[0];
+
+ /* P must point to the start of a Lisp_Misc, not be
+ one of the unused cells in the current misc block,
+ and not be on the free-list. */
+ return (offset % sizeof b->markers[0] == 0
+ && (b != marker_block
+ || offset / sizeof b->markers[0] < marker_block_index)
+ && ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free);
+ }
+ else
+ return 0;
+}
+
+
+/* Value is non-zero if P is a pointer to a live vector-like object.
+ M is a pointer to the mem_block for P. */
+
+static INLINE int
+live_vector_p (m, p)
+ struct mem_node *m;
+ void *p;
+{
+ return m->type == MEM_TYPE_VECTOR && p == m->start;
+}
+
+
+/* Value is non-zero of P is a pointer to a live buffer. M is a
+ pointer to the mem_block for P. */
+
+static INLINE int
+live_buffer_p (m, p)
+ struct mem_node *m;
+ void *p;
+{
+ /* P must point to the start of the block, and the buffer
+ must not have been killed. */
+ return (m->type == MEM_TYPE_BUFFER
+ && p == m->start
+ && !NILP (((struct buffer *) p)->name));
+}
+
+
+#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
+
+/* Array of objects that are kept alive because the C stack contains
+ a pattern that looks like a reference to them . */
+
+#define MAX_ZOMBIES 10
+static Lisp_Object zombies[MAX_ZOMBIES];
+
+/* Number of zombie objects. */
+
+static int nzombies;
+
+/* Number of garbage collections. */
+
+static int ngcs;
+
+/* Average percentage of zombies per collection. */
+
+static double avg_zombies;
+
+/* Max. number of live and zombie objects. */
+
+static int max_live, max_zombies;
+
+/* Average number of live objects per GC. */
+
+static double avg_live;
+
+DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
+ "Show information about live and zombie objects.")
+ ()
+{
+ Lisp_Object args[7];
+ args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
+ args[1] = make_number (ngcs);
+ args[2] = make_float (avg_live);
+ args[3] = make_float (avg_zombies);
+ args[4] = make_float (avg_zombies / avg_live / 100);
+ args[5] = make_number (max_live);
+ args[6] = make_number (max_zombies);
+ return Fmessage (7, args);
+}
+
+#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
+
+
+/* Mark OBJ if we can prove it's a Lisp_Object. */
+
+static INLINE void
+mark_maybe_object (obj)
+ Lisp_Object obj;
+{
+ void *po = (void *) XPNTR (obj);
+ struct mem_node *m = mem_find (po);
+
+ if (m != MEM_NIL)
+ {
+ int mark_p = 0;
+
+ switch (XGCTYPE (obj))
+ {
+ case Lisp_String:
+ mark_p = (live_string_p (m, po)
+ && !STRING_MARKED_P ((struct Lisp_String *) po));
+ break;
+
+ case Lisp_Cons:
+ mark_p = (live_cons_p (m, po)
+ && !XMARKBIT (XCONS (obj)->car));
+ break;
+
+ case Lisp_Symbol:
+ mark_p = (live_symbol_p (m, po)
+ && !XMARKBIT (XSYMBOL (obj)->plist));
+ break;
+
+ case Lisp_Float:
+ mark_p = (live_float_p (m, po)
+ && !XMARKBIT (XFLOAT (obj)->type));
+ break;
+
+ case Lisp_Vectorlike:
+ /* Note: can't check GC_BUFFERP before we know it's a
+ buffer because checking that dereferences the pointer
+ PO which might point anywhere. */
+ if (live_vector_p (m, po))
+ mark_p = (!GC_SUBRP (obj)
+ && !(XVECTOR (obj)->size & ARRAY_MARK_FLAG));
+ else if (live_buffer_p (m, po))
+ mark_p = GC_BUFFERP (obj) && !XMARKBIT (XBUFFER (obj)->name);
+ break;
+
+ case Lisp_Misc:
+ if (live_misc_p (m, po))
+ {
+ switch (XMISCTYPE (obj))
+ {
+ case Lisp_Misc_Marker:
+ mark_p = !XMARKBIT (XMARKER (obj)->chain);
+ break;
+
+ case Lisp_Misc_Buffer_Local_Value:
+ case Lisp_Misc_Some_Buffer_Local_Value:
+ mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
+ break;
+
+ case Lisp_Misc_Overlay:
+ mark_p = !XMARKBIT (XOVERLAY (obj)->plist);
+ break;
+ }
+ }
+ break;
+ }
+
+ if (mark_p)
+ {
+#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
+ if (nzombies < MAX_ZOMBIES)
+ zombies[nzombies] = *p;
+ ++nzombies;
+#endif
+ mark_object (&obj);
+ }
+ }