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