comparison src/alloc.c @ 27738:581c76c41ca4

(mark_object): Don't mark symbol names in pure space. (gc_sweep): Don't unmark symbol names in pure space. (toplevel): Include setjmp.h. (PURE_POINTER_P): New define. (enum mem_type) [GC_MARK_STACK]: New enumeration. (Vdead) [GC_MARK_STACK]: New variable. (lisp_malloc): Add parameter TYPE, call mem_insert if GC_MARK_STACK is defined. (allocate_buffer): New function. (lisp_free) [GC_MARK_STACK]: Call mem_delete. (free_float) [GC_MARK_STACK]: Set type to Vdead. (free_cons) [GC_MARK_STACK]: Set car to Vdead. (stack_base, mem_root, mem_z) [GC_MARK_STACK]: New variables. (MEM_NIL) [GC_MARK_STACK]: New define. (struct mem_node) [GC_MARK_STACK]: New structure. (mem_init, mem_find, mem_insert, mem_delete, mem_insert_fixup) (mem_delete_fixup, mem_rotate_left, mem_rotate_right) (live_string_p, live_cons_p, live_symbol_p, live_float_p) (live_misc_p, live_vector_p, live_buffer_p, mark_memory) (mark_stack) [GC_MARK_STACK]: New functions. (Fgarbage_collect) [GC_MARK_STACK]: Call mark_stack. (clear_marks): Removed. (gc_sweep): Set free conses' car, free floats' type, free symbols' function to Vdead. Use lisp_free to free buffers. (init_alloc_once): Initialize Vdead. (survives_gc_p): Return non-zero for pure objects. Add comments throughout the file.

27737:861c19525f53

#include "frame.h"
#include "blockinput.h"
#include "keyboard.h"
#include "charset.h"
#include "syssignal.h"

extern char *sbrk ();

#ifdef DOUG_LEA_MALLOC

/* Two limits controlling how much undo information to keep.  */

int undo_limit;
int undo_strong_limit;

int total_conses, total_markers, total_symbols, total_vector_size;
int total_free_conses, total_free_markers, total_free_symbols;
int total_free_floats, total_floats;

/* Points to memory space allocated as "spare", to be freed if we run
   out of memory.  */

static char *spare_memory;

EMACS_INT pure_size;

#endif /* not HAVE_SHM */

/* Index in pure at which next pure object will be allocated.. */

int pureptr;

/* If nonzero, this is a warning delivered by malloc and not yet

static void mark_buffer P_ ((Lisp_Object));
static void mark_kboards P_ ((void));
static void gc_sweep P_ ((void));
static void mark_glyph_matrix P_ ((struct glyph_matrix *));
static void mark_face_cache P_ ((struct face_cache *));
#if 0
static void clear_marks ();
#endif

#ifdef HAVE_WINDOW_SYSTEM
static void mark_image P_ ((struct image *));
static void mark_image_cache P_ ((struct frame *));
#endif /* HAVE_WINDOW_SYSTEM */

static void compact_small_strings P_ ((void));
static void free_large_strings P_ ((void));
static void sweep_strings P_ ((void));

extern int message_enable_multibyte;

/* Versions of malloc and realloc that print warnings as memory gets
   full.  */

Lisp_Object
malloc_warning_1 (str)
     Lisp_Object str;
{

  write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
  write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
  return Qnil;
}

/* malloc calls this if it finds we are near exhausting storage.  */

void
malloc_warning (str)
     char *str;
{
  pending_malloc_warning = str;
}

void
display_malloc_warning ()
{
  register Lisp_Object val;

  val = build_string (pending_malloc_warning);
  pending_malloc_warning = 0;
  internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
}

#ifdef DOUG_LEA_MALLOC
#  define BYTES_USED (mallinfo ().arena)
#else
#  define BYTES_USED _bytes_used
#endif

/* Called if malloc returns zero.  */

void
memory_full ()
{

  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
  while (1)
    Fsignal (Qnil, memory_signal_data);
}

/* Called if we can't allocate relocatable space for a buffer.  */

void
buffer_memory_full ()

     get infinite recursion trying to build the string.  */
  while (1)
    Fsignal (Qerror, memory_signal_data);
}

/* Like malloc routines but check for no memory and block interrupt
   input..  */

long *
xmalloc (size)
     int size;
{

  if (!val && size)
    memory_full ();
  return val;
}

long *
xrealloc (block, size)
     long *block;
     int size;

  if (!val && size) memory_full ();
  return val;
}

void
xfree (block)
     long *block;
{
  BLOCK_INPUT;
  free (block);
  UNBLOCK_INPUT;
}

/* Like malloc but used for allocating Lisp data.  */

long *
lisp_malloc (size)
     int size;
{
  register long *val;

  BLOCK_INPUT;
  allocating_for_lisp++;
  val = (long *) malloc (size);
  allocating_for_lisp--;
  UNBLOCK_INPUT;

  if (!val && size) memory_full ();
  return val;
}

void
lisp_free (block)
     long *block;
{
  BLOCK_INPUT;
  allocating_for_lisp++;
  free (block);
  allocating_for_lisp--;
  UNBLOCK_INPUT;
}

/* Arranging to disable input signals while we're in malloc.

   This only works with GNU malloc.  To help out systems which can't
   use GNU malloc, all the calls to malloc, realloc, and free

  __free_hook = emacs_blocked_free;
  UNBLOCK_INPUT;
}

/* 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.

   This is called when a relocatable block is freed in ralloc.c.  */

refill_memory_reserve ()
{
  if (spare_memory == 0)
    spare_memory = (char *) malloc (SPARE_MEMORY);
}

/* This function is the malloc hook that Emacs uses.  */

static void *
emacs_blocked_malloc (size)

  UNBLOCK_INPUT;

  return value;
}

static void *
emacs_blocked_realloc (ptr, size)
     void *ptr;
     unsigned size;
{

  UNBLOCK_INPUT;

  return value;
}

void
uninterrupt_malloc ()
{
  if (__free_hook != emacs_blocked_free)
    old_free_hook = __free_hook;


/***********************************************************************
			 Interval Allocation
 ***********************************************************************/

#define INTERVAL_BLOCK_SIZE \
  ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))

struct interval_block
{
  struct interval_block *next;
  struct interval intervals[INTERVAL_BLOCK_SIZE];
};

