Mercurial > emacs
annotate src/alloc.c @ 4413:5a00cec8e9b0
(fill-region-as-paragraph): When we take one word
after the fill column, don't stop at period with just one space.
When checking whether at beginning of line, if no fill prefix,
ignore intervening whitespace.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Mon, 02 Aug 1993 05:55:56 +0000 |
parents | a696547fb51e |
children | 15b073a6c860 |
rev | line source |
---|---|
300 | 1 /* Storage allocation and gc for GNU Emacs Lisp interpreter. |
2961 | 2 Copyright (C) 1985, 1986, 1988, 1993 Free Software Foundation, Inc. |
300 | 3 |
4 This file is part of GNU Emacs. | |
5 | |
6 GNU Emacs is free software; you can redistribute it and/or modify | |
7 it under the terms of the GNU General Public License as published by | |
1784
11f62e53acff
Make scrollbar structures into lisp objects, so that they can be
Jim Blandy <jimb@redhat.com>
parents:
1562
diff
changeset
|
8 the Free Software Foundation; either version 2, or (at your option) |
300 | 9 any later version. |
10 | |
11 GNU Emacs is distributed in the hope that it will be useful, | |
12 but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 GNU General Public License for more details. | |
15 | |
16 You should have received a copy of the GNU General Public License | |
17 along with GNU Emacs; see the file COPYING. If not, write to | |
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ | |
19 | |
3003
5a73d384f45e
* syssignal.h: Don't #include <signal.h>
Jim Blandy <jimb@redhat.com>
parents:
2961
diff
changeset
|
20 #include <signal.h> |
300 | 21 |
22 #include "config.h" | |
23 #include "lisp.h" | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
24 #include "intervals.h" |
356 | 25 #include "puresize.h" |
300 | 26 #ifndef standalone |
27 #include "buffer.h" | |
28 #include "window.h" | |
764 | 29 #include "frame.h" |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
30 #include "blockinput.h" |
300 | 31 #endif |
32 | |
638 | 33 #include "syssignal.h" |
34 | |
300 | 35 #define max(A,B) ((A) > (B) ? (A) : (B)) |
36 | |
37 /* Macro to verify that storage intended for Lisp objects is not | |
38 out of range to fit in the space for a pointer. | |
39 ADDRESS is the start of the block, and SIZE | |
40 is the amount of space within which objects can start. */ | |
41 #define VALIDATE_LISP_STORAGE(address, size) \ | |
42 do \ | |
43 { \ | |
44 Lisp_Object val; \ | |
45 XSET (val, Lisp_Cons, (char *) address + size); \ | |
46 if ((char *) XCONS (val) != (char *) address + size) \ | |
47 { \ | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
48 xfree (address); \ |
300 | 49 memory_full (); \ |
50 } \ | |
51 } while (0) | |
52 | |
53 /* Number of bytes of consing done since the last gc */ | |
54 int consing_since_gc; | |
55 | |
56 /* Number of bytes of consing since gc before another gc should be done. */ | |
57 int gc_cons_threshold; | |
58 | |
59 /* Nonzero during gc */ | |
60 int gc_in_progress; | |
61 | |
62 #ifndef VIRT_ADDR_VARIES | |
63 extern | |
64 #endif /* VIRT_ADDR_VARIES */ | |
65 int malloc_sbrk_used; | |
66 | |
67 #ifndef VIRT_ADDR_VARIES | |
68 extern | |
69 #endif /* VIRT_ADDR_VARIES */ | |
70 int malloc_sbrk_unused; | |
71 | |
764 | 72 /* Two limits controlling how much undo information to keep. */ |
73 int undo_limit; | |
74 int undo_strong_limit; | |
300 | 75 |
76 /* Non-nil means defun should do purecopy on the function definition */ | |
77 Lisp_Object Vpurify_flag; | |
78 | |
79 #ifndef HAVE_SHM | |
80 int pure[PURESIZE / sizeof (int)] = {0,}; /* Force it into data space! */ | |
81 #define PUREBEG (char *) pure | |
82 #else | |
83 #define pure PURE_SEG_BITS /* Use shared memory segment */ | |
84 #define PUREBEG (char *)PURE_SEG_BITS | |
356 | 85 |
86 /* This variable is used only by the XPNTR macro when HAVE_SHM is | |
87 defined. If we used the PURESIZE macro directly there, that would | |
88 make most of emacs dependent on puresize.h, which we don't want - | |
89 you should be able to change that without too much recompilation. | |
90 So map_in_data initializes pure_size, and the dependencies work | |
91 out. */ | |
92 int pure_size; | |
300 | 93 #endif /* not HAVE_SHM */ |
94 | |
95 /* Index in pure at which next pure object will be allocated. */ | |
96 int pureptr; | |
97 | |
98 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */ | |
99 char *pending_malloc_warning; | |
100 | |
101 /* Maximum amount of C stack to save when a GC happens. */ | |
102 | |
103 #ifndef MAX_SAVE_STACK | |
104 #define MAX_SAVE_STACK 16000 | |
105 #endif | |
106 | |
107 /* Buffer in which we save a copy of the C stack at each GC. */ | |
108 | |
109 char *stack_copy; | |
110 int stack_copy_size; | |
111 | |
112 /* Non-zero means ignore malloc warnings. Set during initialization. */ | |
113 int ignore_warnings; | |
1318 | 114 |
115 static void mark_object (), mark_buffer (); | |
116 static void clear_marks (), gc_sweep (); | |
117 static void compact_strings (); | |
300 | 118 |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
119 /* Versions of malloc and realloc that print warnings as memory gets full. */ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
120 |
300 | 121 Lisp_Object |
122 malloc_warning_1 (str) | |
123 Lisp_Object str; | |
124 { | |
125 Fprinc (str, Vstandard_output); | |
126 write_string ("\nKilling some buffers may delay running out of memory.\n", -1); | |
127 write_string ("However, certainly by the time you receive the 95% warning,\n", -1); | |
128 write_string ("you should clean up, kill this Emacs, and start a new one.", -1); | |
129 return Qnil; | |
130 } | |
131 | |
132 /* malloc calls this if it finds we are near exhausting storage */ | |
133 malloc_warning (str) | |
134 char *str; | |
135 { | |
136 pending_malloc_warning = str; | |
137 } | |
138 | |
139 display_malloc_warning () | |
140 { | |
141 register Lisp_Object val; | |
142 | |
143 val = build_string (pending_malloc_warning); | |
144 pending_malloc_warning = 0; | |
145 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val); | |
146 } | |
147 | |
148 /* Called if malloc returns zero */ | |
149 memory_full () | |
150 { | |
151 error ("Memory exhausted"); | |
152 } | |
153 | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
154 /* like malloc routines but check for no memory and block interrupt input. */ |
300 | 155 |
156 long * | |
157 xmalloc (size) | |
158 int size; | |
159 { | |
160 register long *val; | |
161 | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
162 BLOCK_INPUT; |
300 | 163 val = (long *) malloc (size); |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
164 UNBLOCK_INPUT; |
300 | 165 |
166 if (!val && size) memory_full (); | |
167 return val; | |
168 } | |
169 | |
170 long * | |
171 xrealloc (block, size) | |
172 long *block; | |
173 int size; | |
174 { | |
175 register long *val; | |
176 | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
177 BLOCK_INPUT; |
590 | 178 /* We must call malloc explicitly when BLOCK is 0, since some |
179 reallocs don't do this. */ | |
180 if (! block) | |
181 val = (long *) malloc (size); | |
600
a8d78999e46d
*** empty log message ***
Noah Friedman <friedman@splode.com>
parents:
590
diff
changeset
|
182 else |
590 | 183 val = (long *) realloc (block, size); |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
184 UNBLOCK_INPUT; |
300 | 185 |
186 if (!val && size) memory_full (); | |
187 return val; | |
188 } | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
189 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
190 void |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
191 xfree (block) |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
192 long *block; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
193 { |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
194 BLOCK_INPUT; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
195 free (block); |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
196 UNBLOCK_INPUT; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
197 } |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
198 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
199 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
200 /* Arranging to disable input signals while we're in malloc. |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
201 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
202 This only works with GNU malloc. To help out systems which can't |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
203 use GNU malloc, all the calls to malloc, realloc, and free |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
204 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
205 pairs; unfortunately, we have no idea what C library functions |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
206 might call malloc, so we can't really protect them unless you're |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
207 using GNU malloc. Fortunately, most of the major operating can use |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
208 GNU malloc. */ |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
209 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
210 #ifndef SYSTEM_MALLOC |
2507
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
211 extern void * (*__malloc_hook) (); |
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
212 static void * (*old_malloc_hook) (); |
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
213 extern void * (*__realloc_hook) (); |
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
214 static void * (*old_realloc_hook) (); |
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
215 extern void (*__free_hook) (); |
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
216 static void (*old_free_hook) (); |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
217 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
218 static void |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
219 emacs_blocked_free (ptr) |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
220 void *ptr; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
221 { |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
222 BLOCK_INPUT; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
223 __free_hook = old_free_hook; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
224 free (ptr); |
2507
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
225 __free_hook = emacs_blocked_free; |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
226 UNBLOCK_INPUT; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
227 } |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
228 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
229 static void * |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
230 emacs_blocked_malloc (size) |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
231 unsigned size; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
232 { |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
233 void *value; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
234 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
235 BLOCK_INPUT; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
236 __malloc_hook = old_malloc_hook; |
3581
152fd924c7bb
* alloc.c (emacs_blocked_malloc, emacs_blocked_realloc): Cast the
Jim Blandy <jimb@redhat.com>
parents:
3536
diff
changeset
|
237 value = (void *) malloc (size); |
2507
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
238 __malloc_hook = emacs_blocked_malloc; |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
239 UNBLOCK_INPUT; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
240 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
241 return value; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
242 } |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
243 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
244 static void * |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
245 emacs_blocked_realloc (ptr, size) |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
246 void *ptr; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
247 unsigned size; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
248 { |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
249 void *value; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
250 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
251 BLOCK_INPUT; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
252 __realloc_hook = old_realloc_hook; |
3581
152fd924c7bb
* alloc.c (emacs_blocked_malloc, emacs_blocked_realloc): Cast the
Jim Blandy <jimb@redhat.com>
parents:
3536
diff
changeset
|
253 value = (void *) realloc (ptr, size); |
2507
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
254 __realloc_hook = emacs_blocked_realloc; |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
255 UNBLOCK_INPUT; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
256 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
257 return value; |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
258 } |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
259 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
260 void |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
261 uninterrupt_malloc () |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
262 { |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
263 old_free_hook = __free_hook; |
2507
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
264 __free_hook = emacs_blocked_free; |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
265 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
266 old_malloc_hook = __malloc_hook; |
2507
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
267 __malloc_hook = emacs_blocked_malloc; |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
268 |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
269 old_realloc_hook = __realloc_hook; |
2507
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
270 __realloc_hook = emacs_blocked_realloc; |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
271 } |
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
272 #endif |
300 | 273 |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
274 /* Interval allocation. */ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
275 |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
276 #ifdef USE_TEXT_PROPERTIES |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
277 #define INTERVAL_BLOCK_SIZE \ |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
278 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval)) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
279 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
280 struct interval_block |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
281 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
282 struct interval_block *next; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
283 struct interval intervals[INTERVAL_BLOCK_SIZE]; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
284 }; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
285 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
286 struct interval_block *interval_block; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
287 static int interval_block_index; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
288 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
289 INTERVAL interval_free_list; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
290 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
291 static void |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
292 init_intervals () |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
293 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
294 interval_block |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
295 = (struct interval_block *) malloc (sizeof (struct interval_block)); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
296 interval_block->next = 0; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
297 bzero (interval_block->intervals, sizeof interval_block->intervals); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
298 interval_block_index = 0; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
299 interval_free_list = 0; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
300 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
301 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
302 #define INIT_INTERVALS init_intervals () |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
303 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
304 INTERVAL |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
305 make_interval () |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
306 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
307 INTERVAL val; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
308 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
309 if (interval_free_list) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
310 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
311 val = interval_free_list; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
312 interval_free_list = interval_free_list->parent; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
313 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
314 else |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
315 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
316 if (interval_block_index == INTERVAL_BLOCK_SIZE) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
317 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
318 register struct interval_block *newi |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
319 = (struct interval_block *) xmalloc (sizeof (struct interval_block)); |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
320 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
321 VALIDATE_LISP_STORAGE (newi, sizeof *newi); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
322 newi->next = interval_block; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
323 interval_block = newi; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
324 interval_block_index = 0; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
325 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
326 val = &interval_block->intervals[interval_block_index++]; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
327 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
328 consing_since_gc += sizeof (struct interval); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
329 RESET_INTERVAL (val); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
330 return val; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
331 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
332 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
333 static int total_free_intervals, total_intervals; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
334 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
335 /* Mark the pointers of one interval. */ |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
336 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
337 static void |
1957
54c8c66cd9ac
(mark_interval): Add ignored arg.
Richard M. Stallman <rms@gnu.org>
parents:
1939
diff
changeset
|
338 mark_interval (i, dummy) |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
339 register INTERVAL i; |
1957
54c8c66cd9ac
(mark_interval): Add ignored arg.
Richard M. Stallman <rms@gnu.org>
parents:
1939
diff
changeset
|
340 Lisp_Object dummy; |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
341 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
342 if (XMARKBIT (i->plist)) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
343 abort (); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
344 mark_object (&i->plist); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
345 XMARK (i->plist); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
346 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
347 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
348 static void |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
349 mark_interval_tree (tree) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
350 register INTERVAL tree; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
351 { |
4139
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
352 /* No need to test if this tree has been marked already; this |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
353 function is always called through the MARK_INTERVAL_TREE macro, |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
354 which takes care of that. */ |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
355 |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
356 /* XMARK expands to an assignment; the LHS of an assignment can't be |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
357 a cast. */ |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
358 XMARK (* (Lisp_Object *) &tree->parent); |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
359 |
1957
54c8c66cd9ac
(mark_interval): Add ignored arg.
Richard M. Stallman <rms@gnu.org>
parents:
1939
diff
changeset
|
360 traverse_intervals (tree, 1, 0, mark_interval, Qnil); |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
361 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
362 |
4139
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
363 #define MARK_INTERVAL_TREE(i) \ |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
364 do { \ |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
365 if (!NULL_INTERVAL_P (i) \ |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
366 && ! XMARKBIT ((Lisp_Object) i->parent)) \ |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
367 mark_interval_tree (i); \ |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
368 } while (0) |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
369 |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
370 /* The oddity in the call to XUNMARK is necessary because XUNMARK |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3581
diff
changeset
|
371 expands to an assignment to its argument, and most C compilers don't |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
372 support casts on the left operand of `='. */ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
373 #define UNMARK_BALANCE_INTERVALS(i) \ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
374 { \ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
375 if (! NULL_INTERVAL_P (i)) \ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
376 { \ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
377 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
378 (i) = balance_intervals (i); \ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
379 } \ |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
380 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
381 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
382 #else /* no interval use */ |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
383 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
384 #define INIT_INTERVALS |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
385 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
386 #define UNMARK_BALANCE_INTERVALS(i) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
387 #define MARK_INTERVAL_TREE(i) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
388 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
389 #endif /* no interval use */ |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
390 |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
391 /* Floating point allocation. */ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
392 |
300 | 393 #ifdef LISP_FLOAT_TYPE |
394 /* Allocation of float cells, just like conses */ | |
395 /* We store float cells inside of float_blocks, allocating a new | |
396 float_block with malloc whenever necessary. Float cells reclaimed by | |
397 GC are put on a free list to be reallocated before allocating | |
398 any new float cells from the latest float_block. | |
399 | |
400 Each float_block is just under 1020 bytes long, | |
401 since malloc really allocates in units of powers of two | |
402 and uses 4 bytes for its own overhead. */ | |
403 | |
404 #define FLOAT_BLOCK_SIZE \ | |
405 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float)) | |
406 | |
407 struct float_block | |
408 { | |
409 struct float_block *next; | |
410 struct Lisp_Float floats[FLOAT_BLOCK_SIZE]; | |
411 }; | |
412 | |
413 struct float_block *float_block; | |
414 int float_block_index; | |
415 | |
416 struct Lisp_Float *float_free_list; | |
417 | |
418 void | |
419 init_float () | |
420 { | |
421 float_block = (struct float_block *) malloc (sizeof (struct float_block)); | |
422 float_block->next = 0; | |
423 bzero (float_block->floats, sizeof float_block->floats); | |
424 float_block_index = 0; | |
425 float_free_list = 0; | |
426 } | |
427 | |
428 /* Explicitly free a float cell. */ | |
429 free_float (ptr) | |
430 struct Lisp_Float *ptr; | |
431 { | |
432 XFASTINT (ptr->type) = (int) float_free_list; | |
433 float_free_list = ptr; | |
434 } | |
435 | |
436 Lisp_Object | |
437 make_float (float_value) | |
438 double float_value; | |
439 { | |
440 register Lisp_Object val; | |
441 | |
442 if (float_free_list) | |
443 { | |
444 XSET (val, Lisp_Float, float_free_list); | |
445 float_free_list = (struct Lisp_Float *) XFASTINT (float_free_list->type); | |
446 } | |
447 else | |
448 { | |
449 if (float_block_index == FLOAT_BLOCK_SIZE) | |
450 { | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
451 register struct float_block *new = (struct float_block *) xmalloc (sizeof (struct float_block)); |
300 | 452 VALIDATE_LISP_STORAGE (new, sizeof *new); |
453 new->next = float_block; | |
454 float_block = new; | |
455 float_block_index = 0; | |
456 } | |
457 XSET (val, Lisp_Float, &float_block->floats[float_block_index++]); | |
458 } | |
459 XFLOAT (val)->data = float_value; | |
460 XFLOAT (val)->type = 0; /* bug chasing -wsr */ | |
461 consing_since_gc += sizeof (struct Lisp_Float); | |
462 return val; | |
463 } | |
464 | |
465 #endif /* LISP_FLOAT_TYPE */ | |
466 | |
467 /* Allocation of cons cells */ | |
468 /* We store cons cells inside of cons_blocks, allocating a new | |
469 cons_block with malloc whenever necessary. Cons cells reclaimed by | |
470 GC are put on a free list to be reallocated before allocating | |
471 any new cons cells from the latest cons_block. | |
472 | |
473 Each cons_block is just under 1020 bytes long, | |
474 since malloc really allocates in units of powers of two | |
475 and uses 4 bytes for its own overhead. */ | |
476 | |
477 #define CONS_BLOCK_SIZE \ | |
478 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons)) | |
479 | |
480 struct cons_block | |
481 { | |
482 struct cons_block *next; | |
483 struct Lisp_Cons conses[CONS_BLOCK_SIZE]; | |
484 }; | |
485 | |
486 struct cons_block *cons_block; | |
487 int cons_block_index; | |
488 | |
489 struct Lisp_Cons *cons_free_list; | |
490 | |
491 void | |
492 init_cons () | |
493 { | |
494 cons_block = (struct cons_block *) malloc (sizeof (struct cons_block)); | |
495 cons_block->next = 0; | |
496 bzero (cons_block->conses, sizeof cons_block->conses); | |
497 cons_block_index = 0; | |
498 cons_free_list = 0; | |
499 } | |
500 | |
501 /* Explicitly free a cons cell. */ | |
502 free_cons (ptr) | |
503 struct Lisp_Cons *ptr; | |
504 { | |
505 XFASTINT (ptr->car) = (int) cons_free_list; | |
506 cons_free_list = ptr; | |
507 } | |
508 | |
509 DEFUN ("cons", Fcons, Scons, 2, 2, 0, | |
510 "Create a new cons, give it CAR and CDR as components, and return it.") | |
511 (car, cdr) | |
512 Lisp_Object car, cdr; | |
513 { | |
514 register Lisp_Object val; | |
515 | |
516 if (cons_free_list) | |
517 { | |
518 XSET (val, Lisp_Cons, cons_free_list); | |
519 cons_free_list = (struct Lisp_Cons *) XFASTINT (cons_free_list->car); | |
520 } | |
521 else | |
522 { | |
523 if (cons_block_index == CONS_BLOCK_SIZE) | |
524 { | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
525 register struct cons_block *new = (struct cons_block *) xmalloc (sizeof (struct cons_block)); |
300 | 526 VALIDATE_LISP_STORAGE (new, sizeof *new); |
527 new->next = cons_block; | |
528 cons_block = new; | |
529 cons_block_index = 0; | |
530 } | |
531 XSET (val, Lisp_Cons, &cons_block->conses[cons_block_index++]); | |
532 } | |
533 XCONS (val)->car = car; | |
534 XCONS (val)->cdr = cdr; | |
535 consing_since_gc += sizeof (struct Lisp_Cons); | |
536 return val; | |
537 } | |
538 | |
539 DEFUN ("list", Flist, Slist, 0, MANY, 0, | |
540 "Return a newly created list with specified arguments as elements.\n\ | |
541 Any number of arguments, even zero arguments, are allowed.") | |
542 (nargs, args) | |
543 int nargs; | |
544 register Lisp_Object *args; | |
545 { | |
546 register Lisp_Object len, val, val_tail; | |
547 | |
548 XFASTINT (len) = nargs; | |
549 val = Fmake_list (len, Qnil); | |
550 val_tail = val; | |
485 | 551 while (!NILP (val_tail)) |
300 | 552 { |
553 XCONS (val_tail)->car = *args++; | |
554 val_tail = XCONS (val_tail)->cdr; | |
555 } | |
556 return val; | |
557 } | |
558 | |
559 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, | |
560 "Return a newly created list of length LENGTH, with each element being INIT.") | |
561 (length, init) | |
562 register Lisp_Object length, init; | |
563 { | |
564 register Lisp_Object val; | |
565 register int size; | |
566 | |
567 if (XTYPE (length) != Lisp_Int || XINT (length) < 0) | |
568 length = wrong_type_argument (Qnatnump, length); | |
569 size = XINT (length); | |
570 | |
571 val = Qnil; | |
572 while (size-- > 0) | |
573 val = Fcons (init, val); | |
574 return val; | |
575 } | |
576 | |
577 /* Allocation of vectors */ | |
578 | |
579 struct Lisp_Vector *all_vectors; | |
580 | |
581 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, | |
582 "Return a newly created vector of length LENGTH, with each element being INIT.\n\ | |
583 See also the function `vector'.") | |
584 (length, init) | |
585 register Lisp_Object length, init; | |
586 { | |
587 register int sizei, index; | |
588 register Lisp_Object vector; | |
589 register struct Lisp_Vector *p; | |
590 | |
591 if (XTYPE (length) != Lisp_Int || XINT (length) < 0) | |
592 length = wrong_type_argument (Qnatnump, length); | |
593 sizei = XINT (length); | |
594 | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
595 p = (struct Lisp_Vector *) xmalloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object)); |
300 | 596 VALIDATE_LISP_STORAGE (p, 0); |
597 | |
598 XSET (vector, Lisp_Vector, p); | |
599 consing_since_gc += sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object); | |
600 | |
601 p->size = sizei; | |
602 p->next = all_vectors; | |
603 all_vectors = p; | |
604 | |
605 for (index = 0; index < sizei; index++) | |
606 p->contents[index] = init; | |
607 | |
608 return vector; | |
609 } | |
610 | |
611 DEFUN ("vector", Fvector, Svector, 0, MANY, 0, | |
612 "Return a newly created vector with specified arguments as elements.\n\ | |
613 Any number of arguments, even zero arguments, are allowed.") | |
614 (nargs, args) | |
615 register int nargs; | |
616 Lisp_Object *args; | |
617 { | |
618 register Lisp_Object len, val; | |
619 register int index; | |
620 register struct Lisp_Vector *p; | |
621 | |
622 XFASTINT (len) = nargs; | |
623 val = Fmake_vector (len, Qnil); | |
624 p = XVECTOR (val); | |
625 for (index = 0; index < nargs; index++) | |
626 p->contents[index] = args[index]; | |
627 return val; | |
628 } | |
629 | |
630 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, | |
631 "Create a byte-code object with specified arguments as elements.\n\ | |
632 The arguments should be the arglist, bytecode-string, constant vector,\n\ | |
633 stack size, (optional) doc string, and (optional) interactive spec.\n\ | |
634 The first four arguments are required; at most six have any\n\ | |
635 significance.") | |
636 (nargs, args) | |
637 register int nargs; | |
638 Lisp_Object *args; | |
639 { | |
640 register Lisp_Object len, val; | |
641 register int index; | |
642 register struct Lisp_Vector *p; | |
643 | |
644 XFASTINT (len) = nargs; | |
485 | 645 if (!NILP (Vpurify_flag)) |
300 | 646 val = make_pure_vector (len); |
647 else | |
648 val = Fmake_vector (len, Qnil); | |
649 p = XVECTOR (val); | |
650 for (index = 0; index < nargs; index++) | |
651 { | |
485 | 652 if (!NILP (Vpurify_flag)) |
300 | 653 args[index] = Fpurecopy (args[index]); |
654 p->contents[index] = args[index]; | |
655 } | |
656 XSETTYPE (val, Lisp_Compiled); | |
657 return val; | |
658 } | |
659 | |
660 /* Allocation of symbols. | |
661 Just like allocation of conses! | |
662 | |
663 Each symbol_block is just under 1020 bytes long, | |
664 since malloc really allocates in units of powers of two | |
665 and uses 4 bytes for its own overhead. */ | |
666 | |
667 #define SYMBOL_BLOCK_SIZE \ | |
668 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol)) | |
669 | |
670 struct symbol_block | |
671 { | |
672 struct symbol_block *next; | |
673 struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE]; | |
674 }; | |
675 | |
676 struct symbol_block *symbol_block; | |
677 int symbol_block_index; | |
678 | |
679 struct Lisp_Symbol *symbol_free_list; | |
680 | |
681 void | |
682 init_symbol () | |
683 { | |
684 symbol_block = (struct symbol_block *) malloc (sizeof (struct symbol_block)); | |
685 symbol_block->next = 0; | |
686 bzero (symbol_block->symbols, sizeof symbol_block->symbols); | |
687 symbol_block_index = 0; | |
688 symbol_free_list = 0; | |
689 } | |
690 | |
691 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, | |
692 "Return a newly allocated uninterned symbol whose name is NAME.\n\ | |
693 Its value and function definition are void, and its property list is nil.") | |
694 (str) | |
695 Lisp_Object str; | |
696 { | |
697 register Lisp_Object val; | |
698 register struct Lisp_Symbol *p; | |
699 | |
700 CHECK_STRING (str, 0); | |
701 | |
702 if (symbol_free_list) | |
703 { | |
704 XSET (val, Lisp_Symbol, symbol_free_list); | |
705 symbol_free_list | |
706 = (struct Lisp_Symbol *) XFASTINT (symbol_free_list->value); | |
707 } | |
708 else | |
709 { | |
710 if (symbol_block_index == SYMBOL_BLOCK_SIZE) | |
711 { | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
712 struct symbol_block *new = (struct symbol_block *) xmalloc (sizeof (struct symbol_block)); |
300 | 713 VALIDATE_LISP_STORAGE (new, sizeof *new); |
714 new->next = symbol_block; | |
715 symbol_block = new; | |
716 symbol_block_index = 0; | |
717 } | |
718 XSET (val, Lisp_Symbol, &symbol_block->symbols[symbol_block_index++]); | |
719 } | |
720 p = XSYMBOL (val); | |
721 p->name = XSTRING (str); | |
722 p->plist = Qnil; | |
723 p->value = Qunbound; | |
724 p->function = Qunbound; | |
725 p->next = 0; | |
726 consing_since_gc += sizeof (struct Lisp_Symbol); | |
727 return val; | |
728 } | |
729 | |
730 /* Allocation of markers. | |
731 Works like allocation of conses. */ | |
732 | |
733 #define MARKER_BLOCK_SIZE \ | |
734 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker)) | |
735 | |
736 struct marker_block | |
737 { | |
738 struct marker_block *next; | |
739 struct Lisp_Marker markers[MARKER_BLOCK_SIZE]; | |
740 }; | |
741 | |
742 struct marker_block *marker_block; | |
743 int marker_block_index; | |
744 | |
745 struct Lisp_Marker *marker_free_list; | |
746 | |
747 void | |
748 init_marker () | |
749 { | |
750 marker_block = (struct marker_block *) malloc (sizeof (struct marker_block)); | |
751 marker_block->next = 0; | |
752 bzero (marker_block->markers, sizeof marker_block->markers); | |
753 marker_block_index = 0; | |
754 marker_free_list = 0; | |
755 } | |
756 | |
757 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, | |
758 "Return a newly allocated marker which does not point at any place.") | |
759 () | |
760 { | |
761 register Lisp_Object val; | |
762 register struct Lisp_Marker *p; | |
638 | 763 |
300 | 764 if (marker_free_list) |
765 { | |
766 XSET (val, Lisp_Marker, marker_free_list); | |
767 marker_free_list | |
768 = (struct Lisp_Marker *) XFASTINT (marker_free_list->chain); | |
769 } | |
770 else | |
771 { | |
772 if (marker_block_index == MARKER_BLOCK_SIZE) | |
773 { | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
774 struct marker_block *new = (struct marker_block *) xmalloc (sizeof (struct marker_block)); |
300 | 775 VALIDATE_LISP_STORAGE (new, sizeof *new); |
776 new->next = marker_block; | |
777 marker_block = new; | |
778 marker_block_index = 0; | |
779 } | |
780 XSET (val, Lisp_Marker, &marker_block->markers[marker_block_index++]); | |
781 } | |
782 p = XMARKER (val); | |
783 p->buffer = 0; | |
784 p->bufpos = 0; | |
785 p->chain = Qnil; | |
786 consing_since_gc += sizeof (struct Lisp_Marker); | |
787 return val; | |
788 } | |
789 | |
790 /* Allocation of strings */ | |
791 | |
792 /* Strings reside inside of string_blocks. The entire data of the string, | |
793 both the size and the contents, live in part of the `chars' component of a string_block. | |
794 The `pos' component is the index within `chars' of the first free byte. | |
795 | |
796 first_string_block points to the first string_block ever allocated. | |
797 Each block points to the next one with its `next' field. | |
798 The `prev' fields chain in reverse order. | |
799 The last one allocated is the one currently being filled. | |
800 current_string_block points to it. | |
801 | |
802 The string_blocks that hold individual large strings | |
803 go in a separate chain, started by large_string_blocks. */ | |
804 | |
805 | |
806 /* String blocks contain this many useful bytes. | |
807 8188 is power of 2, minus 4 for malloc overhead. */ | |
808 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head)) | |
809 | |
810 /* A string bigger than this gets its own specially-made string block | |
811 if it doesn't fit in the current one. */ | |
812 #define STRING_BLOCK_OUTSIZE 1024 | |
813 | |
814 struct string_block_head | |
815 { | |
816 struct string_block *next, *prev; | |
817 int pos; | |
818 }; | |
819 | |
820 struct string_block | |
821 { | |
822 struct string_block *next, *prev; | |
823 int pos; | |
824 char chars[STRING_BLOCK_SIZE]; | |
825 }; | |
826 | |
827 /* This points to the string block we are now allocating strings. */ | |
828 | |
829 struct string_block *current_string_block; | |
830 | |
831 /* This points to the oldest string block, the one that starts the chain. */ | |
832 | |
833 struct string_block *first_string_block; | |
834 | |
835 /* Last string block in chain of those made for individual large strings. */ | |
836 | |
837 struct string_block *large_string_blocks; | |
838 | |
839 /* If SIZE is the length of a string, this returns how many bytes | |
840 the string occupies in a string_block (including padding). */ | |
841 | |
842 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \ | |
843 & ~(PAD - 1)) | |
844 #define PAD (sizeof (int)) | |
845 | |
846 #if 0 | |
847 #define STRING_FULLSIZE(SIZE) \ | |
848 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1)) | |
849 #endif | |
850 | |
851 void | |
852 init_strings () | |
853 { | |
854 current_string_block = (struct string_block *) malloc (sizeof (struct string_block)); | |
855 first_string_block = current_string_block; | |
856 consing_since_gc += sizeof (struct string_block); | |
857 current_string_block->next = 0; | |
858 current_string_block->prev = 0; | |
859 current_string_block->pos = 0; | |
860 large_string_blocks = 0; | |
861 } | |
862 | |
863 DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, | |
864 "Return a newly created string of length LENGTH, with each element being INIT.\n\ | |
865 Both LENGTH and INIT must be numbers.") | |
866 (length, init) | |
867 Lisp_Object length, init; | |
868 { | |
869 register Lisp_Object val; | |
870 register unsigned char *p, *end, c; | |
871 | |
872 if (XTYPE (length) != Lisp_Int || XINT (length) < 0) | |
873 length = wrong_type_argument (Qnatnump, length); | |
874 CHECK_NUMBER (init, 1); | |
875 val = make_uninit_string (XINT (length)); | |
876 c = XINT (init); | |
877 p = XSTRING (val)->data; | |
878 end = p + XSTRING (val)->size; | |
879 while (p != end) | |
880 *p++ = c; | |
881 *p = 0; | |
882 return val; | |
883 } | |
884 | |
885 Lisp_Object | |
886 make_string (contents, length) | |
887 char *contents; | |
888 int length; | |
889 { | |
890 register Lisp_Object val; | |
891 val = make_uninit_string (length); | |
892 bcopy (contents, XSTRING (val)->data, length); | |
893 return val; | |
894 } | |
895 | |
896 Lisp_Object | |
897 build_string (str) | |
898 char *str; | |
899 { | |
900 return make_string (str, strlen (str)); | |
901 } | |
902 | |
903 Lisp_Object | |
904 make_uninit_string (length) | |
905 int length; | |
906 { | |
907 register Lisp_Object val; | |
908 register int fullsize = STRING_FULLSIZE (length); | |
909 | |
910 if (length < 0) abort (); | |
911 | |
912 if (fullsize <= STRING_BLOCK_SIZE - current_string_block->pos) | |
913 /* This string can fit in the current string block */ | |
914 { | |
915 XSET (val, Lisp_String, | |
916 (struct Lisp_String *) (current_string_block->chars + current_string_block->pos)); | |
917 current_string_block->pos += fullsize; | |
918 } | |
919 else if (fullsize > STRING_BLOCK_OUTSIZE) | |
920 /* This string gets its own string block */ | |
921 { | |
922 register struct string_block *new | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
923 = (struct string_block *) xmalloc (sizeof (struct string_block_head) + fullsize); |
300 | 924 VALIDATE_LISP_STORAGE (new, 0); |
925 consing_since_gc += sizeof (struct string_block_head) + fullsize; | |
926 new->pos = fullsize; | |
927 new->next = large_string_blocks; | |
928 large_string_blocks = new; | |
929 XSET (val, Lisp_String, | |
930 (struct Lisp_String *) ((struct string_block_head *)new + 1)); | |
931 } | |
932 else | |
933 /* Make a new current string block and start it off with this string */ | |
934 { | |
935 register struct string_block *new | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
936 = (struct string_block *) xmalloc (sizeof (struct string_block)); |
300 | 937 VALIDATE_LISP_STORAGE (new, sizeof *new); |
938 consing_since_gc += sizeof (struct string_block); | |
939 current_string_block->next = new; | |
940 new->prev = current_string_block; | |
941 new->next = 0; | |
942 current_string_block = new; | |
943 new->pos = fullsize; | |
944 XSET (val, Lisp_String, | |
945 (struct Lisp_String *) current_string_block->chars); | |
946 } | |
947 | |
948 XSTRING (val)->size = length; | |
949 XSTRING (val)->data[length] = 0; | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
950 INITIALIZE_INTERVAL (XSTRING (val), NULL_INTERVAL); |
300 | 951 |
952 return val; | |
953 } | |
954 | |
955 /* Return a newly created vector or string with specified arguments as | |
2013
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
956 elements. If all the arguments are characters that can fit |
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
957 in a string of events, make a string; otherwise, make a vector. |
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
958 |
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
959 Any number of arguments, even zero arguments, are allowed. */ |
300 | 960 |
961 Lisp_Object | |
2013
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
962 make_event_array (nargs, args) |
300 | 963 register int nargs; |
964 Lisp_Object *args; | |
965 { | |
966 int i; | |
967 | |
968 for (i = 0; i < nargs; i++) | |
2013
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
969 /* The things that fit in a string |
3536
58d5ee6ec253
(make_event_array): Ignore bits above CHAR_META.
Richard M. Stallman <rms@gnu.org>
parents:
3181
diff
changeset
|
970 are characters that are in 0...127, |
58d5ee6ec253
(make_event_array): Ignore bits above CHAR_META.
Richard M. Stallman <rms@gnu.org>
parents:
3181
diff
changeset
|
971 after discarding the meta bit and all the bits above it. */ |
300 | 972 if (XTYPE (args[i]) != Lisp_Int |
3536
58d5ee6ec253
(make_event_array): Ignore bits above CHAR_META.
Richard M. Stallman <rms@gnu.org>
parents:
3181
diff
changeset
|
973 || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200) |
300 | 974 return Fvector (nargs, args); |
975 | |
976 /* Since the loop exited, we know that all the things in it are | |
977 characters, so we can make a string. */ | |
978 { | |
979 Lisp_Object result = Fmake_string (nargs, make_number (0)); | |
980 | |
981 for (i = 0; i < nargs; i++) | |
2013
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
982 { |
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
983 XSTRING (result)->data[i] = XINT (args[i]); |
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
984 /* Move the meta bit to the right place for a string char. */ |
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
985 if (XINT (args[i]) & CHAR_META) |
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
986 XSTRING (result)->data[i] |= 0x80; |
e2a164ac4088
(Fmake_rope, Frope_elt): Fns deleted.
Richard M. Stallman <rms@gnu.org>
parents:
1994
diff
changeset
|
987 } |
300 | 988 |
989 return result; | |
990 } | |
991 } | |
992 | |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
993 /* Pure storage management. */ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
994 |
300 | 995 /* Must get an error if pure storage is full, |
996 since if it cannot hold a large string | |
997 it may be able to hold conses that point to that string; | |
998 then the string is not protected from gc. */ | |
999 | |
1000 Lisp_Object | |
1001 make_pure_string (data, length) | |
1002 char *data; | |
1003 int length; | |
1004 { | |
1005 register Lisp_Object new; | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1006 register int size = sizeof (int) + INTERVAL_PTR_SIZE + length + 1; |
300 | 1007 |
1008 if (pureptr + size > PURESIZE) | |
1009 error ("Pure Lisp storage exhausted"); | |
1010 XSET (new, Lisp_String, PUREBEG + pureptr); | |
1011 XSTRING (new)->size = length; | |
1012 bcopy (data, XSTRING (new)->data, length); | |
1013 XSTRING (new)->data[length] = 0; | |
1014 pureptr += (size + sizeof (int) - 1) | |
1015 / sizeof (int) * sizeof (int); | |
1016 return new; | |
1017 } | |
1018 | |
1019 Lisp_Object | |
1020 pure_cons (car, cdr) | |
1021 Lisp_Object car, cdr; | |
1022 { | |
1023 register Lisp_Object new; | |
1024 | |
1025 if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE) | |
1026 error ("Pure Lisp storage exhausted"); | |
1027 XSET (new, Lisp_Cons, PUREBEG + pureptr); | |
1028 pureptr += sizeof (struct Lisp_Cons); | |
1029 XCONS (new)->car = Fpurecopy (car); | |
1030 XCONS (new)->cdr = Fpurecopy (cdr); | |
1031 return new; | |
1032 } | |
1033 | |
1034 #ifdef LISP_FLOAT_TYPE | |
1035 | |
1036 Lisp_Object | |
1037 make_pure_float (num) | |
1038 double num; | |
1039 { | |
1040 register Lisp_Object new; | |
1041 | |
1939
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1042 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1043 (double) boundary. Some architectures (like the sparc) require |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1044 this, and I suspect that floats are rare enough that it's no |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1045 tragedy for those that do. */ |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1046 { |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1047 int alignment; |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1048 char *p = PUREBEG + pureptr; |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1049 |
1936
82bbf90208d4
* alloc.c (make_pure_float): Align pureptr according to __alignof,
Jim Blandy <jimb@redhat.com>
parents:
1908
diff
changeset
|
1050 #ifdef __GNUC__ |
82bbf90208d4
* alloc.c (make_pure_float): Align pureptr according to __alignof,
Jim Blandy <jimb@redhat.com>
parents:
1908
diff
changeset
|
1051 #if __GNUC__ >= 2 |
1939
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1052 alignment = __alignof (struct Lisp_Float); |
1936
82bbf90208d4
* alloc.c (make_pure_float): Align pureptr according to __alignof,
Jim Blandy <jimb@redhat.com>
parents:
1908
diff
changeset
|
1053 #else |
1939
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1054 alignment = sizeof (struct Lisp_Float); |
1936
82bbf90208d4
* alloc.c (make_pure_float): Align pureptr according to __alignof,
Jim Blandy <jimb@redhat.com>
parents:
1908
diff
changeset
|
1055 #endif |
82bbf90208d4
* alloc.c (make_pure_float): Align pureptr according to __alignof,
Jim Blandy <jimb@redhat.com>
parents:
1908
diff
changeset
|
1056 #else |
1939
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1057 alignment = sizeof (struct Lisp_Float); |
1936
82bbf90208d4
* alloc.c (make_pure_float): Align pureptr according to __alignof,
Jim Blandy <jimb@redhat.com>
parents:
1908
diff
changeset
|
1058 #endif |
1939
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1059 p = (char *) (((unsigned long) p + alignment - 1) & - alignment); |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1060 pureptr = p - PUREBEG; |
def7b9c64935
* alloc.c (make_pure_float): Assure that PUREBEG + pureptr is
Jim Blandy <jimb@redhat.com>
parents:
1936
diff
changeset
|
1061 } |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
1062 |
300 | 1063 if (pureptr + sizeof (struct Lisp_Float) > PURESIZE) |
1064 error ("Pure Lisp storage exhausted"); | |
1065 XSET (new, Lisp_Float, PUREBEG + pureptr); | |
1066 pureptr += sizeof (struct Lisp_Float); | |
1067 XFLOAT (new)->data = num; | |
1068 XFLOAT (new)->type = 0; /* bug chasing -wsr */ | |
1069 return new; | |
1070 } | |
1071 | |
1072 #endif /* LISP_FLOAT_TYPE */ | |
1073 | |
1074 Lisp_Object | |
1075 make_pure_vector (len) | |
1076 int len; | |
1077 { | |
1078 register Lisp_Object new; | |
1079 register int size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object); | |
1080 | |
1081 if (pureptr + size > PURESIZE) | |
1082 error ("Pure Lisp storage exhausted"); | |
1083 | |
1084 XSET (new, Lisp_Vector, PUREBEG + pureptr); | |
1085 pureptr += size; | |
1086 XVECTOR (new)->size = len; | |
1087 return new; | |
1088 } | |
1089 | |
1090 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, | |
1091 "Make a copy of OBJECT in pure storage.\n\ | |
1092 Recursively copies contents of vectors and cons cells.\n\ | |
1093 Does not copy symbols.") | |
1094 (obj) | |
1095 register Lisp_Object obj; | |
1096 { | |
1097 register Lisp_Object new, tem; | |
1098 register int i; | |
1099 | |
485 | 1100 if (NILP (Vpurify_flag)) |
300 | 1101 return obj; |
1102 | |
1103 if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE) | |
1104 && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure) | |
1105 return obj; | |
1106 | |
1107 #ifdef SWITCH_ENUM_BUG | |
1108 switch ((int) XTYPE (obj)) | |
1109 #else | |
1110 switch (XTYPE (obj)) | |
1111 #endif | |
1112 { | |
1113 case Lisp_Marker: | |
1114 error ("Attempt to copy a marker to pure storage"); | |
1115 | |
1116 case Lisp_Cons: | |
1117 return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr); | |
1118 | |
1119 #ifdef LISP_FLOAT_TYPE | |
1120 case Lisp_Float: | |
1121 return make_pure_float (XFLOAT (obj)->data); | |
1122 #endif /* LISP_FLOAT_TYPE */ | |
1123 | |
1124 case Lisp_String: | |
1125 return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size); | |
1126 | |
1127 case Lisp_Compiled: | |
1128 case Lisp_Vector: | |
1129 new = make_pure_vector (XVECTOR (obj)->size); | |
1130 for (i = 0; i < XVECTOR (obj)->size; i++) | |
1131 { | |
1132 tem = XVECTOR (obj)->contents[i]; | |
1133 XVECTOR (new)->contents[i] = Fpurecopy (tem); | |
1134 } | |
1135 XSETTYPE (new, XTYPE (obj)); | |
1136 return new; | |
1137 | |
1138 default: | |
1139 return obj; | |
1140 } | |
1141 } | |
1142 | |
1143 /* Recording what needs to be marked for gc. */ | |
1144 | |
1145 struct gcpro *gcprolist; | |
1146 | |
727 | 1147 #define NSTATICS 512 |
300 | 1148 |
1149 Lisp_Object *staticvec[NSTATICS] = {0}; | |
1150 | |
1151 int staticidx = 0; | |
1152 | |
1153 /* Put an entry in staticvec, pointing at the variable whose address is given */ | |
1154 | |
1155 void | |
1156 staticpro (varaddress) | |
1157 Lisp_Object *varaddress; | |
1158 { | |
1159 staticvec[staticidx++] = varaddress; | |
1160 if (staticidx >= NSTATICS) | |
1161 abort (); | |
1162 } | |
1163 | |
1164 struct catchtag | |
1165 { | |
1166 Lisp_Object tag; | |
1167 Lisp_Object val; | |
1168 struct catchtag *next; | |
1169 /* jmp_buf jmp; /* We don't need this for GC purposes */ | |
1170 }; | |
1171 | |
1172 struct backtrace | |
1173 { | |
1174 struct backtrace *next; | |
1175 Lisp_Object *function; | |
1176 Lisp_Object *args; /* Points to vector of args. */ | |
1177 int nargs; /* length of vector */ | |
1178 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */ | |
1179 char evalargs; | |
1180 }; | |
1181 | |
1182 /* Two flags that are set during GC in the `size' component | |
1183 of a string or vector. On some machines, these flags | |
1184 are defined by the m- file to be different bits. */ | |
1185 | |
1186 /* On vector, means it has been marked. | |
1187 On string size field or a reference to a string, | |
1188 means not the last reference in the chain. */ | |
1189 | |
1190 #ifndef ARRAY_MARK_FLAG | |
1191 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT) | |
1192 #endif /* no ARRAY_MARK_FLAG */ | |
1193 | |
1194 /* Any slot that is a Lisp_Object can point to a string | |
1195 and thus can be put on a string's reference-chain | |
1196 and thus may need to have its ARRAY_MARK_FLAG set. | |
1197 This includes the slots whose markbits are used to mark | |
1198 the containing objects. */ | |
1199 | |
1200 #if ARRAY_MARK_FLAG == MARKBIT | |
1201 you lose | |
1202 #endif | |
1203 | |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
1204 /* Garbage collection! */ |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
1205 |
300 | 1206 int total_conses, total_markers, total_symbols, total_string_size, total_vector_size; |
1207 int total_free_conses, total_free_markers, total_free_symbols; | |
1208 #ifdef LISP_FLOAT_TYPE | |
1209 int total_free_floats, total_floats; | |
1210 #endif /* LISP_FLOAT_TYPE */ | |
1211 | |
1212 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", | |
1213 "Reclaim storage for Lisp objects no longer needed.\n\ | |
1214 Returns info on amount of space in use:\n\ | |
1215 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\ | |
1216 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\ | |
1217 (USED-FLOATS . FREE-FLOATS))\n\ | |
1218 Garbage collection happens automatically if you cons more than\n\ | |
1219 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.") | |
1220 () | |
1221 { | |
1222 register struct gcpro *tail; | |
1223 register struct specbinding *bind; | |
1224 struct catchtag *catch; | |
1225 struct handler *handler; | |
1226 register struct backtrace *backlist; | |
1227 register Lisp_Object tem; | |
1228 char *omessage = echo_area_glyphs; | |
1229 char stack_top_variable; | |
1230 register int i; | |
1231 | |
1232 /* Save a copy of the contents of the stack, for debugging. */ | |
1233 #if MAX_SAVE_STACK > 0 | |
485 | 1234 if (NILP (Vpurify_flag)) |
300 | 1235 { |
1236 i = &stack_top_variable - stack_bottom; | |
1237 if (i < 0) i = -i; | |
1238 if (i < MAX_SAVE_STACK) | |
1239 { | |
1240 if (stack_copy == 0) | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
1241 stack_copy = (char *) xmalloc (stack_copy_size = i); |
300 | 1242 else if (stack_copy_size < i) |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
1243 stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i)); |
300 | 1244 if (stack_copy) |
1245 { | |
1246 if ((int) (&stack_top_variable - stack_bottom) > 0) | |
1247 bcopy (stack_bottom, stack_copy, i); | |
1248 else | |
1249 bcopy (&stack_top_variable, stack_copy, i); | |
1250 } | |
1251 } | |
1252 } | |
1253 #endif /* MAX_SAVE_STACK > 0 */ | |
1254 | |
1255 if (!noninteractive) | |
1256 message1 ("Garbage collecting..."); | |
1257 | |
1258 /* Don't keep command history around forever */ | |
1259 tem = Fnthcdr (make_number (30), Vcommand_history); | |
1260 if (CONSP (tem)) | |
1261 XCONS (tem)->cdr = Qnil; | |
648 | 1262 |
300 | 1263 /* Likewise for undo information. */ |
1264 { | |
1265 register struct buffer *nextb = all_buffers; | |
1266 | |
1267 while (nextb) | |
1268 { | |
648 | 1269 /* If a buffer's undo list is Qt, that means that undo is |
1270 turned off in that buffer. Calling truncate_undo_list on | |
1271 Qt tends to return NULL, which effectively turns undo back on. | |
1272 So don't call truncate_undo_list if undo_list is Qt. */ | |
1273 if (! EQ (nextb->undo_list, Qt)) | |
1274 nextb->undo_list | |
764 | 1275 = truncate_undo_list (nextb->undo_list, undo_limit, |
1276 undo_strong_limit); | |
300 | 1277 nextb = nextb->next; |
1278 } | |
1279 } | |
1280 | |
1281 gc_in_progress = 1; | |
1282 | |
1283 /* clear_marks (); */ | |
1284 | |
1285 /* In each "large string", set the MARKBIT of the size field. | |
1286 That enables mark_object to recognize them. */ | |
1287 { | |
1288 register struct string_block *b; | |
1289 for (b = large_string_blocks; b; b = b->next) | |
1290 ((struct Lisp_String *)(&b->chars[0]))->size |= MARKBIT; | |
1291 } | |
1292 | |
1293 /* Mark all the special slots that serve as the roots of accessibility. | |
1294 | |
1295 Usually the special slots to mark are contained in particular structures. | |
1296 Then we know no slot is marked twice because the structures don't overlap. | |
1297 In some cases, the structures point to the slots to be marked. | |
1298 For these, we use MARKBIT to avoid double marking of the slot. */ | |
1299 | |
1300 for (i = 0; i < staticidx; i++) | |
1301 mark_object (staticvec[i]); | |
1302 for (tail = gcprolist; tail; tail = tail->next) | |
1303 for (i = 0; i < tail->nvars; i++) | |
1304 if (!XMARKBIT (tail->var[i])) | |
1305 { | |
1306 mark_object (&tail->var[i]); | |
1307 XMARK (tail->var[i]); | |
1308 } | |
1309 for (bind = specpdl; bind != specpdl_ptr; bind++) | |
1310 { | |
1311 mark_object (&bind->symbol); | |
1312 mark_object (&bind->old_value); | |
1313 } | |
1314 for (catch = catchlist; catch; catch = catch->next) | |
1315 { | |
1316 mark_object (&catch->tag); | |
1317 mark_object (&catch->val); | |
1318 } | |
1319 for (handler = handlerlist; handler; handler = handler->next) | |
1320 { | |
1321 mark_object (&handler->handler); | |
1322 mark_object (&handler->var); | |
1323 } | |
1324 for (backlist = backtrace_list; backlist; backlist = backlist->next) | |
1325 { | |
1326 if (!XMARKBIT (*backlist->function)) | |
1327 { | |
1328 mark_object (backlist->function); | |
1329 XMARK (*backlist->function); | |
1330 } | |
1331 if (backlist->nargs == UNEVALLED || backlist->nargs == MANY) | |
1332 i = 0; | |
1333 else | |
1334 i = backlist->nargs - 1; | |
1335 for (; i >= 0; i--) | |
1336 if (!XMARKBIT (backlist->args[i])) | |
1337 { | |
1338 mark_object (&backlist->args[i]); | |
1339 XMARK (backlist->args[i]); | |
1340 } | |
1341 } | |
1342 | |
1343 gc_sweep (); | |
1344 | |
1345 /* Clear the mark bits that we set in certain root slots. */ | |
1346 | |
1347 for (tail = gcprolist; tail; tail = tail->next) | |
1348 for (i = 0; i < tail->nvars; i++) | |
1349 XUNMARK (tail->var[i]); | |
1350 for (backlist = backtrace_list; backlist; backlist = backlist->next) | |
1351 { | |
1352 XUNMARK (*backlist->function); | |
1353 if (backlist->nargs == UNEVALLED || backlist->nargs == MANY) | |
1354 i = 0; | |
1355 else | |
1356 i = backlist->nargs - 1; | |
1357 for (; i >= 0; i--) | |
1358 XUNMARK (backlist->args[i]); | |
1359 } | |
1360 XUNMARK (buffer_defaults.name); | |
1361 XUNMARK (buffer_local_symbols.name); | |
1362 | |
1363 /* clear_marks (); */ | |
1364 gc_in_progress = 0; | |
1365 | |
1366 consing_since_gc = 0; | |
1367 if (gc_cons_threshold < 10000) | |
1368 gc_cons_threshold = 10000; | |
1369 | |
3851
dbdcbcbe910a
* alloc.c (Fgarbage_collect): If the minibuffer is active, don't
Jim Blandy <jimb@redhat.com>
parents:
3591
diff
changeset
|
1370 if (omessage || minibuf_level > 0) |
300 | 1371 message1 (omessage); |
1372 else if (!noninteractive) | |
1373 message1 ("Garbage collecting...done"); | |
1374 | |
1375 return Fcons (Fcons (make_number (total_conses), | |
1376 make_number (total_free_conses)), | |
1377 Fcons (Fcons (make_number (total_symbols), | |
1378 make_number (total_free_symbols)), | |
1379 Fcons (Fcons (make_number (total_markers), | |
1380 make_number (total_free_markers)), | |
1381 Fcons (make_number (total_string_size), | |
1382 Fcons (make_number (total_vector_size), | |
1383 | |
1384 #ifdef LISP_FLOAT_TYPE | |
1385 Fcons (Fcons (make_number (total_floats), | |
1386 make_number (total_free_floats)), | |
1387 Qnil) | |
1388 #else /* not LISP_FLOAT_TYPE */ | |
1389 Qnil | |
1390 #endif /* not LISP_FLOAT_TYPE */ | |
1391 ))))); | |
1392 } | |
1393 | |
1394 #if 0 | |
1395 static void | |
1396 clear_marks () | |
1397 { | |
1398 /* Clear marks on all conses */ | |
1399 { | |
1400 register struct cons_block *cblk; | |
1401 register int lim = cons_block_index; | |
1402 | |
1403 for (cblk = cons_block; cblk; cblk = cblk->next) | |
1404 { | |
1405 register int i; | |
1406 for (i = 0; i < lim; i++) | |
1407 XUNMARK (cblk->conses[i].car); | |
1408 lim = CONS_BLOCK_SIZE; | |
1409 } | |
1410 } | |
1411 /* Clear marks on all symbols */ | |
1412 { | |
1413 register struct symbol_block *sblk; | |
1414 register int lim = symbol_block_index; | |
1415 | |
1416 for (sblk = symbol_block; sblk; sblk = sblk->next) | |
1417 { | |
1418 register int i; | |
1419 for (i = 0; i < lim; i++) | |
1420 { | |
1421 XUNMARK (sblk->symbols[i].plist); | |
1422 } | |
1423 lim = SYMBOL_BLOCK_SIZE; | |
1424 } | |
1425 } | |
1426 /* Clear marks on all markers */ | |
1427 { | |
1428 register struct marker_block *sblk; | |
1429 register int lim = marker_block_index; | |
1430 | |
1431 for (sblk = marker_block; sblk; sblk = sblk->next) | |
1432 { | |
1433 register int i; | |
1434 for (i = 0; i < lim; i++) | |
1435 XUNMARK (sblk->markers[i].chain); | |
1436 lim = MARKER_BLOCK_SIZE; | |
1437 } | |
1438 } | |
1439 /* Clear mark bits on all buffers */ | |
1440 { | |
1441 register struct buffer *nextb = all_buffers; | |
1442 | |
1443 while (nextb) | |
1444 { | |
1445 XUNMARK (nextb->name); | |
1446 nextb = nextb->next; | |
1447 } | |
1448 } | |
1449 } | |
1450 #endif | |
1451 | |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
1452 /* Mark reference to a Lisp_Object. |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
1453 If the object referred to has not been seen yet, recursively mark |
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
1454 all the references contained in it. |
300 | 1455 |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3581
diff
changeset
|
1456 If the object referenced is a short string, the referencing slot |
300 | 1457 is threaded into a chain of such slots, pointed to from |
1458 the `size' field of the string. The actual string size | |
1459 lives in the last slot in the chain. We recognize the end | |
1460 because it is < (unsigned) STRING_BLOCK_SIZE. */ | |
1461 | |
1168
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1462 #define LAST_MARKED_SIZE 500 |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1463 Lisp_Object *last_marked[LAST_MARKED_SIZE]; |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1464 int last_marked_index; |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1465 |
300 | 1466 static void |
1467 mark_object (objptr) | |
1468 Lisp_Object *objptr; | |
1469 { | |
1470 register Lisp_Object obj; | |
1471 | |
4087
bdecedbd64db
(mark_object) [DEBUG_MOLE]: Add abort at beginning.
Richard M. Stallman <rms@gnu.org>
parents:
3918
diff
changeset
|
1472 #ifdef DEBUG_MOLE |
bdecedbd64db
(mark_object) [DEBUG_MOLE]: Add abort at beginning.
Richard M. Stallman <rms@gnu.org>
parents:
3918
diff
changeset
|
1473 if (*(int *) ((char *)__builtin_frame_address (0) - 16) == 0) |
bdecedbd64db
(mark_object) [DEBUG_MOLE]: Add abort at beginning.
Richard M. Stallman <rms@gnu.org>
parents:
3918
diff
changeset
|
1474 abort (); |
bdecedbd64db
(mark_object) [DEBUG_MOLE]: Add abort at beginning.
Richard M. Stallman <rms@gnu.org>
parents:
3918
diff
changeset
|
1475 #endif |
bdecedbd64db
(mark_object) [DEBUG_MOLE]: Add abort at beginning.
Richard M. Stallman <rms@gnu.org>
parents:
3918
diff
changeset
|
1476 |
300 | 1477 obj = *objptr; |
1478 XUNMARK (obj); | |
1479 | |
1480 loop: | |
1481 | |
1482 if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE) | |
1483 && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure) | |
1484 return; | |
1485 | |
1168
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1486 last_marked[last_marked_index++] = objptr; |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1487 if (last_marked_index == LAST_MARKED_SIZE) |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1488 last_marked_index = 0; |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1489 |
300 | 1490 #ifdef SWITCH_ENUM_BUG |
1491 switch ((int) XGCTYPE (obj)) | |
1492 #else | |
1493 switch (XGCTYPE (obj)) | |
1494 #endif | |
1495 { | |
1496 case Lisp_String: | |
1497 { | |
1498 register struct Lisp_String *ptr = XSTRING (obj); | |
1499 | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1500 MARK_INTERVAL_TREE (ptr->intervals); |
300 | 1501 if (ptr->size & MARKBIT) |
1502 /* A large string. Just set ARRAY_MARK_FLAG. */ | |
1503 ptr->size |= ARRAY_MARK_FLAG; | |
1504 else | |
1505 { | |
1506 /* A small string. Put this reference | |
1507 into the chain of references to it. | |
1508 The address OBJPTR is even, so if the address | |
1509 includes MARKBIT, put it in the low bit | |
1510 when we store OBJPTR into the size field. */ | |
1511 | |
1512 if (XMARKBIT (*objptr)) | |
1513 { | |
1514 XFASTINT (*objptr) = ptr->size; | |
1515 XMARK (*objptr); | |
1516 } | |
1517 else | |
1518 XFASTINT (*objptr) = ptr->size; | |
1519 if ((int)objptr & 1) abort (); | |
1520 ptr->size = (int) objptr & ~MARKBIT; | |
1521 if ((int) objptr & MARKBIT) | |
1522 ptr->size ++; | |
1523 } | |
1524 } | |
1525 break; | |
1526 | |
1527 case Lisp_Vector: | |
1528 case Lisp_Window: | |
1529 case Lisp_Process: | |
1530 case Lisp_Window_Configuration: | |
1531 { | |
1532 register struct Lisp_Vector *ptr = XVECTOR (obj); | |
1533 register int size = ptr->size; | |
1168
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1534 struct Lisp_Vector *volatile ptr1 = ptr; |
300 | 1535 register int i; |
1536 | |
1537 if (size & ARRAY_MARK_FLAG) break; /* Already marked */ | |
1538 ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ | |
1539 for (i = 0; i < size; i++) /* and then mark its elements */ | |
1168
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1540 { |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1541 if (ptr != ptr1) |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1542 abort (); |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1543 mark_object (&ptr->contents[i]); |
2b07af77d7ec
(mark_object): Save last 500 values of objptr.
Richard M. Stallman <rms@gnu.org>
parents:
1114
diff
changeset
|
1544 } |
300 | 1545 } |
1546 break; | |
1547 | |
1295
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1548 case Lisp_Compiled: |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1549 /* We could treat this just like a vector, but it is better |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1550 to save the COMPILED_CONSTANTS element for last and avoid recursion |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1551 there. */ |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1552 { |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1553 register struct Lisp_Vector *ptr = XVECTOR (obj); |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1554 register int size = ptr->size; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1555 struct Lisp_Vector *volatile ptr1 = ptr; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1556 register int i; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1557 |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1558 if (size & ARRAY_MARK_FLAG) break; /* Already marked */ |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1559 ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1560 for (i = 0; i < size; i++) /* and then mark its elements */ |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1561 { |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1562 if (ptr != ptr1) |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1563 abort (); |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1564 if (i != COMPILED_CONSTANTS) |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1565 mark_object (&ptr->contents[i]); |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1566 } |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1567 objptr = &ptr->contents[COMPILED_CONSTANTS]; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1568 obj = *objptr; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1569 goto loop; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1570 } |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1571 |
764 | 1572 #ifdef MULTI_FRAME |
1573 case Lisp_Frame: | |
300 | 1574 { |
764 | 1575 register struct frame *ptr = XFRAME (obj); |
300 | 1576 register int size = ptr->size; |
1577 | |
1578 if (size & ARRAY_MARK_FLAG) break; /* Already marked */ | |
1579 ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ | |
1580 | |
1581 mark_object (&ptr->name); | |
764 | 1582 mark_object (&ptr->focus_frame); |
300 | 1583 mark_object (&ptr->width); |
1584 mark_object (&ptr->height); | |
1585 mark_object (&ptr->selected_window); | |
1586 mark_object (&ptr->minibuffer_window); | |
1587 mark_object (&ptr->param_alist); | |
1994
73ce9dd21093
Use the term `scroll bar', instead of `scrollbar'.
Jim Blandy <jimb@redhat.com>
parents:
1957
diff
changeset
|
1588 mark_object (&ptr->scroll_bars); |
73ce9dd21093
Use the term `scroll bar', instead of `scrollbar'.
Jim Blandy <jimb@redhat.com>
parents:
1957
diff
changeset
|
1589 mark_object (&ptr->condemned_scroll_bars); |
2151
6775c932a51b
(mark_object): Mark the menu_bar_items field.
Richard M. Stallman <rms@gnu.org>
parents:
2013
diff
changeset
|
1590 mark_object (&ptr->menu_bar_items); |
2370
4817a2197ac2
(mark_object): Mark face_alist of a frame.
Richard M. Stallman <rms@gnu.org>
parents:
2152
diff
changeset
|
1591 mark_object (&ptr->face_alist); |
300 | 1592 } |
1593 break; | |
2152 | 1594 #endif /* MULTI_FRAME */ |
300 | 1595 |
1596 case Lisp_Symbol: | |
1597 { | |
1598 register struct Lisp_Symbol *ptr = XSYMBOL (obj); | |
1599 struct Lisp_Symbol *ptrx; | |
1600 | |
1601 if (XMARKBIT (ptr->plist)) break; | |
1602 XMARK (ptr->plist); | |
1603 mark_object ((Lisp_Object *) &ptr->value); | |
3918
41c85710702d
(mark_object): Add aborts in Lisp_Symbol case.
Richard M. Stallman <rms@gnu.org>
parents:
3851
diff
changeset
|
1604 if ((unsigned int) ptr <= 4) |
41c85710702d
(mark_object): Add aborts in Lisp_Symbol case.
Richard M. Stallman <rms@gnu.org>
parents:
3851
diff
changeset
|
1605 abort (); |
300 | 1606 mark_object (&ptr->function); |
3918
41c85710702d
(mark_object): Add aborts in Lisp_Symbol case.
Richard M. Stallman <rms@gnu.org>
parents:
3851
diff
changeset
|
1607 if ((unsigned int) ptr <= 4) |
41c85710702d
(mark_object): Add aborts in Lisp_Symbol case.
Richard M. Stallman <rms@gnu.org>
parents:
3851
diff
changeset
|
1608 abort (); |
300 | 1609 mark_object (&ptr->plist); |
3918
41c85710702d
(mark_object): Add aborts in Lisp_Symbol case.
Richard M. Stallman <rms@gnu.org>
parents:
3851
diff
changeset
|
1610 if ((unsigned int) ptr <= 4) |
41c85710702d
(mark_object): Add aborts in Lisp_Symbol case.
Richard M. Stallman <rms@gnu.org>
parents:
3851
diff
changeset
|
1611 abort (); |
1114
903883eed4de
* alloc.c (mark_object): mark a symbol's name after marking its
Jim Blandy <jimb@redhat.com>
parents:
1000
diff
changeset
|
1612 XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String); |
903883eed4de
* alloc.c (mark_object): mark a symbol's name after marking its
Jim Blandy <jimb@redhat.com>
parents:
1000
diff
changeset
|
1613 mark_object (&ptr->name); |
3918
41c85710702d
(mark_object): Add aborts in Lisp_Symbol case.
Richard M. Stallman <rms@gnu.org>
parents:
3851
diff
changeset
|
1614 if ((unsigned int) ptr <= 4) |
41c85710702d
(mark_object): Add aborts in Lisp_Symbol case.
Richard M. Stallman <rms@gnu.org>
parents:
3851
diff
changeset
|
1615 abort (); |
300 | 1616 ptr = ptr->next; |
1617 if (ptr) | |
1618 { | |
2507
7ba4316ae840
* alloc.c (__malloc_hook, __realloc_hook, __free_hook): Declare
Jim Blandy <jimb@redhat.com>
parents:
2439
diff
changeset
|
1619 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */ |
300 | 1620 XSETSYMBOL (obj, ptrx); |
1621 goto loop; | |
1622 } | |
1623 } | |
1624 break; | |
1625 | |
1626 case Lisp_Marker: | |
1627 XMARK (XMARKER (obj)->chain); | |
1628 /* DO NOT mark thru the marker's chain. | |
1629 The buffer's markers chain does not preserve markers from gc; | |
1295
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1630 instead, markers are removed from the chain when freed by gc. */ |
300 | 1631 break; |
1632 | |
1633 case Lisp_Cons: | |
1634 case Lisp_Buffer_Local_Value: | |
1635 case Lisp_Some_Buffer_Local_Value: | |
2782
683f4472f1c8
* lisp.h (Lisp_Overlay): New tag.
Jim Blandy <jimb@redhat.com>
parents:
2507
diff
changeset
|
1636 case Lisp_Overlay: |
300 | 1637 { |
1638 register struct Lisp_Cons *ptr = XCONS (obj); | |
1639 if (XMARKBIT (ptr->car)) break; | |
1640 XMARK (ptr->car); | |
1295
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1641 /* If the cdr is nil, avoid recursion for the car. */ |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1642 if (EQ (ptr->cdr, Qnil)) |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1643 { |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1644 objptr = &ptr->car; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1645 obj = ptr->car; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1646 XUNMARK (obj); |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1647 goto loop; |
a9241dc503ab
(mark_object): Avoid car recursion on cons with nil in cdr.
Richard M. Stallman <rms@gnu.org>
parents:
1168
diff
changeset
|
1648 } |
3181
b2e5c888f5f6
(mark_object): Add debugging code to check for ptr clobbered.
Richard M. Stallman <rms@gnu.org>
parents:
3003
diff
changeset
|
1649 if (ptr == 0) |
b2e5c888f5f6
(mark_object): Add debugging code to check for ptr clobbered.
Richard M. Stallman <rms@gnu.org>
parents:
3003
diff
changeset
|
1650 abort (); |
300 | 1651 mark_object (&ptr->car); |
3181
b2e5c888f5f6
(mark_object): Add debugging code to check for ptr clobbered.
Richard M. Stallman <rms@gnu.org>
parents:
3003
diff
changeset
|
1652 if (ptr == 0) |
b2e5c888f5f6
(mark_object): Add debugging code to check for ptr clobbered.
Richard M. Stallman <rms@gnu.org>
parents:
3003
diff
changeset
|
1653 abort (); |
300 | 1654 objptr = &ptr->cdr; |
1655 obj = ptr->cdr; | |
1656 goto loop; | |
1657 } | |
1658 | |
1659 #ifdef LISP_FLOAT_TYPE | |
1660 case Lisp_Float: | |
1661 XMARK (XFLOAT (obj)->type); | |
1662 break; | |
1663 #endif /* LISP_FLOAT_TYPE */ | |
1664 | |
1665 case Lisp_Buffer: | |
1666 if (!XMARKBIT (XBUFFER (obj)->name)) | |
1667 mark_buffer (obj); | |
1668 break; | |
1669 | |
1670 case Lisp_Int: | |
1671 case Lisp_Void: | |
1672 case Lisp_Subr: | |
1673 case Lisp_Intfwd: | |
1674 case Lisp_Boolfwd: | |
1675 case Lisp_Objfwd: | |
1676 case Lisp_Buffer_Objfwd: | |
1677 case Lisp_Internal_Stream: | |
1678 /* Don't bother with Lisp_Buffer_Objfwd, | |
1679 since all markable slots in current buffer marked anyway. */ | |
1680 /* Don't need to do Lisp_Objfwd, since the places they point | |
1681 are protected with staticpro. */ | |
1682 break; | |
1683 | |
1684 default: | |
1685 abort (); | |
1686 } | |
1687 } | |
1688 | |
1689 /* Mark the pointers in a buffer structure. */ | |
1690 | |
1691 static void | |
1692 mark_buffer (buf) | |
1693 Lisp_Object buf; | |
1694 { | |
1695 register struct buffer *buffer = XBUFFER (buf); | |
1696 register Lisp_Object *ptr; | |
1697 | |
1698 /* This is the buffer's markbit */ | |
1699 mark_object (&buffer->name); | |
1700 XMARK (buffer->name); | |
1701 | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1702 MARK_INTERVAL_TREE (buffer->intervals); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1703 |
300 | 1704 #if 0 |
1705 mark_object (buffer->syntax_table); | |
1706 | |
1707 /* Mark the various string-pointers in the buffer object. | |
1708 Since the strings may be relocated, we must mark them | |
1709 in their actual slots. So gc_sweep must convert each slot | |
1710 back to an ordinary C pointer. */ | |
1711 XSET (*(Lisp_Object *)&buffer->upcase_table, | |
1712 Lisp_String, buffer->upcase_table); | |
1713 mark_object ((Lisp_Object *)&buffer->upcase_table); | |
1714 XSET (*(Lisp_Object *)&buffer->downcase_table, | |
1715 Lisp_String, buffer->downcase_table); | |
1716 mark_object ((Lisp_Object *)&buffer->downcase_table); | |
1717 | |
1718 XSET (*(Lisp_Object *)&buffer->sort_table, | |
1719 Lisp_String, buffer->sort_table); | |
1720 mark_object ((Lisp_Object *)&buffer->sort_table); | |
1721 XSET (*(Lisp_Object *)&buffer->folding_sort_table, | |
1722 Lisp_String, buffer->folding_sort_table); | |
1723 mark_object ((Lisp_Object *)&buffer->folding_sort_table); | |
1724 #endif | |
1725 | |
1726 for (ptr = &buffer->name + 1; | |
1727 (char *)ptr < (char *)buffer + sizeof (struct buffer); | |
1728 ptr++) | |
1729 mark_object (ptr); | |
1730 } | |
1731 | |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
1732 /* Sweep: find all structures not marked, and free them. */ |
300 | 1733 |
1734 static void | |
1735 gc_sweep () | |
1736 { | |
1737 total_string_size = 0; | |
1738 compact_strings (); | |
1739 | |
1740 /* Put all unmarked conses on free list */ | |
1741 { | |
1742 register struct cons_block *cblk; | |
1743 register int lim = cons_block_index; | |
1744 register int num_free = 0, num_used = 0; | |
1745 | |
1746 cons_free_list = 0; | |
1747 | |
1748 for (cblk = cons_block; cblk; cblk = cblk->next) | |
1749 { | |
1750 register int i; | |
1751 for (i = 0; i < lim; i++) | |
1752 if (!XMARKBIT (cblk->conses[i].car)) | |
1753 { | |
1754 XFASTINT (cblk->conses[i].car) = (int) cons_free_list; | |
1755 num_free++; | |
1756 cons_free_list = &cblk->conses[i]; | |
1757 } | |
1758 else | |
1759 { | |
1760 num_used++; | |
1761 XUNMARK (cblk->conses[i].car); | |
1762 } | |
1763 lim = CONS_BLOCK_SIZE; | |
1764 } | |
1765 total_conses = num_used; | |
1766 total_free_conses = num_free; | |
1767 } | |
1768 | |
1769 #ifdef LISP_FLOAT_TYPE | |
1770 /* Put all unmarked floats on free list */ | |
1771 { | |
1772 register struct float_block *fblk; | |
1773 register int lim = float_block_index; | |
1774 register int num_free = 0, num_used = 0; | |
1775 | |
1776 float_free_list = 0; | |
1777 | |
1778 for (fblk = float_block; fblk; fblk = fblk->next) | |
1779 { | |
1780 register int i; | |
1781 for (i = 0; i < lim; i++) | |
1782 if (!XMARKBIT (fblk->floats[i].type)) | |
1783 { | |
1784 XFASTINT (fblk->floats[i].type) = (int) float_free_list; | |
1785 num_free++; | |
1786 float_free_list = &fblk->floats[i]; | |
1787 } | |
1788 else | |
1789 { | |
1790 num_used++; | |
1791 XUNMARK (fblk->floats[i].type); | |
1792 } | |
1793 lim = FLOAT_BLOCK_SIZE; | |
1794 } | |
1795 total_floats = num_used; | |
1796 total_free_floats = num_free; | |
1797 } | |
1798 #endif /* LISP_FLOAT_TYPE */ | |
1799 | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1800 #ifdef USE_TEXT_PROPERTIES |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1801 /* Put all unmarked intervals on free list */ |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1802 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1803 register struct interval_block *iblk; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1804 register int lim = interval_block_index; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1805 register int num_free = 0, num_used = 0; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1806 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1807 interval_free_list = 0; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1808 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1809 for (iblk = interval_block; iblk; iblk = iblk->next) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1810 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1811 register int i; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1812 |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1813 for (i = 0; i < lim; i++) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1814 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1815 if (! XMARKBIT (iblk->intervals[i].plist)) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1816 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1817 iblk->intervals[i].parent = interval_free_list; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1818 interval_free_list = &iblk->intervals[i]; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1819 num_free++; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1820 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1821 else |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1822 { |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1823 num_used++; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1824 XUNMARK (iblk->intervals[i].plist); |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1825 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1826 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1827 lim = INTERVAL_BLOCK_SIZE; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1828 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1829 total_intervals = num_used; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1830 total_free_intervals = num_free; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1831 } |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1832 #endif /* USE_TEXT_PROPERTIES */ |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1833 |
300 | 1834 /* Put all unmarked symbols on free list */ |
1835 { | |
1836 register struct symbol_block *sblk; | |
1837 register int lim = symbol_block_index; | |
1838 register int num_free = 0, num_used = 0; | |
1839 | |
1840 symbol_free_list = 0; | |
1841 | |
1842 for (sblk = symbol_block; sblk; sblk = sblk->next) | |
1843 { | |
1844 register int i; | |
1845 for (i = 0; i < lim; i++) | |
1846 if (!XMARKBIT (sblk->symbols[i].plist)) | |
1847 { | |
1848 XFASTINT (sblk->symbols[i].value) = (int) symbol_free_list; | |
1849 symbol_free_list = &sblk->symbols[i]; | |
1850 num_free++; | |
1851 } | |
1852 else | |
1853 { | |
1854 num_used++; | |
1855 sblk->symbols[i].name | |
1856 = XSTRING (*(Lisp_Object *) &sblk->symbols[i].name); | |
1857 XUNMARK (sblk->symbols[i].plist); | |
1858 } | |
1859 lim = SYMBOL_BLOCK_SIZE; | |
1860 } | |
1861 total_symbols = num_used; | |
1862 total_free_symbols = num_free; | |
1863 } | |
1864 | |
1865 #ifndef standalone | |
1866 /* Put all unmarked markers on free list. | |
1867 Dechain each one first from the buffer it points into. */ | |
1868 { | |
1869 register struct marker_block *mblk; | |
1870 struct Lisp_Marker *tem1; | |
1871 register int lim = marker_block_index; | |
1872 register int num_free = 0, num_used = 0; | |
1873 | |
1874 marker_free_list = 0; | |
1875 | |
1876 for (mblk = marker_block; mblk; mblk = mblk->next) | |
1877 { | |
1878 register int i; | |
1879 for (i = 0; i < lim; i++) | |
1880 if (!XMARKBIT (mblk->markers[i].chain)) | |
1881 { | |
1882 Lisp_Object tem; | |
1883 tem1 = &mblk->markers[i]; /* tem1 avoids Sun compiler bug */ | |
1884 XSET (tem, Lisp_Marker, tem1); | |
1885 unchain_marker (tem); | |
1886 XFASTINT (mblk->markers[i].chain) = (int) marker_free_list; | |
1887 marker_free_list = &mblk->markers[i]; | |
1888 num_free++; | |
1889 } | |
1890 else | |
1891 { | |
1892 num_used++; | |
1893 XUNMARK (mblk->markers[i].chain); | |
1894 } | |
1895 lim = MARKER_BLOCK_SIZE; | |
1896 } | |
1897 | |
1898 total_markers = num_used; | |
1899 total_free_markers = num_free; | |
1900 } | |
1901 | |
1902 /* Free all unmarked buffers */ | |
1903 { | |
1904 register struct buffer *buffer = all_buffers, *prev = 0, *next; | |
1905 | |
1906 while (buffer) | |
1907 if (!XMARKBIT (buffer->name)) | |
1908 { | |
1909 if (prev) | |
1910 prev->next = buffer->next; | |
1911 else | |
1912 all_buffers = buffer->next; | |
1913 next = buffer->next; | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
1914 xfree (buffer); |
300 | 1915 buffer = next; |
1916 } | |
1917 else | |
1918 { | |
1919 XUNMARK (buffer->name); | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
1920 UNMARK_BALANCE_INTERVALS (buffer->intervals); |
300 | 1921 |
1922 #if 0 | |
1923 /* Each `struct Lisp_String *' was turned into a Lisp_Object | |
1924 for purposes of marking and relocation. | |
1925 Turn them back into C pointers now. */ | |
1926 buffer->upcase_table | |
1927 = XSTRING (*(Lisp_Object *)&buffer->upcase_table); | |
1928 buffer->downcase_table | |
1929 = XSTRING (*(Lisp_Object *)&buffer->downcase_table); | |
1930 buffer->sort_table | |
1931 = XSTRING (*(Lisp_Object *)&buffer->sort_table); | |
1932 buffer->folding_sort_table | |
1933 = XSTRING (*(Lisp_Object *)&buffer->folding_sort_table); | |
1934 #endif | |
1935 | |
1936 prev = buffer, buffer = buffer->next; | |
1937 } | |
1938 } | |
1939 | |
1940 #endif /* standalone */ | |
1941 | |
1942 /* Free all unmarked vectors */ | |
1943 { | |
1944 register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next; | |
1945 total_vector_size = 0; | |
1946 | |
1947 while (vector) | |
1948 if (!(vector->size & ARRAY_MARK_FLAG)) | |
1949 { | |
1950 if (prev) | |
1951 prev->next = vector->next; | |
1952 else | |
1953 all_vectors = vector->next; | |
1954 next = vector->next; | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
1955 xfree (vector); |
300 | 1956 vector = next; |
1957 } | |
1958 else | |
1959 { | |
1960 vector->size &= ~ARRAY_MARK_FLAG; | |
1961 total_vector_size += vector->size; | |
1962 prev = vector, vector = vector->next; | |
1963 } | |
1964 } | |
1965 | |
1966 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */ | |
1967 { | |
1968 register struct string_block *sb = large_string_blocks, *prev = 0, *next; | |
4139
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1969 struct Lisp_String *s; |
300 | 1970 |
1971 while (sb) | |
4139
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1972 { |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1973 s = (struct Lisp_String *) &sb->chars[0]; |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1974 if (s->size & ARRAY_MARK_FLAG) |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1975 { |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1976 ((struct Lisp_String *)(&sb->chars[0]))->size |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1977 &= ~ARRAY_MARK_FLAG & ~MARKBIT; |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1978 UNMARK_BALANCE_INTERVALS (s->intervals); |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1979 total_string_size += ((struct Lisp_String *)(&sb->chars[0]))->size; |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1980 prev = sb, sb = sb->next; |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1981 } |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1982 else |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1983 { |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1984 if (prev) |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1985 prev->next = sb->next; |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1986 else |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1987 large_string_blocks = sb->next; |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1988 next = sb->next; |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1989 xfree (sb); |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1990 sb = next; |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1991 } |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
1992 } |
300 | 1993 } |
1994 } | |
1995 | |
1908
d649f2179d67
* alloc.c (make_pure_float): Align pureptr on a sizeof (double)
Jim Blandy <jimb@redhat.com>
parents:
1893
diff
changeset
|
1996 /* Compactify strings, relocate references, and free empty string blocks. */ |
300 | 1997 |
1998 static void | |
1999 compact_strings () | |
2000 { | |
2001 /* String block of old strings we are scanning. */ | |
2002 register struct string_block *from_sb; | |
2003 /* A preceding string block (or maybe the same one) | |
2004 where we are copying the still-live strings to. */ | |
2005 register struct string_block *to_sb; | |
2006 int pos; | |
2007 int to_pos; | |
2008 | |
2009 to_sb = first_string_block; | |
2010 to_pos = 0; | |
2011 | |
2012 /* Scan each existing string block sequentially, string by string. */ | |
2013 for (from_sb = first_string_block; from_sb; from_sb = from_sb->next) | |
2014 { | |
2015 pos = 0; | |
2016 /* POS is the index of the next string in the block. */ | |
2017 while (pos < from_sb->pos) | |
2018 { | |
2019 register struct Lisp_String *nextstr | |
2020 = (struct Lisp_String *) &from_sb->chars[pos]; | |
2021 | |
2022 register struct Lisp_String *newaddr; | |
2023 register int size = nextstr->size; | |
2024 | |
2025 /* NEXTSTR is the old address of the next string. | |
2026 Just skip it if it isn't marked. */ | |
2027 if ((unsigned) size > STRING_BLOCK_SIZE) | |
2028 { | |
2029 /* It is marked, so its size field is really a chain of refs. | |
2030 Find the end of the chain, where the actual size lives. */ | |
2031 while ((unsigned) size > STRING_BLOCK_SIZE) | |
2032 { | |
2033 if (size & 1) size ^= MARKBIT | 1; | |
2034 size = *(int *)size & ~MARKBIT; | |
2035 } | |
2036 | |
2037 total_string_size += size; | |
2038 | |
2039 /* If it won't fit in TO_SB, close it out, | |
2040 and move to the next sb. Keep doing so until | |
2041 TO_SB reaches a large enough, empty enough string block. | |
2042 We know that TO_SB cannot advance past FROM_SB here | |
2043 since FROM_SB is large enough to contain this string. | |
2044 Any string blocks skipped here | |
2045 will be patched out and freed later. */ | |
2046 while (to_pos + STRING_FULLSIZE (size) | |
2047 > max (to_sb->pos, STRING_BLOCK_SIZE)) | |
2048 { | |
2049 to_sb->pos = to_pos; | |
2050 to_sb = to_sb->next; | |
2051 to_pos = 0; | |
2052 } | |
2053 /* Compute new address of this string | |
2054 and update TO_POS for the space being used. */ | |
2055 newaddr = (struct Lisp_String *) &to_sb->chars[to_pos]; | |
2056 to_pos += STRING_FULLSIZE (size); | |
2057 | |
2058 /* Copy the string itself to the new place. */ | |
2059 if (nextstr != newaddr) | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
2060 bcopy (nextstr, newaddr, size + 1 + sizeof (int) |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
2061 + INTERVAL_PTR_SIZE); |
300 | 2062 |
2063 /* Go through NEXTSTR's chain of references | |
2064 and make each slot in the chain point to | |
2065 the new address of this string. */ | |
2066 size = newaddr->size; | |
2067 while ((unsigned) size > STRING_BLOCK_SIZE) | |
2068 { | |
2069 register Lisp_Object *objptr; | |
2070 if (size & 1) size ^= MARKBIT | 1; | |
2071 objptr = (Lisp_Object *)size; | |
2072 | |
2073 size = XFASTINT (*objptr) & ~MARKBIT; | |
2074 if (XMARKBIT (*objptr)) | |
2075 { | |
2076 XSET (*objptr, Lisp_String, newaddr); | |
2077 XMARK (*objptr); | |
2078 } | |
2079 else | |
2080 XSET (*objptr, Lisp_String, newaddr); | |
2081 } | |
2082 /* Store the actual size in the size field. */ | |
2083 newaddr->size = size; | |
4139
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2084 |
4212
a696547fb51e
(compact_strings): Add USE_TEXT_PROPERTIES conditional.
Richard M. Stallman <rms@gnu.org>
parents:
4139
diff
changeset
|
2085 #ifdef USE_TEXT_PROPERTIES |
4139
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2086 /* Now that the string has been relocated, rebalance its |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2087 interval tree, and update the tree's parent pointer. */ |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2088 if (! NULL_INTERVAL_P (newaddr->intervals)) |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2089 { |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2090 UNMARK_BALANCE_INTERVALS (newaddr->intervals); |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2091 XSET (* (Lisp_Object *) &newaddr->intervals->parent, |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2092 Lisp_String, |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2093 newaddr); |
0b32ee899a3a
Consistently use the mark bit of the root interval's parent field
Jim Blandy <jimb@redhat.com>
parents:
4087
diff
changeset
|
2094 } |
4212
a696547fb51e
(compact_strings): Add USE_TEXT_PROPERTIES conditional.
Richard M. Stallman <rms@gnu.org>
parents:
4139
diff
changeset
|
2095 #endif /* USE_TEXT_PROPERTIES */ |
300 | 2096 } |
2097 pos += STRING_FULLSIZE (size); | |
2098 } | |
2099 } | |
2100 | |
2101 /* Close out the last string block still used and free any that follow. */ | |
2102 to_sb->pos = to_pos; | |
2103 current_string_block = to_sb; | |
2104 | |
2105 from_sb = to_sb->next; | |
2106 to_sb->next = 0; | |
2107 while (from_sb) | |
2108 { | |
2109 to_sb = from_sb->next; | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
2110 xfree (from_sb); |
300 | 2111 from_sb = to_sb; |
2112 } | |
2113 | |
2114 /* Free any empty string blocks further back in the chain. | |
2115 This loop will never free first_string_block, but it is very | |
2116 unlikely that that one will become empty, so why bother checking? */ | |
2117 | |
2118 from_sb = first_string_block; | |
2119 while (to_sb = from_sb->next) | |
2120 { | |
2121 if (to_sb->pos == 0) | |
2122 { | |
2123 if (from_sb->next = to_sb->next) | |
2124 from_sb->next->prev = from_sb; | |
2439
b6c62e4abf59
Put interrupt input blocking in a separate file from xterm.h.
Jim Blandy <jimb@redhat.com>
parents:
2370
diff
changeset
|
2125 xfree (to_sb); |
300 | 2126 } |
2127 else | |
2128 from_sb = to_sb; | |
2129 } | |
2130 } | |
2131 | |
1327
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2132 /* Debugging aids. */ |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2133 |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2134 DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, "", |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2135 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\ |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2136 This may be helpful in debugging Emacs's memory usage.\n\ |
1893
b047e77f3be4
(Fmemory_limit): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
1784
diff
changeset
|
2137 We divide the value by 1024 to make sure it fits in a Lisp integer.") |
1327
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2138 () |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2139 { |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2140 Lisp_Object end; |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2141 |
1362
4bea5980f778
* alloc.c (Fmemory_limit): Explain why we divide by 1024.
Jim Blandy <jimb@redhat.com>
parents:
1327
diff
changeset
|
2142 XSET (end, Lisp_Int, (int) sbrk (0) / 1024); |
1327
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2143 |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2144 return end; |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2145 } |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2146 |
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2147 |
300 | 2148 /* Initialization */ |
2149 | |
2150 init_alloc_once () | |
2151 { | |
2152 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ | |
2153 pureptr = 0; | |
356 | 2154 #ifdef HAVE_SHM |
2155 pure_size = PURESIZE; | |
2156 #endif | |
300 | 2157 all_vectors = 0; |
2158 ignore_warnings = 1; | |
2159 init_strings (); | |
2160 init_cons (); | |
2161 init_symbol (); | |
2162 init_marker (); | |
2163 #ifdef LISP_FLOAT_TYPE | |
2164 init_float (); | |
2165 #endif /* LISP_FLOAT_TYPE */ | |
1300
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
2166 INIT_INTERVALS; |
b13b79e28eb5
* alloc.c: #include "intervals.h".
Joseph Arceneaux <jla@gnu.org>
parents:
1295
diff
changeset
|
2167 |
300 | 2168 ignore_warnings = 0; |
2169 gcprolist = 0; | |
2170 staticidx = 0; | |
2171 consing_since_gc = 0; | |
2172 gc_cons_threshold = 100000; | |
2173 #ifdef VIRT_ADDR_VARIES | |
2174 malloc_sbrk_unused = 1<<22; /* A large number */ | |
2175 malloc_sbrk_used = 100000; /* as reasonable as any number */ | |
2176 #endif /* VIRT_ADDR_VARIES */ | |
2177 } | |
2178 | |
2179 init_alloc () | |
2180 { | |
2181 gcprolist = 0; | |
2182 } | |
2183 | |
2184 void | |
2185 syms_of_alloc () | |
2186 { | |
2187 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold, | |
2188 "*Number of bytes of consing between garbage collections.\n\ | |
2189 Garbage collection can happen automatically once this many bytes have been\n\ | |
2190 allocated since the last garbage collection. All data types count.\n\n\ | |
2191 Garbage collection happens automatically only when `eval' is called.\n\n\ | |
2192 By binding this temporarily to a large number, you can effectively\n\ | |
2193 prevent garbage collection during a part of the program."); | |
2194 | |
2195 DEFVAR_INT ("pure-bytes-used", &pureptr, | |
2196 "Number of bytes of sharable Lisp data allocated so far."); | |
2197 | |
2198 #if 0 | |
2199 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used, | |
2200 "Number of bytes of unshared memory allocated in this session."); | |
2201 | |
2202 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused, | |
2203 "Number of bytes of unshared memory remaining available in this session."); | |
2204 #endif | |
2205 | |
2206 DEFVAR_LISP ("purify-flag", &Vpurify_flag, | |
2207 "Non-nil means loading Lisp code in order to dump an executable.\n\ | |
2208 This means that certain objects should be allocated in shared (pure) space."); | |
2209 | |
764 | 2210 DEFVAR_INT ("undo-limit", &undo_limit, |
300 | 2211 "Keep no more undo information once it exceeds this size.\n\ |
764 | 2212 This limit is applied when garbage collection happens.\n\ |
300 | 2213 The size is counted as the number of bytes occupied,\n\ |
2214 which includes both saved text and other data."); | |
764 | 2215 undo_limit = 20000; |
300 | 2216 |
764 | 2217 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit, |
300 | 2218 "Don't keep more than this much size of undo information.\n\ |
2219 A command which pushes past this size is itself forgotten.\n\ | |
764 | 2220 This limit is applied when garbage collection happens.\n\ |
300 | 2221 The size is counted as the number of bytes occupied,\n\ |
2222 which includes both saved text and other data."); | |
764 | 2223 undo_strong_limit = 30000; |
300 | 2224 |
2225 defsubr (&Scons); | |
2226 defsubr (&Slist); | |
2227 defsubr (&Svector); | |
2228 defsubr (&Smake_byte_code); | |
2229 defsubr (&Smake_list); | |
2230 defsubr (&Smake_vector); | |
2231 defsubr (&Smake_string); | |
2232 defsubr (&Smake_symbol); | |
2233 defsubr (&Smake_marker); | |
2234 defsubr (&Spurecopy); | |
2235 defsubr (&Sgarbage_collect); | |
1327
ef16e7c0d402
* alloc.c (Fmemory_limit): New function.
Jim Blandy <jimb@redhat.com>
parents:
1318
diff
changeset
|
2236 defsubr (&Smemory_limit); |
300 | 2237 } |