Return to alloc.c CVS log

Up to [Apple XNU] / GNUtools / emacs / src

Annotation of GNUtools/emacs/src/alloc.c, revision 1.1

1.1     ! root        1: /* Storage allocation and gc for GNU Emacs Lisp interpreter.
        !             2:    Copyright (C) 1985, 1986 Free Software Foundation, Inc.
        !             3: 
        !             4: This file is part of GNU Emacs.
        !             5: 
        !             6: GNU Emacs is free software; you can redistribute it and/or modify
        !             7: it under the terms of the GNU General Public License as published by
        !             8: the Free Software Foundation; either version 1, or (at your option)
        !             9: any later version.
        !            10: 
        !            11: GNU Emacs is distributed in the hope that it will be useful,
        !            12: but WITHOUT ANY WARRANTY; without even the implied warranty of
        !            13: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
        !            14: GNU General Public License for more details.
        !            15: 
        !            16: You should have received a copy of the GNU General Public License
        !            17: along with GNU Emacs; see the file COPYING.  If not, write to
        !            18: the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
        !            19: 
        !            20: 
        !            21: #include "config.h"
        !            22: #include "lisp.h"
        !            23: #ifndef standalone
        !            24: #include "buffer.h"
        !            25: #include "window.h"
        !            26: #endif
        !            27: 
        !            28: #define max(A,B) ((A) > (B) ? (A) : (B))
        !            29: 
        !            30: /* Macro to verify that storage intended for Lisp objects is not
        !            31:    out of range to fit in the space for a pointer.
        !            32:    ADDRESS is the start of the block, and SIZE
        !            33:    is the amount of space within which objects can start.  */
        !            34: #define VALIDATE_LISP_STORAGE(address, size)                   \
        !            35: do                                                             \
        !            36:   {                                                            \
        !            37:     Lisp_Object val;                                           \
        !            38:     XSET (val, Lisp_Cons, (char *) address + size);            \
        !            39:     if ((char *) XCONS (val) != (char *) address + size)       \
        !            40:       {                                                                \
        !            41:        free (address);                                         \
        !            42:        memory_full ();                                         \
        !            43:       }                                                                \
        !            44:   } while (0)
        !            45: 
        !            46: /* Number of bytes of consing done since the last gc */
        !            47: int consing_since_gc;
        !            48: 
        !            49: /* Number of bytes of consing since gc before another gc should be done. */
        !            50: int gc_cons_threshold;
        !            51: 
        !            52: /* value of consing_since_gc when undos were last truncated.  */
        !            53: int consing_at_last_truncate;
        !            54: 
        !            55: /* Nonzero during gc */
        !            56: int gc_in_progress;
        !            57: 
        !            58: #ifndef VIRT_ADDR_VARIES
        !            59: extern
        !            60: #endif /* VIRT_ADDR_VARIES */
        !            61:  int malloc_sbrk_used;
        !            62: 
        !            63: #ifndef VIRT_ADDR_VARIES
        !            64: extern
        !            65: #endif /* VIRT_ADDR_VARIES */
        !            66:  int malloc_sbrk_unused;
        !            67: 
        !            68: /* Two thresholds controlling how much undo information to keep.  */
        !            69: int undo_threshold;
        !            70: int undo_high_threshold;
        !            71: 
        !            72: /* Non-nil means defun should do purecopy on the function definition */
        !            73: Lisp_Object Vpurify_flag;
        !            74: 
        !            75: /* Argument we give to Fsignal when memory is full.
        !            76:    Preallocated since perhaps we can't allocate it when memory is full.  */
        !            77: Lisp_Object memory_exhausted_message;
        !            78: 
        !            79: #ifndef HAVE_SHM
        !            80: #ifdef VMS
        !            81: int pure[PURESIZE / sizeof (int)];     /*no need to initialize - wasted space*/
        !            82: #else
        !            83: int pure[PURESIZE / sizeof (int)] = {0,};   /* Force it into data space! */
        !            84: #endif /* NOT VMS */
        !            85: #define PUREBEG (char *) pure
        !            86: #else
        !            87: #define pure PURE_SEG_BITS   /* Use shared memory segment */
        !            88: #define PUREBEG (char *)PURE_SEG_BITS
        !            89: #endif /* not HAVE_SHM */
        !            90: 
        !            91: /* Index in pure at which next pure object will be allocated. */
        !            92: int pureptr;
        !            93: 
        !            94: /* If nonzero, this is a warning delivered by malloc and not yet displayed.  */
        !            95: char *pending_malloc_warning;
        !            96: 
        !            97: Lisp_Object
        !            98: malloc_warning_1 (str)
        !            99:      Lisp_Object str;
        !           100: {
        !           101:   Fprinc (str, Vstandard_output);
        !           102:   write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
        !           103:   write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
        !           104:   write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
        !           105:   return Qnil;
        !           106: }
        !           107: 
        !           108: /* malloc calls this if it finds we are near exhausting storage */
        !           109: malloc_warning (str)
        !           110:      char *str;
        !           111: {
        !           112:   pending_malloc_warning = str;
        !           113: }
        !           114: 
        !           115: display_malloc_warning ()
        !           116: {
        !           117:   register Lisp_Object val;
        !           118: 
        !           119:   val = build_string (pending_malloc_warning);
        !           120:   pending_malloc_warning = 0;
        !           121:   internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
        !           122: }
        !           123: 
        !           124: /* Called if malloc returns zero */
        !           125: memory_full ()
        !           126: {
        !           127:   while (1)
        !           128:     Fsignal (Qerror, memory_exhausted_message);
        !           129: }
        !           130: 
        !           131: /* like malloc and realloc but check for no memory left */
        !           132: 
        !           133: long *
        !           134: xmalloc (size)
        !           135:      int size;
        !           136: {
        !           137:   register long *val;
        !           138:   /* Avoid failure if malloc (0) returns 0.  */
        !           139:   if (size == 0)
        !           140:     size = 1;
        !           141:   val = (long *) malloc (size);
        !           142:   if (!val) memory_full ();
        !           143:   return val;
        !           144: }
        !           145: 
        !           146: long *
        !           147: xrealloc (block, size)
        !           148:      long *block;
        !           149:      int size;
        !           150: {
        !           151:   register long *val;
        !           152:   /* Avoid failure if malloc (0) returns 0.  */
        !           153:   if (size == 0)
        !           154:     size = 1;
        !           155:   val = (long *) realloc (block, size);
        !           156:   if (!val) memory_full ();
        !           157:   return val;
        !           158: }
        !           159: 
        !           160: /* Allocation of cons cells */
        !           161: /* We store cons cells inside of cons_blocks, allocating a new
        !           162:  cons_block with malloc whenever necessary.  Cons cells reclaimed by
        !           163:  GC are put on a free list to be reallocated before allocating
        !           164:  any new cons cells from the latest cons_block.
        !           165: 
        !           166:  Each cons_block is just under 1016 bytes long,
        !           167:  since malloc really allocates in units of powers of two
        !           168:  and uses 8 bytes for its own overhead. */
        !           169: 
        !           170: #define CONS_BLOCK_SIZE \
        !           171:   ((1016 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
        !           172: 
        !           173: struct cons_block
        !           174:   {
        !           175:     struct cons_block *next;
        !           176:     struct Lisp_Cons conses[CONS_BLOCK_SIZE];
        !           177:   };
        !           178: 
        !           179: struct cons_block *cons_block;
        !           180: int cons_block_index;
        !           181: 
        !           182: struct Lisp_Cons *cons_free_list;
        !           183: 
        !           184: void
        !           185: init_cons ()
        !           186: {
        !           187:   cons_block = (struct cons_block *) malloc (sizeof (struct cons_block));
        !           188:   cons_block->next = 0;
        !           189:   bzero (cons_block->conses, sizeof cons_block->conses);
        !           190:   cons_block_index = 0;
        !           191:   cons_free_list = 0;
        !           192: }
        !           193: 
        !           194: /* Explicitly free a cons cell.  */
        !           195: free_cons (ptr)
        !           196:      struct Lisp_Cons *ptr;
        !           197: {
        !           198:   XFASTINT (ptr->car) = (int) cons_free_list;
        !           199:   cons_free_list = ptr;
        !           200: }
        !           201: 
        !           202: DEFUN ("cons", Fcons, Scons, 2, 2, 0,
        !           203:   "Create a new cons, give it CAR and CDR as components, and return it.")
        !           204:   (car, cdr)
        !           205:      Lisp_Object car, cdr;
        !           206: {
        !           207:   register Lisp_Object val;
        !           208: 
        !           209:   if (cons_free_list)
        !           210:     {
        !           211:       XSET (val, Lisp_Cons, cons_free_list);
        !           212:       cons_free_list = (struct Lisp_Cons *) XFASTINT (cons_free_list->car);
        !           213:     }
        !           214:   else
        !           215:     {
        !           216:       if (cons_block_index == CONS_BLOCK_SIZE)
        !           217:        {
        !           218:          register struct cons_block *new = (struct cons_block *) malloc (sizeof (struct cons_block));
        !           219:          if (!new) memory_full ();
        !           220:          VALIDATE_LISP_STORAGE (new, sizeof *new);
        !           221:          new->next = cons_block;
        !           222:          cons_block = new;
        !           223:          cons_block_index = 0;
        !           224:          XSET (val, Lisp_Cons, &cons_block->conses[CONS_BLOCK_SIZE - 1]);
        !           225:        }
        !           226:       XSET (val, Lisp_Cons, &cons_block->conses[cons_block_index++]);
        !           227:     }
        !           228:   XCONS (val)->car = car;
        !           229:   XCONS (val)->cdr = cdr;
        !           230:   consing_since_gc += sizeof (struct Lisp_Cons);
        !           231:   return val;
        !           232: }
        !           233: 
        !           234: DEFUN ("list", Flist, Slist, 0, MANY, 0,
        !           235:   "Return a newly created list whose elements are the arguments (any number).")
        !           236:   (nargs, args)
        !           237:      int nargs;
        !           238:      register Lisp_Object *args;
        !           239: {
        !           240:   register Lisp_Object len, val, val_tail;
        !           241: 
        !           242:   XFASTINT (len) = nargs;
        !           243:   val = Fmake_list (len, Qnil);
        !           244:   val_tail = val;
        !           245:   while (!NULL (val_tail))
        !           246:     {
        !           247:       XCONS (val_tail)->car = *args++;
        !           248:       val_tail = XCONS (val_tail)->cdr;
        !           249:     }
        !           250:   return val;
        !           251: }
        !           252: 
        !           253: DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
        !           254:   "Return a newly created list of length LENGTH, with each element being INIT.")
        !           255:   (length, init)
        !           256:      register Lisp_Object length, init;
        !           257: {
        !           258:   register Lisp_Object val;
        !           259:   register int size;
        !           260: 
        !           261:   if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
        !           262:     length = wrong_type_argument (Qnatnump, length);
        !           263:   size = XINT (length);
        !           264: 
        !           265:   val = Qnil;
        !           266:   while (size-- > 0)
        !           267:     val = Fcons (init, val);
        !           268:   return val;
        !           269: }
        !           270: 
        !           271: /* Allocation of vectors */
        !           272: 
        !           273: struct Lisp_Vector *all_vectors;
        !           274: 
        !           275: DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
        !           276:   "Return a newly created vector of length LENGTH, with each element being INIT.")
        !           277:   (length, init)
        !           278:      register Lisp_Object length, init;
        !           279: {
        !           280:   register int sizei, index;
        !           281:   register Lisp_Object vector;
        !           282:   register struct Lisp_Vector *p;
        !           283: 
        !           284:   if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
        !           285:     length = wrong_type_argument (Qnatnump, length);
        !           286:   sizei = XINT (length);
        !           287: 
        !           288:   p = (struct Lisp_Vector *) malloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object));
        !           289:   if (p == 0)
        !           290:     memory_full ();
        !           291:   VALIDATE_LISP_STORAGE (p, 0);
        !           292: 
        !           293:   XSET (vector, Lisp_Vector, p);
        !           294:   consing_since_gc += sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object);
        !           295: 
        !           296:   p->size = sizei;
        !           297:   p->next = all_vectors;
        !           298:   all_vectors = p;
        !           299: 
        !           300:   for (index = 0; index < sizei; index++)
        !           301:     p->contents[index] = init;
        !           302: 
        !           303:   return vector;
        !           304: }
        !           305: 
        !           306: DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
        !           307:   "Return a newly created vector with our arguments (any number) as its elements.")
        !           308:   (nargs, args)
        !           309:      register int nargs;
        !           310:      Lisp_Object *args;
        !           311: {
        !           312:   register Lisp_Object len, val;
        !           313:   register int index;
        !           314:   register struct Lisp_Vector *p;
        !           315: 
        !           316:   XFASTINT (len) = nargs;
        !           317:   val = Fmake_vector (len, Qnil);
        !           318:   p = XVECTOR (val);
        !           319:   for (index = 0; index < nargs; index++)
        !           320:     p->contents[index] = args[index];
        !           321:   return val;
        !           322: }
        !           323: 
        !           324: /* Allocation of symbols.
        !           325:  Just like allocation of conses!
        !           326: 
        !           327:  Each symbol_block is just under 1016 bytes long,
        !           328:  since malloc really allocates in units of powers of two
        !           329:  and uses 8 bytes for its own overhead. */
        !           330: 
        !           331: #define SYMBOL_BLOCK_SIZE \
        !           332:   ((1016 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
        !           333: 
        !           334: struct symbol_block
        !           335:   {
        !           336:     struct symbol_block *next;
        !           337:     struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
        !           338:   };
        !           339: 
        !           340: struct symbol_block *symbol_block;
        !           341: int symbol_block_index;
        !           342: 
        !           343: struct Lisp_Symbol *symbol_free_list;
        !           344: 
        !           345: void
        !           346: init_symbol ()
        !           347: {
        !           348:   symbol_block = (struct symbol_block *) malloc (sizeof (struct symbol_block));
        !           349:   symbol_block->next = 0;
        !           350:   bzero (symbol_block->symbols, sizeof symbol_block->symbols);
        !           351:   symbol_block_index = 0;
        !           352:   symbol_free_list = 0;
        !           353: }
        !           354: 
        !           355: DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
        !           356:   "Return a newly allocated uninterned symbol whose name is NAME.\n\
        !           357: Its value and function definition are void, and its property list is NIL.")
        !           358:   (str)
        !           359:      Lisp_Object str;
        !           360: {
        !           361:   register Lisp_Object val;
        !           362:   register struct Lisp_Symbol *p;
        !           363: 
        !           364:   CHECK_STRING (str, 0);
        !           365: 
        !           366:   if (symbol_free_list)
        !           367:     {
        !           368:       XSET (val, Lisp_Symbol, symbol_free_list);
        !           369:       symbol_free_list
        !           370:        = (struct Lisp_Symbol *) XFASTINT (symbol_free_list->value);
        !           371:     }
        !           372:   else
        !           373:     {
        !           374:       if (symbol_block_index == SYMBOL_BLOCK_SIZE)
        !           375:        {
        !           376:          struct symbol_block *new = (struct symbol_block *) malloc (sizeof (struct symbol_block));
        !           377:          if (!new) memory_full ();
        !           378:          VALIDATE_LISP_STORAGE (new, sizeof *new);
        !           379:          new->next = symbol_block;
        !           380:          symbol_block = new;
        !           381:          symbol_block_index = 0;
        !           382:        }
        !           383:       XSET (val, Lisp_Symbol, &symbol_block->symbols[symbol_block_index++]);
        !           384:     }
        !           385:   p = XSYMBOL (val);
        !           386:   p->name = XSTRING (str);
        !           387:   p->plist = Qnil;
        !           388:   p->value = Qunbound;
        !           389:   p->function = Qunbound;
        !           390:   p->next = 0;
        !           391:   consing_since_gc += sizeof (struct Lisp_Symbol);
        !           392:   return val;
        !           393: }
        !           394: 
        !           395: /* Allocation of markers.
        !           396:  Works like allocation of conses. */
        !           397: 
        !           398: #define MARKER_BLOCK_SIZE \
        !           399:   ((1016 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
        !           400: 
        !           401: struct marker_block
        !           402:   {
        !           403:     struct marker_block *next;
        !           404:     struct Lisp_Marker markers[MARKER_BLOCK_SIZE];
        !           405:   };
        !           406: 
        !           407: struct marker_block *marker_block;
        !           408: int marker_block_index;
        !           409: 
        !           410: struct Lisp_Marker *marker_free_list;
        !           411: 
        !           412: void
        !           413: init_marker ()
        !           414: {
        !           415:   marker_block = (struct marker_block *) malloc (sizeof (struct marker_block));
        !           416:   marker_block->next = 0;
        !           417:   bzero (marker_block->markers, sizeof marker_block->markers);
        !           418:   marker_block_index = 0;
        !           419:   marker_free_list = 0;
        !           420: }
        !           421: 
        !           422: DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
        !           423:   "Return a newly allocated marker which does not point at any place.")
        !           424:   ()
        !           425: {
        !           426:   register Lisp_Object val;
        !           427:   register struct Lisp_Marker *p;
        !           428: 
        !           429:   if (marker_free_list)
        !           430:     {
        !           431:       XSET (val, Lisp_Marker, marker_free_list);
        !           432:       marker_free_list
        !           433:        = (struct Lisp_Marker *) XFASTINT (marker_free_list->chain);
        !           434:     }
        !           435:   else
        !           436:     {
        !           437:       if (marker_block_index == MARKER_BLOCK_SIZE)
        !           438:        {
        !           439:          struct marker_block *new = (struct marker_block *) malloc (sizeof (struct marker_block));
        !           440:          if (!new) memory_full ();
        !           441:          VALIDATE_LISP_STORAGE (new, sizeof *new);
        !           442:          new->next = marker_block;
        !           443:          marker_block = new;
        !           444:          marker_block_index = 0;
        !           445:        }
        !           446:       XSET (val, Lisp_Marker, &marker_block->markers[marker_block_index++]);
        !           447:     }
        !           448:   p = XMARKER (val);
        !           449:   p->buffer = 0;
        !           450:   p->bufpos = 0;
        !           451:   p->chain = Qnil;
        !           452:   consing_since_gc += sizeof (struct Lisp_Marker);
        !           453:   return val;
        !           454: }
        !           455: 
        !           456: /* Allocation of strings */
        !           457: 
        !           458: /* Strings reside inside of string_blocks.  The entire data of the string,
        !           459:  both the size and the contents, live in part of the `chars' component of a string_block.
        !           460:  The `pos' component is the index within `chars' of the first free byte.
        !           461: 
        !           462:  first_string_block points to the first string_block ever allocated.
        !           463:  Each block points to the next one with its `next' field.
        !           464:  The `prev' fields chain in reverse order.
        !           465:  The last one allocated is the one currently being filled.
        !           466:  current_string_block points to it.
        !           467: 
        !           468:  The string_blocks that hold individual large strings
        !           469:  go in a separate chain, started by large_string_blocks.  */
        !           470: 
        !           471: 
        !           472: /* String blocks contain this many useful bytes.
        !           473:    8184 is power of 2, minus 8 for malloc overhead. */
        !           474: #define STRING_BLOCK_SIZE (8184 - sizeof (struct string_block_head))
        !           475: 
        !           476: /* A string bigger than this gets its own specially-made string block
        !           477:  if it doesn't fit in the current one. */
        !           478: #define STRING_BLOCK_OUTSIZE 1024
        !           479: 
        !           480: struct string_block_head
        !           481:   {
        !           482:     struct string_block *next, *prev;
        !           483:     int pos;
        !           484:   };
        !           485: 
        !           486: struct string_block
        !           487:   {
        !           488:     struct string_block *next, *prev;
        !           489:     int pos;
        !           490:     char chars[STRING_BLOCK_SIZE];
        !           491:   };
        !           492: 
        !           493: /* This points to the string block we are now allocating strings.  */
        !           494: 
        !           495: struct string_block *current_string_block;
        !           496: 
        !           497: /* This points to the oldest string block, the one that starts the chain.  */
        !           498: 
        !           499: struct string_block *first_string_block;
        !           500: 
        !           501: /* Last string block in chain of those made for individual large strings.  */
        !           502: 
        !           503: struct string_block *large_string_blocks;
        !           504: 
        !           505: /* If SIZE is the length of a string, this returns how many bytes
        !           506:    the string occupies in a string_block (including padding).  */
        !           507: 
        !           508: #define STRING_FULLSIZE(SIZE)   \
        !           509: (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
        !           510: 
        !           511: void
        !           512: init_strings ()
        !           513: {
        !           514:   current_string_block = (struct string_block *) malloc (sizeof (struct string_block));
        !           515:   first_string_block = current_string_block;
        !           516:   consing_since_gc += sizeof (struct string_block);
        !           517:   current_string_block->next = 0;
        !           518:   current_string_block->prev = 0;
        !           519:   current_string_block->pos = 0;
        !           520:   large_string_blocks = 0;
        !           521: }
        !           522: 
        !           523: static Lisp_Object make_uninit_string ();
        !           524: 
        !           525: DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
        !           526:   "Return a newly created string of length LENGTH, with each element being INIT.\n\
        !           527: Both LENGTH and INIT must be numbers.")
        !           528:   (length, init)
        !           529:      Lisp_Object length, init;
        !           530: {
        !           531:   register Lisp_Object val;
        !           532:   register unsigned char *p, *end, c;
        !           533: 
        !           534:   if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
        !           535:     length = wrong_type_argument (Qnatnump, length);
        !           536:   CHECK_NUMBER (init, 1);
        !           537:   val = make_uninit_string (XINT (length));
        !           538:   c = XINT (init);
        !           539:   p = XSTRING (val)->data;
        !           540:   end = p + XSTRING (val)->size;
        !           541:   while (p != end)
        !           542:     *p++ = c;
        !           543:   *p = 0;
        !           544:   return val;
        !           545: }
        !           546: 
        !           547: Lisp_Object
        !           548: make_string (contents, length)
        !           549:      char *contents;
        !           550:      int length;
        !           551: {
        !           552:   register Lisp_Object val;
        !           553:   val = make_uninit_string (length, 0);
        !           554:   bcopy (contents, XSTRING (val)->data, length);
        !           555:   return val;
        !           556: }
        !           557: 
        !           558: Lisp_Object
        !           559: build_string (str)
        !           560:      char *str;
        !           561: {
        !           562:   return make_string (str, strlen (str));
        !           563: }
        !           564: 
        !           565: static Lisp_Object
        !           566: make_uninit_string (length)
        !           567:      int length;
        !           568: {
        !           569:   register Lisp_Object val;
        !           570:   register int fullsize = STRING_FULLSIZE (length);
        !           571: 
        !           572:   if (length < 0) abort ();
        !           573: 
        !           574:   if (fullsize <= STRING_BLOCK_SIZE - current_string_block->pos)
        !           575:     /* This string can fit in the current string block */
        !           576:     {
        !           577:       XSET (val, Lisp_String,
        !           578:            (struct Lisp_String *) (current_string_block->chars + current_string_block->pos));
        !           579:       current_string_block->pos += fullsize;
        !           580:     }
        !           581:   else if (fullsize > STRING_BLOCK_OUTSIZE)
        !           582:     /* This string gets its own string block */
        !           583:     {
        !           584:       register struct string_block *new
        !           585:        = (struct string_block *) malloc (sizeof (struct string_block_head) + fullsize);
        !           586:       if (!new) memory_full ();
        !           587:       VALIDATE_LISP_STORAGE (new, 0);
        !           588:       consing_since_gc += sizeof (struct string_block_head) + fullsize;
        !           589:       new->pos = fullsize;
        !           590:       new->next = large_string_blocks;
        !           591:       large_string_blocks = new;
        !           592:       XSET (val, Lisp_String,
        !           593:            (struct Lisp_String *) ((struct string_block_head *)new + 1));
        !           594:     }
        !           595:   else
        !           596:     /* Make a new current string block and start it off with this string */
        !           597:     {
        !           598:       register struct string_block *new
        !           599:        = (struct string_block *) malloc (sizeof (struct string_block));
        !           600:       if (!new) memory_full ();
        !           601:       VALIDATE_LISP_STORAGE (new, sizeof *new);
        !           602:       consing_since_gc += sizeof (struct string_block);
        !           603:       current_string_block->next = new;
        !           604:       new->prev = current_string_block;
        !           605:       new->next = 0;
        !           606:       current_string_block = new;
        !           607:       new->pos = fullsize;
        !           608:       XSET (val, Lisp_String,
        !           609:            (struct Lisp_String *) current_string_block->chars);
        !           610:     }
        !           611:     
        !           612:   XSTRING (val)->size = length;
        !           613:   XSTRING (val)->data[length] = 0;
        !           614: 
        !           615:   return val;
        !           616: }
        !           617: 
        !           618: /* Must get an error if pure storage is full,
        !           619:  since if it cannot hold a large string
        !           620:  it may be able to hold conses that point to that string;
        !           621:  then the string is not protected from gc. */
        !           622: 
        !           623: Lisp_Object
        !           624: make_pure_string (data, length)
        !           625:      char *data;
        !           626:      int length;
        !           627: {
        !           628:   register Lisp_Object new;
        !           629:   register int size = sizeof (int) + length + 1;
        !           630: 
        !           631:   if (pureptr + size > PURESIZE)
        !           632:     error ("Pure Lisp storage exhausted");
        !           633:   XSET (new, Lisp_String, PUREBEG + pureptr);
        !           634:   XSTRING (new)->size = length;
        !           635:   bcopy (data, XSTRING (new)->data, length);
        !           636:   XSTRING (new)->data[length] = 0;
        !           637:   pureptr += (size + sizeof (int) - 1)
        !           638:             / sizeof (int) * sizeof (int);
        !           639:   return new;
        !           640: }
        !           641: 
        !           642: Lisp_Object
        !           643: pure_cons (car, cdr)
        !           644:      Lisp_Object car, cdr;
        !           645: {
        !           646:   register Lisp_Object new;
        !           647: 
        !           648:   if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE)
        !           649:     error ("Pure Lisp storage exhausted");
        !           650:   XSET (new, Lisp_Cons, PUREBEG + pureptr);
        !           651:   pureptr += sizeof (struct Lisp_Cons);
        !           652:   XCONS (new)->car = Fpurecopy (car);
        !           653:   XCONS (new)->cdr = Fpurecopy (cdr);
        !           654:   return new;
        !           655: }
        !           656: 
        !           657: Lisp_Object
        !           658: make_pure_vector (len)
        !           659:      int len;
        !           660: {
        !           661:   register Lisp_Object new;
        !           662:   register int size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object);
        !           663: 
        !           664:   if (pureptr + size > PURESIZE)
        !           665:     error ("Pure Lisp storage exhausted");
        !           666: 
        !           667:   XSET (new, Lisp_Vector, PUREBEG + pureptr);
        !           668:   pureptr += size;
        !           669:   XVECTOR (new)->size = len;
        !           670:   return new;
        !           671: }
        !           672: 
        !           673: DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
        !           674:   "Make a copy of OBJECT in pure storage.\n\
        !           675: Recursively copies contents of vectors and cons cells.\n\
        !           676: Does not copy symbols.")
        !           677:   (obj)
        !           678:      register Lisp_Object obj;
        !           679: {
        !           680:   register Lisp_Object new, tem;
        !           681:   register int i;
        !           682: 
        !           683:   if (NULL (Vpurify_flag))
        !           684:     return obj;
        !           685: 
        !           686:   if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
        !           687:       && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
        !           688:     return obj;
        !           689: 
        !           690: #ifdef SWITCH_ENUM_BUG
        !           691:   switch ((int) XTYPE (obj))
        !           692: #else
        !           693:   switch (XTYPE (obj))
        !           694: #endif
        !           695:     {
        !           696:     case Lisp_Marker:
        !           697:       error ("Attempt to copy a marker to pure storage");
        !           698: 
        !           699:     case Lisp_Cons:
        !           700:       return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr);
        !           701: 
        !           702:     case Lisp_String:
        !           703:       return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size);
        !           704: 
        !           705:     case Lisp_Vector:
        !           706:       new = make_pure_vector (XVECTOR (obj)->size);
        !           707:       for (i = 0; i < XVECTOR (obj)->size; i++)
        !           708:        {
        !           709:          tem = XVECTOR (obj)->contents[i];
        !           710:          XVECTOR (new)->contents[i] = Fpurecopy (tem);
        !           711:        }
        !           712:       return new;
        !           713: 
        !           714:     default:
        !           715:       return obj;
        !           716:     }
        !           717: }
        !           718: 
        !           719: /* Recording what needs to be marked for gc.  */
        !           720: 
        !           721: struct gcpro *gcprolist;
        !           722: 
        !           723: #define NSTATICS 200
        !           724: 
        !           725: int staticidx = 0;
        !           726: 
        !           727: #ifdef __GNUC__
        !           728: Lisp_Object *staticvec[NSTATICS] = {0};
        !           729: #else
        !           730: char staticvec1[NSTATICS * sizeof (Lisp_Object *)] = {0};
        !           731: #define staticvec ((Lisp_Object **) staticvec1)
        !           732: #endif
        !           733: 
        !           734: /* Put an entry in staticvec, pointing at the variable whose address is given */
        !           735: 
        !           736: void
        !           737: staticpro (varaddress)
        !           738:      Lisp_Object *varaddress;
        !           739: {
        !           740:   staticvec[staticidx++] = varaddress;
        !           741:   if (staticidx >= NSTATICS)
        !           742:     abort ();
        !           743: }
        !           744: 
        !           745: struct catchtag
        !           746:   {
        !           747:     Lisp_Object tag;
        !           748:     Lisp_Object val;
        !           749:     struct catchtag *next;
        !           750: /*    jmp_buf jmp;  /* We don't need this for GC purposes */
        !           751:   };
        !           752: 
        !           753: extern struct catchtag *catchlist;
        !           754: 
        !           755: struct backtrace
        !           756:   {
        !           757:     struct backtrace *next;
        !           758:     Lisp_Object *function;
        !           759:     Lisp_Object *args; /* Points to vector of args. */
        !           760:     int nargs;         /* length of vector */
        !           761:               /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
        !           762:     char evalargs;
        !           763:   };
        !           764: 
        !           765: extern struct backtrace *backtrace_list;
        !           766: 
        !           767: /* Two flags that are set during GC in the `size' component
        !           768:    of a string or vector.  On some machines, these flags
        !           769:    are defined by the m- file to be different bits.  */
        !           770: 
        !           771: /* On vector, means it has been marked.
        !           772:    On string size field or a reference to a string,
        !           773:    means not the last reference in the chain.  */
        !           774: 
        !           775: #ifndef ARRAY_MARK_FLAG
        !           776: #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
        !           777: #endif /* no ARRAY_MARK_FLAG */
        !           778: 
        !           779: /* Any slot that is a Lisp_Object can point to a string
        !           780:    and thus can be put on a string's reference-chain
        !           781:    and thus may need to have its ARRAY_MARK_FLAG set.
        !           782:    This includes the slots whose markbits are used to mark
        !           783:    the containing objects.  */
        !           784: 
        !           785: #if ARRAY_MARK_FLAG == MARKBIT
        !           786: you lose
        !           787: #endif
        !           788: 
        !           789: int total_conses, total_markers, total_symbols, total_string_size, total_vector_size;
        !           790: int total_free_conses, total_free_markers, total_free_symbols;
        !           791: 
        !           792: static void mark_object (), mark_buffer ();
        !           793: static void clear_marks (), gc_sweep ();
        !           794: static void compact_strings ();
        !           795: 
        !           796: DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
        !           797:   "Reclaim storage for Lisp objects no longer needed.\n\
        !           798: Returns info on amount of space in use:\n\
        !           799:  ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
        !           800:   (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS)\n\
        !           801: Garbage collection happens automatically if you cons more than\n\
        !           802: gc-cons-threshold  bytes of Lisp data since previous garbage collection.")
        !           803:   ()
        !           804: {
        !           805:   register struct gcpro *tail;
        !           806:   register struct specbinding *bind;
        !           807:   struct catchtag *catch;
        !           808:   struct handler *handler;
        !           809:   register struct backtrace *backlist;
        !           810:   register Lisp_Object tem;
        !           811:   char *omessage = echo_area_contents;
        !           812: 
        !           813:   register int i;
        !           814: 
        !           815:   if (!noninteractive)
        !           816:     message1 ("Garbage collecting...");
        !           817: 
        !           818:   /* Don't keep command history around forever */
        !           819:   tem = Fnthcdr (make_number (30), Vcommand_history);
        !           820:   if (CONSP (tem))
        !           821:     XCONS (tem)->cdr = Qnil;
        !           822:   /* Likewise for undo information.  */
        !           823:   truncate_all_undos ();
        !           824: 
        !           825:   gc_in_progress = 1;
        !           826: 
        !           827: /*  clear_marks ();  */
        !           828: 
        !           829:   /* In each "large string", set the MARKBIT of the size field.
        !           830:      That enables mark_object to recognize them.  */
        !           831:   {
        !           832:     register struct string_block *b;
        !           833:     for (b = large_string_blocks; b; b = b->next)
        !           834:       ((struct Lisp_String *)(&b->chars[0]))->size |= MARKBIT;
        !           835:   }
        !           836: 
        !           837:   /* Mark all the special slots that serve as the roots of accessibility.
        !           838: 
        !           839:      Usually the special slots to mark are contained in particular structures.
        !           840:      Then we know no slot is marked twice because the structures don't overlap.
        !           841:      In some cases, the structures point to the slots to be marked.
        !           842:      For these, we use MARKBIT to avoid double marking of the slot.  */
        !           843: 
        !           844:   for (i = 0; i < staticidx; i++)
        !           845:     mark_object (staticvec[i]);
        !           846:   for (tail = gcprolist; tail; tail = tail->next)
        !           847:     for (i = 0; i < tail->nvars; i++)
        !           848:       if (!XMARKBIT (tail->var[i]))
        !           849:        {
        !           850:          mark_object (&tail->var[i]);
        !           851:          XMARK (tail->var[i]);
        !           852:        }
        !           853:   for (bind = specpdl; bind != specpdl_ptr; bind++)
        !           854:     {
        !           855:       mark_object (&bind->symbol);
        !           856:       mark_object (&bind->old_value);
        !           857:     }
        !           858:   for (catch = catchlist; catch; catch = catch->next)
        !           859:     {
        !           860:       mark_object (&catch->tag);
        !           861:       mark_object (&catch->val);
        !           862:     }  
        !           863:   for (handler = handlerlist; handler; handler = handler->next)
        !           864:     {
        !           865:       mark_object (&handler->handler);
        !           866:       mark_object (&handler->var);
        !           867:     }  
        !           868:   for (backlist = backtrace_list; backlist; backlist = backlist->next)
        !           869:     {
        !           870:       if (!XMARKBIT (*backlist->function))
        !           871:        {
        !           872:          mark_object (backlist->function);
        !           873:          XMARK (*backlist->function);
        !           874:        }
        !           875:       if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
        !           876:        i = 0;
        !           877:       else
        !           878:        i = backlist->nargs - 1;
        !           879:       for (; i >= 0; i--)
        !           880:        if (!XMARKBIT (backlist->args[i]))
        !           881:          {
        !           882:            mark_object (&backlist->args[i]);
        !           883:            XMARK (backlist->args[i]);
        !           884:          }
        !           885:     }  
        !           886: 
        !           887:   gc_sweep ();
        !           888: 
        !           889:   /* Clear the mark bits that we set in certain root slots.  */
        !           890: 
        !           891:   for (tail = gcprolist; tail; tail = tail->next)
        !           892:     for (i = 0; i < tail->nvars; i++)
        !           893:       XUNMARK (tail->var[i]);
        !           894:   for (backlist = backtrace_list; backlist; backlist = backlist->next)
        !           895:     {
        !           896:       XUNMARK (*backlist->function);
        !           897:       if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
        !           898:        i = 0;
        !           899:       else
        !           900:        i = backlist->nargs - 1;
        !           901:       for (; i >= 0; i--)
        !           902:        XUNMARK (backlist->args[i]);
        !           903:     }  
        !           904:   XUNMARK (buffer_defaults.name);
        !           905:   XUNMARK (buffer_local_symbols.name);
        !           906: 
        !           907: /*  clear_marks (); */
        !           908:   gc_in_progress = 0;
        !           909: 
        !           910:   consing_since_gc = 0;
        !           911:   consing_at_last_truncate = 0;
        !           912:   if (gc_cons_threshold < 10000)
        !           913:     gc_cons_threshold = 10000;
        !           914: 
        !           915:   if (omessage)
        !           916:     message1 (omessage);
        !           917:   else if (!noninteractive)
        !           918:     message1 ("Garbage collecting...done");
        !           919: 
        !           920:   return Fcons (Fcons (make_number (total_conses),
        !           921:                       make_number (total_free_conses)),
        !           922:                Fcons (Fcons (make_number (total_symbols),
        !           923:                              make_number (total_free_symbols)),
        !           924:                       Fcons (Fcons (make_number (total_markers),
        !           925:                                     make_number (total_free_markers)),
        !           926:                              Fcons (make_number (total_string_size),
        !           927:                                     Fcons (make_number (total_vector_size),
        !           928:                                            Qnil)))));
        !           929: }
        !           930: 
        !           931: #if 0
        !           932: static void
        !           933: clear_marks ()
        !           934: {
        !           935:   /* Clear marks on all conses */
        !           936:   {
        !           937:     register struct cons_block *cblk;
        !           938:     register int lim = cons_block_index;
        !           939:   
        !           940:     for (cblk = cons_block; cblk; cblk = cblk->next)
        !           941:       {
        !           942:        register int i;
        !           943:        for (i = 0; i < lim; i++)
        !           944:          XUNMARK (cblk->conses[i].car);
        !           945:        lim = CONS_BLOCK_SIZE;
        !           946:       }
        !           947:   }
        !           948:   /* Clear marks on all symbols */
        !           949:   {
        !           950:     register struct symbol_block *sblk;
        !           951:     register int lim = symbol_block_index;
        !           952:   
        !           953:     for (sblk = symbol_block; sblk; sblk = sblk->next)
        !           954:       {
        !           955:        register int i;
        !           956:        for (i = 0; i < lim; i++)
        !           957:          {
        !           958:            XUNMARK (sblk->symbols[i].plist);
        !           959:          }
        !           960:        lim = SYMBOL_BLOCK_SIZE;
        !           961:       }
        !           962:   }
        !           963:   /* Clear marks on all markers */
        !           964:   {
        !           965:     register struct marker_block *sblk;
        !           966:     register int lim = marker_block_index;
        !           967:   
        !           968:     for (sblk = marker_block; sblk; sblk = sblk->next)
        !           969:       {
        !           970:        register int i;
        !           971:        for (i = 0; i < lim; i++)
        !           972:          XUNMARK (sblk->markers[i].chain);
        !           973:        lim = MARKER_BLOCK_SIZE;
        !           974:       }
        !           975:   }
        !           976:   /* Clear mark bits on all buffers */
        !           977:   {
        !           978:     register struct buffer *nextb = all_buffers;
        !           979: 
        !           980:     while (nextb)
        !           981:       {
        !           982:        XUNMARK (nextb->name);
        !           983:        nextb = nextb->next;
        !           984:       }
        !           985:   }
        !           986: }
        !           987: #endif
        !           988: 
        !           989: /* Mark reference to a Lisp_Object.  If the object referred to
        !           990:    has not been seen yet, recursively mark all the references contained in it.
        !           991: 
        !           992:    If the object referenced is a short string, the referrencing slot
        !           993:    is threaded into a chain of such slots, pointed to from
        !           994:    the `size' field of the string.  The actual string size
        !           995:    lives in the last slot in the chain.  We recognize the end
        !           996:    because it is < (unsigned) STRING_BLOCK_SIZE.  */
        !           997: 
        !           998: static void
        !           999: mark_object (objptr)
        !          1000:      Lisp_Object *objptr;
        !          1001: {
        !          1002:   register Lisp_Object obj;
        !          1003: 
        !          1004:   obj = *objptr;
        !          1005:   XUNMARK (obj);
        !          1006: 
        !          1007:  loop:
        !          1008: 
        !          1009:   if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
        !          1010:       && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
        !          1011:     return;
        !          1012: 
        !          1013: #ifdef SWITCH_ENUM_BUG
        !          1014:   switch ((int) XGCTYPE (obj))
        !          1015: #else
        !          1016:   switch (XGCTYPE (obj))
        !          1017: #endif
        !          1018:     {
        !          1019:     case Lisp_String:
        !          1020:       {
        !          1021:        register struct Lisp_String *ptr = XSTRING (obj);
        !          1022: 
        !          1023:        if (ptr->size & MARKBIT)
        !          1024:          /* A large string.  Just set ARRAY_MARK_FLAG.  */
        !          1025:          ptr->size |= ARRAY_MARK_FLAG;
        !          1026:        else
        !          1027:          {
        !          1028:            /* A small string.  Put this reference
        !          1029:               into the chain of references to it.
        !          1030:               The address OBJPTR is even, so if the address
        !          1031:               includes MARKBIT, put it in the low bit
        !          1032:               when we store OBJPTR into the size field.  */
        !          1033: 
        !          1034:            if (XMARKBIT (*objptr))
        !          1035:              {
        !          1036:                XFASTINT (*objptr) = ptr->size;
        !          1037:                XMARK (*objptr);
        !          1038:              }
        !          1039:            else
        !          1040:              XFASTINT (*objptr) = ptr->size;
        !          1041:            if ((int)objptr & 1) abort ();
        !          1042:            ptr->size = (int) objptr & ~MARKBIT;
        !          1043:            if ((int) objptr & MARKBIT)
        !          1044:              ptr->size ++;
        !          1045:          }
        !          1046:       }
        !          1047:       break;
        !          1048: 
        !          1049:     case Lisp_Vector:
        !          1050:     case Lisp_Window:
        !          1051:     case Lisp_Process:
        !          1052:     case Lisp_Window_Configuration:
        !          1053:       {
        !          1054:        register struct Lisp_Vector *ptr = XVECTOR (obj);
        !          1055:        register int size = ptr->size;
        !          1056:        register int i;
        !          1057: 
        !          1058:        if (size & ARRAY_MARK_FLAG) break;   /* Already marked */
        !          1059:        ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
        !          1060:        for (i = 0; i < size; i++)     /* and then mark its elements */
        !          1061:          mark_object (&ptr->contents[i]);
        !          1062:       }
        !          1063:       break;
        !          1064: 
        !          1065: #if 0
        !          1066:     case Lisp_Temp_Vector:
        !          1067:       {
        !          1068:        register struct Lisp_Vector *ptr = XVECTOR (obj);
        !          1069:        register int size = ptr->size;
        !          1070:        register int i;
        !          1071: 
        !          1072:        for (i = 0; i < size; i++)     /* and then mark its elements */
        !          1073:          mark_object (&ptr->contents[i]);
        !          1074:       }
        !          1075:       break;
        !          1076: #endif 0
        !          1077: 
        !          1078:     case Lisp_Symbol:
        !          1079:       {
        !          1080:        register struct Lisp_Symbol *ptr = XSYMBOL (obj);
        !          1081:        struct Lisp_Symbol *ptrx;
        !          1082: 
        !          1083:        if (XMARKBIT (ptr->plist)) break;
        !          1084:        XMARK (ptr->plist);
        !          1085:        XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
        !          1086:        mark_object (&ptr->name);
        !          1087:        mark_object ((Lisp_Object *) &ptr->value);
        !          1088:        mark_object (&ptr->function);
        !          1089:        mark_object (&ptr->plist);
        !          1090:        ptr = ptr->next;
        !          1091:        if (ptr)
        !          1092:          {
        !          1093:            ptrx = ptr;         /* Use pf ptrx avoids compiler bug on Sun */
        !          1094:            XSETSYMBOL (obj, ptrx);
        !          1095:            goto loop;
        !          1096:          }
        !          1097:       }
        !          1098:       break;
        !          1099: 
        !          1100:     case Lisp_Marker:
        !          1101:       XMARK (XMARKER (obj)->chain);
        !          1102:       /* DO NOT mark thru the marker's chain.
        !          1103:         The buffer's markers chain does not preserve markers from gc;
        !          1104:         instead, markers are removed from the chain when they are freed by gc. */
        !          1105:       break;
        !          1106: 
        !          1107:     case Lisp_Cons:
        !          1108:     case Lisp_Buffer_Local_Value:
        !          1109:     case Lisp_Some_Buffer_Local_Value:
        !          1110:       {
        !          1111:        register struct Lisp_Cons *ptr = XCONS (obj);
        !          1112:        if (XMARKBIT (ptr->car)) break;
        !          1113:        XMARK (ptr->car);
        !          1114:        /* If the cdr is nil, avoid recursion for the car.  */
        !          1115:        if (EQ (ptr->cdr, Qnil))
        !          1116:          {
        !          1117:            objptr = &ptr->car;
        !          1118:            obj = ptr->car;
        !          1119:            XUNMARK (obj);
        !          1120:            goto loop;
        !          1121:          }
        !          1122:        /* If the cdr is (INTEGER . nil), mark the cdr first,
        !          1123:           to avoid recursion for the car.  This case occurs
        !          1124:           in every compiled function.  */
        !          1125:        if (XTYPE (ptr->cdr) == Lisp_Cons
        !          1126:            && XGCTYPE (XCONS (ptr->cdr)->car) == Lisp_Int
        !          1127:            && EQ (XCONS (ptr->cdr)->cdr, Qnil))
        !          1128:          {
        !          1129:            mark_object (&ptr->cdr);
        !          1130:            objptr = &ptr->car;
        !          1131:            obj = ptr->car;
        !          1132:            XUNMARK (obj);
        !          1133:            goto loop;
        !          1134:          }
        !          1135:        mark_object (&ptr->car);
        !          1136:        objptr = &ptr->cdr;
        !          1137:        obj = ptr->cdr;
        !          1138:        goto loop;
        !          1139:       }
        !          1140: 
        !          1141:     case Lisp_Buffer:
        !          1142:       if (!XMARKBIT (XBUFFER (obj)->name))
        !          1143:        mark_buffer (obj);
        !          1144:       break;
        !          1145: 
        !          1146:     case Lisp_Int:
        !          1147:     case Lisp_Void:
        !          1148:     case Lisp_Subr:
        !          1149:     case Lisp_Intfwd:
        !          1150:     case Lisp_Boolfwd:
        !          1151:     case Lisp_Objfwd:
        !          1152:     case Lisp_Buffer_Objfwd:
        !          1153:     case Lisp_Internal_Stream:
        !          1154:     /* Don't bother with Lisp_Buffer_Objfwd,
        !          1155:        since all markable slots in current buffer marked anyway.  */
        !          1156:     /* Don't need to do Lisp_Objfwd, since the places they point
        !          1157:        are protected with staticpro.  */
        !          1158:       break;
        !          1159: 
        !          1160:     default:
        !          1161:       abort ();
        !          1162:     }
        !          1163: }
        !          1164: 
        !          1165: /* Mark the pointers in a buffer structure.  */
        !          1166: 
        !          1167: static void
        !          1168: mark_buffer (buf)
        !          1169:      Lisp_Object buf;
        !          1170: {
        !          1171:   Lisp_Object tem;
        !          1172:   register struct buffer *buffer = XBUFFER (buf);
        !          1173:   register Lisp_Object *ptr;
        !          1174: 
        !          1175:   /* This is the buffer's markbit */
        !          1176:   mark_object (&buffer->name);
        !          1177:   XMARK (buffer->name);
        !          1178: 
        !          1179:   for (ptr = &buffer->name + 1;
        !          1180:        (char *)ptr < (char *)buffer + sizeof (struct buffer);
        !          1181:        ptr++)
        !          1182:     mark_object (ptr);
        !          1183: }
        !          1184: 
        !          1185: /* Find all structures not marked, and free them. */
        !          1186: 
        !          1187: static void
        !          1188: gc_sweep ()
        !          1189: {
        !          1190:   total_string_size = 0;
        !          1191:   compact_strings ();
        !          1192: 
        !          1193:   /* Put all unmarked conses on free list */
        !          1194:   {
        !          1195:     register struct cons_block *cblk;
        !          1196:     register int lim = cons_block_index;
        !          1197:     register int num_free = 0, num_used = 0;
        !          1198: 
        !          1199:     cons_free_list = 0;
        !          1200:   
        !          1201:     for (cblk = cons_block; cblk; cblk = cblk->next)
        !          1202:       {
        !          1203:        register int i;
        !          1204:        for (i = 0; i < lim; i++)
        !          1205:          if (!XMARKBIT (cblk->conses[i].car))
        !          1206:            {
        !          1207:              XFASTINT (cblk->conses[i].car) = (int) cons_free_list;
        !          1208:              num_free++;
        !          1209:              cons_free_list = &cblk->conses[i];
        !          1210:            }
        !          1211:          else
        !          1212:            {
        !          1213:              num_used++;
        !          1214:              XUNMARK (cblk->conses[i].car);
        !          1215:            }
        !          1216:        lim = CONS_BLOCK_SIZE;
        !          1217:       }
        !          1218:     total_conses = num_used;
        !          1219:     total_free_conses = num_free;
        !          1220:   }
        !          1221: 
        !          1222:   /* Put all unmarked symbols on free list */
        !          1223:   {
        !          1224:     register struct symbol_block *sblk;
        !          1225:     register int lim = symbol_block_index;
        !          1226:     register int num_free = 0, num_used = 0;
        !          1227: 
        !          1228:     symbol_free_list = 0;
        !          1229:   
        !          1230:     for (sblk = symbol_block; sblk; sblk = sblk->next)
        !          1231:       {
        !          1232:        register int i;
        !          1233:        for (i = 0; i < lim; i++)
        !          1234:          if (!XMARKBIT (sblk->symbols[i].plist))
        !          1235:            {
        !          1236:              XFASTINT (sblk->symbols[i].value) = (int) symbol_free_list;
        !          1237:              symbol_free_list = &sblk->symbols[i];
        !          1238:              num_free++;
        !          1239:            }
        !          1240:          else
        !          1241:            {
        !          1242:              num_used++;
        !          1243:              sblk->symbols[i].name
        !          1244:                = XSTRING (*(Lisp_Object *) &sblk->symbols[i].name);
        !          1245:              XUNMARK (sblk->symbols[i].plist);
        !          1246:            }
        !          1247:        lim = SYMBOL_BLOCK_SIZE;
        !          1248:       }
        !          1249:     total_symbols = num_used;
        !          1250:     total_free_symbols = num_free;
        !          1251:   }
        !          1252: 
        !          1253: #ifndef standalone
        !          1254:   /* Put all unmarked markers on free list.
        !          1255:      Dechain each one first from the buffer it points into. */
        !          1256:   {
        !          1257:     register struct marker_block *mblk;
        !          1258:     struct Lisp_Marker *tem1;
        !          1259:     register int lim = marker_block_index;
        !          1260:     register int num_free = 0, num_used = 0;
        !          1261: 
        !          1262:     marker_free_list = 0;
        !          1263:   
        !          1264:     for (mblk = marker_block; mblk; mblk = mblk->next)
        !          1265:       {
        !          1266:        register int i;
        !          1267:        for (i = 0; i < lim; i++)
        !          1268:          if (!XMARKBIT (mblk->markers[i].chain))
        !          1269:            {
        !          1270:              Lisp_Object tem;
        !          1271:              tem1 = &mblk->markers[i];  /* tem1 avoids Sun compiler bug */
        !          1272:              XSET (tem, Lisp_Marker, tem1);
        !          1273:              if (tem1->buffer)
        !          1274:                unchain_marker (tem);
        !          1275:              XFASTINT (mblk->markers[i].chain) = (int) marker_free_list;
        !          1276:              marker_free_list = &mblk->markers[i];
        !          1277:              num_free++;
        !          1278:            }
        !          1279:          else
        !          1280:            {
        !          1281:              num_used++;
        !          1282:              XUNMARK (mblk->markers[i].chain);
        !          1283:            }
        !          1284:        lim = MARKER_BLOCK_SIZE;
        !          1285:       }
        !          1286: 
        !          1287:     total_markers = num_used;
        !          1288:     total_free_markers = num_free;
        !          1289:   }
        !          1290: 
        !          1291:   /* Free all unmarked buffers */
        !          1292:   {
        !          1293:     register struct buffer *buffer = all_buffers, *prev = 0, *next;
        !          1294: 
        !          1295:     while (buffer)
        !          1296:       if (!XMARKBIT (buffer->name))
        !          1297:        {
        !          1298:          if (prev)
        !          1299:            prev->next = buffer->next;
        !          1300:          else
        !          1301:            all_buffers = buffer->next;
        !          1302:          next = buffer->next;
        !          1303:          free (buffer);
        !          1304:          buffer = next;
        !          1305:        }
        !          1306:       else
        !          1307:        {
        !          1308:          XUNMARK (buffer->name);
        !          1309:          prev = buffer, buffer = buffer->next;
        !          1310:        }
        !          1311:   }
        !          1312: 
        !          1313: #endif standalone
        !          1314: 
        !          1315:   /* Free all unmarked vectors */
        !          1316:   {
        !          1317:     register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
        !          1318:     total_vector_size = 0;
        !          1319: 
        !          1320:     while (vector)
        !          1321:       if (!(vector->size & ARRAY_MARK_FLAG))
        !          1322:        {
        !          1323:          if (prev)
        !          1324:            prev->next = vector->next;
        !          1325:          else
        !          1326:            all_vectors = vector->next;
        !          1327:          next = vector->next;
        !          1328:          free (vector);
        !          1329:          vector = next;
        !          1330:        }
        !          1331:       else
        !          1332:        {
        !          1333:          vector->size &= ~ARRAY_MARK_FLAG;
        !          1334:          total_vector_size += vector->size;
        !          1335:          prev = vector, vector = vector->next;
        !          1336:        }
        !          1337:   }
        !          1338: 
        !          1339:   /* Free all "large strings" not marked with ARRAY_MARK_FLAG.  */
        !          1340:   {
        !          1341:     register struct string_block *sb = large_string_blocks, *prev = 0, *next;
        !          1342: 
        !          1343:     while (sb)
        !          1344:       if (!(((struct Lisp_String *)(&sb->chars[0]))->size & ARRAY_MARK_FLAG))
        !          1345:        {
        !          1346:          if (prev)
        !          1347:            prev->next = sb->next;
        !          1348:          else
        !          1349:            large_string_blocks = sb->next;
        !          1350:          next = sb->next;
        !          1351:          free (sb);
        !          1352:          sb = next;
        !          1353:        }
        !          1354:       else
        !          1355:        {
        !          1356:          ((struct Lisp_String *)(&sb->chars[0]))->size
        !          1357:            &= ~ARRAY_MARK_FLAG & ~MARKBIT;
        !          1358:          total_string_size += ((struct Lisp_String *)(&sb->chars[0]))->size;
        !          1359:          prev = sb, sb = sb->next;
        !          1360:        }
        !          1361:   }
        !          1362: }
        !          1363: 
        !          1364: /* Compactify strings, relocate references to them, and
        !          1365:    free any string blocks that become empty.  */
        !          1366: 
        !          1367: static void
        !          1368: compact_strings ()
        !          1369: {
        !          1370:   /* String block of old strings we are scanning.  */
        !          1371:   register struct string_block *from_sb;
        !          1372:   /* A preceding string block (or maybe the same one)
        !          1373:      where we are copying the still-live strings to.  */
        !          1374:   register struct string_block *to_sb;
        !          1375:   int pos;
        !          1376:   int to_pos;
        !          1377: 
        !          1378:   to_sb = first_string_block;
        !          1379:   to_pos = 0;
        !          1380: 
        !          1381:   /* Scan each existing string block sequentially, string by string.  */
        !          1382:   for (from_sb = first_string_block; from_sb; from_sb = from_sb->next)
        !          1383:     {
        !          1384:       pos = 0;
        !          1385:       /* POS is the index of the next string in the block.  */
        !          1386:       while (pos < from_sb->pos)
        !          1387:        {
        !          1388:          register struct Lisp_String *nextstr
        !          1389:            = (struct Lisp_String *) &from_sb->chars[pos];
        !          1390: 
        !          1391:          register struct Lisp_String *newaddr;
        !          1392:          register int size = nextstr->size;
        !          1393: 
        !          1394:          /* NEXTSTR is the old address of the next string.
        !          1395:             Just skip it if it isn't marked.  */
        !          1396:          if ((unsigned) size > STRING_BLOCK_SIZE)
        !          1397:            {
        !          1398:              /* It is marked, so its size field is really a chain of refs.
        !          1399:                 Find the end of the chain, where the actual size lives.  */
        !          1400:              while ((unsigned) size > STRING_BLOCK_SIZE)
        !          1401:                {
        !          1402:                  if (size & 1) size ^= MARKBIT | 1;
        !          1403:                  size = *(int *)size & ~MARKBIT;
        !          1404:                }
        !          1405: 
        !          1406:              total_string_size += size;
        !          1407: 
        !          1408:              /* If it won't fit in TO_SB, close it out,
        !          1409:                 and move to the next sb.  Keep doing so until
        !          1410:                 TO_SB reaches a large enough, empty enough string block.
        !          1411:                 We know that TO_SB cannot advance past FROM_SB here
        !          1412:                 since FROM_SB is large enough to contain this string.
        !          1413:                 Any string blocks skipped here
        !          1414:                 will be patched out and freed later.  */
        !          1415:              while (to_pos + STRING_FULLSIZE (size)
        !          1416:                     > max (to_sb->pos, STRING_BLOCK_SIZE))
        !          1417:                {
        !          1418:                  to_sb->pos = to_pos;
        !          1419:                  to_sb = to_sb->next;
        !          1420:                  to_pos = 0;
        !          1421:                }
        !          1422:              /* Compute new address of this string
        !          1423:                 and update TO_POS for the space being used.  */
        !          1424:              newaddr = (struct Lisp_String *) &to_sb->chars[to_pos];
        !          1425:              to_pos += STRING_FULLSIZE (size);
        !          1426: 
        !          1427:              /* Copy the string itself to the new place.  */
        !          1428:              if (nextstr != newaddr)
        !          1429:                bcopy (nextstr, newaddr, size + 1 + sizeof (int));
        !          1430: 
        !          1431:              /* Go through NEXTSTR's chain of references
        !          1432:                 and make each slot in the chain point to
        !          1433:                 the new address of this string.  */
        !          1434:              size = newaddr->size;
        !          1435:              while ((unsigned) size > STRING_BLOCK_SIZE)
        !          1436:                {
        !          1437:                  register Lisp_Object *objptr;
        !          1438:                  if (size & 1) size ^= MARKBIT | 1;
        !          1439:                  objptr = (Lisp_Object *)size;
        !          1440: 
        !          1441:                  size = XFASTINT (*objptr) & ~MARKBIT;
        !          1442:                  if (XMARKBIT (*objptr))
        !          1443:                    {
        !          1444:                      XSET (*objptr, Lisp_String, newaddr);
        !          1445:                      XMARK (*objptr);
        !          1446:                    }
        !          1447:                  else
        !          1448:                    XSET (*objptr, Lisp_String, newaddr);
        !          1449:                }
        !          1450:              /* Store the actual size in the size field.  */
        !          1451:              newaddr->size = size;
        !          1452:            }
        !          1453:          pos += STRING_FULLSIZE (size);
        !          1454:        }
        !          1455:     }
        !          1456: 
        !          1457:   /* Close out the last string block still used and free any that follow.  */
        !          1458:   to_sb->pos = to_pos;
        !          1459:   current_string_block = to_sb;
        !          1460: 
        !          1461:   from_sb = to_sb->next;
        !          1462:   to_sb->next = 0;
        !          1463:   while (from_sb)
        !          1464:     {
        !          1465:       to_sb = from_sb->next;
        !          1466:       free (from_sb);
        !          1467:       from_sb = to_sb;
        !          1468:     }
        !          1469: 
        !          1470:   /* Free any empty string blocks further back in the chain.
        !          1471:      This loop will never free first_string_block, but it is very
        !          1472:      unlikely that that one will become empty, so why bother checking?  */
        !          1473: 
        !          1474:   from_sb = first_string_block;
        !          1475:   while (to_sb = from_sb->next)
        !          1476:     {
        !          1477:       if (to_sb->pos == 0)
        !          1478:        {
        !          1479:          if (from_sb->next = to_sb->next)
        !          1480:            from_sb->next->prev = from_sb;
        !          1481:          free (to_sb);
        !          1482:        }
        !          1483:       else
        !          1484:        from_sb = to_sb;
        !          1485:     }
        !          1486: }
        !          1487: 
        !          1488: truncate_all_undos ()
        !          1489: {
        !          1490:   register struct buffer *nextb = all_buffers;
        !          1491: 
        !          1492:   consing_at_last_truncate = consing_since_gc;
        !          1493: 
        !          1494:   while (nextb)
        !          1495:     {
        !          1496:       /* If a buffer's undo list is Qt, that means that undo is
        !          1497:         turned off in that buffer.  Calling truncate_undo_list on
        !          1498:         Qt tends to return NULL, which effectively turns undo back on.
        !          1499:         So don't call truncate_undo_list if undo_list is Qt.  */
        !          1500:       if (! EQ (nextb->undo_list, Qt))
        !          1501:        nextb->undo_list 
        !          1502:          = truncate_undo_list (nextb->undo_list, undo_threshold,
        !          1503:                                undo_high_threshold);
        !          1504:       nextb = nextb->next;
        !          1505:     }
        !          1506: }
        !          1507: 
        !          1508: /* Initialization */
        !          1509: 
        !          1510: init_alloc_once ()
        !          1511: {
        !          1512:   /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
        !          1513:   pureptr = 0;
        !          1514:   all_vectors = 0;
        !          1515:   init_strings ();
        !          1516:   init_cons ();
        !          1517:   init_symbol ();
        !          1518:   init_marker ();
        !          1519:   gcprolist = 0;
        !          1520:   staticidx = 0;
        !          1521:   consing_since_gc = 0;
        !          1522:   gc_cons_threshold = 100000;
        !          1523: #ifdef VIRT_ADDR_VARIES
        !          1524:   malloc_sbrk_unused = 1<<22;  /* A large number */
        !          1525:   malloc_sbrk_used = 100000;   /* as reasonable as any number */
        !          1526: #endif /* VIRT_ADDR_VARIES */
        !          1527: }
        !          1528: 
        !          1529: init_alloc ()
        !          1530: {
        !          1531:   gcprolist = 0;
        !          1532: }
        !          1533: 
        !          1534: void
        !          1535: syms_of_alloc ()
        !          1536: {
        !          1537:   memory_exhausted_message = Fcons (build_string ("Memory exhausted"), Qnil);
        !          1538:   staticpro (&memory_exhausted_message);
        !          1539: 
        !          1540:   DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
        !          1541:     "*Number of bytes of consing between garbage collections.");
        !          1542: 
        !          1543:   DEFVAR_INT ("pure-bytes-used", &pureptr,
        !          1544:     "Number of bytes of sharable Lisp data allocated so far.");
        !          1545: 
        !          1546: #if 0
        !          1547:   DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used,
        !          1548:     "Number of bytes of unshared memory allocated in this session.");
        !          1549: 
        !          1550:   DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused,
        !          1551:     "Number of bytes of unshared memory remaining available in this session.");
        !          1552: #endif
        !          1553: 
        !          1554:   DEFVAR_LISP ("purify-flag", &Vpurify_flag,
        !          1555:     "Non-nil means loading Lisp code in order to dump an executable.");
        !          1556: 
        !          1557:   DEFVAR_INT ("undo-threshold", &undo_threshold,
        !          1558:     "Keep no more undo information once it exceeds this size.\n\
        !          1559: This threshold is applied when garbage collection happens.\n\
        !          1560: The size is counted as the number of bytes occupied,\n\
        !          1561: which includes both saved text and other data.");
        !          1562:   undo_threshold = 15000;
        !          1563:   DEFVAR_INT ("undo-high-threshold", &undo_high_threshold,
        !          1564:     "Don't keep more than this much size of undo information.\n\
        !          1565: A command which pushes past this size is itself forgotten.\n\
        !          1566: This threshold is applied when garbage collection happens.\n\
        !          1567: The size is counted as the number of bytes occupied,\n\
        !          1568: which includes both saved text and other data.");
        !          1569:   undo_high_threshold = 20000;
        !          1570: 
        !          1571:   defsubr (&Scons);
        !          1572:   defsubr (&Slist);
        !          1573:   defsubr (&Svector);
        !          1574:   defsubr (&Smake_list);
        !          1575:   defsubr (&Smake_vector);
        !          1576:   defsubr (&Smake_string);
        !          1577:   defsubr (&Smake_symbol);
        !          1578:   defsubr (&Smake_marker);
        !          1579:   defsubr (&Spurecopy);
        !          1580:   defsubr (&Sgarbage_collect);
        !          1581: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.