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