comparison src/alloc.c @ 109126:aec1143e8d85

Convert (most) functions in src to standard C. * src/alloc.c: Convert function definitions to standard C. * src/atimer.c: * src/bidi.c: * src/bytecode.c: * src/callint.c: * src/callproc.c: * src/casefiddle.c: * src/casetab.c: * src/category.c: * src/ccl.c: * src/character.c: * src/charset.c: * src/chartab.c: * src/cmds.c: * src/coding.c: * src/composite.c: * src/data.c: * src/dbusbind.c: * src/dired.c: * src/dispnew.c: * src/doc.c: * src/doprnt.c: * src/ecrt0.c: * src/editfns.c: * src/fileio.c: * src/filelock.c: * src/filemode.c: * src/fns.c: * src/font.c: * src/fontset.c: * src/frame.c: * src/fringe.c: * src/ftfont.c: * src/ftxfont.c: * src/gtkutil.c: * src/indent.c: * src/insdel.c: * src/intervals.c: * src/keymap.c: * src/lread.c: * src/macros.c: * src/marker.c: * src/md5.c: * src/menu.c: * src/minibuf.c: * src/prefix-args.c: * src/print.c: * src/ralloc.c: * src/regex.c: * src/region-cache.c: * src/scroll.c: * src/search.c: * src/sound.c: * src/strftime.c: * src/syntax.c: * src/sysdep.c: * src/termcap.c: * src/terminal.c: * src/terminfo.c: * src/textprop.c: * src/tparam.c: * src/undo.c: * src/unexelf.c: * src/window.c: * src/xfaces.c: * src/xfns.c: * src/xfont.c: * src/xftfont.c: * src/xgselect.c: * src/xmenu.c: * src/xrdb.c: * src/xselect.c: * src/xsettings.c: * src/xsmfns.c: * src/xterm.c: Likewise.

109125:12b02558bf51

  MEM_TYPE_VECTORLIKE
};

static POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
void refill_memory_reserve ();


#if GC_MARK_STACK || defined GC_MALLOC_CHECK

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES

 ************************************************************************/

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

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


/* Display an already-pending malloc warning.  */

void
display_malloc_warning ()
{
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));

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

