X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/50aee051c38a6faa6e67f014bbf9499fd2b61448..dd5c96e8a6e2187acc4c7bedf83b6d9bfef8ea63:/src/alloc.c

diff --git a/src/alloc.c b/src/alloc.c
index ed57954cf1..be4ab45168 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1,5 +1,6 @@
 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
-   Copyright (C) 1985, 86, 88, 93, 94, 95, 97 Free Software Foundation, Inc.
+   Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999
+      Free Software Foundation, Inc.
 
 This file is part of GNU Emacs.
 
@@ -18,10 +19,15 @@ along with GNU Emacs; see the file COPYING.  If not, write to
 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 Boston, MA 02111-1307, USA.  */
 
+#include <config.h>
+
 /* Note that this declares bzero on OSF/1.  How dumb.  */
 #include <signal.h>
 
-#include <config.h>
+/* This file is part of the core Lisp implementation, and thus must
+   deal with the real data structures.  If the Lisp implementation is
+   replaced, this file likely will not be used.  */
+#undef HIDE_LISP_IMPLEMENTATION
 #include "lisp.h"
 #include "intervals.h"
 #include "puresize.h"
@@ -31,6 +37,7 @@ Boston, MA 02111-1307, USA.  */
 #include "frame.h"
 #include "blockinput.h"
 #include "keyboard.h"
+#include "charset.h"
 #endif
 
 #include "syssignal.h"
@@ -40,6 +47,12 @@ extern char *sbrk ();
 #ifdef DOUG_LEA_MALLOC
 #include <malloc.h>
 #define __malloc_size_t int
+
+/* Specify maximum number of areas to mmap.
+   It would be nice to use a value that explicitly
+   means "no limit".  */
+#define MMAP_MAX_AREAS 100000000
+
 #else
 /* The following come from gmalloc.c.  */
 
@@ -53,8 +66,6 @@ extern __malloc_size_t _bytes_used;
 extern int __malloc_extra_blocks;
 #endif /* !defined(DOUG_LEA_MALLOC) */
 
-extern Lisp_Object Vhistory_length;
-
 #define max(A,B) ((A) > (B) ? (A) : (B))
 #define min(A,B) ((A) < (B) ? (A) : (B))
 
@@ -112,6 +123,12 @@ extern
 int undo_limit;
 int undo_strong_limit;
 
+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 */
+
 /* Points to memory space allocated as "spare",
    to be freed if we run out of memory.  */
 static char *spare_memory;
@@ -180,9 +197,22 @@ int ignore_warnings;
 
 Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
 
-static void mark_object (), mark_buffer (), mark_kboards ();
-static void clear_marks (), gc_sweep ();
+static void mark_buffer (), mark_kboards ();
+static void gc_sweep ();
 static void compact_strings ();
+static void mark_glyph_matrix P_ ((struct glyph_matrix *));
+static void mark_face_cache P_ ((struct face_cache *));
+#if 0
+static void clear_marks ();
+#endif
+
+#ifdef HAVE_WINDOW_SYSTEM
+static void mark_image P_ ((struct image *));
+static void mark_image_cache P_ ((struct frame *));
+#endif /* HAVE_WINDOW_SYSTEM */
+
+
+extern int message_enable_multibyte;
 
 /* Versions of malloc and realloc that print warnings as memory gets full.  */
 
@@ -198,12 +228,15 @@ malloc_warning_1 (str)
 }
 
 /* malloc calls this if it finds we are near exhausting storage */
+
+void
 malloc_warning (str)
      char *str;
 {
   pending_malloc_warning = str;
 }
 
+void
 display_malloc_warning ()
 {
   register Lisp_Object val;
@@ -221,6 +254,7 @@ display_malloc_warning ()
 
 /* Called if malloc returns zero */
 
+void
 memory_full ()
 {
 #ifndef SYSTEM_MALLOC
@@ -237,7 +271,7 @@ memory_full ()
   /* This used to call error, but if we've run out of memory, we could get
      infinite recursion trying to build the string.  */
   while (1)
-    Fsignal (Qerror, memory_signal_data);
+    Fsignal (Qnil, memory_signal_data);
 }
 
 /* Called if we can't allocate relocatable space for a buffer.  */
@@ -262,7 +296,7 @@ buffer_memory_full ()
     Fsignal (Qerror, memory_signal_data);
 }
 
-/* like malloc routines but check for no memory and block interrupt input.  */
+/* Like malloc routines but check for no memory and block interrupt input.  */
 
 long *
 xmalloc (size)
@@ -307,6 +341,34 @@ xfree (block)
   UNBLOCK_INPUT;
 }
 
+/* Like malloc but used for allocating Lisp data.  */
+
+long *
+lisp_malloc (size)
+     int size;
+{
+  register long *val;
+
+  BLOCK_INPUT;
+  allocating_for_lisp++;
+  val = (long *) malloc (size);
+  allocating_for_lisp--;
+  UNBLOCK_INPUT;
+
+  if (!val && size) memory_full ();
+  return val;
+}
+
+void
+lisp_free (block)
+     long *block;
+{
+  BLOCK_INPUT;
+  allocating_for_lisp++;
+  free (block);
+  allocating_for_lisp--;
+  UNBLOCK_INPUT;
+}
 
 /* Arranging to disable input signals while we're in malloc.
 
@@ -405,13 +467,16 @@ emacs_blocked_realloc (ptr, size)
 void
 uninterrupt_malloc ()
 {
-  old_free_hook = __free_hook;
+  if (__free_hook != emacs_blocked_free)
+    old_free_hook = __free_hook;
   __free_hook = emacs_blocked_free;
 
-  old_malloc_hook = __malloc_hook;
+  if (__malloc_hook != emacs_blocked_malloc)
+    old_malloc_hook = __malloc_hook;
   __malloc_hook = emacs_blocked_malloc;
 
-  old_realloc_hook = __realloc_hook;
+  if (__realloc_hook != emacs_blocked_realloc)
+    old_realloc_hook = __realloc_hook;
   __realloc_hook = emacs_blocked_realloc;
 }
 #endif
@@ -433,17 +498,19 @@ static int interval_block_index;
 
 INTERVAL interval_free_list;
 
+/* Total number of interval blocks now in use.  */
+int n_interval_blocks;
+
 static void
 init_intervals ()
 {
-  allocating_for_lisp = 1;
   interval_block
-    = (struct interval_block *) malloc (sizeof (struct interval_block));
-  allocating_for_lisp = 0;
+    = (struct interval_block *) lisp_malloc (sizeof (struct interval_block));
   interval_block->next = 0;
   bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
   interval_block_index = 0;
   interval_free_list = 0;
+  n_interval_blocks = 1;
 }
 
 #define INIT_INTERVALS init_intervals ()
@@ -464,14 +531,13 @@ make_interval ()
 	{
 	  register struct interval_block *newi;
 
-	  allocating_for_lisp = 1;
-	  newi = (struct interval_block *) xmalloc (sizeof (struct interval_block));
+	  newi = (struct interval_block *) lisp_malloc (sizeof (struct interval_block));
 
-	  allocating_for_lisp = 0;
 	  VALIDATE_LISP_STORAGE (newi, sizeof *newi);
 	  newi->next = interval_block;
 	  interval_block = newi;
 	  interval_block_index = 0;
+	  n_interval_blocks++;
 	}
       val = &interval_block->intervals[interval_block_index++];
     }
