XEmacs 21.2.6
[chise/xemacs-chise.git.1] / src / alloc.c
1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2    Copyright (C) 1985-1998 Free Software Foundation, Inc.
3    Copyright (C) 1995 Sun Microsystems, Inc.
4    Copyright (C) 1995, 1996 Ben Wing.
5
6 This file is part of XEmacs.
7
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING.  If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA.  */
22
23 /* Synched up with: FSF 19.28, Mule 2.0.  Substantially different from
24    FSF. */
25
26 /* Authorship:
27
28    FSF: Original version; a long time ago.
29    Mly: Significantly rewritten to use new 3-bit tags and
30         nicely abstracted object definitions, for 19.8.
31    JWZ: Improved code to keep track of purespace usage and
32         issue nice purespace and GC stats.
33    Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34         and various changes for Mule, for 19.12.
35         Added bit vectors for 19.13.
36         Added lcrecord lists for 19.14.
37    slb: Lots of work on the purification and dump time code.
38         Synched Doug Lea malloc support from Emacs 20.2.
39 */
40
41 #include <config.h>
42 #include "lisp.h"
43
44 #include "backtrace.h"
45 #include "buffer.h"
46 #include "bytecode.h"
47 #include "chartab.h"
48 #include "device.h"
49 #include "elhash.h"
50 #include "events.h"
51 #include "extents.h"
52 #include "frame.h"
53 #include "glyphs.h"
54 #include "opaque.h"
55 #include "redisplay.h"
56 #include "specifier.h"
57 #include "sysfile.h"
58 #include "window.h"
59
60 #include <stddef.h>
61
62 #ifdef DOUG_LEA_MALLOC
63 #include <malloc.h>
64 #endif
65
66 EXFUN (Fgarbage_collect, 0);
67
68 /* Return the true size of a struct with a variable-length array field.  */
69 #define STRETCHY_STRUCT_SIZEOF(stretchy_struct_type,            \
70                                stretchy_array_field,            \
71                                stretchy_array_length)           \
72   (offsetof (stretchy_struct_type, stretchy_array_field) +      \
73    (offsetof (stretchy_struct_type, stretchy_array_field[1]) -  \
74     offsetof (stretchy_struct_type, stretchy_array_field[0])) * \
75    (stretchy_array_length))
76
77 #if 0 /* this is _way_ too slow to be part of the standard debug options */
78 #if defined(DEBUG_XEMACS) && defined(MULE)
79 #define VERIFY_STRING_CHARS_INTEGRITY
80 #endif
81 #endif
82
83 /* Define this to see where all that space is going... */
84 /* But the length of the printout is obnoxious, so limit it to testers */
85 #ifdef MEMORY_USAGE_STATS
86 #define PURESTAT
87 #endif
88
89 /* Define this to use malloc/free with no freelist for all datatypes,
90    the hope being that some debugging tools may help detect
91    freed memory references */
92 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
93 #include <dmalloc.h>
94 #define ALLOC_NO_POOLS
95 #endif
96
97 #include "puresize.h"
98
99 #ifdef DEBUG_XEMACS
100 static int debug_allocation;
101 static int debug_allocation_backtrace_length;
102 #endif
103
104 /* Number of bytes of consing done since the last gc */
105 EMACS_INT consing_since_gc;
106 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
107
108 #define debug_allocation_backtrace()                            \
109 do {                                                            \
110   if (debug_allocation_backtrace_length > 0)                    \
111     debug_short_backtrace (debug_allocation_backtrace_length);  \
112 } while (0)
113
114 #ifdef DEBUG_XEMACS
115 #define INCREMENT_CONS_COUNTER(foosize, type)                   \
116   do {                                                          \
117     if (debug_allocation)                                       \
118       {                                                         \
119         stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
120         debug_allocation_backtrace ();                          \
121       }                                                         \
122     INCREMENT_CONS_COUNTER_1 (foosize);                         \
123   } while (0)
124 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type)           \
125   do {                                                          \
126     if (debug_allocation > 1)                                   \
127       {                                                         \
128         stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
129         debug_allocation_backtrace ();                          \
130       }                                                         \
131     INCREMENT_CONS_COUNTER_1 (foosize);                         \
132   } while (0)
133 #else
134 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
135 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
136   INCREMENT_CONS_COUNTER_1 (size)
137 #endif
138
139 #define DECREMENT_CONS_COUNTER(size) do {       \
140   consing_since_gc -= (size);                   \
141   if (consing_since_gc < 0)                     \
142     consing_since_gc = 0;                       \
143 } while (0)
144
145 /* Number of bytes of consing since gc before another gc should be done. */
146 EMACS_INT gc_cons_threshold;
147
148 /* Nonzero during gc */
149 int gc_in_progress;
150
151 /* Number of times GC has happened at this level or below.
152  * Level 0 is most volatile, contrary to usual convention.
153  *  (Of course, there's only one level at present) */
154 EMACS_INT gc_generation_number[1];
155
156 /* This is just for use by the printer, to allow things to print uniquely */
157 static int lrecord_uid_counter;
158
159 /* Nonzero when calling certain hooks or doing other things where
160    a GC would be bad */
161 int gc_currently_forbidden;
162
163 /* Hooks. */
164 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
165 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
166
167 /* "Garbage collecting" */
168 Lisp_Object Vgc_message;
169 Lisp_Object Vgc_pointer_glyph;
170 static CONST char gc_default_message[] = "Garbage collecting";
171 Lisp_Object Qgarbage_collecting;
172
173 #ifndef VIRT_ADDR_VARIES
174 extern
175 #endif /* VIRT_ADDR_VARIES */
176  EMACS_INT malloc_sbrk_used;
177
178 #ifndef VIRT_ADDR_VARIES
179 extern
180 #endif /* VIRT_ADDR_VARIES */
181  EMACS_INT malloc_sbrk_unused;
182
183 /* Non-zero means defun should do purecopy on the function definition */
184 int purify_flag;
185
186 #ifdef HEAP_IN_DATA
187 extern void sheap_adjust_h();
188 #endif
189
190 /* Force linker to put it into data space! */
191 EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = { (EMACS_INT) 0};
192
193 #define PUREBEG ((char *) pure)
194
195 #if 0 /* This is breathing_space in XEmacs */
196 /* Points to memory space allocated as "spare",
197    to be freed if we run out of memory.  */
198 static char *spare_memory;
199
200 /* Amount of spare memory to keep in reserve.  */
201 #define SPARE_MEMORY (1 << 14)
202 #endif
203
204 /* Index in pure at which next pure object will be allocated. */
205 static size_t pure_bytes_used;
206
207 #define PURIFIED(ptr)                           \
208 ((char *) (ptr) >= PUREBEG &&                   \
209  (char *) (ptr) <  PUREBEG + get_PURESIZE())
210
211 /* Non-zero if pure_bytes_used > get_PURESIZE();
212    accounts for excess purespace needs. */
213 static size_t pure_lossage;
214
215 #ifdef ERROR_CHECK_TYPECHECK
216
217 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
218
219 #endif
220
221 int
222 purified (Lisp_Object obj)
223 {
224   return POINTER_TYPE_P (XGCTYPE (obj)) && PURIFIED (XPNTR (obj));
225 }
226
227 size_t
228 purespace_usage (void)
229 {
230   return pure_bytes_used;
231 }
232
233 static int
234 check_purespace (size_t size)
235 {
236   if (pure_lossage)
237     {
238       pure_lossage += size;
239       return 0;
240     }
241   else if (pure_bytes_used + size > get_PURESIZE())
242     {
243       /* This can cause recursive bad behavior, we'll yell at the end */
244       /* when we're done. */
245       /* message ("\nERROR:  Pure Lisp storage exhausted!\n"); */
246       pure_lossage = size;
247       return 0;
248     }
249   else
250     return 1;
251 }
252
253
254 \f
255 #ifndef PURESTAT
256
257 #define bump_purestat(p,b) DO_NOTHING
258
259 #else /* PURESTAT */
260
261 static int purecopying_function_constants;
262
263 static size_t pure_sizeof (Lisp_Object);
264
265 /* Keep statistics on how much of what is in purespace */
266 static struct purestat
267 {
268   int nobjects;
269   int nbytes;
270   CONST char *name;
271 }
272   purestat_cons = {0, 0, "cons cells"},
273   purestat_float = {0, 0, "float objects"},
274   purestat_string_pname = {0, 0, "symbol-name strings"},
275   purestat_function = {0, 0, "compiled-function objects"},
276   purestat_opaque_instructions = {0, 0, "compiled-function instructions"},
277   purestat_vector_constants = {0, 0, "compiled-function constants vectors"},
278   purestat_string_interactive = {0, 0, "interactive strings"},
279 #ifdef I18N3
280   purestat_string_domain = {0, 0, "domain strings"},
281 #endif
282   purestat_string_documentation = {0, 0, "documentation strings"},
283   purestat_string_other_function = {0, 0, "other function strings"},
284   purestat_vector_other = {0, 0, "other vectors"},
285   purestat_string_other = {0, 0, "other strings"},
286   purestat_string_all = {0, 0, "all strings"},
287   purestat_vector_all = {0, 0, "all vectors"};
288
289 static void
290 bump_purestat (struct purestat *purestat, size_t nbytes)
291 {
292   if (pure_lossage) return;
293   purestat->nobjects += 1;
294   purestat->nbytes += nbytes;
295 }
296
297 static void
298 print_purestat (struct purestat *purestat)
299 {
300   char buf [100];
301   sprintf(buf, "%s:", purestat->name);
302   message ("   %-36s %5d  %7d  %2d%%",
303            buf,
304            purestat->nobjects,
305            purestat->nbytes,
306            (int) (purestat->nbytes / (pure_bytes_used / 100.0) + 0.5));
307 }
308 #endif /* PURESTAT */
309
310 \f
311 /* Maximum amount of C stack to save when a GC happens.  */
312
313 #ifndef MAX_SAVE_STACK
314 #define MAX_SAVE_STACK 0 /* 16000 */
315 #endif
316
317 /* Non-zero means ignore malloc warnings.  Set during initialization.  */
318 int ignore_malloc_warnings;
319
320 \f
321 static void *breathing_space;
322
323 void
324 release_breathing_space (void)
325 {
326   if (breathing_space)
327     {
328       void *tmp = breathing_space;
329       breathing_space = 0;
330       xfree (tmp);
331     }
332 }
333
334 /* malloc calls this if it finds we are near exhausting storage */
335 void
336 malloc_warning (CONST char *str)
337 {
338   if (ignore_malloc_warnings)
339     return;
340
341   warn_when_safe
342     (Qmemory, Qcritical,
343      "%s\n"
344      "Killing some buffers may delay running out of memory.\n"
345      "However, certainly by the time you receive the 95%% warning,\n"
346      "you should clean up, kill this Emacs, and start a new one.",
347      str);
348 }
349
350 /* Called if malloc returns zero */
351 DOESNT_RETURN
352 memory_full (void)
353 {
354   /* Force a GC next time eval is called.
355      It's better to loop garbage-collecting (we might reclaim enough
356      to win) than to loop beeping and barfing "Memory exhausted"
357    */
358   consing_since_gc = gc_cons_threshold + 1;
359   release_breathing_space ();
360
361   /* Flush some histories which might conceivably contain garbalogical
362      inhibitors.  */
363   if (!NILP (Fboundp (Qvalues)))
364     Fset (Qvalues, Qnil);
365   Vcommand_history = Qnil;
366
367   error ("Memory exhausted");
368 }
369
370 /* like malloc and realloc but check for no memory left, and block input. */
371
372 #ifdef xmalloc
373 #undef xmalloc
374 #endif
375
376 void *
377 xmalloc (size_t size)
378 {
379   void *val = (void *) malloc (size);
380
381   if (!val && (size != 0)) memory_full ();
382   return val;
383 }
384
385 static void *
386 xcalloc (size_t nelem, size_t elsize)
387 {
388   void *val = (void *) calloc (nelem, elsize);
389
390   if (!val && (nelem != 0)) memory_full ();
391   return val;
392 }
393
394 void *
395 xmalloc_and_zero (size_t size)
396 {
397   return xcalloc (size, sizeof (char));
398 }
399
400 #ifdef xrealloc
401 #undef xrealloc
402 #endif
403
404 void *
405 xrealloc (void *block, size_t size)
406 {
407   /* We must call malloc explicitly when BLOCK is 0, since some
408      reallocs don't do this.  */
409   void *val = (void *) (block ? realloc (block, size) : malloc (size));
410
411   if (!val && (size != 0)) memory_full ();
412   return val;
413 }
414
415 void
416 #ifdef ERROR_CHECK_MALLOC
417 xfree_1 (void *block)
418 #else
419 xfree (void *block)
420 #endif
421 {
422 #ifdef ERROR_CHECK_MALLOC
423   /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
424      error until much later on for many system mallocs, such as
425      the one that comes with Solaris 2.3.  FMH!! */
426   assert (block != (void *) 0xDEADBEEF);
427   assert (block);
428 #endif /* ERROR_CHECK_MALLOC */
429   free (block);
430 }
431
432 #ifdef ERROR_CHECK_GC
433
434 #if SIZEOF_INT == 4
435 typedef unsigned int four_byte_t;
436 #elif SIZEOF_LONG == 4
437 typedef unsigned long four_byte_t;
438 #elif SIZEOF_SHORT == 4
439 typedef unsigned short four_byte_t;
440 #else
441 What kind of strange-ass system are we running on?
442 #endif
443
444 static void
445 deadbeef_memory (void *ptr, size_t size)
446 {
447   four_byte_t *ptr4 = (four_byte_t *) ptr;
448   size_t beefs = size >> 2;
449
450   /* In practice, size will always be a multiple of four.  */
451   while (beefs--)
452     (*ptr4++) = 0xDEADBEEF;
453 }
454
455 #else /* !ERROR_CHECK_GC */
456
457
458 #define deadbeef_memory(ptr, size)
459
460 #endif /* !ERROR_CHECK_GC */
461
462 #ifdef xstrdup
463 #undef xstrdup
464 #endif
465
466 char *
467 xstrdup (CONST char *str)
468 {
469   int len = strlen (str) + 1;   /* for stupid terminating 0 */
470
471   void *val = xmalloc (len);
472   if (val == 0) return 0;
473   memcpy (val, str, len);
474   return (char *) val;
475 }
476
477 #ifdef NEED_STRDUP
478 char *
479 strdup (CONST char *s)
480 {
481   return xstrdup (s);
482 }
483 #endif /* NEED_STRDUP */
484
485 \f
486 static void *
487 allocate_lisp_storage (size_t size)
488 {
489   void *p = xmalloc (size);
490 #ifndef USE_MINIMAL_TAGBITS
491   char *lim = ((char *) p) + size;
492   Lisp_Object val;
493
494   XSETOBJ (val, Lisp_Type_Record, lim);
495   if ((char *) XPNTR (val) != lim)
496     {
497       xfree (p);
498       memory_full ();
499     }
500 #endif /* ! USE_MINIMAL_TAGBITS */
501   return p;
502 }
503
504
505 /* lrecords are chained together through their "next.v" field.
506  * After doing the mark phase, the GC will walk this linked
507  *  list and free any record which hasn't been marked.
508  */
509 static struct lcrecord_header *all_lcrecords;
510
511 void *
512 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
513 {
514   struct lcrecord_header *lcheader;
515
516 #ifdef ERROR_CHECK_GC
517   if (implementation->static_size == 0)
518     assert (implementation->size_in_bytes_method);
519   else
520     assert (implementation->static_size == size);
521 #endif
522
523   lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
524   set_lheader_implementation (&(lcheader->lheader), implementation);
525   lcheader->next = all_lcrecords;
526 #if 1                           /* mly prefers to see small ID numbers */
527   lcheader->uid = lrecord_uid_counter++;
528 #else                           /* jwz prefers to see real addrs */
529   lcheader->uid = (int) &lcheader;
530 #endif
531   lcheader->free = 0;
532   all_lcrecords = lcheader;
533   INCREMENT_CONS_COUNTER (size, implementation->name);
534   return lcheader;
535 }
536
537 #if 0 /* Presently unused */
538 /* Very, very poor man's EGC?
539  * This may be slow and thrash pages all over the place.
540  *  Only call it if you really feel you must (and if the
541  *  lrecord was fairly recently allocated).
542  * Otherwise, just let the GC do its job -- that's what it's there for
543  */
544 void
545 free_lcrecord (struct lcrecord_header *lcrecord)
546 {
547   if (all_lcrecords == lcrecord)
548     {
549       all_lcrecords = lcrecord->next;
550     }
551   else
552     {
553       struct lrecord_header *header = all_lcrecords;
554       for (;;)
555         {
556           struct lrecord_header *next = header->next;
557           if (next == lcrecord)
558             {
559               header->next = lrecord->next;
560               break;
561             }
562           else if (next == 0)
563             abort ();
564           else
565             header = next;
566         }
567     }
568   if (lrecord->implementation->finalizer)
569     lrecord->implementation->finalizer (lrecord, 0);
570   xfree (lrecord);
571   return;
572 }
573 #endif /* Unused */
574
575
576 static void
577 disksave_object_finalization_1 (void)
578 {
579   struct lcrecord_header *header;
580
581   for (header = all_lcrecords; header; header = header->next)
582     {
583       if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
584           !header->free)
585         ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
586          (header, 1));
587     }
588 }
589
590
591 /* This must not be called -- it just serves as for EQ test
592  *  If lheader->implementation->finalizer is this_marks_a_marked_record,
593  *  then lrecord has been marked by the GC sweeper
594  * header->implementation is put back to its correct value by
595  *  sweep_records */
596 void
597 this_marks_a_marked_record (void *dummy0, int dummy1)
598 {
599   abort ();
600 }
601
602 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
603    in CONST space and you get SEGV's if you attempt to mark them.
604    This sits in lheader->implementation->marker. */
605
606 Lisp_Object
607 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
608 {
609   abort ();
610   return Qnil;
611 }
612
613 /* XGCTYPE for records */
614 int
615 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
616 {
617   CONST struct lrecord_implementation *imp;
618
619   if (XGCTYPE (frob) != Lisp_Type_Record)
620     return 0;
621
622   imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
623 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
624   return imp == type;
625 #else
626   return imp == type || imp == type + 1;
627 #endif
628 }
629
630 \f
631 /************************************************************************/
632 /*                        Debugger support                              */
633 /************************************************************************/
634 /* Give gdb/dbx enough information to decode Lisp Objects.
635    We make sure certain symbols are defined, so gdb doesn't complain
636    about expressions in src/gdbinit.  Values are randomly chosen.
637    See src/gdbinit or src/dbxrc to see how this is used.  */
638
639 enum dbg_constants
640 {
641 #ifdef USE_MINIMAL_TAGBITS
642   dbg_valmask = (EMACS_INT) (((1UL << VALBITS) - 1) << GCBITS),
643   dbg_typemask = (EMACS_INT) ((1UL << GCTYPEBITS) - 1),
644   dbg_USE_MINIMAL_TAGBITS = 1,
645   dbg_Lisp_Type_Int = 100,
646 #else /* ! USE_MIMIMAL_TAGBITS */
647   dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1),
648   dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)),
649   dbg_USE_MINIMAL_TAGBITS = 0,
650   dbg_Lisp_Type_Int = Lisp_Type_Int,
651 #endif /* ! USE_MIMIMAL_TAGBITS */
652
653 #ifdef USE_UNION_TYPE
654   dbg_USE_UNION_TYPE = 1,
655 #else
656   dbg_USE_UNION_TYPE = 0,
657 #endif
658
659 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
660   dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1,
661 #else
662   dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
663 #endif
664
665   dbg_Lisp_Type_Char = Lisp_Type_Char,
666   dbg_Lisp_Type_Record = Lisp_Type_Record,
667 #ifdef LRECORD_CONS
668   dbg_Lisp_Type_Cons = 101,
669 #else
670   dbg_Lisp_Type_Cons = Lisp_Type_Cons,
671   lrecord_cons = 201,
672 #endif
673 #ifdef LRECORD_STRING
674   dbg_Lisp_Type_String = 102,
675 #else
676   dbg_Lisp_Type_String = Lisp_Type_String,
677   lrecord_string = 202,
678 #endif
679 #ifdef LRECORD_VECTOR
680   dbg_Lisp_Type_Vector = 103,
681 #else
682   dbg_Lisp_Type_Vector = Lisp_Type_Vector,
683   lrecord_vector = 203,
684 #endif
685 #ifdef LRECORD_SYMBOL
686   dbg_Lisp_Type_Symbol = 104,
687 #else
688   dbg_Lisp_Type_Symbol = Lisp_Type_Symbol,
689   lrecord_symbol = 204,
690 #endif
691 #ifndef MULE
692   lrecord_char_table_entry = 205,
693   lrecord_charset          = 206,
694   lrecord_coding_system    = 207,
695 #endif
696 #ifndef HAVE_TOOLBARS
697   lrecord_toolbar_button   = 208,
698 #endif
699 #ifndef HAVE_TOOLTALK
700   lrecord_tooltalk_message = 210,
701   lrecord_tooltalk_pattern = 211,
702 #endif
703 #ifndef HAVE_DATABASE
704   lrecord_database = 212,
705 #endif
706   dbg_valbits = VALBITS,
707   dbg_gctypebits = GCTYPEBITS
708   /* If we don't have an actual object of this enum, pgcc (and perhaps
709      other compilers) might optimize away the entire type declaration :-( */
710 } dbg_dummy;
711
712 /* A few macros turned into functions for ease of debugging.
713    Debuggers don't know about macros! */
714 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
715 int
716 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
717 {
718   return EQ (obj1, obj2);
719 }
720
721 \f
722 /************************************************************************/
723 /*                        Fixed-size type macros                        */
724 /************************************************************************/
725
726 /* For fixed-size types that are commonly used, we malloc() large blocks
727    of memory at a time and subdivide them into chunks of the correct
728    size for an object of that type.  This is more efficient than
729    malloc()ing each object separately because we save on malloc() time
730    and overhead due to the fewer number of malloc()ed blocks, and
731    also because we don't need any extra pointers within each object
732    to keep them threaded together for GC purposes.  For less common
733    (and frequently large-size) types, we use lcrecords, which are
734    malloc()ed individually and chained together through a pointer
735    in the lcrecord header.  lcrecords do not need to be fixed-size
736    (i.e. two objects of the same type need not have the same size;
737    however, the size of a particular object cannot vary dynamically).
738    It is also much easier to create a new lcrecord type because no
739    additional code needs to be added to alloc.c.  Finally, lcrecords
740    may be more efficient when there are only a small number of them.
741
742    The types that are stored in these large blocks (or "frob blocks")
743    are cons, float, compiled-function, symbol, marker, extent, event,
744    and string.
745
746    Note that strings are special in that they are actually stored in
747    two parts: a structure containing information about the string, and
748    the actual data associated with the string.  The former structure
749    (a struct Lisp_String) is a fixed-size structure and is managed the
750    same way as all the other such types.  This structure contains a
751    pointer to the actual string data, which is stored in structures of
752    type struct string_chars_block.  Each string_chars_block consists
753    of a pointer to a struct Lisp_String, followed by the data for that
754    string, followed by another pointer to a struct Lisp_String,
755    followed by the data for that string, etc.  At GC time, the data in
756    these blocks is compacted by searching sequentially through all the
757    blocks and compressing out any holes created by unmarked strings.
758    Strings that are more than a certain size (bigger than the size of
759    a string_chars_block, although something like half as big might
760    make more sense) are malloc()ed separately and not stored in
761    string_chars_blocks.  Furthermore, no one string stretches across
762    two string_chars_blocks.
763
764    Vectors are each malloc()ed separately, similar to lcrecords.
765
766    In the following discussion, we use conses, but it applies equally
767    well to the other fixed-size types.
768
769    We store cons cells inside of cons_blocks, allocating a new
770    cons_block with malloc() whenever necessary.  Cons cells reclaimed
771    by GC are put on a free list to be reallocated before allocating
772    any new cons cells from the latest cons_block.  Each cons_block is
773    just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
774    the versions in malloc.c and gmalloc.c) really allocates in units
775    of powers of two and uses 4 bytes for its own overhead.
776
777    What GC actually does is to search through all the cons_blocks,
778    from the most recently allocated to the oldest, and put all
779    cons cells that are not marked (whether or not they're already
780    free) on a cons_free_list.  The cons_free_list is a stack, and
781    so the cons cells in the oldest-allocated cons_block end up
782    at the head of the stack and are the first to be reallocated.
783    If any cons_block is entirely free, it is freed with free()
784    and its cons cells removed from the cons_free_list.  Because
785    the cons_free_list ends up basically in memory order, we have
786    a high locality of reference (assuming a reasonable turnover
787    of allocating and freeing) and have a reasonable probability
788    of entirely freeing up cons_blocks that have been more recently
789    allocated.  This stage is called the "sweep stage" of GC, and
790    is executed after the "mark stage", which involves starting
791    from all places that are known to point to in-use Lisp objects
792    (e.g. the obarray, where are all symbols are stored; the
793    current catches and condition-cases; the backtrace list of
794    currently executing functions; the gcpro list; etc.) and
795    recursively marking all objects that are accessible.
796
797    At the beginning of the sweep stage, the conses in the cons
798    blocks are in one of three states: in use and marked, in use
799    but not marked, and not in use (already freed).  Any conses
800    that are marked have been marked in the mark stage just
801    executed, because as part of the sweep stage we unmark any
802    marked objects.  The way we tell whether or not a cons cell
803    is in use is through the FREE_STRUCT_P macro.  This basically
804    looks at the first 4 bytes (or however many bytes a pointer
805    fits in) to see if all the bits in those bytes are 1.  The
806    resulting value (0xFFFFFFFF) is not a valid pointer and is
807    not a valid Lisp_Object.  All current fixed-size types have
808    a pointer or Lisp_Object as their first element with the
809    exception of strings; they have a size value, which can
810    never be less than zero, and so 0xFFFFFFFF is invalid for
811    strings as well.  Now assuming that a cons cell is in use,
812    the way we tell whether or not it is marked is to look at
813    the mark bit of its car (each Lisp_Object has one bit
814    reserved as a mark bit, in case it's needed).  Note that
815    different types of objects use different fields to indicate
816    whether the object is marked, but the principle is the same.
817
818    Conses on the free_cons_list are threaded through a pointer
819    stored in the bytes directly after the bytes that are set
820    to 0xFFFFFFFF (we cannot overwrite these because the cons
821    is still in a cons_block and needs to remain marked as
822    not in use for the next time that GC happens).  This
823    implies that all fixed-size types must be at least big
824    enough to store two pointers, which is indeed the case
825    for all current fixed-size types.
826
827    Some types of objects need additional "finalization" done
828    when an object is converted from in use to not in use;
829    this is the purpose of the ADDITIONAL_FREE_type macro.
830    For example, markers need to be removed from the chain
831    of markers that is kept in each buffer.  This is because
832    markers in a buffer automatically disappear if the marker
833    is no longer referenced anywhere (the same does not
834    apply to extents, however).
835
836    WARNING: Things are in an extremely bizarre state when
837    the ADDITIONAL_FREE_type macros are called, so beware!
838
839    When ERROR_CHECK_GC is defined, we do things differently
840    so as to maximize our chances of catching places where
841    there is insufficient GCPROing.  The thing we want to
842    avoid is having an object that we're using but didn't
843    GCPRO get freed by GC and then reallocated while we're
844    in the process of using it -- this will result in something
845    seemingly unrelated getting trashed, and is extremely
846    difficult to track down.  If the object gets freed but
847    not reallocated, we can usually catch this because we
848    set all bytes of a freed object to 0xDEADBEEF. (The
849    first four bytes, however, are 0xFFFFFFFF, and the next
850    four are a pointer used to chain freed objects together;
851    we play some tricks with this pointer to make it more
852    bogus, so crashes are more likely to occur right away.)
853
854    We want freed objects to stay free as long as possible,
855    so instead of doing what we do above, we maintain the
856    free objects in a first-in first-out queue.  We also
857    don't recompute the free list each GC, unlike above;
858    this ensures that the queue ordering is preserved.
859    [This means that we are likely to have worse locality
860    of reference, and that we can never free a frob block
861    once it's allocated. (Even if we know that all cells
862    in it are free, there's no easy way to remove all those
863    cells from the free list because the objects on the
864    free list are unlikely to be in memory order.)]
865    Furthermore, we never take objects off the free list
866    unless there's a large number (usually 1000, but
867    varies depending on type) of them already on the list.
868    This way, we ensure that an object that gets freed will
869    remain free for the next 1000 (or whatever) times that
870    an object of that type is allocated.
871 */
872
873 #ifndef MALLOC_OVERHEAD
874 #ifdef GNU_MALLOC
875 #define MALLOC_OVERHEAD 0
876 #elif defined (rcheck)
877 #define MALLOC_OVERHEAD 20
878 #else
879 #define MALLOC_OVERHEAD 8
880 #endif
881 #endif /* MALLOC_OVERHEAD */
882
883 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
884 /* If we released our reserve (due to running out of memory),
885    and we have a fair amount free once again,
886    try to set aside another reserve in case we run out once more.
887
888    This is called when a relocatable block is freed in ralloc.c.  */
889 void refill_memory_reserve (void);
890 void
891 refill_memory_reserve ()
892 {
893   if (breathing_space == 0)
894     breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
895 }
896 #endif
897
898 #ifdef ALLOC_NO_POOLS
899 # define TYPE_ALLOC_SIZE(type, structtype) 1
900 #else
901 # define TYPE_ALLOC_SIZE(type, structtype)                      \
902     ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *))  \
903      / sizeof (structtype))
904 #endif /* ALLOC_NO_POOLS */
905
906 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype)      \
907                                                         \
908 struct type##_block                                     \
909 {                                                       \
910   struct type##_block *prev;                            \
911   structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
912 };                                                      \
913                                                         \
914 static struct type##_block *current_##type##_block;     \
915 static int current_##type##_block_index;                \
916                                                         \
917 static structtype *type##_free_list;                    \
918 static structtype *type##_free_list_tail;               \
919                                                         \
920 static void                                             \
921 init_##type##_alloc (void)                              \
922 {                                                       \
923   current_##type##_block = 0;                           \
924   current_##type##_block_index =                        \
925     countof (current_##type##_block->block);            \
926   type##_free_list = 0;                                 \
927   type##_free_list_tail = 0;                            \
928 }                                                       \
929                                                         \
930 static int gc_count_num_##type##_in_use;                \
931 static int gc_count_num_##type##_freelist
932
933 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do {               \
934   if (current_##type##_block_index                                      \
935       == countof (current_##type##_block->block))                       \
936     {                                                                   \
937       struct type##_block *AFTFB_new = (struct type##_block *)          \
938         allocate_lisp_storage (sizeof (struct type##_block));           \
939       AFTFB_new->prev = current_##type##_block;                         \
940       current_##type##_block = AFTFB_new;                               \
941       current_##type##_block_index = 0;                                 \
942     }                                                                   \
943   (result) =                                                            \
944     &(current_##type##_block->block[current_##type##_block_index++]);   \
945 } while (0)
946
947 /* Allocate an instance of a type that is stored in blocks.
948    TYPE is the "name" of the type, STRUCTTYPE is the corresponding
949    structure type. */
950
951 #ifdef ERROR_CHECK_GC
952
953 /* Note: if you get crashes in this function, suspect incorrect calls
954    to free_cons() and friends.  This happened once because the cons
955    cell was not GC-protected and was getting collected before
956    free_cons() was called. */
957
958 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result)                  \
959 do                                                                       \
960 {                                                                        \
961   if (gc_count_num_##type##_freelist >                                   \
962       MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type)                           \
963     {                                                                    \
964       result = type##_free_list;                                         \
965       /* Before actually using the chain pointer, we complement all its  \
966          bits; see FREE_FIXED_TYPE(). */                                 \
967       type##_free_list =                                                 \
968         (structtype *) ~(unsigned long)                                  \
969           (* (structtype **) ((char *) result + sizeof (void *)));       \
970       gc_count_num_##type##_freelist--;                                  \
971     }                                                                    \
972   else                                                                   \
973     ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result);                       \
974   MARK_STRUCT_AS_NOT_FREE (result);                                      \
975 } while (0)
976
977 #else /* !ERROR_CHECK_GC */
978
979 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result)         \
980 do                                                              \
981 {                                                               \
982   if (type##_free_list)                                         \
983     {                                                           \
984       result = type##_free_list;                                \
985       type##_free_list =                                        \
986         * (structtype **) ((char *) result + sizeof (void *));  \
987     }                                                           \
988   else                                                          \
989     ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result);              \
990   MARK_STRUCT_AS_NOT_FREE (result);                             \
991 } while (0)
992
993 #endif /* !ERROR_CHECK_GC */
994
995 #define ALLOCATE_FIXED_TYPE(type, structtype, result)   \
996 do                                                      \
997 {                                                       \
998   ALLOCATE_FIXED_TYPE_1 (type, structtype, result);     \
999   INCREMENT_CONS_COUNTER (sizeof (structtype), #type);  \
1000 } while (0)
1001
1002 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result)   \
1003 do                                                              \
1004 {                                                               \
1005   ALLOCATE_FIXED_TYPE_1 (type, structtype, result);             \
1006   NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type);  \
1007 } while (0)
1008
1009 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
1010    to a Lisp object and invalid as an actual Lisp_Object value.  We have
1011    to make sure that this value cannot be an integer in Lisp_Object form.
1012    0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
1013    On a 32-bit system, the type bits will be non-zero, making the value
1014    be a pointer, and the pointer will be misaligned.
1015
1016    Even if Emacs is run on some weirdo system that allows and allocates
1017    byte-aligned pointers, this pointer is at the very top of the address
1018    space and so it's almost inconceivable that it could ever be valid. */
1019
1020 #if INTBITS == 32
1021 # define INVALID_POINTER_VALUE 0xFFFFFFFF
1022 #elif INTBITS == 48
1023 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
1024 #elif INTBITS == 64
1025 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
1026 #else
1027 You have some weird system and need to supply a reasonable value here.
1028 #endif
1029
1030 #define FREE_STRUCT_P(ptr) \
1031   (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
1032 #define MARK_STRUCT_AS_FREE(ptr) \
1033   (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
1034 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
1035   (* (void **) ptr = 0)
1036
1037 #ifdef ERROR_CHECK_GC
1038
1039 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr)              \
1040 do { if (type##_free_list_tail)                                         \
1041        {                                                                \
1042          /* When we store the chain pointer, we complement all          \
1043             its bits; this should significantly increase its            \
1044             bogosity in case someone tries to use the value, and        \
1045             should make us dump faster if someone stores something      \
1046             over the pointer because when it gets un-complemented in    \
1047             ALLOCATED_FIXED_TYPE(), the resulting pointer will be       \
1048             extremely bogus. */                                         \
1049          * (structtype **)                                              \
1050            ((char *) type##_free_list_tail + sizeof (void *)) =         \
1051              (structtype *) ~(unsigned long) ptr;                       \
1052        }                                                                \
1053      else                                                               \
1054        type##_free_list = ptr;                                          \
1055      type##_free_list_tail = ptr;                                       \
1056    } while (0)
1057
1058 #else /* !ERROR_CHECK_GC */
1059
1060 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr)      \
1061 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) =     \
1062        type##_free_list;                                        \
1063      type##_free_list = (ptr);                                  \
1064    } while (0)
1065
1066 #endif /* !ERROR_CHECK_GC */
1067
1068 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
1069
1070 #define FREE_FIXED_TYPE(type, structtype, ptr) do {             \
1071   structtype *FFT_ptr = (ptr);                                  \
1072   ADDITIONAL_FREE_##type (FFT_ptr);                             \
1073   deadbeef_memory (FFT_ptr, sizeof (structtype));               \
1074   PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr);      \
1075   MARK_STRUCT_AS_FREE (FFT_ptr);                                \
1076 } while (0)
1077
1078 /* Like FREE_FIXED_TYPE() but used when we are explicitly
1079    freeing a structure through free_cons(), free_marker(), etc.
1080    rather than through the normal process of sweeping.
1081    We attempt to undo the changes made to the allocation counters
1082    as a result of this structure being allocated.  This is not
1083    completely necessary but helps keep things saner: e.g. this way,
1084    repeatedly allocating and freeing a cons will not result in
1085    the consing-since-gc counter advancing, which would cause a GC
1086    and somewhat defeat the purpose of explicitly freeing. */
1087
1088 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)   \
1089 do { FREE_FIXED_TYPE (type, structtype, ptr);                   \
1090      DECREMENT_CONS_COUNTER (sizeof (structtype));              \
1091      gc_count_num_##type##_freelist++;                          \
1092    } while (0)
1093
1094
1095 \f
1096 /************************************************************************/
1097 /*                         Cons allocation                              */
1098 /************************************************************************/
1099
1100 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
1101 /* conses are used and freed so often that we set this really high */
1102 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
1103 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
1104
1105 #ifdef LRECORD_CONS
1106 static Lisp_Object
1107 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1108 {
1109   if (GC_NILP (XCDR (obj)))
1110     return XCAR (obj);
1111
1112   markobj (XCAR (obj));
1113   return XCDR (obj);
1114 }
1115
1116 static int
1117 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1118 {
1119   while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1120     {
1121       ob1 = XCDR (ob1);
1122       ob2 = XCDR (ob2);
1123       if (! CONSP (ob1) || ! CONSP (ob2))
1124         return internal_equal (ob1, ob2, depth + 1);
1125     }
1126   return 0;
1127 }
1128
1129 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
1130                                      mark_cons, print_cons, 0,
1131                                      cons_equal,
1132                                      /*
1133                                       * No `hash' method needed.
1134                                       * internal_hash knows how to
1135                                       * handle conses.
1136                                       */
1137                                      0,
1138                                      struct Lisp_Cons);
1139 #endif /* LRECORD_CONS */
1140
1141 DEFUN ("cons", Fcons, 2, 2, 0, /*
1142 Create a new cons, give it CAR and CDR as components, and return it.
1143 */
1144        (car, cdr))
1145 {
1146   /* This cannot GC. */
1147   Lisp_Object val;
1148   struct Lisp_Cons *c;
1149
1150   ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1151 #ifdef LRECORD_CONS
1152   set_lheader_implementation (&(c->lheader), lrecord_cons);
1153 #endif
1154   XSETCONS (val, c);
1155   c->car = car;
1156   c->cdr = cdr;
1157   return val;
1158 }
1159
1160 /* This is identical to Fcons() but it used for conses that we're
1161    going to free later, and is useful when trying to track down
1162    "real" consing. */
1163 Lisp_Object
1164 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1165 {
1166   Lisp_Object val;
1167   struct Lisp_Cons *c;
1168
1169   NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1170 #ifdef LRECORD_CONS
1171   set_lheader_implementation (&(c->lheader), lrecord_cons);
1172 #endif
1173   XSETCONS (val, c);
1174   XCAR (val) = car;
1175   XCDR (val) = cdr;
1176   return val;
1177 }
1178
1179 DEFUN ("list", Flist, 0, MANY, 0, /*
1180 Return a newly created list with specified arguments as elements.
1181 Any number of arguments, even zero arguments, are allowed.
1182 */
1183        (int nargs, Lisp_Object *args))
1184 {
1185   Lisp_Object val = Qnil;
1186   Lisp_Object *argp = args + nargs;
1187
1188   while (argp > args)
1189     val = Fcons (*--argp, val);
1190   return val;
1191 }
1192
1193 Lisp_Object
1194 list1 (Lisp_Object obj0)
1195 {
1196   /* This cannot GC. */
1197   return Fcons (obj0, Qnil);
1198 }
1199
1200 Lisp_Object
1201 list2 (Lisp_Object obj0, Lisp_Object obj1)
1202 {
1203   /* This cannot GC. */
1204   return Fcons (obj0, Fcons (obj1, Qnil));
1205 }
1206
1207 Lisp_Object
1208 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1209 {
1210   /* This cannot GC. */
1211   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1212 }
1213
1214 Lisp_Object
1215 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1216 {
1217   /* This cannot GC. */
1218   return Fcons (obj0, Fcons (obj1, obj2));
1219 }
1220
1221 Lisp_Object
1222 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1223 {
1224   return Fcons (Fcons (key, value), alist);
1225 }
1226
1227 Lisp_Object
1228 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1229 {
1230   /* This cannot GC. */
1231   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1232 }
1233
1234 Lisp_Object
1235 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1236        Lisp_Object obj4)
1237 {
1238   /* This cannot GC. */
1239   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1240 }
1241
1242 Lisp_Object
1243 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1244        Lisp_Object obj4, Lisp_Object obj5)
1245 {
1246   /* This cannot GC. */
1247   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1248 }
1249
1250 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1251 Return a new list of length LENGTH, with each element being INIT.
1252 */
1253        (length, init))
1254 {
1255   CHECK_NATNUM (length);
1256
1257   {
1258     Lisp_Object val = Qnil;
1259     int size = XINT (length);
1260
1261     while (size-- > 0)
1262       val = Fcons (init, val);
1263     return val;
1264   }
1265 }
1266
1267 \f
1268 /************************************************************************/
1269 /*                        Float allocation                              */
1270 /************************************************************************/
1271
1272 #ifdef LISP_FLOAT_TYPE
1273
1274 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1275 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1276
1277 Lisp_Object
1278 make_float (double float_value)
1279 {
1280   Lisp_Object val;
1281   struct Lisp_Float *f;
1282
1283   ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1284   set_lheader_implementation (&(f->lheader), lrecord_float);
1285   float_data (f) = float_value;
1286   XSETFLOAT (val, f);
1287   return val;
1288 }
1289
1290 #endif /* LISP_FLOAT_TYPE */
1291
1292 \f
1293 /************************************************************************/
1294 /*                         Vector allocation                            */
1295 /************************************************************************/
1296
1297 #ifdef LRECORD_VECTOR
1298 static Lisp_Object
1299 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1300 {
1301   Lisp_Vector *ptr = XVECTOR (obj);
1302   int len = vector_length (ptr);
1303   int i;
1304
1305   for (i = 0; i < len - 1; i++)
1306     markobj (ptr->contents[i]);
1307   return (len > 0) ? ptr->contents[len - 1] : Qnil;
1308 }
1309
1310 static size_t
1311 size_vector (CONST void *lheader)
1312 {
1313   return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1314                                  ((Lisp_Vector *) lheader)->size);
1315 }
1316
1317 static int
1318 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1319 {
1320   int len = XVECTOR_LENGTH (obj1);
1321   if (len != XVECTOR_LENGTH (obj2))
1322     return 0;
1323
1324   {
1325     Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1326     Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1327     while (len--)
1328       if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1329         return 0;
1330   }
1331   return 1;
1332 }
1333
1334 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1335                                        mark_vector, print_vector, 0,
1336                                        vector_equal,
1337                                        /*
1338                                         * No `hash' method needed for
1339                                         * vectors.  internal_hash
1340                                         * knows how to handle vectors.
1341                                         */
1342                                        0,
1343                                        size_vector, Lisp_Vector);
1344
1345 /* #### should allocate `small' vectors from a frob-block */
1346 static Lisp_Vector *
1347 make_vector_internal (size_t sizei)
1348 {
1349   /* no vector_next */
1350   size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1351   Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
1352
1353   p->size = sizei;
1354   return p;
1355 }
1356
1357 #else /* ! LRECORD_VECTOR */
1358
1359 static Lisp_Object all_vectors;
1360
1361 /* #### should allocate `small' vectors from a frob-block */
1362 static Lisp_Vector *
1363 make_vector_internal (size_t sizei)
1364 {
1365   /* + 1 to account for vector_next */
1366   size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei+1);
1367   Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem);
1368
1369   INCREMENT_CONS_COUNTER (sizem, "vector");
1370
1371   p->size = sizei;
1372   vector_next (p) = all_vectors;
1373   XSETVECTOR (all_vectors, p);
1374   return p;
1375 }
1376
1377 #endif /* ! LRECORD_VECTOR */
1378
1379 Lisp_Object
1380 make_vector (size_t length, Lisp_Object init)
1381 {
1382   Lisp_Vector *vecp = make_vector_internal (length);
1383   Lisp_Object *p = vector_data (vecp);
1384
1385   while (length--)
1386     *p++ = init;
1387
1388   {
1389     Lisp_Object vector;
1390     XSETVECTOR (vector, vecp);
1391     return vector;
1392   }
1393 }
1394
1395 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1396 Return a new vector of length LENGTH, with each element being INIT.
1397 See also the function `vector'.
1398 */
1399        (length, init))
1400 {
1401   CONCHECK_NATNUM (length);
1402   return make_vector (XINT (length), init);
1403 }
1404
1405 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1406 Return a newly created vector with specified arguments as elements.
1407 Any number of arguments, even zero arguments, are allowed.
1408 */
1409        (int nargs, Lisp_Object *args))
1410 {
1411   Lisp_Vector *vecp = make_vector_internal (nargs);
1412   Lisp_Object *p = vector_data (vecp);
1413
1414   while (nargs--)
1415     *p++ = *args++;
1416
1417   {
1418     Lisp_Object vector;
1419     XSETVECTOR (vector, vecp);
1420     return vector;
1421   }
1422 }
1423
1424 Lisp_Object
1425 vector1 (Lisp_Object obj0)
1426 {
1427   return Fvector (1, &obj0);
1428 }
1429
1430 Lisp_Object
1431 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1432 {
1433   Lisp_Object args[2];
1434   args[0] = obj0;
1435   args[1] = obj1;
1436   return Fvector (2, args);
1437 }
1438
1439 Lisp_Object
1440 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1441 {
1442   Lisp_Object args[3];
1443   args[0] = obj0;
1444   args[1] = obj1;
1445   args[2] = obj2;
1446   return Fvector (3, args);
1447 }
1448
1449 #if 0 /* currently unused */
1450
1451 Lisp_Object
1452 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1453          Lisp_Object obj3)
1454 {
1455   Lisp_Object args[4];
1456   args[0] = obj0;
1457   args[1] = obj1;
1458   args[2] = obj2;
1459   args[3] = obj3;
1460   return Fvector (4, args);
1461 }
1462
1463 Lisp_Object
1464 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1465          Lisp_Object obj3, Lisp_Object obj4)
1466 {
1467   Lisp_Object args[5];
1468   args[0] = obj0;
1469   args[1] = obj1;
1470   args[2] = obj2;
1471   args[3] = obj3;
1472   args[4] = obj4;
1473   return Fvector (5, args);
1474 }
1475
1476 Lisp_Object
1477 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1478          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1479 {
1480   Lisp_Object args[6];
1481   args[0] = obj0;
1482   args[1] = obj1;
1483   args[2] = obj2;
1484   args[3] = obj3;
1485   args[4] = obj4;
1486   args[5] = obj5;
1487   return Fvector (6, args);
1488 }
1489
1490 Lisp_Object
1491 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1492          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1493          Lisp_Object obj6)
1494 {
1495   Lisp_Object args[7];
1496   args[0] = obj0;
1497   args[1] = obj1;
1498   args[2] = obj2;
1499   args[3] = obj3;
1500   args[4] = obj4;
1501   args[5] = obj5;
1502   args[6] = obj6;
1503   return Fvector (7, args);
1504 }
1505
1506 Lisp_Object
1507 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1508          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1509          Lisp_Object obj6, Lisp_Object obj7)
1510 {
1511   Lisp_Object args[8];
1512   args[0] = obj0;
1513   args[1] = obj1;
1514   args[2] = obj2;
1515   args[3] = obj3;
1516   args[4] = obj4;
1517   args[5] = obj5;
1518   args[6] = obj6;
1519   args[7] = obj7;
1520   return Fvector (8, args);
1521 }
1522 #endif /* unused */
1523
1524 /************************************************************************/
1525 /*                       Bit Vector allocation                          */
1526 /************************************************************************/
1527
1528 static Lisp_Object all_bit_vectors;
1529
1530 /* #### should allocate `small' bit vectors from a frob-block */
1531 static struct Lisp_Bit_Vector *
1532 make_bit_vector_internal (size_t sizei)
1533 {
1534   size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1535   size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1536   Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1537   set_lheader_implementation (&(p->lheader), lrecord_bit_vector);
1538
1539   INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1540
1541   bit_vector_length (p) = sizei;
1542   bit_vector_next   (p) = all_bit_vectors;
1543   /* make sure the extra bits in the last long are 0; the calling
1544      functions might not set them. */
1545   p->bits[num_longs - 1] = 0;
1546   XSETBIT_VECTOR (all_bit_vectors, p);
1547   return p;
1548 }
1549
1550 Lisp_Object
1551 make_bit_vector (size_t length, Lisp_Object init)
1552 {
1553   struct Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1554   size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1555
1556   CHECK_BIT (init);
1557
1558   if (ZEROP (init))
1559     memset (p->bits, 0, num_longs * sizeof (long));
1560   else
1561     {
1562       size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1563       memset (p->bits, ~0, num_longs * sizeof (long));
1564       /* But we have to make sure that the unused bits in the
1565          last long are 0, so that equal/hash is easy. */
1566       if (bits_in_last)
1567         p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1568     }
1569
1570   {
1571     Lisp_Object bit_vector;
1572     XSETBIT_VECTOR (bit_vector, p);
1573     return bit_vector;
1574   }
1575 }
1576
1577 Lisp_Object
1578 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1579 {
1580   int i;
1581   Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1582
1583   for (i = 0; i < length; i++)
1584     set_bit_vector_bit (p, i, bytevec[i]);
1585
1586   {
1587     Lisp_Object bit_vector;
1588     XSETBIT_VECTOR (bit_vector, p);
1589     return bit_vector;
1590   }
1591 }
1592
1593 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1594 Return a new bit vector of length LENGTH. with each bit being INIT.
1595 Each element is set to INIT.  See also the function `bit-vector'.
1596 */
1597        (length, init))
1598 {
1599   CONCHECK_NATNUM (length);
1600
1601   return make_bit_vector (XINT (length), init);
1602 }
1603
1604 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1605 Return a newly created bit vector with specified arguments as elements.
1606 Any number of arguments, even zero arguments, are allowed.
1607 */
1608        (int nargs, Lisp_Object *args))
1609 {
1610   int i;
1611   Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1612
1613   for (i = 0; i < nargs; i++)
1614     {
1615       CHECK_BIT (args[i]);
1616       set_bit_vector_bit (p, i, !ZEROP (args[i]));
1617     }
1618
1619   {
1620     Lisp_Object bit_vector;
1621     XSETBIT_VECTOR (bit_vector, p);
1622     return bit_vector;
1623   }
1624 }
1625
1626 \f
1627 /************************************************************************/
1628 /*                   Compiled-function allocation                       */
1629 /************************************************************************/
1630
1631 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1632 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1633
1634 static Lisp_Object
1635 make_compiled_function (int make_pure)
1636 {
1637   Lisp_Compiled_Function *f;
1638   Lisp_Object fun;
1639   size_t size = sizeof (Lisp_Compiled_Function);
1640
1641   if (make_pure && check_purespace (size))
1642     {
1643       f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
1644       set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1645 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
1646       f->lheader.pure = 1;
1647 #endif
1648       pure_bytes_used += size;
1649       bump_purestat (&purestat_function, size);
1650     }
1651   else
1652     {
1653       ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1654       set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1655     }
1656   f->stack_depth = 0;
1657   f->specpdl_depth = 0;
1658   f->flags.documentationp = 0;
1659   f->flags.interactivep = 0;
1660   f->flags.domainp = 0; /* I18N3 */
1661   f->instructions = Qzero;
1662   f->constants = Qzero;
1663   f->arglist = Qnil;
1664   f->doc_and_interactive = Qnil;
1665 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1666   f->annotated = Qnil;
1667 #endif
1668   XSETCOMPILED_FUNCTION (fun, f);
1669   return fun;
1670 }
1671
1672 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1673 Return a new compiled-function object.
1674 Usage: (arglist instructions constants stack-depth
1675         &optional doc-string interactive)
1676 Note that, unlike all other emacs-lisp functions, calling this with five
1677 arguments is NOT the same as calling it with six arguments, the last of
1678 which is nil.  If the INTERACTIVE arg is specified as nil, then that means
1679 that this function was defined with `(interactive)'.  If the arg is not
1680 specified, then that means the function is not interactive.
1681 This is terrible behavior which is retained for compatibility with old
1682 `.elc' files which expect these semantics.
1683 */
1684        (int nargs, Lisp_Object *args))
1685 {
1686 /* In a non-insane world this function would have this arglist...
1687    (arglist instructions constants stack_depth &optional doc_string interactive)
1688  */
1689   Lisp_Object fun = make_compiled_function (purify_flag);
1690   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1691
1692   Lisp_Object arglist      = args[0];
1693   Lisp_Object instructions = args[1];
1694   Lisp_Object constants    = args[2];
1695   Lisp_Object stack_depth  = args[3];
1696   Lisp_Object doc_string   = (nargs > 4) ? args[4] : Qnil;
1697   Lisp_Object interactive  = (nargs > 5) ? args[5] : Qunbound;
1698
1699   /* Don't purecopy the doc references in instructions because it's
1700      wasteful; they will get fixed up later.
1701
1702      #### If something goes wrong and they don't get fixed up,
1703      we're screwed, because pure stuff isn't marked and thus the
1704      cons references won't be marked and will get reused.
1705
1706      Note: there will be a window after the byte code is created and
1707      before the doc references are fixed up in which there will be
1708      impure objects inside a pure object, which apparently won't
1709      get marked, leading to trouble.  But during that entire window,
1710      the objects are sitting on Vload_force_doc_string_list, which
1711      is staticpro'd, so we're OK. */
1712   Lisp_Object (*cons) (Lisp_Object, Lisp_Object)
1713     = purify_flag ? pure_cons : Fcons;
1714
1715   if (nargs < 4 || nargs > 6)
1716     return Fsignal (Qwrong_number_of_arguments,
1717                     list2 (intern ("make-byte-code"), make_int (nargs)));
1718
1719   /* Check for valid formal parameter list now, to allow us to use
1720      SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1721   {
1722     Lisp_Object symbol, tail;
1723     EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1724       {
1725         CHECK_SYMBOL (symbol);
1726         if (EQ (symbol, Qt)   ||
1727             EQ (symbol, Qnil) ||
1728             SYMBOL_IS_KEYWORD (symbol))
1729           signal_simple_error_2
1730             ("Invalid constant symbol in formal parameter list",
1731              symbol, arglist);
1732       }
1733   }
1734   f->arglist = arglist;
1735
1736   /* `instructions' is a string or a cons (string . int) for a
1737      lazy-loaded function. */
1738   if (CONSP (instructions))
1739     {
1740       CHECK_STRING (XCAR (instructions));
1741       CHECK_INT (XCDR (instructions));
1742     }
1743   else
1744     {
1745       CHECK_STRING (instructions);
1746     }
1747   f->instructions = instructions;
1748
1749   if (!NILP (constants))
1750     CHECK_VECTOR (constants);
1751   f->constants = constants;
1752
1753   CHECK_NATNUM (stack_depth);
1754   f->stack_depth  = XINT (stack_depth);
1755
1756 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1757   if (!NILP (Vcurrent_compiled_function_annotation))
1758     f->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
1759   else if (!NILP (Vload_file_name_internal_the_purecopy))
1760     f->annotated = Vload_file_name_internal_the_purecopy;
1761   else if (!NILP (Vload_file_name_internal))
1762     {
1763       struct gcpro gcpro1;
1764       GCPRO1 (fun);             /* don't let fun get reaped */
1765       Vload_file_name_internal_the_purecopy =
1766         Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1767       f->annotated = Vload_file_name_internal_the_purecopy;
1768       UNGCPRO;
1769     }
1770 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1771
1772   /* doc_string may be nil, string, int, or a cons (string . int).
1773      interactive may be list or string (or unbound). */
1774   f->doc_and_interactive = Qunbound;
1775 #ifdef I18N3
1776   if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1777     f->doc_and_interactive = Vfile_domain;
1778 #endif
1779   if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1780     {
1781       if (purify_flag)
1782         {
1783           interactive = Fpurecopy (interactive);
1784           if (STRINGP (interactive))
1785             bump_purestat (&purestat_string_interactive,
1786                            pure_sizeof (interactive));
1787         }
1788       f->doc_and_interactive
1789         = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1790            cons (interactive, f->doc_and_interactive));
1791     }
1792   if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1793     {
1794       if (purify_flag)
1795         {
1796           doc_string = Fpurecopy (doc_string);
1797           if (STRINGP (doc_string))
1798             /* These should have been snagged by make-docfile... */
1799             bump_purestat (&purestat_string_documentation,
1800                            pure_sizeof (doc_string));
1801         }
1802       f->doc_and_interactive
1803         = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1804            cons (doc_string, f->doc_and_interactive));
1805     }
1806   if (UNBOUNDP (f->doc_and_interactive))
1807     f->doc_and_interactive = Qnil;
1808
1809   if (purify_flag)
1810     {
1811
1812       if (!purified (f->arglist))
1813         f->arglist = Fpurecopy (f->arglist);
1814
1815       /* Statistics are kept differently for the constants */
1816       if (!purified (f->constants))
1817         {
1818 #ifdef PURESTAT
1819           int old = purecopying_function_constants;
1820           purecopying_function_constants = 1;
1821           f->constants = Fpurecopy (f->constants);
1822           bump_purestat (&purestat_vector_constants,
1823                          pure_sizeof (f->constants));
1824           purecopying_function_constants = old;
1825 #else
1826           f->constants = Fpurecopy (f->constants);
1827 #endif /* PURESTAT */
1828         }
1829
1830       optimize_compiled_function (fun);
1831
1832       bump_purestat (&purestat_opaque_instructions,
1833                      pure_sizeof (f->instructions));
1834     }
1835
1836   return fun;
1837 }
1838
1839 \f
1840 /************************************************************************/
1841 /*                          Symbol allocation                           */
1842 /************************************************************************/
1843
1844 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1845 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1846
1847 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1848 Return a newly allocated uninterned symbol whose name is NAME.
1849 Its value and function definition are void, and its property list is nil.
1850 */
1851        (name))
1852 {
1853   Lisp_Object val;
1854   struct Lisp_Symbol *p;
1855
1856   CHECK_STRING (name);
1857
1858   ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1859 #ifdef LRECORD_SYMBOL
1860   set_lheader_implementation (&(p->lheader), lrecord_symbol);
1861 #endif
1862   p->name     = XSTRING (name);
1863   p->plist    = Qnil;
1864   p->value    = Qunbound;
1865   p->function = Qunbound;
1866   p->obarray  = Qnil;
1867   symbol_next (p) = 0;
1868   XSETSYMBOL (val, p);
1869   return val;
1870 }
1871
1872 \f
1873 /************************************************************************/
1874 /*                         Extent allocation                            */
1875 /************************************************************************/
1876
1877 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1878 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1879
1880 struct extent *
1881 allocate_extent (void)
1882 {
1883   struct extent *e;
1884
1885   ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1886   set_lheader_implementation (&(e->lheader), lrecord_extent);
1887   extent_object (e) = Qnil;
1888   set_extent_start (e, -1);
1889   set_extent_end (e, -1);
1890   e->plist = Qnil;
1891
1892   xzero (e->flags);
1893
1894   extent_face (e) = Qnil;
1895   e->flags.end_open = 1;  /* default is for endpoints to behave like markers */
1896   e->flags.detachable = 1;
1897
1898   return e;
1899 }
1900
1901 \f
1902 /************************************************************************/
1903 /*                         Event allocation                             */
1904 /************************************************************************/
1905
1906 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1907 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1908
1909 Lisp_Object
1910 allocate_event (void)
1911 {
1912   Lisp_Object val;
1913   struct Lisp_Event *e;
1914
1915   ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1916   set_lheader_implementation (&(e->lheader), lrecord_event);
1917
1918   XSETEVENT (val, e);
1919   return val;
1920 }
1921
1922 \f
1923 /************************************************************************/
1924 /*                       Marker allocation                              */
1925 /************************************************************************/
1926
1927 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1928 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1929
1930 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1931 Return a new marker which does not point at any place.
1932 */
1933        ())
1934 {
1935   Lisp_Object val;
1936   struct Lisp_Marker *p;
1937
1938   ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1939   set_lheader_implementation (&(p->lheader), lrecord_marker);
1940   p->buffer = 0;
1941   p->memind = 0;
1942   marker_next (p) = 0;
1943   marker_prev (p) = 0;
1944   p->insertion_type = 0;
1945   XSETMARKER (val, p);
1946   return val;
1947 }
1948
1949 Lisp_Object
1950 noseeum_make_marker (void)
1951 {
1952   Lisp_Object val;
1953   struct Lisp_Marker *p;
1954
1955   NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1956   set_lheader_implementation (&(p->lheader), lrecord_marker);
1957   p->buffer = 0;
1958   p->memind = 0;
1959   marker_next (p) = 0;
1960   marker_prev (p) = 0;
1961   p->insertion_type = 0;
1962   XSETMARKER (val, p);
1963   return val;
1964 }
1965
1966 \f
1967 /************************************************************************/
1968 /*                        String allocation                             */
1969 /************************************************************************/
1970
1971 /* The data for "short" strings generally resides inside of structs of type
1972    string_chars_block. The Lisp_String structure is allocated just like any
1973    other Lisp object (except for vectors), and these are freelisted when
1974    they get garbage collected. The data for short strings get compacted,
1975    but the data for large strings do not.
1976
1977    Previously Lisp_String structures were relocated, but this caused a lot
1978    of bus-errors because the C code didn't include enough GCPRO's for
1979    strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1980    that the reference would get relocated).
1981
1982    This new method makes things somewhat bigger, but it is MUCH safer.  */
1983
1984 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1985 /* strings are used and freed quite often */
1986 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1987 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1988
1989 #ifdef LRECORD_STRING
1990 static Lisp_Object
1991 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1992 {
1993   struct Lisp_String *ptr = XSTRING (obj);
1994
1995   if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1996     flush_cached_extent_info (XCAR (ptr->plist));
1997   return ptr->plist;
1998 }
1999
2000 static int
2001 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2002 {
2003   Bytecount len;
2004   return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
2005           !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
2006 }
2007
2008 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
2009                                      mark_string, print_string,
2010                                      /*
2011                                       * No `finalize', or `hash' methods.
2012                                       * internal_hash already knows how
2013                                       * to hash strings and finalization
2014                                       * is done with the
2015                                       * ADDITIONAL_FREE_string macro,
2016                                       * which is the standard way to do
2017                                       * finalization when using
2018                                       * SWEEP_FIXED_TYPE_BLOCK().
2019                                       */
2020                                      0, string_equal, 0,
2021                                      struct Lisp_String);
2022 #endif /* LRECORD_STRING */
2023
2024 /* String blocks contain this many useful bytes. */
2025 #define STRING_CHARS_BLOCK_SIZE                                 \
2026 ((Bytecount) (8192 - MALLOC_OVERHEAD -                          \
2027               ((2 * sizeof (struct string_chars_block *))       \
2028                + sizeof (EMACS_INT))))
2029 /* Block header for small strings. */
2030 struct string_chars_block
2031 {
2032   EMACS_INT pos;
2033   struct string_chars_block *next;
2034   struct string_chars_block *prev;
2035   /* Contents of string_chars_block->string_chars are interleaved
2036      string_chars structures (see below) and the actual string data */
2037   unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2038 };
2039
2040 struct string_chars_block *first_string_chars_block;
2041 struct string_chars_block *current_string_chars_block;
2042
2043 /* If SIZE is the length of a string, this returns how many bytes
2044  *  the string occupies in string_chars_block->string_chars
2045  *  (including alignment padding).
2046  */
2047 #define STRING_FULLSIZE(s) \
2048    ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
2049                ALIGNOF (struct Lisp_String *))
2050
2051 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2052 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2053
2054 #define CHARS_TO_STRING_CHAR(x) \
2055   ((struct string_chars *) \
2056    (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
2057
2058
2059 struct string_chars
2060 {
2061   struct Lisp_String *string;
2062   unsigned char chars[1];
2063 };
2064
2065 struct unused_string_chars
2066 {
2067   struct Lisp_String *string;
2068   EMACS_INT fullsize;
2069 };
2070
2071 static void
2072 init_string_chars_alloc (void)
2073 {
2074   first_string_chars_block = xnew (struct string_chars_block);
2075   first_string_chars_block->prev = 0;
2076   first_string_chars_block->next = 0;
2077   first_string_chars_block->pos = 0;
2078   current_string_chars_block = first_string_chars_block;
2079 }
2080
2081 static struct string_chars *
2082 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
2083                               EMACS_INT fullsize)
2084 {
2085   struct string_chars *s_chars;
2086
2087   /* Allocate the string's actual data */
2088   if (BIG_STRING_FULLSIZE_P (fullsize))
2089     {
2090       s_chars = (struct string_chars *) xmalloc (fullsize);
2091     }
2092   else if (fullsize <=
2093            (countof (current_string_chars_block->string_chars)
2094             - current_string_chars_block->pos))
2095     {
2096       /* This string can fit in the current string chars block */
2097       s_chars = (struct string_chars *)
2098         (current_string_chars_block->string_chars
2099          + current_string_chars_block->pos);
2100       current_string_chars_block->pos += fullsize;
2101     }
2102   else
2103     {
2104       /* Make a new current string chars block */
2105       struct string_chars_block *new_scb = xnew (struct string_chars_block);
2106
2107       current_string_chars_block->next = new_scb;
2108       new_scb->prev = current_string_chars_block;
2109       new_scb->next = 0;
2110       current_string_chars_block = new_scb;
2111       new_scb->pos = fullsize;
2112       s_chars = (struct string_chars *)
2113         current_string_chars_block->string_chars;
2114     }
2115
2116   s_chars->string = string_it_goes_with;
2117
2118   INCREMENT_CONS_COUNTER (fullsize, "string chars");
2119
2120   return s_chars;
2121 }
2122
2123 Lisp_Object
2124 make_uninit_string (Bytecount length)
2125 {
2126   struct Lisp_String *s;
2127   struct string_chars *s_chars;
2128   EMACS_INT fullsize = STRING_FULLSIZE (length);
2129   Lisp_Object val;
2130
2131   if ((length < 0) || (fullsize <= 0))
2132     abort ();
2133
2134   /* Allocate the string header */
2135   ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2136 #ifdef LRECORD_STRING
2137   set_lheader_implementation (&(s->lheader), lrecord_string);
2138 #endif
2139
2140   s_chars = allocate_string_chars_struct (s, fullsize);
2141
2142   set_string_data (s, &(s_chars->chars[0]));
2143   set_string_length (s, length);
2144   s->plist = Qnil;
2145
2146   set_string_byte (s, length, 0);
2147
2148   XSETSTRING (val, s);
2149   return val;
2150 }
2151
2152 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2153 static void verify_string_chars_integrity (void);
2154 #endif
2155
2156 /* Resize the string S so that DELTA bytes can be inserted starting
2157    at POS.  If DELTA < 0, it means deletion starting at POS.  If
2158    POS < 0, resize the string but don't copy any characters.  Use
2159    this if you're planning on completely overwriting the string.
2160 */
2161
2162 void
2163 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
2164 {
2165 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2166   verify_string_chars_integrity ();
2167 #endif
2168
2169 #ifdef ERROR_CHECK_BUFPOS
2170   if (pos >= 0)
2171     {
2172       assert (pos <= string_length (s));
2173       if (delta < 0)
2174         assert (pos + (-delta) <= string_length (s));
2175     }
2176   else
2177     {
2178       if (delta < 0)
2179         assert ((-delta) <= string_length (s));
2180     }
2181 #endif /* ERROR_CHECK_BUFPOS */
2182
2183   if (pos >= 0 && delta < 0)
2184   /* If DELTA < 0, the functions below will delete the characters
2185      before POS.  We want to delete characters *after* POS, however,
2186      so convert this to the appropriate form. */
2187     pos += -delta;
2188
2189   if (delta == 0)
2190     /* simplest case: no size change. */
2191     return;
2192   else
2193     {
2194       Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
2195       Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2196
2197       if (oldfullsize == newfullsize)
2198         {
2199           /* next simplest case; size change but the necessary
2200              allocation size won't change (up or down; code somewhere
2201              depends on there not being any unused allocation space,
2202              modulo any alignment constraints). */
2203           if (pos >= 0)
2204             {
2205               Bufbyte *addroff = pos + string_data (s);
2206
2207               memmove (addroff + delta, addroff,
2208                        /* +1 due to zero-termination. */
2209                        string_length (s) + 1 - pos);
2210             }
2211         }
2212       else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
2213                BIG_STRING_FULLSIZE_P (newfullsize))
2214         {
2215           /* next simplest case; the string is big enough to be malloc()ed
2216              itself, so we just realloc.
2217
2218              It's important not to let the string get below the threshold
2219              for making big strings and still remain malloc()ed; if that
2220              were the case, repeated calls to this function on the same
2221              string could result in memory leakage. */
2222           set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2223                                                     newfullsize));
2224           if (pos >= 0)
2225             {
2226               Bufbyte *addroff = pos + string_data (s);
2227
2228               memmove (addroff + delta, addroff,
2229                        /* +1 due to zero-termination. */
2230                        string_length (s) + 1 - pos);
2231             }
2232         }
2233       else
2234         {
2235           /* worst case.  We make a new string_chars struct and copy
2236              the string's data into it, inserting/deleting the delta
2237              in the process.  The old string data will either get
2238              freed by us (if it was malloc()ed) or will be reclaimed
2239              in the normal course of garbage collection. */
2240           struct string_chars *s_chars =
2241             allocate_string_chars_struct (s, newfullsize);
2242           Bufbyte *new_addr = &(s_chars->chars[0]);
2243           Bufbyte *old_addr = string_data (s);
2244           if (pos >= 0)
2245             {
2246               memcpy (new_addr, old_addr, pos);
2247               memcpy (new_addr + pos + delta, old_addr + pos,
2248                       string_length (s) + 1 - pos);
2249             }
2250           set_string_data (s, new_addr);
2251           if (BIG_STRING_FULLSIZE_P (oldfullsize))
2252             xfree (old_addr);
2253           else
2254             {
2255               /* We need to mark this chunk of the string_chars_block
2256                  as unused so that compact_string_chars() doesn't
2257                  freak. */
2258               struct string_chars *old_s_chars =
2259                 (struct string_chars *) ((char *) old_addr -
2260                                          sizeof (struct Lisp_String *));
2261               /* Sanity check to make sure we aren't hosed by strange
2262                  alignment/padding. */
2263               assert (old_s_chars->string == s);
2264               MARK_STRUCT_AS_FREE (old_s_chars);
2265               ((struct unused_string_chars *) old_s_chars)->fullsize =
2266                 oldfullsize;
2267             }
2268         }
2269
2270       set_string_length (s, string_length (s) + delta);
2271       /* If pos < 0, the string won't be zero-terminated.
2272          Terminate now just to make sure. */
2273       string_data (s)[string_length (s)] = '\0';
2274
2275       if (pos >= 0)
2276         {
2277           Lisp_Object string;
2278
2279           XSETSTRING (string, s);
2280           /* We also have to adjust all of the extent indices after the
2281              place we did the change.  We say "pos - 1" because
2282              adjust_extents() is exclusive of the starting position
2283              passed to it. */
2284           adjust_extents (string, pos - 1, string_length (s),
2285                           delta);
2286         }
2287     }
2288
2289 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2290   verify_string_chars_integrity ();
2291 #endif
2292 }
2293
2294 #ifdef MULE
2295
2296 void
2297 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2298 {
2299   Bufbyte newstr[MAX_EMCHAR_LEN];
2300   Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2301   Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2302   Bytecount newlen = set_charptr_emchar (newstr, c);
2303
2304   if (oldlen != newlen)
2305     resize_string (s, bytoff, newlen - oldlen);
2306   /* Remember, string_data (s) might have changed so we can't cache it. */
2307   memcpy (string_data (s) + bytoff, newstr, newlen);
2308 }
2309
2310 #endif /* MULE */
2311
2312 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2313 Return a new string of length LENGTH, with each character being INIT.
2314 LENGTH must be an integer and INIT must be a character.
2315 */
2316        (length, init))
2317 {
2318   CHECK_NATNUM (length);
2319   CHECK_CHAR_COERCE_INT (init);
2320   {
2321     Bufbyte init_str[MAX_EMCHAR_LEN];
2322     int len = set_charptr_emchar (init_str, XCHAR (init));
2323     Lisp_Object val = make_uninit_string (len * XINT (length));
2324
2325     if (len == 1)
2326       /* Optimize the single-byte case */
2327       memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2328     else
2329       {
2330         int i;
2331         Bufbyte *ptr = XSTRING_DATA (val);
2332
2333         for (i = XINT (length); i; i--)
2334           {
2335             Bufbyte *init_ptr = init_str;
2336             switch (len)
2337               {
2338               case 4: *ptr++ = *init_ptr++;
2339               case 3: *ptr++ = *init_ptr++;
2340               case 2: *ptr++ = *init_ptr++;
2341               case 1: *ptr++ = *init_ptr++;
2342               }
2343           }
2344       }
2345     return val;
2346   }
2347 }
2348
2349 DEFUN ("string", Fstring, 0, MANY, 0, /*
2350 Concatenate all the argument characters and make the result a string.
2351 */
2352        (int nargs, Lisp_Object *args))
2353 {
2354   Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2355   Bufbyte *p = storage;
2356
2357   for (; nargs; nargs--, args++)
2358     {
2359       Lisp_Object lisp_char = *args;
2360       CHECK_CHAR_COERCE_INT (lisp_char);
2361       p += set_charptr_emchar (p, XCHAR (lisp_char));
2362     }
2363   return make_string (storage, p - storage);
2364 }
2365
2366 /* Take some raw memory, which MUST already be in internal format,
2367    and package it up into a Lisp string. */
2368 Lisp_Object
2369 make_string (CONST Bufbyte *contents, Bytecount length)
2370 {
2371   Lisp_Object val;
2372
2373   /* Make sure we find out about bad make_string's when they happen */
2374 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2375   bytecount_to_charcount (contents, length); /* Just for the assertions */
2376 #endif
2377
2378   val = make_uninit_string (length);
2379   memcpy (XSTRING_DATA (val), contents, length);
2380   return val;
2381 }
2382
2383 /* Take some raw memory, encoded in some external data format,
2384    and convert it into a Lisp string. */
2385 Lisp_Object
2386 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2387                  enum external_data_format fmt)
2388 {
2389   Bufbyte *intstr;
2390   Bytecount intlen;
2391
2392   GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2393   return make_string (intstr, intlen);
2394 }
2395
2396 Lisp_Object
2397 build_string (CONST char *str)
2398 {
2399   /* Some strlen's crash and burn if passed null. */
2400   return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2401 }
2402
2403 Lisp_Object
2404 build_ext_string (CONST char *str, enum external_data_format fmt)
2405 {
2406   /* Some strlen's crash and burn if passed null. */
2407   return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2408 }
2409
2410 Lisp_Object
2411 build_translated_string (CONST char *str)
2412 {
2413   return build_string (GETTEXT (str));
2414 }
2415
2416 \f
2417 /************************************************************************/
2418 /*                           lcrecord lists                             */
2419 /************************************************************************/
2420
2421 /* Lcrecord lists are used to manage the allocation of particular
2422    sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2423    malloc() and garbage-collection junk) as much as possible.
2424    It is similar to the Blocktype class.
2425
2426    It works like this:
2427
2428    1) Create an lcrecord-list object using make_lcrecord_list().
2429       This is often done at initialization.  Remember to staticpro
2430       this object!  The arguments to make_lcrecord_list() are the
2431       same as would be passed to alloc_lcrecord().
2432    2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2433       and pass the lcrecord-list earlier created.
2434    3) When done with the lcrecord, call free_managed_lcrecord().
2435       The standard freeing caveats apply: ** make sure there are no
2436       pointers to the object anywhere! **
2437    4) Calling free_managed_lcrecord() is just like kissing the
2438       lcrecord goodbye as if it were garbage-collected.  This means:
2439       -- the contents of the freed lcrecord are undefined, and the
2440          contents of something produced by allocate_managed_lcrecord()
2441          are undefined, just like for alloc_lcrecord().
2442       -- the mark method for the lcrecord's type will *NEVER* be called
2443          on freed lcrecords.
2444       -- the finalize method for the lcrecord's type will be called
2445          at the time that free_managed_lcrecord() is called.
2446
2447    */
2448
2449 static Lisp_Object
2450 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2451 {
2452   struct lcrecord_list *list = XLCRECORD_LIST (obj);
2453   Lisp_Object chain = list->free;
2454
2455   while (!NILP (chain))
2456     {
2457       struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2458       struct free_lcrecord_header *free_header =
2459         (struct free_lcrecord_header *) lheader;
2460
2461 #ifdef ERROR_CHECK_GC
2462       CONST struct lrecord_implementation *implementation
2463         = LHEADER_IMPLEMENTATION(lheader);
2464
2465       /* There should be no other pointers to the free list. */
2466       assert (!MARKED_RECORD_HEADER_P (lheader));
2467       /* Only lcrecords should be here. */
2468       assert (!implementation->basic_p);
2469       /* Only free lcrecords should be here. */
2470       assert (free_header->lcheader.free);
2471       /* The type of the lcrecord must be right. */
2472       assert (implementation == list->implementation);
2473       /* So must the size. */
2474       assert (implementation->static_size == 0
2475               || implementation->static_size == list->size);
2476 #endif /* ERROR_CHECK_GC */
2477
2478       MARK_RECORD_HEADER (lheader);
2479       chain = free_header->chain;
2480     }
2481
2482   return Qnil;
2483 }
2484
2485 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2486                                mark_lcrecord_list, internal_object_printer,
2487                                0, 0, 0, struct lcrecord_list);
2488 Lisp_Object
2489 make_lcrecord_list (size_t size,
2490                     CONST struct lrecord_implementation *implementation)
2491 {
2492   struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2493                                                  lrecord_lcrecord_list);
2494   Lisp_Object val;
2495
2496   p->implementation = implementation;
2497   p->size = size;
2498   p->free = Qnil;
2499   XSETLCRECORD_LIST (val, p);
2500   return val;
2501 }
2502
2503 Lisp_Object
2504 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2505 {
2506   struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2507   if (!NILP (list->free))
2508     {
2509       Lisp_Object val = list->free;
2510       struct free_lcrecord_header *free_header =
2511         (struct free_lcrecord_header *) XPNTR (val);
2512
2513 #ifdef ERROR_CHECK_GC
2514       struct lrecord_header *lheader =
2515         (struct lrecord_header *) free_header;
2516       CONST struct lrecord_implementation *implementation
2517         = LHEADER_IMPLEMENTATION (lheader);
2518
2519       /* There should be no other pointers to the free list. */
2520       assert (!MARKED_RECORD_HEADER_P (lheader));
2521       /* Only lcrecords should be here. */
2522       assert (!implementation->basic_p);
2523       /* Only free lcrecords should be here. */
2524       assert (free_header->lcheader.free);
2525       /* The type of the lcrecord must be right. */
2526       assert (implementation == list->implementation);
2527       /* So must the size. */
2528       assert (implementation->static_size == 0
2529               || implementation->static_size == list->size);
2530 #endif /* ERROR_CHECK_GC */
2531       list->free = free_header->chain;
2532       free_header->lcheader.free = 0;
2533       return val;
2534     }
2535   else
2536     {
2537       Lisp_Object val;
2538
2539       XSETOBJ (val, Lisp_Type_Record,
2540                alloc_lcrecord (list->size, list->implementation));
2541       return val;
2542     }
2543 }
2544
2545 void
2546 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2547 {
2548   struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2549   struct free_lcrecord_header *free_header =
2550     (struct free_lcrecord_header *) XPNTR (lcrecord);
2551   struct lrecord_header *lheader =
2552     (struct lrecord_header *) free_header;
2553   CONST struct lrecord_implementation *implementation
2554     = LHEADER_IMPLEMENTATION (lheader);
2555
2556 #ifdef ERROR_CHECK_GC
2557   /* Make sure the size is correct.  This will catch, for example,
2558      putting a window configuration on the wrong free list. */
2559   if (implementation->size_in_bytes_method)
2560     assert (implementation->size_in_bytes_method (lheader) == list->size);
2561   else
2562     assert (implementation->static_size == list->size);
2563 #endif /* ERROR_CHECK_GC */
2564
2565   if (implementation->finalizer)
2566     implementation->finalizer (lheader, 0);
2567   free_header->chain = list->free;
2568   free_header->lcheader.free = 1;
2569   list->free = lcrecord;
2570 }
2571
2572 \f
2573 /************************************************************************/
2574 /*                 Purity of essence, peace on earth                    */
2575 /************************************************************************/
2576
2577 static int symbols_initialized;
2578
2579 Lisp_Object
2580 make_pure_string (CONST Bufbyte *data, Bytecount length,
2581                   Lisp_Object plist, int no_need_to_copy_data)
2582 {
2583   Lisp_String *s;
2584   size_t size = sizeof (Lisp_String) +
2585     (no_need_to_copy_data ? 0 : (length + 1)); /* + 1 for terminating 0 */
2586   size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2587
2588   if (symbols_initialized && !pure_lossage)
2589     {
2590       /* Try to share some names.  Saves a few kbytes. */
2591       Lisp_Object tem = oblookup (Vobarray, data, length);
2592       if (SYMBOLP (tem))
2593         {
2594           s = XSYMBOL (tem)->name;
2595           if (!PURIFIED (s)) abort ();
2596
2597           {
2598             Lisp_Object string;
2599             XSETSTRING (string, s);
2600             return string;
2601           }
2602         }
2603     }
2604
2605   if (!check_purespace (size))
2606     return make_string (data, length);
2607
2608   s = (Lisp_String *) (PUREBEG + pure_bytes_used);
2609 #ifdef LRECORD_STRING
2610   set_lheader_implementation (&(s->lheader), lrecord_string);
2611 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2612   s->lheader.pure = 1;
2613 #endif
2614 #endif
2615   set_string_length (s, length);
2616   if (no_need_to_copy_data)
2617     {
2618       set_string_data (s, (Bufbyte *) data);
2619     }
2620   else
2621     {
2622       set_string_data (s, (Bufbyte *) s + sizeof (Lisp_String));
2623       memcpy (string_data (s), data, length);
2624       set_string_byte (s, length, 0);
2625     }
2626   s->plist = Qnil;
2627   pure_bytes_used += size;
2628
2629 #ifdef PURESTAT
2630   bump_purestat (&purestat_string_all, size);
2631   if (purecopying_function_constants)
2632     bump_purestat (&purestat_string_other_function, size);
2633 #endif /* PURESTAT */
2634
2635   /* Do this after the official "completion" of the purecopying. */
2636   s->plist = Fpurecopy (plist);
2637
2638   {
2639     Lisp_Object string;
2640     XSETSTRING (string, s);
2641     return string;
2642   }
2643 }
2644
2645
2646 Lisp_Object
2647 make_pure_pname (CONST Bufbyte *data, Bytecount length,
2648                  int no_need_to_copy_data)
2649 {
2650   Lisp_Object name = make_pure_string (data, length, Qnil,
2651                                        no_need_to_copy_data);
2652   bump_purestat (&purestat_string_pname, pure_sizeof (name));
2653
2654   /* We've made (at least) Qnil now, and Vobarray will soon be set up. */
2655   symbols_initialized = 1;
2656
2657   return name;
2658 }
2659
2660
2661 Lisp_Object
2662 pure_cons (Lisp_Object car, Lisp_Object cdr)
2663 {
2664   Lisp_Cons *c;
2665
2666   if (!check_purespace (sizeof (Lisp_Cons)))
2667     return Fcons (Fpurecopy (car), Fpurecopy (cdr));
2668
2669   c = (Lisp_Cons *) (PUREBEG + pure_bytes_used);
2670 #ifdef LRECORD_CONS
2671   set_lheader_implementation (&(c->lheader), lrecord_cons);
2672 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2673   c->lheader.pure = 1;
2674 #endif
2675 #endif
2676   pure_bytes_used += sizeof (Lisp_Cons);
2677   bump_purestat (&purestat_cons, sizeof (Lisp_Cons));
2678
2679   c->car = Fpurecopy (car);
2680   c->cdr = Fpurecopy (cdr);
2681
2682   {
2683     Lisp_Object cons;
2684     XSETCONS (cons, c);
2685     return cons;
2686   }
2687 }
2688
2689 Lisp_Object
2690 pure_list (int nargs, Lisp_Object *args)
2691 {
2692   Lisp_Object val = Qnil;
2693
2694   for (--nargs; nargs >= 0; nargs--)
2695     val = pure_cons (args[nargs], val);
2696
2697   return val;
2698 }
2699
2700 #ifdef LISP_FLOAT_TYPE
2701
2702 static Lisp_Object
2703 make_pure_float (double num)
2704 {
2705   struct Lisp_Float *f;
2706   Lisp_Object val;
2707
2708   /* Make sure that PUREBEG + pure_bytes_used is aligned on at least a sizeof
2709      (double) boundary.  Some architectures (like the sparc) require
2710      this, and I suspect that floats are rare enough that it's no
2711      tragedy for those that don't. */
2712   {
2713 #if defined (__GNUC__) && (__GNUC__ >= 2)
2714     /* In gcc, we can directly ask what the alignment constraints of a
2715        structure are, but in general, that's not possible...  Arrgh!!
2716      */
2717     int alignment = __alignof (struct Lisp_Float);
2718 #else /* !GNUC */
2719     /* Best guess is to make the `double' slot be aligned to the size
2720        of double (which is probably 8 bytes).  This assumes that it's
2721        ok to align the beginning of the structure to the same boundary
2722        that the `double' slot in it is supposed to be aligned to; this
2723        should be ok because presumably there is padding in the layout
2724        of the struct to account for this.
2725      */
2726     int alignment = sizeof (float_data (f));
2727 #endif /* !GNUC */
2728     char *p = ((char *) PUREBEG + pure_bytes_used);
2729
2730     p = (char *) (((EMACS_UINT) p + alignment - 1) & - alignment);
2731     pure_bytes_used = p - (char *) PUREBEG;
2732   }
2733
2734   if (!check_purespace (sizeof (struct Lisp_Float)))
2735     return make_float (num);
2736
2737   f = (struct Lisp_Float *) (PUREBEG + pure_bytes_used);
2738   set_lheader_implementation (&(f->lheader), lrecord_float);
2739 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2740   f->lheader.pure = 1;
2741 #endif
2742   pure_bytes_used += sizeof (struct Lisp_Float);
2743   bump_purestat (&purestat_float, sizeof (struct Lisp_Float));
2744
2745   float_data (f) = num;
2746   XSETFLOAT (val, f);
2747   return val;
2748 }
2749
2750 #endif /* LISP_FLOAT_TYPE */
2751
2752 Lisp_Object
2753 make_pure_vector (size_t len, Lisp_Object init)
2754 {
2755   Lisp_Vector *v;
2756   size_t size = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, len);
2757
2758   init = Fpurecopy (init);
2759
2760   if (!check_purespace (size))
2761     return make_vector (len, init);
2762
2763   v = (Lisp_Vector *) (PUREBEG + pure_bytes_used);
2764 #ifdef LRECORD_VECTOR
2765   set_lheader_implementation (&(v->header.lheader), lrecord_vector);
2766 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2767   v->header.lheader.pure = 1;
2768 #endif
2769 #endif
2770   pure_bytes_used += size;
2771   bump_purestat (&purestat_vector_all, size);
2772
2773   v->size = len;
2774
2775   for (size = 0; size < len; size++)
2776     v->contents[size] = init;
2777
2778   {
2779     Lisp_Object vector;
2780     XSETVECTOR (vector, v);
2781     return vector;
2782   }
2783 }
2784
2785 #if 0
2786 /* Presently unused */
2787 void *
2788 alloc_pure_lrecord (int size, struct lrecord_implementation *implementation)
2789 {
2790   struct lrecord_header *header = (void *) (PUREBEG + pure_bytes_used);
2791
2792   if (pure_bytes_used + size > get_PURESIZE())
2793     pure_storage_exhausted ();
2794
2795   set_lheader_implementation (header, implementation);
2796   header->next = 0;
2797   return header;
2798 }
2799 #endif /* unused */
2800
2801
2802 \f
2803 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2804 Make a copy of OBJECT in pure storage.
2805 Recursively copies contents of vectors and cons cells.
2806 Does not copy symbols.
2807 */
2808        (obj))
2809 {
2810   if (!purify_flag)
2811     {
2812       return obj;
2813     }
2814   else if (!POINTER_TYPE_P (XTYPE (obj))
2815            || PURIFIED (XPNTR (obj))
2816            /* happens when bootstrapping Qnil */
2817            || EQ (obj, Qnull_pointer))
2818     {
2819       return obj;
2820     }
2821   /* Order of subsequent tests determined via profiling. */
2822   else if (SYMBOLP (obj))
2823     {
2824       /* Symbols can't be made pure (and thus read-only), because
2825          assigning to their function, value or plist slots would
2826          produced a SEGV in the dumped XEmacs.  So we previously would
2827          just return the symbol unchanged.
2828
2829          But purified aggregate objects like lists and vectors can
2830          contain uninterned symbols.  If there are no other non-pure
2831          references to the symbol, then the symbol is not protected
2832          from garbage collection because the collector does not mark
2833          the contents of purified objects.  So to protect the symbols,
2834          an impure reference has to be kept for each uninterned symbol
2835          that is referenced by a pure object.  All such symbols are
2836          stored in the hash table pointed to by
2837          Vpure_uninterned_symbol_table, which is itself
2838          staticpro'd. */
2839       if (NILP (XSYMBOL (obj)->obarray))
2840         Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
2841       return obj;
2842     }
2843   else if (CONSP (obj))
2844     {
2845       return pure_cons (XCAR (obj), XCDR (obj));
2846     }
2847   else if (STRINGP (obj))
2848     {
2849       return make_pure_string (XSTRING_DATA (obj),
2850                                XSTRING_LENGTH (obj),
2851                                XSTRING (obj)->plist,
2852                                0);
2853     }
2854   else if (VECTORP (obj))
2855     {
2856       int i;
2857       Lisp_Vector *o = XVECTOR (obj);
2858       Lisp_Object pure_obj = make_pure_vector (vector_length (o), Qnil);
2859       for (i = 0; i < vector_length (o); i++)
2860         XVECTOR_DATA (pure_obj)[i] = Fpurecopy (o->contents[i]);
2861       return pure_obj;
2862     }
2863 #ifdef LISP_FLOAT_TYPE
2864   else if (FLOATP (obj))
2865     {
2866       return make_pure_float (XFLOAT_DATA (obj));
2867     }
2868 #endif
2869   else if (COMPILED_FUNCTIONP (obj))
2870     {
2871       Lisp_Object pure_obj = make_compiled_function (1);
2872       Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
2873       Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (pure_obj);
2874       n->flags                 = o->flags;
2875       n->instructions          = o->instructions;
2876       n->constants             = Fpurecopy (o->constants);
2877       n->arglist               = Fpurecopy (o->arglist);
2878       n->doc_and_interactive   = Fpurecopy (o->doc_and_interactive);
2879       n->stack_depth           = o->stack_depth;
2880       optimize_compiled_function (pure_obj);
2881       return pure_obj;
2882     }
2883   else if (OPAQUEP (obj))
2884     {
2885       Lisp_Object pure_obj;
2886       Lisp_Opaque *old_opaque = XOPAQUE (obj);
2887       Lisp_Opaque *new_opaque = (Lisp_Opaque *) (PUREBEG + pure_bytes_used);
2888       struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2889       CONST struct lrecord_implementation *implementation
2890         = LHEADER_IMPLEMENTATION (lheader);
2891       size_t size = implementation->size_in_bytes_method (lheader);
2892       size_t pure_size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2893       if (!check_purespace (pure_size))
2894         return obj;
2895       pure_bytes_used += pure_size;
2896
2897       memcpy (new_opaque, old_opaque, size);
2898 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2899       lheader->pure = 1;
2900 #endif
2901       new_opaque->header.next = 0;
2902
2903       XSETOPAQUE (pure_obj, new_opaque);
2904       return pure_obj;
2905     }
2906   else
2907     {
2908       signal_simple_error ("Can't purecopy %S", obj);
2909     }
2910   return obj; /* Unreached */
2911 }
2912
2913
2914 \f
2915 static void
2916 puresize_adjust_h (size_t puresize)
2917 {
2918   FILE *stream = fopen ("puresize-adjust.h", "w");
2919
2920   if (stream == NULL)
2921     report_file_error ("Opening puresize adjustment file",
2922                        Fcons (build_string ("puresize-adjust.h"), Qnil));
2923
2924   fprintf (stream,
2925            "/*\tDo not edit this file!\n"
2926            "\tAutomatically generated by XEmacs */\n"
2927            "# define PURESIZE_ADJUSTMENT (%ld)\n",
2928            (long) (puresize - RAW_PURESIZE));
2929   fclose (stream);
2930 }
2931
2932 void
2933 report_pure_usage (int report_impurities,
2934                    int die_if_pure_storage_exceeded)
2935 {
2936   int rc = 0;
2937
2938   if (pure_lossage)
2939     {
2940       message ("\n****\tPure Lisp storage exhausted!\n"
2941                "\tPurespace usage: %ld of %ld\n"
2942                "****",
2943                (long) get_PURESIZE() + pure_lossage,
2944                (long) get_PURESIZE());
2945       if (die_if_pure_storage_exceeded)
2946         {
2947           puresize_adjust_h (get_PURESIZE() + pure_lossage);
2948 #ifdef HEAP_IN_DATA
2949           sheap_adjust_h();
2950 #endif
2951           rc = -1;
2952         }
2953     }
2954   else
2955     {
2956       size_t lost = (get_PURESIZE() - pure_bytes_used) / 1024;
2957       char buf[200];
2958       /* extern Lisp_Object Vemacs_beta_version; */
2959       /* This used to be NILP(Vemacs_beta_version) ? 512 : 4; */
2960 #ifndef PURESIZE_SLOP
2961 #define PURESIZE_SLOP 0
2962 #endif
2963       size_t slop = PURESIZE_SLOP;
2964
2965       sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
2966                (long) pure_bytes_used,
2967                (long) get_PURESIZE(),
2968                (int) (pure_bytes_used / (get_PURESIZE() / 100.0) + 0.5));
2969       if (lost > ((slop ? slop : 1) / 1024)) {
2970         sprintf (buf + strlen (buf), " -- %ldk wasted", (long)lost);
2971         if (die_if_pure_storage_exceeded) {
2972           puresize_adjust_h (pure_bytes_used + slop);
2973 #ifdef HEAP_IN_DATA
2974           sheap_adjust_h();
2975 #endif
2976           rc = -1;
2977         }
2978       }
2979
2980       strcat (buf, ").");
2981       message ("%s", buf);
2982     }
2983
2984 #ifdef PURESTAT
2985
2986   purestat_vector_other.nbytes =
2987     purestat_vector_all.nbytes -
2988     purestat_vector_constants.nbytes;
2989   purestat_vector_other.nobjects =
2990     purestat_vector_all.nobjects -
2991     purestat_vector_constants.nobjects;
2992
2993   purestat_string_other.nbytes =
2994     purestat_string_all.nbytes -
2995     (purestat_string_pname.nbytes +
2996      purestat_string_interactive.nbytes +
2997      purestat_string_documentation.nbytes +
2998 #ifdef I18N3
2999      purestat_string_domain.nbytes +
3000 #endif
3001      purestat_string_other_function.nbytes);
3002
3003   purestat_string_other.nobjects =
3004     purestat_string_all.nobjects -
3005     (purestat_string_pname.nobjects +
3006      purestat_string_interactive.nobjects +
3007      purestat_string_documentation.nobjects +
3008 #ifdef I18N3
3009      purestat_string_domain.nobjects +
3010 #endif
3011      purestat_string_other_function.nobjects);
3012
3013   message ("   %-34s Objects    Bytes", "");
3014
3015   print_purestat (&purestat_cons);
3016   print_purestat (&purestat_float);
3017   print_purestat (&purestat_string_pname);
3018   print_purestat (&purestat_function);
3019   print_purestat (&purestat_opaque_instructions);
3020   print_purestat (&purestat_vector_constants);
3021   print_purestat (&purestat_string_interactive);
3022 #ifdef I18N3
3023   print_purestat (&purestat_string_domain);
3024 #endif
3025   print_purestat (&purestat_string_documentation);
3026   print_purestat (&purestat_string_other_function);
3027   print_purestat (&purestat_vector_other);
3028   print_purestat (&purestat_string_other);
3029   print_purestat (&purestat_string_all);
3030   print_purestat (&purestat_vector_all);
3031
3032 #endif /* PURESTAT */
3033
3034
3035   if (report_impurities)
3036     {
3037       Lisp_Object plist;
3038       struct gcpro gcpro1;
3039       plist = XCAR (XCDR (XCDR (XCDR (XCDR (XCDR (Fgarbage_collect()))))));
3040       GCPRO1 (plist);
3041       message ("\nImpurities:");
3042       for (; CONSP (plist); plist = XCDR (XCDR (plist)))
3043         {
3044           Lisp_Object symbol = XCAR (plist);
3045           int size = XINT (XCAR (XCDR (plist)));
3046           if (size > 0)
3047             {
3048               char buf [100];
3049               char *s = buf;
3050               memcpy (buf,
3051                       string_data   (XSYMBOL (symbol)->name),
3052                       string_length (XSYMBOL (symbol)->name) + 1);
3053               while (*s++) if (*s == '-') *s = ' ';
3054               *(s-1) = ':'; *s = 0;
3055               message ("   %-34s %6d", buf, size);
3056             }
3057         }
3058       UNGCPRO;
3059       garbage_collect_1 ();     /* collect Fgarbage_collect()'s garbage */
3060     }
3061   clear_message ();
3062
3063   if (rc < 0) {
3064     unlink("SATISFIED");
3065     fatal ("Pure size adjusted, Don't Panic!  I will restart the `make'");
3066   } else if (pure_lossage && die_if_pure_storage_exceeded) {
3067     fatal ("Pure storage exhausted");
3068   }
3069 }
3070
3071 \f
3072 /************************************************************************/
3073 /*                         Garbage Collection                           */
3074 /************************************************************************/
3075
3076 /* This will be used more extensively In The Future */
3077 static int last_lrecord_type_index_assigned;
3078
3079 CONST struct lrecord_implementation *lrecord_implementations_table[128];
3080 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
3081
3082 struct gcpro *gcprolist;
3083
3084 /* 415 used Mly 29-Jun-93 */
3085 /* 1327 used slb 28-Feb-98 */
3086 #ifdef HAVE_SHLIB
3087 #define NSTATICS 4000
3088 #else
3089 #define NSTATICS 2000
3090 #endif
3091 /* Not "static" because of linker lossage on some systems */
3092 Lisp_Object *staticvec[NSTATICS]
3093      /* Force it into data space! */
3094      = {0};
3095 static int staticidx;
3096
3097 /* Put an entry in staticvec, pointing at the variable whose address is given
3098  */
3099 void
3100 staticpro (Lisp_Object *varaddress)
3101 {
3102   if (staticidx >= countof (staticvec))
3103     /* #### This is now a dubious abort() since this routine may be called */
3104     /* by Lisp attempting to load a DLL. */
3105     abort ();
3106   staticvec[staticidx++] = varaddress;
3107 }
3108
3109 \f
3110 /* Mark reference to a Lisp_Object.  If the object referred to has not been
3111    seen yet, recursively mark all the references contained in it. */
3112
3113 static void
3114 mark_object (Lisp_Object obj)
3115 {
3116  tail_recurse:
3117
3118 #ifdef ERROR_CHECK_GC
3119   assert (! (GC_EQ (obj, Qnull_pointer)));
3120 #endif
3121   /* Checks we used to perform */
3122   /* if (EQ (obj, Qnull_pointer)) return; */
3123   /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3124   /* if (PURIFIED (XPNTR (obj))) return; */
3125
3126   switch (XGCTYPE (obj))
3127     {
3128 #ifndef LRECORD_CONS
3129     case Lisp_Type_Cons:
3130       {
3131         struct Lisp_Cons *ptr = XCONS (obj);
3132         if (PURIFIED (ptr))
3133           break;
3134         if (CONS_MARKED_P (ptr))
3135           break;
3136         MARK_CONS (ptr);
3137         /* If the cdr is nil, tail-recurse on the car.  */
3138         if (GC_NILP (ptr->cdr))
3139           {
3140             obj = ptr->car;
3141           }
3142         else
3143           {
3144             mark_object (ptr->car);
3145             obj = ptr->cdr;
3146           }
3147         goto tail_recurse;
3148       }
3149 #endif
3150
3151     case Lisp_Type_Record:
3152       {
3153         struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3154 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
3155         assert (lheader->type <= last_lrecord_type_index_assigned);
3156 #endif
3157         if (PURIFIED (lheader))
3158           return;
3159
3160         if (! MARKED_RECORD_HEADER_P (lheader) &&
3161             ! UNMARKABLE_RECORD_HEADER_P (lheader))
3162           {
3163             CONST struct lrecord_implementation *implementation =
3164               LHEADER_IMPLEMENTATION (lheader);
3165             MARK_RECORD_HEADER (lheader);
3166 #ifdef ERROR_CHECK_GC
3167             if (!implementation->basic_p)
3168               assert (! ((struct lcrecord_header *) lheader)->free);
3169 #endif
3170             if (implementation->marker)
3171               {
3172                 obj = implementation->marker (obj, mark_object);
3173                 if (!GC_NILP (obj)) goto tail_recurse;
3174               }
3175           }
3176       }
3177       break;
3178
3179 #ifndef LRECORD_STRING
3180     case Lisp_Type_String:
3181       {
3182         struct Lisp_String *ptr = XSTRING (obj);
3183         if (PURIFIED (ptr))
3184           return;
3185
3186         if (!XMARKBIT (ptr->plist))
3187           {
3188             if (CONSP (ptr->plist) &&
3189                 EXTENT_INFOP (XCAR (ptr->plist)))
3190               flush_cached_extent_info (XCAR (ptr->plist));
3191             XMARK (ptr->plist);
3192             obj = ptr->plist;
3193             goto tail_recurse;
3194           }
3195       }
3196       break;
3197 #endif /* ! LRECORD_STRING */
3198
3199 #ifndef LRECORD_VECTOR
3200     case Lisp_Type_Vector:
3201       {
3202         struct Lisp_Vector *ptr = XVECTOR (obj);
3203         int len, i;
3204
3205         if (PURIFIED (ptr))
3206           return;
3207
3208         len = vector_length (ptr);
3209
3210         if (len < 0)
3211           break;                /* Already marked */
3212         ptr->size = -1 - len;   /* Else mark it */
3213         for (i = 0; i < len - 1; i++) /* and then mark its elements */
3214           mark_object (ptr->contents[i]);
3215         if (len > 0)
3216         {
3217           obj = ptr->contents[len - 1];
3218           goto tail_recurse;
3219         }
3220       }
3221       break;
3222 #endif /* !LRECORD_VECTOR */
3223
3224 #ifndef LRECORD_SYMBOL
3225     case Lisp_Type_Symbol:
3226       {
3227         struct Lisp_Symbol *sym = XSYMBOL (obj);
3228
3229         if (PURIFIED (sym))
3230           return;
3231
3232         while (!XMARKBIT (sym->plist))
3233           {
3234             XMARK (sym->plist);
3235             mark_object (sym->value);
3236             mark_object (sym->function);
3237             {
3238               /*
3239                * symbol->name is a struct Lisp_String *, not a
3240                * Lisp_Object.  Fix it up and pass to mark_object.
3241                */
3242               Lisp_Object symname;
3243               XSETSTRING (symname, sym->name);
3244               mark_object (symname);
3245             }
3246             if (!symbol_next (sym))
3247               {
3248                 obj = sym->plist;
3249                 goto tail_recurse;
3250               }
3251             mark_object (sym->plist);
3252             /* Mark the rest of the symbols in the hash-chain */
3253             sym = symbol_next (sym);
3254           }
3255       }
3256       break;
3257 #endif /* !LRECORD_SYMBOL */
3258
3259       /* Check for invalid Lisp_Object types */
3260 #if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS)
3261     case Lisp_Type_Int:
3262     case Lisp_Type_Char:
3263       break;
3264     default:
3265       abort();
3266       break;
3267 #endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */
3268     }
3269 }
3270
3271 /* mark all of the conses in a list and mark the final cdr; but
3272    DO NOT mark the cars.
3273
3274    Use only for internal lists!  There should never be other pointers
3275    to the cons cells, because if so, the cars will remain unmarked
3276    even when they maybe should be marked. */
3277 void
3278 mark_conses_in_list (Lisp_Object obj)
3279 {
3280   Lisp_Object rest;
3281
3282   for (rest = obj; CONSP (rest); rest = XCDR (rest))
3283     {
3284       if (CONS_MARKED_P (XCONS (rest)))
3285         return;
3286       MARK_CONS (XCONS (rest));
3287     }
3288
3289   mark_object (rest);
3290 }
3291
3292 \f
3293 #ifdef PURESTAT
3294 /* Simpler than mark-object, because pure structure can't
3295    have any circularities */
3296
3297 static size_t
3298 pure_string_sizeof (Lisp_Object obj)
3299 {
3300   struct Lisp_String *ptr = XSTRING (obj);
3301
3302   if (string_data (ptr) != (Bufbyte *) ptr + sizeof (*ptr))
3303     {
3304       /* string-data not allocated contiguously.
3305          Probably (better be!!) a pointer constant "C" data. */
3306       return sizeof (*ptr);
3307     }
3308   else
3309     {
3310       size_t size = sizeof (*ptr) + string_length (ptr) + 1;
3311       size = ALIGN_SIZE (size, sizeof (Lisp_Object));
3312       return size;
3313     }
3314 }
3315
3316 static size_t
3317 pure_sizeof (Lisp_Object obj)
3318 {
3319   if (!POINTER_TYPE_P (XTYPE (obj))
3320       || !PURIFIED (XPNTR (obj)))
3321     return 0;
3322   /* symbol sizes are accounted for separately */
3323   else if (SYMBOLP (obj))
3324     return 0;
3325   else if (STRINGP (obj))
3326     return pure_string_sizeof (obj);
3327   else if (LRECORDP (obj))
3328     {
3329       struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3330       CONST struct lrecord_implementation *implementation
3331         = LHEADER_IMPLEMENTATION (lheader);
3332
3333         return implementation->size_in_bytes_method
3334           ? implementation->size_in_bytes_method (lheader)
3335           : implementation->static_size;
3336     }
3337 #ifndef LRECORD_VECTOR
3338   else if (VECTORP (obj))
3339     return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, XVECTOR_LENGTH (obj));
3340 #endif /* !LRECORD_VECTOR */
3341
3342 #ifndef LRECORD_CONS
3343   else if (CONSP (obj))
3344     return sizeof (struct Lisp_Cons);
3345 #endif /* !LRECORD_CONS */
3346   else
3347     /* Others can't be purified */
3348     abort ();
3349   return 0; /* unreached */
3350 }
3351 #endif /* PURESTAT */
3352
3353
3354
3355 \f
3356 /* Find all structures not marked, and free them. */
3357
3358 #ifndef LRECORD_VECTOR
3359 static int gc_count_num_vector_used, gc_count_vector_total_size;
3360 static int gc_count_vector_storage;
3361 #endif
3362 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3363 static int gc_count_bit_vector_storage;
3364 static int gc_count_num_short_string_in_use;
3365 static int gc_count_string_total_size;
3366 static int gc_count_short_string_total_size;
3367
3368 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3369
3370 \f
3371 int
3372 lrecord_type_index (CONST struct lrecord_implementation *implementation)
3373 {
3374   int type_index = *(implementation->lrecord_type_index);
3375   /* Have to do this circuitous validation test because of problems
3376      dumping out initialized variables (ie can't set xxx_type_index to -1
3377      because that would make xxx_type_index read-only in a dumped emacs. */
3378   if (type_index < 0 || type_index > max_lrecord_type
3379       || lrecord_implementations_table[type_index] != implementation)
3380     {
3381       if (last_lrecord_type_index_assigned == max_lrecord_type)
3382         abort ();
3383       type_index = ++last_lrecord_type_index_assigned;
3384       lrecord_implementations_table[type_index] = implementation;
3385       *(implementation->lrecord_type_index) = type_index;
3386     }
3387   return type_index;
3388 }
3389
3390 /* stats on lcrecords in use - kinda kludgy */
3391
3392 static struct
3393 {
3394   int instances_in_use;
3395   int bytes_in_use;
3396   int instances_freed;
3397   int bytes_freed;
3398   int instances_on_free_list;
3399 } lcrecord_stats [countof (lrecord_implementations_table)];
3400
3401
3402 static void
3403 reset_lcrecord_stats (void)
3404 {
3405   int i;
3406   for (i = 0; i < countof (lcrecord_stats); i++)
3407     {
3408       lcrecord_stats[i].instances_in_use = 0;
3409       lcrecord_stats[i].bytes_in_use = 0;
3410       lcrecord_stats[i].instances_freed = 0;
3411       lcrecord_stats[i].bytes_freed = 0;
3412       lcrecord_stats[i].instances_on_free_list = 0;
3413     }
3414 }
3415
3416 static void
3417 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
3418 {
3419   CONST struct lrecord_implementation *implementation =
3420     LHEADER_IMPLEMENTATION (h);
3421   int type_index = lrecord_type_index (implementation);
3422
3423   if (((struct lcrecord_header *) h)->free)
3424     {
3425       assert (!free_p);
3426       lcrecord_stats[type_index].instances_on_free_list++;
3427     }
3428   else
3429     {
3430       size_t sz = (implementation->size_in_bytes_method
3431                    ? implementation->size_in_bytes_method (h)
3432                    : implementation->static_size);
3433
3434       if (free_p)
3435         {
3436           lcrecord_stats[type_index].instances_freed++;
3437           lcrecord_stats[type_index].bytes_freed += sz;
3438         }
3439       else
3440         {
3441           lcrecord_stats[type_index].instances_in_use++;
3442           lcrecord_stats[type_index].bytes_in_use += sz;
3443         }
3444     }
3445 }
3446
3447 \f
3448 /* Free all unmarked records */
3449 static void
3450 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3451 {
3452   struct lcrecord_header *header;
3453   int num_used = 0;
3454   /* int total_size = 0; */
3455   reset_lcrecord_stats ();
3456
3457   /* First go through and call all the finalize methods.
3458      Then go through and free the objects.  There used to
3459      be only one loop here, with the call to the finalizer
3460      occurring directly before the xfree() below.  That
3461      is marginally faster but much less safe -- if the
3462      finalize method for an object needs to reference any
3463      other objects contained within it (and many do),
3464      we could easily be screwed by having already freed that
3465      other object. */
3466
3467   for (header = *prev; header; header = header->next)
3468     {
3469       struct lrecord_header *h = &(header->lheader);
3470       if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
3471         {
3472           if (LHEADER_IMPLEMENTATION (h)->finalizer)
3473             LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3474         }
3475     }
3476
3477   for (header = *prev; header; )
3478     {
3479       struct lrecord_header *h = &(header->lheader);
3480       if (MARKED_RECORD_HEADER_P (h))
3481         {
3482           UNMARK_RECORD_HEADER (h);
3483           num_used++;
3484           /* total_size += n->implementation->size_in_bytes (h);*/
3485           prev = &(header->next);
3486           header = *prev;
3487           tick_lcrecord_stats (h, 0);
3488         }
3489       else
3490         {
3491           struct lcrecord_header *next = header->next;
3492           *prev = next;
3493           tick_lcrecord_stats (h, 1);
3494           /* used to call finalizer right here. */
3495           xfree (header);
3496           header = next;
3497         }
3498     }
3499   *used = num_used;
3500   /* *total = total_size; */
3501 }
3502
3503 #ifndef LRECORD_VECTOR
3504
3505 static void
3506 sweep_vectors_1 (Lisp_Object *prev,
3507                  int *used, int *total, int *storage)
3508 {
3509   Lisp_Object vector;
3510   int num_used = 0;
3511   int total_size = 0;
3512   int total_storage = 0;
3513
3514   for (vector = *prev; VECTORP (vector); )
3515     {
3516       Lisp_Vector *v = XVECTOR (vector);
3517       int len = v->size;
3518       if (len < 0)     /* marked */
3519         {
3520           len = - (len + 1);
3521           v->size = len;
3522           total_size += len;
3523           total_storage +=
3524             MALLOC_OVERHEAD +
3525             STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, len + 1);
3526           num_used++;
3527           prev = &(vector_next (v));
3528           vector = *prev;
3529         }
3530       else
3531         {
3532           Lisp_Object next = vector_next (v);
3533           *prev = next;
3534           xfree (v);
3535           vector = next;
3536         }
3537     }
3538   *used = num_used;
3539   *total = total_size;
3540   *storage = total_storage;
3541 }
3542
3543 #endif /* ! LRECORD_VECTOR */
3544
3545 static void
3546 sweep_bit_vectors_1 (Lisp_Object *prev,
3547                      int *used, int *total, int *storage)
3548 {
3549   Lisp_Object bit_vector;
3550   int num_used = 0;
3551   int total_size = 0;
3552   int total_storage = 0;
3553
3554   /* BIT_VECTORP fails because the objects are marked, which changes
3555      their implementation */
3556   for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3557     {
3558       Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3559       int len = v->size;
3560       if (MARKED_RECORD_P (bit_vector))
3561         {
3562           UNMARK_RECORD_HEADER (&(v->lheader));
3563           total_size += len;
3564           total_storage +=
3565             MALLOC_OVERHEAD +
3566             STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
3567                                     BIT_VECTOR_LONG_STORAGE (len));
3568           num_used++;
3569           prev = &(bit_vector_next (v));
3570           bit_vector = *prev;
3571         }
3572       else
3573         {
3574           Lisp_Object next = bit_vector_next (v);
3575           *prev = next;
3576           xfree (v);
3577           bit_vector = next;
3578         }
3579     }
3580   *used = num_used;
3581   *total = total_size;
3582   *storage = total_storage;
3583 }
3584
3585 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3586    to make macros prettier. */
3587
3588 #ifdef ERROR_CHECK_GC
3589
3590 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)                      \
3591 do {                                                                    \
3592   struct typename##_block *SFTB_current;                                \
3593   struct typename##_block **SFTB_prev;                                  \
3594   int SFTB_limit;                                                       \
3595   int num_free = 0, num_used = 0;                                       \
3596                                                                         \
3597   for (SFTB_prev = &current_##typename##_block,                         \
3598        SFTB_current = current_##typename##_block,                       \
3599        SFTB_limit = current_##typename##_block_index;                   \
3600        SFTB_current;                                                    \
3601        )                                                                \
3602     {                                                                   \
3603       int SFTB_iii;                                                     \
3604                                                                         \
3605       for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++)             \
3606         {                                                               \
3607           obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]);     \
3608                                                                         \
3609           if (FREE_STRUCT_P (SFTB_victim))                              \
3610             {                                                           \
3611               num_free++;                                               \
3612             }                                                           \
3613           else if (!MARKED_##typename##_P (SFTB_victim))                \
3614             {                                                           \
3615               num_free++;                                               \
3616               FREE_FIXED_TYPE (typename, obj_type, SFTB_victim);        \
3617             }                                                           \
3618           else                                                          \
3619             {                                                           \
3620