libguile/smob.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   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.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * 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.
  12  *
  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
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include <stdio.h>
  26 #include <errno.h>
  27
  28 #include "libguile/_scm.h"
  29
  30 #include "libguile/async.h"
  31 #include "libguile/goops.h"
  32 #include "libguile/instructions.h"
  33 #include "libguile/objcodes.h"
  34 #include "libguile/programs.h"
  35
  36 #ifdef HAVE_MALLOC_H
  37 #include <malloc.h>
  38 #endif
  39
  40 #include "libguile/smob.h"
  41
  42 #include "libguile/bdw-gc.h"
  43 #include <gc/gc_mark.h>
  44
  45
  46 \f
  47
  48 /* scm_smobs scm_numsmob
  49  * implement a fixed sized array of smob records.
  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  */
  53
  54 #define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT
  55
  56 long scm_numsmob;
  57 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
  58
  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
  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
  80 scm_mark0 (SCM ptr SCM_UNUSED)
  81 {
  82   return SCM_BOOL_F;
  83 }
  84
  85 SCM
  86 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
  87    be used for real pairs. */
  88 scm_markcdr (SCM ptr)
  89 {
  90   return SCM_CELL_OBJECT_1 (ptr);
  91 }
  92
  93 \f
  94 /* {Free}
  95  */
  96
  97 size_t
  98 scm_free0 (SCM ptr SCM_UNUSED)
  99 {
 100   return 0;
 101 }
 102
 103 \f
 104 /* {Print}
 105  */
 106
 107 int
 108 scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 109 {
 110   long n = SCM_SMOBNUM (exp);
 111   scm_puts_unlocked ("#<", port);
 112   scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 113   scm_putc_unlocked (' ', port);
 114   if (scm_smobs[n].size)
 115     scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
 116   else
 117     scm_uintprint (SCM_UNPACK (exp), 16, port);
 118   scm_putc_unlocked ('>', port);
 119   return 1;
 120 }
 121
 122 \f
 123 /* {Apply}
 124  */
 125
 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
 133
 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                                      \
 258   SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
 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)]
 344
 345 static SCM
 346 scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
 347                              unsigned int rest)
 348 {
 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);
 353 }
 354
 355 \f
 356
 357 scm_t_bits
 358 scm_make_smob_type (char const *name, size_t size)
 359 #define FUNC_NAME "scm_make_smob_type"
 360 {
 361   long new_smob;
 362
 363   SCM_CRITICAL_SECTION_START;
 364   new_smob = scm_numsmob;
 365   if (scm_numsmob != MAX_SMOB_COUNT)
 366     ++scm_numsmob;
 367   SCM_CRITICAL_SECTION_END;
 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;
 373   scm_smobs[new_smob].size = size;
 374
 375   /* Make a class object if Goops is present. */
 376   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 377     scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
 378
 379   return scm_tc7_smob + new_smob * 256;
 380 }
 381 #undef FUNC_NAME
 382
 383
 384 void
 385 scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
 386 {
 387   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 388 }
 389
 390 void
 391 scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
 392 {
 393   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 394 }
 395
 396 void
 397 scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
 398 {
 399   scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
 400 }
 401
 402 void
 403 scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
 404 {
 405   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 406 }
 407
 408 void
 409 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
 410                     unsigned int req, unsigned int opt, unsigned int rst)
 411 {
 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);
 415
 416   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 417     scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
 418 }
 419
 420 static SCM tramp_weak_map = SCM_BOOL_F;
 421
 422 SCM
 423 scm_i_smob_apply_trampoline (SCM smob)
 424 {
 425   SCM tramp;
 426
 427   tramp = scm_weak_table_refq (tramp_weak_map, smob, SCM_BOOL_F);
 428
 429   if (scm_is_true (tramp))
 430     return tramp;
 431   else
 432     {
 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_utf8_symbol (name));
 442       tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
 443                                 objtable, SCM_BOOL_F);
 444
 445       /* Race conditions (between the ref and this set!) cannot cause
 446          any harm here.  */
 447       scm_weak_table_putq_x (tramp_weak_map, smob, tramp);
 448       return tramp;
 449     }
 450 }
 451
 452 SCM
 453 scm_make_smob (scm_t_bits tc)
 454 {
 455   scm_t_bits n = SCM_TC2SMOBNUM (tc);
 456   size_t size = scm_smobs[n].size;
 457   scm_t_bits data = (size > 0
 458                      ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
 459                      : 0);
 460
 461   SCM_RETURN_NEWSMOB (tc, data);
 462 }
 463
 464
 465 \f
 466 /* Marking SMOBs using user-supplied mark procedures.  */
 467
 468
 469 /* The GC kind used for SMOB types that provide a custom mark procedure.  */
 470 static int smob_gc_kind;
 471
 472
 473 /* The generic SMOB mark procedure that gets called for SMOBs allocated
 474    with smob_gc_kind.  */
 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;
 480   register scm_t_bits tc, smobnum;
 481
 482   cell = SCM_PACK_POINTER (addr);
 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;
 488
 489   tc = SCM_CELL_WORD_0 (cell);
 490   smobnum = SCM_TC2SMOBNUM (tc);
 491
 492   if (smobnum >= scm_numsmob)
 493     /* The first word looks corrupt.  */
 494     abort ();
 495
 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
 519       if (SCM_HEAP_OBJECT_P (obj))
 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 {
 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
 544   if (SCM_HEAP_OBJECT_P (o))
 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     }
 559 #undef CURRENT_MARK_PTR
 560 #undef CURRENT_MARK_LIMIT
 561 }
 562
 563 \f
 564 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 565 static void
 566 finalize_smob (GC_PTR ptr, GC_PTR data)
 567 {
 568   SCM smob;
 569   size_t (* free_smob) (SCM);
 570
 571   smob = SCM_PACK_POINTER (ptr);
 572 #if 0
 573   printf ("finalizing SMOB %p (smobnum: %u)\n",
 574           ptr, SCM_SMOBNUM (smob));
 575 #endif
 576
 577   free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
 578   if (free_smob)
 579     free_smob (smob);
 580 }
 581
 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)
 595     ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
 596   else
 597     ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
 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
 607       GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret),
 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)
 627     ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
 628   else
 629     ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
 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
 641       GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret),
 642                                       finalize_smob, NULL,
 643                                       &prev_finalizer, &prev_finalizer_data);
 644     }
 645
 646   return ret;
 647 }
 648
 649 \f
 650 void
 651 scm_smob_prehistory ()
 652 {
 653   long i;
 654
 655   smob_gc_kind = GC_new_kind (GC_new_free_list (),
 656                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 657                               0,
 658                               /* Clear new objects.  As of version 7.1, libgc
 659                                  doesn't seem to support passing 0 here.  */
 660                               1);
 661
 662   scm_numsmob = 0;
 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;
 672       scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
 673     }
 674
 675   tramp_weak_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 676 }
 677
 678 /*
 679   Local Variables:
 680   c-file-style: "gnu"
 681   End:
 682 */