comparison src/alloc.c @ 49600:23a1cea22d13

Trailing whitespace deleted.

49599:5ade352e8d1c

  /* Start and end of allocated region.  */
  void *start, *end;

  /* Node color.  */
  enum {MEM_BLACK, MEM_RED} color;
  
  /* Memory type.  */
  enum mem_type type;
};

/* Base address of stack.  Set in main.  */

  BLOCK_INPUT;

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
  
  val = (void *) malloc (nbytes);

#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
  if (val && type != MEM_TYPE_NON_LISP)
    mem_insert (val, (char *) val + nbytes, type);
#endif
   
  UNBLOCK_INPUT;
  if (!val && nbytes)
    memory_full ();
  return val;
}

   a call to lisp_malloc.  */

struct buffer *
allocate_buffer ()
{
  struct buffer *b 
    = (struct buffer *) lisp_malloc (sizeof (struct buffer),
				     MEM_TYPE_BUFFER);
  VALIDATE_LISP_STORAGE (b, sizeof *b);
  return b;
}

#ifdef GC_MALLOC_CHECK
  if (ptr)
    {
      struct mem_node *m;
  
      m = mem_find (ptr);
      if (m == MEM_NIL || m->start != ptr)
	{
	  fprintf (stderr,
		   "Freeing `%p' which wasn't allocated with malloc\n", ptr);

	  /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
	  mem_delete (m);
	}
    }
#endif /* GC_MALLOC_CHECK */
  
  __free_hook = old_free_hook;
  free (ptr);
  
  /* If we released our reserve (due to running out of memory),
     and we have a fair amount free once again,
     try to set aside another reserve in case we run out once more.  */
  if (spare_memory == 0
      /* Verify there is enough space that even with the malloc

	mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
	allocated_mem_type = MEM_TYPE_NON_LISP;
      }
  }
#endif /* GC_MALLOC_CHECK */
  
  __malloc_hook = emacs_blocked_malloc;
  UNBLOCK_INPUT;

  /* fprintf (stderr, "%p malloc\n", value); */
  return value;

	  abort ();
	}

      mem_delete (m);
    }
  
  /* fprintf (stderr, "%p -> realloc\n", ptr); */
  
  /* Prevent malloc from registering blocks.  */
  dont_register_blocks = 1;
#endif /* GC_MALLOC_CHECK */

  value = (void *) realloc (ptr, size);

      }

    /* Can't handle zero size regions in the red-black tree.  */
    mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
  }
  
  /* fprintf (stderr, "%p <- realloc\n", value); */
#endif /* GC_MALLOC_CHECK */
  
  __realloc_hook = emacs_blocked_realloc;
  UNBLOCK_INPUT;

  return value;
}

     (STRING) is the size of the data, and DATA contains the string's
     contents.  */
  struct Lisp_String *string;

#ifdef GC_CHECK_STRING_BYTES
  
  EMACS_INT nbytes;
  unsigned char data[1];
  
#define SDATA_NBYTES(S)	(S)->nbytes
#define SDATA_DATA(S)	(S)->data
  
#else /* not GC_CHECK_STRING_BYTES */

  union
  {
    /* When STRING in non-null.  */
    unsigned char data[1];

    /* When STRING is null.  */
    EMACS_INT nbytes;
  } u;
  

#define SDATA_NBYTES(S)	(S)->u.nbytes
#define SDATA_DATA(S)	(S)->u.data

#endif /* not GC_CHECK_STRING_BYTES */

/* Return a pointer to the sdata structure belonging to Lisp string S.
   S must be live, i.e. S->data must not be null.  S->data is actually
   a pointer to the `u.data' member of its sdata structure; the
   structure starts at a constant offset in front of that.  */
   
#ifdef GC_CHECK_STRING_BYTES

#define SDATA_OF_STRING(S) \
     ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
			- sizeof (EMACS_INT)))

      && s->data
      && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
    abort ();
  return nbytes;
}
    
/* Check validity of Lisp strings' string_bytes member in B.  */

void
check_sblock (b)
     struct sblock *b;
{
  struct sdata *from, *end, *from_end;
      
  end = b->next_free;
      
  for (from = &b->first_data; from < end; from = from_end)
    {
      /* Compute the next FROM here because copying below may
	 overwrite data we need to compute it.  */
      int nbytes;
      
      /* Check that the string size recorded in the string is the
	 same as the one recorded in the sdata structure. */
      if (from->string)
	CHECK_STRING_BYTES (from->string);
      
      if (from->string)
	nbytes = GC_STRING_BYTES (from->string);
      else
	nbytes = SDATA_NBYTES (from);
      
      nbytes = SDATA_SIZE (nbytes);
      from_end = (struct sdata *) ((char *) from + nbytes);
    }
}

	{
	  struct Lisp_String *s = b->first_data.string;
	  if (s)
	    CHECK_STRING_BYTES (s);
	}
      
      for (b = oldest_sblock; b; b = b->next)
	check_sblock (b);
    }
  else
    check_sblock (current_sblock);

	 a dumped Emacs.  */
      mallopt (M_MMAP_MAX, 0);
#endif

      b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP);
      
#ifdef DOUG_LEA_MALLOC
      /* Back to a reasonable maximum of mmap'ed areas. */
      mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
  
      b->next_free = &b->first_data;
      b->first_data.string = NULL;
      b->next = large_sblocks;
      large_sblocks = b;
    }

  else
    b = current_sblock;

  old_data = s->data ? SDATA_OF_STRING (s) : NULL;
  old_nbytes = GC_STRING_BYTES (s);
  
  data = b->next_free;
  data->string = s;
  s->data = SDATA_DATA (data);
#ifdef GC_CHECK_STRING_BYTES
  SDATA_NBYTES (data) = nbytes;