struct interval_block *interval_block;
static int interval_block_index;
static int total_free_intervals, total_intervals;

INTERVAL interval_free_list;

/* Total number of interval blocks now in use.  */

int n_interval_blocks;

static void
init_intervals ()
{
  interval_block
    = (struct interval_block *) lisp_malloc (sizeof (struct interval_block));
  interval_block->next = 0;
  bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
  interval_block_index = 0;
  interval_free_list = 0;
  n_interval_blocks = 1;
}

#define INIT_INTERVALS init_intervals ()

INTERVAL
make_interval ()
{
  INTERVAL val;

    {
      if (interval_block_index == INTERVAL_BLOCK_SIZE)
	{
	  register struct interval_block *newi;

	  newi = (struct interval_block *) lisp_malloc (sizeof (struct interval_block));

	  VALIDATE_LISP_STORAGE (newi, sizeof *newi);
	  newi->next = interval_block;
	  interval_block = newi;
	  interval_block_index = 0;

  intervals_consed++;
  RESET_INTERVAL (val);
  return val;
}

/* Mark the pointers of one interval. */

static void
mark_interval (i, dummy)
     register INTERVAL i;
     Lisp_Object dummy;

    abort ();
  mark_object (&i->plist);
  XMARK (i->plist);
}

static void
mark_interval_tree (tree)
     register INTERVAL tree;
{
  /* No need to test if this tree has been marked already; this

     a cast.  */
  XMARK (* (Lisp_Object *) &tree->parent);

  traverse_intervals (tree, 1, 0, mark_interval, Qnil);
}

#define MARK_INTERVAL_TREE(i)				\
  do {							\
    if (!NULL_INTERVAL_P (i)				\
	&& ! XMARKBIT (*(Lisp_Object *) &i->parent))	\
      mark_interval_tree (i);				\
  } while (0)

/* The oddity in the call to XUNMARK is necessary because XUNMARK
   expands to an assignment to its argument, and most C compilers
   don't support casts on the left operand of `='.  */

       XUNMARK (* (Lisp_Object *) (&(i)->parent));	\
       (i) = balance_intervals (i);			\
     }							\
  } while (0)


/***********************************************************************
			  String Allocation
 ***********************************************************************/

struct sdata
{
  /* Back-pointer to the string this sdata belongs to.  If null, this
     structure is free, and the NBYTES member of the union below
     contains the string byte size (the same value that STRING_BYTES
     would return if STRING were non-null).  If non-null, STRING_BYTES
     (STRING) is the size of the data, and DATA contains the string's
     contents.  */
  struct Lisp_String *string;