@@ -514,7 +580,7 @@ mark_interval_tree (tree)
 #define MARK_INTERVAL_TREE(i)				\
   do {							\
     if (!NULL_INTERVAL_P (i)				\
-	&& ! XMARKBIT ((Lisp_Object) i->parent))	\
+	&& ! XMARKBIT (*(Lisp_Object *) &i->parent))	\
       mark_interval_tree (i);				\
   } while (0)
 
@@ -564,25 +630,28 @@ struct float_block
 struct float_block *float_block;
 int float_block_index;
 
+/* Total number of float blocks now in use.  */
+int n_float_blocks;
+
 struct Lisp_Float *float_free_list;
 
 void
 init_float ()
 {
-  allocating_for_lisp = 1;
-  float_block = (struct float_block *) malloc (sizeof (struct float_block));
-  allocating_for_lisp = 0;
+  float_block = (struct float_block *) lisp_malloc (sizeof (struct float_block));
   float_block->next = 0;
   bzero ((char *) float_block->floats, sizeof float_block->floats);
   float_block_index = 0;
   float_free_list = 0;
+  n_float_blocks = 1;
 }
 
 /* Explicitly free a float cell.  */
+void
 free_float (ptr)
      struct Lisp_Float *ptr;
 {
-  *(struct Lisp_Float **)&ptr->type = float_free_list;
+  *(struct Lisp_Float **)&ptr->data = float_free_list;
   float_free_list = ptr;
 }
 
@@ -594,8 +663,10 @@ make_float (float_value)
 
   if (float_free_list)
     {
+      /* We use the data field for chaining the free list
+	 so that we won't use the same field that has the mark bit.  */
       XSETFLOAT (val, float_free_list);
-      float_free_list = *(struct Lisp_Float **)&float_free_list->type;
+      float_free_list = *(struct Lisp_Float **)&float_free_list->data;
     }
   else
     {
@@ -603,17 +674,16 @@ make_float (float_value)
 	{
 	  register struct float_block *new;
 
-	  allocating_for_lisp = 1;
-	  new = (struct float_block *) xmalloc (sizeof (struct float_block));
-	  allocating_for_lisp = 0;
+	  new = (struct float_block *) lisp_malloc (sizeof (struct float_block));
 	  VALIDATE_LISP_STORAGE (new, sizeof *new);
 	  new->next = float_block;
 	  float_block = new;
 	  float_block_index = 0;
+	  n_float_blocks++;
 	}
       XSETFLOAT (val, &float_block->floats[float_block_index++]);
     }
-  XFLOAT (val)->data = float_value;
+  XFLOAT_DATA (val) = float_value;
   XSETFASTINT (XFLOAT (val)->type, 0);	/* bug chasing -wsr */
   consing_since_gc += sizeof (struct Lisp_Float);
   floats_consed++;
@@ -646,23 +716,27 @@ int cons_block_index;
 
 struct Lisp_Cons *cons_free_list;
 
+/* Total number of cons blocks now in use.  */
+int n_cons_blocks;
+
 void
 init_cons ()
 {
-  allocating_for_lisp = 1;
-  cons_block = (struct cons_block *) malloc (sizeof (struct cons_block));
-  allocating_for_lisp = 0;
+  cons_block = (struct cons_block *) lisp_malloc (sizeof (struct cons_block));
   cons_block->next = 0;
   bzero ((char *) cons_block->conses, sizeof cons_block->conses);
   cons_block_index = 0;
   cons_free_list = 0;
+  n_cons_blocks = 1;
 }
 
 /* Explicitly free a cons cell.  */
+
+void
 free_cons (ptr)
      struct Lisp_Cons *ptr;
 {
-  *(struct Lisp_Cons **)&ptr->car = cons_free_list;
+  *(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
   cons_free_list = ptr;
 }
 
@@ -675,30 +749,62 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
 
   if (cons_free_list)
     {
+      /* We use the cdr for chaining the free list
+	 so that we won't use the same field that has the mark bit.  */
       XSETCONS (val, cons_free_list);
-      cons_free_list = *(struct Lisp_Cons **)&cons_free_list->car;
+      cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr;
     }
   else
     {
       if (cons_block_index == CONS_BLOCK_SIZE)
 	{
 	  register struct cons_block *new;
-	  allocating_for_lisp = 1;
-	  new = (struct cons_block *) xmalloc (sizeof (struct cons_block));
-	  allocating_for_lisp = 0;
+	  new = (struct cons_block *) lisp_malloc (sizeof (struct cons_block));
 	  VALIDATE_LISP_STORAGE (new, sizeof *new);
 	  new->next = cons_block;
 	  cons_block = new;
 	  cons_block_index = 0;
+	  n_cons_blocks++;
 	}
       XSETCONS (val, &cons_block->conses[cons_block_index++]);
     }
-  XCONS (val)->car = car;
-  XCONS (val)->cdr = cdr;
+  XCAR (val) = car;
+  XCDR (val) = cdr;
   consing_since_gc += sizeof (struct Lisp_Cons);
   cons_cells_consed++;
   return val;
 }