#endif
  s->size = nchars;
  s->size_byte = nbytes;
  s->data[nbytes] = '\0';
  b->next_free = (struct sdata *) ((char *) data + needed);
  
  /* If S had already data assigned, mark that as free by setting its
     string back-pointer to null, and recording the size of the data
     in it.  */
  if (old_data)
    {

static void
sweep_strings ()
{
  struct string_block *b, *next;
  struct string_block *live_blocks = NULL;
  
  string_free_list = NULL;
  total_strings = total_free_strings = 0;
  total_string_size = 0;

  /* Scan strings_blocks, free Lisp_Strings that aren't marked.  */

	      /* String was not on free-list before.  */
	      if (STRING_MARKED_P (s))
		{
		  /* String is live; unmark it and its intervals.  */
		  UNMARK_STRING (s);
		  
		  if (!NULL_INTERVAL_P (s->intervals))
		    UNMARK_BALANCE_INTERVALS (s->intervals);

		  ++total_strings;
		  total_string_size += STRING_BYTES (s);

static void
free_large_strings ()
{
  struct sblock *b, *next;
  struct sblock *live_blocks = NULL;
  
  for (b = large_sblocks; b; b = next)
    {
      next = b->next;

      if (b->first_data.string == NULL)

     copying will happen this way.  */
  for (b = oldest_sblock; b; b = b->next)
    {
      end = b->next_free;
      xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
      
      for (from = &b->first_data; from < end; from = from_end)
	{
	  /* Compute the next FROM here because copying below may
	     overwrite data we need to compute it.  */
	  int nbytes;

	     same as the one recorded in the sdata structure. */
	  if (from->string
	      && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
	    abort ();
#endif /* GC_CHECK_STRING_BYTES */
	  
	  if (from->string)
	    nbytes = GC_STRING_BYTES (from->string);
	  else
	    nbytes = SDATA_NBYTES (from);
	  
	  nbytes = SDATA_SIZE (nbytes);
	  from_end = (struct sdata *) ((char *) from + nbytes);
	  
	  /* FROM->string non-null means it's alive.  Copy its data.  */
	  if (from->string)
	    {
	      /* If TB is full, proceed with the next sblock.  */
	      to_end = (struct sdata *) ((char *) to + nbytes);

		  tb = tb->next;
		  tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
		  to = &tb->first_data;
		  to_end = (struct sdata *) ((char *) to + nbytes);
		}
	      
	      /* Copy, and update the string's `data' pointer.  */
	      if (from != to)
		{
		  xassert (tb != b || to <= from);
		  safe_bcopy ((char *) from, (char *) to, nbytes);

	{
	  bcopy (str, p, len);
	  p += len;
	}
    }
  
  *p = 0;
  return val;
}

  /* We must allocate one more elements than LENGTH_IN_ELTS for the
     slot `size' of the struct Lisp_Bool_Vector.  */
  val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
  p = XBOOL_VECTOR (val);
  
  /* Get rid of any bits that would cause confusion.  */
  p->vector_size = 0;
  XSETBOOL_VECTOR (val, p);
  p->size = XFASTINT (length);
  
  real_init = (NILP (init) ? 0 : -1);
  for (i = 0; i < length_in_chars ; i++)
    p->data[i] = real_init;
  
  /* Clear the extraneous bits in the last byte.  */
  if (XINT (length) != length_in_chars * BITS_PER_CHAR)
    XBOOL_VECTOR (val)->data[length_in_chars - 1]
      &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;

	  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;

	  cons_block_index = 0;
	  n_cons_blocks++;
	}
      XSETCONS (val, &cons_block->conses[cons_block_index++]);
    }
  
  XSETCAR (val, car);
  XSETCDR (val, cdr);
  consing_since_gc += sizeof (struct Lisp_Cons);
  cons_cells_consed++;
  return val;

      if (size > 0)
	{
	  val = Fcons (init, val);
	  --size;
      
	  if (size > 0)
	    {
	      val = Fcons (init, val);
	      --size;
      
	      if (size > 0)
		{
		  val = Fcons (init, val);
		  --size;
      
		  if (size > 0)
		    {
		      val = Fcons (init, val);
		      --size;
		    }

	    }
	}

      QUIT;
    }
  
  return val;
}




  /* 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, type);
  
#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;

allocate_hash_table ()
{
  EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE);
  EMACS_INT i;
  
  v->size = len;
  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;
  
  return (struct Lisp_Hash_Table *) v;
}


struct window *
allocate_window ()
{
  EMACS_INT len = VECSIZE (struct window);
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW);
  EMACS_INT i;
  
  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;
  v->size = len;
  
  return (struct window *) v;
}


struct frame *
allocate_frame ()
{
  EMACS_INT len = VECSIZE (struct frame);
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME);
  EMACS_INT i;
  
  for (i = 0; i < len; ++i)
    v->contents[i] = make_number (0);
  v->size = len;
  return (struct frame *) v;
}

allocate_process ()
{
  EMACS_INT len = VECSIZE (struct Lisp_Process);
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS);
  EMACS_INT i;
  
  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;
  v->size = len;
  
  return (struct Lisp_Process *) v;
}


struct Lisp_Vector *
allocate_other_vector (len)
     EMACS_INT len;
{
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR);
  EMACS_INT i;
  
  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;
  v->size = len;
  
  return v;
}


DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,

	  symbol_block_index = 0;
	  n_symbol_blocks++;
	}
      XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
    }
  
  p = XSYMBOL (val);
  p->xname = name;
  p->plist = Qnil;
  p->value = Qunbound;
  p->function = Qunbound;

	  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;
}

  /* 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++)
      {
	SSET (result, i, XINT (args[i]));
	/* Move the meta bit to the right place for a string char.  */
	if (XINT (args[i]) & CHAR_META)
	  SSET (result, i, SREF (result, i) | 0x80);
      }
    
    return result;
  }
}

     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 (start < parent->start)
	parent->left = x;
      else
	parent->right = x;
    }
  else 
    mem_root = x;

  /* Re-establish red-black tree properties.  */
  mem_insert_fixup (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.  */

        }
      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;

	      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);
            }
        }

     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

  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)

      else
	x->parent->left = y;
    }
  else
    mem_root = y;
  
  y->right = x;
  if (x != MEM_NIL)
    x->parent = y;
}

    {
      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);

  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
	{
	  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;
            }

		  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

