1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
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.
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.
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
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
27 #include "libguile/_scm.h"
29 #include "libguile/async.h"
30 #include "libguile/objects.h"
31 #include "libguile/goops.h"
32 #include "libguile/ports.h"
38 #include "libguile/smob.h"
42 /* scm_smobs scm_numsmob
43 * implement a fixed sized array of smob records.
44 * Indexes into this table are used when generating type
45 * tags for smobjects (if you know a tag you can get an index and conversely).
48 #define MAX_SMOB_COUNT 256
50 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
52 /* Lower 16 bit of data must be zero.
55 scm_i_set_smob_flags (SCM x, scm_t_bits data)
57 SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
61 scm_assert_smob_type (scm_t_bits tag, SCM val)
63 if (!SCM_SMOB_PREDICATE (tag, val))
64 scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
70 /* This function is vestigial. It used to be the mark function's
71 responsibility to set the mark bit on the smob or port, but now the
72 generic marking routine in gc.c takes care of that, and a zero
73 pointer for a mark function means "don't bother". So you never
76 However, we leave it here because it's harmless to call it, and
77 people out there have smob code that uses it, and there's no reason
78 to make their links fail. */
81 scm_mark0 (SCM ptr SCM_UNUSED)
87 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
88 be used for real pairs. */
91 return SCM_CELL_OBJECT_1 (ptr);
98 scm_free0 (SCM ptr SCM_UNUSED)
104 scm_smob_free (SCM obj)
106 long n = SCM_SMOBNUM (obj);
107 if (scm_smobs[n].size > 0)
108 scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
109 scm_smobs[n].size, SCM_SMOBNAME (n));
117 scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
119 long n = SCM_SMOBNUM (exp);
120 scm_puts ("#<", port);
121 scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
122 scm_putc (' ', port);
123 if (scm_smobs[n].size)
124 scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
126 scm_uintprint (SCM_UNPACK (exp), 16, port);
127 scm_putc ('>', port);
134 #define SCM_SMOB_APPLY0(SMOB) \
135 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
136 #define SCM_SMOB_APPLY1(SMOB, A1) \
137 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
138 #define SCM_SMOB_APPLY2(SMOB, A1, A2) \
139 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
140 #define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
141 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
144 scm_smob_apply_0_010 (SCM smob)
146 return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
150 scm_smob_apply_0_020 (SCM smob)
152 return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
156 scm_smob_apply_0_030 (SCM smob)
158 return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
162 scm_smob_apply_0_001 (SCM smob)
164 return SCM_SMOB_APPLY1 (smob, SCM_EOL);
168 scm_smob_apply_0_011 (SCM smob)
170 return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
174 scm_smob_apply_0_021 (SCM smob)
176 return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
180 scm_smob_apply_0_error (SCM smob)
182 scm_wrong_num_args (smob);
186 scm_smob_apply_1_020 (SCM smob, SCM a1)
188 return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
192 scm_smob_apply_1_030 (SCM smob, SCM a1)
194 return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
198 scm_smob_apply_1_001 (SCM smob, SCM a1)
200 return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
204 scm_smob_apply_1_011 (SCM smob, SCM a1)
206 return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
210 scm_smob_apply_1_021 (SCM smob, SCM a1)
212 return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
216 scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
218 scm_wrong_num_args (smob);
222 scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
224 return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
228 scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
230 return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
234 scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
236 return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
240 scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
242 return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
246 scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
248 scm_wrong_num_args (smob);
252 scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
254 if (!scm_is_null (SCM_CDR (rst)))
255 scm_wrong_num_args (smob);
256 return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
260 scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
262 return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
266 scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
268 return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
272 scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
274 return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
278 scm_smob_apply_3_error (SCM smob,
283 scm_wrong_num_args (smob);
289 scm_make_smob_type (char const *name, size_t size)
290 #define FUNC_NAME "scm_make_smob_type"
294 SCM_CRITICAL_SECTION_START;
295 new_smob = scm_numsmob;
296 if (scm_numsmob != MAX_SMOB_COUNT)
298 SCM_CRITICAL_SECTION_END;
300 if (new_smob == MAX_SMOB_COUNT)
301 scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
303 scm_smobs[new_smob].name = name;
306 scm_smobs[new_smob].size = size;
307 scm_smobs[new_smob].free = scm_smob_free;
310 /* Make a class object if Goops is present. */
312 scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
314 return scm_tc7_smob + new_smob * 256;
320 scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
322 scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
326 scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
328 scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
332 scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
334 scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
338 scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
340 scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
344 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
345 unsigned int req, unsigned int opt, unsigned int rst)
347 SCM (*apply_0) (SCM);
348 SCM (*apply_1) (SCM, SCM);
349 SCM (*apply_2) (SCM, SCM, SCM);
350 SCM (*apply_3) (SCM, SCM, SCM, SCM);
351 int type = SCM_GSUBR_MAKTYPE (req, opt, rst);
353 if (rst > 1 || req + opt + rst > 3)
355 puts ("Unsupported smob application type");
361 case SCM_GSUBR_MAKTYPE (0, 0, 0):
362 apply_0 = apply; break;
363 case SCM_GSUBR_MAKTYPE (0, 1, 0):
364 apply_0 = scm_smob_apply_0_010; break;
365 case SCM_GSUBR_MAKTYPE (0, 2, 0):
366 apply_0 = scm_smob_apply_0_020; break;
367 case SCM_GSUBR_MAKTYPE (0, 3, 0):
368 apply_0 = scm_smob_apply_0_030; break;
369 case SCM_GSUBR_MAKTYPE (0, 0, 1):
370 apply_0 = scm_smob_apply_0_001; break;
371 case SCM_GSUBR_MAKTYPE (0, 1, 1):
372 apply_0 = scm_smob_apply_0_011; break;
373 case SCM_GSUBR_MAKTYPE (0, 2, 1):
374 apply_0 = scm_smob_apply_0_021; break;
376 apply_0 = scm_smob_apply_0_error; break;
381 case SCM_GSUBR_MAKTYPE (1, 0, 0):
382 case SCM_GSUBR_MAKTYPE (0, 1, 0):
383 apply_1 = apply; break;
384 case SCM_GSUBR_MAKTYPE (1, 1, 0):
385 case SCM_GSUBR_MAKTYPE (0, 2, 0):
386 apply_1 = scm_smob_apply_1_020; break;
387 case SCM_GSUBR_MAKTYPE (1, 2, 0):
388 case SCM_GSUBR_MAKTYPE (0, 3, 0):
389 apply_1 = scm_smob_apply_1_030; break;
390 case SCM_GSUBR_MAKTYPE (0, 0, 1):
391 apply_1 = scm_smob_apply_1_001; break;
392 case SCM_GSUBR_MAKTYPE (1, 0, 1):
393 case SCM_GSUBR_MAKTYPE (0, 1, 1):
394 apply_1 = scm_smob_apply_1_011; break;
395 case SCM_GSUBR_MAKTYPE (1, 1, 1):
396 case SCM_GSUBR_MAKTYPE (0, 2, 1):
397 apply_1 = scm_smob_apply_1_021; break;
399 apply_1 = scm_smob_apply_1_error; break;
404 case SCM_GSUBR_MAKTYPE (2, 0, 0):
405 case SCM_GSUBR_MAKTYPE (1, 1, 0):
406 case SCM_GSUBR_MAKTYPE (0, 2, 0):
407 apply_2 = apply; break;
408 case SCM_GSUBR_MAKTYPE (2, 1, 0):
409 case SCM_GSUBR_MAKTYPE (1, 2, 0):
410 case SCM_GSUBR_MAKTYPE (0, 3, 0):
411 apply_2 = scm_smob_apply_2_030; break;
412 case SCM_GSUBR_MAKTYPE (0, 0, 1):
413 apply_2 = scm_smob_apply_2_001; break;
414 case SCM_GSUBR_MAKTYPE (1, 0, 1):
415 case SCM_GSUBR_MAKTYPE (0, 1, 1):
416 apply_2 = scm_smob_apply_2_011; break;
417 case SCM_GSUBR_MAKTYPE (2, 0, 1):
418 case SCM_GSUBR_MAKTYPE (1, 1, 1):
419 case SCM_GSUBR_MAKTYPE (0, 2, 1):
420 apply_2 = scm_smob_apply_2_021; break;
422 apply_2 = scm_smob_apply_2_error; break;
427 case SCM_GSUBR_MAKTYPE (3, 0, 0):
428 case SCM_GSUBR_MAKTYPE (2, 1, 0):
429 case SCM_GSUBR_MAKTYPE (1, 2, 0):
430 case SCM_GSUBR_MAKTYPE (0, 3, 0):
431 apply_3 = scm_smob_apply_3_030; break;
432 case SCM_GSUBR_MAKTYPE (0, 0, 1):
433 apply_3 = scm_smob_apply_3_001; break;
434 case SCM_GSUBR_MAKTYPE (1, 0, 1):
435 case SCM_GSUBR_MAKTYPE (0, 1, 1):
436 apply_3 = scm_smob_apply_3_011; break;
437 case SCM_GSUBR_MAKTYPE (2, 0, 1):
438 case SCM_GSUBR_MAKTYPE (1, 1, 1):
439 case SCM_GSUBR_MAKTYPE (0, 2, 1):
440 apply_3 = scm_smob_apply_3_021; break;
442 apply_3 = scm_smob_apply_3_error; break;
445 scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
446 scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
447 scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
448 scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
449 scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
450 scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
453 scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
457 scm_make_smob (scm_t_bits tc)
459 long n = SCM_TC2SMOBNUM (tc);
460 size_t size = scm_smobs[n].size;
461 scm_t_bits data = (size > 0
462 ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
464 return scm_cell (tc, data);
468 /* {Initialization for the type of free cells}
472 free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
475 sprintf (buf, "#<freed cell %p; GC missed a reference>",
476 (void *) SCM_UNPACK (exp));
477 scm_puts (buf, port);
479 #if (SCM_DEBUG_CELL_ACCESSES == 1)
480 if (scm_debug_cell_accesses_p)
489 scm_smob_prehistory ()
495 for (i = 0; i < MAX_SMOB_COUNT; ++i)
497 scm_smobs[i].name = 0;
498 scm_smobs[i].size = 0;
499 scm_smobs[i].mark = 0;
500 scm_smobs[i].free = 0;
501 scm_smobs[i].print = scm_smob_print;
502 scm_smobs[i].equalp = 0;
503 scm_smobs[i].apply = 0;
504 scm_smobs[i].apply_0 = 0;
505 scm_smobs[i].apply_1 = 0;
506 scm_smobs[i].apply_2 = 0;
507 scm_smobs[i].apply_3 = 0;
508 scm_smobs[i].gsubr_type = 0;
511 /* WARNING: This scm_make_smob_type call must be done first. */
512 tc = scm_make_smob_type ("free", 0);
513 scm_set_smob_print (tc, free_print);