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 | ||
b782773b 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 | |
e4dd8d12 | 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 | ||
b782773b | 192 | /* Like GC_MALLOC but check for no memory. */ |
7146af97 | 193 | |
261cb4bb | 194 | void * |
971de7fb | 195 | xmalloc (size_t size) |
7146af97 | 196 | { |
b782773b | 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 | { | |
b782773b | 208 | return xmalloc (size); |
23f86fce | 209 | } |
34400008 | 210 | |
b782773b | 211 | /* Like GC_REALLOC but check for no memory. */ |
34400008 | 212 | |
261cb4bb PE |
213 | void * |
214 | xrealloc (void *block, size_t size) | |
7146af97 | 215 | { |
b782773b | 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 | { |
b782773b | 225 | return; |
9ac0d9e0 JB |
226 | } |
227 | ||
143439dd 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 | ||
f11db2f4 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 | ||
0a38955b 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 | |
143439dd 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. | |
b782773b | 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 | ||
143439dd 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. | |
b782773b | 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 | |
b782773b 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; |
c1ade6f7 | 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; | |
c1ade6f7 | 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 | } | |
b782773b RT |
417 | \f |
418 | /*********************************************************************** | |
419 | Interval Allocation | |
420 | ***********************************************************************/ | |
98c6f1e3 | 421 | |
b782773b | 422 | /* Return a new interval. */ |
f61bef8b | 423 | |
b782773b RT |
424 | INTERVAL |
425 | make_interval (void) | |
c8099634 | 426 | { |
b782773b RT |
427 | INTERVAL val = xmalloc (sizeof (struct interval)); |
428 | RESET_INTERVAL (val); | |
c8099634 RS |
429 | return val; |
430 | } | |
431 | ||
b782773b RT |
432 | /*********************************************************************** |
433 | String Allocation | |
434 | ***********************************************************************/ | |
435 | ||
436 | /* Initialize string allocation. Called from init_alloc_once. */ | |
34400008 | 437 | |
bf952fb6 | 438 | static void |
b782773b | 439 | init_strings (void) |
c8099634 | 440 | { |
e4dd8d12 RT |
441 | empty_unibyte_string = make_empty_string (0); |
442 | empty_multibyte_string = make_empty_string (1); | |
c8099634 | 443 | } |
34400008 | 444 | |
b782773b | 445 | /* Return a new Lisp_String. */ |
e76119d7 | 446 | |
b782773b RT |
447 | static struct Lisp_String * |
448 | allocate_string (void) | |
aea07e2c | 449 | { |
49609976 BT |
450 | struct Lisp_String *p; |
451 | ||
452 | p = xmalloc (sizeof *p); | |
453 | SCM_NEWSMOB (p->self, lisp_string_tag, p); | |
454 | return p; | |
aea07e2c | 455 | } |
ab6780cd | 456 | |
ab6780cd | 457 | |
b782773b RT |
458 | /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes, |
459 | plus a NUL byte at the end. Allocate an sdata structure for S, and | |
460 | set S->data to its `u.data' member. Store a NUL byte at the end of | |
461 | S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free | |
462 | S->data if it was initially non-null. */ | |
ab6780cd | 463 | |
b782773b RT |
464 | void |
465 | allocate_string_data (struct Lisp_String *s, | |
466 | EMACS_INT nchars, EMACS_INT nbytes) | |
467 | { | |
468 | unsigned char *data; | |
ab6780cd | 469 | |
b782773b RT |
470 | if (STRING_BYTES_BOUND < nbytes) |
471 | string_overflow (); | |
ab6780cd | 472 | |
b782773b RT |
473 | data = GC_MALLOC_ATOMIC (nbytes + 1); |
474 | s->data = data; | |
475 | s->size = nchars; | |
476 | s->size_byte = nbytes; | |
477 | s->data[nbytes] = '\0'; | |
478 | } | |
ab6780cd | 479 | |
b782773b RT |
480 | void |
481 | string_overflow (void) | |
ab6780cd | 482 | { |
b782773b RT |
483 | error ("Maximum string size exceeded"); |
484 | } | |
ab6780cd | 485 | |
e4dd8d12 RT |
486 | static Lisp_Object |
487 | make_empty_string (int multibyte) | |
488 | { | |
489 | Lisp_Object string; | |
490 | struct Lisp_String *s; | |
491 | ||
492 | s = allocate_string (); | |
493 | allocate_string_data (s, 0, 0); | |
494 | XSETSTRING (string, s); | |
495 | if (! multibyte) | |
496 | STRING_SET_UNIBYTE (string); | |
497 | ||
498 | return string; | |
499 | } | |
500 | ||
b782773b RT |
501 | DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, |
502 | doc: /* Return a newly created string of length LENGTH, with INIT in each element. | |
503 | LENGTH must be an integer. | |
504 | INIT must be an integer that represents a character. */) | |
505 | (Lisp_Object length, Lisp_Object init) | |
506 | { | |
507 | register Lisp_Object val; | |
508 | int c; | |
509 | EMACS_INT nbytes; | |
ab6780cd | 510 | |
b782773b RT |
511 | CHECK_NATNUM (length); |
512 | CHECK_CHARACTER (init); | |
ab6780cd | 513 | |
b782773b RT |
514 | c = XFASTINT (init); |
515 | if (ASCII_CHAR_P (c)) | |
ab6780cd | 516 | { |
b782773b RT |
517 | nbytes = XINT (length); |
518 | val = make_uninit_string (nbytes); | |
519 | memset (SDATA (val), c, nbytes); | |
520 | SDATA (val)[nbytes] = 0; | |
521 | } | |
522 | else | |
523 | { | |
524 | unsigned char str[MAX_MULTIBYTE_LENGTH]; | |
525 | ptrdiff_t len = CHAR_STRING (c, str); | |
526 | EMACS_INT string_len = XINT (length); | |
527 | unsigned char *p, *beg, *end; | |
ab6780cd | 528 | |
b782773b RT |
529 | if (string_len > STRING_BYTES_BOUND / len) |
530 | string_overflow (); | |
531 | nbytes = len * string_len; | |
532 | val = make_uninit_multibyte_string (string_len, nbytes); | |
533 | for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len) | |
8f924df7 | 534 | { |
b782773b RT |
535 | /* First time we just copy `str' to the data of `val'. */ |
536 | if (p == beg) | |
537 | memcpy (p, str, len); | |
538 | else | |
8f924df7 | 539 | { |
b782773b RT |
540 | /* Next time we copy largest possible chunk from |
541 | initialized to uninitialized part of `val'. */ | |
542 | len = min (p - beg, end - p); | |
543 | memcpy (p, beg, len); | |
8f924df7 KH |
544 | } |
545 | } | |
b782773b | 546 | *p = 0; |
ab6780cd SM |
547 | } |
548 | ||
ab6780cd SM |
549 | return val; |
550 | } | |
551 | ||
b782773b RT |
552 | /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise. |
553 | Return A. */ | |
ab6780cd | 554 | |
b782773b RT |
555 | Lisp_Object |
556 | bool_vector_fill (Lisp_Object a, Lisp_Object init) | |
557 | { | |
558 | EMACS_INT nbits = bool_vector_size (a); | |
559 | if (0 < nbits) | |
560 | { | |
561 | unsigned char *data = bool_vector_uchar_data (a); | |
562 | int pattern = NILP (init) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR) - 1; | |
563 | ptrdiff_t nbytes = bool_vector_bytes (nbits); | |
564 | int last_mask = ~ (~0u << ((nbits - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)); | |
565 | memset (data, pattern, nbytes - 1); | |
566 | data[nbytes - 1] = pattern & last_mask; | |
ab6780cd | 567 | } |
b782773b | 568 | return a; |
ab6780cd | 569 | } |
1a4f1e2c | 570 | |
b782773b | 571 | /* Return a newly allocated, uninitialized bool vector of size NBITS. */ |
34400008 | 572 | |
b782773b RT |
573 | Lisp_Object |
574 | make_uninit_bool_vector (EMACS_INT nbits) | |
2e471eb5 | 575 | { |
b782773b RT |
576 | Lisp_Object val; |
577 | EMACS_INT words = bool_vector_words (nbits); | |
578 | EMACS_INT word_bytes = words * sizeof (bits_word); | |
579 | EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes | |
580 | + word_size - 1) | |
581 | / word_size); | |
582 | struct Lisp_Bool_Vector *p | |
583 | = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements); | |
584 | XSETVECTOR (val, p); | |
585 | XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0); | |
586 | p->size = nbits; | |
d5e35230 | 587 | |
b782773b RT |
588 | /* Clear padding at the end. */ |
589 | if (words) | |
590 | p->data[words - 1] = 0; | |
34400008 | 591 | |
b782773b RT |
592 | return val; |
593 | } | |
34400008 | 594 | |
b782773b RT |
595 | DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0, |
596 | doc: /* Return a new bool-vector of length LENGTH, using INIT for each element. | |
597 | LENGTH must be a number. INIT matters only in whether it is t or nil. */) | |
598 | (Lisp_Object length, Lisp_Object init) | |
599 | { | |
600 | Lisp_Object val; | |
34400008 | 601 | |
b782773b RT |
602 | CHECK_NATNUM (length); |
603 | val = make_uninit_bool_vector (XFASTINT (length)); | |
604 | return bool_vector_fill (val, init); | |
605 | } | |
34400008 | 606 | |
b782773b RT |
607 | DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0, |
608 | doc: /* Return a new bool-vector with specified arguments as elements. | |
609 | Any number of arguments, even zero arguments, are allowed. | |
610 | usage: (bool-vector &rest OBJECTS) */) | |
611 | (ptrdiff_t nargs, Lisp_Object *args) | |
612 | { | |
613 | ptrdiff_t i; | |
614 | Lisp_Object vector; | |
d5e35230 | 615 | |
b782773b RT |
616 | vector = make_uninit_bool_vector (nargs); |
617 | for (i = 0; i < nargs; i++) | |
618 | bool_vector_set (vector, i, !NILP (args[i])); | |
34400008 | 619 | |
b782773b RT |
620 | return vector; |
621 | } | |
d5e35230 | 622 | |
b782773b RT |
623 | /* Make a string from NBYTES bytes at CONTENTS, and compute the number |
624 | of characters from the contents. This string may be unibyte or | |
625 | multibyte, depending on the contents. */ | |
d5e35230 | 626 | |
b782773b RT |
627 | Lisp_Object |
628 | make_string (const char *contents, ptrdiff_t nbytes) | |
d5e35230 | 629 | { |
b782773b RT |
630 | register Lisp_Object val; |
631 | ptrdiff_t nchars, multibyte_nbytes; | |
d5e35230 | 632 | |
b782773b RT |
633 | parse_str_as_multibyte ((const unsigned char *) contents, nbytes, |
634 | &nchars, &multibyte_nbytes); | |
635 | if (nbytes == nchars || nbytes != multibyte_nbytes) | |
636 | /* CONTENTS contains no multibyte sequences or contains an invalid | |
637 | multibyte sequence. We must make unibyte string. */ | |
638 | val = make_unibyte_string (contents, nbytes); | |
d5e35230 | 639 | else |
b782773b | 640 | val = make_multibyte_string (contents, nchars, nbytes); |
d5e35230 JA |
641 | return val; |
642 | } | |
643 | ||
34400008 | 644 | |
b782773b | 645 | /* Make an unibyte string from LENGTH bytes at CONTENTS. */ |
d5e35230 | 646 | |
b782773b RT |
647 | Lisp_Object |
648 | make_unibyte_string (const char *contents, ptrdiff_t length) | |
d5e35230 | 649 | { |
b782773b RT |
650 | register Lisp_Object val; |
651 | val = make_uninit_string (length); | |
652 | memcpy (SDATA (val), contents, length); | |
653 | return val; | |
d5e35230 JA |
654 | } |
655 | ||
34400008 | 656 | |
b782773b RT |
657 | /* Make a multibyte string from NCHARS characters occupying NBYTES |
658 | bytes at CONTENTS. */ | |
1a4f1e2c | 659 | |
b782773b RT |
660 | Lisp_Object |
661 | make_multibyte_string (const char *contents, | |
662 | ptrdiff_t nchars, ptrdiff_t nbytes) | |
663 | { | |
664 | register Lisp_Object val; | |
665 | val = make_uninit_multibyte_string (nchars, nbytes); | |
666 | memcpy (SDATA (val), contents, nbytes); | |
667 | return val; | |
668 | } | |
7146af97 | 669 | |
7146af97 | 670 | |
b782773b RT |
671 | /* Make a string from NCHARS characters occupying NBYTES bytes at |
672 | CONTENTS. It is a multibyte string if NBYTES != NCHARS. */ | |
7146af97 | 673 | |
b782773b RT |
674 | Lisp_Object |
675 | make_string_from_bytes (const char *contents, | |
676 | ptrdiff_t nchars, ptrdiff_t nbytes) | |
677 | { | |
678 | register Lisp_Object val; | |
679 | val = make_uninit_multibyte_string (nchars, nbytes); | |
680 | memcpy (SDATA (val), contents, nbytes); | |
681 | if (SBYTES (val) == SCHARS (val)) | |
682 | STRING_SET_UNIBYTE (val); | |
683 | return val; | |
684 | } | |
7146af97 | 685 | |
7146af97 | 686 | |
b782773b RT |
687 | /* Make a string from NCHARS characters occupying NBYTES bytes at |
688 | CONTENTS. The argument MULTIBYTE controls whether to label the | |
689 | string as multibyte. If NCHARS is negative, it counts the number of | |
690 | characters by itself. */ | |
c8099634 | 691 | |
b782773b RT |
692 | Lisp_Object |
693 | make_specified_string (const char *contents, | |
694 | ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte) | |
695 | { | |
696 | Lisp_Object val; | |
7146af97 | 697 | |
b782773b RT |
698 | if (nchars < 0) |
699 | { | |
700 | if (multibyte) | |
701 | nchars = multibyte_chars_in_text ((const unsigned char *) contents, | |
702 | nbytes); | |
703 | else | |
704 | nchars = nbytes; | |
705 | } | |
706 | val = make_uninit_multibyte_string (nchars, nbytes); | |
707 | memcpy (SDATA (val), contents, nbytes); | |
708 | if (!multibyte) | |
709 | STRING_SET_UNIBYTE (val); | |
710 | return val; | |
711 | } | |
2e471eb5 | 712 | |
2e471eb5 | 713 | |
b782773b RT |
714 | /* Return an unibyte Lisp_String set up to hold LENGTH characters |
715 | occupying LENGTH bytes. */ | |
91f2d272 | 716 | |
b782773b RT |
717 | Lisp_Object |
718 | make_uninit_string (EMACS_INT length) | |
fbe9e0b9 | 719 | { |
b782773b | 720 | Lisp_Object val; |
2e471eb5 | 721 | |
b782773b RT |
722 | if (!length) |
723 | return empty_unibyte_string; | |
724 | val = make_uninit_multibyte_string (length, length); | |
725 | STRING_SET_UNIBYTE (val); | |
726 | return val; | |
727 | } | |
177c0ea7 | 728 | |
31d929e5 | 729 | |
b782773b RT |
730 | /* Return a multibyte Lisp_String set up to hold NCHARS characters |
731 | which occupy NBYTES bytes. */ | |
2e471eb5 | 732 | |
b782773b RT |
733 | Lisp_Object |
734 | make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) | |
7146af97 | 735 | { |
b782773b RT |
736 | Lisp_Object string; |
737 | struct Lisp_String *s; | |
2e471eb5 | 738 | |
b782773b RT |
739 | if (nchars < 0) |
740 | emacs_abort (); | |
741 | if (!nbytes) | |
742 | return empty_multibyte_string; | |
2e471eb5 | 743 | |
b782773b RT |
744 | s = allocate_string (); |
745 | s->intervals = NULL; | |
746 | allocate_string_data (s, nchars, nbytes); | |
747 | XSETSTRING (string, s); | |
748 | return string; | |
749 | } | |
2e471eb5 | 750 | |
b782773b RT |
751 | /* Print arguments to BUF according to a FORMAT, then return |
752 | a Lisp_String initialized with the data from BUF. */ | |
2e471eb5 | 753 | |
b782773b RT |
754 | Lisp_Object |
755 | make_formatted_string (char *buf, const char *format, ...) | |
7146af97 | 756 | { |
b782773b RT |
757 | va_list ap; |
758 | int length; | |
7146af97 | 759 | |
b782773b RT |
760 | va_start (ap, format); |
761 | length = vsprintf (buf, format, ap); | |
762 | va_end (ap); | |
763 | return make_string (buf, length); | |
764 | } | |
3c06d205 | 765 | |
b782773b RT |
766 | \f |
767 | /*********************************************************************** | |
768 | Float Allocation | |
769 | ***********************************************************************/ | |
7146af97 | 770 | |
b782773b | 771 | /* Return a new float object with value FLOAT_VALUE. */ |
7146af97 | 772 | |
b782773b RT |
773 | Lisp_Object |
774 | make_float (double float_value) | |
775 | { | |
ed446f1e | 776 | return scm_from_double (float_value); |
b782773b | 777 | } |
7146af97 | 778 | |
b782773b RT |
779 | \f |
780 | /*********************************************************************** | |
781 | Cons Allocation | |
782 | ***********************************************************************/ | |
7146af97 | 783 | |
b782773b RT |
784 | DEFUN ("cons", Fcons, Scons, 2, 2, 0, |
785 | doc: /* Create a new cons, give it CAR and CDR as components, and return it. */) | |
786 | (Lisp_Object car, Lisp_Object cdr) | |
787 | { | |
e642c718 | 788 | return scm_cons (car, cdr); |
b782773b | 789 | } |
7146af97 | 790 | |
b782773b | 791 | /* Make a list of 1, 2, 3, 4 or 5 specified objects. */ |
c8099634 | 792 | |
b782773b RT |
793 | Lisp_Object |
794 | list1 (Lisp_Object arg1) | |
795 | { | |
796 | return Fcons (arg1, Qnil); | |
797 | } | |
7146af97 | 798 | |
b782773b RT |
799 | Lisp_Object |
800 | list2 (Lisp_Object arg1, Lisp_Object arg2) | |
801 | { | |
802 | return Fcons (arg1, Fcons (arg2, Qnil)); | |
803 | } | |
2e471eb5 | 804 | |
2e471eb5 | 805 | |
b782773b RT |
806 | Lisp_Object |
807 | list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) | |
808 | { | |
809 | return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil))); | |
810 | } | |
2e471eb5 | 811 | |
2e471eb5 | 812 | |
b782773b RT |
813 | Lisp_Object |
814 | list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4) | |
815 | { | |
816 | return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil)))); | |
817 | } | |
177c0ea7 | 818 | |
31d929e5 | 819 | |
b782773b RT |
820 | Lisp_Object |
821 | list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) | |
822 | { | |
823 | return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, | |
824 | Fcons (arg5, Qnil))))); | |
825 | } | |
2e471eb5 | 826 | |
b782773b RT |
827 | /* Make a list of COUNT Lisp_Objects, where ARG is the |
828 | first one. Allocate conses from pure space if TYPE | |
829 | is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */ | |
f2d3008d | 830 | |
b782773b RT |
831 | Lisp_Object |
832 | listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...) | |
833 | { | |
834 | va_list ap; | |
835 | ptrdiff_t i; | |
836 | Lisp_Object val, *objp; | |
31d929e5 | 837 | |
b782773b RT |
838 | /* Change to SAFE_ALLOCA if you hit this eassert. */ |
839 | eassert (count <= MAX_ALLOCA / word_size); | |
c9d624c6 | 840 | |
b782773b RT |
841 | objp = alloca (count * word_size); |
842 | objp[0] = arg; | |
843 | va_start (ap, arg); | |
844 | for (i = 1; i < count; i++) | |
845 | objp[i] = va_arg (ap, Lisp_Object); | |
846 | va_end (ap); | |
d457598b | 847 | |
b782773b RT |
848 | for (val = Qnil, i = count - 1; i >= 0; i--) |
849 | { | |
850 | if (type == CONSTYPE_PURE) | |
851 | val = pure_cons (objp[i], val); | |
852 | else if (type == CONSTYPE_HEAP) | |
853 | val = Fcons (objp[i], val); | |
854 | else | |
855 | emacs_abort (); | |
856 | } | |
857 | return val; | |
7146af97 JB |
858 | } |
859 | ||
b782773b RT |
860 | DEFUN ("list", Flist, Slist, 0, MANY, 0, |
861 | doc: /* Return a newly created list with specified arguments as elements. | |
862 | Any number of arguments, even zero arguments, are allowed. | |
863 | usage: (list &rest OBJECTS) */) | |
864 | (ptrdiff_t nargs, Lisp_Object *args) | |
7146af97 | 865 | { |
b782773b RT |
866 | register Lisp_Object val; |
867 | val = Qnil; | |
7146af97 | 868 | |
b782773b | 869 | while (nargs > 0) |
7146af97 | 870 | { |
b782773b RT |
871 | nargs--; |
872 | val = Fcons (args[nargs], val); | |
7146af97 | 873 | } |
b782773b RT |
874 | return val; |
875 | } | |
c0f51373 | 876 | |
c0f51373 | 877 | |
b782773b RT |
878 | DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, |
879 | doc: /* Return a newly created list of length LENGTH, with each element being INIT. */) | |
880 | (register Lisp_Object length, Lisp_Object init) | |
881 | { | |
882 | register Lisp_Object val; | |
883 | register EMACS_INT size; | |
c0f51373 | 884 | |
b782773b RT |
885 | CHECK_NATNUM (length); |
886 | size = XFASTINT (length); | |
7146af97 | 887 | |
b782773b RT |
888 | val = Qnil; |
889 | while (size > 0) | |
890 | { | |
891 | val = Fcons (init, val); | |
892 | --size; | |
7146af97 | 893 | |
b782773b RT |
894 | if (size > 0) |
895 | { | |
896 | val = Fcons (init, val); | |
897 | --size; | |
7146af97 | 898 | |
b782773b RT |
899 | if (size > 0) |
900 | { | |
901 | val = Fcons (init, val); | |
902 | --size; | |
7146af97 | 903 | |
b782773b RT |
904 | if (size > 0) |
905 | { | |
906 | val = Fcons (init, val); | |
907 | --size; | |
c9d624c6 | 908 | |
b782773b RT |
909 | if (size > 0) |
910 | { | |
911 | val = Fcons (init, val); | |
912 | --size; | |
913 | } | |
914 | } | |
915 | } | |
916 | } | |
917 | ||
918 | QUIT; | |
b7ffe040 | 919 | } |
e2984df0 | 920 | |
b782773b RT |
921 | return val; |
922 | } | |
2e471eb5 | 923 | |
2e471eb5 | 924 | |
b782773b RT |
925 | \f |
926 | /*********************************************************************** | |
927 | Vector Allocation | |
928 | ***********************************************************************/ | |
177c0ea7 | 929 | |
b782773b | 930 | /* The only vector with 0 slots, allocated from pure space. */ |
177c0ea7 | 931 | |
b782773b | 932 | Lisp_Object zero_vector; |
5c5fecb3 | 933 | |
b782773b | 934 | /* Called once to initialize vector allocation. */ |
a0b08700 | 935 | |
b782773b RT |
936 | static void |
937 | init_vectors (void) | |
938 | { | |
49609976 BT |
939 | struct Lisp_Vector *p = xmalloc (header_size); |
940 | ||
941 | SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p); | |
942 | p->header.size = 0; | |
943 | XSETVECTOR (zero_vector, p); | |
b782773b | 944 | } |
b7ffe040 | 945 | |
b782773b RT |
946 | /* Value is a pointer to a newly allocated Lisp_Vector structure |
947 | with room for LEN Lisp_Objects. */ | |
b7ffe040 | 948 | |
b782773b RT |
949 | static struct Lisp_Vector * |
950 | allocate_vectorlike (ptrdiff_t len) | |
951 | { | |
49609976 BT |
952 | struct Lisp_Vector *p; |
953 | ||
b782773b | 954 | if (len == 0) |
49609976 | 955 | p = XVECTOR (zero_vector); |
b782773b | 956 | else |
49609976 BT |
957 | { |
958 | p = xmalloc (header_size + len * word_size); | |
959 | SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p); | |
960 | } | |
961 | ||
962 | return p; | |
2e471eb5 GM |
963 | } |
964 | ||
965 | ||
b782773b | 966 | /* Allocate a vector with LEN slots. */ |
2e471eb5 | 967 | |
b782773b RT |
968 | struct Lisp_Vector * |
969 | allocate_vector (EMACS_INT len) | |
2e471eb5 | 970 | { |
b782773b RT |
971 | struct Lisp_Vector *v; |
972 | ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX); | |
177c0ea7 | 973 | |
b782773b RT |
974 | if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len) |
975 | memory_full (SIZE_MAX); | |
976 | v = allocate_vectorlike (len); | |
977 | v->header.size = len; | |
978 | return v; | |
979 | } | |
2e471eb5 | 980 | |
2e471eb5 | 981 | |
b782773b | 982 | /* Allocate other vector-like structures. */ |
2e471eb5 | 983 | |
b782773b RT |
984 | struct Lisp_Vector * |
985 | allocate_pseudovector (int memlen, int lisplen, enum pvec_type tag) | |
986 | { | |
987 | struct Lisp_Vector *v = allocate_vectorlike (memlen); | |
988 | int i; | |
2e471eb5 | 989 | |
b782773b RT |
990 | /* Catch bogus values. */ |
991 | eassert (tag <= PVEC_FONT); | |
992 | eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1); | |
993 | eassert (lisplen <= (1 << PSEUDOVECTOR_SIZE_BITS) - 1); | |
177c0ea7 | 994 | |
b782773b RT |
995 | /* Only the first lisplen slots will be traced normally by the GC. */ |
996 | for (i = 0; i < lisplen; ++i) | |
997 | v->contents[i] = Qnil; | |
2e471eb5 | 998 | |
b782773b RT |
999 | XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); |
1000 | return v; | |
1001 | } | |
2e471eb5 | 1002 | |
b782773b RT |
1003 | struct buffer * |
1004 | allocate_buffer (void) | |
1005 | { | |
1006 | struct buffer *b = xmalloc (sizeof *b); | |
2e471eb5 | 1007 | |
49609976 | 1008 | SCM_NEWSMOB (b->header.self, lisp_vectorlike_tag, b); |
b782773b RT |
1009 | BUFFER_PVEC_INIT (b); |
1010 | /* Put B on the chain of all buffers including killed ones. */ | |
1011 | b->next = all_buffers; | |
1012 | all_buffers = b; | |
1013 | /* Note that the rest fields of B are not initialized. */ | |
1014 | return b; | |
2e471eb5 GM |
1015 | } |
1016 | ||
b782773b RT |
1017 | struct Lisp_Hash_Table * |
1018 | allocate_hash_table (void) | |
1019 | { | |
1020 | return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE); | |
1021 | } | |
2e471eb5 | 1022 | |
b782773b RT |
1023 | struct window * |
1024 | allocate_window (void) | |
2e471eb5 | 1025 | { |
b782773b | 1026 | struct window *w; |
177c0ea7 | 1027 | |
b782773b RT |
1028 | w = ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW); |
1029 | /* Users assumes that non-Lisp data is zeroed. */ | |
1030 | memset (&w->current_matrix, 0, | |
1031 | sizeof (*w) - offsetof (struct window, current_matrix)); | |
1032 | return w; | |
1033 | } | |
2e471eb5 | 1034 | |
b782773b RT |
1035 | struct terminal * |
1036 | allocate_terminal (void) | |
1037 | { | |
1038 | struct terminal *t; | |
2e471eb5 | 1039 | |
b782773b RT |
1040 | t = ALLOCATE_PSEUDOVECTOR (struct terminal, next_terminal, PVEC_TERMINAL); |
1041 | /* Users assumes that non-Lisp data is zeroed. */ | |
1042 | memset (&t->next_terminal, 0, | |
1043 | sizeof (*t) - offsetof (struct terminal, next_terminal)); | |
1044 | return t; | |
2e471eb5 GM |
1045 | } |
1046 | ||
b782773b RT |
1047 | struct frame * |
1048 | allocate_frame (void) | |
1049 | { | |
1050 | struct frame *f; | |
2e471eb5 | 1051 | |
b782773b RT |
1052 | f = ALLOCATE_PSEUDOVECTOR (struct frame, face_cache, PVEC_FRAME); |
1053 | /* Users assumes that non-Lisp data is zeroed. */ | |
1054 | memset (&f->face_cache, 0, | |
1055 | sizeof (*f) - offsetof (struct frame, face_cache)); | |
1056 | return f; | |
1057 | } | |
2e471eb5 | 1058 | |
b782773b RT |
1059 | struct Lisp_Process * |
1060 | allocate_process (void) | |
2e471eb5 | 1061 | { |
b782773b | 1062 | struct Lisp_Process *p; |
177c0ea7 | 1063 | |
b782773b RT |
1064 | p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS); |
1065 | /* Users assumes that non-Lisp data is zeroed. */ | |
1066 | memset (&p->pid, 0, | |
1067 | sizeof (*p) - offsetof (struct Lisp_Process, pid)); | |
1068 | return p; | |
1069 | } | |
2e471eb5 | 1070 | |
b782773b RT |
1071 | DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, |
1072 | doc: /* Return a newly created vector of length LENGTH, with each element being INIT. | |
1073 | See also the function `vector'. */) | |
1074 | (register Lisp_Object length, Lisp_Object init) | |
1075 | { | |
1076 | Lisp_Object vector; | |
1077 | register ptrdiff_t sizei; | |
1078 | register ptrdiff_t i; | |
1079 | register struct Lisp_Vector *p; | |
212f33f1 | 1080 | |
b782773b | 1081 | CHECK_NATNUM (length); |
177c0ea7 | 1082 | |
b782773b RT |
1083 | p = allocate_vector (XFASTINT (length)); |
1084 | sizei = XFASTINT (length); | |
1085 | for (i = 0; i < sizei; i++) | |
1086 | p->contents[i] = init; | |
177c0ea7 | 1087 | |
b782773b RT |
1088 | XSETVECTOR (vector, p); |
1089 | return vector; | |
1090 | } | |
2e471eb5 | 1091 | |
2e471eb5 | 1092 | |
b782773b RT |
1093 | DEFUN ("vector", Fvector, Svector, 0, MANY, 0, |
1094 | doc: /* Return a newly created vector with specified arguments as elements. | |
1095 | Any number of arguments, even zero arguments, are allowed. | |
1096 | usage: (vector &rest OBJECTS) */) | |
1097 | (ptrdiff_t nargs, Lisp_Object *args) | |
1098 | { | |
1099 | ptrdiff_t i; | |
1100 | register Lisp_Object val = make_uninit_vector (nargs); | |
1101 | register struct Lisp_Vector *p = XVECTOR (val); | |
2e471eb5 | 1102 | |
b782773b RT |
1103 | for (i = 0; i < nargs; i++) |
1104 | p->contents[i] = args[i]; | |
1105 | return val; | |
2e471eb5 GM |
1106 | } |
1107 | ||
cb93f9be | 1108 | void |
b782773b | 1109 | make_byte_code (struct Lisp_Vector *v) |
2e471eb5 | 1110 | { |
b782773b RT |
1111 | /* Don't allow the global zero_vector to become a byte code object. */ |
1112 | eassert (0 < v->header.size); | |
2e471eb5 | 1113 | |
b782773b RT |
1114 | if (v->header.size > 1 && STRINGP (v->contents[1]) |
1115 | && STRING_MULTIBYTE (v->contents[1])) | |
1116 | /* BYTECODE-STRING must have been produced by Emacs 20.2 or the | |
1117 | earlier because they produced a raw 8-bit string for byte-code | |
1118 | and now such a byte-code string is loaded as multibyte while | |
1119 | raw 8-bit characters converted to multibyte form. Thus, now we | |
1120 | must convert them back to the original unibyte form. */ | |
1121 | v->contents[1] = Fstring_as_unibyte (v->contents[1]); | |
1122 | XSETPVECTYPE (v, PVEC_COMPILED); | |
1123 | } | |
2e471eb5 | 1124 | |
b782773b RT |
1125 | DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, |
1126 | doc: /* Create a byte-code object with specified arguments as elements. | |
1127 | The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant | |
1128 | vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING, | |
1129 | and (optional) INTERACTIVE-SPEC. | |
1130 | The first four arguments are required; at most six have any | |
1131 | significance. | |
1132 | The ARGLIST can be either like the one of `lambda', in which case the arguments | |
1133 | will be dynamically bound before executing the byte code, or it can be an | |
1134 | integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the | |
1135 | minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number | |
1136 | of arguments (ignoring &rest) and the R bit specifies whether there is a &rest | |
1137 | argument to catch the left-over arguments. If such an integer is used, the | |
1138 | arguments will not be dynamically bound but will be instead pushed on the | |
1139 | stack before executing the byte-code. | |
1140 | usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) | |
2bcf0551 DA |
1141 | (ptrdiff_t nargs, Lisp_Object *args) |
1142 | { | |
1143 | ptrdiff_t i; | |
b782773b RT |
1144 | register Lisp_Object val = make_uninit_vector (nargs); |
1145 | register struct Lisp_Vector *p = XVECTOR (val); | |
2e471eb5 | 1146 | |
b782773b RT |
1147 | /* We used to purecopy everything here, if purify-flag was set. This worked |
1148 | OK for Emacs-23, but with Emacs-24's lexical binding code, it can be | |
1149 | dangerous, since make-byte-code is used during execution to build | |
1150 | closures, so any closure built during the preload phase would end up | |
1151 | copied into pure space, including its free variables, which is sometimes | |
1152 | just wasteful and other times plainly wrong (e.g. those free vars may want | |
1153 | to be setcar'd). */ | |
4d774b0f | 1154 | |
b782773b RT |
1155 | for (i = 0; i < nargs; i++) |
1156 | p->contents[i] = args[i]; | |
1157 | make_byte_code (p); | |
1158 | XSETCOMPILED (val, p); | |
2e471eb5 | 1159 | return val; |
b782773b | 1160 | } |
2e471eb5 | 1161 | |
3ab6e069 | 1162 | |
b782773b RT |
1163 | \f |
1164 | /*********************************************************************** | |
1165 | Symbol Allocation | |
1166 | ***********************************************************************/ | |
3ab6e069 | 1167 | |
d23d13c0 BT |
1168 | DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, |
1169 | doc: /* Return a newly allocated uninterned symbol whose name is NAME. | |
1170 | Its value is void, and its function definition and property list are nil. */) | |
1171 | (Lisp_Object name) | |
1172 | { | |
1173 | register Lisp_Object val; | |
1174 | ||
1175 | CHECK_STRING (name); | |
1176 | ||
1177 | val = scm_make_symbol (scm_from_utf8_stringn (SSDATA (name), | |
1178 | SBYTES (name))); | |
b782773b RT |
1179 | return val; |
1180 | } | |
5b835e1d | 1181 | |
5b835e1d | 1182 | |
b782773b RT |
1183 | \f |
1184 | /*********************************************************************** | |
1185 | Marker (Misc) Allocation | |
1186 | ***********************************************************************/ | |
3ab6e069 | 1187 | |
b782773b | 1188 | /* Return a newly allocated Lisp_Misc object of specified TYPE. */ |
3ab6e069 | 1189 | |
b782773b RT |
1190 | static Lisp_Object |
1191 | allocate_misc (enum Lisp_Misc_Type type) | |
1192 | { | |
1193 | Lisp_Object val; | |
49609976 | 1194 | union Lisp_Misc *p; |
2e471eb5 | 1195 | |
49609976 BT |
1196 | p = xmalloc (sizeof *p); |
1197 | SCM_NEWSMOB (p->u_any.self, lisp_misc_tag, p); | |
1198 | XSETMISC (val, p); | |
b782773b RT |
1199 | XMISCANY (val)->type = type; |
1200 | return val; | |
1201 | } | |
f8643a6b | 1202 | |
b782773b | 1203 | /* Free a Lisp_Misc object. */ |
7146af97 | 1204 | |
b782773b RT |
1205 | void |
1206 | free_misc (Lisp_Object misc) | |
1207 | { | |
1208 | return; | |
1209 | } | |
2c5bd608 | 1210 | |
b782773b RT |
1211 | /* Verify properties of Lisp_Save_Value's representation |
1212 | that are assumed here and elsewhere. */ | |
d35af63c | 1213 | |
b782773b RT |
1214 | verify (SAVE_UNUSED == 0); |
1215 | verify (((SAVE_INTEGER | SAVE_POINTER | SAVE_FUNCPOINTER | SAVE_OBJECT) | |
1216 | >> SAVE_SLOT_BITS) | |
1217 | == 0); | |
2c5bd608 | 1218 | |
b782773b RT |
1219 | /* Return Lisp_Save_Value objects for the various combinations |
1220 | that callers need. */ | |
12b3895d | 1221 | |
b782773b RT |
1222 | Lisp_Object |
1223 | make_save_int_int_int (ptrdiff_t a, ptrdiff_t b, ptrdiff_t c) | |
1224 | { | |
1225 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1226 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1227 | p->save_type = SAVE_TYPE_INT_INT_INT; | |
1228 | p->data[0].integer = a; | |
1229 | p->data[1].integer = b; | |
1230 | p->data[2].integer = c; | |
1231 | return val; | |
7146af97 | 1232 | } |
34400008 | 1233 | |
b782773b RT |
1234 | Lisp_Object |
1235 | make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c, | |
1236 | Lisp_Object d) | |
c94e3311 | 1237 | { |
b782773b RT |
1238 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); |
1239 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1240 | p->save_type = SAVE_TYPE_OBJ_OBJ_OBJ_OBJ; | |
1241 | p->data[0].object = a; | |
1242 | p->data[1].object = b; | |
1243 | p->data[2].object = c; | |
1244 | p->data[3].object = d; | |
1245 | return val; | |
1246 | } | |
c94e3311 | 1247 | |
b782773b RT |
1248 | Lisp_Object |
1249 | make_save_ptr (void *a) | |
1250 | { | |
1251 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1252 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1253 | p->save_type = SAVE_POINTER; | |
1254 | p->data[0].pointer = a; | |
1255 | return val; | |
c94e3311 | 1256 | } |
41c28a37 | 1257 | |
b782773b RT |
1258 | Lisp_Object |
1259 | make_save_ptr_int (void *a, ptrdiff_t b) | |
1260 | { | |
1261 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1262 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1263 | p->save_type = SAVE_TYPE_PTR_INT; | |
1264 | p->data[0].pointer = a; | |
1265 | p->data[1].integer = b; | |
1266 | return val; | |
1267 | } | |
41c28a37 | 1268 | |
b782773b RT |
1269 | #if ! (defined USE_X_TOOLKIT || defined USE_GTK) |
1270 | Lisp_Object | |
1271 | make_save_ptr_ptr (void *a, void *b) | |
41c28a37 | 1272 | { |
b782773b RT |
1273 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); |
1274 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1275 | p->save_type = SAVE_TYPE_PTR_PTR; | |
1276 | p->data[0].pointer = a; | |
1277 | p->data[1].pointer = b; | |
1278 | return val; | |
1279 | } | |
1280 | #endif | |
41c28a37 | 1281 | |
b782773b RT |
1282 | Lisp_Object |
1283 | make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c) | |
1284 | { | |
1285 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1286 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1287 | p->save_type = SAVE_TYPE_FUNCPTR_PTR_OBJ; | |
1288 | p->data[0].funcpointer = a; | |
1289 | p->data[1].pointer = b; | |
1290 | p->data[2].object = c; | |
1291 | return val; | |
41c28a37 GM |
1292 | } |
1293 | ||
b782773b RT |
1294 | /* Return a Lisp_Save_Value object that represents an array A |
1295 | of N Lisp objects. */ | |
7146af97 | 1296 | |
b782773b RT |
1297 | Lisp_Object |
1298 | make_save_memory (Lisp_Object *a, ptrdiff_t n) | |
1299 | { | |
1300 | Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); | |
1301 | struct Lisp_Save_Value *p = XSAVE_VALUE (val); | |
1302 | p->save_type = SAVE_TYPE_MEMORY; | |
1303 | p->data[0].pointer = a; | |
1304 | p->data[1].integer = n; | |
1305 | return val; | |
1306 | } | |
785cd37f | 1307 | |
b782773b RT |
1308 | /* Free a Lisp_Save_Value object. Do not use this function |
1309 | if SAVE contains pointer other than returned by xmalloc. */ | |
1342fc6f | 1310 | |
b782773b RT |
1311 | void |
1312 | free_save_value (Lisp_Object save) | |
d2029e5b | 1313 | { |
b782773b RT |
1314 | xfree (XSAVE_POINTER (save, 0)); |
1315 | free_misc (save); | |
d2029e5b SM |
1316 | } |
1317 | ||
b782773b | 1318 | /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */ |
58026347 | 1319 | |
b782773b RT |
1320 | Lisp_Object |
1321 | build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist) | |
58026347 | 1322 | { |
b782773b | 1323 | register Lisp_Object overlay; |
58026347 | 1324 | |
b782773b RT |
1325 | overlay = allocate_misc (Lisp_Misc_Overlay); |
1326 | OVERLAY_START (overlay) = start; | |
1327 | OVERLAY_END (overlay) = end; | |
1328 | set_overlay_plist (overlay, plist); | |
1329 | XOVERLAY (overlay)->next = NULL; | |
1330 | return overlay; | |
58026347 KH |
1331 | } |
1332 | ||
b782773b RT |
1333 | DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, |
1334 | doc: /* Return a newly allocated marker which does not point at any place. */) | |
1335 | (void) | |
83f14500 | 1336 | { |
b782773b RT |
1337 | register Lisp_Object val; |
1338 | register struct Lisp_Marker *p; | |
15684f52 | 1339 | |
b782773b RT |
1340 | val = allocate_misc (Lisp_Misc_Marker); |
1341 | p = XMARKER (val); | |
1342 | p->buffer = 0; | |
1343 | p->bytepos = 0; | |
1344 | p->charpos = 0; | |
1345 | p->next = NULL; | |
1346 | p->insertion_type = 0; | |
1347 | p->need_adjustment = 0; | |
1348 | return val; | |
83f14500 DA |
1349 | } |
1350 | ||
b782773b RT |
1351 | /* Return a newly allocated marker which points into BUF |
1352 | at character position CHARPOS and byte position BYTEPOS. */ | |
36429c89 | 1353 | |
b782773b RT |
1354 | Lisp_Object |
1355 | build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos) | |
36429c89 | 1356 | { |
b782773b RT |
1357 | Lisp_Object obj; |
1358 | struct Lisp_Marker *m; | |
1359 | ||
1360 | /* No dead buffers here. */ | |
1361 | eassert (BUFFER_LIVE_P (buf)); | |
1362 | ||
1363 | /* Every character is at least one byte. */ | |
1364 | eassert (charpos <= bytepos); | |
1365 | ||
1366 | obj = allocate_misc (Lisp_Misc_Marker); | |
1367 | m = XMARKER (obj); | |
1368 | m->buffer = buf; | |
1369 | m->charpos = charpos; | |
1370 | m->bytepos = bytepos; | |
1371 | m->insertion_type = 0; | |
1372 | m->need_adjustment = 0; | |
1373 | m->next = BUF_MARKERS (buf); | |
1374 | BUF_MARKERS (buf) = m; | |
1375 | return obj; | |
36429c89 | 1376 | } |
b782773b RT |
1377 | \f |
1378 | /* Return a newly created vector or string with specified arguments as | |
1379 | elements. If all the arguments are characters that can fit | |
1380 | in a string of events, make a string; otherwise, make a vector. | |
36429c89 | 1381 | |
b782773b | 1382 | Any number of arguments, even zero arguments, are allowed. */ |
cf5c0175 | 1383 | |
b782773b RT |
1384 | Lisp_Object |
1385 | make_event_array (ptrdiff_t nargs, Lisp_Object *args) | |
cf5c0175 | 1386 | { |
b782773b RT |
1387 | ptrdiff_t i; |
1388 | ||
1389 | for (i = 0; i < nargs; i++) | |
1390 | /* The things that fit in a string | |
1391 | are characters that are in 0...127, | |
1392 | after discarding the meta bit and all the bits above it. */ | |
1393 | if (!INTEGERP (args[i]) | |
1394 | || (XINT (args[i]) & ~(-CHAR_META)) >= 0200) | |
1395 | return Fvector (nargs, args); | |
1396 | ||
1397 | /* Since the loop exited, we know that all the things in it are | |
1398 | characters, so we can make a string. */ | |
1399 | { | |
1400 | Lisp_Object result; | |
cf5c0175 | 1401 | |
b782773b RT |
1402 | result = Fmake_string (make_number (nargs), make_number (0)); |
1403 | for (i = 0; i < nargs; i++) | |
1404 | { | |
1405 | SSET (result, i, XINT (args[i])); | |
1406 | /* Move the meta bit to the right place for a string char. */ | |
1407 | if (XINT (args[i]) & CHAR_META) | |
1408 | SSET (result, i, SREF (result, i) | 0x80); | |
1409 | } | |
cf5c0175 | 1410 | |
b782773b RT |
1411 | return result; |
1412 | } | |
1413 | } | |
cf5c0175 | 1414 | |
cf5c0175 | 1415 | |
b782773b RT |
1416 | \f |
1417 | /************************************************************************ | |
1418 | Memory Full Handling | |
1419 | ************************************************************************/ | |
cf5c0175 | 1420 | |
cf5c0175 | 1421 | |
b782773b RT |
1422 | /* Called if xmalloc (NBYTES) returns zero. If NBYTES == SIZE_MAX, |
1423 | there may have been size_t overflow so that xmalloc was never | |
1424 | called, or perhaps xmalloc was invoked successfully but the | |
1425 | resulting pointer had problems fitting into a tagged EMACS_INT. In | |
1426 | either case this counts as memory being full even though xmalloc | |
1427 | did not fail. */ | |
fc54bdd5 | 1428 | |
b782773b RT |
1429 | void |
1430 | memory_full (size_t nbytes) | |
fc54bdd5 | 1431 | { |
b782773b RT |
1432 | /* Do not go into hysterics merely because a large request failed. */ |
1433 | bool enough_free_memory = 0; | |
1434 | if (SPARE_MEMORY < nbytes) | |
fc54bdd5 | 1435 | { |
c1ade6f7 | 1436 | void *p = xmalloc_atomic_unsafe (SPARE_MEMORY); |
b782773b | 1437 | if (p) |
fc54bdd5 | 1438 | { |
b782773b RT |
1439 | xfree (p); |
1440 | enough_free_memory = 1; | |
fc54bdd5 DA |
1441 | } |
1442 | } | |
83f14500 | 1443 | |
b782773b | 1444 | if (! enough_free_memory) |
2c70e6b0 | 1445 | { |
b782773b | 1446 | Vmemory_full = Qt; |
d73e321c | 1447 | |
b782773b RT |
1448 | /* The first time we get here, free the spare memory. */ |
1449 | if (spare_memory) | |
1450 | { | |
1451 | xfree (spare_memory); | |
1452 | spare_memory = NULL; | |
1453 | } | |
d73e321c | 1454 | } |
b782773b RT |
1455 | |
1456 | /* This used to call error, but if we've run out of memory, we could | |
1457 | get infinite recursion trying to build the string. */ | |
1458 | xsignal (Qnil, Vmemory_signal_data); | |
d73e321c DA |
1459 | } |
1460 | ||
b782773b RT |
1461 | /* If we released our reserve (due to running out of memory), |
1462 | and we have a fair amount free once again, | |
1463 | try to set aside another reserve in case we run out once more. | |
2c70e6b0 | 1464 | |
b782773b RT |
1465 | This is called when a relocatable block is freed in ralloc.c, |
1466 | and also directly from this file, in case we're not using ralloc.c. */ | |
cf5c0175 | 1467 | |
41c28a37 | 1468 | void |
b782773b | 1469 | refill_memory_reserve (void) |
7146af97 | 1470 | { |
b782773b | 1471 | if (spare_memory == NULL) |
c1ade6f7 | 1472 | spare_memory = xmalloc_atomic_unsafe (SPARE_MEMORY); |
7146af97 | 1473 | |
b782773b RT |
1474 | if (spare_memory) |
1475 | Vmemory_full = Qnil; | |
1476 | } | |
1477 | \f | |
1478 | /* Determine whether it is safe to access memory at address P. */ | |
1479 | static int | |
1480 | valid_pointer_p (void *p) | |
1481 | { | |
1482 | #ifdef WINDOWSNT | |
1483 | return w32_valid_pointer_p (p, 16); | |
1484 | #else | |
1485 | int fd[2]; | |
7146af97 | 1486 | |
b782773b RT |
1487 | /* Obviously, we cannot just access it (we would SEGV trying), so we |
1488 | trick the o/s to tell us whether p is a valid pointer. | |
1489 | Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may | |
1490 | not validate p in that case. */ | |
785cd37f | 1491 | |
b782773b | 1492 | if (emacs_pipe (fd) == 0) |
7146af97 | 1493 | { |
b782773b RT |
1494 | bool valid = emacs_write (fd[1], p, 16) == 16; |
1495 | emacs_close (fd[1]); | |
1496 | emacs_close (fd[0]); | |
1497 | return valid; | |
1498 | } | |
df24a230 | 1499 | |
b782773b | 1500 | return -1; |
df24a230 | 1501 | #endif |
b782773b | 1502 | } |
cf5c0175 | 1503 | |
b782773b RT |
1504 | /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a |
1505 | valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we | |
1506 | cannot validate OBJ. This function can be quite slow, so its primary | |
1507 | use is the manual debugging. The only exception is print_object, where | |
1508 | we use it to check whether the memory referenced by the pointer of | |
1509 | Lisp_Save_Value object contains valid objects. */ | |
5779a1dc | 1510 | |
b782773b RT |
1511 | int |
1512 | valid_lisp_object_p (Lisp_Object obj) | |
1513 | { | |
1514 | void *p; | |
e99f70c8 | 1515 | |
49609976 | 1516 | if (SCM_IMP (obj)) |
b782773b | 1517 | return 1; |
e99f70c8 | 1518 | |
49609976 | 1519 | p = (void *) SCM2PTR (obj); |
cf5c0175 | 1520 | |
b782773b RT |
1521 | if (p == &buffer_defaults || p == &buffer_local_symbols) |
1522 | return 2; | |
cf5c0175 | 1523 | |
b782773b RT |
1524 | return valid_pointer_p (p); |
1525 | } | |
cf5c0175 | 1526 | |
b782773b RT |
1527 | /* If GC_MARK_STACK, return 1 if STR is a relocatable data of Lisp_String |
1528 | (i.e. there is a non-pure Lisp_Object X so that SDATA (X) == STR) and 0 | |
1529 | if not. Otherwise we can't rely on valid_lisp_object_p and return -1. | |
1530 | This function is slow and should be used for debugging purposes. */ | |
cf5c0175 | 1531 | |
b782773b RT |
1532 | int |
1533 | relocatable_string_data_p (const char *str) | |
1534 | { | |
b782773b RT |
1535 | return -1; |
1536 | } | |
cf5c0175 | 1537 | |
b782773b | 1538 | /*********************************************************************** |
e4dd8d12 | 1539 | Pure Storage Compatibility Functions |
b782773b | 1540 | ***********************************************************************/ |
cf5c0175 | 1541 | |
b782773b RT |
1542 | void |
1543 | check_pure_size (void) | |
4a729fd8 | 1544 | { |
e4dd8d12 | 1545 | return; |
41c28a37 GM |
1546 | } |
1547 | ||
b782773b RT |
1548 | Lisp_Object |
1549 | make_pure_string (const char *data, | |
1550 | ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte) | |
1551 | { | |
e4dd8d12 | 1552 | return make_specified_string (data, nchars, nbytes, multibyte); |
b029599f | 1553 | } |
7146af97 | 1554 | |
b782773b RT |
1555 | Lisp_Object |
1556 | make_pure_c_string (const char *data, ptrdiff_t nchars) | |
b029599f | 1557 | { |
e4dd8d12 | 1558 | return build_string (data); |
b782773b | 1559 | } |
177c0ea7 | 1560 | |
b782773b RT |
1561 | Lisp_Object |
1562 | pure_cons (Lisp_Object car, Lisp_Object cdr) | |
b029599f | 1563 | { |
e4dd8d12 | 1564 | return Fcons (car, cdr); |
b782773b | 1565 | } |
177c0ea7 | 1566 | |
b782773b | 1567 | DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, |
e4dd8d12 | 1568 | doc: /* Return OBJ. */) |
b782773b RT |
1569 | (register Lisp_Object obj) |
1570 | { | |
b782773b | 1571 | return obj; |
7146af97 | 1572 | } |
7146af97 | 1573 | \f |
b782773b RT |
1574 | /*********************************************************************** |
1575 | Protection from GC | |
1576 | ***********************************************************************/ | |
20d24714 | 1577 | |
b782773b RT |
1578 | void |
1579 | staticpro (Lisp_Object *varaddress) | |
310ea200 | 1580 | { |
1c34c3c0 | 1581 | return; |
310ea200 | 1582 | } |
b782773b RT |
1583 | \f |
1584 | DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", | |
1585 | doc: /* Reclaim storage for Lisp objects no longer needed. | |
1586 | Garbage collection happens automatically if you cons more than | |
1587 | `gc-cons-threshold' bytes of Lisp data since previous garbage collection. | |
1588 | `garbage-collect' normally returns a list with info on amount of space in use, | |
1589 | where each entry has the form (NAME SIZE USED FREE), where: | |
1590 | - NAME is a symbol describing the kind of objects this entry represents, | |
1591 | - SIZE is the number of bytes used by each one, | |
1592 | - USED is the number of those objects that were found live in the heap, | |
1593 | - FREE is the number of those objects that are not live but that Emacs | |
1594 | keeps around for future allocations (maybe because it does not know how | |
1595 | to return them to the OS). | |
1596 | However, if there was overflow in pure space, `garbage-collect' | |
1597 | returns nil, because real GC can't be done. | |
1598 | See Info node `(elisp)Garbage Collection'. */) | |
1599 | (void) | |
8b058d44 | 1600 | { |
b782773b RT |
1601 | GC_gcollect (); |
1602 | return Qt; | |
8b058d44 | 1603 | } |
b782773b | 1604 | \f |
244ed907 | 1605 | #ifdef ENABLE_CHECKING |
f4a681b0 | 1606 | |
fce31d69 | 1607 | bool suppress_checking; |
d3d47262 | 1608 | |
e0b8c689 | 1609 | void |
971de7fb | 1610 | die (const char *msg, const char *file, int line) |
e0b8c689 | 1611 | { |
5013fc08 | 1612 | fprintf (stderr, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n", |
e0b8c689 | 1613 | file, line, msg); |
4d7e6e51 | 1614 | terminate_due_to_signal (SIGABRT, INT_MAX); |
e0b8c689 | 1615 | } |
244ed907 | 1616 | #endif |
20d24714 | 1617 | \f |
b09cca6a | 1618 | /* Initialization. */ |
7146af97 | 1619 | |
dfcf069d | 1620 | void |
971de7fb | 1621 | init_alloc_once (void) |
7146af97 | 1622 | { |
49609976 BT |
1623 | lisp_misc_tag = scm_make_smob_type ("elisp-misc", 0); |
1624 | lisp_string_tag = scm_make_smob_type ("elisp-string", 0); | |
1625 | lisp_vectorlike_tag = scm_make_smob_type ("elisp-vectorlike", 0); | |
49609976 | 1626 | |
7146af97 | 1627 | /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ |
ab6780cd | 1628 | |
7146af97 | 1629 | init_strings (); |
f3372c87 | 1630 | init_vectors (); |
d5e35230 | 1631 | |
24d8a105 | 1632 | refill_memory_reserve (); |
0dd6d66d | 1633 | gc_cons_threshold = GC_DEFAULT_THRESHOLD; |
7146af97 JB |
1634 | } |
1635 | ||
dfcf069d | 1636 | void |
971de7fb | 1637 | init_alloc (void) |
7146af97 JB |
1638 | { |
1639 | gcprolist = 0; | |
2c5bd608 DL |
1640 | Vgc_elapsed = make_float (0.0); |
1641 | gcs_done = 0; | |
a84683fd DC |
1642 | |
1643 | #if USE_VALGRIND | |
d160dd0c | 1644 | valgrind_p = RUNNING_ON_VALGRIND != 0; |
a84683fd | 1645 | #endif |
7146af97 JB |
1646 | } |
1647 | ||
1648 | void | |
971de7fb | 1649 | syms_of_alloc (void) |
7146af97 | 1650 | { |
fe6aa7a1 BT |
1651 | #include "alloc.x" |
1652 | ||
29208e82 | 1653 | DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold, |
fb7ada5f | 1654 | doc: /* Number of bytes of consing between garbage collections. |
228299fa GM |
1655 | Garbage collection can happen automatically once this many bytes have been |
1656 | allocated since the last garbage collection. All data types count. | |
7146af97 | 1657 | |
228299fa | 1658 | Garbage collection happens automatically only when `eval' is called. |
7146af97 | 1659 | |
228299fa | 1660 | By binding this temporarily to a large number, you can effectively |
96f077ad SM |
1661 | prevent garbage collection during a part of the program. |
1662 | See also `gc-cons-percentage'. */); | |
1663 | ||
29208e82 | 1664 | DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage, |
fb7ada5f | 1665 | doc: /* Portion of the heap used for allocation. |
96f077ad SM |
1666 | Garbage collection can happen automatically once this portion of the heap |
1667 | has been allocated since the last garbage collection. | |
1668 | If this portion is smaller than `gc-cons-threshold', this is ignored. */); | |
1669 | Vgc_cons_percentage = make_float (0.1); | |
0819585c | 1670 | |
29208e82 | 1671 | DEFVAR_INT ("pure-bytes-used", pure_bytes_used, |
333f9019 | 1672 | doc: /* Number of bytes of shareable Lisp data allocated so far. */); |
0819585c | 1673 | |
29208e82 | 1674 | DEFVAR_LISP ("purify-flag", Vpurify_flag, |
a6266d23 | 1675 | doc: /* Non-nil means loading Lisp code in order to dump an executable. |
e9515805 SM |
1676 | This means that certain objects should be allocated in shared (pure) space. |
1677 | It can also be set to a hash-table, in which case this table is used to | |
1678 | do hash-consing of the objects allocated to pure space. */); | |
228299fa | 1679 | |
29208e82 | 1680 | DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages, |
a6266d23 | 1681 | doc: /* Non-nil means display messages at start and end of garbage collection. */); |
299585ee RS |
1682 | garbage_collection_messages = 0; |
1683 | ||
29208e82 | 1684 | DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook, |
a6266d23 | 1685 | doc: /* Hook run after garbage collection has finished. */); |
9e713715 | 1686 | Vpost_gc_hook = Qnil; |
cd3520a4 | 1687 | DEFSYM (Qpost_gc_hook, "post-gc-hook"); |
9e713715 | 1688 | |
29208e82 | 1689 | DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data, |
74a54b04 | 1690 | doc: /* Precomputed `signal' argument for memory-full error. */); |
bcb61d60 KH |
1691 | /* We build this in advance because if we wait until we need it, we might |
1692 | not be able to allocate the memory to hold it. */ | |
74a54b04 | 1693 | Vmemory_signal_data |
3438fe21 | 1694 | = listn (CONSTYPE_PURE, 2, Qerror, |
694b6c97 | 1695 | build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs")); |
74a54b04 | 1696 | |
29208e82 | 1697 | DEFVAR_LISP ("memory-full", Vmemory_full, |
24d8a105 | 1698 | doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); |
74a54b04 | 1699 | Vmemory_full = Qnil; |
bcb61d60 | 1700 | |
cd3520a4 JB |
1701 | DEFSYM (Qgc_cons_threshold, "gc-cons-threshold"); |
1702 | DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots"); | |
a59de17b | 1703 | |
29208e82 | 1704 | DEFVAR_LISP ("gc-elapsed", Vgc_elapsed, |
2c5bd608 | 1705 | doc: /* Accumulated time elapsed in garbage collections. |
e7415487 | 1706 | The time is in seconds as a floating point value. */); |
29208e82 | 1707 | DEFVAR_INT ("gcs-done", gcs_done, |
e7415487 | 1708 | doc: /* Accumulated number of garbage collections done. */); |
7146af97 | 1709 | } |
5eceb8fb | 1710 | |
4706125e PE |
1711 | /* When compiled with GCC, GDB might say "No enum type named |
1712 | pvec_type" if we don't have at least one symbol with that type, and | |
1713 | then xbacktrace could fail. Similarly for the other enums and | |
62aba0d4 FP |
1714 | their values. Some non-GCC compilers don't like these constructs. */ |
1715 | #ifdef __GNUC__ | |
4706125e PE |
1716 | union |
1717 | { | |
03a660a6 PE |
1718 | enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS; |
1719 | enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS; | |
1720 | enum char_bits char_bits; | |
03a660a6 | 1721 | enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE; |
4706125e | 1722 | enum Lisp_Bits Lisp_Bits; |
03a660a6 PE |
1723 | enum Lisp_Compiled Lisp_Compiled; |
1724 | enum maxargs maxargs; | |
1725 | enum MAX_ALLOCA MAX_ALLOCA; | |
4706125e PE |
1726 | enum More_Lisp_Bits More_Lisp_Bits; |
1727 | enum pvec_type pvec_type; | |
1728 | } const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0}; | |
62aba0d4 | 1729 | #endif /* __GNUC__ */ |