=== modified file 'src/alloc.c'
--- src/alloc.c	2012-07-18 09:46:07 +0000
+++ src/alloc.c	2012-07-18 15:45:05 +0000
@@ -270,6 +270,7 @@
 static Lisp_Object make_pure_vector (ptrdiff_t);
 static void mark_glyph_matrix (struct glyph_matrix *);
 static void mark_face_cache (struct face_cache *);
+static int compact_buffer (struct buffer *);
 
 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
 static void refill_memory_reserve (void);
@@ -5391,6 +5392,7 @@
   (void)
 {
   register struct specbinding *bind;
+  register struct buffer *nextb;
   char stack_top_variable;
   ptrdiff_t i;
   int message_p;
@@ -5408,42 +5410,10 @@
 
   CHECK_CONS_LIST ();
 
-  /* Don't keep undo information around forever.
-     Do this early on, so it is no problem if the user quits.  */
-  {
-    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 (! NILP (nextb->BUFFER_INTERNAL_FIELD (name))
-	    && ! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
-	  truncate_undo_list (nextb);
-
-	/* Shrink buffer gaps, but skip indirect and dead buffers.  */
-	if (nextb->base_buffer == 0 && !NILP (nextb->BUFFER_INTERNAL_FIELD (name))
-	    && ! nextb->text->inhibit_shrinking)
-	  {
-	    /* If a buffer's gap size is more than 10% of the buffer
-	       size, or larger than 2000 bytes, then shrink it
-	       accordingly.  Keep a minimum size of 20 bytes.  */
-	    int size = min (2000, max (20, (nextb->text->z_byte / 10)));
-
-	    if (nextb->text->gap_size > size)
-	      {
-		struct buffer *save_current = current_buffer;
-		current_buffer = nextb;
-		make_gap (-(nextb->text->gap_size - size));
-		current_buffer = save_current;
-	      }
-	  }
-
-	nextb = nextb->header.next.buffer;
-      }
-  }
+  /* Don't keep undo information around forever. Do this
+     early on, so it is no problem if the user quits.  */
+  for (nextb = all_buffers; nextb; nextb = nextb->header.next.buffer)
+    compact_buffer (nextb);
 
   t1 = current_emacs_time ();
 
@@ -5552,53 +5522,47 @@
   mark_stack ();
 #endif
 
-  /* Everything is now marked, except for the things that require special
-     finalization, i.e. the undo_list.
-     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->BUFFER_INTERNAL_FIELD (undo_list), Qt))
-	  {
-	    Lisp_Object tail, prev;
-	    tail = nextb->BUFFER_INTERNAL_FIELD (undo_list);
-	    prev = Qnil;
-	    while (CONSP (tail))
-	      {
-		if (CONSP (XCAR (tail))
-		    && MARKERP (XCAR (XCAR (tail)))
-		    && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
-		  {
-		    if (NILP (prev))
-		      nextb->BUFFER_INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
-		    else
-		      {
-			tail = XCDR (tail);
-			XSETCDR (prev, tail);
-		      }
-		  }
-		else
-		  {
-		    prev = tail;
-		    tail = XCDR (tail);
-		  }
-	      }
-	  }
-	/* Now that we have stripped the elements that need not be in the
-	   undo_list any more, we can finally mark the list.  */
-	mark_object (nextb->BUFFER_INTERNAL_FIELD (undo_list));
-
-	nextb = nextb->header.next.buffer;
-      }
-  }
+  /* Everything is now marked, except for the things that
+     require special finalization, i.e. the undo_list.
+     Look thru every buffer's undo list for elements that
+     update markers that were not marked, and delete them.  */
+
+  for (nextb = all_buffers; nextb; nextb = nextb->header.next.buffer)
+    {
+      /* 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->BUFFER_INTERNAL_FIELD (undo_list), Qt))
+	{
+	  Lisp_Object tail, prev;
+	  tail = nextb->BUFFER_INTERNAL_FIELD (undo_list);
+	  prev = Qnil;
+	  while (CONSP (tail))
+	    {
+	      if (CONSP (XCAR (tail))
+		  && MARKERP (XCAR (XCAR (tail)))
+		  && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
+		{
+		  if (NILP (prev))
+		    nextb->BUFFER_INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
+		  else
+		    {
+		      tail = XCDR (tail);
+		      XSETCDR (prev, tail);
+		    }
+		}
+	      else
+		{
+		  prev = tail;
+		  tail = XCDR (tail);
+		}
+	    }
+	}
+      /* Now that we have stripped the elements that need not be in the
+	 undo_list any more, we can finally mark the list.  */
+      mark_object (nextb->BUFFER_INTERNAL_FIELD (undo_list));
+    }
 
   gc_sweep ();
 
