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