{
  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 >= 0
	      && offset % sizeof b->symbols[0] == 0

{
  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 >= 0
	      && offset % sizeof b->floats[0] == 0

{
  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 >= 0
	      && offset % sizeof b->markers[0] == 0

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))

	      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;
		}
	    }

  /* Quickly rule out some values which can't point to Lisp data.  We
     assume that Lisp data is aligned on even addresses.  */
  if ((EMACS_INT) p & 1)
    return;
      
  m = mem_find (p);
  if (m != MEM_NIL)
    {
      Lisp_Object obj = Qnil;
      
      switch (m->type)
	{
	case MEM_TYPE_NON_LISP:
	  /* Nothing to do; not a pointer to Lisp memory.  */
	  break;
	  
	case MEM_TYPE_BUFFER:
	  if (live_buffer_p (m, p)
	      && !XMARKBIT (((struct buffer *) p)->name))
	    XSETVECTOR (obj, p);
	  break;
	  
	case MEM_TYPE_CONS:
	  if (live_cons_p (m, p)
	      && !XMARKBIT (((struct Lisp_Cons *) p)->car))
	    XSETCONS (obj, p);
	  break;
	  
	case MEM_TYPE_STRING:
	  if (live_string_p (m, p)
	      && !STRING_MARKED_P ((struct Lisp_String *) p))
	    XSETSTRING (obj, p);
	  break;

	case MEM_TYPE_MISC:
	  if (live_misc_p (m, p))
	    {
	      Lisp_Object tem;
	      XSETMISC (tem, p);
	      
	      switch (XMISCTYPE (tem))
		{
		case Lisp_Misc_Marker:
		  if (!XMARKBIT (XMARKER (tem)->chain))
		    obj = tem;
		  break;
		      
		case Lisp_Misc_Buffer_Local_Value:
		case Lisp_Misc_Some_Buffer_Local_Value:
		  if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue))
		    obj = tem;
		  break;
		      
		case Lisp_Misc_Overlay:
		  if (!XMARKBIT (XOVERLAY (tem)->plist))
		    obj = tem;
		  break;
		}
	    }
	  break;
	  
	case MEM_TYPE_SYMBOL:
	  if (live_symbol_p (m, p)
	      && !XMARKBIT (((struct Lisp_Symbol *) p)->plist))
	    XSETSYMBOL (obj, p);
	  break;
	  
	case MEM_TYPE_FLOAT:
	  if (live_float_p (m, p)
	      && !XMARKBIT (((struct Lisp_Float *) p)->type))
	    XSETFLOAT (obj, p);
	  break;
	  
	case MEM_TYPE_VECTOR:
	case MEM_TYPE_PROCESS:
	case MEM_TYPE_HASH_TABLE:
	case MEM_TYPE_FRAME:
	case MEM_TYPE_WINDOW:

}


/* Mark Lisp objects referenced from the address range START..END.  */

static void 
mark_memory (start, end)
     void *start, *end;
{
  Lisp_Object *p;
  void **pp;

     }

     Here, `obj' isn't really used, and the compiler optimizes it
     away.  The only reference to the life string is through the
     pointer `s'.  */
  
  for (pp = (void **) start; (void *) pp < end; ++pp)
    mark_maybe_pointer (*pp);
}

/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in

     needed on ia64 too.  See mach_dep.c, where it also says inline
     assembler doesn't work with relevant proprietary compilers.  */
#ifdef sparc
  asm ("ta 3");
#endif
  
  /* Save registers that we need to see on the stack.  We need to see
     registers used to hold register variables and registers used to
     pass parameters.  */
#ifdef GC_SAVE_REGISTERS_ON_STACK
  GC_SAVE_REGISTERS_ON_STACK (end);
#else /* not GC_SAVE_REGISTERS_ON_STACK */
  
#ifndef GC_SETJMP_WORKS  /* If it hasn't been checked yet that
			    setjmp will definitely work, test it
			    and print a message with the result
			    of the test.  */
  if (!setjmp_tested_p)
    {
      setjmp_tested_p = 1;
      test_setjmp ();
    }
