Commit | Line | Data |
---|---|---|
f9654187 | 1 | /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
4 | * modify it under the terms of the GNU Lesser General Public License |
5 | * as published by the Free Software Foundation; either version 3 of | |
6 | * the License, or (at your option) any later version. | |
0f2d19dd | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
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 | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
73be1d9e | 17 | */ |
1bbd0b84 | 18 | |
1bbd0b84 | 19 | |
0f2d19dd | 20 | \f |
dbb605f5 | 21 | #ifdef HAVE_CONFIG_H |
f9fe039d RB |
22 | # include <config.h> |
23 | #endif | |
0f2d19dd JB |
24 | |
25 | #include <stdio.h> | |
e6e2e95a MD |
26 | #include <errno.h> |
27 | ||
a0599745 | 28 | #include "libguile/_scm.h" |
20e6290e | 29 | |
4e047c3e | 30 | #include "libguile/async.h" |
9511876f | 31 | #include "libguile/goops.h" |
75c3ed28 AW |
32 | #include "libguile/instructions.h" |
33 | #include "libguile/objcodes.h" | |
34 | #include "libguile/programs.h" | |
d7ec6b9f | 35 | |
0f2d19dd JB |
36 | #ifdef HAVE_MALLOC_H |
37 | #include <malloc.h> | |
38 | #endif | |
39 | ||
a0599745 | 40 | #include "libguile/smob.h" |
9dd5943c | 41 | |
1c44468d | 42 | #include "libguile/bdw-gc.h" |
e9d635e5 LC |
43 | #include <gc/gc_mark.h> |
44 | ||
45 | ||
0f2d19dd JB |
46 | \f |
47 | ||
48 | /* scm_smobs scm_numsmob | |
7a7f7c53 | 49 | * implement a fixed sized array of smob records. |
0f2d19dd JB |
50 | * Indexes into this table are used when generating type |
51 | * tags for smobjects (if you know a tag you can get an index and conversely). | |
52 | */ | |
7a7f7c53 | 53 | |
c891a40e LC |
54 | #define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT |
55 | ||
c014a02e | 56 | long scm_numsmob; |
7a7f7c53 | 57 | scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT]; |
0f2d19dd | 58 | |
197b0573 MV |
59 | void |
60 | scm_assert_smob_type (scm_t_bits tag, SCM val) | |
61 | { | |
62 | if (!SCM_SMOB_PREDICATE (tag, val)) | |
63 | scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name); | |
64 | } | |
65 | ||
9dd5943c MD |
66 | /* {Mark} |
67 | */ | |
68 | ||
69 | /* This function is vestigial. It used to be the mark function's | |
70 | responsibility to set the mark bit on the smob or port, but now the | |
71 | generic marking routine in gc.c takes care of that, and a zero | |
72 | pointer for a mark function means "don't bother". So you never | |
73 | need scm_mark0. | |
74 | ||
75 | However, we leave it here because it's harmless to call it, and | |
76 | people out there have smob code that uses it, and there's no reason | |
77 | to make their links fail. */ | |
78 | ||
79 | SCM | |
e81d98ec | 80 | scm_mark0 (SCM ptr SCM_UNUSED) |
9dd5943c MD |
81 | { |
82 | return SCM_BOOL_F; | |
83 | } | |
84 | ||
85 | SCM | |
22a52da1 DH |
86 | /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only |
87 | be used for real pairs. */ | |
6e8d25a6 | 88 | scm_markcdr (SCM ptr) |
9dd5943c | 89 | { |
22a52da1 | 90 | return SCM_CELL_OBJECT_1 (ptr); |
9dd5943c MD |
91 | } |
92 | ||
3051344b | 93 | \f |
9dd5943c MD |
94 | /* {Free} |
95 | */ | |
96 | ||
1be6b49c | 97 | size_t |
e81d98ec | 98 | scm_free0 (SCM ptr SCM_UNUSED) |
9dd5943c MD |
99 | { |
100 | return 0; | |
101 | } | |
102 | ||
3051344b | 103 | \f |
9dd5943c MD |
104 | /* {Print} |
105 | */ | |
106 | ||
107 | int | |
e81d98ec | 108 | scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) |
9dd5943c | 109 | { |
c014a02e | 110 | long n = SCM_SMOBNUM (exp); |
9dd5943c | 111 | scm_puts ("#<", port); |
2c16a78a | 112 | scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); |
9dd5943c | 113 | scm_putc (' ', port); |
7a7f7c53 | 114 | if (scm_smobs[n].size) |
0345e278 | 115 | scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port); |
7a7f7c53 | 116 | else |
0345e278 | 117 | scm_uintprint (SCM_UNPACK (exp), 16, port); |
9dd5943c MD |
118 | scm_putc ('>', port); |
119 | return 1; | |
120 | } | |
1cc91f1b | 121 | |
75c3ed28 | 122 | \f |
0717dfd8 KN |
123 | /* {Apply} |
124 | */ | |
125 | ||
75c3ed28 AW |
126 | #ifdef WORDS_BIGENDIAN |
127 | #define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40 | |
128 | #define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0 | |
129 | #else | |
130 | #define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0 | |
131 | #define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0 | |
132 | #endif | |
cb1c46c5 | 133 | |
75c3ed28 AW |
134 | /* This code is the same as in gsubr.c, except we use smob_call instead of |
135 | struct_call. */ | |
136 | ||
137 | /* A: req; B: opt; C: rest */ | |
138 | #define A(nreq) \ | |
139 | OBJCODE_HEADER, \ | |
140 | /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \ | |
141 | /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \ | |
142 | /* 5 */ scm_op_smob_call, nreq, /* and call (will return value as well) */ \ | |
143 | /* 7 */ scm_op_nop, \ | |
144 | /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ | |
145 | /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ | |
146 | /* 16 */ META (3, 7, nreq, 0, 0) | |
147 | ||
148 | #define B(nopt) \ | |
149 | OBJCODE_HEADER, \ | |
150 | /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \ | |
151 | /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */ \ | |
152 | /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ | |
153 | /* 8 */ scm_op_smob_call, nopt, /* and call (will return value as well) */ \ | |
154 | /* 10 */ scm_op_nop, scm_op_nop, \ | |
155 | /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ | |
156 | /* 16 */ META (6, 10, 0, nopt, 0) | |
157 | ||
158 | #define C() \ | |
159 | OBJCODE_HEADER, \ | |
160 | /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */ \ | |
161 | /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ | |
162 | /* 5 */ scm_op_smob_call, 1, /* and call (will return value as well) */ \ | |
163 | /* 7 */ scm_op_nop, \ | |
164 | /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ | |
165 | /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ | |
166 | /* 16 */ META (3, 7, 0, 0, 1) | |
167 | ||
168 | #define AB(nreq, nopt) \ | |
169 | OBJCODE_HEADER, \ | |
170 | /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ | |
171 | /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \ | |
172 | /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \ | |
173 | /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ | |
174 | /* 11 */ scm_op_smob_call, nreq+nopt, /* and call (will return value as well) */ \ | |
175 | /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \ | |
176 | /* 16 */ META (9, 13, nreq, nopt, 0) | |
177 | ||
178 | #define AC(nreq) \ | |
179 | OBJCODE_HEADER, \ | |
180 | /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ | |
181 | /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */ \ | |
182 | /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ | |
183 | /* 8 */ scm_op_smob_call, nreq+1, /* and call (will return value as well) */ \ | |
184 | /* 10 */ scm_op_nop, scm_op_nop, \ | |
185 | /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ | |
186 | /* 16 */ META (6, 10, nreq, 0, 1) | |
187 | ||
188 | #define BC(nopt) \ | |
189 | OBJCODE_HEADER, \ | |
190 | /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \ | |
191 | /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */ \ | |
192 | /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ | |
193 | /* 8 */ scm_op_smob_call, nopt+1, /* and call (will return value as well) */ \ | |
194 | /* 10 */ scm_op_nop, scm_op_nop, \ | |
195 | /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ | |
196 | /* 16 */ META (6, 10, 0, nopt, 1) | |
197 | ||
198 | #define ABC(nreq, nopt) \ | |
199 | OBJCODE_HEADER, \ | |
200 | /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ | |
201 | /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \ | |
202 | /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */ \ | |
203 | /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ | |
204 | /* 11 */ scm_op_smob_call, nreq+nopt+1, /* and call (will return value as well) */ \ | |
205 | /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \ | |
206 | /* 16 */ META (9, 13, nreq, nopt, 1) | |
207 | ||
208 | #define META(start, end, nreq, nopt, rest) \ | |
209 | META_HEADER, \ | |
210 | /* 0 */ scm_op_make_eol, /* bindings */ \ | |
211 | /* 1 */ scm_op_make_eol, /* sources */ \ | |
212 | /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \ | |
213 | /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \ | |
214 | /* 8 */ scm_op_make_int8, nopt, /* N optionals */ \ | |
215 | /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ \ | |
216 | /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */ \ | |
217 | /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \ | |
218 | /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \ | |
219 | /* 25 */ scm_op_object_ref, 1, /* the name from the object table */ \ | |
220 | /* 27 */ scm_op_cons, /* make a pair for the properties */ \ | |
221 | /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \ | |
222 | /* 31 */ scm_op_return /* and return */ \ | |
223 | /* 32 */ | |
224 | ||
225 | static const struct | |
226 | { | |
227 | scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */ | |
228 | const scm_t_uint8 bytes[16 * (sizeof (struct scm_objcode) + 16 | |
229 | + sizeof (struct scm_objcode) + 32)]; | |
230 | } raw_bytecode = { | |
231 | 0, | |
232 | { | |
233 | /* Use the elisp macros from gsubr.c */ | |
234 | /* C-u 3 M-x generate-bytecodes RET */ | |
235 | /* 0 arguments */ | |
236 | A(0), | |
237 | /* 1 arguments */ | |
238 | A(1), B(1), C(), | |
239 | /* 2 arguments */ | |
240 | A(2), AB(1,1), B(2), AC(1), BC(1), | |
241 | /* 3 arguments */ | |
242 | A(3), AB(2,1), AB(1,2), B(3), AC(2), ABC(1,1), BC(2) | |
243 | } | |
244 | }; | |
245 | ||
246 | #undef A | |
247 | #undef B | |
248 | #undef C | |
249 | #undef AB | |
250 | #undef AC | |
251 | #undef BC | |
252 | #undef ABC | |
253 | #undef OBJCODE_HEADER | |
254 | #undef META_HEADER | |
255 | #undef META | |
256 | ||
257 | #define STATIC_OBJCODE_TAG \ | |
f9654187 | 258 | SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)) |
75c3ed28 AW |
259 | |
260 | static const struct | |
261 | { | |
262 | scm_t_uint64 dummy; /* alignment */ | |
263 | scm_t_cell cells[16 * 2]; /* 4*4 double cells */ | |
264 | } objcode_cells = { | |
265 | 0, | |
266 | /* C-u 3 M-x generate-objcode-cells RET */ | |
267 | { | |
268 | /* 0 arguments */ | |
269 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) }, | |
270 | { SCM_BOOL_F, SCM_PACK (0) }, | |
271 | ||
272 | /* 1 arguments */ | |
273 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) }, | |
274 | { SCM_BOOL_F, SCM_PACK (0) }, | |
275 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) }, | |
276 | { SCM_BOOL_F, SCM_PACK (0) }, | |
277 | ||
278 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) }, | |
279 | { SCM_BOOL_F, SCM_PACK (0) }, | |
280 | ||
281 | /* 2 arguments */ | |
282 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) }, | |
283 | { SCM_BOOL_F, SCM_PACK (0) }, | |
284 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) }, | |
285 | { SCM_BOOL_F, SCM_PACK (0) }, | |
286 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) }, | |
287 | { SCM_BOOL_F, SCM_PACK (0) }, | |
288 | ||
289 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) }, | |
290 | { SCM_BOOL_F, SCM_PACK (0) }, | |
291 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) }, | |
292 | { SCM_BOOL_F, SCM_PACK (0) }, | |
293 | ||
294 | /* 3 arguments */ | |
295 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) }, | |
296 | { SCM_BOOL_F, SCM_PACK (0) }, | |
297 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) }, | |
298 | { SCM_BOOL_F, SCM_PACK (0) }, | |
299 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) }, | |
300 | { SCM_BOOL_F, SCM_PACK (0) }, | |
301 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) }, | |
302 | { SCM_BOOL_F, SCM_PACK (0) }, | |
303 | ||
304 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) }, | |
305 | { SCM_BOOL_F, SCM_PACK (0) }, | |
306 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) }, | |
307 | { SCM_BOOL_F, SCM_PACK (0) }, | |
308 | { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) }, | |
309 | { SCM_BOOL_F, SCM_PACK (0) } | |
310 | } | |
311 | }; | |
312 | ||
313 | static const SCM scm_smob_objcode_trampolines[16] = { | |
314 | /* C-u 3 M-x generate-objcodes RET */ | |
315 | /* 0 arguments */ | |
316 | SCM_PACK (objcode_cells.cells+0), | |
317 | ||
318 | /* 1 arguments */ | |
319 | SCM_PACK (objcode_cells.cells+2), | |
320 | SCM_PACK (objcode_cells.cells+4), | |
321 | SCM_PACK (objcode_cells.cells+6), | |
322 | ||
323 | /* 2 arguments */ | |
324 | SCM_PACK (objcode_cells.cells+8), | |
325 | SCM_PACK (objcode_cells.cells+10), | |
326 | SCM_PACK (objcode_cells.cells+12), | |
327 | SCM_PACK (objcode_cells.cells+14), | |
328 | SCM_PACK (objcode_cells.cells+16), | |
329 | ||
330 | /* 3 arguments */ | |
331 | SCM_PACK (objcode_cells.cells+18), | |
332 | SCM_PACK (objcode_cells.cells+20), | |
333 | SCM_PACK (objcode_cells.cells+22), | |
334 | SCM_PACK (objcode_cells.cells+24), | |
335 | SCM_PACK (objcode_cells.cells+26), | |
336 | SCM_PACK (objcode_cells.cells+28), | |
337 | SCM_PACK (objcode_cells.cells+30) | |
338 | }; | |
339 | ||
340 | /* (nargs * nargs) + nopt + rest * (nargs + 1) */ | |
341 | #define SCM_SMOB_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \ | |
342 | scm_smob_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \ | |
343 | + nopt + rest * (nreq + nopt + rest + 1)] | |
cb1c46c5 KN |
344 | |
345 | static SCM | |
75c3ed28 AW |
346 | scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt, |
347 | unsigned int rest) | |
cb1c46c5 | 348 | { |
75c3ed28 AW |
349 | if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3)) |
350 | scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest)); | |
351 | ||
352 | return SCM_SMOB_OBJCODE_TRAMPOLINE (nreq, nopt, rest); | |
cb1c46c5 KN |
353 | } |
354 | ||
355 | \f | |
7a7f7c53 | 356 | |
92c2555f | 357 | scm_t_bits |
da0e6c2b | 358 | scm_make_smob_type (char const *name, size_t size) |
7a7f7c53 | 359 | #define FUNC_NAME "scm_make_smob_type" |
0f2d19dd | 360 | { |
c014a02e | 361 | long new_smob; |
7a7f7c53 | 362 | |
9de87eea | 363 | SCM_CRITICAL_SECTION_START; |
7a7f7c53 DH |
364 | new_smob = scm_numsmob; |
365 | if (scm_numsmob != MAX_SMOB_COUNT) | |
366 | ++scm_numsmob; | |
9de87eea | 367 | SCM_CRITICAL_SECTION_END; |
7a7f7c53 DH |
368 | |
369 | if (new_smob == MAX_SMOB_COUNT) | |
370 | scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL); | |
371 | ||
372 | scm_smobs[new_smob].name = name; | |
3051344b | 373 | scm_smobs[new_smob].size = size; |
7a7f7c53 | 374 | |
d7ec6b9f | 375 | /* Make a class object if Goops is present. */ |
47455469 | 376 | if (SCM_UNPACK (scm_smob_class[0]) != 0) |
74b6d6e4 | 377 | scm_smob_class[new_smob] = scm_make_extended_class (name, 0); |
7a7f7c53 DH |
378 | |
379 | return scm_tc7_smob + new_smob * 256; | |
0f2d19dd | 380 | } |
7a7f7c53 DH |
381 | #undef FUNC_NAME |
382 | ||
0f2d19dd | 383 | |
9dd5943c | 384 | void |
92c2555f | 385 | scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM)) |
9dd5943c MD |
386 | { |
387 | scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark; | |
388 | } | |
389 | ||
390 | void | |
92c2555f | 391 | scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM)) |
9dd5943c MD |
392 | { |
393 | scm_smobs[SCM_TC2SMOBNUM (tc)].free = free; | |
394 | } | |
395 | ||
396 | void | |
92c2555f | 397 | scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*)) |
9dd5943c MD |
398 | { |
399 | scm_smobs[SCM_TC2SMOBNUM (tc)].print = print; | |
400 | } | |
401 | ||
402 | void | |
92c2555f | 403 | scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) |
9dd5943c MD |
404 | { |
405 | scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp; | |
406 | } | |
407 | ||
0717dfd8 | 408 | void |
92c2555f | 409 | scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), |
7c58e21b | 410 | unsigned int req, unsigned int opt, unsigned int rst) |
0717dfd8 | 411 | { |
75c3ed28 AW |
412 | scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; |
413 | scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode | |
414 | = scm_smob_objcode_trampoline (req, opt, rst); | |
cb1c46c5 | 415 | |
75c3ed28 AW |
416 | if (SCM_UNPACK (scm_smob_class[0]) != 0) |
417 | scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]); | |
418 | } | |
cb1c46c5 | 419 | |
75c3ed28 | 420 | static SCM tramp_weak_map = SCM_BOOL_F; |
c0937f09 | 421 | |
75c3ed28 AW |
422 | SCM |
423 | scm_i_smob_apply_trampoline (SCM smob) | |
424 | { | |
c0937f09 AW |
425 | SCM tramp; |
426 | ||
203a92b6 | 427 | tramp = scm_weak_table_refq (tramp_weak_map, smob, SCM_BOOL_F); |
cb1c46c5 | 428 | |
75c3ed28 AW |
429 | if (scm_is_true (tramp)) |
430 | return tramp; | |
431 | else | |
cb1c46c5 | 432 | { |
75c3ed28 AW |
433 | const char *name; |
434 | SCM objtable; | |
435 | ||
436 | name = SCM_SMOBNAME (SCM_SMOBNUM (smob)); | |
437 | if (!name) | |
438 | name = "smob-apply"; | |
439 | objtable = scm_c_make_vector (2, SCM_UNDEFINED); | |
440 | SCM_SIMPLE_VECTOR_SET (objtable, 0, smob); | |
441 | SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name)); | |
442 | tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode, | |
443 | objtable, SCM_BOOL_F); | |
c0937f09 AW |
444 | |
445 | /* Race conditions (between the ref and this set!) cannot cause | |
446 | any harm here. */ | |
203a92b6 | 447 | scm_weak_table_putq_x (tramp_weak_map, smob, tramp); |
75c3ed28 | 448 | return tramp; |
cb1c46c5 | 449 | } |
0717dfd8 KN |
450 | } |
451 | ||
9dd5943c | 452 | SCM |
92c2555f | 453 | scm_make_smob (scm_t_bits tc) |
9dd5943c | 454 | { |
4a6a4b49 | 455 | scm_t_bits n = SCM_TC2SMOBNUM (tc); |
1be6b49c | 456 | size_t size = scm_smobs[n].size; |
16d4699b | 457 | scm_t_bits data = (size > 0 |
4c9419ac | 458 | ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n)) |
16d4699b | 459 | : 0); |
4a6a4b49 LC |
460 | |
461 | SCM_RETURN_NEWSMOB (tc, data); | |
9dd5943c MD |
462 | } |
463 | ||
ceef3208 | 464 | |
378f2625 LC |
465 | \f |
466 | /* Marking SMOBs using user-supplied mark procedures. */ | |
467 | ||
378f2625 | 468 | |
1f7de769 LC |
469 | /* The GC kind used for SMOB types that provide a custom mark procedure. */ |
470 | static int smob_gc_kind; | |
378f2625 | 471 | |
378f2625 | 472 | |
27583e74 AW |
473 | /* The generic SMOB mark procedure that gets called for SMOBs allocated |
474 | with smob_gc_kind. */ | |
378f2625 LC |
475 | static struct GC_ms_entry * |
476 | smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, | |
477 | struct GC_ms_entry *mark_stack_limit, GC_word env) | |
478 | { | |
479 | register SCM cell; | |
194c0a3e LC |
480 | register scm_t_bits tc, smobnum; |
481 | ||
21041372 | 482 | cell = SCM_PACK_POINTER (addr); |
194c0a3e LC |
483 | |
484 | if (SCM_TYP7 (cell) != scm_tc7_smob) | |
485 | /* It is likely that the GC passed us a pointer to a free-list element | |
486 | which we must ignore (see warning in `gc/gc_mark.h'). */ | |
487 | return mark_stack_ptr; | |
378f2625 | 488 | |
378f2625 LC |
489 | tc = SCM_CELL_WORD_0 (cell); |
490 | smobnum = SCM_TC2SMOBNUM (tc); | |
491 | ||
492 | if (smobnum >= scm_numsmob) | |
194c0a3e | 493 | /* The first word looks corrupt. */ |
378f2625 LC |
494 | abort (); |
495 | ||
378f2625 LC |
496 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)), |
497 | mark_stack_ptr, | |
498 | mark_stack_limit, NULL); | |
499 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)), | |
500 | mark_stack_ptr, | |
501 | mark_stack_limit, NULL); | |
502 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)), | |
503 | mark_stack_ptr, | |
504 | mark_stack_limit, NULL); | |
505 | ||
506 | if (scm_smobs[smobnum].mark) | |
507 | { | |
508 | SCM obj; | |
509 | ||
510 | SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; | |
511 | SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit; | |
512 | ||
513 | /* Invoke the SMOB's mark procedure, which will in turn invoke | |
514 | `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */ | |
515 | obj = scm_smobs[smobnum].mark (cell); | |
516 | ||
517 | mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr; | |
518 | ||
8c5bb729 | 519 | if (SCM_HEAP_OBJECT_P (obj)) |
378f2625 LC |
520 | /* Mark the returned object. */ |
521 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj), | |
522 | mark_stack_ptr, | |
523 | mark_stack_limit, NULL); | |
524 | ||
525 | SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL; | |
526 | SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL; | |
527 | } | |
528 | ||
529 | return mark_stack_ptr; | |
530 | ||
531 | } | |
532 | ||
533 | /* Mark object O. We assume that this function is only called during the | |
534 | mark phase, i.e., from within `smob_mark ()' or one of its | |
535 | descendents. */ | |
536 | void | |
537 | scm_gc_mark (SCM o) | |
538 | { | |
194c0a3e LC |
539 | #define CURRENT_MARK_PTR \ |
540 | ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr)) | |
541 | #define CURRENT_MARK_LIMIT \ | |
542 | ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit)) | |
543 | ||
8c5bb729 | 544 | if (SCM_HEAP_OBJECT_P (o)) |
378f2625 LC |
545 | { |
546 | /* At this point, the `current_mark_*' fields of the current thread | |
547 | must be defined (they are set in `smob_mark ()'). */ | |
548 | register struct GC_ms_entry *mark_stack_ptr; | |
549 | ||
550 | if (!CURRENT_MARK_PTR) | |
551 | /* The function was not called from a mark procedure. */ | |
552 | abort (); | |
553 | ||
554 | mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o), | |
555 | CURRENT_MARK_PTR, CURRENT_MARK_LIMIT, | |
556 | NULL); | |
557 | SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; | |
558 | } | |
194c0a3e LC |
559 | #undef CURRENT_MARK_PTR |
560 | #undef CURRENT_MARK_LIMIT | |
378f2625 LC |
561 | } |
562 | ||
e9d635e5 LC |
563 | \f |
564 | /* Finalize SMOB by calling its SMOB type's free function, if any. */ | |
27583e74 AW |
565 | static void |
566 | finalize_smob (GC_PTR ptr, GC_PTR data) | |
e9d635e5 | 567 | { |
10fb3386 | 568 | SCM smob; |
e9d635e5 LC |
569 | size_t (* free_smob) (SCM); |
570 | ||
21041372 | 571 | smob = SCM_PACK_POINTER (ptr); |
10fb3386 LC |
572 | #if 0 |
573 | printf ("finalizing SMOB %p (smobnum: %u)\n", | |
574 | ptr, SCM_SMOBNUM (smob)); | |
575 | #endif | |
576 | ||
e9d635e5 LC |
577 | free_smob = scm_smobs[SCM_SMOBNUM (smob)].free; |
578 | if (free_smob) | |
579 | free_smob (smob); | |
e9d635e5 | 580 | } |
378f2625 | 581 | |
27583e74 AW |
582 | /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may |
583 | provide a custom mark procedure and it will be honored. */ | |
584 | SCM | |
585 | scm_i_new_smob (scm_t_bits tc, scm_t_bits data) | |
586 | { | |
587 | scm_t_bits smobnum = SCM_TC2SMOBNUM (tc); | |
588 | SCM ret; | |
589 | ||
590 | /* Use the smob_gc_kind if needed to allow the mark procedure to | |
591 | run. Since the marker only deals with double cells, that case | |
592 | allocates a double cell. We leave words 2 and 3 to there initial | |
593 | values, which is 0. */ | |
594 | if (scm_smobs [smobnum].mark) | |
21041372 | 595 | ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind)); |
27583e74 | 596 | else |
21041372 | 597 | ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell))); |
27583e74 AW |
598 | |
599 | SCM_SET_CELL_WORD_1 (ret, data); | |
600 | SCM_SET_CELL_WORD_0 (ret, tc); | |
601 | ||
602 | if (scm_smobs[smobnum].free) | |
603 | { | |
604 | GC_finalization_proc prev_finalizer; | |
605 | GC_PTR prev_finalizer_data; | |
606 | ||
47ed8656 | 607 | GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret), |
27583e74 AW |
608 | finalize_smob, NULL, |
609 | &prev_finalizer, &prev_finalizer_data); | |
610 | } | |
611 | ||
612 | return ret; | |
613 | } | |
614 | ||
615 | /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may | |
616 | provide a custom mark procedure and it will be honored. */ | |
617 | SCM | |
618 | scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1, | |
619 | scm_t_bits data2, scm_t_bits data3) | |
620 | { | |
621 | scm_t_bits smobnum = SCM_TC2SMOBNUM (tc); | |
622 | SCM ret; | |
623 | ||
624 | /* Use the smob_gc_kind if needed to allow the mark procedure to | |
625 | run. */ | |
626 | if (scm_smobs [smobnum].mark) | |
21041372 | 627 | ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind)); |
27583e74 | 628 | else |
21041372 | 629 | ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell))); |
27583e74 AW |
630 | |
631 | SCM_SET_CELL_WORD_3 (ret, data3); | |
632 | SCM_SET_CELL_WORD_2 (ret, data2); | |
633 | SCM_SET_CELL_WORD_1 (ret, data1); | |
634 | SCM_SET_CELL_WORD_0 (ret, tc); | |
635 | ||
636 | if (scm_smobs[smobnum].free) | |
637 | { | |
638 | GC_finalization_proc prev_finalizer; | |
639 | GC_PTR prev_finalizer_data; | |
640 | ||
47ed8656 | 641 | GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret), |
27583e74 AW |
642 | finalize_smob, NULL, |
643 | &prev_finalizer, &prev_finalizer_data); | |
644 | } | |
645 | ||
646 | return ret; | |
647 | } | |
648 | ||
378f2625 | 649 | \f |
0f2d19dd JB |
650 | void |
651 | scm_smob_prehistory () | |
0f2d19dd | 652 | { |
c014a02e | 653 | long i; |
e841c3e0 | 654 | |
1f7de769 | 655 | smob_gc_kind = GC_new_kind (GC_new_free_list (), |
378f2625 | 656 | GC_MAKE_PROC (GC_new_proc (smob_mark), 0), |
62779634 LC |
657 | 0, |
658 | /* Clear new objects. As of version 7.1, libgc | |
659 | doesn't seem to support passing 0 here. */ | |
660 | 1); | |
378f2625 | 661 | |
0f2d19dd | 662 | scm_numsmob = 0; |
7a7f7c53 DH |
663 | for (i = 0; i < MAX_SMOB_COUNT; ++i) |
664 | { | |
665 | scm_smobs[i].name = 0; | |
666 | scm_smobs[i].size = 0; | |
667 | scm_smobs[i].mark = 0; | |
668 | scm_smobs[i].free = 0; | |
669 | scm_smobs[i].print = scm_smob_print; | |
670 | scm_smobs[i].equalp = 0; | |
671 | scm_smobs[i].apply = 0; | |
75c3ed28 | 672 | scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F; |
7a7f7c53 | 673 | } |
75c3ed28 | 674 | |
203a92b6 | 675 | tramp_weak_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); |
0f2d19dd | 676 | } |
89e00824 ML |
677 | |
678 | /* | |
679 | Local Variables: | |
680 | c-file-style: "gnu" | |
681 | End: | |
682 | */ |