+
+/* Make a list of 2, 3, 4 or 5 specified objects.  */
+
+Lisp_Object
+list2 (arg1, arg2)
+     Lisp_Object arg1, arg2;
+{
+  return Fcons (arg1, Fcons (arg2, Qnil));
+}
+
+Lisp_Object
+list3 (arg1, arg2, arg3)
+     Lisp_Object arg1, arg2, arg3;
+{
+  return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
+}
+
+Lisp_Object
+list4 (arg1, arg2, arg3, arg4)
+     Lisp_Object arg1, arg2, arg3, arg4;
+{
+  return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
+}
+
+Lisp_Object
+list5 (arg1, arg2, arg3, arg4, arg5)
+     Lisp_Object arg1, arg2, arg3, arg4, arg5;
+{
+  return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
+						       Fcons (arg5, Qnil)))));
+}
 
 DEFUN ("list", Flist, Slist, 0, MANY, 0,
   "Return a newly created list with specified arguments as elements.\n\
@@ -739,28 +845,30 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
 
 struct Lisp_Vector *all_vectors;
 
+/* Total number of vectorlike objects now in use.  */
+int n_vectors;
+
 struct Lisp_Vector *
 allocate_vectorlike (len)
      EMACS_INT len;
 {
   struct Lisp_Vector *p;
 
-  allocating_for_lisp = 1;
 #ifdef DOUG_LEA_MALLOC
   /* Prevent mmap'ing the chunk (which is potentially very large). */
   mallopt (M_MMAP_MAX, 0);
 #endif
-  p = (struct Lisp_Vector *)xmalloc (sizeof (struct Lisp_Vector)
+  p = (struct Lisp_Vector *)lisp_malloc (sizeof (struct Lisp_Vector)
 				     + (len - 1) * sizeof (Lisp_Object));
 #ifdef DOUG_LEA_MALLOC
   /* Back to a reasonable maximum of mmap'ed areas. */
-  mallopt (M_MMAP_MAX, 64);
+  mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
 #endif
-  allocating_for_lisp = 0;
   VALIDATE_LISP_STORAGE (p, 0);
   consing_since_gc += (sizeof (struct Lisp_Vector)
 		       + (len - 1) * sizeof (Lisp_Object));
   vector_cells_consed += len;
+  n_vectors++;
 
   p->next = all_vectors;
   all_vectors = p;
@@ -901,16 +1009,18 @@ int symbol_block_index;
 
 struct Lisp_Symbol *symbol_free_list;
 
+/* Total number of symbol blocks now in use.  */
+int n_symbol_blocks;
+
 void
 init_symbol ()
 {
-  allocating_for_lisp = 1;
-  symbol_block = (struct symbol_block *) malloc (sizeof (struct symbol_block));
-  allocating_for_lisp = 0;
+  symbol_block = (struct symbol_block *) lisp_malloc (sizeof (struct symbol_block));
   symbol_block->next = 0;
   bzero ((char *) symbol_block->symbols, sizeof symbol_block->symbols);
   symbol_block_index = 0;
   symbol_free_list = 0;
+  n_symbol_blocks = 1;
 }
 
 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
@@ -934,13 +1044,12 @@ Its value and function definition are void, and its property list is nil.")
       if (symbol_block_index == SYMBOL_BLOCK_SIZE)
 	{
 	  struct symbol_block *new;
-	  allocating_for_lisp = 1;
-	  new = (struct symbol_block *) xmalloc (sizeof (struct symbol_block));
-	  allocating_for_lisp = 0;
+	  new = (struct symbol_block *) lisp_malloc (sizeof (struct symbol_block));
 	  VALIDATE_LISP_STORAGE (new, sizeof *new);
 	  new->next = symbol_block;
 	  symbol_block = new;
 	  symbol_block_index = 0;
+	  n_symbol_blocks++;
 	}
       XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
     }
@@ -963,7 +1072,7 @@ Its value and function definition are void, and its property list is nil.")
   ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
 
 struct marker_block
-  {
+{
     struct marker_block *next;
     union Lisp_Misc markers[MARKER_BLOCK_SIZE];
   };
@@ -973,16 +1082,18 @@ int marker_block_index;
 
 union Lisp_Misc *marker_free_list;
 
+/* Total number of marker blocks now in use.  */
+int n_marker_blocks;
+
 void
 init_marker ()
 {
-  allocating_for_lisp = 1;
-  marker_block = (struct marker_block *) malloc (sizeof (struct marker_block));
-  allocating_for_lisp = 0;
+  marker_block = (struct marker_block *) lisp_malloc (sizeof (struct marker_block));
   marker_block->next = 0;
   bzero ((char *) marker_block->markers, sizeof marker_block->markers);
   marker_block_index = 0;
   marker_free_list = 0;
+  n_marker_blocks = 1;
 }
 
 /* Return a newly allocated Lisp_Misc object, with no substructure.  */
@@ -1001,13 +1112,12 @@ allocate_misc ()
       if (marker_block_index == MARKER_BLOCK_SIZE)
 	{
 	  struct marker_block *new;
-	  allocating_for_lisp = 1;
-	  new = (struct marker_block *) xmalloc (sizeof (struct marker_block));
-	  allocating_for_lisp = 0;
+	  new = (struct marker_block *) lisp_malloc (sizeof (struct marker_block));
 	  VALIDATE_LISP_STORAGE (new, sizeof *new);
 	  new->next = marker_block;
 	  marker_block = new;
 	  marker_block_index = 0;
+	  n_marker_blocks++;
 	}
       XSETMISC (val, &marker_block->markers[marker_block_index++]);
     }
@@ -1027,11 +1137,27 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
   XMISCTYPE (val) = Lisp_Misc_Marker;
   p = XMARKER (val);
   p->buffer = 0;
-  p->bufpos = 0;
+  p->bytepos = 0;
+  p->charpos = 0;
   p->chain = Qnil;
   p->insertion_type = 0;
   return val;
 }
+
+/* Put MARKER back on the free list after using it temporarily.  */
+
+void
+free_marker (marker)
+     Lisp_Object marker;
+{
+  unchain_marker (marker);
+
+  XMISC (marker)->u_marker.type = Lisp_Misc_Free;
+  XMISC (marker)->u_free.chain = marker_free_list;
+  marker_free_list = XMISC (marker);
+
+  total_free_markers++;
+}
 
 /* Allocation of strings */
 
@@ -1085,29 +1211,36 @@ 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 (EMACS_INT))
+#define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
+			       & ~(STRING_PAD - 1))
+     /* Add 1 for the null terminator,
+	and add STRING_PAD - 1 as part of rounding up.  */
+
+#define STRING_PAD (sizeof (EMACS_INT))
+/* Size of the stuff in the string not including its data.  */
+#define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
 
 #if 0
 #define STRING_FULLSIZE(SIZE)   \
 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
 #endif
 
+/* Total number of string blocks now in use.  */
+int n_string_blocks;
+
 void
 init_strings ()
 {
-  allocating_for_lisp = 1;
-  current_string_block = (struct string_block *) malloc (sizeof (struct string_block));
-  allocating_for_lisp = 0;
+  current_string_block = (struct string_block *) lisp_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;
+  n_string_blocks = 1;
 }
-
+
 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.")
@@ -1115,16 +1248,37 @@ Both LENGTH and INIT must be numbers.")
      Lisp_Object length, init;
 {
   register Lisp_Object val;
-  register unsigned char *p, *end, c;
+  register unsigned char *p, *end;
+  int c, nbytes;
 
   CHECK_NATNUM (length, 0);
   CHECK_NUMBER (init, 1);
-  val = make_uninit_string (XFASTINT (length));
+
   c = XINT (init);
-  p = XSTRING (val)->data;
-  end = p + XSTRING (val)->size;
-  while (p != end)
-    *p++ = c;
+  if (SINGLE_BYTE_CHAR_P (c))
+    {
+      nbytes = XINT (length);
+      val = make_uninit_string (nbytes);
+      p = XSTRING (val)->data;
+      end = p + XSTRING (val)->size;
+      while (p != end)
+	*p++ = c;
+    }
+  else
+    {
+      unsigned char work[4], *str;
+      int len = CHAR_STRING (c, work, str);
+
+      nbytes = len * XINT (length);
+      val = make_uninit_multibyte_string (XINT (length), nbytes);
+      p = XSTRING (val)->data;
+      end = p + nbytes;
+      while (p != end)
+	{
+	  bcopy (str, p, len);
+	  p += len;
+	}
+    }
   *p = 0;
   return val;
 }
@@ -1145,7 +1299,7 @@ LENGTH must be a number.  INIT matters only in whether it is t or nil.")
   bits_per_value = sizeof (EMACS_INT) * BITS_PER_CHAR;
 
   length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
-  length_in_chars = length_in_elts * sizeof (EMACS_INT);
+  length_in_chars = ((XFASTINT (length) + BITS_PER_CHAR - 1) / BITS_PER_CHAR);
 
   /* We must allocate one more elements than LENGTH_IN_ELTS for the
      slot `size' of the struct Lisp_Bool_Vector.  */
@@ -1159,34 +1313,120 @@ LENGTH must be a number.  INIT matters only in whether it is t or nil.")
   real_init = (NILP (init) ? 0 : -1);
   for (i = 0; i < length_in_chars ; i++)
     p->data[i] = real_init;
+  /* Clear the extraneous bits in the last byte.  */
+  if (XINT (length) != length_in_chars * BITS_PER_CHAR)
+    XBOOL_VECTOR (val)->data[length_in_chars - 1]
+      &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;
 
   return val;
 }
+
+/* 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)
+     char *contents;
+     int nbytes;
+{
+  register Lisp_Object val;
+  int nchars = chars_in_text (contents, nbytes);
+  val = make_uninit_multibyte_string (nchars, nbytes);
+  bcopy (contents, XSTRING (val)->data, nbytes);
+  if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size)
+    SET_STRING_BYTES (XSTRING (val), -1);
+  return val;
+}
+
+/* Make a unibyte string from LENGTH bytes at CONTENTS.  */
 
 Lisp_Object