  if (string_free_list == NULL)
    {
      struct string_block *b;
      int i;

      b = (struct string_block *) lisp_malloc (sizeof *b);
      VALIDATE_LISP_STORAGE (b, sizeof *b);
      bzero (b, sizeof *b);
      b->next = string_blocks;
      string_blocks = b;
      ++n_string_blocks;

#ifdef DOUG_LEA_MALLOC
      /* Prevent mmap'ing the chunk (which is potentially very large). */
      mallopt (M_MMAP_MAX, 0);
#endif

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

	   || (((char *) current_sblock + SBLOCK_SIZE
		- (char *) current_sblock->next_free)
	       < needed))
    {
      /* Not enough room in the current sblock.  */
      b = (struct sblock *) lisp_malloc (SBLOCK_SIZE);
      b->next_free = &b->first_data;
      b->first_data.string = NULL;
      b->next = NULL;

      if (current_sblock)

	      string_free_list = s;
	      ++nfree;
	    }
	}

      /* Free blocks that are contain free Lisp_Strings only, except
	 the first two of them.  */
      if (nfree == STRINGS_IN_STRING_BLOCK
	  && total_free_strings > STRINGS_IN_STRING_BLOCK)
	{
	  lisp_free (b);

  /* 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;

{
  struct float_block *next;
  struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
};

struct float_block *float_block;
int float_block_index;

/* Total number of float blocks now in use.  */

int n_float_blocks;

struct Lisp_Float *float_free_list;

void
init_float ()
{
  float_block = (struct float_block *) lisp_malloc (sizeof (struct float_block));
  float_block->next = 0;
  bzero ((char *) float_block->floats, sizeof float_block->floats);
  float_block_index = 0;
  float_free_list = 0;
  n_float_blocks = 1;
}

/* Explicitly free a float cell.  */

void
free_float (ptr)
     struct Lisp_Float *ptr;
{
  *(struct Lisp_Float **)&ptr->data = float_free_list;
  float_free_list = ptr;
}

Lisp_Object
make_float (float_value)
     double float_value;
{

    {
      if (float_block_index == FLOAT_BLOCK_SIZE)
	{
	  register struct float_block *new;

	  new = (struct float_block *) lisp_malloc (sizeof (struct float_block));
	  VALIDATE_LISP_STORAGE (new, sizeof *new);
	  new->next = float_block;
	  float_block = new;
	  float_block_index = 0;
	  n_float_blocks++;

{
  struct cons_block *next;
  struct Lisp_Cons conses[CONS_BLOCK_SIZE];
};

struct cons_block *cons_block;
int cons_block_index;

struct Lisp_Cons *cons_free_list;

/* Total number of cons blocks now in use.  */

int n_cons_blocks;

void
init_cons ()
{
  cons_block = (struct cons_block *) lisp_malloc (sizeof (struct cons_block));
  cons_block->next = 0;
  bzero ((char *) cons_block->conses, sizeof cons_block->conses);
  cons_block_index = 0;
  cons_free_list = 0;
  n_cons_blocks = 1;
}

/* Explicitly free a cons cell.  */

void
free_cons (ptr)
     struct Lisp_Cons *ptr;
{
  *(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
  cons_free_list = ptr;
}

DEFUN ("cons", Fcons, Scons, 2, 2, 0,
  "Create a new cons, give it CAR and CDR as components, and return it.")
  (car, cdr)
     Lisp_Object car, cdr;

  else
    {
      if (cons_block_index == CONS_BLOCK_SIZE)
	{
	  register struct cons_block *new;
	  new = (struct cons_block *) lisp_malloc (sizeof (struct cons_block));
	  VALIDATE_LISP_STORAGE (new, sizeof *new);
	  new->next = cons_block;
	  cons_block = new;
	  cons_block_index = 0;
	  n_cons_blocks++;

  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)

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


/***********************************************************************
			   Vector Allocation
 ***********************************************************************/

struct Lisp_Vector *all_vectors;

/* Total number of vector-like objects now in use.  */

int n_vectors;

struct Lisp_Vector *
allocate_vectorlike (len)
     EMACS_INT len;
{
  struct Lisp_Vector *p;

#ifdef DOUG_LEA_MALLOC
  /* Prevent mmap'ing the chunk (which is potentially very large).. */
  mallopt (M_MMAP_MAX, 0);
#endif
  p = (struct Lisp_Vector *)lisp_malloc (sizeof (struct Lisp_Vector)
					 + (len - 1) * sizeof (Lisp_Object));
#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 += (sizeof (struct Lisp_Vector)
		       + (len - 1) * sizeof (Lisp_Object));
  vector_cells_consed += len;
  n_vectors++;

  p->next = all_vectors;
  all_vectors = p;
  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)

    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\

  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

  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;

  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\

    }
  XSETCOMPILED (val, p);
  return val;
}


/***********************************************************************
			   Symbol Allocation
 ***********************************************************************/

{
  struct symbol_block *next;
  struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
};

struct symbol_block *symbol_block;
int symbol_block_index;

struct Lisp_Symbol *symbol_free_list;

/* Total number of symbol blocks now in use.  */

int n_symbol_blocks;

void
init_symbol ()
{
  symbol_block = (struct symbol_block *) lisp_malloc (sizeof (struct symbol_block));
  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;

  else
    {
      if (symbol_block_index == SYMBOL_BLOCK_SIZE)
	{
	  struct symbol_block *new;
	  new = (struct symbol_block *) lisp_malloc (sizeof (struct symbol_block));
	  VALIDATE_LISP_STORAGE (new, sizeof *new);
	  new->next = symbol_block;
	  symbol_block = new;
	  symbol_block_index = 0;
	  n_symbol_blocks++;

}



/***********************************************************************
			   Marker Allocation
 ***********************************************************************/

/* Allocation of markers and other objects that share that structure.
   Works like allocation of conses. */

int n_marker_blocks;

void
init_marker ()
{
  marker_block = (struct marker_block *) lisp_malloc (sizeof (struct marker_block));
  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;

  else
    {
      if (marker_block_index == MARKER_BLOCK_SIZE)
	{
	  struct marker_block *new;
	  new = (struct marker_block *) lisp_malloc (sizeof (struct marker_block));
	  VALIDATE_LISP_STORAGE (new, sizeof *new);
	  new->next = marker_block;
	  marker_block = new;
	  marker_block_index = 0;
	  n_marker_blocks++;

  }
}



/***********************************************************************
		       Pure Storage Management
 ***********************************************************************/

/* Return a string allocated in pure space.  DATA is a buffer holding

  XSETSTRING (string, s);
  return string;
}


Lisp_Object
pure_cons (car, cdr)
     Lisp_Object car, cdr;
{
  register Lisp_Object new;

  XCAR (new) = Fpurecopy (car);
  XCDR (new) = Fpurecopy (cdr);
  return new;
}


Lisp_Object
make_pure_float (num)
     double num;
{

  XFLOAT_DATA (new) = num;
  XSETFASTINT (XFLOAT (new)->type, 0);	/* bug chasing -wsr */
  return new;
}

Lisp_Object
make_pure_vector (len)
     EMACS_INT len;
{
  register Lisp_Object new;
  register EMACS_INT size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object);

  if (pureptr + size > PURESIZE)
    error ("Pure Lisp storage exhausted");

  XSETVECTOR (new, PUREBEG + pureptr);
  pureptr += size;
  XVECTOR (new)->size = len;
  return new;
}

DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
  "Make a copy of OBJECT in pure storage.\n\
Recursively copies contents of vectors and cons cells.\n\
Does not copy symbols.  Copies strings without text properties.")

    error ("Attempt to copy a marker to pure storage");
  else
    return obj;
}


/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

#define NSTATICS 1024

Lisp_Object *staticvec[NSTATICS] = {0};

int staticidx = 0;

/* Put an entry in staticvec, pointing at the variable with address
   VARADDRESS.  */

void

struct catchtag
{
    Lisp_Object tag;
    Lisp_Object val;
    struct catchtag *next;
#if 0 /* We don't need this for GC purposes */
    jmp_buf jmp;
#endif
};

struct backtrace
{
  struct backtrace *next;

  /* If nargs is UNEVALLED, args points to slot holding list of
     unevalled args.  */
  char evalargs;
};


/* Garbage collection!  */

/* Temporarily prevent garbage collection.  */

int
inhibit_garbage_collection ()

  specbind (Qgc_cons_threshold, number);

  return count;
}

DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
  "Reclaim storage for Lisp objects no longer needed.\n\
Returns info on amount of space in use:\n\
 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\

     In some cases, the structures point to the slots to be marked.
     For these, we use MARKBIT to avoid double marking of the slot.  */

  for (i = 0; i < staticidx; i++)
    mark_object (staticvec[i]);
  for (tail = gcprolist; tail; tail = tail->next)
    for (i = 0; i < tail->nvars; i++)
      if (!XMARKBIT (tail->var[i]))
	{
	  mark_object (&tail->var[i]);
	  XMARK (tail->var[i]);
	}
  mark_byte_stack ();
  for (bind = specpdl; bind != specpdl_ptr; bind++)
    {
      mark_object (&bind->symbol);
      mark_object (&bind->old_value);

	nextb = nextb->next;
      }
  }

  gc_sweep ();

  /* Clear the mark bits that we set in certain root slots.  */

  for (tail = gcprolist; tail; tail = tail->next)
    for (i = 0; i < tail->nvars; i++)
      XUNMARK (tail->var[i]);
  unmark_byte_stack ();
  for (backlist = backtrace_list; backlist; backlist = backlist->next)
    {
      XUNMARK (*backlist->function);
      if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)

      for (; i >= 0; i--)
	XUNMARK (backlist->args[i]);
    }  
  XUNMARK (buffer_defaults.name);
  XUNMARK (buffer_local_symbols.name);

  UNBLOCK_INPUT;

  /* clear_marks (); */
  gc_in_progress = 0;

  total[5] = Fcons (make_number (total_intervals),
		    make_number (total_free_intervals));
  total[6] = Fcons (make_number (total_strings),
		    make_number (total_free_strings));

  return Flist (7, total);
}