#endif /* GC_SETJMP_WORKS */
  
  setjmp (j);
  end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif /* not GC_SAVE_REGISTERS_ON_STACK */

  /* This assumes that the stack is a contiguous region in memory.  If

	/* If a buffer's undo list is Qt, that means that undo is
	   turned off in that buffer.  Calling truncate_undo_list on
	   Qt tends to return NULL, which effectively turns undo back on.
	   So don't call truncate_undo_list if undo_list is Qt.  */
	if (! EQ (nextb->undo_list, Qt))
	  nextb->undo_list 
	    = truncate_undo_list (nextb->undo_list, undo_limit,
				  undo_strong_limit);

	/* Shrink buffer gaps, but skip indirect and dead buffers.  */
	if (nextb->base_buffer == 0 && !NILP (nextb->name))

	     discarding the `volatile' qualifier.  */
	  mark_object ((Lisp_Object *)&tail->var[i]);
	  XMARK (tail->var[i]);
	}
#endif
  
  mark_byte_stack ();
  for (bind = specpdl; bind != specpdl_ptr; bind++)
    {
      mark_object (&bind->symbol);
      mark_object (&bind->old_value);
    }
  for (catch = catchlist; catch; catch = catch->next)
    {
      mark_object (&catch->tag);
      mark_object (&catch->val);
    }  
  for (handler = handlerlist; handler; handler = handler->next)
    {
      mark_object (&handler->handler);
      mark_object (&handler->var);
    }  
  for (backlist = backtrace_list; backlist; backlist = backlist->next)
    {
      if (!XMARKBIT (*backlist->function))
	{
	  mark_object (backlist->function);

	if (!XMARKBIT (backlist->args[i]))
	  {
	    mark_object (&backlist->args[i]);
	    XMARK (backlist->args[i]);
	  }
    }  
  mark_kboards ();

  /* Look thru every buffer's undo list
     for elements that update markers that were not marked,
     and delete them.  */

     || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
  for (tail = gcprolist; tail; tail = tail->next)
    for (i = 0; i < tail->nvars; i++)
      XUNMARK (tail->var[i]);
#endif
  
  unmark_byte_stack ();
  for (backlist = backtrace_list; backlist; backlist = backlist->next)
    {
      XUNMARK (*backlist->function);
      if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
	i = 0;
      else
	i = backlist->nargs - 1;
      for (; i >= 0; i--)
	XUNMARK (backlist->args[i]);
    }  
  XUNMARK (buffer_defaults.name);
  XUNMARK (buffer_local_symbols.name);

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
  dump_zombies ();

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
  {
    /* Compute average percentage of zombies.  */
    double nlive = 0;
      
    for (i = 0; i < 7; ++i)
      if (CONSP (total[i]))
	nlive += XFASTINT (XCAR (total[i]));

    avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);

	int area;
	for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
	  {
	    struct glyph *glyph = row->glyphs[area];
	    struct glyph *end_glyph = glyph + row->used[area];
	    
	    for (; glyph < end_glyph; ++glyph)
	      if (GC_STRINGP (glyph->object)
		  && !STRING_MARKED_P (XSTRING (glyph->object)))
		mark_object (&glyph->object);
	  }

static void
mark_image (img)
     struct image *img;
{
  mark_object (&img->spec);
  
  if (!NILP (img->data.lisp_val))
    mark_object (&img->data.lisp_val);
}

#define CHECK_ALLOCATED_AND_LIVE(LIVEP)		\
  do {						\
    CHECK_ALLOCATED ();				\
    CHECK_LIVE (LIVEP);				\
  } while (0)					\
  
#else /* not GC_CHECK_MARKED_OBJECTS */
  
#define CHECK_ALLOCATED()		(void) 0
#define CHECK_LIVE(LIVEP)		(void) 0
#define CHECK_ALLOCATED_AND_LIVE(LIVEP)	(void) 0
  
#endif /* not GC_CHECK_MARKED_OBJECTS */

  switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
    {
    case Lisp_String:

      if (m == MEM_NIL && !GC_SUBRP (obj)
	  && po != &buffer_defaults
	  && po != &buffer_local_symbols)
	abort ();
#endif /* GC_CHECK_MARKED_OBJECTS */
      
      if (GC_BUFFERP (obj))
	{
	  if (!XMARKBIT (XBUFFER (obj)->name))
	    {
#ifdef GC_CHECK_MARKED_OBJECTS

	  register EMACS_INT size = ptr->size;
	  register int i;

	  if (size & ARRAY_MARK_FLAG)
	    break;   /* Already marked */
	  
	  CHECK_LIVE (live_vector_p);
	  ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
	  size &= PSEUDOVECTOR_SIZE_MASK;
	  for (i = 0; i < size; i++) /* and then mark its elements */
	    {

	}
      else if (GC_HASH_TABLE_P (obj))
	{
	  struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
	  EMACS_INT size = h->size;
	  
	  /* Stop if already marked.  */
	  if (size & ARRAY_MARK_FLAG)
	    break;
	  
	  /* Mark it.  */
	  CHECK_LIVE (live_vector_p);
	  h->size |= ARRAY_MARK_FLAG;

	  /* Mark contents.  */
	  /* Do not mark next_free or next_weak.
	     Being in the next_weak chain 
	     should not keep the hash table alive.
	     No need to mark `count' since it is an integer.  */
	  mark_object (&h->test);
	  mark_object (&h->weak);
	  mark_object (&h->rehash_size);

	     For weak tables, mark only the vector.  */
	  if (GC_NILP (h->weak))
	    mark_object (&h->key_and_value);
	  else
	    XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG;
	    
	}
      else
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);
	  register EMACS_INT size = ptr->size;

	mark_object (&ptr->plist);

	if (!PURE_POINTER_P (XSTRING (ptr->xname)))
	  MARK_STRING (XSTRING (ptr->xname));
	MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
	
	/* Note that we do not mark the obarray of the symbol.
	   It is safe not to do so because nothing accesses that
	   slot except to check whether it is nil.  */
	ptr = ptr->next;
	if (ptr)

    mark_object (ptr);

  /* If this is an indirect buffer, mark its base buffer.  */
  if (buffer->base_buffer && !XMARKBIT (buffer->base_buffer->name))
    {
      XSETBUFFER (base_buffer, buffer->base_buffer); 
      mark_buffer (base_buffer);
    }
}

int
survives_gc_p (obj)
     Lisp_Object obj;
{
  int survives_p;
  
  switch (XGCTYPE (obj))
    {
    case Lisp_Int:
      survives_p = 1;
      break;

      switch (XMISCTYPE (obj))
	{
	case Lisp_Misc_Marker:
	  survives_p = XMARKBIT (obj);
	  break;
	  
	case Lisp_Misc_Buffer_Local_Value:
	case Lisp_Misc_Some_Buffer_Local_Value:
	  survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
	  break;
	  
	case Lisp_Misc_Intfwd:
	case Lisp_Misc_Boolfwd:
	case Lisp_Misc_Objfwd:
	case Lisp_Misc_Buffer_Objfwd:
	case Lisp_Misc_Kboard_Objfwd:
	  survives_p = 1;
	  break;
	  
	case Lisp_Misc_Overlay:
	  survives_p = XMARKBIT (XOVERLAY (obj)->plist);
	  break;

	default:

    struct cons_block **cprev = &cons_block;
    register int lim = cons_block_index;
    register int num_free = 0, num_used = 0;

    cons_free_list = 0;
  
    for (cblk = cons_block; cblk; cblk = *cprev)
      {
	register int i;
	int this_free = 0;
	for (i = 0; i < lim; i++)

    struct float_block **fprev = &float_block;
    register int lim = float_block_index;
    register int num_free = 0, num_used = 0;

    float_free_list = 0;
  
    for (fblk = float_block; fblk; fblk = *fprev)
      {
	register int i;
	int this_free = 0;
	for (i = 0; i < lim; i++)

    struct symbol_block **sprev = &symbol_block;
    register int lim = symbol_block_index;
    register int num_free = 0, num_used = 0;

    symbol_free_list = NULL;
  
    for (sblk = symbol_block; sblk; sblk = *sprev)
      {
	int this_free = 0;
	struct Lisp_Symbol *sym = sblk->symbols;
	struct Lisp_Symbol *end = sym + lim;

	  {
	    /* Check if the symbol was created during loadup.  In such a case
	       it might be pointed to by pure bytecode which we don't trace,
	       so we conservatively assume that it is live.  */
	    int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
	    
	    if (!XMARKBIT (sym->plist) && !pure_p)
	      {
		*(struct Lisp_Symbol **) &sym->value = symbol_free_list;
		symbol_free_list = sym;
#if GC_MARK_STACK

		if (!pure_p)
		  UNMARK_STRING (XSTRING (sym->xname));
		XUNMARK (sym->plist);
	      }
	  }
	
	lim = SYMBOL_BLOCK_SIZE;
	/* If this block contains only free symbols and we have already
	   seen more than two blocks worth of free symbols then deallocate
	   this block.  */
	if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)

    struct marker_block **mprev = &marker_block;
    register int lim = marker_block_index;
    register int num_free = 0, num_used = 0;

    marker_free_list = 0;
  
    for (mblk = marker_block; mblk; mblk = *mprev)
      {
	register int i;
	int this_free = 0;
	EMACS_INT already_free = -1;

	  else
	    total_vector_size += vector->size;
	  prev = vector, vector = vector->next;
	}
  }
  
#ifdef GC_CHECK_STRING_BYTES
  if (!noninteractive)
    check_string_bytes (1);
#endif
}

49600:23a1cea22d13

  /* Start and end of allocated region.  */
  void *start, *end;

  /* Node color.  */
  enum {MEM_BLACK, MEM_RED} color;

  /* Memory type.  */
  enum mem_type type;
};

/* Base address of stack.  Set in main.  */

  BLOCK_INPUT;

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif

  val = (void *) malloc (nbytes);

#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
  if (val && type != MEM_TYPE_NON_LISP)
    mem_insert (val, (char *) val + nbytes, type);
#endif

  UNBLOCK_INPUT;
  if (!val && nbytes)
    memory_full ();
  return val;
}

   a call to lisp_malloc.  */

struct buffer *
allocate_buffer ()
{
  struct buffer *b
    = (struct buffer *) lisp_malloc (sizeof (struct buffer),
				     MEM_TYPE_BUFFER);
  VALIDATE_LISP_STORAGE (b, sizeof *b);
  return b;
}

#ifdef GC_MALLOC_CHECK
  if (ptr)
    {
      struct mem_node *m;

      m = mem_find (ptr);
      if (m == MEM_NIL || m->start != ptr)
	{
	  fprintf (stderr,
		   "Freeing `%p' which wasn't allocated with malloc\n", ptr);

	  /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
	  mem_delete (m);
	}
    }
#endif /* GC_MALLOC_CHECK */

  __free_hook = old_free_hook;
  free (ptr);

  /* If we released our reserve (due to running out of memory),
     and we have a fair amount free once again,
     try to set aside another reserve in case we run out once more.  */
  if (spare_memory == 0
      /* Verify there is enough space that even with the malloc

	mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
	allocated_mem_type = MEM_TYPE_NON_LISP;
      }
  }
#endif /* GC_MALLOC_CHECK */

  __malloc_hook = emacs_blocked_malloc;
  UNBLOCK_INPUT;

  /* fprintf (stderr, "%p malloc\n", value); */
  return value;

	  abort ();
	}

      mem_delete (m);
    }

  /* fprintf (stderr, "%p -> realloc\n", ptr); */

  /* Prevent malloc from registering blocks.  */
  dont_register_blocks = 1;