-make_string (contents, length)
+make_unibyte_string (contents, length)
      char *contents;
      int length;
 {
   register Lisp_Object val;
   val = make_uninit_string (length);
   bcopy (contents, XSTRING (val)->data, length);
+  SET_STRING_BYTES (XSTRING (val), -1);
   return val;
 }
 
+/* Make a multibyte string from NCHARS characters
+   occupying NBYTES bytes at CONTENTS.  */
+
+Lisp_Object
+make_multibyte_string (contents, nchars, nbytes)
+     char *contents;
+     int nchars, nbytes;
+{
+  register Lisp_Object val;
+  val = make_uninit_multibyte_string (nchars, nbytes);
+  bcopy (contents, XSTRING (val)->data, 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)
+     char *contents;
+     int nchars, nbytes;
+{
+  register Lisp_Object val;
+  val = make_uninit_multibyte_string (nchars, nbytes);
+  bcopy (contents, XSTRING (val)->data, nbytes);
+  if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size)
+    SET_STRING_BYTES (XSTRING (val), -1);
+  return val;
+}
+
+/* Make a multibyte string from NCHARS characters
+   occupying NBYTES bytes at CONTENTS.  */
+
+Lisp_Object
+make_specified_string (contents, nchars, nbytes, multibyte)
+     char *contents;
+     int nchars, nbytes;
+     int multibyte;
+{
+  register Lisp_Object val;
+  val = make_uninit_multibyte_string (nchars, nbytes);
+  bcopy (contents, XSTRING (val)->data, nbytes);
+  if (!multibyte)
+    SET_STRING_BYTES (XSTRING (val), -1);
+  return val;
+}
+
+/* Make a string from the data at STR,
+   treating it as multibyte if the data warrants.  */
+
 Lisp_Object
 build_string (str)
      char *str;
 {
   return make_string (str, strlen (str));
 }
-
+
 Lisp_Object
 make_uninit_string (length)
      int length;
+{
+  Lisp_Object val;
+  val = make_uninit_multibyte_string (length, length);
+  SET_STRING_BYTES (XSTRING (val), -1);
+  return val;
+}
+
+Lisp_Object
+make_uninit_multibyte_string (length, length_byte)
+     int length, length_byte;
 {
   register Lisp_Object val;
-  register int fullsize = STRING_FULLSIZE (length);
+  register int fullsize = STRING_FULLSIZE (length_byte);
 
   if (length < 0) abort ();
 
@@ -1202,17 +1442,16 @@ make_uninit_string (length)
     /* This string gets its own string block */
     {
       register struct string_block *new;
-      allocating_for_lisp = 1;
 #ifdef DOUG_LEA_MALLOC
       /* Prevent mmap'ing the chunk (which is potentially very large).  */
       mallopt (M_MMAP_MAX, 0);
 #endif
-      new = (struct string_block *) xmalloc (sizeof (struct string_block_head) + fullsize);
+      new = (struct string_block *) lisp_malloc (sizeof (struct string_block_head) + fullsize);
 #ifdef DOUG_LEA_MALLOC
       /* Back to a reasonable maximum of mmap'ed areas. */
-      mallopt (M_MMAP_MAX, 64);
+      mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
 #endif
-      allocating_for_lisp = 0;
+      n_string_blocks++;
       VALIDATE_LISP_STORAGE (new, 0);
       consing_since_gc += sizeof (struct string_block_head) + fullsize;
       new->pos = fullsize;
@@ -1226,9 +1465,8 @@ make_uninit_string (length)
     /* Make a new current string block and start it off with this string */
     {
       register struct string_block *new;
-      allocating_for_lisp = 1;
-      new = (struct string_block *) xmalloc (sizeof (struct string_block));
-      allocating_for_lisp = 0;
+      new = (struct string_block *) lisp_malloc (sizeof (struct string_block));
+      n_string_blocks++;
       VALIDATE_LISP_STORAGE (new, sizeof *new);
       consing_since_gc += sizeof (struct string_block);
       current_string_block->next = new;
@@ -1242,12 +1480,13 @@ make_uninit_string (length)
     
   string_chars_consed += fullsize;
   XSTRING (val)->size = length;
-  XSTRING (val)->data[length] = 0;
+  SET_STRING_BYTES (XSTRING (val), length_byte);
+  XSTRING (val)->data[length_byte] = 0;
   INITIALIZE_INTERVAL (XSTRING (val), NULL_INTERVAL);
 
   return val;
 }
-
+
 /* Return a newly created vector or string with specified arguments as
    elements.  If all the arguments are characters that can fit
    in a string of events, make a string; otherwise, make a vector.
@@ -1295,27 +1534,30 @@ make_event_array (nargs, args)
  then the string is not protected from gc. */
 
 Lisp_Object
-make_pure_string (data, length)
+make_pure_string (data, length, length_byte, multibyte)
      char *data;
      int length;
+     int length_byte;
+     int multibyte;
 {
+
   register Lisp_Object new;
-  register int size = sizeof (EMACS_INT) + INTERVAL_PTR_SIZE + length + 1;
+  register int size = STRING_FULLSIZE (length_byte);
 
   if (pureptr + size > PURESIZE)
     error ("Pure Lisp storage exhausted");
   XSETSTRING (new, PUREBEG + pureptr);
   XSTRING (new)->size = length;
-  bcopy (data, XSTRING (new)->data, length);
-  XSTRING (new)->data[length] = 0;
+  SET_STRING_BYTES (XSTRING (new), (multibyte ? length_byte : -1));
+  bcopy (data, XSTRING (new)->data, length_byte);
+  XSTRING (new)->data[length_byte] = 0;
 
   /* We must give strings in pure storage some kind of interval.  So we
      give them a null one.  */
 #if defined (USE_TEXT_PROPERTIES)
   XSTRING (new)->intervals = NULL_INTERVAL;
 #endif
-  pureptr += (size + sizeof (EMACS_INT) - 1)
-	     / sizeof (EMACS_INT) * sizeof (EMACS_INT);
+  pureptr += size;
   return new;
 }
 
@@ -1329,8 +1571,8 @@ pure_cons (car, cdr)
     error ("Pure Lisp storage exhausted");
   XSETCONS (new, PUREBEG + pureptr);
   pureptr += sizeof (struct Lisp_Cons);
-  XCONS (new)->car = Fpurecopy (car);
-  XCONS (new)->cdr = Fpurecopy (cdr);
+  XCAR (new) = Fpurecopy (car);
+  XCDR (new) = Fpurecopy (cdr);
   return new;
 }
 
@@ -1367,7 +1609,7 @@ make_pure_float (num)
     error ("Pure Lisp storage exhausted");
   XSETFLOAT (new, PUREBEG + pureptr);
   pureptr += sizeof (struct Lisp_Float);
-  XFLOAT (new)->data = num;
+  XFLOAT_DATA (new) = num;
   XSETFASTINT (XFLOAT (new)->type, 0);	/* bug chasing -wsr */
   return new;
 }
@@ -1405,13 +1647,15 @@ Does not copy symbols.")
     return obj;
 
   if (CONSP (obj))
-    return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr);
+    return pure_cons (XCAR (obj), XCDR (obj));
 #ifdef LISP_FLOAT_TYPE
   else if (FLOATP (obj))