#if 0
static void
clear_marks ()
{
  /* Clear marks on all conses */
  {
    register struct cons_block *cblk;
    register int lim = cons_block_index;
  
    for (cblk = cons_block; cblk; cblk = cblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  XUNMARK (cblk->conses[i].car);
	lim = CONS_BLOCK_SIZE;
      }
  }
  /* Clear marks on all symbols */
  {
    register struct symbol_block *sblk;
    register int lim = symbol_block_index;
  
    for (sblk = symbol_block; sblk; sblk = sblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  {
	    XUNMARK (sblk->symbols[i].plist);
	  }
	lim = SYMBOL_BLOCK_SIZE;
      }
  }
  /* Clear marks on all markers */
  {
    register struct marker_block *sblk;
    register int lim = marker_block_index;
  
    for (sblk = marker_block; sblk; sblk = sblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  if (sblk->markers[i].u_marker.type == Lisp_Misc_Marker)
	    XUNMARK (sblk->markers[i].u_marker.chain);
	lim = MARKER_BLOCK_SIZE;
      }
  }
  /* Clear mark bits on all buffers */
  {
    register struct buffer *nextb = all_buffers;

    while (nextb)
      {
	XUNMARK (nextb->name);
	nextb = nextb->next;
      }
  }
}
#endif

/* Mark Lisp objects in glyph matrix MATRIX.  Currently the
   only interesting objects referenced from glyphs are strings.  */

static void

		mark_object (&glyph->object);
	  }
      }
}

/* Mark Lisp faces in the face cache C.  */

static void
mark_face_cache (c)
     struct face_cache *c;

 loop:
  obj = *objptr;
 loop2:
  XUNMARK (obj);

  if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
      && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
    return;

  last_marked[last_marked_index++] = objptr;
  if (last_marked_index == LAST_MARKED_SIZE)
    last_marked_index = 0;

	if (XMARKBIT (ptr->plist)) break;
	XMARK (ptr->plist);
	mark_object ((Lisp_Object *) &ptr->value);
	mark_object (&ptr->function);
	mark_object (&ptr->plist);
	MARK_INTERVAL_TREE (ptr->name->intervals);
	MARK_STRING (ptr->name);
	
	/* 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;

    default:
      abort ();
    }

  return survives_p;
}



/* Sweep: find all structures not marked, and free them. */

	  if (!XMARKBIT (cblk->conses[i].car))
	    {
	      this_free++;
	      *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
	      cons_free_list = &cblk->conses[i];
	    }
	  else
	    {
	      num_used++;
	      XUNMARK (cblk->conses[i].car);

	  if (!XMARKBIT (fblk->floats[i].type))
	    {
	      this_free++;
	      *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
	      float_free_list = &fblk->floats[i];
	    }
	  else
	    {
	      num_used++;
	      XUNMARK (fblk->floats[i].type);

	for (i = 0; i < lim; i++)
	  if (!XMARKBIT (sblk->symbols[i].plist))
	    {
	      *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list;
	      symbol_free_list = &sblk->symbols[i];
	      this_free++;
	    }
	  else
	    {
	      num_used++;
	      UNMARK_STRING (sblk->symbols[i].name);
	      XUNMARK (sblk->symbols[i].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

	  if (prev)
	    prev->next = buffer->next;
	  else
	    all_buffers = buffer->next;
	  next = buffer->next;
	  xfree (buffer);
	  buffer = next;
	}
      else
	{
	  XUNMARK (buffer->name);

    total_vector_size = 0;

    while (vector)
      if (!(vector->size & ARRAY_MARK_FLAG))
	{
#if 0
	  if ((vector->size & (PSEUDOVECTOR_FLAG | PVEC_HASH_TABLE))
	      == (PSEUDOVECTOR_FLAG | PVEC_HASH_TABLE))
	    fprintf (stderr, "Freeing hash table %p\n", vector);
#endif
	  if (prev)
	    prev->next = vector->next;
	  else
	    all_vectors = vector->next;
	  next = vector->next;

void
init_alloc_once ()
{
  /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
  pureptr = 0;
#ifdef HAVE_SHM
  pure_size = PURESIZE;
#endif
  all_vectors = 0;
  ignore_warnings = 1;

  init_strings ();
  init_cons ();
  init_symbol ();
  init_marker ();
  init_float ();
  INIT_INTERVALS;

#ifdef REL_ALLOC
  malloc_hysteresis = 32;
#else
  malloc_hysteresis = 0;

  DEFVAR_INT ("intervals-consed", &intervals_consed,
    "Number of intervals that have been consed so far.");

  DEFVAR_INT ("strings-consed", &strings_consed,
    "Number of strings that have been consed so far.");

#if 0
  DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used,
    "Number of bytes of unshared memory allocated in this session.");

  DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused,
    "Number of bytes of unshared memory remaining available in this session.");
#endif

  DEFVAR_LISP ("purify-flag", &Vpurify_flag,
    "Non-nil means loading Lisp code in order to dump an executable.\n\
This means that certain objects should be allocated in shared (pure) space.");

  defsubr (&Smake_marker);
  defsubr (&Spurecopy);
  defsubr (&Sgarbage_collect);
  defsubr (&Smemory_limit);
  defsubr (&Smemory_use_counts);
}

27738:581c76c41ca4

#include "frame.h"
#include "blockinput.h"
#include "keyboard.h"
#include "charset.h"
#include "syssignal.h"
#include <setjmp.h>

extern char *sbrk ();

#ifdef DOUG_LEA_MALLOC

/* Two limits controlling how much undo information to keep.  */

int undo_limit;
int undo_strong_limit;

/* Number of live and free conses etc.  */

static int total_conses, total_markers, total_symbols, total_vector_size;
static int total_free_conses, total_free_markers, total_free_symbols;
static int total_free_floats, total_floats;

/* Points to memory space allocated as "spare", to be freed if we run
   out of memory.  */

static char *spare_memory;

EMACS_INT pure_size;

#endif /* not HAVE_SHM */

/* Value is non-zero if P points into pure space.  */

#define PURE_POINTER_P(P)					\
     (((PNTR_COMPARISON_TYPE) (P)				\
       < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE))	\
      && ((PNTR_COMPARISON_TYPE) (P)				\
	  >= (PNTR_COMPARISON_TYPE) pure))

/* Index in pure at which next pure object will be allocated.. */

int pureptr;

/* If nonzero, this is a warning delivered by malloc and not yet

static void mark_buffer P_ ((Lisp_Object));
static void mark_kboards P_ ((void));
static void gc_sweep P_ ((void));
static void mark_glyph_matrix P_ ((struct glyph_matrix *));
static void mark_face_cache P_ ((struct face_cache *));

#ifdef HAVE_WINDOW_SYSTEM
static void mark_image P_ ((struct image *));
static void mark_image_cache P_ ((struct frame *));
#endif /* HAVE_WINDOW_SYSTEM */

static void compact_small_strings P_ ((void));
static void free_large_strings P_ ((void));
static void sweep_strings P_ ((void));

extern int message_enable_multibyte;


#if GC_MARK_STACK

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
#include <stdio.h>		/* For fprintf.  */
#endif

/* A unique object in pure space used to make some Lisp objects
   on free lists recognizable in O(1).  */

Lisp_Object Vdead;

/* When scanning the C stack for live Lisp objects, Emacs keeps track
   of what memory allocated via lisp_malloc is intended for what
   purpose.  This enumeration specifies the type of memory.  */

enum mem_type
{
  MEM_TYPE_NON_LISP,
  MEM_TYPE_BUFFER,
  MEM_TYPE_CONS,
  MEM_TYPE_STRING,
  MEM_TYPE_MISC,
  MEM_TYPE_SYMBOL,
  MEM_TYPE_FLOAT,
  MEM_TYPE_VECTOR
};

struct mem_node;
static void *lisp_malloc P_ ((int, enum mem_type));
static void mark_stack P_ ((void));
static void init_stack P_ ((Lisp_Object *));
static int live_vector_p P_ ((struct mem_node *, void *));
static int live_buffer_p P_ ((struct mem_node *, void *));
static int live_string_p P_ ((struct mem_node *, void *));
static int live_cons_p P_ ((struct mem_node *, void *));
static int live_symbol_p P_ ((struct mem_node *, void *));
static int live_float_p P_ ((struct mem_node *, void *));
static int live_misc_p P_ ((struct mem_node *, void *));
static void mark_memory P_ ((void *, void *));
static void mem_init P_ ((void));
static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
static void mem_insert_fixup P_ ((struct mem_node *));
static void mem_rotate_left P_ ((struct mem_node *));
static void mem_rotate_right P_ ((struct mem_node *));
static void mem_delete P_ ((struct mem_node *));
static void mem_delete_fixup P_ ((struct mem_node *));
static INLINE struct mem_node *mem_find P_ ((void *));

#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
static void check_gcpros P_ ((void));
#endif

#endif /* GC_MARK_STACK != 0 */


/************************************************************************
				Malloc
 ************************************************************************/

/* Write STR to Vstandard_output plus some advice on how to free some
   memory.  Called when memory gets low.  */

Lisp_Object
malloc_warning_1 (str)
     Lisp_Object str;
{

  write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
  write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
  return Qnil;
}


/* Function malloc calls this if it finds we are near exhausting
   storage.  */

void
malloc_warning (str)
     char *str;
{
  pending_malloc_warning = str;
}


/* Display a malloc warning in buffer *Danger*.  */

void
display_malloc_warning ()
{
  register Lisp_Object val;

  val = build_string (pending_malloc_warning);
  pending_malloc_warning = 0;
  internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
}


#ifdef DOUG_LEA_MALLOC
#  define BYTES_USED (mallinfo ().arena)
#else
#  define BYTES_USED _bytes_used
#endif


/* Called if malloc returns zero.  */

void
memory_full ()
{

  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
  while (1)
    Fsignal (Qnil, memory_signal_data);
}


/* Called if we can't allocate relocatable space for a buffer.  */

void
buffer_memory_full ()

     get infinite recursion trying to build the string.  */
  while (1)
    Fsignal (Qerror, memory_signal_data);
}


/* Like malloc but check for no memory and block interrupt input..  */

long *
xmalloc (size)
     int size;
{

  if (!val && size)
    memory_full ();
  return val;
}


/* Like realloc but check for no memory and block interrupt input..  */

long *
xrealloc (block, size)
     long *block;
     int size;

  if (!val && size) memory_full ();
  return val;
}


