Commit | Line | Data |
---|---|---|
2b829bbb | 1 | /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e MV |
3 | * This library is free software; you can redistribute it and/or |
4 | * modify it under the terms of the GNU Lesser General Public | |
5 | * License as published by the Free Software Foundation; either | |
6 | * version 2.1 of the License, or (at your option) any later version. | |
0f2d19dd | 7 | * |
73be1d9e MV |
8 | * This library is distributed in the hope that it will be useful, |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | * Lesser General Public License for more details. | |
0f2d19dd | 12 | * |
73be1d9e MV |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
92205699 | 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 16 | */ |
1bbd0b84 | 17 | |
1bbd0b84 | 18 | |
0f2d19dd | 19 | \f |
dbb605f5 | 20 | #ifdef HAVE_CONFIG_H |
f9fe039d RB |
21 | # include <config.h> |
22 | #endif | |
0f2d19dd JB |
23 | |
24 | #include <stdio.h> | |
e6e2e95a MD |
25 | #include <errno.h> |
26 | ||
a0599745 | 27 | #include "libguile/_scm.h" |
20e6290e | 28 | |
4e047c3e | 29 | #include "libguile/async.h" |
a0599745 | 30 | #include "libguile/objects.h" |
9511876f | 31 | #include "libguile/goops.h" |
a0599745 | 32 | #include "libguile/ports.h" |
d7ec6b9f | 33 | |
0f2d19dd JB |
34 | #ifdef HAVE_MALLOC_H |
35 | #include <malloc.h> | |
36 | #endif | |
37 | ||
a0599745 | 38 | #include "libguile/smob.h" |
9dd5943c | 39 | |
e7bca227 | 40 | #include "libguile/boehm-gc.h" |
e9d635e5 LC |
41 | #include <gc/gc_mark.h> |
42 | ||
43 | ||
0f2d19dd JB |
44 | \f |
45 | ||
46 | /* scm_smobs scm_numsmob | |
7a7f7c53 | 47 | * implement a fixed sized array of smob records. |
0f2d19dd JB |
48 | * Indexes into this table are used when generating type |
49 | * tags for smobjects (if you know a tag you can get an index and conversely). | |
50 | */ | |
7a7f7c53 DH |
51 | |
52 | #define MAX_SMOB_COUNT 256 | |
c014a02e | 53 | long scm_numsmob; |
7a7f7c53 | 54 | scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT]; |
0f2d19dd | 55 | |
37fc18ae MV |
56 | /* Lower 16 bit of data must be zero. |
57 | */ | |
58 | void | |
59 | scm_i_set_smob_flags (SCM x, scm_t_bits data) | |
60 | { | |
61 | SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data); | |
62 | } | |
63 | ||
197b0573 MV |
64 | void |
65 | scm_assert_smob_type (scm_t_bits tag, SCM val) | |
66 | { | |
67 | if (!SCM_SMOB_PREDICATE (tag, val)) | |
68 | scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name); | |
69 | } | |
70 | ||
9dd5943c MD |
71 | /* {Mark} |
72 | */ | |
73 | ||
74 | /* This function is vestigial. It used to be the mark function's | |
75 | responsibility to set the mark bit on the smob or port, but now the | |
76 | generic marking routine in gc.c takes care of that, and a zero | |
77 | pointer for a mark function means "don't bother". So you never | |
78 | need scm_mark0. | |
79 | ||
80 | However, we leave it here because it's harmless to call it, and | |
81 | people out there have smob code that uses it, and there's no reason | |
82 | to make their links fail. */ | |
83 | ||
84 | SCM | |
e81d98ec | 85 | scm_mark0 (SCM ptr SCM_UNUSED) |
9dd5943c MD |
86 | { |
87 | return SCM_BOOL_F; | |
88 | } | |
89 | ||
90 | SCM | |
22a52da1 DH |
91 | /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only |
92 | be used for real pairs. */ | |
6e8d25a6 | 93 | scm_markcdr (SCM ptr) |
9dd5943c | 94 | { |
22a52da1 | 95 | return SCM_CELL_OBJECT_1 (ptr); |
9dd5943c MD |
96 | } |
97 | ||
98 | /* {Free} | |
99 | */ | |
100 | ||
1be6b49c | 101 | size_t |
e81d98ec | 102 | scm_free0 (SCM ptr SCM_UNUSED) |
9dd5943c MD |
103 | { |
104 | return 0; | |
105 | } | |
106 | ||
1be6b49c | 107 | size_t |
9dd5943c MD |
108 | scm_smob_free (SCM obj) |
109 | { | |
4c9419ac MV |
110 | long n = SCM_SMOBNUM (obj); |
111 | if (scm_smobs[n].size > 0) | |
112 | scm_gc_free ((void *) SCM_CELL_WORD_1 (obj), | |
113 | scm_smobs[n].size, SCM_SMOBNAME (n)); | |
114 | return 0; | |
9dd5943c MD |
115 | } |
116 | ||
117 | /* {Print} | |
118 | */ | |
119 | ||
120 | int | |
e81d98ec | 121 | scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) |
9dd5943c | 122 | { |
c014a02e | 123 | long n = SCM_SMOBNUM (exp); |
9dd5943c | 124 | scm_puts ("#<", port); |
2c16a78a | 125 | scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); |
9dd5943c | 126 | scm_putc (' ', port); |
7a7f7c53 | 127 | if (scm_smobs[n].size) |
0345e278 | 128 | scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port); |
7a7f7c53 | 129 | else |
0345e278 | 130 | scm_uintprint (SCM_UNPACK (exp), 16, port); |
9dd5943c MD |
131 | scm_putc ('>', port); |
132 | return 1; | |
133 | } | |
1cc91f1b | 134 | |
0717dfd8 KN |
135 | /* {Apply} |
136 | */ | |
137 | ||
cb1c46c5 KN |
138 | #define SCM_SMOB_APPLY0(SMOB) \ |
139 | SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB) | |
34d19ef6 | 140 | #define SCM_SMOB_APPLY1(SMOB, A1) \ |
cb1c46c5 | 141 | SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1) |
34d19ef6 | 142 | #define SCM_SMOB_APPLY2(SMOB, A1, A2) \ |
cb1c46c5 | 143 | SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2) |
34d19ef6 | 144 | #define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \ |
cb1c46c5 KN |
145 | SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3) |
146 | ||
cb1c46c5 KN |
147 | static SCM |
148 | scm_smob_apply_0_010 (SCM smob) | |
0717dfd8 | 149 | { |
cb1c46c5 | 150 | return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED); |
0717dfd8 KN |
151 | } |
152 | ||
cb1c46c5 KN |
153 | static SCM |
154 | scm_smob_apply_0_020 (SCM smob) | |
0717dfd8 | 155 | { |
cb1c46c5 | 156 | return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED); |
0717dfd8 KN |
157 | } |
158 | ||
cb1c46c5 KN |
159 | static SCM |
160 | scm_smob_apply_0_030 (SCM smob) | |
0717dfd8 | 161 | { |
cb1c46c5 | 162 | return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED); |
0717dfd8 KN |
163 | } |
164 | ||
cb1c46c5 KN |
165 | static SCM |
166 | scm_smob_apply_0_001 (SCM smob) | |
0717dfd8 | 167 | { |
cb1c46c5 KN |
168 | return SCM_SMOB_APPLY1 (smob, SCM_EOL); |
169 | } | |
170 | ||
171 | static SCM | |
172 | scm_smob_apply_0_011 (SCM smob) | |
173 | { | |
174 | return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL); | |
175 | } | |
176 | ||
177 | static SCM | |
178 | scm_smob_apply_0_021 (SCM smob) | |
179 | { | |
180 | return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL); | |
181 | } | |
182 | ||
183 | static SCM | |
184 | scm_smob_apply_0_error (SCM smob) | |
185 | { | |
186 | scm_wrong_num_args (smob); | |
187 | } | |
188 | ||
cb1c46c5 KN |
189 | static SCM |
190 | scm_smob_apply_1_020 (SCM smob, SCM a1) | |
191 | { | |
192 | return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED); | |
193 | } | |
194 | ||
195 | static SCM | |
196 | scm_smob_apply_1_030 (SCM smob, SCM a1) | |
197 | { | |
198 | return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED); | |
199 | } | |
200 | ||
201 | static SCM | |
202 | scm_smob_apply_1_001 (SCM smob, SCM a1) | |
203 | { | |
1afff620 | 204 | return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1)); |
cb1c46c5 KN |
205 | } |
206 | ||
207 | static SCM | |
208 | scm_smob_apply_1_011 (SCM smob, SCM a1) | |
209 | { | |
210 | return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL); | |
211 | } | |
212 | ||
213 | static SCM | |
214 | scm_smob_apply_1_021 (SCM smob, SCM a1) | |
215 | { | |
216 | return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL); | |
217 | } | |
218 | ||
219 | static SCM | |
e81d98ec | 220 | scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED) |
cb1c46c5 KN |
221 | { |
222 | scm_wrong_num_args (smob); | |
223 | } | |
224 | ||
cb1c46c5 KN |
225 | static SCM |
226 | scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2) | |
227 | { | |
228 | return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED); | |
229 | } | |
230 | ||
231 | static SCM | |
232 | scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2) | |
233 | { | |
1afff620 | 234 | return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2)); |
7c58e21b | 235 | } |
cb1c46c5 KN |
236 | |
237 | static SCM | |
238 | scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2) | |
239 | { | |
1afff620 | 240 | return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2)); |
cb1c46c5 KN |
241 | } |
242 | ||
243 | static SCM | |
244 | scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2) | |
245 | { | |
246 | return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL); | |
247 | } | |
248 | ||
249 | static SCM | |
e81d98ec | 250 | scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED) |
cb1c46c5 KN |
251 | { |
252 | scm_wrong_num_args (smob); | |
253 | } | |
254 | ||
255 | static SCM | |
256 | scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst) | |
257 | { | |
d2e53ed6 | 258 | if (!scm_is_null (SCM_CDR (rst))) |
cb1c46c5 KN |
259 | scm_wrong_num_args (smob); |
260 | return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst)); | |
261 | } | |
262 | ||
263 | static SCM | |
264 | scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst) | |
265 | { | |
266 | return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst)); | |
0717dfd8 KN |
267 | } |
268 | ||
cb1c46c5 KN |
269 | static SCM |
270 | scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst) | |
271 | { | |
272 | return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst)); | |
273 | } | |
274 | ||
275 | static SCM | |
276 | scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst) | |
277 | { | |
278 | return SCM_SMOB_APPLY3 (smob, a1, a2, rst); | |
279 | } | |
280 | ||
281 | static SCM | |
e81d98ec DH |
282 | scm_smob_apply_3_error (SCM smob, |
283 | SCM a1 SCM_UNUSED, | |
284 | SCM a2 SCM_UNUSED, | |
285 | SCM rst SCM_UNUSED) | |
cb1c46c5 KN |
286 | { |
287 | scm_wrong_num_args (smob); | |
288 | } | |
289 | ||
290 | \f | |
7a7f7c53 | 291 | |
92c2555f | 292 | scm_t_bits |
da0e6c2b | 293 | scm_make_smob_type (char const *name, size_t size) |
7a7f7c53 | 294 | #define FUNC_NAME "scm_make_smob_type" |
0f2d19dd | 295 | { |
c014a02e | 296 | long new_smob; |
7a7f7c53 | 297 | |
9de87eea | 298 | SCM_CRITICAL_SECTION_START; |
7a7f7c53 DH |
299 | new_smob = scm_numsmob; |
300 | if (scm_numsmob != MAX_SMOB_COUNT) | |
301 | ++scm_numsmob; | |
9de87eea | 302 | SCM_CRITICAL_SECTION_END; |
7a7f7c53 DH |
303 | |
304 | if (new_smob == MAX_SMOB_COUNT) | |
305 | scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL); | |
306 | ||
307 | scm_smobs[new_smob].name = name; | |
308 | if (size != 0) | |
2500356c | 309 | { |
7a7f7c53 DH |
310 | scm_smobs[new_smob].size = size; |
311 | scm_smobs[new_smob].free = scm_smob_free; | |
2500356c | 312 | } |
7a7f7c53 | 313 | |
d7ec6b9f MD |
314 | /* Make a class object if Goops is present. */ |
315 | if (scm_smob_class) | |
74b6d6e4 | 316 | scm_smob_class[new_smob] = scm_make_extended_class (name, 0); |
7a7f7c53 DH |
317 | |
318 | return scm_tc7_smob + new_smob * 256; | |
0f2d19dd | 319 | } |
7a7f7c53 DH |
320 | #undef FUNC_NAME |
321 | ||
0f2d19dd | 322 | |
9dd5943c | 323 | void |
92c2555f | 324 | scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM)) |
9dd5943c MD |
325 | { |
326 | scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark; | |
327 | } | |
328 | ||
329 | void | |
92c2555f | 330 | scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM)) |
9dd5943c MD |
331 | { |
332 | scm_smobs[SCM_TC2SMOBNUM (tc)].free = free; | |
333 | } | |
334 | ||
335 | void | |
92c2555f | 336 | scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*)) |
9dd5943c MD |
337 | { |
338 | scm_smobs[SCM_TC2SMOBNUM (tc)].print = print; | |
339 | } | |
340 | ||
341 | void | |
92c2555f | 342 | scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) |
9dd5943c MD |
343 | { |
344 | scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp; | |
345 | } | |
346 | ||
0717dfd8 | 347 | void |
92c2555f | 348 | scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), |
7c58e21b | 349 | unsigned int req, unsigned int opt, unsigned int rst) |
0717dfd8 | 350 | { |
cb1c46c5 KN |
351 | SCM (*apply_0) (SCM); |
352 | SCM (*apply_1) (SCM, SCM); | |
353 | SCM (*apply_2) (SCM, SCM, SCM); | |
354 | SCM (*apply_3) (SCM, SCM, SCM, SCM); | |
355 | int type = SCM_GSUBR_MAKTYPE (req, opt, rst); | |
356 | ||
7c58e21b | 357 | if (rst > 1 || req + opt + rst > 3) |
cb1c46c5 KN |
358 | { |
359 | puts ("Unsupported smob application type"); | |
360 | abort (); | |
361 | } | |
362 | ||
363 | switch (type) | |
364 | { | |
365 | case SCM_GSUBR_MAKTYPE (0, 0, 0): | |
7c58e21b | 366 | apply_0 = apply; break; |
cb1c46c5 KN |
367 | case SCM_GSUBR_MAKTYPE (0, 1, 0): |
368 | apply_0 = scm_smob_apply_0_010; break; | |
369 | case SCM_GSUBR_MAKTYPE (0, 2, 0): | |
370 | apply_0 = scm_smob_apply_0_020; break; | |
371 | case SCM_GSUBR_MAKTYPE (0, 3, 0): | |
372 | apply_0 = scm_smob_apply_0_030; break; | |
373 | case SCM_GSUBR_MAKTYPE (0, 0, 1): | |
374 | apply_0 = scm_smob_apply_0_001; break; | |
375 | case SCM_GSUBR_MAKTYPE (0, 1, 1): | |
376 | apply_0 = scm_smob_apply_0_011; break; | |
377 | case SCM_GSUBR_MAKTYPE (0, 2, 1): | |
378 | apply_0 = scm_smob_apply_0_021; break; | |
379 | default: | |
380 | apply_0 = scm_smob_apply_0_error; break; | |
381 | } | |
382 | ||
383 | switch (type) | |
384 | { | |
385 | case SCM_GSUBR_MAKTYPE (1, 0, 0): | |
386 | case SCM_GSUBR_MAKTYPE (0, 1, 0): | |
7c58e21b | 387 | apply_1 = apply; break; |
cb1c46c5 KN |
388 | case SCM_GSUBR_MAKTYPE (1, 1, 0): |
389 | case SCM_GSUBR_MAKTYPE (0, 2, 0): | |
390 | apply_1 = scm_smob_apply_1_020; break; | |
391 | case SCM_GSUBR_MAKTYPE (1, 2, 0): | |
392 | case SCM_GSUBR_MAKTYPE (0, 3, 0): | |
393 | apply_1 = scm_smob_apply_1_030; break; | |
394 | case SCM_GSUBR_MAKTYPE (0, 0, 1): | |
395 | apply_1 = scm_smob_apply_1_001; break; | |
396 | case SCM_GSUBR_MAKTYPE (1, 0, 1): | |
397 | case SCM_GSUBR_MAKTYPE (0, 1, 1): | |
398 | apply_1 = scm_smob_apply_1_011; break; | |
399 | case SCM_GSUBR_MAKTYPE (1, 1, 1): | |
400 | case SCM_GSUBR_MAKTYPE (0, 2, 1): | |
401 | apply_1 = scm_smob_apply_1_021; break; | |
402 | default: | |
403 | apply_1 = scm_smob_apply_1_error; break; | |
404 | } | |
405 | ||
406 | switch (type) | |
407 | { | |
408 | case SCM_GSUBR_MAKTYPE (2, 0, 0): | |
409 | case SCM_GSUBR_MAKTYPE (1, 1, 0): | |
410 | case SCM_GSUBR_MAKTYPE (0, 2, 0): | |
7c58e21b | 411 | apply_2 = apply; break; |
cb1c46c5 KN |
412 | case SCM_GSUBR_MAKTYPE (2, 1, 0): |
413 | case SCM_GSUBR_MAKTYPE (1, 2, 0): | |
414 | case SCM_GSUBR_MAKTYPE (0, 3, 0): | |
415 | apply_2 = scm_smob_apply_2_030; break; | |
416 | case SCM_GSUBR_MAKTYPE (0, 0, 1): | |
417 | apply_2 = scm_smob_apply_2_001; break; | |
418 | case SCM_GSUBR_MAKTYPE (1, 0, 1): | |
419 | case SCM_GSUBR_MAKTYPE (0, 1, 1): | |
420 | apply_2 = scm_smob_apply_2_011; break; | |
421 | case SCM_GSUBR_MAKTYPE (2, 0, 1): | |
422 | case SCM_GSUBR_MAKTYPE (1, 1, 1): | |
423 | case SCM_GSUBR_MAKTYPE (0, 2, 1): | |
424 | apply_2 = scm_smob_apply_2_021; break; | |
425 | default: | |
426 | apply_2 = scm_smob_apply_2_error; break; | |
427 | } | |
428 | ||
429 | switch (type) | |
430 | { | |
431 | case SCM_GSUBR_MAKTYPE (3, 0, 0): | |
432 | case SCM_GSUBR_MAKTYPE (2, 1, 0): | |
433 | case SCM_GSUBR_MAKTYPE (1, 2, 0): | |
434 | case SCM_GSUBR_MAKTYPE (0, 3, 0): | |
435 | apply_3 = scm_smob_apply_3_030; break; | |
436 | case SCM_GSUBR_MAKTYPE (0, 0, 1): | |
437 | apply_3 = scm_smob_apply_3_001; break; | |
438 | case SCM_GSUBR_MAKTYPE (1, 0, 1): | |
439 | case SCM_GSUBR_MAKTYPE (0, 1, 1): | |
440 | apply_3 = scm_smob_apply_3_011; break; | |
441 | case SCM_GSUBR_MAKTYPE (2, 0, 1): | |
442 | case SCM_GSUBR_MAKTYPE (1, 1, 1): | |
443 | case SCM_GSUBR_MAKTYPE (0, 2, 1): | |
444 | apply_3 = scm_smob_apply_3_021; break; | |
445 | default: | |
446 | apply_3 = scm_smob_apply_3_error; break; | |
447 | } | |
448 | ||
03416a99 | 449 | scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; |
cb1c46c5 KN |
450 | scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0; |
451 | scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1; | |
452 | scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2; | |
453 | scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3; | |
68b06924 | 454 | scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type; |
74b6d6e4 MD |
455 | |
456 | if (scm_smob_class) | |
457 | scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]); | |
0717dfd8 KN |
458 | } |
459 | ||
9dd5943c | 460 | SCM |
92c2555f | 461 | scm_make_smob (scm_t_bits tc) |
9dd5943c | 462 | { |
4a6a4b49 | 463 | scm_t_bits n = SCM_TC2SMOBNUM (tc); |
1be6b49c | 464 | size_t size = scm_smobs[n].size; |
16d4699b | 465 | scm_t_bits data = (size > 0 |
4c9419ac | 466 | ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n)) |
16d4699b | 467 | : 0); |
4a6a4b49 LC |
468 | |
469 | SCM_RETURN_NEWSMOB (tc, data); | |
9dd5943c MD |
470 | } |
471 | ||
ceef3208 | 472 | \f |
534c55a9 | 473 | /* {Initialization for the type of free cells} |
0f2d19dd JB |
474 | */ |
475 | ||
ceef3208 | 476 | static int |
e81d98ec | 477 | free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) |
ceef3208 JB |
478 | { |
479 | char buf[100]; | |
e841c3e0 KN |
480 | sprintf (buf, "#<freed cell %p; GC missed a reference>", |
481 | (void *) SCM_UNPACK (exp)); | |
ceef3208 | 482 | scm_puts (buf, port); |
1e71eafb HWN |
483 | |
484 | #if (SCM_DEBUG_CELL_ACCESSES == 1) | |
485 | if (scm_debug_cell_accesses_p) | |
486 | abort(); | |
487 | #endif | |
488 | ||
ceef3208 JB |
489 | |
490 | return 1; | |
491 | } | |
492 | ||
378f2625 LC |
493 | \f |
494 | /* Marking SMOBs using user-supplied mark procedures. */ | |
495 | ||
378f2625 LC |
496 | |
497 | /* The freelist and GC kind used for SMOB types that provide a custom mark | |
498 | procedure. */ | |
499 | static void **smob_freelist = NULL; | |
500 | static int smob_gc_kind = 0; | |
501 | ||
378f2625 LC |
502 | |
503 | /* The generic SMOB mark procedure that gets called for SMOBs allocated with | |
504 | `scm_i_new_smob_with_mark_proc ()'. */ | |
505 | static struct GC_ms_entry * | |
506 | smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, | |
507 | struct GC_ms_entry *mark_stack_limit, GC_word env) | |
508 | { | |
509 | register SCM cell; | |
194c0a3e LC |
510 | register scm_t_bits tc, smobnum; |
511 | ||
512 | cell = PTR2SCM (addr); | |
513 | ||
514 | if (SCM_TYP7 (cell) != scm_tc7_smob) | |
515 | /* It is likely that the GC passed us a pointer to a free-list element | |
516 | which we must ignore (see warning in `gc/gc_mark.h'). */ | |
517 | return mark_stack_ptr; | |
378f2625 | 518 | |
378f2625 LC |
519 | tc = SCM_CELL_WORD_0 (cell); |
520 | smobnum = SCM_TC2SMOBNUM (tc); | |
521 | ||
522 | if (smobnum >= scm_numsmob) | |
194c0a3e | 523 | /* The first word looks corrupt. */ |
378f2625 LC |
524 | abort (); |
525 | ||
378f2625 LC |
526 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)), |
527 | mark_stack_ptr, | |
528 | mark_stack_limit, NULL); | |
529 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)), | |
530 | mark_stack_ptr, | |
531 | mark_stack_limit, NULL); | |
532 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)), | |
533 | mark_stack_ptr, | |
534 | mark_stack_limit, NULL); | |
535 | ||
536 | if (scm_smobs[smobnum].mark) | |
537 | { | |
538 | SCM obj; | |
539 | ||
540 | SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; | |
541 | SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit; | |
542 | ||
543 | /* Invoke the SMOB's mark procedure, which will in turn invoke | |
544 | `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */ | |
545 | obj = scm_smobs[smobnum].mark (cell); | |
546 | ||
547 | mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr; | |
548 | ||
549 | if (SCM_NIMP (obj)) | |
550 | /* Mark the returned object. */ | |
551 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj), | |
552 | mark_stack_ptr, | |
553 | mark_stack_limit, NULL); | |
554 | ||
555 | SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL; | |
556 | SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL; | |
557 | } | |
558 | ||
559 | return mark_stack_ptr; | |
560 | ||
561 | } | |
562 | ||
563 | /* Mark object O. We assume that this function is only called during the | |
564 | mark phase, i.e., from within `smob_mark ()' or one of its | |
565 | descendents. */ | |
566 | void | |
567 | scm_gc_mark (SCM o) | |
568 | { | |
194c0a3e LC |
569 | #define CURRENT_MARK_PTR \ |
570 | ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr)) | |
571 | #define CURRENT_MARK_LIMIT \ | |
572 | ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit)) | |
573 | ||
378f2625 LC |
574 | if (SCM_NIMP (o)) |
575 | { | |
576 | /* At this point, the `current_mark_*' fields of the current thread | |
577 | must be defined (they are set in `smob_mark ()'). */ | |
578 | register struct GC_ms_entry *mark_stack_ptr; | |
579 | ||
580 | if (!CURRENT_MARK_PTR) | |
581 | /* The function was not called from a mark procedure. */ | |
582 | abort (); | |
583 | ||
584 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o), | |
585 | CURRENT_MARK_PTR, CURRENT_MARK_LIMIT, | |
586 | NULL); | |
587 | SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; | |
588 | } | |
194c0a3e LC |
589 | #undef CURRENT_MARK_PTR |
590 | #undef CURRENT_MARK_LIMIT | |
378f2625 LC |
591 | } |
592 | ||
593 | /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may | |
594 | provide a custom mark procedure and it will be honored. */ | |
595 | SCM | |
596 | scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1, | |
597 | scm_t_bits data2, scm_t_bits data3) | |
598 | { | |
599 | /* Return a double cell. */ | |
600 | SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell), | |
601 | smob_gc_kind)); | |
602 | ||
603 | SCM_SET_CELL_WORD_3 (cell, data3); | |
604 | SCM_SET_CELL_WORD_2 (cell, data2); | |
605 | SCM_SET_CELL_WORD_1 (cell, data1); | |
606 | SCM_SET_CELL_WORD_0 (cell, tc); | |
607 | ||
608 | return cell; | |
609 | } | |
610 | ||
e9d635e5 LC |
611 | \f |
612 | /* Finalize SMOB by calling its SMOB type's free function, if any. */ | |
10fb3386 LC |
613 | void |
614 | scm_i_finalize_smob (GC_PTR ptr, GC_PTR data) | |
e9d635e5 | 615 | { |
10fb3386 | 616 | SCM smob; |
e9d635e5 LC |
617 | size_t (* free_smob) (SCM); |
618 | ||
10fb3386 LC |
619 | smob = PTR2SCM (ptr); |
620 | #if 0 | |
621 | printf ("finalizing SMOB %p (smobnum: %u)\n", | |
622 | ptr, SCM_SMOBNUM (smob)); | |
623 | #endif | |
624 | ||
e9d635e5 LC |
625 | free_smob = scm_smobs[SCM_SMOBNUM (smob)].free; |
626 | if (free_smob) | |
627 | free_smob (smob); | |
e9d635e5 | 628 | } |
378f2625 LC |
629 | |
630 | \f | |
0f2d19dd JB |
631 | void |
632 | scm_smob_prehistory () | |
0f2d19dd | 633 | { |
c014a02e | 634 | long i; |
92c2555f | 635 | scm_t_bits tc; |
e841c3e0 | 636 | |
378f2625 LC |
637 | smob_freelist = GC_new_free_list (); |
638 | smob_gc_kind = GC_new_kind ((void **)smob_freelist, | |
639 | GC_MAKE_PROC (GC_new_proc (smob_mark), 0), | |
62779634 LC |
640 | 0, |
641 | /* Clear new objects. As of version 7.1, libgc | |
642 | doesn't seem to support passing 0 here. */ | |
643 | 1); | |
378f2625 | 644 | |
0f2d19dd | 645 | scm_numsmob = 0; |
7a7f7c53 DH |
646 | for (i = 0; i < MAX_SMOB_COUNT; ++i) |
647 | { | |
648 | scm_smobs[i].name = 0; | |
649 | scm_smobs[i].size = 0; | |
650 | scm_smobs[i].mark = 0; | |
651 | scm_smobs[i].free = 0; | |
652 | scm_smobs[i].print = scm_smob_print; | |
653 | scm_smobs[i].equalp = 0; | |
654 | scm_smobs[i].apply = 0; | |
655 | scm_smobs[i].apply_0 = 0; | |
656 | scm_smobs[i].apply_1 = 0; | |
657 | scm_smobs[i].apply_2 = 0; | |
658 | scm_smobs[i].apply_3 = 0; | |
659 | scm_smobs[i].gsubr_type = 0; | |
660 | } | |
9dd5943c | 661 | |
534c55a9 | 662 | /* WARNING: This scm_make_smob_type call must be done first. */ |
e841c3e0 KN |
663 | tc = scm_make_smob_type ("free", 0); |
664 | scm_set_smob_print (tc, free_print); | |
0f2d19dd | 665 | } |
89e00824 ML |
666 | |
667 | /* | |
668 | Local Variables: | |
669 | c-file-style: "gnu" | |
670 | End: | |
671 | */ |