#endif /* GC_MALLOC_CHECK */

  value = (void *) realloc (ptr, size);

      }

    /* Can't handle zero size regions in the red-black tree.  */
    mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
  }

  /* fprintf (stderr, "%p <- realloc\n", value); */
#endif /* GC_MALLOC_CHECK */

  __realloc_hook = emacs_blocked_realloc;
  UNBLOCK_INPUT;

  return value;
}

     (STRING) is the size of the data, and DATA contains the string's
     contents.  */
  struct Lisp_String *string;

#ifdef GC_CHECK_STRING_BYTES

  EMACS_INT nbytes;
  unsigned char data[1];

#define SDATA_NBYTES(S)	(S)->nbytes
#define SDATA_DATA(S)	(S)->data

#else /* not GC_CHECK_STRING_BYTES */

  union
  {
    /* When STRING in non-null.  */
    unsigned char data[1];

    /* When STRING is null.  */
    EMACS_INT nbytes;
  } u;


#define SDATA_NBYTES(S)	(S)->u.nbytes
#define SDATA_DATA(S)	(S)->u.data

#endif /* not GC_CHECK_STRING_BYTES */

/* Return a pointer to the sdata structure belonging to Lisp string S.
   S must be live, i.e. S->data must not be null.  S->data is actually
   a pointer to the `u.data' member of its sdata structure; the
   structure starts at a constant offset in front of that.  */

#ifdef GC_CHECK_STRING_BYTES

#define SDATA_OF_STRING(S) \
     ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
			- sizeof (EMACS_INT)))

      && s->data
      && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
    abort ();
  return nbytes;
}

/* Check validity of Lisp strings' string_bytes member in B.  */

void
check_sblock (b)
     struct sblock *b;
{
  struct sdata *from, *end, *from_end;

  end = b->next_free;

  for (from = &b->first_data; from < end; from = from_end)
    {
      /* Compute the next FROM here because copying below may
	 overwrite data we need to compute it.  */
      int nbytes;

      /* Check that the string size recorded in the string is the
	 same as the one recorded in the sdata structure. */
      if (from->string)
	CHECK_STRING_BYTES (from->string);

      if (from->string)
	nbytes = GC_STRING_BYTES (from->string);
      else
	nbytes = SDATA_NBYTES (from);

      nbytes = SDATA_SIZE (nbytes);
      from_end = (struct sdata *) ((char *) from + nbytes);
    }
}

	{
	  struct Lisp_String *s = b->first_data.string;
	  if (s)
	    CHECK_STRING_BYTES (s);
	}

      for (b = oldest_sblock; b; b = b->next)
	check_sblock (b);
    }
  else
    check_sblock (current_sblock);

	 a dumped Emacs.  */
      mallopt (M_MMAP_MAX, 0);
#endif

      b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP);

#ifdef DOUG_LEA_MALLOC
      /* Back to a reasonable maximum of mmap'ed areas. */
      mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif

      b->next_free = &b->first_data;
      b->first_data.string = NULL;
      b->next = large_sblocks;
      large_sblocks = b;
    }

  else
    b = current_sblock;

  old_data = s->data ? SDATA_OF_STRING (s) : NULL;
  old_nbytes = GC_STRING_BYTES (s);

  data = b->next_free;
  data->string = s;
  s->data = SDATA_DATA (data);
#ifdef GC_CHECK_STRING_BYTES
  SDATA_NBYTES (data) = nbytes;
