+/* 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 || defined GC_MALLOC_CHECK
+
+/* 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. */
+#ifdef GC_MALLOC_CHECK
+ x = (struct mem_node *) _malloc_internal (sizeof *x);
+ if (x == NULL)
+ abort ();
+#else
+ x = (struct mem_node *) xmalloc (sizeof *x);
+#endif
+ 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);
+
+#ifdef GC_MALLOC_CHECK
+ _free_internal (y);
+#else
+ xfree (y);
+#endif
+}
+
+
+/* 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));
+}
+
+#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
+
+#if GC_MARK_STACK
+
+#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;
+
+ case Lisp_Int:
+ case Lisp_Type_Limit:
+ 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);
+ }
+ }
+}
+
+/* Mark Lisp objects in the address range START..END. */
+
+static void
+mark_memory (start, end)
+ void *start, *end;
+{
+ Lisp_Object *p;
+
+#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
+ nzombies = 0;
+#endif
+
+ /* Make START the pointer to the start of the memory region,
+ if it isn't already. */
+ if (end < start)
+ {
+ void *tem = start;
+ start = end;
+ end = tem;
+ }
+
+ for (p = (Lisp_Object *) start; (void *) p < end; ++p)
+ mark_maybe_object (*p);
+}
+
+
+#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
+
+static int setjmp_tested_p, longjmps_done;
+
+#define SETJMP_WILL_LIKELY_WORK "\
+\n\
+Emacs garbage collector has been changed to use conservative stack\n\
+marking. Emacs has determined that the method it uses to do the\n\
+marking will likely work on your system, but this isn't sure.\n\
+\n\
+If you are a system-programmer, or can get the help of a local wizard\n\
+who is, please take a look at the function mark_stack in alloc.c, and\n\
+verify that the methods used are appropriate for your system.\n\
+\n\
+Please mail the result to <gerd@gnu.org>.\n\
+"
+
+#define SETJMP_WILL_NOT_WORK "\
+\n\
+Emacs garbage collector has been changed to use conservative stack\n\
+marking. Emacs has determined that the default method it uses to do the\n\
+marking will not work on your system. We will need a system-dependent\n\
+solution for your system.\n\
+\n\
+Please take a look at the function mark_stack in alloc.c, and\n\
+try to find a way to make it work on your system.\n\
+Please mail the result to <gerd@gnu.org>.\n\
+"
+
+
+/* Perform a quick check if it looks like setjmp saves registers in a
+ jmp_buf. Print a message to stderr saying so. When this test
+ succeeds, this is _not_ a proof that setjmp is sufficient for
+ conservative stack marking. Only the sources or a disassembly
+ can prove that. */
+
+static void
+test_setjmp ()
+{
+ char buf[10];
+ register int x;
+ jmp_buf jbuf;
+ int result = 0;
+
+ /* Arrange for X to be put in a register. */
+ sprintf (buf, "1");
+ x = strlen (buf);
+ x = 2 * x - 1;
+
+ setjmp (jbuf);
+ if (longjmps_done == 1)
+ {
+ /* Came here after the longjmp at the end of the function.
+
+ If x == 1, the longjmp has restored the register to its
+ value before the setjmp, and we can hope that setjmp
+ saves all such registers in the jmp_buf, although that
+ isn't sure.
+
+ For other values of X, either something really strange is
+ taking place, or the setjmp just didn't save the register. */
+
+ if (x == 1)
+ fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
+ else
+ {
+ fprintf (stderr, SETJMP_WILL_NOT_WORK);
+ exit (1);
+ }
+ }
+
+ ++longjmps_done;
+ x = 2;
+ if (longjmps_done == 1)
+ longjmp (jbuf, 1);
+}
+
+#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */