view src/alloc.c @ 7253:6ba87aed7836

*** empty log message ***

+
鐃緒申/* Storage allocation and gc for GNU Emacs Lisp interpreter.
+
鐃緒申   Copyright (C) 1985, 1986, 1988, 1993 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 2, 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 <signal.h>
+
鐃緒申
+
鐃緒申#include <config.h>
+
鐃緒申#include "lisp.h"
+
鐃緒申#include "intervals.h"
+
鐃緒申#include "puresize.h"
+
鐃緒申#ifndef standalone
+
鐃緒申#include "buffer.h"
+
鐃緒申#include "window.h"
+
鐃緒申#include "frame.h"
+
鐃緒申#include "blockinput.h"
+
鐃緒申#endif
+
鐃緒申
+
鐃緒申#include "syssignal.h"
+
鐃緒申
+
鐃緒申#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)	\
+
鐃緒申      {								\
+
鐃緒申	xfree (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 limits controlling how much undo information to keep.  */
+
鐃緒申int undo_limit;
+
鐃緒申int undo_strong_limit;
+
鐃緒申
+
鐃緒申/* 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
+
鐃緒申
+
鐃緒申/* This variable is used only by the XPNTR macro when HAVE_SHM is
+
鐃緒申   defined.  If we used the PURESIZE macro directly there, that would
+
鐃緒申   make most of emacs dependent on puresize.h, which we don't want -
+
鐃緒申   you should be able to change that without too much recompilation.
+
鐃緒申   So map_in_data initializes pure_size, and the dependencies work
+
鐃緒申   out.  */
+
鐃緒申int pure_size;
+
鐃緒申#endif /* not HAVE_SHM */
+
鐃緒申
+
鐃緒申/* Index in pure at which next pure object will be allocated. */
+
鐃緒申int pureptr;
+
鐃緒申
+
鐃緒申/* If nonzero, this is a warning delivered by malloc and not yet displayed.  */
+
鐃緒申char *pending_malloc_warning;
+
鐃緒申
+
鐃緒申/* Pre-computed signal argument for use when memory is exhausted.  */
+
鐃緒申Lisp_Object memory_signal_data;
+
鐃緒申
+
鐃緒申/* 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;
+
鐃緒申
+
鐃緒申static void mark_object (), mark_buffer ();
+
鐃緒申static void clear_marks (), gc_sweep ();
+
鐃緒申static void compact_strings ();
+
鐃緒申
+
鐃緒申/* Versions of malloc and realloc that print warnings as memory gets full.  */
+
鐃緒申
+
鐃緒申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 ()
+
鐃緒申{
+
鐃緒申  /* 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);
+
鐃緒申}
+
鐃緒申
+
鐃緒申/* like malloc routines but check for no memory and block interrupt input.  */
+
鐃緒申
+
鐃緒申long *
+
鐃緒申xmalloc (size)
+
鐃緒申     int size;
+
鐃緒申{
+
鐃緒申  register long *val;
+
鐃緒申
+
鐃緒申  BLOCK_INPUT;
+
鐃緒申  val = (long *) malloc (size);
+
鐃緒申  UNBLOCK_INPUT;
+
鐃緒申
+
鐃緒申  if (!val && size) memory_full ();
+
鐃緒申  return val;
+
鐃緒申}
+
鐃緒申
+
鐃緒申long *
+
鐃緒申xrealloc (block, size)
+
鐃緒申     long *block;
+
鐃緒申     int size;
+
鐃緒申{
+
鐃緒申  register long *val;
+
鐃緒申
+
鐃緒申  BLOCK_INPUT;
+
鐃緒申  /* We must call malloc explicitly when BLOCK is 0, since some
+
鐃緒申     reallocs don't do this.  */
+
鐃緒申  if (! block)
+
鐃緒申    val = (long *) malloc (size);
+
鐃緒申  else
+
鐃緒申    val = (long *) realloc (block, size);
+
鐃緒申  UNBLOCK_INPUT;
+
鐃緒申
+
鐃緒申  if (!val && size) memory_full ();
+
鐃緒申  return val;
+
鐃緒申}
+
鐃緒申
+
鐃緒申void
+
鐃緒申xfree (block)
+
鐃緒申     long *block;
+
鐃緒申{
+
鐃緒申  BLOCK_INPUT;
+
鐃緒申  free (block);
+
鐃緒申  UNBLOCK_INPUT;
+
鐃緒申}
+
鐃緒申
+
鐃緒申
+
鐃緒申/* Arranging to disable input signals while we're in malloc.
+
鐃緒申
+
鐃緒申   This only works with GNU malloc.  To help out systems which can't
+
鐃緒申   use GNU malloc, all the calls to malloc, realloc, and free
+
鐃緒申   elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
+
鐃緒申   pairs; unfortunately, we have no idea what C library functions
+
鐃緒申   might call malloc, so we can't really protect them unless you're
+
鐃緒申   using GNU malloc.  Fortunately, most of the major operating can use
+
鐃緒申   GNU malloc.  */
+
鐃緒申
+
鐃緒申#ifndef SYSTEM_MALLOC
+
鐃緒申extern void * (*__malloc_hook) ();
+
鐃緒申static void * (*old_malloc_hook) ();
+
鐃緒申extern void * (*__realloc_hook) ();
+
鐃緒申static void * (*old_realloc_hook) ();
+
鐃緒申extern void (*__free_hook) ();
+
鐃緒申static void (*old_free_hook) ();
+
鐃緒申
+
鐃緒申static void
+
鐃緒申emacs_blocked_free (ptr)
+
鐃緒申     void *ptr;
+
鐃緒申{
+
鐃緒申  BLOCK_INPUT;
+
鐃緒申  __free_hook = old_free_hook;
+
鐃緒申  free (ptr);
+
鐃緒申  __free_hook = emacs_blocked_free;
+
鐃緒申  UNBLOCK_INPUT;
+
鐃緒申}
+
鐃緒申
+
鐃緒申static void *
+
鐃緒申emacs_blocked_malloc (size)
+
鐃緒申     unsigned size;
+
鐃緒申{
+
鐃緒申  void *value;
+
鐃緒申
+
鐃緒申  BLOCK_INPUT;
+
鐃緒申  __malloc_hook = old_malloc_hook;
+
鐃緒申  value = (void *) malloc (size);
+
鐃緒申  __malloc_hook = emacs_blocked_malloc;
+
鐃緒申  UNBLOCK_INPUT;
+
鐃緒申
+
鐃緒申  return value;
+
鐃緒申}
+
鐃緒申
+
鐃緒申static void *
+
鐃緒申emacs_blocked_realloc (ptr, size)
+
鐃緒申     void *ptr;
+
鐃緒申     unsigned size;
+
鐃緒申{
+
鐃緒申  void *value;
+
鐃緒申
+
鐃緒申  BLOCK_INPUT;
+
鐃緒申  __realloc_hook = old_realloc_hook;
+
鐃緒申  value = (void *) realloc (ptr, size);
+
鐃緒申  __realloc_hook = emacs_blocked_realloc;
+
鐃緒申  UNBLOCK_INPUT;
+
鐃緒申
+
鐃緒申  return value;
+
鐃緒申}
+
鐃緒申
+
鐃緒申void
+
鐃緒申uninterrupt_malloc ()
+
鐃緒申{
+
鐃緒申  old_free_hook = __free_hook;
+
鐃緒申  __free_hook = emacs_blocked_free;
+
鐃緒申
+
鐃緒申  old_malloc_hook = __malloc_hook;
+
鐃緒申  __malloc_hook = emacs_blocked_malloc;
+
鐃緒申
+
鐃緒申  old_realloc_hook = __realloc_hook;
+
鐃緒申  __realloc_hook = emacs_blocked_realloc;
+
鐃緒申}
+
鐃緒申#endif
+
鐃緒申
+
鐃緒申/* Interval allocation.  */
+
鐃緒申
+
鐃緒申#ifdef USE_TEXT_PROPERTIES
+
鐃緒申#define INTERVAL_BLOCK_SIZE \
+
鐃緒申  ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
+
鐃緒申
+
鐃緒申struct interval_block
+
鐃緒申  {
+
鐃緒申    struct interval_block *next;
+
鐃緒申    struct interval intervals[INTERVAL_BLOCK_SIZE];
+
鐃緒申  };
+
鐃緒申
+
鐃緒申struct interval_block *interval_block;
+
鐃緒申static int interval_block_index;
+
鐃緒申
+
鐃緒申INTERVAL interval_free_list;
+
鐃緒申
+
鐃緒申static void
+
鐃緒申init_intervals ()
+
鐃緒申{
+
鐃緒申  interval_block
+
鐃緒申    = (struct interval_block *) malloc (sizeof (struct interval_block));
+
鐃緒申  interval_block->next = 0;
+
鐃緒申  bzero (interval_block->intervals, sizeof interval_block->intervals);
+
鐃緒申  interval_block_index = 0;
+
鐃緒申  interval_free_list = 0;
+
鐃緒申}
+
鐃緒申
+
鐃緒申#define INIT_INTERVALS init_intervals ()
+
鐃緒申
+
鐃緒申INTERVAL
+
鐃緒申make_interval ()
+
鐃緒申{
+
鐃緒申  INTERVAL val;
+
鐃緒申
+
鐃緒申  if (interval_free_list)
+
鐃緒申    {
+
鐃緒申      val = interval_free_list;
+
鐃緒申      interval_free_list = interval_free_list->parent;
+
鐃緒申    }
+
鐃緒申  else
+
鐃緒申    {
+
鐃緒申      if (interval_block_index == INTERVAL_BLOCK_SIZE)
+
鐃緒申	{
+
鐃緒申	  register struct interval_block *newi
+
鐃緒申	    = (struct interval_block *) xmalloc (sizeof (struct interval_block));
+
鐃緒申
+
鐃緒申	  VALIDATE_LISP_STORAGE (newi, sizeof *newi);
+
鐃緒申	  newi->next = interval_block;
+
鐃緒申	  interval_block = newi;
+
鐃緒申	  interval_block_index = 0;
+
鐃緒申	}
+
鐃緒申      val = &interval_block->intervals[interval_block_index++];
+
鐃緒申    }
+
鐃緒申  consing_since_gc += sizeof (struct interval);
+
鐃緒申  RESET_INTERVAL (val);
+
鐃緒申  return val;
+
鐃緒申}
+
鐃緒申
+
鐃緒申static int total_free_intervals, total_intervals;
+
鐃緒申
+
鐃緒申/* Mark the pointers of one interval. */
+
鐃緒申
+
鐃緒申static void
+
鐃緒申mark_interval (i, dummy)
+
鐃緒申     register INTERVAL i;
+
鐃緒申     Lisp_Object dummy;
+
鐃緒申{
+
鐃緒申  if (XMARKBIT (i->plist))
+
鐃緒申    abort ();
+
鐃緒申  mark_object (&i->plist);
+
鐃緒申  XMARK (i->plist);
+
鐃緒申}
+
鐃緒申
+
鐃緒申static void
+
鐃緒申mark_interval_tree (tree)
+
鐃緒申     register INTERVAL tree;
+
鐃緒申{
+
鐃緒申  /* No need to test if this tree has been marked already; this
+
鐃緒申     function is always called through the MARK_INTERVAL_TREE macro,
+
鐃緒申     which takes care of that.  */
+
鐃緒申
+
鐃緒申  /* XMARK expands to an assignment; the LHS of an assignment can't be
+
鐃緒申     a cast.  */
+
鐃緒申  XMARK (* (Lisp_Object *) &tree->parent);
+
鐃緒申
+
鐃緒申  traverse_intervals (tree, 1, 0, mark_interval, Qnil);
+
鐃緒申}
+
鐃緒申
+
鐃緒申#define MARK_INTERVAL_TREE(i)				\
+
鐃緒申  do {							\
+
鐃緒申    if (!NULL_INTERVAL_P (i)				\
+
鐃緒申	&& ! XMARKBIT ((Lisp_Object) i->parent))	\
+
鐃緒申      mark_interval_tree (i);				\
+
鐃緒申  } while (0)
+
鐃緒申
+
鐃緒申/* The oddity in the call to XUNMARK is necessary because XUNMARK
+
鐃緒申   expands to an assignment to its argument, and most C compilers don't
+
鐃緒申   support casts on the left operand of `='.  */
+
鐃緒申#define UNMARK_BALANCE_INTERVALS(i) 				\
+
鐃緒申{                                   				\
+
鐃緒申   if (! NULL_INTERVAL_P (i))       				\
+
鐃緒申     {                              				\
+
鐃緒申       XUNMARK (* (Lisp_Object *) (&(i)->parent));		\
+
鐃緒申       (i) = balance_intervals (i);				\
+
鐃緒申     } 								\
+
鐃緒申}
+
鐃緒申
+
鐃緒申#else  /* no interval use */
+
鐃緒申
+
鐃緒申#define INIT_INTERVALS
+
鐃緒申
+
鐃緒申#define UNMARK_BALANCE_INTERVALS(i)
+
鐃緒申#define MARK_INTERVAL_TREE(i)
+
鐃緒申
+
鐃緒申#endif /* no interval use */
+
鐃緒申
+
鐃緒申/* Floating point allocation.  */
+
鐃緒申
+
鐃緒申#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 *) xmalloc (sizeof (struct float_block));
+
鐃緒申	  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 *) xmalloc (sizeof (struct cons_block));
+
鐃緒申	  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 (!NILP (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 *) xmalloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object));
+
鐃緒申  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 (!NILP (Vpurify_flag))
+
鐃緒申    val = make_pure_vector (len);
+
鐃緒申  else
+
鐃緒申    val = Fmake_vector (len, Qnil);
+
鐃緒申  p = XVECTOR (val);
+
鐃緒申  for (index = 0; index < nargs; index++)
+
鐃緒申    {
+
鐃緒申      if (!NILP (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 *) xmalloc (sizeof (struct symbol_block));
+
鐃緒申	  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;
+
鐃緒申
+
鐃緒申  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 *) xmalloc (sizeof (struct marker_block));
+
鐃緒申	  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 *) xmalloc (sizeof (struct string_block_head) + fullsize);
+
鐃緒申      VALIDATE_LISP_STORAGE (new, 0);
+
鐃緒申      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 *) xmalloc (sizeof (struct string_block));
+
鐃緒申      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;
+
鐃緒申  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.
+
鐃緒申
+
鐃緒申   Any number of arguments, even zero arguments, are allowed.  */
+
鐃緒申
+
鐃緒申Lisp_Object
+
鐃緒申make_event_array (nargs, args)
+
鐃緒申     register int nargs;
+
鐃緒申     Lisp_Object *args;
+
鐃緒申{
+
鐃緒申  int i;
+
鐃緒申
+
鐃緒申  for (i = 0; i < nargs; i++)
+
鐃緒申    /* The things that fit in a string
+
鐃緒申       are characters that are in 0...127,
+
鐃緒申       after discarding the meta bit and all the bits above it.  */
+
鐃緒申    if (XTYPE (args[i]) != Lisp_Int
+
鐃緒申	|| (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
+
鐃緒申      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;
+
鐃緒申    
+
鐃緒申    result = Fmake_string (nargs, make_number (0));
+
鐃緒申    for (i = 0; i < nargs; i++)
+
鐃緒申      {
+
鐃緒申	XSTRING (result)->data[i] = XINT (args[i]);
+
鐃緒申	/* Move the meta bit to the right place for a string char.  */
+
鐃緒申	if (XINT (args[i]) & CHAR_META)
+
鐃緒申	  XSTRING (result)->data[i] |= 0x80;
+
鐃緒申      }
+
鐃緒申    
+
鐃緒申    return result;
+
鐃緒申  }
+
鐃緒申}
+
鐃緒申
+
鐃緒申/* Pure storage management.  */
+
鐃緒申
+
鐃緒申/* 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) + INTERVAL_PTR_SIZE + 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;
+
鐃緒申
+
鐃緒申  /* 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 (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;
+
鐃緒申
+
鐃緒申  /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
+
鐃緒申     (double) boundary.  Some architectures (like the sparc) require
+
鐃緒申     this, and I suspect that floats are rare enough that it's no
+
鐃緒申     tragedy for those that do.  */
+
鐃緒申  {
+
鐃緒申    int alignment;
+
鐃緒申    char *p = PUREBEG + pureptr;
+
鐃緒申
+
鐃緒申#ifdef __GNUC__
+
鐃緒申#if __GNUC__ >= 2
+
鐃緒申    alignment = __alignof (struct Lisp_Float);
+
鐃緒申#else
+
鐃緒申    alignment = sizeof (struct Lisp_Float);
+
鐃緒申#endif
+
鐃緒申#else
+
鐃緒申    alignment = sizeof (struct Lisp_Float);
+
鐃緒申#endif  
+
鐃緒申    p = (char *) (((unsigned long) p + alignment - 1) & - alignment);
+
鐃緒申    pureptr = p - PUREBEG;
+
鐃緒申  }
+
鐃緒申
+
鐃緒申  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 (NILP (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 512
+
鐃緒申
+
鐃緒申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;
+
鐃緒申  };
+
鐃緒申
+
鐃緒申/* 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 */
+
鐃緒申
+
鐃緒申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;
+
鐃緒申  int omessage_length = echo_area_glyphs_length;
+
鐃緒申  char stack_top_variable;
+
鐃緒申  register int i;
+
鐃緒申
+
鐃緒申  /* Save a copy of the contents of the stack, for debugging.  */
+
鐃緒申#if MAX_SAVE_STACK > 0
+
鐃緒申  if (NILP (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 *) xmalloc (stack_copy_size = i);
+
鐃緒申	  else if (stack_copy_size < i)
+
鐃緒申	    stack_copy = (char *) xrealloc (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)
+
鐃緒申      {
+
鐃緒申	/* 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))
+
鐃緒申	  nextb->undo_list 
+
鐃緒申	    = truncate_undo_list (nextb->undo_list, undo_limit,
+
鐃緒申				  undo_strong_limit);
+
鐃緒申	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 || minibuf_level > 0)
+
鐃緒申    message2 (omessage, omessage_length);
+
鐃緒申  else if (!noninteractive)
+
鐃緒申    message1 ("Garbage collecting...done");
+
鐃緒申
+
鐃緒申  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 referencing 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.  */
+
鐃緒申
+
鐃緒申#define LAST_MARKED_SIZE 500
+
鐃緒申Lisp_Object *last_marked[LAST_MARKED_SIZE];
+
鐃緒申int last_marked_index;
+
鐃緒申
+
鐃緒申static void
+
鐃緒申mark_object (objptr)
+
鐃緒申     Lisp_Object *objptr;
+
鐃緒申{
+
鐃緒申  register Lisp_Object obj;
+
鐃緒申
+
鐃緒申 loop:
+
鐃緒申  obj = *objptr;
+
鐃緒申 loop2:
+
鐃緒申  XUNMARK (obj);
+
鐃緒申
+
鐃緒申  if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
+
鐃緒申      && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
+
鐃緒申    return;
+
鐃緒申
+
鐃緒申  last_marked[last_marked_index++] = objptr;
+
鐃緒申  if (last_marked_index == LAST_MARKED_SIZE)
+
鐃緒申    last_marked_index = 0;
+
鐃緒申
+
鐃緒申#ifdef SWITCH_ENUM_BUG
+
鐃緒申  switch ((int) XGCTYPE (obj))
+
鐃緒申#else
+
鐃緒申  switch (XGCTYPE (obj))
+
鐃緒申#endif
+
鐃緒申    {
+
鐃緒申    case Lisp_String:
+
鐃緒申      {
+
鐃緒申	register struct Lisp_String *ptr = XSTRING (obj);
+
鐃緒申
+
鐃緒申	MARK_INTERVAL_TREE (ptr->intervals);
+
鐃緒申	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:
+
鐃緒申      {
+
鐃緒申	register struct Lisp_Vector *ptr = XVECTOR (obj);
+
鐃緒申	register 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;
+
鐃緒申
+
鐃緒申	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 (&ptr1->contents[i]);
+
鐃緒申      }
+
鐃緒申      break;
+
鐃緒申
+
鐃緒申    case Lisp_Compiled:
+
鐃緒申      /* We could treat this just like a vector, but it is better
+
鐃緒申	 to save the COMPILED_CONSTANTS element for last and avoid recursion
+
鐃緒申	 there.  */
+
鐃緒申      {
+
鐃緒申	register struct Lisp_Vector *ptr = XVECTOR (obj);
+
鐃緒申	register int size = ptr->size;
+
鐃緒申	/* See comment above under Lisp_Vector.  */
+
鐃緒申	struct Lisp_Vector *volatile ptr1 = ptr;
+
鐃緒申	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 */
+
鐃緒申	  {
+
鐃緒申	    if (i != COMPILED_CONSTANTS)
+
鐃緒申	      mark_object (&ptr1->contents[i]);
+
鐃緒申	  }
+
鐃緒申	/* This cast should be unnecessary, but some Mips compiler complains
+
鐃緒申	   (MIPS-ABI + SysVR4, DC/OSx, etc).  */
+
鐃緒申	objptr = (Lisp_Object *) &ptr1->contents[COMPILED_CONSTANTS];
+
鐃緒申	goto loop;
+
鐃緒申      }
+
鐃緒申
+
鐃緒申#ifdef MULTI_FRAME
+
鐃緒申    case Lisp_Frame:
+
鐃緒申      {
+
鐃緒申	/* See comment above under Lisp_Vector for why this is volatile.  */
+
鐃緒申	register struct frame *volatile ptr = XFRAME (obj);
+
鐃緒申	register int size = ptr->size;
+
鐃緒申
+
鐃緒申	if (size & ARRAY_MARK_FLAG) break;   /* Already marked */
+
鐃緒申	ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+
鐃緒申
+
鐃緒申	mark_object (&ptr->name);
+
鐃緒申	mark_object (&ptr->focus_frame);
+
鐃緒申	mark_object (&ptr->width);
+
鐃緒申	mark_object (&ptr->height);
+
鐃緒申	mark_object (&ptr->selected_window);
+
鐃緒申	mark_object (&ptr->minibuffer_window);
+
鐃緒申	mark_object (&ptr->param_alist);
+
鐃緒申	mark_object (&ptr->scroll_bars);
+
鐃緒申	mark_object (&ptr->condemned_scroll_bars);
+
鐃緒申	mark_object (&ptr->menu_bar_items);
+
鐃緒申	mark_object (&ptr->menu_bar_vector);
+
鐃緒申	mark_object (&ptr->face_alist);
+
鐃緒申      }
+
鐃緒申      break;
+
鐃緒申#endif /* MULTI_FRAME */
+
鐃緒申
+
鐃緒申    case Lisp_Symbol:
+
鐃緒申      {
+
鐃緒申	/* See comment above under Lisp_Vector for why this is volatile.  */
+
鐃緒申	register struct Lisp_Symbol *volatile ptr = XSYMBOL (obj);
+
鐃緒申	struct Lisp_Symbol *ptrx;
+
鐃緒申
+
鐃緒申	if (XMARKBIT (ptr->plist)) break;
+
鐃緒申	XMARK (ptr->plist);
+
鐃緒申	mark_object ((Lisp_Object *) &ptr->value);
+
鐃緒申	mark_object (&ptr->function);
+
鐃緒申	mark_object (&ptr->plist);
+
鐃緒申	XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
+
鐃緒申	mark_object (&ptr->name);
+
鐃緒申	ptr = ptr->next;
+
鐃緒申	if (ptr)
+
鐃緒申	  {
+
鐃緒申	    /* For the benefit of the last_marked log.  */
+
鐃緒申	    objptr = (Lisp_Object *)&XSYMBOL (obj)->next;
+
鐃緒申	    ptrx = ptr;		/* Use of ptrx avoids compiler bug on Sun */
+
鐃緒申	    XSETSYMBOL (obj, ptrx);
+
鐃緒申	    /* We can't goto loop here because *objptr doesn't contain an
+
鐃緒申	       actual Lisp_Object with valid datatype field.  */
+
鐃緒申	    goto loop2;
+
鐃緒申	  }
+
鐃緒申      }
+
鐃緒申      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 freed by gc.  */
+
鐃緒申      break;
+
鐃緒申
+
鐃緒申    case Lisp_Cons:
+
鐃緒申    case Lisp_Buffer_Local_Value:
+
鐃緒申    case Lisp_Some_Buffer_Local_Value:
+
鐃緒申    case Lisp_Overlay:
+
鐃緒申      {
+
鐃緒申	register struct Lisp_Cons *ptr = XCONS (obj);
+
鐃緒申	if (XMARKBIT (ptr->car)) break;
+
鐃緒申	XMARK (ptr->car);
+
鐃緒申	/* If the cdr is nil, avoid recursion for the car.  */
+
鐃緒申	if (EQ (ptr->cdr, Qnil))
+
鐃緒申	  {
+
鐃緒申	    objptr = &ptr->car;
+
鐃緒申	    goto loop;
+
鐃緒申	  }
+
鐃緒申	mark_object (&ptr->car);
+
鐃緒申	/* See comment above under Lisp_Vector for why not use ptr here.  */
+
鐃緒申	objptr = &XCONS (obj)->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;
+
鐃緒申{
+
鐃緒申  register struct buffer *buffer = XBUFFER (buf);
+
鐃緒申  register Lisp_Object *ptr;
+
鐃緒申
+
鐃緒申  /* This is the buffer's markbit */
+
鐃緒申  mark_object (&buffer->name);
+
鐃緒申  XMARK (buffer->name);
+
鐃緒申
+
鐃緒申  MARK_INTERVAL_TREE (buffer->intervals);
+
鐃緒申
+
鐃緒申#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);
+
鐃緒申}
+
鐃緒申
+
鐃緒申/* Sweep: 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 */
+
鐃緒申
+
鐃緒申#ifdef USE_TEXT_PROPERTIES
+
鐃緒申  /* Put all unmarked intervals on free list */
+
鐃緒申  {
+
鐃緒申    register struct interval_block *iblk;
+
鐃緒申    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)
+
鐃緒申      {
+
鐃緒申	register int i;
+
鐃緒申
+
鐃緒申	for (i = 0; i < lim; i++)
+
鐃緒申	  {
+
鐃緒申	    if (! XMARKBIT (iblk->intervals[i].plist))
+
鐃緒申	      {
+
鐃緒申		iblk->intervals[i].parent = interval_free_list;
+
鐃緒申		interval_free_list = &iblk->intervals[i];
+
鐃緒申		num_free++;
+
鐃緒申	      }
+
鐃緒申	    else
+
鐃緒申	      {
+
鐃緒申		num_used++;
+
鐃緒申		XUNMARK (iblk->intervals[i].plist);
+
鐃緒申	      }
+
鐃緒申	  }
+
鐃緒申	lim = INTERVAL_BLOCK_SIZE;
+
鐃緒申      }
+
鐃緒申    total_intervals = num_used;
+
鐃緒申    total_free_intervals = num_free;
+
鐃緒申  }
+
鐃緒申#endif /* USE_TEXT_PROPERTIES */
+
鐃緒申
+
鐃緒申  /* 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;
+
鐃緒申	  xfree (buffer);
+
鐃緒申	  buffer = next;
+
鐃緒申	}
+
鐃緒申      else
+
鐃緒申	{
+
鐃緒申	  XUNMARK (buffer->name);
+
鐃緒申	  UNMARK_BALANCE_INTERVALS (buffer->intervals);
+
鐃緒申
+
鐃緒申#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;
+
鐃緒申	  xfree (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;
+
鐃緒申    struct Lisp_String *s;
+
鐃緒申
+
鐃緒申    while (sb)
+
鐃緒申      {
+
鐃緒申	s = (struct Lisp_String *) &sb->chars[0];
+
鐃緒申	if (s->size & ARRAY_MARK_FLAG)
+
鐃緒申	  {
+
鐃緒申	    ((struct Lisp_String *)(&sb->chars[0]))->size
+
鐃緒申	      &= ~ARRAY_MARK_FLAG & ~MARKBIT;
+
鐃緒申	    UNMARK_BALANCE_INTERVALS (s->intervals);
+
鐃緒申	    total_string_size += ((struct Lisp_String *)(&sb->chars[0]))->size;
+
鐃緒申	    prev = sb, sb = sb->next;
+
鐃緒申	  }
+
鐃緒申	else
+
鐃緒申	  {
+
鐃緒申	    if (prev)
+
鐃緒申	      prev->next = sb->next;
+
鐃緒申	    else
+
鐃緒申	      large_string_blocks = sb->next;
+
鐃緒申	    next = sb->next;
+
鐃緒申	    xfree (sb);
+
鐃緒申	    sb = next;
+
鐃緒申	  }
+
鐃緒申      }
+
鐃緒申  }
+
鐃緒申}
+
鐃緒申
+
鐃緒申/* Compactify strings, relocate references, and free empty string blocks.  */
+
鐃緒申
+
鐃緒申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)
+
鐃緒申		       + INTERVAL_PTR_SIZE);
+
鐃緒申
+
鐃緒申	      /* 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;
+
鐃緒申
+
鐃緒申#ifdef USE_TEXT_PROPERTIES
+
鐃緒申	      /* Now that the string has been relocated, rebalance its
+
鐃緒申                 interval tree, and update the tree's parent pointer. */
+
鐃緒申	      if (! NULL_INTERVAL_P (newaddr->intervals))
+
鐃緒申		{
+
鐃緒申		  UNMARK_BALANCE_INTERVALS (newaddr->intervals);
+
鐃緒申		  XSET (* (Lisp_Object *) &newaddr->intervals->parent,
+
鐃緒申			Lisp_String,
+
鐃緒申			newaddr);
+
鐃緒申		}
+
鐃緒申#endif /* USE_TEXT_PROPERTIES */
+
鐃緒申	    }
+
鐃緒申	  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;
+
鐃緒申      xfree (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;
+
鐃緒申	  xfree (to_sb);
+
鐃緒申	}
+
鐃緒申      else
+
鐃緒申	from_sb = to_sb;
+
鐃緒申    }
+
鐃緒申}
+
鐃緒申
+
鐃緒申/* Debugging aids.  */
+
鐃緒申
+
鐃緒申DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
+
鐃緒申  "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
+
鐃緒申This may be helpful in debugging Emacs's memory usage.\n\
+
鐃緒申We divide the value by 1024 to make sure it fits in a Lisp integer.")
+
鐃緒申  ()
+
鐃緒申{
+
鐃緒申  Lisp_Object end;
+
鐃緒申
+
鐃緒申  XSET (end, Lisp_Int, (int) sbrk (0) / 1024);
+
鐃緒申
+
鐃緒申  return end;
+
鐃緒申}
+
鐃緒申
+
鐃緒申
+
鐃緒申/* Initialization */
+
鐃緒申
+
鐃緒申init_alloc_once ()
+
鐃緒申{
+
鐃緒申  /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
+
鐃緒申  pureptr = 0;
+
鐃緒申#ifdef HAVE_SHM
+
鐃緒申  pure_size = PURESIZE;
+
鐃緒申#endif
+
鐃緒申  all_vectors = 0;
+
鐃緒申  ignore_warnings = 1;
+
鐃緒申  init_strings ();
+
鐃緒申  init_cons ();
+
鐃緒申  init_symbol ();
+
鐃緒申  init_marker ();
+
鐃緒申#ifdef LISP_FLOAT_TYPE
+
鐃緒申  init_float ();
+
鐃緒申#endif /* LISP_FLOAT_TYPE */
+
鐃緒申  INIT_INTERVALS;
+
鐃緒申
+
鐃緒申  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-limit", &undo_limit,
+
鐃緒申    "Keep no more undo information once it exceeds this size.\n\
+
鐃緒申This limit 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_limit = 20000;
+
鐃緒申
+
鐃緒申  DEFVAR_INT ("undo-strong-limit", &undo_strong_limit,
+
鐃緒申    "Don't keep more than this much size of undo information.\n\
+
鐃緒申A command which pushes past this size is itself forgotten.\n\
+
鐃緒申This limit 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_strong_limit = 30000;
+
鐃緒申
+
鐃緒申  /* We build this in advance because if we wait until we need it, we might
+
鐃緒申     not be able to allocate the memory to hold it.  */
+
鐃緒申  memory_signal_data
+
鐃緒申    = Fcons (Qerror, Fcons (build_string ("Memory exhausted"), Qnil));
+
鐃緒申  staticpro (&memory_signal_data);
+
鐃緒申
+
鐃緒申  defsubr (&Scons);
+
鐃緒申  defsubr (&Slist);
+
鐃緒申  defsubr (&Svector);
+
鐃緒申  defsubr (&Smake_byte_code);
+
鐃緒申  defsubr (&Smake_list);
+
鐃緒申  defsubr (&Smake_vector);
+
鐃緒申  defsubr (&Smake_string);
+
鐃緒申  defsubr (&Smake_symbol);
+
鐃緒申  defsubr (&Smake_marker);
+
鐃緒申  defsubr (&Spurecopy);
+
鐃緒申  defsubr (&Sgarbage_collect);
+
鐃緒申  defsubr (&Smemory_limit);
+
鐃緒申}