Commit | Line | Data |
---|---|---|
7146af97 | 1 | /* Storage allocation and gc for GNU Emacs Lisp interpreter. |
999dd333 | 2 | |
ba318903 | 3 | Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software |
ab422c4d | 4 | Foundation, Inc. |
7146af97 JB |
5 | |
6 | This file is part of GNU Emacs. | |
7 | ||
9ec0b715 | 8 | GNU Emacs is free software: you can redistribute it and/or modify |
7146af97 | 9 | it under the terms of the GNU General Public License as published by |
9ec0b715 GM |
10 | the Free Software Foundation, either version 3 of the License, or |
11 | (at your option) any later version. | |
7146af97 JB |
12 | |
13 | GNU Emacs 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 | |
9ec0b715 | 19 | along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ |
7146af97 | 20 | |
18160b98 | 21 | #include <config.h> |
f162bcc3 | 22 | |
e9b309ac | 23 | #include <stdio.h> |
92939d31 | 24 | |
bc8000ff | 25 | #ifdef ENABLE_CHECKING |
b09cca6a | 26 | #include <signal.h> /* For SIGABRT. */ |
bc8000ff EZ |
27 | #endif |
28 | ||
ae9e757a | 29 | #ifdef HAVE_PTHREAD |
aa477689 JD |
30 | #include <pthread.h> |
31 | #endif | |
32 | ||
d90fb7af RT |
33 | #include <gc.h> |
34 | ||
7146af97 | 35 | #include "lisp.h" |
ece93c02 | 36 | #include "process.h" |
d5e35230 | 37 | #include "intervals.h" |
e5560ff7 | 38 | #include "character.h" |
7146af97 JB |
39 | #include "buffer.h" |
40 | #include "window.h" | |
2538fae4 | 41 | #include "keyboard.h" |
502b9b64 | 42 | #include "frame.h" |
4a729fd8 | 43 | #include "termhooks.h" /* For struct terminal. */ |
d141d701 DA |
44 | #ifdef HAVE_WINDOW_SYSTEM |
45 | #include TERM_HEADER | |
46 | #endif /* HAVE_WINDOW_SYSTEM */ | |
0328b6de | 47 | |
0065d054 | 48 | #include <verify.h> |
608a4502 | 49 | #include <execinfo.h> /* For backtrace. */ |
01ae0fbf | 50 | |
009581fa PE |
51 | #if (defined ENABLE_CHECKING \ |
52 | && defined HAVE_VALGRIND_VALGRIND_H \ | |
53 | && !defined USE_VALGRIND) | |
54 | # define USE_VALGRIND 1 | |
55 | #endif | |
56 | ||
a84683fd DC |
57 | #if USE_VALGRIND |
58 | #include <valgrind/valgrind.h> | |
59 | #include <valgrind/memcheck.h> | |
d160dd0c | 60 | static bool valgrind_p; |
a84683fd DC |
61 | #endif |
62 | ||
bf952fb6 | 63 | #include <unistd.h> |
de7124a7 | 64 | #include <fcntl.h> |
de7124a7 | 65 | |
a411ac43 PE |
66 | #ifdef USE_GTK |
67 | # include "gtkutil.h" | |
68 | #endif | |
69666f77 | 69 | #ifdef WINDOWSNT |
f892cf9c | 70 | #include "w32.h" |
62aba0d4 | 71 | #include "w32heap.h" /* for sbrk */ |
69666f77 EZ |
72 | #endif |
73 | ||
0dd6d66d DA |
74 | /* Default value of gc_cons_threshold (see below). */ |
75 | ||
663e2b3f | 76 | #define GC_DEFAULT_THRESHOLD (100000 * word_size) |
0dd6d66d | 77 | |
29208e82 TT |
78 | /* Global variables. */ |
79 | struct emacs_globals globals; | |
80 | ||
2e471eb5 GM |
81 | /* Number of bytes of consing done since the last gc. */ |
82 | ||
dac616ff | 83 | EMACS_INT consing_since_gc; |
7146af97 | 84 | |
974aae61 RS |
85 | /* Similar minimum, computed from Vgc_cons_percentage. */ |
86 | ||
dac616ff | 87 | EMACS_INT gc_relative_threshold; |
310ea200 | 88 | |
24d8a105 RS |
89 | /* Minimum number of bytes of consing since GC before next GC, |
90 | when memory is full. */ | |
91 | ||
c6b04f6b | 92 | EMACS_INT memory_full_cons_threshold = 1 << 10; |
24d8a105 | 93 | |
fce31d69 | 94 | /* True during GC. */ |
2e471eb5 | 95 | |
fce31d69 | 96 | bool gc_in_progress; |
7146af97 | 97 | |
fce31d69 | 98 | /* True means abort if try to GC. |
3de0effb RS |
99 | This is for code which is written on the assumption that |
100 | no GC will happen, so as to verify that assumption. */ | |
101 | ||
fce31d69 | 102 | bool abort_on_gc; |
3de0effb | 103 | |
34400008 GM |
104 | /* Number of live and free conses etc. */ |
105 | ||
3ab6e069 | 106 | static EMACS_INT total_conses, total_markers, total_symbols, total_buffers; |
c0c5c8ae | 107 | static EMACS_INT total_free_conses, total_free_markers, total_free_symbols; |
3ab6e069 | 108 | static EMACS_INT total_free_floats, total_floats; |
fd27a537 | 109 | |
2e471eb5 | 110 | /* Points to memory space allocated as "spare", to be freed if we run |
c6b04f6b | 111 | out of memory. */ |
2e471eb5 | 112 | |
c6b04f6b | 113 | static void *spare_memory; |
276cbe5a | 114 | |
2b6148e4 PE |
115 | /* Amount of spare memory to keep in large reserve block, or to see |
116 | whether this much is available when malloc fails on a larger request. */ | |
2e471eb5 | 117 | |
c6b04f6b | 118 | #define SPARE_MEMORY (1 << 15) |
4d09bcf6 | 119 | |
2e471eb5 GM |
120 | /* If nonzero, this is a warning delivered by malloc and not yet |
121 | displayed. */ | |
122 | ||
a8fe7202 | 123 | const char *pending_malloc_warning; |
7146af97 | 124 | |
955cbe7b PE |
125 | static Lisp_Object Qgc_cons_threshold; |
126 | Lisp_Object Qchar_table_extra_slots; | |
e8197642 | 127 | |
9e713715 GM |
128 | /* Hook run after GC has finished. */ |
129 | ||
955cbe7b | 130 | static Lisp_Object Qpost_gc_hook; |
2c5bd608 | 131 | |
69003fd8 PE |
132 | #if !defined REL_ALLOC || defined SYSTEM_MALLOC |
133 | static void refill_memory_reserve (void); | |
134 | #endif | |
836d0c80 | 135 | static Lisp_Object make_empty_string (int); |
196e41e4 | 136 | extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; |
34400008 | 137 | |
ca78dc43 PE |
138 | #ifndef DEADP |
139 | # define DEADP(x) 0 | |
140 | #endif | |
141 | ||
1f0b3fd2 GM |
142 | /* Recording what needs to be marked for gc. */ |
143 | ||
144 | struct gcpro *gcprolist; | |
7146af97 | 145 | \f |
34400008 GM |
146 | /************************************************************************ |
147 | Malloc | |
148 | ************************************************************************/ | |
149 | ||
4455ad75 | 150 | /* Function malloc calls this if it finds we are near exhausting storage. */ |
d457598b AS |
151 | |
152 | void | |
a8fe7202 | 153 | malloc_warning (const char *str) |
7146af97 JB |
154 | { |
155 | pending_malloc_warning = str; | |
156 | } | |
157 | ||
34400008 | 158 | |
4455ad75 | 159 | /* Display an already-pending malloc warning. */ |
34400008 | 160 | |
d457598b | 161 | void |
971de7fb | 162 | display_malloc_warning (void) |
7146af97 | 163 | { |
4455ad75 RS |
164 | call3 (intern ("display-warning"), |
165 | intern ("alloc"), | |
166 | build_string (pending_malloc_warning), | |
167 | intern ("emergency")); | |
7146af97 | 168 | pending_malloc_warning = 0; |
7146af97 | 169 | } |
49efed3a | 170 | \f |
276cbe5a RS |
171 | /* Called if we can't allocate relocatable space for a buffer. */ |
172 | ||
173 | void | |
d311d28c | 174 | buffer_memory_full (ptrdiff_t nbytes) |
276cbe5a | 175 | { |
2e471eb5 GM |
176 | /* If buffers use the relocating allocator, no need to free |
177 | spare_memory, because we may have plenty of malloc space left | |
178 | that we could get, and if we don't, the malloc that fails will | |
179 | itself cause spare_memory to be freed. If buffers don't use the | |
180 | relocating allocator, treat this like any other failing | |
181 | malloc. */ | |
276cbe5a RS |
182 | |
183 | #ifndef REL_ALLOC | |
531b0165 | 184 | memory_full (nbytes); |
d9df6f40 | 185 | #else |
2e471eb5 GM |
186 | /* This used to call error, but if we've run out of memory, we could |
187 | get infinite recursion trying to build the string. */ | |
9b306d37 | 188 | xsignal (Qnil, Vmemory_signal_data); |
d9df6f40 | 189 | #endif |
7146af97 JB |
190 | } |
191 | ||
d90fb7af | 192 | /* Like GC_MALLOC but check for no memory. */ |
7146af97 | 193 | |
261cb4bb | 194 | void * |
971de7fb | 195 | xmalloc (size_t size) |
7146af97 | 196 | { |
d90fb7af | 197 | void *val = GC_MALLOC (size); |
2e471eb5 | 198 | if (!val && size) |
531b0165 | 199 | memory_full (size); |
7146af97 JB |
200 | return val; |
201 | } | |
202 | ||
23f86fce DA |
203 | /* Like the above, but zeroes out the memory just allocated. */ |
204 | ||
205 | void * | |
206 | xzalloc (size_t size) | |
207 | { | |
d90fb7af | 208 | return xmalloc (size); |
23f86fce | 209 | } |
34400008 | 210 | |
d90fb7af | 211 | /* Like GC_REALLOC but check for no memory. */ |
34400008 | 212 | |
261cb4bb PE |
213 | void * |
214 | xrealloc (void *block, size_t size) | |
7146af97 | 215 | { |
d90fb7af | 216 | void *val = GC_REALLOC (block, size); |
531b0165 PE |
217 | if (!val && size) |
218 | memory_full (size); | |
7146af97 JB |
219 | return val; |
220 | } | |
9ac0d9e0 JB |
221 | |
222 | void | |
261cb4bb | 223 | xfree (void *block) |
9ac0d9e0 | 224 | { |
d90fb7af | 225 | return; |
9ac0d9e0 JB |
226 | } |
227 | ||
c6b8a15b RT |
228 | /* Allocate pointerless memory. */ |
229 | ||
230 | void * | |
231 | xmalloc_atomic (size_t size) | |
232 | { | |
233 | void *val = GC_MALLOC_ATOMIC (size); | |
234 | if (! val && size) | |
235 | memory_full (size); | |
236 | return val; | |
237 | } | |
238 | ||
239 | void * | |
240 | xzalloc_atomic (size_t size) | |
241 | { | |
242 | return xmalloc_atomic (size); | |
243 | } | |
244 | ||
902fe370 BT |
245 | /* Allocate uncollectable memory. */ |
246 | ||
247 | void * | |
248 | xmalloc_uncollectable (size_t size) | |
249 | { | |
250 | void *val = GC_MALLOC_UNCOLLECTABLE (size); | |
251 | if (! val && size) | |
252 | memory_full (size); | |
253 | return val; | |
254 | } | |
255 | ||
c308c819 RT |
256 | /* Allocate memory, but if memory is exhausted, return NULL instead of |
257 | signalling an error. */ | |
258 | ||
259 | void * | |
260 | xmalloc_unsafe (size_t size) | |
261 | { | |
262 | return GC_MALLOC (size); | |
263 | } | |
c8099634 | 264 | |
c6b8a15b RT |
265 | /* Allocate pointerless memory, but if memory is exhausted, return |
266 | NULL instead of signalling an error. */ | |
267 | ||
268 | void * | |
269 | xmalloc_atomic_unsafe (size_t size) | |
270 | { | |
271 | return GC_MALLOC_ATOMIC (size); | |
272 | } | |
273 | ||
0065d054 PE |
274 | /* Other parts of Emacs pass large int values to allocator functions |
275 | expecting ptrdiff_t. This is portable in practice, but check it to | |
276 | be safe. */ | |
277 | verify (INT_MAX <= PTRDIFF_MAX); | |
278 | ||
279 | ||
280 | /* Allocate an array of NITEMS items, each of size ITEM_SIZE. | |
d90fb7af | 281 | Signal an error on memory exhaustion. */ |
0065d054 PE |
282 | |
283 | void * | |
284 | xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size) | |
285 | { | |
a54e2c05 | 286 | eassert (0 <= nitems && 0 < item_size); |
0065d054 PE |
287 | if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) |
288 | memory_full (SIZE_MAX); | |
289 | return xmalloc (nitems * item_size); | |
290 | } | |
291 | ||
c6b8a15b RT |
292 | /* Like xnmalloc for pointerless objects. */ |
293 | ||
294 | void * | |
295 | xnmalloc_atomic (ptrdiff_t nitems, ptrdiff_t item_size) | |
296 | { | |
297 | eassert (0 <= nitems && 0 < item_size); | |
298 | if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) | |
299 | memory_full (SIZE_MAX); | |
300 | return xmalloc_atomic (nitems * item_size); | |
301 | } | |
0065d054 PE |
302 | |
303 | /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE. | |
d90fb7af | 304 | Signal an error on memory exhaustion. */ |
0065d054 PE |
305 | |
306 | void * | |
307 | xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size) | |
308 | { | |
a54e2c05 | 309 | eassert (0 <= nitems && 0 < item_size); |
0065d054 PE |
310 | if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) |
311 | memory_full (SIZE_MAX); | |
312 | return xrealloc (pa, nitems * item_size); | |
313 | } | |
314 | ||
315 | ||
316 | /* Grow PA, which points to an array of *NITEMS items, and return the | |
317 | location of the reallocated array, updating *NITEMS to reflect its | |
318 | new size. The new array will contain at least NITEMS_INCR_MIN more | |
319 | items, but will not contain more than NITEMS_MAX items total. | |
320 | ITEM_SIZE is the size of each item, in bytes. | |
321 | ||
322 | ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be | |
323 | nonnegative. If NITEMS_MAX is -1, it is treated as if it were | |
324 | infinity. | |
325 | ||
326 | If PA is null, then allocate a new array instead of reallocating | |
2dd2e622 | 327 | the old one. |
0065d054 | 328 | |
d90fb7af RT |
329 | If memory exhaustion occurs, set *NITEMS to zero if PA is null, and |
330 | signal an error (i.e., do not return). | |
2dd2e622 PE |
331 | |
332 | Thus, to grow an array A without saving its old contents, do | |
333 | { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }. | |
334 | The A = NULL avoids a dangling pointer if xpalloc exhausts memory | |
335 | and signals an error, and later this code is reexecuted and | |
336 | attempts to free A. */ | |
0065d054 PE |
337 | |
338 | void * | |
339 | xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min, | |
340 | ptrdiff_t nitems_max, ptrdiff_t item_size) | |
341 | { | |
342 | /* The approximate size to use for initial small allocation | |
343 | requests. This is the largest "small" request for the GNU C | |
344 | library malloc. */ | |
345 | enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 }; | |
346 | ||
347 | /* If the array is tiny, grow it to about (but no greater than) | |
348 | DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */ | |
349 | ptrdiff_t n = *nitems; | |
350 | ptrdiff_t tiny_max = DEFAULT_MXFAST / item_size - n; | |
351 | ptrdiff_t half_again = n >> 1; | |
352 | ptrdiff_t incr_estimate = max (tiny_max, half_again); | |
353 | ||
354 | /* Adjust the increment according to three constraints: NITEMS_INCR_MIN, | |
355 | NITEMS_MAX, and what the C language can represent safely. */ | |
356 | ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / item_size; | |
357 | ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max | |
358 | ? nitems_max : C_language_max); | |
359 | ptrdiff_t nitems_incr_max = n_max - n; | |
360 | ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max)); | |
361 | ||
7216e43b | 362 | eassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max); |
0065d054 PE |
363 | if (! pa) |
364 | *nitems = 0; | |
365 | if (nitems_incr_max < incr) | |
366 | memory_full (SIZE_MAX); | |
367 | n += incr; | |
368 | pa = xrealloc (pa, n * item_size); | |
369 | *nitems = n; | |
370 | return pa; | |
371 | } | |
372 | ||
373 | ||
dca7c6a8 GM |
374 | /* Like strdup, but uses xmalloc. */ |
375 | ||
376 | char * | |
971de7fb | 377 | xstrdup (const char *s) |
dca7c6a8 | 378 | { |
9acc1074 | 379 | ptrdiff_t size; |
309f24d1 | 380 | eassert (s); |
9acc1074 | 381 | size = strlen (s) + 1; |
a0a9ac13 | 382 | return memcpy (xmalloc_atomic (size), s, size); |
dca7c6a8 GM |
383 | } |
384 | ||
5b71542d DA |
385 | /* Like above, but duplicates Lisp string to C string. */ |
386 | ||
387 | char * | |
388 | xlispstrdup (Lisp_Object string) | |
389 | { | |
390 | ptrdiff_t size = SBYTES (string) + 1; | |
a0a9ac13 | 391 | return memcpy (xmalloc_atomic (size), SSDATA (string), size); |
5b71542d DA |
392 | } |
393 | ||
8268febf PE |
394 | /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly |
395 | pointed to. If STRING is null, assign it without copying anything. | |
396 | Allocate before freeing, to avoid a dangling pointer if allocation | |
397 | fails. */ | |
398 | ||
399 | void | |
400 | dupstring (char **ptr, char const *string) | |
401 | { | |
402 | char *old = *ptr; | |
403 | *ptr = string ? xstrdup (string) : 0; | |
404 | xfree (old); | |
405 | } | |
406 | ||
407 | ||
5745a7df PE |
408 | /* Like putenv, but (1) use the equivalent of xmalloc and (2) the |
409 | argument is a const pointer. */ | |
410 | ||
411 | void | |
412 | xputenv (char const *string) | |
413 | { | |
414 | if (putenv ((char *) string) != 0) | |
415 | memory_full (0); | |
416 | } | |
dca7c6a8 | 417 | |
98c6f1e3 PE |
418 | /* Return a newly allocated memory block of SIZE bytes, remembering |
419 | to free it when unwinding. */ | |
420 | void * | |
421 | record_xmalloc (size_t size) | |
422 | { | |
423 | void *p = xmalloc (size); | |
27e498e6 | 424 | record_unwind_protect_ptr (xfree, p); |
98c6f1e3 PE |
425 | return p; |
426 | } | |
d90fb7af RT |
427 | \f |
428 | /*********************************************************************** | |
429 | Interval Allocation | |
430 | ***********************************************************************/ | |
98c6f1e3 | 431 | |
d90fb7af | 432 | /* Return a new interval. */ |
f61bef8b | 433 | |
d90fb7af RT |
434 | INTERVAL |
435 | make_interval (void) | |
c8099634 | 436 | { |
d90fb7af RT |
437 | INTERVAL val = xmalloc (sizeof (struct interval)); |
438 | RESET_INTERVAL (val); | |
c8099634 RS |
439 | return val; |
440 | } | |
441 | ||
d90fb7af RT |
442 | /*********************************************************************** |
443 | String Allocation | |
444 | ***********************************************************************/ | |
445 | ||
446 | /* Initialize string allocation. Called from init_alloc_once. */ | |
34400008 | 447 | |
bf952fb6 | 448 | static void |
d90fb7af | 449 | init_strings (void) |
c8099634 | 450 | { |
836d0c80 RT |
451 | empty_unibyte_string = make_empty_string (0); |
452 | empty_multibyte_string = make_empty_string (1); | |
c8099634 | 453 | } |
34400008 | 454 | |
d90fb7af | 455 | /* Return a new Lisp_String. */ |
e76119d7 | 456 | |
d90fb7af RT |
457 | static struct Lisp_String * |
458 | allocate_string (void) | |
aea07e2c | 459 | { |
2316e1d3 BT |
460 | struct Lisp_String *p; |
461 | ||
462 | p = xmalloc (sizeof *p); | |
463 | SCM_NEWSMOB (p->self, lisp_string_tag, p); | |
464 | return p; | |
aea07e2c | 465 | } |
ab6780cd | 466 | |
ab6780cd | 467 | |
d90fb7af RT |
468 | /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes, |
469 | plus a NUL byte at the end. Allocate an sdata structure for S, and | |
470 | set S->data to its `u.data' member. Store a NUL byte at the end of | |
471 | S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free | |
472 | S->data if it was initially non-null. */ | |
ab6780cd | 473 | |
d90fb7af RT |
474 | void |
475 | allocate_string_data (struct Lisp_String *s, | |
476 | EMACS_INT nchars, EMACS_INT nbytes) | |
477 | { | |
478 | unsigned char *data; | |
ab6780cd | 479 | |
d90fb7af RT |
480 | if (STRING_BYTES_BOUND < nbytes) |
481 | string_overflow (); | |
ab6780cd | 482 | |
d90fb7af RT |
483 | data = GC_MALLOC_ATOMIC (nbytes + 1); |
484 | s->data = data; | |
485 | s->size = nchars; | |
486 | s->size_byte = nbytes; | |
487 | s->data[nbytes] = '\0'; | |
488 | } | |
ab6780cd | 489 | |
d90fb7af RT |
490 | void |
491 | string_overflow (void) | |
ab6780cd | 492 | { |
d90fb7af RT |
493 | error ("Maximum string size exceeded"); |
494 | } | |
ab6780cd | 495 | |
836d0c80 RT |
496 | static Lisp_Object |
497 | make_empty_string (int multibyte) | |
498 | { | |
499 | Lisp_Object string; | |
500 | struct Lisp_String *s; | |
501 | ||
502 | s = allocate_string (); | |
503 | allocate_string_data (s, 0, 0); | |
504 | XSETSTRING (string, s); | |
505 | if (! multibyte) | |
506 | STRING_SET_UNIBYTE (string); | |
507 | ||
508 | return string; | |
509 | } | |
510 | ||
d90fb7af RT |
511 | DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, |
512 | doc: /* Return a newly created string of length LENGTH, with INIT in each element. | |
513 | LENGTH must be an integer. | |
514 | INIT must be an integer that represents a character. */) | |
515 | (Lisp_Object length, Lisp_Object init) | |
516 | { | |
517 | register Lisp_Object val; | |
518 | int c; | |
519 | EMACS_INT nbytes; | |
ab6780cd | 520 | |
d90fb7af RT |
521 | CHECK_NATNUM (length); |
522 | CHECK_CHARACTER (init); | |
ab6780cd | 523 | |
d90fb7af RT |
524 | c = XFASTINT (init); |
525 | if (ASCII_CHAR_P (c)) | |
ab6780cd | 526 | { |
d90fb7af RT |
527 | nbytes = XINT (length); |
528 | val = make_uninit_string (nbytes); | |
529 | memset (SDATA (val), c, nbytes); | |
530 | SDATA (val)[nbytes] = 0; | |
531 | } | |
532 | else | |
533 | { | |
534 | unsigned char str[MAX_MULTIBYTE_LENGTH]; | |
535 | ptrdiff_t len = CHAR_STRING (c, str); | |
536 | EMACS_INT string_len = XINT (length); | |
537 | unsigned char *p, *beg, *end; | |
ab6780cd | 538 | |
d90fb7af RT |
539 | if (string_len > STRING_BYTES_BOUND / len) |
540 | string_overflow (); | |
541 | nbytes = len * string_len; | |
542 | val = make_uninit_multibyte_string (string_len, nbytes); | |
543 | for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len) | |
8f924df7 | 544 | { |
d90fb7af RT |
545 | /* First time we just copy `str' to the data of `val'. */ |
546 | if (p == beg) | |
547 | memcpy (p, str, len); | |
548 | else | |
8f924df7 | 549 | { |
d90fb7af RT |
550 | /* Next time we copy largest possible chunk from |
551 | initialized to uninitialized part of `val'. */ | |
552 | len = min (p - beg, end - p); | |
553 | memcpy (p, beg, len); | |
8f924df7 KH |
554 | } |
555 | } | |
d90fb7af | 556 | *p = 0; |
ab6780cd SM |
557 | } |
558 | ||
ab6780cd SM |
559 | return val; |
560 | } | |
561 | ||
d90fb7af RT |
562 | /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise. |
563 | Return A. */ | |
ab6780cd | 564 | |
d90fb7af RT |
565 | Lisp_Object |
566 | bool_vector_fill (Lisp_Object a, Lisp_Object init) | |
567 | { | |
568 | EMACS_INT nbits = bool_vector_size (a); | |
569 | if (0 < nbits) | |
570 | { | |
571 | unsigned char *data = bool_vector_uchar_data (a); | |
572 | int pattern = NILP (init) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR) - 1; | |
573 | ptrdiff_t nbytes = bool_vector_bytes (nbits); | |
574 | int last_mask = ~ (~0u << ((nbits - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)); | |
575 | memset (data, pattern, nbytes - 1); | |
576 | data[nbytes - 1] = pattern & last_mask; | |
ab6780cd | 577 | } |
d90fb7af | 578 | return a; |
ab6780cd | 579 | } |
1a4f1e2c | 580 | |
d90fb7af | 581 | /* Return a newly allocated, uninitialized bool vector of size NBITS. */ |
34400008 | 582 | |
d90fb7af RT |
583 | Lisp_Object |
584 | make_uninit_bool_vector (EMACS_INT nbits) | |
2e471eb5 | 585 | { |
d90fb7af RT |
586 | Lisp_Object val; |
587 | EMACS_INT words = bool_vector_words (nbits); | |
588 | EMACS_INT word_bytes = words * sizeof (bits_word); | |
589 | EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes | |
590 | + word_size - 1) | |
591 | / word_size); | |
592 | struct Lisp_Bool_Vector *p | |
593 | = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements); | |
594 | XSETVECTOR (val, p); | |
595 | XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0); | |
596 | p->size = nbits; | |
d5e35230 | 597 | |
d90fb7af RT |
598 | /* Clear padding at the end. */ |
599 | if (words) | |
600 | p->data[words - 1] = 0; | |
34400008 | 601 | |
d90fb7af RT |
602 | return val; |
603 | } | |
34400008 | 604 | |
d90fb7af RT |
605 | DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0, |
606 | doc: /* Return a new bool-vector of length LENGTH, using INIT for each element. | |
607 | LENGTH must be a number. INIT matters only in whether it is t or nil. */) | |
608 | (Lisp_Object length, Lisp_Object init) | |
609 | { | |
610 | Lisp_Object val; | |
34400008 | 611 | |
d90fb7af RT |
612 | CHECK_NATNUM (length); |
613 | val = make_uninit_bool_vector (XFASTINT (length)); | |
614 | return bool_vector_fill (val, init); | |
615 | } | |
34400008 | 616 | |
d90fb7af RT |
617 | DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0, |
618 | doc: /* Return a new bool-vector with specified arguments as elements. | |
619 | Any number of arguments, even zero arguments, are allowed. | |
620 | usage: (bool-vector &rest OBJECTS) */) | |
621 | (ptrdiff_t nargs, Lisp_Object *args) | |
622 | { | |
623 | ptrdiff_t i; | |
624 | Lisp_Object vector; | |
d5e35230 | 625 | |
d90fb7af RT |
626 | vector = make_uninit_bool_vector (nargs); |
627 | for (i = 0; i < nargs; i++) | |
628 | bool_vector_set (vector, i, !NILP (args[i])); | |
34400008 | 629 | |
d90fb7af RT |
630 | return vector; |
631 | } | |
d5e35230 | 632 | |
d90fb7af RT |
633 | /* Make a string from NBYTES bytes at CONTENTS, and compute the number |
634 | of characters from the contents. This string may be unibyte or | |
635 | multibyte, depending on the contents. */ | |
d5e35230 | 636 | |
d90fb7af RT |
637 | Lisp_Object |
638 | make_string (const char *contents, ptrdiff_t nbytes) | |
d5e35230 | 639 | { |
d90fb7af RT |
640 | register Lisp_Object val; |
641 | ptrdiff_t nchars, multibyte_nbytes; | |
d5e35230 | 642 | |
d90fb7af RT |
643 | parse_str_as_multibyte ((const unsigned char *) contents, nbytes, |
644 | &nchars, &multibyte_nbytes); | |
645 | if (nbytes == nchars || nbytes != multibyte_nbytes) | |
646 | /* CONTENTS contains no multibyte sequences or contains an invalid | |
647 | multibyte sequence. We must make unibyte string. */ | |
648 | val = make_unibyte_string (contents, nbytes); | |
d5e35230 | 649 | else |
d90fb7af | 650 | val = make_multibyte_string (contents, nchars, nbytes); |
d5e35230 JA |
651 | return val; |
652 | } | |
653 | ||
34400008 | 654 | |
d90fb7af | 655 | /* Make an unibyte string from LENGTH bytes at CONTENTS. */ |
d5e35230 | 656 | |
d90fb7af RT |
657 | Lisp_Object |
658 | make_unibyte_string (const char *contents, ptrdiff_t length) | |
d5e35230 | 659 | { |
d90fb7af RT |
660 | register Lisp_Object val; |
661 | val = make_uninit_string (length); | |
662 | memcpy (SDATA (val), contents, length); | |
663 | return val; | |
d5e35230 JA |
664 | } |
665 | ||
34400008 | 666 | |
d90fb7af RT |
667 | /* Make a multibyte string from NCHARS characters occupying NBYTES |
668 | bytes at CONTENTS. */ | |
1a4f1e2c | 669 | |
d90fb7af RT |
670 | Lisp_Object |
671 | make_multibyte_string (const char *contents, | |
672 | ptrdiff_t nchars, ptrdiff_t nbytes) | |
673 | { | |
674 | register Lisp_Object val; | |
675 | val = make_uninit_multibyte_string (nchars, nbytes); | |
676 | memcpy (SDATA (val), contents, nbytes); | |
677 | return val; | |
678 | } | |
7146af97 | 679 | |
7146af97 | 680 | |
d90fb7af RT |
681 | /* Make a string from NCHARS characters occupying NBYTES bytes at |
682 | CONTENTS. It is a multibyte string if NBYTES != NCHARS. */ | |
7146af97 | 683 | |
d90fb7af RT |
684 | Lisp_Object |
685 | make_string_from_bytes (const char *contents, | |
686 | ptrdiff_t nchars, ptrdiff_t nbytes) | |
687 | { | |
688 | register Lisp_Object val; | |
689 | val = make_uninit_multibyte_string (nchars, nbytes); | |
690 | memcpy (SDATA (val), contents, nbytes); | |
691 | if (SBYTES (val) == SCHARS (val)) | |
692 | STRING_SET_UNIBYTE (val); | |
693 | return val; | |
694 | } | |
7146af97 | 695 | |
7146af97 | 696 | |
d90fb7af RT |
697 | /* Make a string from NCHARS characters occupying NBYTES bytes at |
698 | CONTENTS. The argument MULTIBYTE controls whether to label the | |
699 | string as multibyte. If NCHARS is negative, it counts the number of | |
700 | characters by itself. */ | |
c8099634 | 701 | |
d90fb7af RT |
702 | Lisp_Object |
703 | make_specified_string (const char *contents, | |
704 | ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte) | |
705 | { | |
706 | Lisp_Object val; | |
7146af97 | 707 | |
d90fb7af RT |
708 | if (nchars < 0) |
709 | { | |
710 | if (multibyte) | |
711 | nchars = multibyte_chars_in_text ((const unsigned char *) contents, | |
712 | nbytes); | |
713 | else | |
714 | nchars = nbytes; | |
715 | } | |
716 | val = make_uninit_multibyte_string (nchars, nbytes); | |
717 | memcpy (SDATA (val), contents, nbytes); | |
718 | if (!multibyte) | |
719 | STRING_SET_UNIBYTE (val); | |
720 | return val; | |
721 | } | |
2e471eb5 | 722 | |
2e471eb5 | 723 | |
d90fb7af RT |
724 | /* Return an unibyte Lisp_String set up to hold LENGTH characters |
725 | occupying LENGTH bytes. */ | |
91f2d272 | 726 | |
d90fb7af RT |
727 | Lisp_Object |
728 | make_uninit_string (EMACS_INT length) | |
fbe9e0b9 | 729 | { |
d90fb7af | 730 | Lisp_Object val; |
2e471eb5 | 731 | |
d90fb7af RT |
732 | if (!length) |
733 | return empty_unibyte_string; | |
734 | val = make_uninit_multibyte_string (length, length); | |
735 | STRING_SET_UNIBYTE (val); | |
736 | return val; | |
737 | } | |
177c0ea7 | 738 | |
31d929e5 | 739 | |
d90fb7af RT |
740 | /* Return a multibyte Lisp_String set up to hold NCHARS characters |
741 | which occupy NBYTES bytes. */ | |
2e471eb5 | 742 | |
d90fb7af RT |
743 | Lisp_Object |
744 | make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) | |
7146af97 | 745 | { |
d90fb7af RT |
746 | Lisp_Object string; |
747 | struct Lisp_String *s; | |
2e471eb5 | 748 | |
d90fb7af RT |
749 | if (nchars < 0) |
750 | emacs_abort (); | |
751 | if (!nbytes) | |
752 | return empty_multibyte_string; | |
2e471eb5 | 753 | |
d90fb7af RT |
754 | s = allocate_string (); |
755 | s->intervals = NULL; | |
756 | allocate_string_data (s, nchars, nbytes); | |
757 | XSETSTRING (string, s); | |
758 | return string; | |
759 | } | |
2e471eb5 | 760 | |
d90fb7af RT |
761 | /* Print arguments to BUF according to a FORMAT, then return |
762 | a Lisp_String initialized with the data from BUF. */ | |
2e471eb5 | 763 | |
d90fb7af RT |
764 | Lisp_Object |
765 | make_formatted_string (char *buf, const char *format, ...) | |
7146af97 | 766 | { |
d90fb7af RT |
767 | va_list ap; |
768 | int length; | |
7146af97 | 769 | |
d90fb7af RT |
770 | va_start (ap, format); |
771 | length = vsprintf (buf, format, ap); | |
772 | va_end (ap); | |
773 | return make_string (buf, length); | |
774 | } | |
3c06d205 | 775 | |
d90fb7af RT |
776 | \f |
777 | /*********************************************************************** | |
778 | Float Allocation | |
779 | ***********************************************************************/ | |
7146af97 | 780 | |
d90fb7af | 781 | /* Return a new float object with value FLOAT_VALUE. */ |
7146af97 | 782 | |
d90fb7af RT |
783 | Lisp_Object |
784 | make_float (double float_value) | |
785 | { | |
195e507c | 786 | return scm_from_double (float_value); |
d90fb7af | 787 | } |
7146af97 | 788 | |
d90fb7af RT |
789 | \f |
790 | /*********************************************************************** | |
791 | Cons Allocation | |
792 | ***********************************************************************/ | |
7146af97 | 793 | |
d90fb7af RT |
794 | DEFUN ("cons", Fcons, Scons, 2, 2, 0, |
795 | doc: /* Create a new cons, give it CAR and CDR as components, and return it. */) | |
796 | (Lisp_Object car, Lisp_Object cdr) | |
797 | { | |
ffd1b8f8 | 798 | return scm_cons (car, cdr); |
d90fb7af | 799 | } |
7146af97 | 800 | |
d90fb7af | 801 | /* Make a list of 1, 2, 3, 4 or 5 specified objects. */ |
c8099634 | 802 | |
d90fb7af RT |
803 | Lisp_Object |
804 | list1 (Lisp_Object arg1) | |
805 | { | |
806 | return Fcons (arg1, Qnil); | |
807 | } | |
7146af97 | 808 | |
d90fb7af RT |
809 | Lisp_Object |
810 | list2 (Lisp_Object arg1, Lisp_Object arg2) | |
811 | { | |
812 | return Fcons (arg1, Fcons (arg2, Qnil)); | |
813 | } | |
2e471eb5 | 814 | |
2e471eb5 | 815 | |
d90fb7af RT |
816 | Lisp_Object |
817 | list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) | |
818 | { | |
819 | return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil))); | |
820 | } | |
2e471eb5 | 821 | |
2e471eb5 | 822 | |
d90fb7af RT |
823 | Lisp_Object |
824 | list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4) | |
825 | { | |
826 | return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil)))); | |
827 | } | |
177c0ea7 | 828 | |
31d929e5 | 829 | |
d90fb7af RT |
830 | Lisp_Object |
831 | list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) | |
832 | { | |
833 | return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, | |
834 | Fcons (arg5, Qnil))))); | |
835 | } | |
2e471eb5 | 836 | |
d90fb7af RT |
837 | /* Make a list of COUNT Lisp_Objects, where ARG is the |
838 | first one. Allocate conses from pure space if TYPE | |
839 | is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */ | |
f2d3008d | 840 | |
d90fb7af RT |
841 | Lisp_Object |
842 | listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...) | |
843 | { | |
844 | va_list ap; | |
845 | ptrdiff_t i; | |
846 | Lisp_Object val, *objp; | |
31d929e5 | 847 | |
d90fb7af RT |
848 | /* Change to SAFE_ALLOCA if you hit this eassert. */ |
849 | eassert (count <= MAX_ALLOCA / word_size); | |
c9d624c6 | 850 | |
d90fb7af RT |
851 | objp = alloca (count * word_size); |
852 | objp[0] = arg; | |
853 | va_start (ap, arg); | |
854 | for (i = 1; i < count; i++) | |
855 | objp[i] = va_arg (ap, Lisp_Object); | |
856 | va_end (ap); | |
d457598b | 857 | |
d90fb7af RT |
858 | for (val = Qnil, i = count - 1; i >= 0; i--) |
859 | { | |
860 | if (type == CONSTYPE_PURE) | |
861 | val = pure_cons (objp[i], val); | |
862 | else if (type == CONSTYPE_HEAP) | |
863 | val = Fcons (objp[i], val); | |
864 | else | |
865 | emacs_abort (); | |
866 | } | |
867 | return val; | |
7146af97 JB |
868 | } |
869 | ||
d90fb7af RT |
870 | DEFUN ("list", Flist, Slist, 0, MANY, 0, |
871 | doc: /* Return a newly created list with specified arguments as elements. | |
872 | Any number of arguments, even zero arguments, are allowed. | |
873 | usage: (list &rest OBJECTS) */) | |
874 | (ptrdiff_t nargs, Lisp_Object *args) | |
7146af97 | 875 | { |
d90fb7af RT |
876 | register Lisp_Object val; |
877 | val = Qnil; | |
7146af97 | 878 | |
d90fb7af | 879 | while (nargs > 0) |
7146af97 | 880 | { |
d90fb7af RT |
881 | nargs--; |
882 | val = Fcons (args[nargs], val); | |
7146af97 | 883 | } |
d90fb7af RT |
884 | return val; |
885 | } | |
c0f51373 | 886 | |
c0f51373 | 887 | |
d90fb7af RT |
888 | DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, |
889 | doc: /* Return a newly created list of length LENGTH, with each element being INIT. */) | |
890 | (register Lisp_Object length, Lisp_Object init) | |
891 | { | |
892 | register Lisp_Object val; | |
893 | register EMACS_INT size; | |
c0f51373 | 894 | |
d90fb7af RT |
895 | CHECK_NATNUM (length); |
896 | size = XFASTINT (length); | |
7146af97 | 897 | |
d90fb7af RT |
898 | val = Qnil; |
899 | while (size > 0) | |
900 | { | |
901 | val = Fcons (init, val); | |
902 | --size; | |
7146af97 | 903 | |
d90fb7af RT |
904 | if (size > 0) |
905 | { | |
906 | val = Fcons (init, val); | |
907 | --size; | |
7146af97 | 908 | |
d90fb7af RT |
909 | if (size > 0) |
910 | { | |
911 | val = Fcons (init, val); | |
912 | --size; | |
7146af97 | 913 | |
d90fb7af RT |
914 | if (size > 0) |
915 | { | |
916 | val = Fcons (init, val); | |
917 | --size; | |
c9d624c6 | 918 | |
d90fb7af RT |
919 | if (size > 0) |
920 | { | |
921 | val = Fcons (init, val); | |
922 | --size; | |
923 | } | |
924 | } | |
925 | } | |
926 | } | |
927 | ||
928 | QUIT; | |
b7ffe040 | 929 | } |
e2984df0 | 930 | |
d90fb7af RT |
931 | return val; |
932 | } | |
2e471eb5 | 933 | |
2e471eb5 | 934 | |
d90fb7af RT |
935 | \f |
936 | /*********************************************************************** | |
937 | Vector Allocation | |
938 | ***********************************************************************/ | |
177c0ea7 | 939 | |
d90fb7af | 940 | /* The only vector with 0 slots, allocated from pure space. */ |
177c0ea7 | 941 | |
d90fb7af | 942 | Lisp_Object zero_vector; |
5c5fecb3 | 943 | |
d90fb7af | 944 | /* Called once to initialize vector allocation. */ |
a0b08700 | 945 | |
d90fb7af RT |
946 | static void |
947 | init_vectors (void) | |
948 | { | |
2316e1d3 BT |
949 | struct Lisp_Vector *p = xmalloc (header_size); |
950 | ||
951 | SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p); | |
952 | p->header.size = 0; | |
953 | XSETVECTOR (zero_vector, p); | |
d90fb7af | 954 | } |
b7ffe040 | 955 | |
d90fb7af RT |
956 | /* Value is a pointer to a newly allocated Lisp_Vector structure |
957 | with room for LEN Lisp_Objects. */ | |
b7ffe040 | 958 | |
d90fb7af RT |
959 | static struct Lisp_Vector * |
960 | allocate_vectorlike (ptrdiff_t len) | |
961 | { | |
2316e1d3 BT |
962 | struct Lisp_Vector *p; |
963 | ||
d90fb7af | 964 | if (len == 0) |
2316e1d3 | 965 | p = XVECTOR (zero_vector); |
d90fb7af | 966 | else |
2316e1d3 BT |
967 | { |
968 | p = xmalloc (header_size + len * word_size); | |
969 | SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p); | |
970 | } | |
971 | ||
972 | return p; | |
2e471eb5 GM |
973 | } |
974 | ||
975 | ||
d90fb7af | 976 | /* Allocate a vector with LEN slots. */ |
2e471eb5 | 977 | |
d90fb7af RT |
978 | struct Lisp_Vector * |
979 | allocate_vector (EMACS_INT len) | |
2e471eb5 | 980 | { |
d90fb7af RT |
981 | struct Lisp_Vector *v; |
982 | ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX); | |
177c0ea7 | 983 | |
d90fb7af RT |
984 | if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len) |
985 | memory_full (SIZE_MAX); | |
986 | v = allocate_vectorlike (len); | |
987 | v->header.size = len; | |
988 | return v; | |
989 | } | |
2e471eb5 | 990 | |
2e471eb5 | 991 | |
d90fb7af | 992 | /* Allocate other vector-like structures. */ |
2e471eb5 | 993 | |
d90fb7af RT |
994 | struct Lisp_Vector * |
995 | allocate_pseudovector (int memlen, int lisplen, enum pvec_type tag) | |
996 | { | |
997 | struct Lisp_Vector *v = allocate_vectorlike (memlen); | |
998 | int i; | |
2e471eb5 | 999 | |
d90fb7af RT |
1000 | /* Catch bogus values. */ |
1001 | eassert (tag <= PVEC_FONT); | |
1002 | eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1); | |
1003 | eassert (lisplen <= (1 << PSEUDOVECTOR_SIZE_BITS) - 1); | |
177c0ea7 | 1004 | |
d90fb7af RT |
1005 | /* Only the first lisplen slots will be traced normally by the GC. */ |
1006 | for (i = 0; i < lisplen; ++i) | |
1007 | v->contents[i] = Qnil; | |
2e471eb5 | 1008 | |
d90fb7af RT |
1009 | XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); |
1010 | return v; | |
1011 | } | |
2e471eb5 | 1012 | |
d90fb7af RT |
1013 | struct buffer * |
1014 | allocate_buffer (void) | |
1015 | { | |
1016 | struct buffer *b = xmalloc (sizeof *b); | |
2e471eb5 | 1017 | |
2316e1d3 | 1018 | SCM_NEWSMOB (b->header.self, lisp_vectorlike_tag, b); |
d90fb7af RT |
1019 | BUFFER_PVEC_INIT (b); |
1020 | /* Put B on the chain of all buffers including killed ones. */ | |
1021 | b->next = all_buffers; | |
1022 | all_buffers = b; | |
1023 | /* Note that the rest fields of B are not initialized. */ | |
1024 | return b; | |
2e471eb5 GM |
1025 | } |
1026 | ||
d90fb7af RT |
1027 | struct Lisp_Hash_Table * |
1028 | allocate_hash_table (void) | |
1029 | { | |
1030 | return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE); | |
1031 | } | |
2e471eb5 | 1032 | |
d90fb7af RT |
1033 | struct window * |
1034 | allocate_window (void) | |
2e471eb5 | 1035 | { |
d90fb7af | 1036 | struct window *w; |
177c0ea7 | 1037 | |
d90fb7af RT |
1038 | w = ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW); |
1039 | /* Users assumes that non-Lisp data is zeroed. */ | |
1040 | memset (&w->current_matrix, 0, | |
1041 | sizeof (*w) - offsetof (struct window, current_matrix)); | |
1042 | return w; | |
1043 | } | |
2e471eb5 | 1044 | |
d90fb7af RT |
1045 | struct terminal * |
1046 | allocate_terminal (void) | |
1047 | { | |
1048 | struct terminal *t; | |
2e471eb5 | 1049 | |
d90fb7af RT |
1050 | t = ALLOCATE_PSEUDOVECTOR (struct terminal, next_terminal, PVEC_TERMINAL); |
1051 | /* Users assumes that non-Lisp data is zeroed. */ | |
1052 | memset (&t->next_terminal, 0, | |
1053 | sizeof (*t) - offsetof (struct terminal, next_terminal)); | |
1054 | return t; | |
2e471eb5 GM |
1055 | } |
1056 | ||
d90fb7af RT |
1057 | struct frame * |
1058 | allocate_frame (void) | |
1059 | { | |
1060 | struct frame *f; | |
2e471eb5 | 1061 | |
d90fb7af RT |
1062 | f = ALLOCATE_PSEUDOVECTOR (struct frame, face_cache, PVEC_FRAME); |
1063 | /* Users assumes that non-Lisp data is zeroed. */ | |
1064 | memset (&f->face_cache, 0, | |
1065 | sizeof (*f) - offsetof (struct frame, face_cache)); | |
1066 | return f; | |
1067 | } | |
2e471eb5 | 1068 | |
d90fb7af RT |
1069 | struct Lisp_Process * |
1070 | allocate_process (void) | |
2e471eb5 | 1071 | { |
d90fb7af | 1072 | struct Lisp_Process *p; |
177c0ea7 | 1073 | |
d90fb7af RT |
1074 | p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS); |
1075 | /* Users assumes that non-Lisp data is zeroed. */ | |
1076 | memset (&p->pid, 0, | |
1077 | sizeof (*p) - offsetof (struct Lisp_Process, pid)); | |
1078 | return p; | |
1079 | } | |
2e471eb5 | 1080 | |
d90fb7af RT |
1081 | DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, |
1082 | doc: /* Return a newly created vector of length LENGTH, with each element being INIT. | |
1083 | See also the function `vector'. */) | |
1084 | (register Lisp_Object length, Lisp_Object init) | |
1085 | { | |
1086 | Lisp_Object vector; | |
1087 | register ptrdiff_t sizei; | |
1088 | register ptrdiff_t i; | |
1089 | register struct Lisp_Vector *p; | |
212f33f1 | 1090 | |
d90fb7af | 1091 | CHECK_NATNUM (length); |
177c0ea7 | 1092 | |
d90fb7af RT |
1093 | p = allocate_vector (XFASTINT (length)); |
1094 | sizei = XFASTINT (length); | |
1095 | for (i = 0; i < sizei; i++) | |
1096 | p->contents[i] = init; | |
177c0ea7 | 1097 | |
d90fb7af RT |
1098 | XSETVECTOR (vector, p); |
1099 | return vector; | |
1100 | } | |
2e471eb5 | 1101 | |
2e471eb5 | 1102 | |
d90fb7af RT |
1103 | DEFUN ("vector", Fvector, Svector, 0, MANY, 0, |
1104 | doc: /* Return a newly created vector with specified arguments as elements. | |
1105 | Any number of arguments, even zero arguments, are allowed. | |
1106 | usage: (vector &rest OBJECTS) */) | |
1107 | (ptrdiff_t nargs, Lisp_Object *args) | |
1108 | { | |
1109 | ptrdiff_t i; | |
1110 | register Lisp_Object val = make_uninit_vector (nargs); | |
1111 | register struct Lisp_Vector *p = XVECTOR (val); | |
2e471eb5 | 1112 | |
d90fb7af RT |
1113 | for (i = 0; i < nargs; i++) |
1114 | p->contents[i] = args[i]; | |
1115 | return val; | |
2e471eb5 GM |
1116 | } |
1117 | ||
cb93f9be | 1118 | void |
d90fb7af | 1119 | make_byte_code (struct Lisp_Vector *v) |
2e471eb5 | 1120 | { |
d90fb7af RT |
1121 | /* Don't allow the global zero_vector to become a byte code object. */ |
1122 | eassert (0 < v->header.size); | |
2e471eb5 | 1123 | |
d90fb7af RT |
1124 | if (v->header.size > 1 && STRINGP (v->contents[1]) |
1125 | && STRING_MULTIBYTE (v->contents[1])) | |
1126 | /* BYTECODE-STRING must have been produced by Emacs 20.2 or the | |
1127 | earlier because they produced a raw 8-bit string for byte-code | |
1128 | and now such a byte-code string is loaded as multibyte while | |
1129 | raw 8-bit characters converted to multibyte form. Thus, now we | |
1130 | must convert them back to the original unibyte form. */ | |
1131 | v->contents[1] = Fstring_as_unibyte (v->contents[1]); | |
1132 | XSETPVECTYPE (v, PVEC_COMPILED); | |
1133 | } | |
2e471eb5 | 1134 | |
d90fb7af RT |
1135 | DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, |
1136 | doc: /* Create a byte-code object with specified arguments as elements. | |
1137 | The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant | |
1138 | vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING, | |
1139 | and (optional) INTERACTIVE-SPEC. | |
1140 | The first four arguments are required; at most six have any | |
1141 | significance. | |
1142 | The ARGLIST can be either like the one of `lambda', in which case the arguments | |
1143 | will be dynamically bound before executing the byte code, or it can be an | |
1144 | integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the | |
1145 | minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number | |
1146 | of arguments (ignoring &rest) and the R bit specifies whether there is a &rest | |
1147 | argument to catch the left-over arguments. If such an integer is used, the | |
1148 | arguments will not be dynamically bound but will be instead pushed on the | |
1149 | stack before executing the byte-code. | |
1150 | usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) | |
2bcf0551 DA |
1151 | (ptrdiff_t nargs, Lisp_Object *args) |
1152 | { | |
1153 | ptrdiff_t i; | |
d90fb7af RT |
1154 | register Lisp_Object val = make_uninit_vector (nargs); |
1155 | register struct Lisp_Vector *p = XVECTOR (val); | |
2e471eb5 | 1156 | |
d90fb7af RT |
1157 | /* We used to purecopy everything here, if purify-flag was set. This worked |
1158 | OK for Emacs-23, but with Emacs-24's lexical binding code, it can be | |
1159 | dangerous, since make-byte-code is used during execution to build | |
1160 | closures, so any closure built during the preload phase would end up | |
1161 | copied into pure space, including its free variables, which is sometimes | |
1162 | just wasteful and other times plainly wrong (e.g. those free vars may want | |
1163 | to be setcar'd). */ | |
4d774b0f | 1164 | |
d90fb7af RT |
1165 | for (i = 0; i < nargs; i++) |
1166 | p->contents[i] = args[i]; | |
1167 | make_byte_code (p); | |
1168 | XSETCOMPILED (val, p); | |
2e471eb5 | 1169 | return val; |
d90fb7af | 1170 | } |
2e471eb5 | 1171 | |
3ab6e069 | 1172 | |
d90fb7af RT |
1173 | \f |
1174 | /*********************************************************************** | |
1175 | Symbol Allocation | |
1176 | ***********************************************************************/ | |
3ab6e069 | 1177 | |
d90fb7af RT |
1178 | static void |
1179 | set_symbol_name (Lisp_Object sym, Lisp_Object name) | |
1180 | { | |
1181 | XSYMBOL (sym)->name = name; | |
1182 | } | |
3ab6e069 | 1183 | |
d90fb7af RT |
1184 | DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, |
1185 | doc: /* Return a newly allocated uninterned symbol whose name is NAME. | |
1186 | Its value is void, and its function definition and property list are nil. */) | |
1187 | (Lisp_Object name) | |
1188 | { | |
1189 | register Lisp_Object val; | |
1190 | register struct Lisp_Symbol *p; | |
3ab6e069 | 1191 | |
d90fb7af | 1192 | CHECK_STRING (name); |
3ab6e069 | 1193 | |
2316e1d3 BT |
1194 | p = xmalloc (sizeof *p); |
1195 | SCM_NEWSMOB (p->self, lisp_symbol_tag, p); | |
1196 | XSETSYMBOL (val, p); | |
d90fb7af RT |
1197 | p = XSYMBOL (val); |
1198 | set_symbol_name (val, name); | |
1199 | set_symbol_plist (val, Qnil); | |
1200 | p->redirect = SYMBOL_PLAINVAL; | |
1201 | SET_SYMBOL_VAL (p, Qunbound); | |
1202 | set_symbol_function (val, Qnil); | |
1203 | set_symbol_next (val, NULL); | |
d90fb7af RT |
1204 | p->interned = SYMBOL_UNINTERNED; |
1205 | p->constant = 0; | |
1206 | p->declared_special = false; | |
1207 | p->pinned = false; | |
1208 | return val; | |
1209 | } | |
5b835e1d | 1210 | |
5b835e1d | 1211 | |
d90fb7af RT |
1212 | \f |
1213 | /*********************************************************************** | |
1214 | Marker (Misc) Allocation | |
1215 | ***********************************************************************/ | |
3ab6e069 | 1216 | |
d90fb7af | 1217 | /* Return a newly allocated Lisp_Misc object of specified TYPE. */ |
3ab6e069 | 1218 | |
d90fb7af RT |
1219 | static Lisp_Object |
1220 | allocate_misc (enum Lisp_Misc_Type type) | |
1221 | { | |
1222 | Lisp_Object val; | |
2316e1d3 | 1223 | union Lisp_Misc *p; |
2e471eb5 | 1224 | |
2316e1d3 BT |
1225 | p = xmalloc (sizeof *p); |
1226 | SCM_NEWSMOB (p->u_any.self, lisp_misc_tag, p); | |
1227 | XSETMISC (val, p); | |
d90fb7af RT |
1228 | XMISCANY (val)->type = type; |
1229 | return val; | |
1230 | } | |
f8643a6b | 1231 | |
d90fb7af | 1232 | /* Free a Lisp_Misc object. */ |
7146af97 | 1233 | |
d90fb7af RT |
1234 | void |
1235 | free_misc (Lisp_Object misc) | |
1236 | { | |
1237 | return; | |
1238 | } | |
2c5bd608 | 1239 | |
d90fb7af RT |
1240 | /* Verify properties of Lisp_Save_Value's representation |
1241 | that are assumed here and elsewhere. */ | |
d35af63c | 1242 | |
d90fb7af RT |
1243 | verify (SAVE_UNUSED == 0); |
1244 | verify (((SAVE_INTEGER | SAVE_POINTER | SAVE_FUNCPOINTER | SAVE_OBJECT) | |
1245 | >> SAVE_SLOT_BITS) | |
1246 | == 0); | |
2c5bd608 | 1247 | |
d90fb7af RT |
1248 | /* Return Lisp_Save_Value objects for the various combinations |
1249 | that callers need. */ | |
12b3895d | 1250 | |
d90fb7af RT |
1251 | Lisp_Object |
1252 | make_save_int_int_int (ptrdiff_t a, ptrdiff_t b, ptrdiff_t c) | |
1253 | { | |
1254 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1255 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1256 | p->save_type = SAVE_TYPE_INT_INT_INT; | |
1257 | p->data[0].integer = a; | |
1258 | p->data[1].integer = b; | |
1259 | p->data[2].integer = c; | |
1260 | return val; | |
7146af97 | 1261 | } |
34400008 | 1262 | |
d90fb7af RT |
1263 | Lisp_Object |
1264 | make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c, | |
1265 | Lisp_Object d) | |
c94e3311 | 1266 | { |
d90fb7af RT |
1267 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); |
1268 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1269 | p->save_type = SAVE_TYPE_OBJ_OBJ_OBJ_OBJ; | |
1270 | p->data[0].object = a; | |
1271 | p->data[1].object = b; | |
1272 | p->data[2].object = c; | |
1273 | p->data[3].object = d; | |
1274 | return val; | |
1275 | } | |
c94e3311 | 1276 | |
d90fb7af RT |
1277 | Lisp_Object |
1278 | make_save_ptr (void *a) | |
1279 | { | |
1280 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1281 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1282 | p->save_type = SAVE_POINTER; | |
1283 | p->data[0].pointer = a; | |
1284 | return val; | |
c94e3311 | 1285 | } |
41c28a37 | 1286 | |
d90fb7af RT |
1287 | Lisp_Object |
1288 | make_save_ptr_int (void *a, ptrdiff_t b) | |
1289 | { | |
1290 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1291 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1292 | p->save_type = SAVE_TYPE_PTR_INT; | |
1293 | p->data[0].pointer = a; | |
1294 | p->data[1].integer = b; | |
1295 | return val; | |
1296 | } | |
41c28a37 | 1297 | |
d90fb7af RT |
1298 | #if ! (defined USE_X_TOOLKIT || defined USE_GTK) |
1299 | Lisp_Object | |
1300 | make_save_ptr_ptr (void *a, void *b) | |
41c28a37 | 1301 | { |
d90fb7af RT |
1302 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); |
1303 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1304 | p->save_type = SAVE_TYPE_PTR_PTR; | |
1305 | p->data[0].pointer = a; | |
1306 | p->data[1].pointer = b; | |
1307 | return val; | |
1308 | } | |
1309 | #endif | |
41c28a37 | 1310 | |
d90fb7af RT |
1311 | Lisp_Object |
1312 | make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c) | |
1313 | { | |
1314 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1315 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1316 | p->save_type = SAVE_TYPE_FUNCPTR_PTR_OBJ; | |
1317 | p->data[0].funcpointer = a; | |
1318 | p->data[1].pointer = b; | |
1319 | p->data[2].object = c; | |
1320 | return val; | |
41c28a37 GM |
1321 | } |
1322 | ||
d90fb7af RT |
1323 | /* Return a Lisp_Save_Value object that represents an array A |
1324 | of N Lisp objects. */ | |
7146af97 | 1325 | |
d90fb7af RT |
1326 | Lisp_Object |
1327 | make_save_memory (Lisp_Object *a, ptrdiff_t n) | |
1328 | { | |
1329 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1330 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1331 | p->save_type = SAVE_TYPE_MEMORY; | |
1332 | p->data[0].pointer = a; | |
1333 | p->data[1].integer = n; | |
1334 | return val; | |
1335 | } | |
785cd37f | 1336 | |
d90fb7af RT |
1337 | /* Free a Lisp_Save_Value object. Do not use this function |
1338 | if SAVE contains pointer other than returned by xmalloc. */ | |
1342fc6f | 1339 | |
d90fb7af RT |
1340 | void |
1341 | free_save_value (Lisp_Object save) | |
d2029e5b | 1342 | { |
d90fb7af RT |
1343 | xfree (XSAVE_POINTER (save, 0)); |
1344 | free_misc (save); | |
d2029e5b SM |
1345 | } |
1346 | ||
d90fb7af | 1347 | /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */ |
58026347 | 1348 | |
d90fb7af RT |
1349 | Lisp_Object |
1350 | build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist) | |
58026347 | 1351 | { |
d90fb7af | 1352 | register Lisp_Object overlay; |
58026347 | 1353 | |
d90fb7af RT |
1354 | overlay = allocate_misc (Lisp_Misc_Overlay); |
1355 | OVERLAY_START (overlay) = start; | |
1356 | OVERLAY_END (overlay) = end; | |
1357 | set_overlay_plist (overlay, plist); | |
1358 | XOVERLAY (overlay)->next = NULL; | |
1359 | return overlay; | |
58026347 KH |
1360 | } |
1361 | ||
d90fb7af RT |
1362 | DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, |
1363 | doc: /* Return a newly allocated marker which does not point at any place. */) | |
1364 | (void) | |
83f14500 | 1365 | { |
d90fb7af RT |
1366 | register Lisp_Object val; |
1367 | register struct Lisp_Marker *p; | |
15684f52 | 1368 | |
d90fb7af RT |
1369 | val = allocate_misc (Lisp_Misc_Marker); |
1370 | p = XMARKER (val); | |
1371 | p->buffer = 0; | |
1372 | p->bytepos = 0; | |
1373 | p->charpos = 0; | |
1374 | p->next = NULL; | |
1375 | p->insertion_type = 0; | |
1376 | p->need_adjustment = 0; | |
1377 | return val; | |
83f14500 DA |
1378 | } |
1379 | ||
d90fb7af RT |
1380 | /* Return a newly allocated marker which points into BUF |
1381 | at character position CHARPOS and byte position BYTEPOS. */ | |
36429c89 | 1382 | |
d90fb7af RT |
1383 | Lisp_Object |
1384 | build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos) | |
36429c89 | 1385 | { |
d90fb7af RT |
1386 | Lisp_Object obj; |
1387 | struct Lisp_Marker *m; | |
1388 | ||
1389 | /* No dead buffers here. */ | |
1390 | eassert (BUFFER_LIVE_P (buf)); | |
1391 | ||
1392 | /* Every character is at least one byte. */ | |
1393 | eassert (charpos <= bytepos); | |
1394 | ||
1395 | obj = allocate_misc (Lisp_Misc_Marker); | |
1396 | m = XMARKER (obj); | |
1397 | m->buffer = buf; | |
1398 | m->charpos = charpos; | |
1399 | m->bytepos = bytepos; | |
1400 | m->insertion_type = 0; | |
1401 | m->need_adjustment = 0; | |
1402 | m->next = BUF_MARKERS (buf); | |
1403 | BUF_MARKERS (buf) = m; | |
1404 | return obj; | |
36429c89 | 1405 | } |
d90fb7af RT |
1406 | \f |
1407 | /* Return a newly created vector or string with specified arguments as | |
1408 | elements. If all the arguments are characters that can fit | |
1409 | in a string of events, make a string; otherwise, make a vector. | |
36429c89 | 1410 | |
d90fb7af | 1411 | Any number of arguments, even zero arguments, are allowed. */ |
cf5c0175 | 1412 | |
d90fb7af RT |
1413 | Lisp_Object |
1414 | make_event_array (ptrdiff_t nargs, Lisp_Object *args) | |
cf5c0175 | 1415 | { |
d90fb7af RT |
1416 | ptrdiff_t i; |
1417 | ||
1418 | for (i = 0; i < nargs; i++) | |
1419 | /* The things that fit in a string | |
1420 | are characters that are in 0...127, | |
1421 | after discarding the meta bit and all the bits above it. */ | |
1422 | if (!INTEGERP (args[i]) | |
1423 | || (XINT (args[i]) & ~(-CHAR_META)) >= 0200) | |
1424 | return Fvector (nargs, args); | |
1425 | ||
1426 | /* Since the loop exited, we know that all the things in it are | |
1427 | characters, so we can make a string. */ | |
1428 | { | |
1429 | Lisp_Object result; | |
cf5c0175 | 1430 | |
d90fb7af RT |
1431 | result = Fmake_string (make_number (nargs), make_number (0)); |
1432 | for (i = 0; i < nargs; i++) | |
1433 | { | |
1434 | SSET (result, i, XINT (args[i])); | |
1435 | /* Move the meta bit to the right place for a string char. */ | |
1436 | if (XINT (args[i]) & CHAR_META) | |
1437 | SSET (result, i, SREF (result, i) | 0x80); | |
1438 | } | |
cf5c0175 | 1439 | |
d90fb7af RT |
1440 | return result; |
1441 | } | |
1442 | } | |
cf5c0175 | 1443 | |
cf5c0175 | 1444 | |
d90fb7af RT |
1445 | \f |
1446 | /************************************************************************ | |
1447 | Memory Full Handling | |
1448 | ************************************************************************/ | |
cf5c0175 | 1449 | |
cf5c0175 | 1450 | |
d90fb7af RT |
1451 | /* Called if xmalloc (NBYTES) returns zero. If NBYTES == SIZE_MAX, |
1452 | there may have been size_t overflow so that xmalloc was never | |
1453 | called, or perhaps xmalloc was invoked successfully but the | |
1454 | resulting pointer had problems fitting into a tagged EMACS_INT. In | |
1455 | either case this counts as memory being full even though xmalloc | |
1456 | did not fail. */ | |
fc54bdd5 | 1457 | |
d90fb7af RT |
1458 | void |
1459 | memory_full (size_t nbytes) | |
fc54bdd5 | 1460 | { |
d90fb7af RT |
1461 | /* Do not go into hysterics merely because a large request failed. */ |
1462 | bool enough_free_memory = 0; | |
1463 | if (SPARE_MEMORY < nbytes) | |
fc54bdd5 | 1464 | { |
a0a9ac13 | 1465 | void *p = xmalloc_atomic_unsafe (SPARE_MEMORY); |
d90fb7af | 1466 | if (p) |
fc54bdd5 | 1467 | { |
d90fb7af RT |
1468 | xfree (p); |
1469 | enough_free_memory = 1; | |
fc54bdd5 DA |
1470 | } |
1471 | } | |
83f14500 | 1472 | |
d90fb7af | 1473 | if (! enough_free_memory) |
2c70e6b0 | 1474 | { |
d90fb7af | 1475 | Vmemory_full = Qt; |
d73e321c | 1476 | |
d90fb7af RT |
1477 | /* The first time we get here, free the spare memory. */ |
1478 | if (spare_memory) | |
1479 | { | |
1480 | xfree (spare_memory); | |
1481 | spare_memory = NULL; | |
1482 | } | |
d73e321c | 1483 | } |
d90fb7af RT |
1484 | |
1485 | /* This used to call error, but if we've run out of memory, we could | |
1486 | get infinite recursion trying to build the string. */ | |
1487 | xsignal (Qnil, Vmemory_signal_data); | |
d73e321c DA |
1488 | } |
1489 | ||
d90fb7af RT |
1490 | /* If we released our reserve (due to running out of memory), |
1491 | and we have a fair amount free once again, | |
1492 | try to set aside another reserve in case we run out once more. | |
2c70e6b0 | 1493 | |
d90fb7af RT |
1494 | This is called when a relocatable block is freed in ralloc.c, |
1495 | and also directly from this file, in case we're not using ralloc.c. */ | |
cf5c0175 | 1496 | |
41c28a37 | 1497 | void |
d90fb7af | 1498 | refill_memory_reserve (void) |
7146af97 | 1499 | { |
d90fb7af | 1500 | if (spare_memory == NULL) |
a0a9ac13 | 1501 | spare_memory = xmalloc_atomic_unsafe (SPARE_MEMORY); |
7146af97 | 1502 | |
d90fb7af RT |
1503 | if (spare_memory) |
1504 | Vmemory_full = Qnil; | |
1505 | } | |
1506 | \f | |
1507 | /* Determine whether it is safe to access memory at address P. */ | |
1508 | static int | |
1509 | valid_pointer_p (void *p) | |
1510 | { | |
1511 | #ifdef WINDOWSNT | |
1512 | return w32_valid_pointer_p (p, 16); | |
1513 | #else | |
1514 | int fd[2]; | |
7146af97 | 1515 | |
d90fb7af RT |
1516 | /* Obviously, we cannot just access it (we would SEGV trying), so we |
1517 | trick the o/s to tell us whether p is a valid pointer. | |
1518 | Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may | |
1519 | not validate p in that case. */ | |
785cd37f | 1520 | |
d90fb7af | 1521 | if (emacs_pipe (fd) == 0) |
7146af97 | 1522 | { |
d90fb7af RT |
1523 | bool valid = emacs_write (fd[1], p, 16) == 16; |
1524 | emacs_close (fd[1]); | |
1525 | emacs_close (fd[0]); | |
1526 | return valid; | |
1527 | } | |
df24a230 | 1528 | |
d90fb7af | 1529 | return -1; |
df24a230 | 1530 | #endif |
d90fb7af | 1531 | } |
cf5c0175 | 1532 | |
d90fb7af RT |
1533 | /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a |
1534 | valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we | |
1535 | cannot validate OBJ. This function can be quite slow, so its primary | |
1536 | use is the manual debugging. The only exception is print_object, where | |
1537 | we use it to check whether the memory referenced by the pointer of | |
1538 | Lisp_Save_Value object contains valid objects. */ | |
5779a1dc | 1539 | |
d90fb7af RT |
1540 | int |
1541 | valid_lisp_object_p (Lisp_Object obj) | |
1542 | { | |
1543 | void *p; | |
e99f70c8 | 1544 | |
2316e1d3 | 1545 | if (SCM_IMP (obj)) |
d90fb7af | 1546 | return 1; |
e99f70c8 | 1547 | |
2316e1d3 | 1548 | p = (void *) SCM2PTR (obj); |
cf5c0175 | 1549 | |
d90fb7af RT |
1550 | if (p == &buffer_defaults || p == &buffer_local_symbols) |
1551 | return 2; | |
cf5c0175 | 1552 | |
d90fb7af RT |
1553 | return valid_pointer_p (p); |
1554 | } | |
cf5c0175 | 1555 | |
d90fb7af RT |
1556 | /* If GC_MARK_STACK, return 1 if STR is a relocatable data of Lisp_String |
1557 | (i.e. there is a non-pure Lisp_Object X so that SDATA (X) == STR) and 0 | |
1558 | if not. Otherwise we can't rely on valid_lisp_object_p and return -1. | |
1559 | This function is slow and should be used for debugging purposes. */ | |
cf5c0175 | 1560 | |
d90fb7af RT |
1561 | int |
1562 | relocatable_string_data_p (const char *str) | |
1563 | { | |
d90fb7af RT |
1564 | return -1; |
1565 | } | |
cf5c0175 | 1566 | |
d90fb7af | 1567 | /*********************************************************************** |
836d0c80 | 1568 | Pure Storage Compatibility Functions |
d90fb7af | 1569 | ***********************************************************************/ |
cf5c0175 | 1570 | |
d90fb7af RT |
1571 | void |
1572 | check_pure_size (void) | |
4a729fd8 | 1573 | { |
836d0c80 | 1574 | return; |
41c28a37 GM |
1575 | } |
1576 | ||
d90fb7af RT |
1577 | Lisp_Object |
1578 | make_pure_string (const char *data, | |
1579 | ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte) | |
1580 | { | |
836d0c80 | 1581 | return make_specified_string (data, nchars, nbytes, multibyte); |
b029599f | 1582 | } |
7146af97 | 1583 | |
d90fb7af RT |
1584 | Lisp_Object |
1585 | make_pure_c_string (const char *data, ptrdiff_t nchars) | |
b029599f | 1586 | { |
836d0c80 | 1587 | return build_string (data); |
d90fb7af | 1588 | } |
177c0ea7 | 1589 | |
d90fb7af RT |
1590 | Lisp_Object |
1591 | pure_cons (Lisp_Object car, Lisp_Object cdr) | |
b029599f | 1592 | { |
836d0c80 | 1593 | return Fcons (car, cdr); |
d90fb7af | 1594 | } |
177c0ea7 | 1595 | |
d90fb7af | 1596 | DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, |
836d0c80 | 1597 | doc: /* Return OBJ. */) |
d90fb7af RT |
1598 | (register Lisp_Object obj) |
1599 | { | |
d90fb7af | 1600 | return obj; |
7146af97 | 1601 | } |
7146af97 | 1602 | \f |
d90fb7af RT |
1603 | /*********************************************************************** |
1604 | Protection from GC | |
1605 | ***********************************************************************/ | |
20d24714 | 1606 | |
d90fb7af RT |
1607 | void |
1608 | staticpro (Lisp_Object *varaddress) | |
310ea200 | 1609 | { |
eb6a5d03 | 1610 | return; |
310ea200 | 1611 | } |
d90fb7af RT |
1612 | \f |
1613 | DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", | |
1614 | doc: /* Reclaim storage for Lisp objects no longer needed. | |
1615 | Garbage collection happens automatically if you cons more than | |
1616 | `gc-cons-threshold' bytes of Lisp data since previous garbage collection. | |
1617 | `garbage-collect' normally returns a list with info on amount of space in use, | |
1618 | where each entry has the form (NAME SIZE USED FREE), where: | |
1619 | - NAME is a symbol describing the kind of objects this entry represents, | |
1620 | - SIZE is the number of bytes used by each one, | |
1621 | - USED is the number of those objects that were found live in the heap, | |
1622 | - FREE is the number of those objects that are not live but that Emacs | |
1623 | keeps around for future allocations (maybe because it does not know how | |
1624 | to return them to the OS). | |
1625 | However, if there was overflow in pure space, `garbage-collect' | |
1626 | returns nil, because real GC can't be done. | |
1627 | See Info node `(elisp)Garbage Collection'. */) | |
1628 | (void) | |
8b058d44 | 1629 | { |
d90fb7af RT |
1630 | GC_gcollect (); |
1631 | return Qt; | |
8b058d44 | 1632 | } |
d90fb7af | 1633 | \f |
244ed907 | 1634 | #ifdef ENABLE_CHECKING |
f4a681b0 | 1635 | |
fce31d69 | 1636 | bool suppress_checking; |
d3d47262 | 1637 | |
e0b8c689 | 1638 | void |
971de7fb | 1639 | die (const char *msg, const char *file, int line) |
e0b8c689 | 1640 | { |
5013fc08 | 1641 | fprintf (stderr, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n", |
e0b8c689 | 1642 | file, line, msg); |
4d7e6e51 | 1643 | terminate_due_to_signal (SIGABRT, INT_MAX); |
e0b8c689 | 1644 | } |
244ed907 | 1645 | #endif |
20d24714 | 1646 | \f |
b09cca6a | 1647 | /* Initialization. */ |
7146af97 | 1648 | |
dfcf069d | 1649 | void |
971de7fb | 1650 | init_alloc_once (void) |
7146af97 | 1651 | { |
2316e1d3 BT |
1652 | lisp_symbol_tag = scm_make_smob_type ("elisp-symbol", 0); |
1653 | lisp_misc_tag = scm_make_smob_type ("elisp-misc", 0); | |
1654 | lisp_string_tag = scm_make_smob_type ("elisp-string", 0); | |
1655 | lisp_vectorlike_tag = scm_make_smob_type ("elisp-vectorlike", 0); | |
2316e1d3 | 1656 | |
7146af97 | 1657 | /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ |
ab6780cd | 1658 | |
7146af97 | 1659 | init_strings (); |
f3372c87 | 1660 | init_vectors (); |
d5e35230 | 1661 | |
24d8a105 | 1662 | refill_memory_reserve (); |
0dd6d66d | 1663 | gc_cons_threshold = GC_DEFAULT_THRESHOLD; |
7146af97 JB |
1664 | } |
1665 | ||
dfcf069d | 1666 | void |
971de7fb | 1667 | init_alloc (void) |
7146af97 JB |
1668 | { |
1669 | gcprolist = 0; | |
2c5bd608 DL |
1670 | Vgc_elapsed = make_float (0.0); |
1671 | gcs_done = 0; | |
a84683fd DC |
1672 | |
1673 | #if USE_VALGRIND | |
d160dd0c | 1674 | valgrind_p = RUNNING_ON_VALGRIND != 0; |
a84683fd | 1675 | #endif |
7146af97 JB |
1676 | } |
1677 | ||
1678 | void | |
971de7fb | 1679 | syms_of_alloc (void) |
7146af97 | 1680 | { |
172a66a1 BT |
1681 | #include "alloc.x" |
1682 | ||
29208e82 | 1683 | DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold, |
fb7ada5f | 1684 | doc: /* Number of bytes of consing between garbage collections. |
228299fa GM |
1685 | Garbage collection can happen automatically once this many bytes have been |
1686 | allocated since the last garbage collection. All data types count. | |
7146af97 | 1687 | |
228299fa | 1688 | Garbage collection happens automatically only when `eval' is called. |
7146af97 | 1689 | |
228299fa | 1690 | By binding this temporarily to a large number, you can effectively |
96f077ad SM |
1691 | prevent garbage collection during a part of the program. |
1692 | See also `gc-cons-percentage'. */); | |
1693 | ||
29208e82 | 1694 | DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage, |
fb7ada5f | 1695 | doc: /* Portion of the heap used for allocation. |
96f077ad SM |
1696 | Garbage collection can happen automatically once this portion of the heap |
1697 | has been allocated since the last garbage collection. | |
1698 | If this portion is smaller than `gc-cons-threshold', this is ignored. */); | |
1699 | Vgc_cons_percentage = make_float (0.1); | |
0819585c | 1700 | |
29208e82 | 1701 | DEFVAR_INT ("pure-bytes-used", pure_bytes_used, |
333f9019 | 1702 | doc: /* Number of bytes of shareable Lisp data allocated so far. */); |
0819585c | 1703 | |
29208e82 | 1704 | DEFVAR_LISP ("purify-flag", Vpurify_flag, |
a6266d23 | 1705 | doc: /* Non-nil means loading Lisp code in order to dump an executable. |
e9515805 SM |
1706 | This means that certain objects should be allocated in shared (pure) space. |
1707 | It can also be set to a hash-table, in which case this table is used to | |
1708 | do hash-consing of the objects allocated to pure space. */); | |
228299fa | 1709 | |
29208e82 | 1710 | DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages, |
a6266d23 | 1711 | doc: /* Non-nil means display messages at start and end of garbage collection. */); |
299585ee RS |
1712 | garbage_collection_messages = 0; |
1713 | ||
29208e82 | 1714 | DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook, |
a6266d23 | 1715 | doc: /* Hook run after garbage collection has finished. */); |
9e713715 | 1716 | Vpost_gc_hook = Qnil; |
cd3520a4 | 1717 | DEFSYM (Qpost_gc_hook, "post-gc-hook"); |
9e713715 | 1718 | |
29208e82 | 1719 | DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data, |
74a54b04 | 1720 | doc: /* Precomputed `signal' argument for memory-full error. */); |
bcb61d60 KH |
1721 | /* We build this in advance because if we wait until we need it, we might |
1722 | not be able to allocate the memory to hold it. */ | |
74a54b04 | 1723 | Vmemory_signal_data |
3438fe21 | 1724 | = listn (CONSTYPE_PURE, 2, Qerror, |
694b6c97 | 1725 | build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs")); |
74a54b04 | 1726 | |
29208e82 | 1727 | DEFVAR_LISP ("memory-full", Vmemory_full, |
24d8a105 | 1728 | doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); |
74a54b04 | 1729 | Vmemory_full = Qnil; |
bcb61d60 | 1730 | |
cd3520a4 JB |
1731 | DEFSYM (Qgc_cons_threshold, "gc-cons-threshold"); |
1732 | DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots"); | |
a59de17b | 1733 | |
29208e82 | 1734 | DEFVAR_LISP ("gc-elapsed", Vgc_elapsed, |
2c5bd608 | 1735 | doc: /* Accumulated time elapsed in garbage collections. |
e7415487 | 1736 | The time is in seconds as a floating point value. */); |
29208e82 | 1737 | DEFVAR_INT ("gcs-done", gcs_done, |
e7415487 | 1738 | doc: /* Accumulated number of garbage collections done. */); |
7146af97 | 1739 | } |
5eceb8fb | 1740 | |
4706125e PE |
1741 | /* When compiled with GCC, GDB might say "No enum type named |
1742 | pvec_type" if we don't have at least one symbol with that type, and | |
1743 | then xbacktrace could fail. Similarly for the other enums and | |
62aba0d4 FP |
1744 | their values. Some non-GCC compilers don't like these constructs. */ |
1745 | #ifdef __GNUC__ | |
4706125e PE |
1746 | union |
1747 | { | |
03a660a6 PE |
1748 | enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS; |
1749 | enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS; | |
1750 | enum char_bits char_bits; | |
03a660a6 | 1751 | enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE; |
4706125e | 1752 | enum Lisp_Bits Lisp_Bits; |
03a660a6 PE |
1753 | enum Lisp_Compiled Lisp_Compiled; |
1754 | enum maxargs maxargs; | |
1755 | enum MAX_ALLOCA MAX_ALLOCA; | |
4706125e PE |
1756 | enum More_Lisp_Bits More_Lisp_Bits; |
1757 | enum pvec_type pvec_type; | |
1758 | } const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0}; | |
62aba0d4 | 1759 | #endif /* __GNUC__ */ |