-    return make_pure_float (XFLOAT (obj)->data);
+    return make_pure_float (XFLOAT_DATA (obj));
 #endif /* LISP_FLOAT_TYPE */
   else if (STRINGP (obj))
-    return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size);
+    return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size,
+			     STRING_BYTES (XSTRING (obj)),
+			     STRING_MULTIBYTE (obj));
   else if (COMPILEDP (obj) || VECTORP (obj))
     {
       register struct Lisp_Vector *vec;
@@ -1439,7 +1683,7 @@ Does not copy symbols.")
 
 struct gcpro *gcprolist;
 
-#define NSTATICS 768
+#define NSTATICS 1024
 
 Lisp_Object *staticvec[NSTATICS] = {0};
 
@@ -1461,7 +1705,9 @@ struct catchtag
     Lisp_Object tag;
     Lisp_Object val;
     struct catchtag *next;
-/*    jmp_buf jmp;  /* We don't need this for GC purposes */
+#if 0 /* We don't need this for GC purposes */
+    jmp_buf jmp;
+#endif
   };
 
 struct backtrace
@@ -1476,12 +1722,6 @@ struct backtrace
 
 /* Garbage collection!  */
 
-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 */
-
 /* Temporarily prevent garbage collection.  */
 
 int
@@ -1513,16 +1753,17 @@ Garbage collection happens automatically if you cons more than\n\
   struct catchtag *catch;
   struct handler *handler;
   register struct backtrace *backlist;
-  register Lisp_Object tem;
-  char *omessage = echo_area_glyphs;
-  int omessage_length = echo_area_glyphs_length;
   char stack_top_variable;
   register int i;
+  int message_p;
 
   /* In case user calls debug_print during GC,
      don't let that cause a recursive GC.  */
   consing_since_gc = 0;
 
+  /* Save what's currently displayed in the echo area.  */
+  message_p = push_message ();
+
   /* Save a copy of the contents of the stack, for debugging.  */
 #if MAX_SAVE_STACK > 0
   if (NILP (Vpurify_flag))
@@ -1549,15 +1790,11 @@ Garbage collection happens automatically if you cons more than\n\
   if (garbage_collection_messages)
     message1_nolog ("Garbage collecting...");
 
-  /* Don't keep command history around forever.  */
-  if (NUMBERP (Vhistory_length) && XINT (Vhistory_length) > 0)
-    {
-      tem = Fnthcdr (Vhistory_length, Vcommand_history);
-      if (CONSP (tem))
-	XCONS (tem)->cdr = Qnil;
-    }
+  BLOCK_INPUT;
+
+  shrink_regexp_cache ();
 
-  /* Likewise for undo information.  */
+  /* Don't keep undo information around forever.  */
   {
     register struct buffer *nextb = all_buffers;
 
@@ -1638,6 +1875,46 @@ Garbage collection happens automatically if you cons more than\n\
     }  
   mark_kboards ();
 
+  /* Look thru every buffer's undo list
+     for elements that update markers that were not marked,
+     and delete them.  */
+  {
+    register struct buffer *nextb = all_buffers;
+
+    while (nextb)
+      {
+	/* If a buffer's undo list is Qt, that means that undo is
+	   turned off in that buffer.  Calling truncate_undo_list on
+	   Qt tends to return NULL, which effectively turns undo back on.
+	   So don't call truncate_undo_list if undo_list is Qt.  */
+	if (! EQ (nextb->undo_list, Qt))
+	  {
+	    Lisp_Object tail, prev;
+	    tail = nextb->undo_list;
+	    prev = Qnil;
+	    while (CONSP (tail))
+	      {
+		if (GC_CONSP (XCAR (tail))
+		    && GC_MARKERP (XCAR (XCAR (tail)))
+		    && ! XMARKBIT (XMARKER (XCAR (XCAR (tail)))->chain))
+		  {
+		    if (NILP (prev))
+		      nextb->undo_list = tail = XCDR (tail);
+		    else
+		      tail = XCDR (prev) = XCDR (tail);
+		  }
+		else
+		  {
+		    prev = tail;
+		    tail = XCDR (tail);
+		  }
+	      }
+	  }
+
+	nextb = nextb->next;
+      }
+  }
+
   gc_sweep ();
 
   /* Clear the mark bits that we set in certain root slots.  */
@@ -1658,6 +1935,8 @@ Garbage collection happens automatically if you cons more than\n\
   XUNMARK (buffer_defaults.name);
   XUNMARK (buffer_local_symbols.name);
 
+  UNBLOCK_INPUT;
+
   /* clear_marks (); */
   gc_in_progress = 0;
 
@@ -1667,12 +1946,14 @@ Garbage collection happens automatically if you cons more than\n\
 
   if (garbage_collection_messages)
     {
-      if (omessage || minibuf_level > 0)
-	message2_nolog (omessage, omessage_length);
+      if (message_p || minibuf_level > 0)
+	restore_message ();
       else
 	message1_nolog ("Garbage collecting...done");
     }
 
+  pop_message ();
+  
   return Fcons (Fcons (make_number (total_conses),
 		       make_number (total_free_conses)),
 		Fcons (Fcons (make_number (total_symbols),
@@ -1756,6 +2037,92 @@ clear_marks ()
   }
 }
 #endif
+
+/* 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;
+
+  while (row < end)
+    {
+      if (row->enabled_p)
+	{
+	  int area;
+	  for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
+	    {
+	      struct glyph *glyph = row->glyphs[area];
+	      struct glyph *end_glyph = glyph + row->used[area];
+	      
+	      while (glyph < end_glyph)
+		{
+		  if (GC_STRINGP (glyph->object))
+		    mark_object (&glyph->object);
+		  ++glyph;
+		}
+	    }
+	}
+      
+      ++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)
+	{
+	  struct face *face = FACE_FROM_ID (c->f, i);
+
+	  if (face)
+	    {
+	      for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
+		mark_object (&face->lface[j]);
+	      mark_object (&face->registry);
+	    }
+	}
+    }
+}
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Mark Lisp objects in image IMG.  */
+
+static void
+mark_image (img)
+     struct image *img;
+{
+  mark_object (&img->spec);
+  
+  if (!NILP (img->data.lisp_val))
+    mark_object (&img->data.lisp_val);
+}
+
+
+/* Mark Lisp objects in image cache of frame F.  It's done this way so
+   that we don't have to include xterm.h here.  */
+
+static void
+mark_image_cache (f)
+     struct frame *f;
+{
+  forall_images_in_image_cache (f, mark_image);
+}
+
+#endif /* HAVE_X_WINDOWS */
+
+
 
 /* Mark reference to a Lisp_Object.
   If the object referred to has not been seen yet, recursively mark
@@ -1771,7 +2138,7 @@ clear_marks ()
 Lisp_Object *last_marked[LAST_MARKED_SIZE];
 int last_marked_index;
 
-static void
+void
 mark_object (argptr)
      Lisp_Object *argptr;
 {
@@ -1881,6 +2248,16 @@ mark_object (argptr)
 	  mark_object (&ptr->menu_bar_vector);
 	  mark_object (&ptr->buffer_predicate);
 	  mark_object (&ptr->buffer_list);
+	  mark_object (&ptr->menu_bar_window);
+	  mark_object (&ptr->tool_bar_window);
+	  mark_face_cache (ptr->face_cache);
+#ifdef HAVE_WINDOW_SYSTEM
+	  mark_image_cache (ptr);
+	  mark_object (&ptr->desired_tool_bar_items);
+	  mark_object (&ptr->current_tool_bar_items);
+	  mark_object (&ptr->desired_tool_bar_string);
+	  mark_object (&ptr->current_tool_bar_string);
+#endif /* HAVE_WINDOW_SYSTEM */
 	}
       else if (GC_BOOL_VECTOR_P (obj))
 	{
@@ -1890,6 +2267,76 @@ mark_object (argptr)
 	    break;   /* Already marked */
 	  ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
 	}
