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