changeset 300:4ee2046fcb72

Initial revision

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/alloc.c	Wed Jun 26 20:21:21 1991 +0000
@@ -0,0 +1,1913 @@
+/* Storage allocation and gc for GNU Emacs Lisp interpreter.
+   Copyright (C) 1985, 1986, 1988 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+
+#include "config.h"
+#include "lisp.h"
+#ifndef standalone
+#include "buffer.h"
+#include "window.h"
+#ifdef HAVE_X_WINDOWS
+#include "xterm.h"
+#ifdef MULTI_SCREEN
+#include "screen.h"
+#endif	/* MULTI_SCREEN */
+#endif	/* HAVE_X_WINDOWS */
+#endif
+
+#define max(A,B) ((A) > (B) ? (A) : (B))
+
+/* Macro to verify that storage intended for Lisp objects is not
+   out of range to fit in the space for a pointer.
+   ADDRESS is the start of the block, and SIZE
+   is the amount of space within which objects can start.  */
+#define VALIDATE_LISP_STORAGE(address, size)			\
+do								\
+  {								\
+    Lisp_Object val;						\
+    XSET (val, Lisp_Cons, (char *) address + size);		\
+    if ((char *) XCONS (val) != (char *) address + size)	\
+      {								\
+	free (address);						\
+	memory_full ();						\
+      }								\
+  } while (0)
+
+/* Number of bytes of consing done since the last gc */
+int consing_since_gc;
+
+/* Number of bytes of consing since gc before another gc should be done. */
+int gc_cons_threshold;
+
+/* Nonzero during gc */
+int gc_in_progress;
+
+#ifndef VIRT_ADDR_VARIES
+extern
+#endif /* VIRT_ADDR_VARIES */
+ int malloc_sbrk_used;
+
+#ifndef VIRT_ADDR_VARIES
+extern
+#endif /* VIRT_ADDR_VARIES */
+ int malloc_sbrk_unused;
+
+/* Two thresholds controlling how much undo information to keep.  */
+int undo_threshold;
+int undo_high_threshold;
+
+/* Non-nil means defun should do purecopy on the function definition */
+Lisp_Object Vpurify_flag;
+
+#ifndef HAVE_SHM
+int pure[PURESIZE / sizeof (int)] = {0,};   /* Force it into data space! */
+#define PUREBEG (char *) pure
+#else
+#define pure PURE_SEG_BITS   /* Use shared memory segment */
+#define PUREBEG (char *)PURE_SEG_BITS
+#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 displayed.  */
+char *pending_malloc_warning;
+
+/* Maximum amount of C stack to save when a GC happens.  */
+
+#ifndef MAX_SAVE_STACK
+#define MAX_SAVE_STACK 16000
+#endif
+
+/* Buffer in which we save a copy of the C stack at each GC.  */
+
+char *stack_copy;
+int stack_copy_size;
+
+/* Non-zero means ignore malloc warnings.  Set during initialization.  */
+int ignore_warnings;
+
+Lisp_Object
+malloc_warning_1 (str)
+     Lisp_Object str;
+{
+  Fprinc (str, Vstandard_output);
+  write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
+  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 */
+malloc_warning (str)
+     char *str;
+{
+  pending_malloc_warning = str;
+}
+
+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);
+}
+
+/* Called if malloc returns zero */
+memory_full ()
+{
+  error ("Memory exhausted");
+}
+
+/* like malloc and realloc but check for no memory left */
+
+long *
+xmalloc (size)
+     int size;
+{
+  register long *val;
+
+  val = (long *) malloc (size);
+
+  if (!val && size) memory_full ();
+  return val;
+}
+
+long *
+xrealloc (block, size)
+     long *block;
+     int size;
+{
+  register long *val;
+
+  val = (long *) realloc (block, size);
+
+  if (!val && size) memory_full ();
+  return val;
+}
+
+#ifdef LISP_FLOAT_TYPE
+/* Allocation of float cells, just like conses */
+/* We store float cells inside of float_blocks, allocating a new
+   float_block with malloc whenever necessary.  Float cells reclaimed by
+   GC are put on a free list to be reallocated before allocating
+   any new float cells from the latest float_block.
+
+   Each float_block is just under 1020 bytes long,
+   since malloc really allocates in units of powers of two
+   and uses 4 bytes for its own overhead. */
+
+#define FLOAT_BLOCK_SIZE \
+  ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
+
+struct float_block
+  {
+    struct float_block *next;
+    struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
+  };
+
+struct float_block *float_block;
+int float_block_index;
+
+struct Lisp_Float *float_free_list;
+
+void
+init_float ()
+{
+  float_block = (struct float_block *) malloc (sizeof (struct float_block));
+  float_block->next = 0;
+  bzero (float_block->floats, sizeof float_block->floats);
+  float_block_index = 0;
+  float_free_list = 0;
+}
+
+/* Explicitly free a float cell.  */
+free_float (ptr)
+     struct Lisp_Float *ptr;
+{
+  XFASTINT (ptr->type) = (int) float_free_list;
+  float_free_list = ptr;
+}
+
+Lisp_Object
+make_float (float_value)
+     double float_value;
+{
+  register Lisp_Object val;
+
+  if (float_free_list)
+    {
+      XSET (val, Lisp_Float, float_free_list);
+      float_free_list = (struct Lisp_Float *) XFASTINT (float_free_list->type);
+    }
+  else
+    {
+      if (float_block_index == FLOAT_BLOCK_SIZE)
+	{
+	  register struct float_block *new = (struct float_block *) malloc (sizeof (struct float_block));
+	  if (!new) memory_full ();
+	  VALIDATE_LISP_STORAGE (new, sizeof *new);
+	  new->next = float_block;
+	  float_block = new;
+	  float_block_index = 0;
+	}
+      XSET (val, Lisp_Float, &float_block->floats[float_block_index++]);
+    }
+  XFLOAT (val)->data = float_value;
+  XFLOAT (val)->type = 0;	/* bug chasing -wsr */
+  consing_since_gc += sizeof (struct Lisp_Float);
+  return val;
+}
+
+#endif /* LISP_FLOAT_TYPE */
+
+/* Allocation of cons cells */
+/* We store cons cells inside of cons_blocks, allocating a new
+   cons_block with malloc whenever necessary.  Cons cells reclaimed by
+   GC are put on a free list to be reallocated before allocating
+   any new cons cells from the latest cons_block.
+
+   Each cons_block is just under 1020 bytes long,
+   since malloc really allocates in units of powers of two
+   and uses 4 bytes for its own overhead. */
+
+#define CONS_BLOCK_SIZE \
+  ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
+
+struct cons_block
+  {
+    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;
+
+void
+init_cons ()
+{
+  cons_block = (struct cons_block *) malloc (sizeof (struct cons_block));
+  cons_block->next = 0;
+  bzero (cons_block->conses, sizeof cons_block->conses);
+  cons_block_index = 0;
+  cons_free_list = 0;
+}
+
+/* Explicitly free a cons cell.  */
+free_cons (ptr)
+     struct Lisp_Cons *ptr;
+{
+  XFASTINT (ptr->car) = (int) 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;
+{
+  register Lisp_Object val;
+
+  if (cons_free_list)
+    {
+      XSET (val, Lisp_Cons, cons_free_list);
+      cons_free_list = (struct Lisp_Cons *) XFASTINT (cons_free_list->car);
+    }
+  else
+    {
+      if (cons_block_index == CONS_BLOCK_SIZE)
+	{
+	  register struct cons_block *new = (struct cons_block *) malloc (sizeof (struct cons_block));
+	  if (!new) memory_full ();
+	  VALIDATE_LISP_STORAGE (new, sizeof *new);
+	  new->next = cons_block;
+	  cons_block = new;
+	  cons_block_index = 0;
+	}
+      XSET (val, Lisp_Cons, &cons_block->conses[cons_block_index++]);
+    }
+  XCONS (val)->car = car;
+  XCONS (val)->cdr = cdr;
+  consing_since_gc += sizeof (struct Lisp_Cons);
+  return val;
+}
+
+DEFUN ("list", Flist, Slist, 0, MANY, 0,
+  "Return a newly created list with specified arguments as elements.\n\
+Any number of arguments, even zero arguments, are allowed.")
+  (nargs, args)
+     int nargs;
+     register Lisp_Object *args;
+{
+  register Lisp_Object len, val, val_tail;
+
+  XFASTINT (len) = nargs;
+  val = Fmake_list (len, Qnil);
+  val_tail = val;
+  while (!NULL (val_tail))
+    {
+      XCONS (val_tail)->car = *args++;
+      val_tail = XCONS (val_tail)->cdr;
+    }
+  return val;
+}
+
+DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
+  "Return a newly created list of length LENGTH, with each element being INIT.")
+  (length, init)
+     register Lisp_Object length, init;
+{
+  register Lisp_Object val;
+  register int size;
+
+  if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
+    length = wrong_type_argument (Qnatnump, length);
+  size = XINT (length);
+
+  val = Qnil;
+  while (size-- > 0)
+    val = Fcons (init, val);
+  return val;
+}
+
+/* Allocation of vectors */
+
+struct Lisp_Vector *all_vectors;
+
+DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
+  "Return a newly created vector of length LENGTH, with each element being INIT.\n\
+See also the function `vector'.")
+  (length, init)
+     register Lisp_Object length, init;
+{
+  register int sizei, index;
+  register Lisp_Object vector;
+  register struct Lisp_Vector *p;
+
+  if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
+    length = wrong_type_argument (Qnatnump, length);
+  sizei = XINT (length);
+
+  p = (struct Lisp_Vector *) malloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object));
+  if (p == 0)
+    memory_full ();
+  VALIDATE_LISP_STORAGE (p, 0);
+
+  XSET (vector, Lisp_Vector, p);
+  consing_since_gc += sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object);
+
+  p->size = sizei;
+  p->next = all_vectors;
+  all_vectors = p;
+
+  for (index = 0; index < sizei; index++)
+    p->contents[index] = init;
+
+  return vector;
+}
+
+DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
+  "Return a newly created vector with specified arguments as elements.\n\
+Any number of arguments, even zero arguments, are allowed.")
+  (nargs, args)
+     register int nargs;
+     Lisp_Object *args;
+{
+  register Lisp_Object len, val;
+  register int index;
+  register struct Lisp_Vector *p;
+
+  XFASTINT (len) = nargs;
+  val = Fmake_vector (len, Qnil);
+  p = XVECTOR (val);
+  for (index = 0; index < nargs; index++)
+    p->contents[index] = args[index];
+  return val;
+}
+
+DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
+  "Create a byte-code object with specified arguments as elements.\n\
+The arguments should be the arglist, bytecode-string, constant vector,\n\
+stack size, (optional) doc string, and (optional) interactive spec.\n\
+The first four arguments are required; at most six have any\n\
+significance.")
+  (nargs, args)
+     register int nargs;
+     Lisp_Object *args;
+{
+  register Lisp_Object len, val;
+  register int index;
+  register struct Lisp_Vector *p;
+
+  XFASTINT (len) = nargs;
+  if (!NULL (Vpurify_flag))
+    val = make_pure_vector (len);
+  else
+    val = Fmake_vector (len, Qnil);
+  p = XVECTOR (val);
+  for (index = 0; index < nargs; index++)
+    {
+      if (!NULL (Vpurify_flag))
+	args[index] = Fpurecopy (args[index]);
+      p->contents[index] = args[index];
+    }
+  XSETTYPE (val, Lisp_Compiled);
+  return val;
+}
+
+/* Allocation of symbols.
+   Just like allocation of conses!
+
+   Each symbol_block is just under 1020 bytes long,
+   since malloc really allocates in units of powers of two
+   and uses 4 bytes for its own overhead. */
+
+#define SYMBOL_BLOCK_SIZE \
+  ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
+
+struct symbol_block
+  {
+    struct symbol_block *next;
+    struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
+  };
+
+struct symbol_block *symbol_block;
+int symbol_block_index;
+
+struct Lisp_Symbol *symbol_free_list;
+
+void
+init_symbol ()
+{
+  symbol_block = (struct symbol_block *) malloc (sizeof (struct symbol_block));
+  symbol_block->next = 0;
+  bzero (symbol_block->symbols, sizeof symbol_block->symbols);
+  symbol_block_index = 0;
+  symbol_free_list = 0;
+}
+
+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.")
+  (str)
+     Lisp_Object str;
+{
+  register Lisp_Object val;
+  register struct Lisp_Symbol *p;
+
+  CHECK_STRING (str, 0);
+
+  if (symbol_free_list)
+    {
+      XSET (val, Lisp_Symbol, symbol_free_list);
+      symbol_free_list
+	= (struct Lisp_Symbol *) XFASTINT (symbol_free_list->value);
+    }
+  else
+    {
+      if (symbol_block_index == SYMBOL_BLOCK_SIZE)
+	{
+	  struct symbol_block *new = (struct symbol_block *) malloc (sizeof (struct symbol_block));
+	  if (!new) memory_full ();
+	  VALIDATE_LISP_STORAGE (new, sizeof *new);
+	  new->next = symbol_block;
+	  symbol_block = new;
+	  symbol_block_index = 0;
+	}
+      XSET (val, Lisp_Symbol, &symbol_block->symbols[symbol_block_index++]);
+    }
+  p = XSYMBOL (val);
+  p->name = XSTRING (str);
+  p->plist = Qnil;
+  p->value = Qunbound;
+  p->function = Qunbound;
+  p->next = 0;
+  consing_since_gc += sizeof (struct Lisp_Symbol);
+  return val;
+}
+
+/* Allocation of markers.
+   Works like allocation of conses. */
+
+#define MARKER_BLOCK_SIZE \
+  ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
+
+struct marker_block
+  {
+    struct marker_block *next;
+    struct Lisp_Marker markers[MARKER_BLOCK_SIZE];
+  };
+
+struct marker_block *marker_block;
+int marker_block_index;
+
+struct Lisp_Marker *marker_free_list;
+
+void
+init_marker ()
+{
+  marker_block = (struct marker_block *) malloc (sizeof (struct marker_block));
+  marker_block->next = 0;
+  bzero (marker_block->markers, sizeof marker_block->markers);
+  marker_block_index = 0;
+  marker_free_list = 0;
+}
+
+DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
+  "Return a newly allocated marker which does not point at any place.")
+  ()
+{
+  register Lisp_Object val;
+  register struct Lisp_Marker *p;
+  /* Detact the bug that seems to have caused this to be called from
+     a signal handler.  */
+  int mask = sigsetmask (-1);
+  sigsetmask (mask);
+  if (mask != 0)
+    abort ();
+
+  if (marker_free_list)
+    {
+      XSET (val, Lisp_Marker, marker_free_list);
+      marker_free_list
+	= (struct Lisp_Marker *) XFASTINT (marker_free_list->chain);
+    }
+  else
+    {
+      if (marker_block_index == MARKER_BLOCK_SIZE)
+	{
+	  struct marker_block *new = (struct marker_block *) malloc (sizeof (struct marker_block));
+	  if (!new) memory_full ();
+	  VALIDATE_LISP_STORAGE (new, sizeof *new);
+	  new->next = marker_block;
+	  marker_block = new;
+	  marker_block_index = 0;
+	}
+      XSET (val, Lisp_Marker, &marker_block->markers[marker_block_index++]);
+    }
+  p = XMARKER (val);
+  p->buffer = 0;
+  p->bufpos = 0;
+  p->chain = Qnil;
+  consing_since_gc += sizeof (struct Lisp_Marker);
+  return val;
+}
+
+/* Allocation of strings */
+
+/* Strings reside inside of string_blocks.  The entire data of the string,
+ both the size and the contents, live in part of the `chars' component of a string_block.
+ The `pos' component is the index within `chars' of the first free byte.
+
+ first_string_block points to the first string_block ever allocated.
+ Each block points to the next one with its `next' field.
+ The `prev' fields chain in reverse order.
+ The last one allocated is the one currently being filled.
+ current_string_block points to it.
+
+ The string_blocks that hold individual large strings
+ go in a separate chain, started by large_string_blocks.  */
+
+
+/* String blocks contain this many useful bytes.
+   8188 is power of 2, minus 4 for malloc overhead. */
+#define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
+
+/* A string bigger than this gets its own specially-made string block
+ if it doesn't fit in the current one. */
+#define STRING_BLOCK_OUTSIZE 1024
+
+struct string_block_head
+  {
+    struct string_block *next, *prev;
+    int pos;
+  };
+
+struct string_block
+  {
+    struct string_block *next, *prev;
+    int pos;
+    char chars[STRING_BLOCK_SIZE];
+  };
+
+/* This points to the string block we are now allocating strings.  */
+
+struct string_block *current_string_block;
+
+/* This points to the oldest string block, the one that starts the chain.  */
+
+struct string_block *first_string_block;
+
+/* Last string block in chain of those made for individual large strings.  */
+
+struct string_block *large_string_blocks;
+
+/* If SIZE is the length of a string, this returns how many bytes
+   the string occupies in a string_block (including padding).  */
+
+#define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
+			       & ~(PAD - 1))
+#define PAD (sizeof (int))
+
+#if 0
+#define STRING_FULLSIZE(SIZE)   \
+(((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
+#endif
+
+void
+init_strings ()
+{
+  current_string_block = (struct string_block *) malloc (sizeof (struct string_block));
+  first_string_block = current_string_block;
+  consing_since_gc += sizeof (struct string_block);
+  current_string_block->next = 0;
+  current_string_block->prev = 0;
+  current_string_block->pos = 0;
+  large_string_blocks = 0;
+}
+
+DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
+  "Return a newly created string of length LENGTH, with each element being INIT.\n\
+Both LENGTH and INIT must be numbers.")
+  (length, init)
+     Lisp_Object length, init;
+{
+  register Lisp_Object val;
+  register unsigned char *p, *end, c;
+
+  if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
+    length = wrong_type_argument (Qnatnump, length);
+  CHECK_NUMBER (init, 1);
+  val = make_uninit_string (XINT (length));
+  c = XINT (init);
+  p = XSTRING (val)->data;
+  end = p + XSTRING (val)->size;
+  while (p != end)
+    *p++ = c;
+  *p = 0;
+  return val;
+}
+
+Lisp_Object
+make_string (contents, length)
+     char *contents;
+     int length;
+{
+  register Lisp_Object val;
+  val = make_uninit_string (length);
+  bcopy (contents, XSTRING (val)->data, length);
+  return val;
+}
+
+Lisp_Object
+build_string (str)
+     char *str;
+{
+  return make_string (str, strlen (str));
+}
+
+Lisp_Object
+make_uninit_string (length)
+     int length;
+{
+  register Lisp_Object val;
+  register int fullsize = STRING_FULLSIZE (length);
+
+  if (length < 0) abort ();
+
+  if (fullsize <= STRING_BLOCK_SIZE - current_string_block->pos)
+    /* This string can fit in the current string block */
+    {
+      XSET (val, Lisp_String,
+	    (struct Lisp_String *) (current_string_block->chars + current_string_block->pos));
+      current_string_block->pos += fullsize;
+    }
+  else if (fullsize > STRING_BLOCK_OUTSIZE)
+    /* This string gets its own string block */
+    {
+      register struct string_block *new
+	= (struct string_block *) malloc (sizeof (struct string_block_head) + fullsize);
+      VALIDATE_LISP_STORAGE (new, 0);
+      if (!new) memory_full ();
+      consing_since_gc += sizeof (struct string_block_head) + fullsize;
+      new->pos = fullsize;
+      new->next = large_string_blocks;
+      large_string_blocks = new;
+      XSET (val, Lisp_String,
+	    (struct Lisp_String *) ((struct string_block_head *)new + 1));
+    }
+  else
+    /* Make a new current string block and start it off with this string */
+    {
+      register struct string_block *new
+	= (struct string_block *) malloc (sizeof (struct string_block));
+      if (!new) memory_full ();
+      VALIDATE_LISP_STORAGE (new, sizeof *new);
+      consing_since_gc += sizeof (struct string_block);
+      current_string_block->next = new;
+      new->prev = current_string_block;
+      new->next = 0;
+      current_string_block = new;
+      new->pos = fullsize;
+      XSET (val, Lisp_String,
+	    (struct Lisp_String *) current_string_block->chars);
+    }
+    
+  XSTRING (val)->size = length;
+  XSTRING (val)->data[length] = 0;
+
+  return val;
+}
+
+/* Return a newly created vector or string with specified arguments as
+   elements.  If all the arguments are characters, make a string;
+   otherwise, make a vector.  Any number of arguments, even zero
+   arguments, are allowed.  */
+
+Lisp_Object
+make_sequence (nargs, args)
+     register int nargs;
+     Lisp_Object *args;
+{
+  int i;
+
+  for (i = 0; i < nargs; i++)
+    if (XTYPE (args[i]) != Lisp_Int
+	|| (unsigned) XINT (args[i]) >= 0400)
+      return Fvector (nargs, args);
+
+  /* Since the loop exited, we know that all the things in it are
+     characters, so we can make a string.  */
+  {
+    Lisp_Object result = Fmake_string (nargs, make_number (0));
+    
+    for (i = 0; i < nargs; i++)
+      XSTRING (result)->data[i] = XINT (args[i]);
+    
+    return result;
+  }
+}
+
+/* Note: the user cannot manipulate ropes portably by referring
+   to the chars of the string, because combining two chars to make a GLYPH
+   depends on endianness.  */
+
+DEFUN ("make-rope", Fmake_rope, Smake_rope, 0, MANY, 0,
+  "Return a newly created rope containing the arguments of this function.
+A rope is a string, except that its contents will be treated as an\n\
+array of glyphs, where a glyph is an integer type that may be larger\n\
+than a character.  Emacs is normally configured to use 8-bit glyphs,\n\
+so ropes are normally no different from strings.  But Emacs may be\n\
+configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
+\n\
+Each argument (which must be an integer) specifies one glyph, whatever\n\
+size glyphs may be.\n\
+\n\
+See variable `buffer-display-table' for the uses of ropes.")
+  (nargs, args)
+     register int nargs;
+     Lisp_Object *args;
+{
+  register int i;
+  register Lisp_Object val;
+  register GLYPH *p;
+
+  val = make_uninit_string (nargs * sizeof (GLYPH));
+
+  p = (GLYPH *) XSTRING (val)->data;
+  for (i = 0; i < nargs; i++)
+    {
+      CHECK_NUMBER (args[i], i);
+      p[i] = XFASTINT (args[i]);
+    }
+  return val;
+}
+
+DEFUN ("rope-elt", Frope_elt, Srope_elt, 2, 2, 0,
+  "Return an element of rope R at index N.\n\
+A rope is a string in which each pair of bytes is considered an element.\n\
+See variable `buffer-display-table' for the uses of ropes.")
+  (r, n)
+{
+  CHECK_STRING (r, 0);
+  CHECK_NUMBER (n, 1);
+  if ((XSTRING (r)->size / sizeof (GLYPH)) <= XINT (n) || XINT (n) < 0)
+    args_out_of_range (r, n);
+  return ((GLYPH *) XSTRING (r)->data)[XFASTINT (n)];
+}
+
+/* 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, length)
+     char *data;
+     int length;
+{
+  register Lisp_Object new;
+  register int size = sizeof (int) + length + 1;
+
+  if (pureptr + size > PURESIZE)
+    error ("Pure Lisp storage exhausted");
+  XSET (new, Lisp_String, PUREBEG + pureptr);
+  XSTRING (new)->size = length;
+  bcopy (data, XSTRING (new)->data, length);
+  XSTRING (new)->data[length] = 0;
+  pureptr += (size + sizeof (int) - 1)
+	     / sizeof (int) * sizeof (int);
+  return new;
+}
+
+Lisp_Object
+pure_cons (car, cdr)
+     Lisp_Object car, cdr;
+{
+  register Lisp_Object new;
+
+  if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE)
+    error ("Pure Lisp storage exhausted");
+  XSET (new, Lisp_Cons, PUREBEG + pureptr);
+  pureptr += sizeof (struct Lisp_Cons);
+  XCONS (new)->car = Fpurecopy (car);
+  XCONS (new)->cdr = Fpurecopy (cdr);
+  return new;
+}
+
+#ifdef LISP_FLOAT_TYPE
+
+Lisp_Object
+make_pure_float (num)
+     double num;
+{
+  register Lisp_Object new;
+
+  if (pureptr + sizeof (struct Lisp_Float) > PURESIZE)
+    error ("Pure Lisp storage exhausted");
+  XSET (new, Lisp_Float, PUREBEG + pureptr);
+  pureptr += sizeof (struct Lisp_Float);
+  XFLOAT (new)->data = num;
+  XFLOAT (new)->type = 0;	/* bug chasing -wsr */
+  return new;
+}
+
+#endif /* LISP_FLOAT_TYPE */
+
+Lisp_Object
+make_pure_vector (len)
+     int len;
+{
+  register Lisp_Object new;
+  register int size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object);
+
+  if (pureptr + size > PURESIZE)
+    error ("Pure Lisp storage exhausted");
+
+  XSET (new, Lisp_Vector, 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.")
+  (obj)
+     register Lisp_Object obj;
+{
+  register Lisp_Object new, tem;
+  register int i;
+
+  if (NULL (Vpurify_flag))
+    return obj;
+
+  if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
+      && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
+    return obj;
+
+#ifdef SWITCH_ENUM_BUG
+  switch ((int) XTYPE (obj))
+#else
+  switch (XTYPE (obj))
+#endif
+    {
+    case Lisp_Marker:
+      error ("Attempt to copy a marker to pure storage");
+
+    case Lisp_Cons:
+      return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr);
+
+#ifdef LISP_FLOAT_TYPE
+    case Lisp_Float:
+      return make_pure_float (XFLOAT (obj)->data);
+#endif /* LISP_FLOAT_TYPE */
+
+    case Lisp_String:
+      return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size);
+
+    case Lisp_Compiled:
+    case Lisp_Vector:
+      new = make_pure_vector (XVECTOR (obj)->size);
+      for (i = 0; i < XVECTOR (obj)->size; i++)
+	{
+	  tem = XVECTOR (obj)->contents[i];
+	  XVECTOR (new)->contents[i] = Fpurecopy (tem);
+	}
+      XSETTYPE (new, XTYPE (obj));
+      return new;
+
+    default:
+      return obj;
+    }
+}
+
+/* Recording what needs to be marked for gc.  */
+
+struct gcpro *gcprolist;
+
+#define NSTATICS 256
+
+Lisp_Object *staticvec[NSTATICS] = {0};
+
+int staticidx = 0;
+
+/* Put an entry in staticvec, pointing at the variable whose address is given */
+
+void
+staticpro (varaddress)
+     Lisp_Object *varaddress;
+{
+  staticvec[staticidx++] = varaddress;
+  if (staticidx >= NSTATICS)
+    abort ();
+}
+
+struct catchtag
+  {
+    Lisp_Object tag;
+    Lisp_Object val;
+    struct catchtag *next;
+/*    jmp_buf jmp;  /* We don't need this for GC purposes */
+  };
+
+struct backtrace
+  {
+    struct backtrace *next;
+    Lisp_Object *function;
+    Lisp_Object *args;	/* Points to vector of args. */
+    int nargs;		/* length of vector */
+	       /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
+    char evalargs;
+  };
+
+/* Two flags that are set during GC in the `size' component
+   of a string or vector.  On some machines, these flags
+   are defined by the m- file to be different bits.  */
+
+/* On vector, means it has been marked.
+   On string size field or a reference to a string,
+   means not the last reference in the chain.  */
+
+#ifndef ARRAY_MARK_FLAG
+#define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
+#endif /* no ARRAY_MARK_FLAG */
+
+/* Any slot that is a Lisp_Object can point to a string
+   and thus can be put on a string's reference-chain
+   and thus may need to have its ARRAY_MARK_FLAG set.
+   This includes the slots whose markbits are used to mark
+   the containing objects.  */
+
+#if ARRAY_MARK_FLAG == MARKBIT
+you lose
+#endif
+
+int total_conses, total_markers, total_symbols, total_string_size, total_vector_size;
+int total_free_conses, total_free_markers, total_free_symbols;
+#ifdef LISP_FLOAT_TYPE
+int total_free_floats, total_floats;
+#endif /* LISP_FLOAT_TYPE */
+
+static void mark_object (), mark_buffer ();
+static void clear_marks (), gc_sweep ();
+static void compact_strings ();
+
+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\
+  (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
+  (USED-FLOATS . FREE-FLOATS))\n\
+Garbage collection happens automatically if you cons more than\n\
+`gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
+  ()
+{
+  register struct gcpro *tail;
+  register struct specbinding *bind;
+  struct catchtag *catch;
+  struct handler *handler;
+  register struct backtrace *backlist;
+  register Lisp_Object tem;
+  char *omessage = echo_area_glyphs;
+  char stack_top_variable;
+  register int i;
+
+  BLOCK_INPUT;
+
+  /* Save a copy of the contents of the stack, for debugging.  */
+#if MAX_SAVE_STACK > 0
+  if (NULL (Vpurify_flag))
+    {
+      i = &stack_top_variable - stack_bottom;
+      if (i < 0) i = -i;
+      if (i < MAX_SAVE_STACK)
+	{
+	  if (stack_copy == 0)
+	    stack_copy = (char *) malloc (stack_copy_size = i);
+	  else if (stack_copy_size < i)
+	    stack_copy = (char *) realloc (stack_copy, (stack_copy_size = i));
+	  if (stack_copy)
+	    {
+	      if ((int) (&stack_top_variable - stack_bottom) > 0)
+		bcopy (stack_bottom, stack_copy, i);
+	      else
+		bcopy (&stack_top_variable, stack_copy, i);
+	    }
+	}
+    }
+#endif /* MAX_SAVE_STACK > 0 */
+
+  if (!noninteractive)
+    message1 ("Garbage collecting...");
+
+  /* Don't keep command history around forever */
+  tem = Fnthcdr (make_number (30), Vcommand_history);
+  if (CONSP (tem))
+    XCONS (tem)->cdr = Qnil;
+  /* Likewise for undo information.  */
+  {
+    register struct buffer *nextb = all_buffers;
+
+    while (nextb)
+      {
+	nextb->undo_list 
+	  = truncate_undo_list (nextb->undo_list, undo_threshold,
+				undo_high_threshold);
+	nextb = nextb->next;
+      }
+  }
+
+  gc_in_progress = 1;
+
+/*  clear_marks ();  */
+
+  /* In each "large string", set the MARKBIT of the size field.
+     That enables mark_object to recognize them.  */
+  {
+    register struct string_block *b;
+    for (b = large_string_blocks; b; b = b->next)
+      ((struct Lisp_String *)(&b->chars[0]))->size |= MARKBIT;
+  }
+
+  /* Mark all the special slots that serve as the roots of accessibility.
+
+     Usually the special slots to mark are contained in particular structures.
+     Then we know no slot is marked twice because the structures don't overlap.
+     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]);
+	}
+  for (bind = specpdl; bind != specpdl_ptr; bind++)
+    {
+      mark_object (&bind->symbol);
+      mark_object (&bind->old_value);
+    }
+  for (catch = catchlist; catch; catch = catch->next)
+    {
+      mark_object (&catch->tag);
+      mark_object (&catch->val);
+    }  
+  for (handler = handlerlist; handler; handler = handler->next)
+    {
+      mark_object (&handler->handler);
+      mark_object (&handler->var);
+    }  
+  for (backlist = backtrace_list; backlist; backlist = backlist->next)
+    {
+      if (!XMARKBIT (*backlist->function))
+	{
+	  mark_object (backlist->function);
+	  XMARK (*backlist->function);
+	}
+      if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
+	i = 0;
+      else
+	i = backlist->nargs - 1;
+      for (; i >= 0; i--)
+	if (!XMARKBIT (backlist->args[i]))
+	  {
+	    mark_object (&backlist->args[i]);
+	    XMARK (backlist->args[i]);
+	  }
+    }  
+
+  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]);
+  for (backlist = backtrace_list; backlist; backlist = backlist->next)
+    {
+      XUNMARK (*backlist->function);
+      if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
+	i = 0;
+      else
+	i = backlist->nargs - 1;
+      for (; i >= 0; i--)
+	XUNMARK (backlist->args[i]);
+    }  
+  XUNMARK (buffer_defaults.name);
+  XUNMARK (buffer_local_symbols.name);
+
+/*  clear_marks (); */
+  gc_in_progress = 0;
+
+  consing_since_gc = 0;
+  if (gc_cons_threshold < 10000)
+    gc_cons_threshold = 10000;
+
+  if (omessage)
+    message1 (omessage);
+  else if (!noninteractive)
+    message1 ("Garbage collecting...done");
+
+#ifdef HAVE_X_WINDOWS
+  UNBLOCK_INPUT;
+#endif
+
+  return Fcons (Fcons (make_number (total_conses),
+		       make_number (total_free_conses)),
+		Fcons (Fcons (make_number (total_symbols),
+			      make_number (total_free_symbols)),
+		       Fcons (Fcons (make_number (total_markers),
+				     make_number (total_free_markers)),
+			      Fcons (make_number (total_string_size),
+				     Fcons (make_number (total_vector_size),
+
+#ifdef LISP_FLOAT_TYPE
+					    Fcons (Fcons (make_number (total_floats),
+							  make_number (total_free_floats)),
+						   Qnil)
+#else /* not LISP_FLOAT_TYPE */
+					    Qnil
+#endif /* not LISP_FLOAT_TYPE */
+					    )))));
+}
+
+#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++)
+	  XUNMARK (sblk->markers[i].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 reference to a Lisp_Object.  If the object referred to
+   has not been seen yet, recursively mark all the references contained in it.
+
+   If the object referenced is a short string, the referrencing slot
+   is threaded into a chain of such slots, pointed to from
+   the `size' field of the string.  The actual string size
+   lives in the last slot in the chain.  We recognize the end
+   because it is < (unsigned) STRING_BLOCK_SIZE.  */
+
+static void
+mark_object (objptr)
+     Lisp_Object *objptr;
+{
+  register Lisp_Object obj;
+
+  obj = *objptr;
+  XUNMARK (obj);
+
+ loop:
+
+  if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
+      && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
+    return;
+
+#ifdef SWITCH_ENUM_BUG
+  switch ((int) XGCTYPE (obj))
+#else
+  switch (XGCTYPE (obj))
+#endif
+    {
+    case Lisp_String:
+      {
+	register struct Lisp_String *ptr = XSTRING (obj);
+
+	if (ptr->size & MARKBIT)
+	  /* A large string.  Just set ARRAY_MARK_FLAG.  */
+	  ptr->size |= ARRAY_MARK_FLAG;
+	else
+	  {
+	    /* A small string.  Put this reference
+	       into the chain of references to it.
+	       The address OBJPTR is even, so if the address
+	       includes MARKBIT, put it in the low bit
+	       when we store OBJPTR into the size field.  */
+
+	    if (XMARKBIT (*objptr))
+	      {
+		XFASTINT (*objptr) = ptr->size;
+		XMARK (*objptr);
+	      }
+	    else
+	      XFASTINT (*objptr) = ptr->size;
+	    if ((int)objptr & 1) abort ();
+	    ptr->size = (int) objptr & ~MARKBIT;
+	    if ((int) objptr & MARKBIT)
+	      ptr->size ++;
+	  }
+      }
+      break;
+
+    case Lisp_Vector:
+    case Lisp_Window:
+    case Lisp_Process:
+    case Lisp_Window_Configuration:
+    case Lisp_Compiled:
+      {
+	register struct Lisp_Vector *ptr = XVECTOR (obj);
+	register int size = ptr->size;
+	register int i;
+
+	if (size & ARRAY_MARK_FLAG) break;   /* Already marked */
+	ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+	for (i = 0; i < size; i++)     /* and then mark its elements */
+	  mark_object (&ptr->contents[i]);
+      }
+      break;
+
+#ifdef MULTI_SCREEN
+    case Lisp_Screen:
+      {
+	register struct screen *ptr = XSCREEN (obj);
+	register int size = ptr->size;
+	register int i;
+
+	if (size & ARRAY_MARK_FLAG) break;   /* Already marked */
+	ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+
+	mark_object (&ptr->name);
+	mark_object (&ptr->width);
+	mark_object (&ptr->height);
+	mark_object (&ptr->selected_window);
+	mark_object (&ptr->minibuffer_window);
+	mark_object (&ptr->param_alist);
+      }
+      break;
+#endif /* MULTI_SCREEN */
+
+#if 0
+    case Lisp_Temp_Vector:
+      {
+	register struct Lisp_Vector *ptr = XVECTOR (obj);
+	register int size = ptr->size;
+	register int i;
+
+	for (i = 0; i < size; i++)     /* and then mark its elements */
+	  mark_object (&ptr->contents[i]);
+      }
+      break;
+#endif /* 0 */
+
+    case Lisp_Symbol:
+      {
+	register struct Lisp_Symbol *ptr = XSYMBOL (obj);
+	struct Lisp_Symbol *ptrx;
+
+	if (XMARKBIT (ptr->plist)) break;
+	XMARK (ptr->plist);
+	XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
+	mark_object (&ptr->name);
+	mark_object ((Lisp_Object *) &ptr->value);
+	mark_object (&ptr->function);
+	mark_object (&ptr->plist);
+	ptr = ptr->next;
+	if (ptr)
+	  {
+	    ptrx = ptr;		/* Use pf ptrx avoids compiler bug on Sun */
+	    XSETSYMBOL (obj, ptrx);
+	    goto loop;
+	  }
+      }
+      break;
+
+    case Lisp_Marker:
+      XMARK (XMARKER (obj)->chain);
+      /* DO NOT mark thru the marker's chain.
+	 The buffer's markers chain does not preserve markers from gc;
+	 instead, markers are removed from the chain when they are freed by gc. */
+      break;
+
+    case Lisp_Cons:
+    case Lisp_Buffer_Local_Value:
+    case Lisp_Some_Buffer_Local_Value:
+      {
+	register struct Lisp_Cons *ptr = XCONS (obj);
+	if (XMARKBIT (ptr->car)) break;
+	XMARK (ptr->car);
+	mark_object (&ptr->car);
+	objptr = &ptr->cdr;
+	obj = ptr->cdr;
+	goto loop;
+      }
+
+#ifdef LISP_FLOAT_TYPE
+    case Lisp_Float:
+      XMARK (XFLOAT (obj)->type);
+      break;
+#endif /* LISP_FLOAT_TYPE */
+
+    case Lisp_Buffer:
+      if (!XMARKBIT (XBUFFER (obj)->name))
+	mark_buffer (obj);
+      break;
+
+    case Lisp_Int:
+    case Lisp_Void:
+    case Lisp_Subr:
+    case Lisp_Intfwd:
+    case Lisp_Boolfwd:
+    case Lisp_Objfwd:
+    case Lisp_Buffer_Objfwd:
+    case Lisp_Internal_Stream:
+    /* Don't bother with Lisp_Buffer_Objfwd,
+       since all markable slots in current buffer marked anyway.  */
+    /* Don't need to do Lisp_Objfwd, since the places they point
+       are protected with staticpro.  */
+      break;
+
+    default:
+      abort ();
+    }
+}
+
+/* Mark the pointers in a buffer structure.  */
+
+static void
+mark_buffer (buf)
+     Lisp_Object buf;
+{
+  Lisp_Object tem;
+  register struct buffer *buffer = XBUFFER (buf);
+  register Lisp_Object *ptr;
+
+  /* This is the buffer's markbit */
+  mark_object (&buffer->name);
+  XMARK (buffer->name);
+
+#if 0
+  mark_object (buffer->syntax_table);
+
+  /* Mark the various string-pointers in the buffer object.
+     Since the strings may be relocated, we must mark them
+     in their actual slots.  So gc_sweep must convert each slot
+     back to an ordinary C pointer.  */
+  XSET (*(Lisp_Object *)&buffer->upcase_table,
+	Lisp_String, buffer->upcase_table);
+  mark_object ((Lisp_Object *)&buffer->upcase_table);
+  XSET (*(Lisp_Object *)&buffer->downcase_table,
+	Lisp_String, buffer->downcase_table);
+  mark_object ((Lisp_Object *)&buffer->downcase_table);
+
+  XSET (*(Lisp_Object *)&buffer->sort_table,
+	Lisp_String, buffer->sort_table);
+  mark_object ((Lisp_Object *)&buffer->sort_table);
+  XSET (*(Lisp_Object *)&buffer->folding_sort_table,
+	Lisp_String, buffer->folding_sort_table);
+  mark_object ((Lisp_Object *)&buffer->folding_sort_table);
+#endif
+
+  for (ptr = &buffer->name + 1;
+       (char *)ptr < (char *)buffer + sizeof (struct buffer);
+       ptr++)
+    mark_object (ptr);
+}
+
+/* Find all structures not marked, and free them. */
+
+static void
+gc_sweep ()
+{
+  total_string_size = 0;
+  compact_strings ();
+
+  /* Put all unmarked conses on free list */
+  {
+    register struct cons_block *cblk;
+    register int lim = cons_block_index;
+    register int num_free = 0, num_used = 0;
+
+    cons_free_list = 0;
+  
+    for (cblk = cons_block; cblk; cblk = cblk->next)
+      {
+	register int i;
+	for (i = 0; i < lim; i++)
+	  if (!XMARKBIT (cblk->conses[i].car))
+	    {
+	      XFASTINT (cblk->conses[i].car) = (int) cons_free_list;
+	      num_free++;
+	      cons_free_list = &cblk->conses[i];
+	    }
+	  else
+	    {
+	      num_used++;
+	      XUNMARK (cblk->conses[i].car);
+	    }
+	lim = CONS_BLOCK_SIZE;
+      }
+    total_conses = num_used;
+    total_free_conses = num_free;
+  }
+
+#ifdef LISP_FLOAT_TYPE
+  /* Put all unmarked floats on free list */
+  {
+    register struct float_block *fblk;
+    register int lim = float_block_index;
+    register int num_free = 0, num_used = 0;
+
+    float_free_list = 0;
+  
+    for (fblk = float_block; fblk; fblk = fblk->next)
+      {
+	register int i;
+	for (i = 0; i < lim; i++)
+	  if (!XMARKBIT (fblk->floats[i].type))
+	    {
+	      XFASTINT (fblk->floats[i].type) = (int) float_free_list;
+	      num_free++;
+	      float_free_list = &fblk->floats[i];
+	    }
+	  else
+	    {
+	      num_used++;
+	      XUNMARK (fblk->floats[i].type);
+	    }
+	lim = FLOAT_BLOCK_SIZE;
+      }
+    total_floats = num_used;
+    total_free_floats = num_free;
+  }
+#endif /* LISP_FLOAT_TYPE */
+
+  /* Put all unmarked symbols on free list */
+  {
+    register struct symbol_block *sblk;
+    register int lim = symbol_block_index;
+    register int num_free = 0, num_used = 0;
+
+    symbol_free_list = 0;
+  
+    for (sblk = symbol_block; sblk; sblk = sblk->next)
+      {
+	register int i;
+	for (i = 0; i < lim; i++)
+	  if (!XMARKBIT (sblk->symbols[i].plist))
+	    {
+	      XFASTINT (sblk->symbols[i].value) = (int) symbol_free_list;
+	      symbol_free_list = &sblk->symbols[i];
+	      num_free++;
+	    }
+	  else
+	    {
+	      num_used++;
+	      sblk->symbols[i].name
+		= XSTRING (*(Lisp_Object *) &sblk->symbols[i].name);
+	      XUNMARK (sblk->symbols[i].plist);
+	    }
+	lim = SYMBOL_BLOCK_SIZE;
+      }
+    total_symbols = num_used;
+    total_free_symbols = num_free;
+  }
+
+#ifndef standalone
+  /* Put all unmarked markers on free list.
+     Dechain each one first from the buffer it points into. */
+  {
+    register struct marker_block *mblk;
+    struct Lisp_Marker *tem1;
+    register int lim = marker_block_index;
+    register int num_free = 0, num_used = 0;
+
+    marker_free_list = 0;
+  
+    for (mblk = marker_block; mblk; mblk = mblk->next)
+      {
+	register int i;
+	for (i = 0; i < lim; i++)
+	  if (!XMARKBIT (mblk->markers[i].chain))
+	    {
+	      Lisp_Object tem;
+	      tem1 = &mblk->markers[i];  /* tem1 avoids Sun compiler bug */
+	      XSET (tem, Lisp_Marker, tem1);
+	      unchain_marker (tem);
+	      XFASTINT (mblk->markers[i].chain) = (int) marker_free_list;
+	      marker_free_list = &mblk->markers[i];
+	      num_free++;
+	    }
+	  else
+	    {
+	      num_used++;
+	      XUNMARK (mblk->markers[i].chain);
+	    }
+	lim = MARKER_BLOCK_SIZE;
+      }
+
+    total_markers = num_used;
+    total_free_markers = num_free;
+  }
+
+  /* Free all unmarked buffers */
+  {
+    register struct buffer *buffer = all_buffers, *prev = 0, *next;
+
+    while (buffer)
+      if (!XMARKBIT (buffer->name))
+	{
+	  if (prev)
+	    prev->next = buffer->next;
+	  else
+	    all_buffers = buffer->next;
+	  next = buffer->next;
+	  free (buffer);
+	  buffer = next;
+	}
+      else
+	{
+	  XUNMARK (buffer->name);
+
+#if 0
+	  /* Each `struct Lisp_String *' was turned into a Lisp_Object
+	     for purposes of marking and relocation.
+	     Turn them back into C pointers now.  */
+	  buffer->upcase_table
+	    = XSTRING (*(Lisp_Object *)&buffer->upcase_table);
+	  buffer->downcase_table
+	    = XSTRING (*(Lisp_Object *)&buffer->downcase_table);
+	  buffer->sort_table
+	    = XSTRING (*(Lisp_Object *)&buffer->sort_table);
+	  buffer->folding_sort_table
+	    = XSTRING (*(Lisp_Object *)&buffer->folding_sort_table);
+#endif
+
+	  prev = buffer, buffer = buffer->next;
+	}
+  }
+
+#endif /* standalone */
+
+  /* Free all unmarked vectors */
+  {
+    register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
+    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;
+	  free (vector);
+	  vector = next;
+	}
+      else
+	{
+	  vector->size &= ~ARRAY_MARK_FLAG;
+	  total_vector_size += vector->size;
+	  prev = vector, vector = vector->next;
+	}
+  }
+
+  /* Free all "large strings" not marked with ARRAY_MARK_FLAG.  */
+  {
+    register struct string_block *sb = large_string_blocks, *prev = 0, *next;
+
+    while (sb)
+      if (!(((struct Lisp_String *)(&sb->chars[0]))->size & ARRAY_MARK_FLAG))
+	{
+	  if (prev)
+	    prev->next = sb->next;
+	  else
+	    large_string_blocks = sb->next;
+	  next = sb->next;
+	  free (sb);
+	  sb = next;
+	}
+      else
+	{
+	  ((struct Lisp_String *)(&sb->chars[0]))->size
+	    &= ~ARRAY_MARK_FLAG & ~MARKBIT;
+	  total_string_size += ((struct Lisp_String *)(&sb->chars[0]))->size;
+	  prev = sb, sb = sb->next;
+	}
+  }
+}
+
+/* Compactify strings, relocate references to them, and
+   free any string blocks that become empty.  */
+
+static void
+compact_strings ()
+{
+  /* String block of old strings we are scanning.  */
+  register struct string_block *from_sb;
+  /* A preceding string block (or maybe the same one)
+     where we are copying the still-live strings to.  */
+  register struct string_block *to_sb;
+  int pos;
+  int to_pos;
+
+  to_sb = first_string_block;
+  to_pos = 0;
+
+  /* Scan each existing string block sequentially, string by string.  */
+  for (from_sb = first_string_block; from_sb; from_sb = from_sb->next)
+    {
+      pos = 0;
+      /* POS is the index of the next string in the block.  */
+      while (pos < from_sb->pos)
+	{
+	  register struct Lisp_String *nextstr
+	    = (struct Lisp_String *) &from_sb->chars[pos];
+
+	  register struct Lisp_String *newaddr;
+	  register int size = nextstr->size;
+
+	  /* NEXTSTR is the old address of the next string.
+	     Just skip it if it isn't marked.  */
+	  if ((unsigned) size > STRING_BLOCK_SIZE)
+	    {
+	      /* It is marked, so its size field is really a chain of refs.
+		 Find the end of the chain, where the actual size lives.  */
+	      while ((unsigned) size > STRING_BLOCK_SIZE)
+		{
+		  if (size & 1) size ^= MARKBIT | 1;
+		  size = *(int *)size & ~MARKBIT;
+		}
+
+	      total_string_size += size;
+
+	      /* If it won't fit in TO_SB, close it out,
+		 and move to the next sb.  Keep doing so until
+		 TO_SB reaches a large enough, empty enough string block.
+		 We know that TO_SB cannot advance past FROM_SB here
+		 since FROM_SB is large enough to contain this string.
+		 Any string blocks skipped here
+		 will be patched out and freed later.  */
+	      while (to_pos + STRING_FULLSIZE (size)
+		     > max (to_sb->pos, STRING_BLOCK_SIZE))
+		{
+		  to_sb->pos = to_pos;
+		  to_sb = to_sb->next;
+		  to_pos = 0;
+		}
+	      /* Compute new address of this string
+		 and update TO_POS for the space being used.  */
+	      newaddr = (struct Lisp_String *) &to_sb->chars[to_pos];
+	      to_pos += STRING_FULLSIZE (size);
+
+	      /* Copy the string itself to the new place.  */
+	      if (nextstr != newaddr)
+		bcopy (nextstr, newaddr, size + 1 + sizeof (int));
+
+	      /* Go through NEXTSTR's chain of references
+		 and make each slot in the chain point to
+		 the new address of this string.  */
+	      size = newaddr->size;
+	      while ((unsigned) size > STRING_BLOCK_SIZE)
+		{
+		  register Lisp_Object *objptr;
+		  if (size & 1) size ^= MARKBIT | 1;
+		  objptr = (Lisp_Object *)size;
+
+		  size = XFASTINT (*objptr) & ~MARKBIT;
+		  if (XMARKBIT (*objptr))
+		    {
+		      XSET (*objptr, Lisp_String, newaddr);
+		      XMARK (*objptr);
+		    }
+		  else
+		    XSET (*objptr, Lisp_String, newaddr);
+		}
+	      /* Store the actual size in the size field.  */
+	      newaddr->size = size;
+	    }
+	  pos += STRING_FULLSIZE (size);
+	}
+    }
+
+  /* Close out the last string block still used and free any that follow.  */
+  to_sb->pos = to_pos;
+  current_string_block = to_sb;
+
+  from_sb = to_sb->next;
+  to_sb->next = 0;
+  while (from_sb)
+    {
+      to_sb = from_sb->next;
+      free (from_sb);
+      from_sb = to_sb;
+    }
+
+  /* Free any empty string blocks further back in the chain.
+     This loop will never free first_string_block, but it is very
+     unlikely that that one will become empty, so why bother checking?  */
+
+  from_sb = first_string_block;
+  while (to_sb = from_sb->next)
+    {
+      if (to_sb->pos == 0)
+	{
+	  if (from_sb->next = to_sb->next)
+	    from_sb->next->prev = from_sb;
+	  free (to_sb);
+	}
+      else
+	from_sb = to_sb;
+    }
+}
+
+/* Initialization */
+
+init_alloc_once ()
+{
+  /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
+  pureptr = 0;
+  all_vectors = 0;
+  ignore_warnings = 1;
+  init_strings ();
+  init_cons ();
+  init_symbol ();
+  init_marker ();
+#ifdef LISP_FLOAT_TYPE
+  init_float ();
+#endif /* LISP_FLOAT_TYPE */
+  ignore_warnings = 0;
+  gcprolist = 0;
+  staticidx = 0;
+  consing_since_gc = 0;
+  gc_cons_threshold = 100000;
+#ifdef VIRT_ADDR_VARIES
+  malloc_sbrk_unused = 1<<22;	/* A large number */
+  malloc_sbrk_used = 100000;	/* as reasonable as any number */
+#endif /* VIRT_ADDR_VARIES */
+}
+
+init_alloc ()
+{
+  gcprolist = 0;
+}
+
+void
+syms_of_alloc ()
+{
+  DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
+    "*Number of bytes of consing between garbage collections.\n\
+Garbage collection can happen automatically once this many bytes have been\n\
+allocated since the last garbage collection.  All data types count.\n\n\
+Garbage collection happens automatically only when `eval' is called.\n\n\
+By binding this temporarily to a large number, you can effectively\n\
+prevent garbage collection during a part of the program.");
+
+  DEFVAR_INT ("pure-bytes-used", &pureptr,
+    "Number of bytes of sharable Lisp data allocated 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.");
+
+  DEFVAR_INT ("undo-threshold", &undo_threshold,
+    "Keep no more undo information once it exceeds this size.\n\
+This threshold is applied when garbage collection happens.\n\
+The size is counted as the number of bytes occupied,\n\
+which includes both saved text and other data.");
+  undo_threshold = 20000;
+
+  DEFVAR_INT ("undo-high-threshold", &undo_high_threshold,
+    "Don't keep more than this much size of undo information.\n\
+A command which pushes past this size is itself forgotten.\n\
+This threshold is applied when garbage collection happens.\n\
+The size is counted as the number of bytes occupied,\n\
+which includes both saved text and other data.");
+  undo_high_threshold = 30000;
+
+  defsubr (&Scons);
+  defsubr (&Slist);
+  defsubr (&Svector);
+  defsubr (&Smake_byte_code);
+  defsubr (&Smake_list);
+  defsubr (&Smake_vector);
+  defsubr (&Smake_string);
+  defsubr (&Smake_rope);
+  defsubr (&Srope_elt);
+  defsubr (&Smake_symbol);
+  defsubr (&Smake_marker);
+  defsubr (&Spurecopy);
+  defsubr (&Sgarbage_collect);
+}