+      else if (GC_WINDOWP (obj))
+	{
+	  register struct Lisp_Vector *ptr = XVECTOR (obj);
+	  struct window *w = XWINDOW (obj);
+	  register EMACS_INT size = ptr->size;
+	  /* The reason we use ptr1 is to avoid an apparent hardware bug
+	     that happens occasionally on the FSF's HP 300s.
+	     The bug is that a2 gets clobbered by recursive calls to mark_object.
+	     The clobberage seems to happen during function entry,
+	     perhaps in the moveml instruction.
+	     Yes, this is a crock, but we have to do it.  */
+	  struct Lisp_Vector *volatile ptr1 = ptr;
+	  register int i;
+
+	  /* Stop if already marked.  */
+	  if (size & ARRAY_MARK_FLAG)
+	    break;
+
+	  /* Mark it.  */
+	  ptr->size |= ARRAY_MARK_FLAG;
+
+	  /* There is no Lisp data above The member CURRENT_MATRIX in
+	     struct WINDOW.  Stop marking when that slot is reached.  */
+	  for (i = 0;
+	       (char *) &ptr1->contents[i] < (char *) &w->current_matrix;
+	       i++)
+	    mark_object (&ptr1->contents[i]);
+
+	  /* Mark glyphs for leaf windows.  Marking window matrices is
+	     sufficient because frame matrices use the same glyph
+	     memory.  */
+	  if (NILP (w->hchild)
+	      && NILP (w->vchild)
+	      && w->current_matrix)
+	    {
+	      mark_glyph_matrix (w->current_matrix);
+	      mark_glyph_matrix (w->desired_matrix);
+	    }
+	}
+      else if (GC_HASH_TABLE_P (obj))
+	{
+	  struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
+	  EMACS_INT size = h->size;
+	  
+	  /* Stop if already marked.  */
+	  if (size & ARRAY_MARK_FLAG)
+	    break;
+
+	  /* Mark it.  */
+	  h->size |= ARRAY_MARK_FLAG;
+
+	  /* Mark contents.  */
+	  mark_object (&h->test);
+	  mark_object (&h->weak);
+	  mark_object (&h->rehash_size);
+	  mark_object (&h->rehash_threshold);
+	  mark_object (&h->hash);
+	  mark_object (&h->next);
+	  mark_object (&h->index);
+	  mark_object (&h->user_hash_function);
+	  mark_object (&h->user_cmp_function);
+
+	  /* If hash table is not weak, mark all keys and values.
+	     For weak tables, mark only the vector.  */
+	  if (GC_NILP (h->weak))
+	    mark_object (&h->key_and_value);
+	  else
+	    XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG;
+	    
+	}
       else
 	{
 	  register struct Lisp_Vector *ptr = XVECTOR (obj);
@@ -1907,6 +2354,7 @@ mark_object (argptr)
 	  ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
 	  if (size & PSEUDOVECTOR_FLAG)
 	    size &= PSEUDOVECTOR_SIZE_MASK;
+
 	  for (i = 0; i < size; i++) /* and then mark its elements */
 	    mark_object (&ptr1->contents[i]);
 	}
@@ -1924,7 +2372,10 @@ mark_object (argptr)
 	mark_object (&ptr->function);
 	mark_object (&ptr->plist);
 	XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
-	mark_object (&ptr->name);
+	mark_object ((Lisp_Object *) &ptr->name);
+	/* Note that we do not mark the obarray of the symbol.
+	   It is safe not to do so because nothing accesses that
+	   slot except to check whether it is nil.  */
 	ptr = ptr->next;
 	if (ptr)
 	  {
@@ -1954,15 +2405,17 @@ mark_object (argptr)
 	  {
 	    register struct Lisp_Buffer_Local_Value *ptr
 	      = XBUFFER_LOCAL_VALUE (obj);
-	    if (XMARKBIT (ptr->car)) break;
-	    XMARK (ptr->car);
+	    if (XMARKBIT (ptr->realvalue)) break;
+	    XMARK (ptr->realvalue);
 	    /* If the cdr is nil, avoid recursion for the car.  */
 	    if (EQ (ptr->cdr, Qnil))
 	      {
-		objptr = &ptr->car;
+		objptr = &ptr->realvalue;
 		goto loop;
 	      }
-	    mark_object (&ptr->car);
+	    mark_object (&ptr->realvalue);
+	    mark_object (&ptr->buffer);
+	    mark_object (&ptr->frame);
 	    /* See comment above under Lisp_Vector for why not use ptr here.  */
 	    objptr = &XBUFFER_LOCAL_VALUE (obj)->cdr;
 	    goto loop;
@@ -2011,7 +2464,7 @@ mark_object (argptr)
 	  }
 	mark_object (&ptr->car);
 	/* See comment above under Lisp_Vector for why not use ptr here.  */
-	objptr = &XCONS (obj)->cdr;
+	objptr = &XCDR (obj);
 	goto loop;
       }
 
@@ -2045,6 +2498,39 @@ mark_buffer (buf)
 
   MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
 
+  if (CONSP (buffer->undo_list))
+    {
+      Lisp_Object tail;
+      tail = buffer->undo_list;
+
+      while (CONSP (tail))
+	{
+	  register struct Lisp_Cons *ptr = XCONS (tail);
+
+	  if (XMARKBIT (ptr->car))
+	    break;
+	  XMARK (ptr->car);
+	  if (GC_CONSP (ptr->car)
+	      && ! XMARKBIT (XCAR (ptr->car))
+	      && GC_MARKERP (XCAR (ptr->car)))
+	    {
+	      XMARK (XCAR (ptr->car));
+	      mark_object (&XCDR (ptr->car));
+	    }
+	  else
+	    mark_object (&ptr->car);
+
+	  if (CONSP (ptr->cdr))
+	    tail = ptr->cdr;
+	  else
+	    break;
+	}
+
+      mark_object (&XCDR (tail));
+    }
+  else
+    mark_object (&buffer->undo_list);
+
 #if 0
   mark_object (buffer->syntax_table);
 
@@ -2089,38 +2575,138 @@ mark_kboards ()
       if (kb->kbd_macro_buffer)
 	for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
 	  mark_object (p);
+      mark_object (&kb->Voverriding_terminal_local_map);
+      mark_object (&kb->Vlast_command);
+      mark_object (&kb->Vreal_last_command);
       mark_object (&kb->Vprefix_arg);
+      mark_object (&kb->Vlast_prefix_arg);
       mark_object (&kb->kbd_queue);
+      mark_object (&kb->defining_kbd_macro);
       mark_object (&kb->Vlast_kbd_macro);
       mark_object (&kb->Vsystem_key_alist);
       mark_object (&kb->system_key_syms);
+      mark_object (&kb->Vdefault_minibuffer_frame);
     }
 }