#endif
  s->size = nchars;
  s->size_byte = nbytes;
  s->data[nbytes] = '\0';
  b->next_free = (struct sdata *) ((char *) data + needed);

  /* If S had already data assigned, mark that as free by setting its
     string back-pointer to null, and recording the size of the data
     in it.  */
  if (old_data)
    {

static void
sweep_strings ()
{
  struct string_block *b, *next;
  struct string_block *live_blocks = NULL;

  string_free_list = NULL;
  total_strings = total_free_strings = 0;
  total_string_size = 0;

  /* Scan strings_blocks, free Lisp_Strings that aren't marked.  */

	      /* String was not on free-list before.  */
	      if (STRING_MARKED_P (s))
		{
		  /* String is live; unmark it and its intervals.  */
		  UNMARK_STRING (s);

		  if (!NULL_INTERVAL_P (s->intervals))
		    UNMARK_BALANCE_INTERVALS (s->intervals);

		  ++total_strings;
		  total_string_size += STRING_BYTES (s);

static void
free_large_strings ()
{
  struct sblock *b, *next;
  struct sblock *live_blocks = NULL;

  for (b = large_sblocks; b; b = next)
    {
      next = b->next;

      if (b->first_data.string == NULL)

     copying will happen this way.  */
  for (b = oldest_sblock; b; b = b->next)
    {
      end = b->next_free;
      xassert ((char *) end <= (char *) b + SBLOCK_SIZE);

      for (from = &b->first_data; from < end; from = from_end)
	{
	  /* Compute the next FROM here because copying below may
	     overwrite data we need to compute it.  */
	  int nbytes;

	     same as the one recorded in the sdata structure. */
	  if (from->string
	      && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
	    abort ();
#endif /* GC_CHECK_STRING_BYTES */

	  if (from->string)
	    nbytes = GC_STRING_BYTES (from->string);
	  else
	    nbytes = SDATA_NBYTES (from);

	  nbytes = SDATA_SIZE (nbytes);
	  from_end = (struct sdata *) ((char *) from + nbytes);

	  /* FROM->string non-null means it's alive.  Copy its data.  */
	  if (from->string)
	    {
	      /* If TB is full, proceed with the next sblock.  */
	      to_end = (struct sdata *) ((char *) to + nbytes);

		  tb = tb->next;
		  tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
		  to = &tb->first_data;
		  to_end = (struct sdata *) ((char *) to + nbytes);
		}

	      /* Copy, and update the string's `data' pointer.  */
	      if (from != to)
		{
		  xassert (tb != b || to <= from);
		  safe_bcopy ((char *) from, (char *) to, nbytes);

	{
	  bcopy (str, p, len);
	  p += len;
	}
    }

  *p = 0;
  return val;
}

  /* We must allocate one more elements than LENGTH_IN_ELTS for the
     slot `size' of the struct Lisp_Bool_Vector.  */
  val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
  p = XBOOL_VECTOR (val);

  /* Get rid of any bits that would cause confusion.  */
  p->vector_size = 0;
  XSETBOOL_VECTOR (val, p);
  p->size = XFASTINT (length);

  real_init = (NILP (init) ? 0 : -1);
  for (i = 0; i < length_in_chars ; i++)
    p->data[i] = real_init;

  /* Clear the extraneous bits in the last byte.  */
  if (XINT (length) != length_in_chars * BITS_PER_CHAR)
    XBOOL_VECTOR (val)->data[length_in_chars - 1]
      &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;

	  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;

	  cons_block_index = 0;
	  n_cons_blocks++;
	}
      XSETCONS (val, &cons_block->conses[cons_block_index++]);
    }

  XSETCAR (val, car);
  XSETCDR (val, cdr);
  consing_since_gc += sizeof (struct Lisp_Cons);
  cons_cells_consed++;
  return val;

      if (size > 0)
	{
	  val = Fcons (init, val);
	  --size;

	  if (size > 0)
	    {
	      val = Fcons (init, val);
	      --size;

	      if (size > 0)
		{
		  val = Fcons (init, val);
		  --size;

		  if (size > 0)
		    {
		      val = Fcons (init, val);
		      --size;
		    }

	    }
	}

      QUIT;
    }

  return val;
}




  /* 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, type);

#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;

allocate_hash_table ()
{
  EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE);
  EMACS_INT i;

  v->size = len;
  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;

  return (struct Lisp_Hash_Table *) v;
}


struct window *
allocate_window ()
{
  EMACS_INT len = VECSIZE (struct window);
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW);
  EMACS_INT i;

  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;
  v->size = len;

  return (struct window *) v;
}


struct frame *
allocate_frame ()
{
  EMACS_INT len = VECSIZE (struct frame);
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME);
  EMACS_INT i;

  for (i = 0; i < len; ++i)
    v->contents[i] = make_number (0);
  v->size = len;
  return (struct frame *) v;
}

allocate_process ()
{
  EMACS_INT len = VECSIZE (struct Lisp_Process);
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS);
  EMACS_INT i;

  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;
  v->size = len;

  return (struct Lisp_Process *) v;
}


struct Lisp_Vector *
allocate_other_vector (len)
     EMACS_INT len;
{
  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR);
  EMACS_INT i;

  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;
  v->size = len;

  return v;
}


DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,

	  symbol_block_index = 0;
	  n_symbol_blocks++;
	}
      XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
    }

  p = XSYMBOL (val);
  p->xname = name;
  p->plist = Qnil;
  p->value = Qunbound;
  p->function = Qunbound;

	  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;
}

  /* 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++)
      {
	SSET (result, i, XINT (args[i]));
	/* Move the meta bit to the right place for a string char.  */
	if (XINT (args[i]) & CHAR_META)
	  SSET (result, i, SREF (result, i) | 0x80);
      }

    return result;
  }
}

     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 (start < parent->start)
	parent->left = x;
      else
	parent->right = x;
    }
  else
    mem_root = x;

  /* Re-establish red-black tree properties.  */
  mem_insert_fixup (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.  */

        }
      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;

	      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);
            }
        }

     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

  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)

      else
	x->parent->left = y;
    }
  else
    mem_root = y;

  y->right = x;
  if (x != MEM_NIL)
    x->parent = y;
}

    {
      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);

  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
	{
	  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;
            }

		  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