/* Like free but block interrupt input..  */

void
xfree (block)
     long *block;
{
  BLOCK_INPUT;
  free (block);
  UNBLOCK_INPUT;
}


/* Like malloc but used for allocating Lisp data.  NBYTES is the
   number of bytes to allocate, TYPE describes the intended use of the
   allcated memory block (for strings, for conses, ...).  */

static void *
lisp_malloc (nbytes, type)
     int nbytes;
     enum mem_type type;
{
  register void *val;

  BLOCK_INPUT;
  allocating_for_lisp++;
  val = (void *) malloc (nbytes);
  allocating_for_lisp--;
  UNBLOCK_INPUT;

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


/* Return a new buffer structure allocated from the heap with
   a call to lisp_malloc.  */

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


/* Free BLOCK.  This must be called to free memory allocated with a
   call to lisp_malloc.  */

void
lisp_free (block)
     long *block;
{
  BLOCK_INPUT;
  allocating_for_lisp++;
  free (block);
#if GC_MARK_STACK
  mem_delete (mem_find (block));
#endif
  allocating_for_lisp--;
  UNBLOCK_INPUT;
}


/* Arranging to disable input signals while we're in malloc.

   This only works with GNU malloc.  To help out systems which can't
   use GNU malloc, all the calls to malloc, realloc, and free

  __free_hook = emacs_blocked_free;
  UNBLOCK_INPUT;
}


/* 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.

   This is called when a relocatable block is freed in ralloc.c.  */

refill_memory_reserve ()
{
  if (spare_memory == 0)
    spare_memory = (char *) malloc (SPARE_MEMORY);
}


/* This function is the malloc hook that Emacs uses.  */

static void *
emacs_blocked_malloc (size)

  UNBLOCK_INPUT;

  return value;
}


/* This function is the realloc hook that Emacs uses.  */