+
+
+/* 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 (XGCTYPE (obj))
+    {
+    case Lisp_Int:
+      survives_p = 1;
+      break;
+
+    case Lisp_Symbol:
+      survives_p = XMARKBIT (XSYMBOL (obj)->plist);
+      break;
+
+    case Lisp_Misc:
+      switch (XMISCTYPE (obj))
+	{
+	case Lisp_Misc_Marker:
+	  survives_p = XMARKBIT (obj);
+	  break;
+	  
+	case Lisp_Misc_Buffer_Local_Value:
+	case Lisp_Misc_Some_Buffer_Local_Value:
+	  survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
+	  break;
+	  
+	case Lisp_Misc_Intfwd:
+	case Lisp_Misc_Boolfwd:
+	case Lisp_Misc_Objfwd:
+	case Lisp_Misc_Buffer_Objfwd:
+	case Lisp_Misc_Kboard_Objfwd:
+	  survives_p = 1;
+	  break;
+	  
+	case Lisp_Misc_Overlay:
+	  survives_p = XMARKBIT (XOVERLAY (obj)->plist);
+	  break;
+
+	default:
+	  abort ();
+	}
+      break;
+
+    case Lisp_String:
+      {
+	struct Lisp_String *s = XSTRING (obj);
+
+	if (s->size & MARKBIT)
+	  survives_p = s->size & ARRAY_MARK_FLAG;
+	else
+	  survives_p = (s->size & ~DONT_COPY_FLAG) > STRING_BLOCK_SIZE;
+      }
+      break;
+
+    case Lisp_Vectorlike:
+      if (GC_BUFFERP (obj))
+	survives_p = XMARKBIT (XBUFFER (obj)->name);
+      else if (GC_SUBRP (obj))
+	survives_p = 1;
+      else
+	survives_p = XVECTOR (obj)->size & ARRAY_MARK_FLAG;
+      break;
+
+    case Lisp_Cons:
+      survives_p = XMARKBIT (XCAR (obj));
+      break;
+
+#ifdef LISP_FLOAT_TYPE
+    case Lisp_Float:
+      survives_p = XMARKBIT (XFLOAT (obj)->type);
+      break;
+#endif /* LISP_FLOAT_TYPE */
+
+    default:
+      abort ();
+    }
+
+  return survives_p;
+}
+
+
 
 /* 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 ();
+
   total_string_size = 0;
   compact_strings ();
 
   /* Put all unmarked conses on free list */
   {
     register struct cons_block *cblk;
+    struct cons_block **cprev = &cons_block;
     register int lim = cons_block_index;
     register int num_free = 0, num_used = 0;
 
     cons_free_list = 0;
   
-    for (cblk = cons_block; cblk; cblk = cblk->next)
+    for (cblk = cons_block; cblk; cblk = *cprev)
       {
 	register int i;
+	int this_free = 0;
 	for (i = 0; i < lim; i++)
 	  if (!XMARKBIT (cblk->conses[i].car))
 	    {
-	      num_free++;
-	      *(struct Lisp_Cons **)&cblk->conses[i].car = cons_free_list;
+	      this_free++;
+	      *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
 	      cons_free_list = &cblk->conses[i];
 	    }
 	  else
@@ -2129,6 +2715,22 @@ gc_sweep ()
 	      XUNMARK (cblk->conses[i].car);
 	    }
 	lim = CONS_BLOCK_SIZE;
+	/* If this block contains only free conses and we have already
+	   seen more than two blocks worth of free conses then deallocate
+	   this block.  */
+	if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
+	  {
+	    *cprev = cblk->next;
+	    /* Unhook from the free list.  */
+	    cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
+	    lisp_free (cblk);
+	    n_cons_blocks--;
+	  }
+	else
+	  {
+	    num_free += this_free;
+	    cprev = &cblk->next;
+	  }
       }
     total_conses = num_used;
     total_free_conses = num_free;
@@ -2138,19 +2740,21 @@ gc_sweep ()
   /* Put all unmarked floats on free list */
   {
     register struct float_block *fblk;
+    struct float_block **fprev = &float_block;
     register int lim = float_block_index;
     register int num_free = 0, num_used = 0;
 
     float_free_list = 0;
   
-    for (fblk = float_block; fblk; fblk = fblk->next)
+    for (fblk = float_block; fblk; fblk = *fprev)
       {
 	register int i;
+	int this_free = 0;
 	for (i = 0; i < lim; i++)
 	  if (!XMARKBIT (fblk->floats[i].type))
 	    {
-	      num_free++;
-	      *(struct Lisp_Float **)&fblk->floats[i].type = float_free_list;
+	      this_free++;
+	      *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
 	      float_free_list = &fblk->floats[i];
 	    }
 	  else
@@ -2159,6 +2763,22 @@ gc_sweep ()
 	      XUNMARK (fblk->floats[i].type);
 	    }
 	lim = FLOAT_BLOCK_SIZE;
+	/* If this block contains only free floats and we have already
+	   seen more than two blocks worth of free floats then deallocate
+	   this block.  */
+	if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
+	  {
+	    *fprev = fblk->next;
+	    /* Unhook from the free list.  */
+	    float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data;
+	    lisp_free (fblk);
+	    n_float_blocks--;
+	  }
+	else
+	  {
+	    num_free += this_free;
+	    fprev = &fblk->next;
+	  }
       }
     total_floats = num_used;
     total_free_floats = num_free;
@@ -2169,14 +2789,16 @@ gc_sweep ()
   /* Put all unmarked intervals on free list */
   {
     register struct interval_block *iblk;
+    struct interval_block **iprev = &interval_block;
     register int lim = interval_block_index;
     register int num_free = 0, num_used = 0;
 
     interval_free_list = 0;
 
-    for (iblk = interval_block; iblk; iblk = iblk->next)
+    for (iblk = interval_block; iblk; iblk = *iprev)
       {
 	register int i;
+	int this_free = 0;
 
 	for (i = 0; i < lim; i++)
 	  {
@@ -2184,7 +2806,7 @@ gc_sweep ()
 	      {
 		iblk->intervals[i].parent = interval_free_list;
 		interval_free_list = &iblk->intervals[i];
-		num_free++;
+		this_free++;
 	      }
 	    else
 	      {
@@ -2193,6 +2815,22 @@ gc_sweep ()
 	      }
 	  }
 	lim = INTERVAL_BLOCK_SIZE;
+	/* If this block contains only free intervals and we have already
+	   seen more than two blocks worth of free intervals then
+	   deallocate this block.  */
+	if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
+	  {
+	    *iprev = iblk->next;
+	    /* Unhook from the free list.  */
+	    interval_free_list = iblk->intervals[0].parent;
+	    lisp_free (iblk);
+	    n_interval_blocks--;
+	  }
+	else
+	  {
+	    num_free += this_free;
+	    iprev = &iblk->next;
+	  }
       }
     total_intervals = num_used;
     total_free_intervals = num_free;
@@ -2202,20 +2840,22 @@ gc_sweep ()
   /* Put all unmarked symbols on free list */
   {
     register struct symbol_block *sblk;
+    struct symbol_block **sprev = &symbol_block;
     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)
+    for (sblk = symbol_block; sblk; sblk = *sprev)
       {
 	register int i;
+	int this_free = 0;
 	for (i = 0; i < lim; i++)
 	  if (!XMARKBIT (sblk->symbols[i].plist))
 	    {
 	      *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list;
 	      symbol_free_list = &sblk->symbols[i];
-	      num_free++;
+	      this_free++;
 	    }
 	  else
 	    {
@@ -2225,25 +2865,42 @@ gc_sweep ()
 	      XUNMARK (sblk->symbols[i].plist);
 	    }
 	lim = SYMBOL_BLOCK_SIZE;
+	/* If this block contains only free symbols and we have already
+	   seen more than two blocks worth of free symbols then deallocate
+	   this block.  */
+	if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
+	  {
+	    *sprev = sblk->next;
+	    /* Unhook from the free list.  */
+	    symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value;
+	    lisp_free (sblk);
+	    n_symbol_blocks--;
+	  }
+	else
+	  {
+	    num_free += this_free;
+	    sprev = &sblk->next;
+	  }
       }
     total_symbols = num_used;
     total_free_symbols = num_free;
   }
 
 #ifndef standalone