@@ -5878,6 +5842,46 @@
     mark_buffer (buffer->base_buffer);
 }
 
+/* Truncate undo list and shrink the gap of BUF.  */
+
+static int
+compact_buffer (struct buffer *buf)
+{
+  /* Skip dead buffers, indirect buffers and buffers
+     which aren't changed since last compaction.  */
+  if (!NILP (buf->BUFFER_INTERNAL_FIELD (name))
+      && (buf->base_buffer == NULL)
+      && (buf->text->compact != buf->text->modiff))
+    {
+      /* 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 (buf->BUFFER_INTERNAL_FIELD (undo_list), Qt))
+	truncate_undo_list (buf);
+
+      /* Shrink buffer gaps.  */
+      if (!buf->text->inhibit_shrinking)
+	{
+	  /* If a buffer's gap size is more than 10% of the buffer
+	     size, or larger than 2000 bytes, then shrink it
+	     accordingly.  Keep a minimum size of 20 bytes.  */
+	  int size = min (2000, max (20, (buf->text->z_byte / 10)));
+
+	  if (buf->text->gap_size > size)
+	    {
+	      struct buffer *save_current = current_buffer;
+	      current_buffer = buf;
+	      make_gap (-(buf->text->gap_size - size));
+	      current_buffer = save_current;
+	    }
+	}
+      buf->text->compact = buf->text->modiff;
+      return 1;
+    }
+  return 0;
+}
+
 /* Determine type of generic Lisp_Object and mark it accordingly.  */
 
 void
@@ -6618,7 +6622,18 @@
 #endif
 }
 
-
+DEFUN ("compact-buffer", Fcompact_buffer, Scompact_buffer, 0, 1, 0,
+       doc: /* Compact BUFFER by truncating undo list and shrinking the gap.
+If buffer is nil, compact current buffer.  Compaction is performed
+only if the buffer was changed since last compaction.  Return t if
+buffer compaction was performed, and nil otherwise.  */)
+  (Lisp_Object buffer)
+{
+  if (NILP (buffer))
+    XSETBUFFER (buffer, current_buffer);
+  CHECK_BUFFER (buffer);
+  return compact_buffer (XBUFFER (buffer)) ? Qt : Qnil;
+}
 
 
 /* Debugging aids.  */
@@ -6897,6 +6912,7 @@
   defsubr (&Smake_symbol);
   defsubr (&Smake_marker);
   defsubr (&Spurecopy);
+  defsubr (&Scompact_buffer);
   defsubr (&Sgarbage_collect);
   defsubr (&Smemory_limit);
   defsubr (&Smemory_free);

=== modified file 'src/buffer.h'
--- src/buffer.h	2012-07-17 04:29:50 +0000
+++ src/buffer.h	2012-07-18 14:45:38 +0000
@@ -436,6 +436,9 @@
 
     EMACS_INT overlay_modiff;	/* Counts modifications to overlays.  */
 
+    EMACS_INT compact;		 /* Set to modiff each time when
+				    compact_buffer adjusts us.  */
+
     /* Minimum value of GPT - BEG since last redisplay that finished.  */
     ptrdiff_t beg_unchanged;