static void *
emacs_blocked_realloc (ptr, size)
     void *ptr;
     unsigned size;
{

  UNBLOCK_INPUT;

  return value;
}


/* Called from main to set up malloc to use our hooks.  */

void
uninterrupt_malloc ()
{
  if (__free_hook != emacs_blocked_free)
    old_free_hook = __free_hook;


/***********************************************************************
			 Interval Allocation
 ***********************************************************************/

/* Number of intervals allocated in an interval_block structure.
   The 1020 is 1024 minus malloc overhead.  */

#define INTERVAL_BLOCK_SIZE \
  ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))

/* Intervals are allocated in chunks in form of an interval_block
   structure.  */

struct interval_block
{
  struct interval_block *next;
  struct interval intervals[INTERVAL_BLOCK_SIZE];
};

/* Current interval block.  Its `next' pointer points to older
   blocks.  */

struct interval_block *interval_block;

/* Index in interval_block above of the next unused interval
   structure.  */

static int interval_block_index;

/* Number of free and live intervals.  */

static int total_free_intervals, total_intervals;

/* List of free intervals.  */

INTERVAL interval_free_list;

/* Total number of interval blocks now in use.  */

int n_interval_blocks;


/* Initialize interval allocation.  */

static void
init_intervals ()
{
  interval_block
    = (struct interval_block *) lisp_malloc (sizeof *interval_block,
					     MEM_TYPE_NON_LISP);
  interval_block->next = 0;
  bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
  interval_block_index = 0;
  interval_free_list = 0;
  n_interval_blocks = 1;
}


/* Return a new interval.  */

INTERVAL
make_interval ()
{
  INTERVAL val;

    {
      if (interval_block_index == INTERVAL_BLOCK_SIZE)
	{
	  register struct interval_block *newi;

	  newi = (struct interval_block *) lisp_malloc (sizeof *newi,
							MEM_TYPE_NON_LISP);

	  VALIDATE_LISP_STORAGE (newi, sizeof *newi);
	  newi->next = interval_block;
	  interval_block = newi;
	  interval_block_index = 0;

  intervals_consed++;
  RESET_INTERVAL (val);
  return val;
}


/* Mark Lisp objects in interval I. */

static void
mark_interval (i, dummy)
     register INTERVAL i;
     Lisp_Object dummy;

    abort ();
  mark_object (&i->plist);
  XMARK (i->plist);
}


/* Mark the interval tree rooted in TREE.  Don't call this directly;
   use the macro MARK_INTERVAL_TREE instead.  */

static void
mark_interval_tree (tree)
     register INTERVAL tree;
{
  /* No need to test if this tree has been marked already; this

     a cast.  */
  XMARK (* (Lisp_Object *) &tree->parent);

  traverse_intervals (tree, 1, 0, mark_interval, Qnil);
}


/* Mark the interval tree rooted in I.  */

#define MARK_INTERVAL_TREE(i)				\
  do {							\
    if (!NULL_INTERVAL_P (i)				\
	&& ! XMARKBIT (*(Lisp_Object *) &i->parent))	\
      mark_interval_tree (i);				\
  } while (0)


/* The oddity in the call to XUNMARK is necessary because XUNMARK
   expands to an assignment to its argument, and most C compilers
   don't support casts on the left operand of `='.  */

       XUNMARK (* (Lisp_Object *) (&(i)->parent));	\
       (i) = balance_intervals (i);			\
     }							\
  } while (0)



/***********************************************************************
			  String Allocation
 ***********************************************************************/

struct sdata
{
  /* Back-pointer to the string this sdata belongs to.  If null, this
     structure is free, and the NBYTES member of the union below
     contains the string's byte size (the same value that STRING_BYTES
     would return if STRING were non-null).  If non-null, STRING_BYTES
     (STRING) is the size of the data, and DATA contains the string's
     contents.  */
  struct Lisp_String *string;

  if (string_free_list == NULL)
    {
      struct string_block *b;
      int i;

      b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
      VALIDATE_LISP_STORAGE (b, sizeof *b);
      bzero (b, sizeof *b);
      b->next = string_blocks;
      string_blocks = b;
      ++n_string_blocks;

#ifdef DOUG_LEA_MALLOC
      /* Prevent mmap'ing the chunk (which is potentially very large). */
      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

	   || (((char *) current_sblock + SBLOCK_SIZE
		- (char *) current_sblock->next_free)
	       < needed))
    {
      /* Not enough room in the current sblock.  */
      b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
      b->next_free = &b->first_data;
      b->first_data.string = NULL;
      b->next = NULL;

      if (current_sblock)

	      string_free_list = s;
	      ++nfree;
	    }
	}

      /* Free blocks that contain free Lisp_Strings only, except
	 the first two of them.  */
      if (nfree == STRINGS_IN_STRING_BLOCK
	  && total_free_strings > STRINGS_IN_STRING_BLOCK)
	{
	  lisp_free (b);

  /* 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;

{
  struct float_block *next;
  struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
};

/* Current float_block.  */

struct float_block *float_block;

/* Index of first unused Lisp_Float in the current float_block.  */

int float_block_index;

/* Total number of float blocks now in use.  */

int n_float_blocks;

/* Free-list of Lisp_Floats.  */

struct Lisp_Float *float_free_list;


/* Initialze float allocation.  */

void
init_float ()
{
  float_block = (struct float_block *) lisp_malloc (sizeof *float_block,
						    MEM_TYPE_FLOAT);
  float_block->next = 0;
  bzero ((char *) float_block->floats, sizeof float_block->floats);
  float_block_index = 0;
  float_free_list = 0;
  n_float_blocks = 1;
}


/* Explicitly free a float cell by putting it on the free-list.  */

void
free_float (ptr)
     struct Lisp_Float *ptr;
{
  *(struct Lisp_Float **)&ptr->data = float_free_list;
#if GC_MARK_STACK
  ptr->type = Vdead;
#endif
  float_free_list = ptr;
}


/* Return a new float object with value FLOAT_VALUE.  */

Lisp_Object
make_float (float_value)
     double float_value;
{

    {
      if (float_block_index == FLOAT_BLOCK_SIZE)
	{
	  register struct float_block *new;

	  new = (struct float_block *) lisp_malloc (sizeof *new,
						    MEM_TYPE_FLOAT);
	  VALIDATE_LISP_STORAGE (new, sizeof *new);
	  new->next = float_block;
	  float_block = new;
	  float_block_index = 0;
	  n_float_blocks++;

{
  struct cons_block *next;
  struct Lisp_Cons conses[CONS_BLOCK_SIZE];
};

/* Current cons_block.  */

struct cons_block *cons_block;

/* Index of first unused Lisp_Cons in the current block.  */

int cons_block_index;

/* Free-list of Lisp_Cons structures.  */

struct Lisp_Cons *cons_free_list;

/* Total number of cons blocks now in use.  */

int n_cons_blocks;


/* Initialize cons allocation.  */

void
init_cons ()
{
  cons_block = (struct cons_block *) lisp_malloc (sizeof *cons_block,
						  MEM_TYPE_CONS);
  cons_block->next = 0;
  bzero ((char *) cons_block->conses, sizeof cons_block->conses);
  cons_block_index = 0;
  cons_free_list = 0;
  n_cons_blocks = 1;
}


/* Explicitly free a cons cell by putting it on the free-list.  */

void
free_cons (ptr)
     struct Lisp_Cons *ptr;
{
  *(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
#if GC_MARK_STACK
  ptr->car = Vdead;
#endif
  cons_free_list = ptr;
}


DEFUN ("cons", Fcons, Scons, 2, 2, 0,
  "Create a new cons, give it CAR and CDR as components, and return it.")
  (car, cdr)
     Lisp_Object car, cdr;

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

  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)

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


/***********************************************************************
			   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;
  int nbytes;

#ifdef DOUG_LEA_MALLOC
  /* Prevent mmap'ing the chunk (which is potentially very large).. */
  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)

    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\

  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

  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;

  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\

    }
  XSETCOMPILED (val, p);
  return val;
}



/***********************************************************************
			   Symbol Allocation
 ***********************************************************************/

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

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

}