void
buffer_memory_full ()
{
  /* If buffers use the relocating allocator, no need to free
     spare_memory, because we may have plenty of malloc space left
     that we could get, and if we don't, the malloc that fails will
     itself cause spare_memory to be freed.  If buffers don't use the

#endif

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

POINTER_TYPE *
xmalloc (size)
     size_t size;
{
  register POINTER_TYPE *val;

  MALLOC_BLOCK_INPUT;
  val = (POINTER_TYPE *) malloc (size);

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

POINTER_TYPE *
xrealloc (block, size)
     POINTER_TYPE *block;
     size_t size;
{
  register POINTER_TYPE *val;

  MALLOC_BLOCK_INPUT;
  /* We must call malloc explicitly when BLOCK is 0, since some

/* Like free but block interrupt input.  */

void
xfree (block)
     POINTER_TYPE *block;
{
  if (!block)
    return;
  MALLOC_BLOCK_INPUT;
  free (block);

/* Like strdup, but uses xmalloc.  */

char *
xstrdup (s)
     const char *s;
{
  size_t len = strlen (s) + 1;
  char *p = (char *) xmalloc (len);
  bcopy (s, p, len);
  return p;

/* Unwind for SAFE_ALLOCA */

Lisp_Object
safe_alloca_unwind (arg)
     Lisp_Object arg;
{
  register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);

  p->dogc = 0;
  xfree (p->pointer);

#ifndef USE_LSB_TAG
static void *lisp_malloc_loser;
#endif

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

  MALLOC_BLOCK_INPUT;

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

static void
lisp_free (block)
     POINTER_TYPE *block;
{
  MALLOC_BLOCK_INPUT;
  free (block);
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
  mem_delete (mem_find (block));

/* Allocate an aligned block of nbytes.
   Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
   smaller or equal to BLOCK_BYTES.  */
static POINTER_TYPE *
lisp_align_malloc (nbytes, type)
     size_t nbytes;
     enum mem_type type;
{
  void *base, *val;
  struct ablocks *abase;

  eassert (nbytes <= BLOCK_BYTES);

  eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
  return val;
}

static void
lisp_align_free (block)
     POINTER_TYPE *block;
{
  struct ablock *ablock = block;
  struct ablocks *abase = ABLOCK_ABASE (ablock);

  MALLOC_BLOCK_INPUT;

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

struct buffer *
allocate_buffer ()
{
  struct buffer *b
    = (struct buffer *) lisp_malloc (sizeof (struct buffer),
				     MEM_TYPE_BUFFER);
  b->size = sizeof (struct buffer) / sizeof (EMACS_INT);

/* Initialize interval allocation.  */

static void
init_intervals ()
{
  interval_block = NULL;
  interval_block_index = INTERVAL_BLOCK_SIZE;
  interval_free_list = 0;
  n_interval_blocks = 0;

/* Return a new interval.  */

INTERVAL
make_interval ()
{
  INTERVAL val;

  /* eassert (!handling_signal); */

/* Mark Lisp objects in interval I. */

static void
mark_interval (i, dummy)
     register INTERVAL i;
     Lisp_Object dummy;
{
  eassert (!i->gcmarkbit);		/* Intervals are never shared.  */
  i->gcmarkbit = 1;
  mark_object (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
     function is always called through the MARK_INTERVAL_TREE macro,
     which takes care of that.  */

#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)

/* Initialize string allocation.  Called from init_alloc_once.  */

static void
init_strings ()
{
  total_strings = total_free_strings = total_string_size = 0;
  oldest_sblock = current_sblock = large_sblocks = NULL;
  string_blocks = NULL;
  n_string_blocks = 0;

#endif

/* Return a new Lisp_String.  */

static struct Lisp_String *
allocate_string ()
{
  struct Lisp_String *s;

  /* eassert (!handling_signal); */

   set S->data to its `u.data' member.  Store a NUL byte at the end of
   S->data.  Set S->size to NCHARS and S->size_byte to NBYTES.  Free
   S->data if it was initially non-null.  */

void
allocate_string_data (s, nchars, nbytes)
     struct Lisp_String *s;
     int nchars, nbytes;
{
  struct sdata *data, *old_data;
  struct sblock *b;
  int needed, old_nbytes;

/* Sweep and compact strings.  */

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

  string_free_list = NULL;

/* Free dead large strings.  */

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

  for (b = large_sblocks; b; b = next)

/* Compact data of small strings.  Free sblocks that don't contain
   data of live strings after compaction.  */

static void
compact_small_strings ()
{
  struct sblock *b, *tb, *next;
  struct sdata *from, *to, *end, *tb_end;
  struct sdata *to_end, *from_end;

/* Make a string from NBYTES bytes at CONTENTS, and compute the number
   of characters from the contents.  This string may be unibyte or
   multibyte, depending on the contents.  */

Lisp_Object
make_string (contents, nbytes)
     const char *contents;
     int nbytes;
{
  register Lisp_Object val;
  int nchars, multibyte_nbytes;

  parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);

/* Make an unibyte string from LENGTH bytes at CONTENTS.  */

Lisp_Object
make_unibyte_string (contents, length)
     const char *contents;
     int length;
{
  register Lisp_Object val;
  val = make_uninit_string (length);
  bcopy (contents, SDATA (val), length);
  STRING_SET_UNIBYTE (val);

/* Make a multibyte string from NCHARS characters occupying NBYTES
   bytes at CONTENTS.  */

Lisp_Object
make_multibyte_string (contents, nchars, nbytes)
     const char *contents;
     int nchars, nbytes;
{
  register Lisp_Object val;
  val = make_uninit_multibyte_string (nchars, nbytes);
  bcopy (contents, SDATA (val), nbytes);
  return val;

/* Make a string from NCHARS characters occupying NBYTES bytes at
   CONTENTS.  It is a multibyte string if NBYTES != NCHARS.  */

Lisp_Object
make_string_from_bytes (contents, nchars, nbytes)
     const char *contents;
     int nchars, nbytes;
{
  register Lisp_Object val;
  val = make_uninit_multibyte_string (nchars, nbytes);
  bcopy (contents, SDATA (val), nbytes);
  if (SBYTES (val) == SCHARS (val))

   CONTENTS.  The argument MULTIBYTE controls whether to label the
   string as multibyte.  If NCHARS is negative, it counts the number of
   characters by itself.  */

Lisp_Object
make_specified_string (contents, nchars, nbytes, multibyte)
     const char *contents;
     int nchars, nbytes;
     int multibyte;
{
  register Lisp_Object val;

  if (nchars < 0)
    {

/* Make a string from the data at STR, treating it as multibyte if the
   data warrants.  */

Lisp_Object
build_string (str)
     const char *str;
{
  return make_string (str, strlen (str));
}


/* Return an unibyte Lisp_String set up to hold LENGTH characters
   occupying LENGTH bytes.  */

Lisp_Object
make_uninit_string (length)
     int length;
{
  Lisp_Object val;

  if (!length)
    return empty_unibyte_string;

/* Return a multibyte Lisp_String set up to hold NCHARS characters
   which occupy NBYTES bytes.  */

Lisp_Object
make_uninit_multibyte_string (nchars, nbytes)
     int nchars, nbytes;
{
  Lisp_Object string;
  struct Lisp_String *s;

  if (nchars < 0)

/* Initialize float allocation.  */

static void
init_float ()
{
  float_block = NULL;
  float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block.   */
  float_free_list = 0;
  n_float_blocks = 0;

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

static void
free_float (ptr)
     struct Lisp_Float *ptr;
{
  ptr->u.chain = float_free_list;
  float_free_list = ptr;
}


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

Lisp_Object
make_float (float_value)
     double float_value;
{
  register Lisp_Object val;

  /* eassert (!handling_signal); */

/* Initialize cons allocation.  */

static void
init_cons ()
{
  cons_block = NULL;
  cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block.  */
  cons_free_list = 0;
  n_cons_blocks = 0;

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

void
free_cons (ptr)
     struct Lisp_Cons *ptr;
{
  ptr->u.chain = cons_free_list;
#if GC_MARK_STACK
  ptr->car = Vdead;
#endif

  return val;
}

/* Get an error now if there's any junk in the cons free list.  */
void
check_cons_list ()
{
#ifdef GC_CHECK_CONS_LIST
  struct Lisp_Cons *tail = cons_free_list;

  while (tail)

}

/* Make a list of 1, 2, 3, 4 or 5 specified objects.  */

Lisp_Object
list1 (arg1)
     Lisp_Object arg1;
{
  return Fcons (arg1, Qnil);
}

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

/* Value is a pointer to a newly allocated Lisp_Vector structure
   with room for LEN Lisp_Objects.  */

static struct Lisp_Vector *
allocate_vectorlike (len)
     EMACS_INT len;
{
  struct Lisp_Vector *p;
  size_t nbytes;

  MALLOC_BLOCK_INPUT;

/* Allocate a vector with NSLOTS slots.  */

struct Lisp_Vector *
allocate_vector (nslots)
     EMACS_INT nslots;
{
  struct Lisp_Vector *v = allocate_vectorlike (nslots);
  v->size = nslots;
  return v;
}


/* Allocate other vector-like structures.  */

struct Lisp_Vector *
allocate_pseudovector (memlen, lisplen, tag)
     int memlen, lisplen;
     EMACS_INT tag;
{
  struct Lisp_Vector *v = allocate_vectorlike (memlen);
  EMACS_INT i;

  /* Only the first lisplen slots will be traced normally by the GC.  */

  return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
}


struct window *
allocate_window ()
{
  return ALLOCATE_PSEUDOVECTOR(struct window, current_matrix, PVEC_WINDOW);
}


struct terminal *
allocate_terminal ()
{
  struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal,
					      next_terminal, PVEC_TERMINAL);
  /* Zero out the non-GC'd fields.  FIXME: This should be made unnecessary.  */
  bzero (&(t->next_terminal),

  return t;
}

struct frame *
allocate_frame ()
{
  struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame,
					   face_cache, PVEC_FRAME);
  /* Zero out the non-GC'd fields.  FIXME: This should be made unnecessary.  */
  bzero (&(f->face_cache),

  return f;
}


struct Lisp_Process *
allocate_process ()
{
  return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
}

/* Initialize symbol allocation.  */

static void
init_symbol ()
{
  symbol_block = NULL;
  symbol_block_index = SYMBOL_BLOCK_SIZE;
  symbol_free_list = 0;
  n_symbol_blocks = 0;

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

static int n_marker_blocks;

static void
init_marker ()
{
  marker_block = NULL;
  marker_block_index = MARKER_BLOCK_SIZE;
  marker_free_list = 0;
  n_marker_blocks = 0;
}

/* Return a newly allocated Lisp_Misc object, with no substructure.  */

Lisp_Object
allocate_misc ()
{
  Lisp_Object val;

  /* eassert (!handling_signal); */

}

/* Free a Lisp_Misc object */

void
free_misc (misc)
     Lisp_Object misc;
{
  XMISCTYPE (misc) = Lisp_Misc_Free;
  XMISC (misc)->u_free.chain = marker_free_list;
  marker_free_list = XMISC (misc);

/* Return a Lisp_Misc_Save_Value object containing POINTER and
   INTEGER.  This is used to package C values to call record_unwind_protect.
   The unwind function can get the C values back using XSAVE_VALUE.  */

Lisp_Object
make_save_value (pointer, integer)
     void *pointer;
     int integer;
{
  register Lisp_Object val;
  register struct Lisp_Save_Value *p;

  val = allocate_misc ();

}

/* Put MARKER back on the free list after using it temporarily.  */

void
free_marker (marker)
     Lisp_Object marker;
{
  unchain_marker (XMARKER (marker));
  free_misc (marker);
}

   in a string of events, make a string; otherwise, make a vector.

   Any number of arguments, even zero arguments, are allowed.  */

Lisp_Object
make_event_array (nargs, args)
     register int nargs;
     Lisp_Object *args;
{
  int i;

  for (i = 0; i < nargs; i++)
    /* The things that fit in a string

/* Called if malloc returns zero.  */

void
memory_full ()
{
  int i;

  Vmemory_full = Qt;

   This is called when a relocatable block is freed in ralloc.c,
   and also directly from this file, in case we're not using ralloc.c.  */

void
refill_memory_reserve ()
{
#ifndef SYSTEM_MALLOC
  if (spare_memory[0] == 0)
    spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
  if (spare_memory[1] == 0)

   object or not.  */

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

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

  if (start < min_heap_address || start > max_heap_address)
    return MEM_NIL;

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

  if (min_heap_address == NULL || start < min_heap_address)
    min_heap_address = start;

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

    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;

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

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

/* 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)
	{

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

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

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

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

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

/* 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 (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
}


/* Value is non-zero if 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

/* Mark OBJ if we can prove it's a Lisp_Object.  */

static INLINE void
mark_maybe_object (obj)
     Lisp_Object obj;
{
  void *po = (void *) XPNTR (obj);
  struct mem_node *m = mem_find (po);

  if (m != MEM_NIL)

/* If P points to Lisp data, mark that as live if it isn't already
   marked.  */

static INLINE void
mark_maybe_pointer (p)
     void *p;
{
  struct mem_node *m;

  /* Quickly rule out some values which can't point to Lisp data.  */
  if ((EMACS_INT) p %

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

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

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES

   The current code assumes by default that Lisp_Objects are aligned
   equally on the stack.  */

static void
mark_stack ()
{
  int i;
  /* jmp_buf may not be aligned enough on darwin-ppc64 */
  union aligned_jmpbuf {
    Lisp_Object o;

#endif /* GC_MARK_STACK != 0 */


/* Determine whether it is safe to access memory at address P.  */
static int
valid_pointer_p (p)
     void *p;
{
#ifdef WINDOWSNT
  return w32_valid_pointer_p (p, 16);
#else
  int fd;

   Return -1 if we cannot validate OBJ.
   This function can be quite slow,
   so it should only be used in code for manual debugging.  */

int
valid_lisp_object_p (obj)
     Lisp_Object obj;
{
  void *p;
#if GC_MARK_STACK
  struct mem_node *m;
#endif

/* Allocate room for SIZE bytes from pure Lisp storage and return a
   pointer to it.  TYPE is the Lisp type for which the memory is
   allocated.  TYPE < 0 means it's not used for a Lisp object.  */

static POINTER_TYPE *
pure_alloc (size, type)
     size_t size;
     int type;
{
  POINTER_TYPE *result;
#ifdef USE_LSB_TAG
  size_t alignment = (1 << GCTYPEBITS);
#else

/* Print a warning if PURESIZE is too small.  */

void
check_pure_size ()
{
  if (pure_bytes_used_before_overflow)
    message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
	     (int) (pure_bytes_used + pure_bytes_used_before_overflow));
}

/* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
   the non-Lisp data pool of the pure storage, and return its start
   address.  Return NULL if not found.  */

static char *
find_string_data_in_pure (data, nbytes)
     const char *data;
     int nbytes;
{
  int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
  const unsigned char *p;
  char *non_lisp_beg;

   Must get an error if pure storage is full, since if it cannot hold
   a large string it may be able to hold conses that point to that
   string; then the string is not protected from gc.  */

Lisp_Object
make_pure_string (data, nchars, nbytes, multibyte)
     const char *data;
     int nchars, nbytes;
     int multibyte;
{
  Lisp_Object string;
  struct Lisp_String *s;

  s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_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;
  struct Lisp_Cons *p;

  p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);

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

static Lisp_Object
make_pure_float (num)
     double num;
{
  register Lisp_Object new;
  struct Lisp_Float *p;

  p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);

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

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

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

void
staticpro (varaddress)
     Lisp_Object *varaddress;
{
  staticvec[staticidx++] = varaddress;
  if (staticidx >= NSTATICS)
    abort ();
}

 ***********************************************************************/

/* Temporarily prevent garbage collection.  */

int
inhibit_garbage_collection ()
{
  int count = SPECPDL_INDEX ();
  int nbits = min (VALBITS, BITS_PER_INT);

  specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));

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

static void
mark_glyph_matrix (matrix)
     struct glyph_matrix *matrix;
{
  struct glyph_row *row = matrix->rows;
  struct glyph_row *end = row + matrix->nrows;

  for (; row < end; ++row)

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

static void
mark_face_cache (c)
     struct face_cache *c;
{
  if (c)
    {
      int i, j;
      for (i = 0; i < c->used; ++i)

   the call to abort will hit a breakpoint.
   Normally this is zero and the check never goes off.  */
static int mark_object_loop_halt;

static void
mark_vectorlike (ptr)
     struct Lisp_Vector *ptr;
{
  register EMACS_INT size = ptr->size;
  register int i;

  eassert (!VECTOR_MARKED_P (ptr));

/* Like mark_vectorlike but optimized for char-tables (and
   sub-char-tables) assuming that the contents are mostly integers or
   symbols.  */

static void
mark_char_table (ptr)
     struct Lisp_Vector *ptr;
{
  register EMACS_INT size = ptr->size & PSEUDOVECTOR_SIZE_MASK;
  register int i;

  eassert (!VECTOR_MARKED_P (ptr));

	mark_object (val);
    }
}

void
mark_object (arg)
     Lisp_Object arg;
{
  register Lisp_Object obj = arg;
#ifdef GC_CHECK_MARKED_OBJECTS
  void *po;
  struct mem_node *m;

}

/* Mark the pointers in a buffer structure.  */

static void
mark_buffer (buf)
     Lisp_Object buf;
{
  register struct buffer *buffer = XBUFFER (buf);
  register Lisp_Object *ptr, tmp;
  Lisp_Object base_buffer;

/* Value is non-zero if OBJ will survive the current GC because it's
   either marked or does not need to be marked to survive.  */

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

  switch (XTYPE (obj))
    {

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

static void
gc_sweep ()
{
  /* Remove or mark entries in weak hash tables.
     This must be done before any object is unmarked.  */
  sweep_weak_hash_tables ();

}

int suppress_checking;

void
die (msg, file, line)
     const char *msg;
     const char *file;
     int line;
{
  fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
	   file, line, msg);
  abort ();
}

/* Initialization */

void
init_alloc_once ()
{
  /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
  purebeg = PUREBEG;
  pure_size = PURESIZE;
  pure_bytes_used = 0;

  malloc_sbrk_used = 100000;	/* as reasonable as any number */
#endif /* VIRT_ADDR_VARIES */
}

void
init_alloc ()
{
  gcprolist = 0;
  byte_stack_list = 0;
#if GC_MARK_STACK
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS

  Vgc_elapsed = make_float (0.0);
  gcs_done = 0;
}

void
syms_of_alloc ()
{
  DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
	      doc: /* *Number of bytes of consing between garbage collections.
Garbage collection can happen automatically once this many bytes have been
allocated since the last garbage collection.  All data types count.

109126:aec1143e8d85

  MEM_TYPE_VECTORLIKE
};

static POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
void refill_memory_reserve (void);


#if GC_MARK_STACK || defined GC_MALLOC_CHECK

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES

 ************************************************************************/

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

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


/* Display an already-pending malloc warning.  */

void
display_malloc_warning (void)
{
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));

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

void
buffer_memory_full (void)
{
  /* If buffers use the relocating allocator, no need to free
     spare_memory, because we may have plenty of malloc space left
     that we could get, and if we don't, the malloc that fails will
     itself cause spare_memory to be freed.  If buffers don't use the

#endif

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

POINTER_TYPE *
xmalloc (size_t size)
{
  register POINTER_TYPE *val;

  MALLOC_BLOCK_INPUT;
  val = (POINTER_TYPE *) malloc (size);

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

POINTER_TYPE *
xrealloc (POINTER_TYPE *block, size_t size)
{
  register POINTER_TYPE *val;

  MALLOC_BLOCK_INPUT;
  /* We must call malloc explicitly when BLOCK is 0, since some

/* Like free but block interrupt input.  */

void
xfree (POINTER_TYPE *block)
{
  if (!block)
    return;
  MALLOC_BLOCK_INPUT;
  free (block);

/* Like strdup, but uses xmalloc.  */

char *
xstrdup (const char *s)
{
  size_t len = strlen (s) + 1;
  char *p = (char *) xmalloc (len);
  bcopy (s, p, len);
  return p;

/* Unwind for SAFE_ALLOCA */

Lisp_Object
safe_alloca_unwind (Lisp_Object arg)
{
  register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);

  p->dogc = 0;
  xfree (p->pointer);

#ifndef USE_LSB_TAG
static void *lisp_malloc_loser;
#endif

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

  MALLOC_BLOCK_INPUT;

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

static void
lisp_free (POINTER_TYPE *block)
{
  MALLOC_BLOCK_INPUT;
  free (block);
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
  mem_delete (mem_find (block));

/* Allocate an aligned block of nbytes.
   Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
   smaller or equal to BLOCK_BYTES.  */
static POINTER_TYPE *
lisp_align_malloc (size_t nbytes, enum mem_type type)
{
  void *base, *val;
  struct ablocks *abase;

  eassert (nbytes <= BLOCK_BYTES);

  eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
  return val;
}

static void
lisp_align_free (POINTER_TYPE *block)
{
  struct ablock *ablock = block;
  struct ablocks *abase = ABLOCK_ABASE (ablock);

  MALLOC_BLOCK_INPUT;

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

struct buffer *
allocate_buffer (void)
{
  struct buffer *b
    = (struct buffer *) lisp_malloc (sizeof (struct buffer),
				     MEM_TYPE_BUFFER);
  b->size = sizeof (struct buffer) / sizeof (EMACS_INT);

/* Initialize interval allocation.  */

static void
init_intervals (void)
{
  interval_block = NULL;
  interval_block_index = INTERVAL_BLOCK_SIZE;
  interval_free_list = 0;
  n_interval_blocks = 0;

/* Return a new interval.  */

INTERVAL
make_interval (void)
{
  INTERVAL val;

  /* eassert (!handling_signal); */

/* Mark Lisp objects in interval I. */

static void
mark_interval (register INTERVAL i, Lisp_Object dummy)
{
  eassert (!i->gcmarkbit);		/* Intervals are never shared.  */
  i->gcmarkbit = 1;
  mark_object (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 (register INTERVAL tree)
{
  /* No need to test if this tree has been marked already; this
     function is always called through the MARK_INTERVAL_TREE macro,
     which takes care of that.  */

#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)

/* Initialize string allocation.  Called from init_alloc_once.  */

static void
init_strings (void)
{
  total_strings = total_free_strings = total_string_size = 0;
  oldest_sblock = current_sblock = large_sblocks = NULL;
  string_blocks = NULL;
  n_string_blocks = 0;

#endif

/* Return a new Lisp_String.  */

static struct Lisp_String *
allocate_string (void)
{
  struct Lisp_String *s;

  /* eassert (!handling_signal); */

   set S->data to its `u.data' member.  Store a NUL byte at the end of
   S->data.  Set S->size to NCHARS and S->size_byte to NBYTES.  Free
   S->data if it was initially non-null.  */

void
allocate_string_data (struct Lisp_String *s, int nchars, int nbytes)
{
  struct sdata *data, *old_data;
  struct sblock *b;
  int needed, old_nbytes;

/* Sweep and compact strings.  */

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

  string_free_list = NULL;

/* Free dead large strings.  */

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

  for (b = large_sblocks; b; b = next)

/* Compact data of small strings.  Free sblocks that don't contain
   data of live strings after compaction.  */

static void
compact_small_strings (void)
{
  struct sblock *b, *tb, *next;
  struct sdata *from, *to, *end, *tb_end;
  struct sdata *to_end, *from_end;

/* Make a string from NBYTES bytes at CONTENTS, and compute the number
   of characters from the contents.  This string may be unibyte or
   multibyte, depending on the contents.  */

Lisp_Object
make_string (const char *contents, int nbytes)
{
  register Lisp_Object val;
  int nchars, multibyte_nbytes;

  parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);

/* Make an unibyte string from LENGTH bytes at CONTENTS.  */

Lisp_Object
make_unibyte_string (const char *contents, int length)
{
  register Lisp_Object val;
  val = make_uninit_string (length);
  bcopy (contents, SDATA (val), length);
  STRING_SET_UNIBYTE (val);

/* Make a multibyte string from NCHARS characters occupying NBYTES
   bytes at CONTENTS.  */

Lisp_Object
make_multibyte_string (const char *contents, int nchars, int nbytes)
{
  register Lisp_Object val;
  val = make_uninit_multibyte_string (nchars, nbytes);
  bcopy (contents, SDATA (val), nbytes);
  return val;

/* Make a string from NCHARS characters occupying NBYTES bytes at
   CONTENTS.  It is a multibyte string if NBYTES != NCHARS.  */

Lisp_Object
make_string_from_bytes (const char *contents, int nchars, int nbytes)
{
  register Lisp_Object val;
  val = make_uninit_multibyte_string (nchars, nbytes);
  bcopy (contents, SDATA (val), nbytes);
  if (SBYTES (val) == SCHARS (val))

   CONTENTS.  The argument MULTIBYTE controls whether to label the
   string as multibyte.  If NCHARS is negative, it counts the number of
   characters by itself.  */

Lisp_Object
make_specified_string (const char *contents, int nchars, int nbytes, int multibyte)
{
  register Lisp_Object val;

  if (nchars < 0)
    {

/* Make a string from the data at STR, treating it as multibyte if the
   data warrants.  */

Lisp_Object
build_string (const char *str)
{
  return make_string (str, strlen (str));
}


/* Return an unibyte Lisp_String set up to hold LENGTH characters
   occupying LENGTH bytes.  */

Lisp_Object
make_uninit_string (int length)
{
  Lisp_Object val;

  if (!length)
    return empty_unibyte_string;

/* Return a multibyte Lisp_String set up to hold NCHARS characters
   which occupy NBYTES bytes.  */

Lisp_Object
make_uninit_multibyte_string (int nchars, int nbytes)
{
  Lisp_Object string;
  struct Lisp_String *s;

  if (nchars < 0)

/* Initialize float allocation.  */

static void
init_float (void)
{
  float_block = NULL;
  float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block.   */
  float_free_list = 0;
  n_float_blocks = 0;

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

static void
free_float (struct Lisp_Float *ptr)
{
  ptr->u.chain = float_free_list;
  float_free_list = ptr;
}


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

Lisp_Object
make_float (double float_value)
{
  register Lisp_Object val;

  /* eassert (!handling_signal); */

/* Initialize cons allocation.  */

static void
init_cons (void)
{
  cons_block = NULL;
  cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block.  */
  cons_free_list = 0;
  n_cons_blocks = 0;

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

void
free_cons (struct Lisp_Cons *ptr)
{
  ptr->u.chain = cons_free_list;
#if GC_MARK_STACK
  ptr->car = Vdead;
#endif

  return val;
}

/* Get an error now if there's any junk in the cons free list.  */
void
check_cons_list (void)
{
#ifdef GC_CHECK_CONS_LIST
  struct Lisp_Cons *tail = cons_free_list;

  while (tail)

}

/* Make a list of 1, 2, 3, 4 or 5 specified objects.  */

Lisp_Object
list1 (Lisp_Object arg1)
{
  return Fcons (arg1, Qnil);
}

Lisp_Object
list2 (Lisp_Object arg1, Lisp_Object arg2)
{
  return Fcons (arg1, Fcons (arg2, Qnil));
}


Lisp_Object
list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
{
  return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
}


Lisp_Object
list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4)
{
  return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
}


Lisp_Object
list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
{
  return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
						       Fcons (arg5, Qnil)))));
}

/* Value is a pointer to a newly allocated Lisp_Vector structure
   with room for LEN Lisp_Objects.  */

static struct Lisp_Vector *
allocate_vectorlike (EMACS_INT len)
{
  struct Lisp_Vector *p;
  size_t nbytes;

  MALLOC_BLOCK_INPUT;

/* Allocate a vector with NSLOTS slots.  */

struct Lisp_Vector *
allocate_vector (EMACS_INT nslots)
{
  struct Lisp_Vector *v = allocate_vectorlike (nslots);
  v->size = nslots;
  return v;
}


/* Allocate other vector-like structures.  */

struct Lisp_Vector *
allocate_pseudovector (int memlen, int lisplen, EMACS_INT tag)
{
  struct Lisp_Vector *v = allocate_vectorlike (memlen);
  EMACS_INT i;

  /* Only the first lisplen slots will be traced normally by the GC.  */

  return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
}


struct window *
allocate_window (void)
{
  return ALLOCATE_PSEUDOVECTOR(struct window, current_matrix, PVEC_WINDOW);
}


struct terminal *
allocate_terminal (void)
{
  struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal,
					      next_terminal, PVEC_TERMINAL);
  /* Zero out the non-GC'd fields.  FIXME: This should be made unnecessary.  */
  bzero (&(t->next_terminal),

  return t;
}

struct frame *
allocate_frame (void)
{
  struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame,
					   face_cache, PVEC_FRAME);
  /* Zero out the non-GC'd fields.  FIXME: This should be made unnecessary.  */
  bzero (&(f->face_cache),

  return f;
}


struct Lisp_Process *
allocate_process (void)
{
  return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
}

/* Initialize symbol allocation.  */

static void
init_symbol (void)
{
  symbol_block = NULL;
  symbol_block_index = SYMBOL_BLOCK_SIZE;
  symbol_free_list = 0;
  n_symbol_blocks = 0;

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

static int n_marker_blocks;

static void
init_marker (void)
{
  marker_block = NULL;
  marker_block_index = MARKER_BLOCK_SIZE;
  marker_free_list = 0;
  n_marker_blocks = 0;
}

/* Return a newly allocated Lisp_Misc object, with no substructure.  */

Lisp_Object
allocate_misc (void)
{
  Lisp_Object val;

  /* eassert (!handling_signal); */

}

/* Free a Lisp_Misc object */

void
free_misc (Lisp_Object misc)
{
  XMISCTYPE (misc) = Lisp_Misc_Free;
  XMISC (misc)->u_free.chain = marker_free_list;
  marker_free_list = XMISC (misc);

/* Return a Lisp_Misc_Save_Value object containing POINTER and
   INTEGER.  This is used to package C values to call record_unwind_protect.
   The unwind function can get the C values back using XSAVE_VALUE.  */

Lisp_Object
make_save_value (void *pointer, int integer)
{
  register Lisp_Object val;
  register struct Lisp_Save_Value *p;

  val = allocate_misc ();

}

/* Put MARKER back on the free list after using it temporarily.  */

void
free_marker (Lisp_Object marker)
{
  unchain_marker (XMARKER (marker));
  free_misc (marker);
}

   in a string of events, make a string; otherwise, make a vector.

   Any number of arguments, even zero arguments, are allowed.  */

Lisp_Object
make_event_array (register int nargs, Lisp_Object *args)
{
  int i;

  for (i = 0; i < nargs; i++)
    /* The things that fit in a string

/* Called if malloc returns zero.  */

void
memory_full (void)
{
  int i;

  Vmemory_full = Qt;

   This is called when a relocatable block is freed in ralloc.c,
   and also directly from this file, in case we're not using ralloc.c.  */

void
refill_memory_reserve (void)
{
#ifndef SYSTEM_MALLOC
  if (spare_memory[0] == 0)
    spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
  if (spare_memory[1] == 0)

   object or not.  */

/* Initialize this part of alloc.c.  */

static void
mem_init (void)
{
  mem_z.left = mem_z.right = MEM_NIL;
  mem_z.parent = NULL;
  mem_z.color = MEM_BLACK;
  mem_z.start = mem_z.end = NULL;

/* 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 (void *start)
{
  struct mem_node *p;

  if (start < min_heap_address || start > max_heap_address)
    return MEM_NIL;

/* 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 (void *start, void *end, enum mem_type type)
{
  struct mem_node *c, *parent, *x;

  if (min_heap_address == NULL || start < min_heap_address)
    min_heap_address = start;

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

    a   (y)      ===>    (x)  c
        / \              / \
       b   c            a   b  */

static void
mem_rotate_left (struct mem_node *x)
{
  struct mem_node *y;

  /* Turn y's left sub-tree into x's right sub-tree.  */
  y = x->right;

     (y)  c      ===>    a  (x)
     / \                    / \
    a   b                  b   c  */

static void
mem_rotate_right (struct mem_node *x)
{
  struct mem_node *y = x->left;

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

/* Delete node Z from the tree.  If Z is null or MEM_NIL, do nothing.  */

static void
mem_delete (struct mem_node *z)
{
  struct mem_node *x, *y;

  if (!z || z == MEM_NIL)
    return;

/* Re-establish the red-black properties of the tree, after a
   deletion.  */

static void
mem_delete_fixup (struct mem_node *x)
{
  while (x != mem_root && x->color == MEM_BLACK)
    {
      if (x == x->parent->left)
	{

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

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

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

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

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

/* 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 (struct mem_node *m, void *p)
{
  return (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
}


/* Value is non-zero if P is a pointer to a live buffer.  M is a
   pointer to the mem_block for P.  */

static INLINE int
live_buffer_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

/* Mark OBJ if we can prove it's a Lisp_Object.  */

static INLINE void
mark_maybe_object (Lisp_Object obj)
{
  void *po = (void *) XPNTR (obj);
  struct mem_node *m = mem_find (po);

  if (m != MEM_NIL)

/* If P points to Lisp data, mark that as live if it isn't already
   marked.  */

static INLINE void
mark_maybe_pointer (void *p)
{
  struct mem_node *m;

  /* Quickly rule out some values which can't point to Lisp data.  */
  if ((EMACS_INT) p %

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

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

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES

   The current code assumes by default that Lisp_Objects are aligned
   equally on the stack.  */

static void
mark_stack (void)
{
  int i;
  /* jmp_buf may not be aligned enough on darwin-ppc64 */
  union aligned_jmpbuf {
    Lisp_Object o;

#endif /* GC_MARK_STACK != 0 */


/* Determine whether it is safe to access memory at address P.  */
static int
valid_pointer_p (void *p)
{
#ifdef WINDOWSNT
  return w32_valid_pointer_p (p, 16);
#else
  int fd;

   Return -1 if we cannot validate OBJ.
   This function can be quite slow,
   so it should only be used in code for manual debugging.  */

int
valid_lisp_object_p (Lisp_Object obj)
{
  void *p;
#if GC_MARK_STACK
  struct mem_node *m;
#endif

/* Allocate room for SIZE bytes from pure Lisp storage and return a
   pointer to it.  TYPE is the Lisp type for which the memory is
   allocated.  TYPE < 0 means it's not used for a Lisp object.  */

static POINTER_TYPE *
pure_alloc (size_t size, int type)
{
  POINTER_TYPE *result;
#ifdef USE_LSB_TAG
  size_t alignment = (1 << GCTYPEBITS);
#else

/* Print a warning if PURESIZE is too small.  */

void
check_pure_size (void)
{
  if (pure_bytes_used_before_overflow)
    message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
	     (int) (pure_bytes_used + pure_bytes_used_before_overflow));
}

/* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
   the non-Lisp data pool of the pure storage, and return its start
   address.  Return NULL if not found.  */

static char *
find_string_data_in_pure (const char *data, int nbytes)
{
  int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
  const unsigned char *p;
  char *non_lisp_beg;

   Must get an error if pure storage is full, since if it cannot hold
   a large string it may be able to hold conses that point to that
   string; then the string is not protected from gc.  */

Lisp_Object
make_pure_string (const char *data, int nchars, int nbytes, int multibyte)
{
  Lisp_Object string;
  struct Lisp_String *s;

  s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);

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

Lisp_Object
pure_cons (Lisp_Object car, Lisp_Object cdr)
{
  register Lisp_Object new;
  struct Lisp_Cons *p;

  p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);

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

static Lisp_Object
make_pure_float (double num)
{
  register Lisp_Object new;
  struct Lisp_Float *p;

  p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);

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

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

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

void
staticpro (Lisp_Object *varaddress)
{
  staticvec[staticidx++] = varaddress;
  if (staticidx >= NSTATICS)
    abort ();
}

 ***********************************************************************/

/* Temporarily prevent garbage collection.  */

int
inhibit_garbage_collection (void)
{
  int count = SPECPDL_INDEX ();
  int nbits = min (VALBITS, BITS_PER_INT);

  specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));

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

static void
mark_glyph_matrix (struct glyph_matrix *matrix)
{
  struct glyph_row *row = matrix->rows;
  struct glyph_row *end = row + matrix->nrows;

  for (; row < end; ++row)

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

static void
mark_face_cache (struct face_cache *c)
{
  if (c)
    {
      int i, j;
      for (i = 0; i < c->used; ++i)

   the call to abort will hit a breakpoint.
   Normally this is zero and the check never goes off.  */
static int mark_object_loop_halt;

static void
mark_vectorlike (struct Lisp_Vector *ptr)
{
  register EMACS_INT size = ptr->size;
  register int i;

  eassert (!VECTOR_MARKED_P (ptr));

/* Like mark_vectorlike but optimized for char-tables (and
   sub-char-tables) assuming that the contents are mostly integers or
   symbols.  */

static void
mark_char_table (struct Lisp_Vector *ptr)
{
  register EMACS_INT size = ptr->size & PSEUDOVECTOR_SIZE_MASK;
  register int i;

  eassert (!VECTOR_MARKED_P (ptr));

	mark_object (val);
    }
}

void
mark_object (Lisp_Object arg)
{
  register Lisp_Object obj = arg;
#ifdef GC_CHECK_MARKED_OBJECTS
  void *po;
  struct mem_node *m;

}

/* Mark the pointers in a buffer structure.  */

static void
mark_buffer (Lisp_Object buf)
{
  register struct buffer *buffer = XBUFFER (buf);
  register Lisp_Object *ptr, tmp;
  Lisp_Object base_buffer;

/* Value is non-zero if OBJ will survive the current GC because it's
   either marked or does not need to be marked to survive.  */

int
survives_gc_p (Lisp_Object obj)
{
  int survives_p;

  switch (XTYPE (obj))
    {

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

static void
gc_sweep (void)
{
  /* Remove or mark entries in weak hash tables.
     This must be done before any object is unmarked.  */
  sweep_weak_hash_tables ();

}

int suppress_checking;

void
die (const char *msg, const char *file, int line)
{
  fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
	   file, line, msg);
  abort ();
}

/* Initialization */

void
init_alloc_once (void)
{
  /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
  purebeg = PUREBEG;
  pure_size = PURESIZE;
  pure_bytes_used = 0;

  malloc_sbrk_used = 100000;	/* as reasonable as any number */
#endif /* VIRT_ADDR_VARIES */
}

void
init_alloc (void)
{
  gcprolist = 0;
  byte_stack_list = 0;
#if GC_MARK_STACK
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS

  Vgc_elapsed = make_float (0.0);
  gcs_done = 0;
}

void
syms_of_alloc (void)
{
  DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
	      doc: /* *Number of bytes of consing between garbage collections.
Garbage collection can happen automatically once this many bytes have been
allocated since the last garbage collection.  All data types count.