{
  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 >= 0
	      && offset % sizeof b->symbols[0] == 0

{
  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 >= 0
	      && offset % sizeof b->floats[0] == 0

{
  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 >= 0
	      && offset % sizeof b->markers[0] == 0

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))

	      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;
		}
	    }

  /* Quickly rule out some values which can't point to Lisp data.  We
     assume that Lisp data is aligned on even addresses.  */
  if ((EMACS_INT) p & 1)
    return;

  m = mem_find (p);
  if (m != MEM_NIL)
    {
      Lisp_Object obj = Qnil;

      switch (m->type)
	{
	case MEM_TYPE_NON_LISP:
	  /* Nothing to do; not a pointer to Lisp memory.  */
	  break;

	case MEM_TYPE_BUFFER:
	  if (live_buffer_p (m, p)
	      && !XMARKBIT (((struct buffer *) p)->name))
	    XSETVECTOR (obj, p);
	  break;

	case MEM_TYPE_CONS:
	  if (live_cons_p (m, p)
	      && !XMARKBIT (((struct Lisp_Cons *) p)->car))
	    XSETCONS (obj, p);
	  break;

	case MEM_TYPE_STRING:
	  if (live_string_p (m, p)
	      && !STRING_MARKED_P ((struct Lisp_String *) p))
	    XSETSTRING (obj, p);
	  break;

	case MEM_TYPE_MISC:
	  if (live_misc_p (m, p))
	    {
	      Lisp_Object tem;
	      XSETMISC (tem, p);

	      switch (XMISCTYPE (tem))
		{
		case Lisp_Misc_Marker:
		  if (!XMARKBIT (XMARKER (tem)->chain))
		    obj = tem;
		  break;

		case Lisp_Misc_Buffer_Local_Value:
		case Lisp_Misc_Some_Buffer_Local_Value:
		  if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue))
		    obj = tem;
		  break;

		case Lisp_Misc_Overlay:
		  if (!XMARKBIT (XOVERLAY (tem)->plist))
		    obj = tem;
		  break;
		}
	    }
	  break;

	case MEM_TYPE_SYMBOL:
	  if (live_symbol_p (m, p)
	      && !XMARKBIT (((struct Lisp_Symbol *) p)->plist))
	    XSETSYMBOL (obj, p);
	  break;

	case MEM_TYPE_FLOAT:
	  if (live_float_p (m, p)
	      && !XMARKBIT (((struct Lisp_Float *) p)->type))
	    XSETFLOAT (obj, p);
	  break;

	case MEM_TYPE_VECTOR:
	case MEM_TYPE_PROCESS:
	case MEM_TYPE_HASH_TABLE:
	case MEM_TYPE_FRAME:
	case MEM_TYPE_WINDOW:

}


/* Mark Lisp objects referenced from the address range START..END.  */

static void
mark_memory (start, end)
     void *start, *end;
{
  Lisp_Object *p;
  void **pp;

     }

     Here, `obj' isn't really used, and the compiler optimizes it
     away.  The only reference to the life string is through the
     pointer `s'.  */

  for (pp = (void **) start; (void *) pp < end; ++pp)
    mark_maybe_pointer (*pp);
}

/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in

     needed on ia64 too.  See mach_dep.c, where it also says inline
     assembler doesn't work with relevant proprietary compilers.  */
#ifdef sparc
  asm ("ta 3");
#endif

  /* Save registers that we need to see on the stack.  We need to see
     registers used to hold register variables and registers used to
     pass parameters.  */
#ifdef GC_SAVE_REGISTERS_ON_STACK
  GC_SAVE_REGISTERS_ON_STACK (end);
#else /* not GC_SAVE_REGISTERS_ON_STACK */

#ifndef GC_SETJMP_WORKS  /* If it hasn't been checked yet that
			    setjmp will definitely work, test it
			    and print a message with the result
			    of the test.  */
  if (!setjmp_tested_p)
    {
      setjmp_tested_p = 1;
      test_setjmp ();
    }
#endif /* GC_SETJMP_WORKS */

  setjmp (j);
  end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif /* not GC_SAVE_REGISTERS_ON_STACK */

  /* This assumes that the stack is a contiguous region in memory.  If

	/* If a buffer's undo list is Qt, that means that undo is
	   turned off in that buffer.  Calling truncate_undo_list on
	   Qt tends to return NULL, which effectively turns undo back on.
	   So don't call truncate_undo_list if undo_list is Qt.  */
	if (! EQ (nextb->undo_list, Qt))
	  nextb->undo_list
	    = truncate_undo_list (nextb->undo_list, undo_limit,
				  undo_strong_limit);

	/* Shrink buffer gaps, but skip indirect and dead buffers.  */
	if (nextb->base_buffer == 0 && !NILP (nextb->name))

	     discarding the `volatile' qualifier.  */
	  mark_object ((Lisp_Object *)&tail->var[i]);
	  XMARK (tail->var[i]);
	}
#endif

  mark_byte_stack ();
  for (bind = specpdl; bind != specpdl_ptr; bind++)
    {
      mark_object (&bind->symbol);
      mark_object (&bind->old_value);
    }
  for (catch = catchlist; catch; catch = catch->next)
    {
      mark_object (&catch->tag);
      mark_object (&catch->val);
    }
  for (handler = handlerlist; handler; handler = handler->next)
    {
      mark_object (&handler->handler);
      mark_object (&handler->var);
    }
  for (backlist = backtrace_list; backlist; backlist = backlist->next)
    {
      if (!XMARKBIT (*backlist->function))
	{
	  mark_object (backlist->function);

	if (!XMARKBIT (backlist->args[i]))
	  {
	    mark_object (&backlist->args[i]);
	    XMARK (backlist->args[i]);
	  }
    }
  mark_kboards ();

  /* Look thru every buffer's undo list
     for elements that update markers that were not marked,
     and delete them.  */

     || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
  for (tail = gcprolist; tail; tail = tail->next)
    for (i = 0; i < tail->nvars; i++)
      XUNMARK (tail->var[i]);
#endif

  unmark_byte_stack ();
  for (backlist = backtrace_list; backlist; backlist = backlist->next)
    {
      XUNMARK (*backlist->function);
      if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
	i = 0;
      else
	i = backlist->nargs - 1;
      for (; i >= 0; i--)
	XUNMARK (backlist->args[i]);
    }
  XUNMARK (buffer_defaults.name);
  XUNMARK (buffer_local_symbols.name);

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
  dump_zombies ();

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
  {
    /* Compute average percentage of zombies.  */
    double nlive = 0;

    for (i = 0; i < 7; ++i)
      if (CONSP (total[i]))
	nlive += XFASTINT (XCAR (total[i]));

    avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);

	int area;
	for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
	  {
	    struct glyph *glyph = row->glyphs[area];
	    struct glyph *end_glyph = glyph + row->used[area];

	    for (; glyph < end_glyph; ++glyph)
	      if (GC_STRINGP (glyph->object)
		  && !STRING_MARKED_P (XSTRING (glyph->object)))
		mark_object (&glyph->object);
	  }

static void
mark_image (img)
     struct image *img;
{
  mark_object (&img->spec);

  if (!NILP (img->data.lisp_val))
    mark_object (&img->data.lisp_val);
}

#define CHECK_ALLOCATED_AND_LIVE(LIVEP)		\
  do {						\
    CHECK_ALLOCATED ();				\
    CHECK_LIVE (LIVEP);				\
  } while (0)					\

#else /* not GC_CHECK_MARKED_OBJECTS */

#define CHECK_ALLOCATED()		(void) 0
#define CHECK_LIVE(LIVEP)		(void) 0
#define CHECK_ALLOCATED_AND_LIVE(LIVEP)	(void) 0

#endif /* not GC_CHECK_MARKED_OBJECTS */

  switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
    {
    case Lisp_String:

      if (m == MEM_NIL && !GC_SUBRP (obj)
	  && po != &buffer_defaults
	  && po != &buffer_local_symbols)
	abort ();
#endif /* GC_CHECK_MARKED_OBJECTS */

      if (GC_BUFFERP (obj))
	{
	  if (!XMARKBIT (XBUFFER (obj)->name))
	    {
#ifdef GC_CHECK_MARKED_OBJECTS

	  register EMACS_INT size = ptr->size;
	  register int i;

	  if (size & ARRAY_MARK_FLAG)
	    break;   /* Already marked */

	  CHECK_LIVE (live_vector_p);
	  ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
	  size &= PSEUDOVECTOR_SIZE_MASK;
	  for (i = 0; i < size; i++) /* and then mark its elements */
	    {

	}
      else if (GC_HASH_TABLE_P (obj))
	{
	  struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
	  EMACS_INT size = h->size;

	  /* Stop if already marked.  */
	  if (size & ARRAY_MARK_FLAG)
	    break;

	  /* Mark it.  */
	  CHECK_LIVE (live_vector_p);
	  h->size |= ARRAY_MARK_FLAG;

	  /* Mark contents.  */
	  /* Do not mark next_free or next_weak.
	     Being in the next_weak chain
	     should not keep the hash table alive.
	     No need to mark `count' since it is an integer.  */
	  mark_object (&h->test);
	  mark_object (&h->weak);
	  mark_object (&h->rehash_size);

	     For weak tables, mark only the vector.  */
	  if (GC_NILP (h->weak))
	    mark_object (&h->key_and_value);
	  else
	    XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG;

	}
      else
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);
	  register EMACS_INT size = ptr->size;

	mark_object (&ptr->plist);

	if (!PURE_POINTER_P (XSTRING (ptr->xname)))
	  MARK_STRING (XSTRING (ptr->xname));
	MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));

	/* Note that we do not mark the obarray of the symbol.
	   It is safe not to do so because nothing accesses that
	   slot except to check whether it is nil.  */
	ptr = ptr->next;
	if (ptr)

    mark_object (ptr);

  /* If this is an indirect buffer, mark its base buffer.  */
  if (buffer->base_buffer && !XMARKBIT (buffer->base_buffer->name))
    {
      XSETBUFFER (base_buffer, buffer->base_buffer);
      mark_buffer (base_buffer);
    }
}