/***********************************************************************
		       Marker (Misc) Allocation
 ***********************************************************************/

/* Allocation of markers and other objects that share that structure.
   Works like allocation of conses. */

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;

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

  }
}



/************************************************************************
			   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 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)
    {
      void *po = (void *) XPNTR (*p);
      struct mem_node *m = mem_find (po);
      
      if (m != MEM_NIL)
	{
	  int mark_p = 0;

	  switch (XGCTYPE (*p))
	    {
	    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 (*p)->car));
	      break;

	    case Lisp_Symbol:
	      mark_p = (live_symbol_p (m, po)
			&& !XMARKBIT (XSYMBOL (*p)->plist));
	      break;

	    case Lisp_Float:
	      mark_p = (live_float_p (m, po)
			&& !XMARKBIT (XFLOAT (*p)->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 (*p)
			  && !(XVECTOR (*p)->size & ARRAY_MARK_FLAG));
	      else if (live_buffer_p (m, po))
		mark_p = GC_BUFFERP (*p) && !XMARKBIT (XBUFFER (*p)->name);
	      break;

	    case Lisp_Misc:
	      if (live_misc_p (m, po))
		{
		  switch (XMISCTYPE (*p))
		    {
		    case Lisp_Misc_Marker:
		      mark_p = !XMARKBIT (XMARKER (*p)->chain);
		      break;
		      
		    case Lisp_Misc_Buffer_Local_Value:
		    case Lisp_Misc_Some_Buffer_Local_Value:
		      mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (*p)->realvalue);
		      break;
		      
		    case Lisp_Misc_Overlay:
		      mark_p = !XMARKBIT (XOVERLAY (*p)->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 (p);
	    }
	}
    }
}


#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS

/* Abort if anything GCPRO'd doesn't survive the GC.  */

static void
check_gcpros ()
{
  struct gcpro *p;
  int i;

  for (p = gcprolist; p; p = p->next)
    for (i = 0; i < p->nvars; ++i)
      if (!survives_gc_p (p->var[i]))
	abort ();
}

#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES

static void
dump_zombies ()
{
  int i;

  fprintf (stderr, "\nZombies kept alive = %d:\n", nzombies);
  for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
    {
      fprintf (stderr, "  %d = ", i);
      debug_print (zombies[i]);
    }
}

#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */


/* Mark live Lisp objects on the C stack.  */

static void
mark_stack ()
{
  jmp_buf j;
  int stack_grows_down_p = (char *) &j > (char *) stack_base;
  void *end;

  /* This trick flushes the register windows so that all the state of
     the process is contained in the stack.  */
#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
  setjmp (j);
  end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif

  /* This assumes that the stack is a contiguous region in memory.  If
     that's not the case, something has to be done here to iterate over
     the stack segments.  */
  mark_memory (stack_base, end);

#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
  check_gcpros ();
#endif
}


#endif /* GC_MARK_STACK != 0 */



/***********************************************************************
		       Pure Storage Management
 ***********************************************************************/

/* Return a string allocated in pure space.  DATA is a buffer holding

  XSETSTRING (string, s);
  return string;
}


/* Return a cons allocated from pure space.  Give it pure copies
   of CAR as car and CDR as cdr.  */

Lisp_Object
pure_cons (car, cdr)
     Lisp_Object car, cdr;
{
  register Lisp_Object new;

  XCAR (new) = Fpurecopy (car);
  XCDR (new) = Fpurecopy (cdr);
  return new;
}


/* Value is a float object with value NUM allocated from pure space.  */

Lisp_Object
make_pure_float (num)
     double num;
{

  XFLOAT_DATA (new) = num;
  XSETFASTINT (XFLOAT (new)->type, 0);	/* bug chasing -wsr */
  return new;
}


/* Return a vector with room for LEN Lisp_Objects allocated from
   pure space.  */

Lisp_Object
make_pure_vector (len)
     EMACS_INT len;
{
  register Lisp_Object new;
  register EMACS_INT size = (sizeof (struct Lisp_Vector)
			     + (len - 1) * sizeof (Lisp_Object));

  if (pureptr + size > PURESIZE)
    error ("Pure Lisp storage exhausted");

  XSETVECTOR (new, PUREBEG + pureptr);
  pureptr += size;
  XVECTOR (new)->size = len;
  return new;
}


DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
  "Make a copy of OBJECT in pure storage.\n\
Recursively copies contents of vectors and cons cells.\n\
Does not copy symbols.  Copies strings without text properties.")

    error ("Attempt to copy a marker to pure storage");
  else
    return obj;
}