-  /* Put all unmarked markers on free list.
-     Unchain each one first from the buffer it points into,
-     but only if it's a real marker.  */
+  /* Put all unmarked misc's on free list.
+     For a marker, first unchain it from the buffer it points into.  */
   {
     register struct marker_block *mblk;
+    struct marker_block **mprev = &marker_block;
     register int lim = marker_block_index;
     register int num_free = 0, num_used = 0;
 
     marker_free_list = 0;
   
-    for (mblk = marker_block; mblk; mblk = mblk->next)
+    for (mblk = marker_block; mblk; mblk = *mprev)
       {
 	register int i;
+	int this_free = 0;
 	EMACS_INT already_free = -1;
 
 	for (i = 0; i < lim; i++)
@@ -2256,7 +2913,7 @@ gc_sweep ()
 		break;
 	      case Lisp_Misc_Buffer_Local_Value:
 	      case Lisp_Misc_Some_Buffer_Local_Value:
-		markword = &mblk->markers[i].u_buffer_local_value.car;
+		markword = &mblk->markers[i].u_buffer_local_value.realvalue;
 		break;
 	      case Lisp_Misc_Overlay:
 		markword = &mblk->markers[i].u_overlay.plist;
@@ -2264,7 +2921,7 @@ gc_sweep ()
 	      case Lisp_Misc_Free:
 		/* If the object was already free, keep it
 		   on the free list.  */
-		markword = &already_free;
+		markword = (Lisp_Object *) &already_free;
 		break;
 	      default:
 		markword = 0;
@@ -2286,7 +2943,7 @@ gc_sweep ()
 		mblk->markers[i].u_marker.type = Lisp_Misc_Free;
 		mblk->markers[i].u_free.chain = marker_free_list;
 		marker_free_list = &mblk->markers[i];
-		num_free++;
+		this_free++;
 	      }
 	    else
 	      {
@@ -2296,6 +2953,22 @@ gc_sweep ()
 	      }
 	  }
 	lim = MARKER_BLOCK_SIZE;
+	/* If this block contains only free markers and we have already
+	   seen more than two blocks worth of free markers then deallocate
+	   this block.  */
+	if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
+	  {
+	    *mprev = mblk->next;
+	    /* Unhook from the free list.  */
+	    marker_free_list = mblk->markers[0].u_free.chain;
+	    lisp_free (mblk);
+	    n_marker_blocks--;
+	  }
+	else
+	  {
+	    num_free += this_free;
+	    mprev = &mblk->next;
+	  }
       }
 
     total_markers = num_used;
@@ -2350,13 +3023,20 @@ gc_sweep ()
     while (vector)
       if (!(vector->size & ARRAY_MARK_FLAG))
 	{
+#if 0
+	  if ((vector->size & (PSEUDOVECTOR_FLAG | PVEC_HASH_TABLE))
+	      == (PSEUDOVECTOR_FLAG | PVEC_HASH_TABLE))
+	    fprintf (stderr, "Freeing hash table %p\n", vector);
+#endif
 	  if (prev)
 	    prev->next = vector->next;
 	  else
 	    all_vectors = vector->next;
 	  next = vector->next;
-	  xfree (vector);
+	  lisp_free (vector);
+	  n_vectors--;
 	  vector = next;
+
 	}
       else
 	{
@@ -2392,8 +3072,9 @@ gc_sweep ()
 	    else
 	      large_string_blocks = sb->next;
 	    next = sb->next;
-	    xfree (sb);
+	    lisp_free (sb);
 	    sb = next;
+	    n_string_blocks--;
 	  }
       }
   }
@@ -2427,6 +3108,7 @@ compact_strings ()
 
 	  register struct Lisp_String *newaddr;
 	  register EMACS_INT size = nextstr->size;
+	  EMACS_INT size_byte = nextstr->size_byte;
 
 	  /* NEXTSTR is the old address of the next string.
 	     Just skip it if it isn't marked.  */
@@ -2441,7 +3123,10 @@ compact_strings ()
 		  size = *(EMACS_INT *)size & ~MARKBIT;
 		}
 
-	      total_string_size += size;
+	      if (size_byte < 0)
+		size_byte = size;
+
+	      total_string_size += size_byte;
 
 	      /* If it won't fit in TO_SB, close it out,
 		 and move to the next sb.  Keep doing so until
@@ -2450,7 +3135,7 @@ compact_strings ()
 		 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)
+	      while (to_pos + STRING_FULLSIZE (size_byte)
 		     > max (to_sb->pos, STRING_BLOCK_SIZE))
 		{
 		  to_sb->pos = to_pos;
@@ -2460,12 +3145,11 @@ compact_strings ()
 	      /* 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);
+	      to_pos += STRING_FULLSIZE (size_byte);
 
 	      /* Copy the string itself to the new place.  */
 	      if (nextstr != newaddr)
-		bcopy (nextstr, newaddr, size + 1 + sizeof (EMACS_INT)
-		       + INTERVAL_PTR_SIZE);
+		bcopy (nextstr, newaddr, STRING_FULLSIZE (size_byte));
 
 	      /* Go through NEXTSTR's chain of references
 		 and make each slot in the chain point to
@@ -2501,7 +3185,10 @@ compact_strings ()
 		}
 #endif /* USE_TEXT_PROPERTIES */
 	    }
-	  pos += STRING_FULLSIZE (size);
+	  else if (size_byte < 0)
+	    size_byte = size;
+
+	  pos += STRING_FULLSIZE (size_byte);
 	}
     }
 
@@ -2514,7 +3201,8 @@ compact_strings ()
   while (from_sb)
     {
       to_sb = from_sb->next;
-      xfree (from_sb);
+      lisp_free (from_sb);
+      n_string_blocks--;
       from_sb = to_sb;
     }
 
@@ -2523,13 +3211,14 @@ compact_strings ()
      unlikely that that one will become empty, so why bother checking?  */
 
   from_sb = first_string_block;
-  while (to_sb = from_sb->next)
+  while ((to_sb = from_sb->next) != 0)
     {
       if (to_sb->pos == 0)
 	{
-	  if (from_sb->next = to_sb->next)
+	  if ((from_sb->next = to_sb->next) != 0)
 	    from_sb->next->prev = from_sb;
-	  xfree (to_sb);
+	  lisp_free (to_sb);
+	  n_string_blocks--;
 	}
       else
 	from_sb = to_sb;
@@ -2601,6 +3290,7 @@ Frames, windows, buffers, and subprocesses count as vectors\n\
 
 /* Initialization */
 
+void
 init_alloc_once ()
 {
   /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
@@ -2613,7 +3303,7 @@ init_alloc_once ()
 #ifdef DOUG_LEA_MALLOC
   mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
   mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
-  mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
+  mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
 #endif
   init_strings ();
   init_cons ();
@@ -2643,6 +3333,7 @@ init_alloc_once ()
 #endif /* VIRT_ADDR_VARIES */
 }
 
+void
 init_alloc ()
 {
   gcprolist = 0;