int
survives_gc_p (obj)
     Lisp_Object obj;
{
  int survives_p;

  switch (XGCTYPE (obj))
    {
    case Lisp_Int:
      survives_p = 1;
      break;

      switch (XMISCTYPE (obj))
	{
	case Lisp_Misc_Marker:
	  survives_p = XMARKBIT (obj);
	  break;

	case Lisp_Misc_Buffer_Local_Value:
	case Lisp_Misc_Some_Buffer_Local_Value:
	  survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
	  break;

	case Lisp_Misc_Intfwd:
	case Lisp_Misc_Boolfwd:
	case Lisp_Misc_Objfwd:
	case Lisp_Misc_Buffer_Objfwd:
	case Lisp_Misc_Kboard_Objfwd:
	  survives_p = 1;
	  break;

	case Lisp_Misc_Overlay:
	  survives_p = XMARKBIT (XOVERLAY (obj)->plist);
	  break;

	default:

    struct cons_block **cprev = &cons_block;
    register int lim = cons_block_index;
    register int num_free = 0, num_used = 0;

    cons_free_list = 0;

    for (cblk = cons_block; cblk; cblk = *cprev)
      {
	register int i;
	int this_free = 0;
	for (i = 0; i < lim; i++)

    struct float_block **fprev = &float_block;
    register int lim = float_block_index;
    register int num_free = 0, num_used = 0;

    float_free_list = 0;

    for (fblk = float_block; fblk; fblk = *fprev)
      {
	register int i;
	int this_free = 0;
	for (i = 0; i < lim; i++)

    struct symbol_block **sprev = &symbol_block;
    register int lim = symbol_block_index;
    register int num_free = 0, num_used = 0;

    symbol_free_list = NULL;

    for (sblk = symbol_block; sblk; sblk = *sprev)
      {
	int this_free = 0;
	struct Lisp_Symbol *sym = sblk->symbols;
	struct Lisp_Symbol *end = sym + lim;

	  {
	    /* Check if the symbol was created during loadup.  In such a case
	       it might be pointed to by pure bytecode which we don't trace,
	       so we conservatively assume that it is live.  */
	    int pure_p = PURE_POINTER_P (XSTRING (sym->xname));

	    if (!XMARKBIT (sym->plist) && !pure_p)
	      {
		*(struct Lisp_Symbol **) &sym->value = symbol_free_list;
		symbol_free_list = sym;
#if GC_MARK_STACK

		if (!pure_p)
		  UNMARK_STRING (XSTRING (sym->xname));
		XUNMARK (sym->plist);
	      }
	  }

	lim = SYMBOL_BLOCK_SIZE;
	/* If this block contains only free symbols and we have already
	   seen more than two blocks worth of free symbols then deallocate
	   this block.  */
	if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)

    struct marker_block **mprev = &marker_block;
    register int lim = marker_block_index;
    register int num_free = 0, num_used = 0;

    marker_free_list = 0;

    for (mblk = marker_block; mblk; mblk = *mprev)
      {
	register int i;
	int this_free = 0;
	EMACS_INT already_free = -1;

	  else
	    total_vector_size += vector->size;
	  prev = vector, vector = vector->next;
	}
  }

#ifdef GC_CHECK_STRING_BYTES
  if (!noninteractive)
    check_string_bytes (1);
#endif
}