Return to alloc.c CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / src

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

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