/***********************************************************************
			  Protection from GC
 ***********************************************************************/

/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

/* Addresses of staticpro'd variables.  */

#define NSTATICS 1024
Lisp_Object *staticvec[NSTATICS] = {0};

/* Index of next unused slot in staticvec.  */

int staticidx = 0;


/* Put an entry in staticvec, pointing at the variable with address
   VARADDRESS.  */

void

struct catchtag
{
    Lisp_Object tag;
    Lisp_Object val;
    struct catchtag *next;
};

struct backtrace
{
  struct backtrace *next;

  /* If nargs is UNEVALLED, args points to slot holding list of
     unevalled args.  */
  char evalargs;
};



/***********************************************************************
			  Protection from GC
 ***********************************************************************/

/* Temporarily prevent garbage collection.  */

int
inhibit_garbage_collection ()

  specbind (Qgc_cons_threshold, number);

  return count;
}


DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
  "Reclaim storage for Lisp objects no longer needed.\n\
Returns info on amount of space in use:\n\
 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\

     In some cases, the structures point to the slots to be marked.
     For these, we use MARKBIT to avoid double marking of the slot.  */

  for (i = 0; i < staticidx; i++)
    mark_object (staticvec[i]);

#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
     || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
  mark_stack ();
#else
  for (tail = gcprolist; tail; tail = tail->next)
    for (i = 0; i < tail->nvars; i++)
      if (!XMARKBIT (tail->var[i]))
	{
	  mark_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);

	nextb = nextb->next;
      }
  }

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
  mark_stack ();
#endif

  gc_sweep ();

  /* Clear the mark bits that we set in certain root slots.  */

#if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
     || 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)

      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 ();
#endif

  UNBLOCK_INPUT;

  /* clear_marks (); */
  gc_in_progress = 0;

  total[5] = Fcons (make_number (total_intervals),
		    make_number (total_free_intervals));
  total[6] = Fcons (make_number (total_strings),
		    make_number (total_free_strings));

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

    avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
    max_live = max (nlive, max_live);
    avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
    max_zombies = max (nzombies, max_zombies);
    ++ngcs;
    }
#endif

  return Flist (7, total);
}


/* Mark Lisp objects in glyph matrix MATRIX.  Currently the
   only interesting objects referenced from glyphs are strings.  */

static void

		mark_object (&glyph->object);
	  }
      }
}


/* Mark Lisp faces in the face cache C.  */

static void
mark_face_cache (c)
     struct face_cache *c;

 loop:
  obj = *objptr;
 loop2:
  XUNMARK (obj);

  if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE) XPNTR (obj)))
    return;

  last_marked[last_marked_index++] = objptr;
  if (last_marked_index == LAST_MARKED_SIZE)
    last_marked_index = 0;

	if (XMARKBIT (ptr->plist)) break;
	XMARK (ptr->plist);
	mark_object ((Lisp_Object *) &ptr->value);
	mark_object (&ptr->function);
	mark_object (&ptr->plist);

	if (!PURE_POINTER_P (ptr->name))
	  MARK_STRING (ptr->name);
	MARK_INTERVAL_TREE (ptr->name->intervals);
	
	/* 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;

    default:
      abort ();
    }

  return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
}



/* Sweep: find all structures not marked, and free them. */

	  if (!XMARKBIT (cblk->conses[i].car))
	    {
	      this_free++;
	      *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
	      cons_free_list = &cblk->conses[i];
#if GC_MARK_STACK
	      cons_free_list->car = Vdead;
#endif
	    }
	  else
	    {
	      num_used++;
	      XUNMARK (cblk->conses[i].car);

	  if (!XMARKBIT (fblk->floats[i].type))
	    {
	      this_free++;
	      *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
	      float_free_list = &fblk->floats[i];
#if GC_MARK_STACK
	      float_free_list->type = Vdead;
#endif
	    }
	  else
	    {
	      num_used++;
	      XUNMARK (fblk->floats[i].type);

	for (i = 0; i < lim; i++)
	  if (!XMARKBIT (sblk->symbols[i].plist))
	    {
	      *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list;
	      symbol_free_list = &sblk->symbols[i];
#if GC_MARK_STACK
	      symbol_free_list->function = Vdead;
#endif
	      this_free++;
	    }
	  else
	    {
	      num_used++;
	      if (!PURE_POINTER_P (sblk->symbols[i].name))
		UNMARK_STRING (sblk->symbols[i].name);
	      XUNMARK (sblk->symbols[i].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

	  if (prev)
	    prev->next = buffer->next;
	  else
	    all_buffers = buffer->next;
	  next = buffer->next;
	  lisp_free (buffer);
	  buffer = next;
	}
      else
	{
	  XUNMARK (buffer->name);

    total_vector_size = 0;

    while (vector)
      if (!(vector->size & ARRAY_MARK_FLAG))
	{
	  if (prev)
	    prev->next = vector->next;
	  else
	    all_vectors = vector->next;
	  next = vector->next;

void
init_alloc_once ()
{
  /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
  pureptr = 0;
#if GC_MARK_STACK
  mem_init ();
  Vdead = make_pure_string ("DEAD", 4, 4, 0);
#endif
#ifdef HAVE_SHM
  pure_size = PURESIZE;
#endif
  all_vectors = 0;
  ignore_warnings = 1;

  init_strings ();
  init_cons ();
  init_symbol ();
  init_marker ();
  init_float ();
  init_intervals ();

#ifdef REL_ALLOC
  malloc_hysteresis = 32;
#else
  malloc_hysteresis = 0;

  DEFVAR_INT ("intervals-consed", &intervals_consed,
    "Number of intervals that have been consed so far.");

  DEFVAR_INT ("strings-consed", &strings_consed,
    "Number of strings that have been consed so far.");

  DEFVAR_LISP ("purify-flag", &Vpurify_flag,
    "Non-nil means loading Lisp code in order to dump an executable.\n\
This means that certain objects should be allocated in shared (pure) space.");

  defsubr (&Smake_marker);
  defsubr (&Spurecopy);
  defsubr (&Sgarbage_collect);
  defsubr (&Smemory_limit);
  defsubr (&Smemory_use_counts);

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
  defsubr (&Sgc_status);
#endif
}