libguile/smob.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010 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 ("#<", port);
 112   scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 113   scm_putc (' ', 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 ('>', 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_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
 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 SCM
 422 scm_i_smob_apply_trampoline (SCM smob)
 423 {
 424   /* could use hashq-create-handle!, but i don't know what to do if it returns a
 425      weak pair */
 426   SCM tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
 427
 428   if (scm_is_true (tramp))
 429     return tramp;
 430   else
 431     {
 432       const char *name;
 433       SCM objtable;
 434
 435       name = SCM_SMOBNAME (SCM_SMOBNUM (smob));
 436       if (!name)
 437         name = "smob-apply";
 438       objtable = scm_c_make_vector (2, SCM_UNDEFINED);
 439       SCM_SIMPLE_VECTOR_SET (objtable, 0, smob);
 440       SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
 441       tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
 442                                 objtable, SCM_BOOL_F);
 443       scm_hashq_set_x (tramp_weak_map, smob, tramp);
 444       return tramp;
 445     }
 446 }
 447
 448 SCM
 449 scm_make_smob (scm_t_bits tc)
 450 {
 451   scm_t_bits n = SCM_TC2SMOBNUM (tc);
 452   size_t size = scm_smobs[n].size;
 453   scm_t_bits data = (size > 0
 454                      ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
 455                      : 0);
 456
 457   SCM_RETURN_NEWSMOB (tc, data);
 458 }
 459
 460
 461 \f
 462 /* Marking SMOBs using user-supplied mark procedures.  */
 463
 464
 465 /* The GC kind used for SMOB types that provide a custom mark procedure.  */
 466 static int smob_gc_kind;
 467
 468
 469 /* The generic SMOB mark procedure that gets called for SMOBs allocated with
 470    `scm_i_new_smob_with_mark_proc ()'.  */
 471 static struct GC_ms_entry *
 472 smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 473            struct GC_ms_entry *mark_stack_limit, GC_word env)
 474 {
 475   register SCM cell;
 476   register scm_t_bits tc, smobnum;
 477
 478   cell = PTR2SCM (addr);
 479
 480   if (SCM_TYP7 (cell) != scm_tc7_smob)
 481     /* It is likely that the GC passed us a pointer to a free-list element
 482        which we must ignore (see warning in `gc/gc_mark.h').  */
 483     return mark_stack_ptr;
 484
 485   tc = SCM_CELL_WORD_0 (cell);
 486   smobnum = SCM_TC2SMOBNUM (tc);
 487
 488   if (smobnum >= scm_numsmob)
 489     /* The first word looks corrupt.  */
 490     abort ();
 491
 492   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
 493                                      mark_stack_ptr,
 494                                      mark_stack_limit, NULL);
 495   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
 496                                      mark_stack_ptr,
 497                                      mark_stack_limit, NULL);
 498   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
 499                                      mark_stack_ptr,
 500                                      mark_stack_limit, NULL);
 501
 502   if (scm_smobs[smobnum].mark)
 503     {
 504       SCM obj;
 505
 506       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 507       SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
 508
 509       /* Invoke the SMOB's mark procedure, which will in turn invoke
 510          `scm_gc_mark ()', which may modify `current_mark_stack_ptr'.  */
 511       obj = scm_smobs[smobnum].mark (cell);
 512
 513       mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
 514
 515       if (SCM_NIMP (obj))
 516         /* Mark the returned object.  */
 517         mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
 518                                            mark_stack_ptr,
 519                                            mark_stack_limit, NULL);
 520
 521       SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
 522       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
 523     }
 524
 525   return mark_stack_ptr;
 526
 527 }
 528
 529 /* Mark object O.  We assume that this function is only called during the
 530    mark phase, i.e., from within `smob_mark ()' or one of its
 531    descendents.  */
 532 void
 533 scm_gc_mark (SCM o)
 534 {
 535 #define CURRENT_MARK_PTR                                                 \
 536   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
 537 #define CURRENT_MARK_LIMIT                                                 \
 538   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
 539
 540   if (SCM_NIMP (o))
 541     {
 542       /* At this point, the `current_mark_*' fields of the current thread
 543          must be defined (they are set in `smob_mark ()').  */
 544       register struct GC_ms_entry *mark_stack_ptr;
 545
 546       if (!CURRENT_MARK_PTR)
 547         /* The function was not called from a mark procedure.  */
 548         abort ();
 549
 550       mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
 551                                          CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
 552                                          NULL);
 553       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 554     }
 555 #undef CURRENT_MARK_PTR
 556 #undef CURRENT_MARK_LIMIT
 557 }
 558
 559 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 560    provide a custom mark procedure and it will be honored.  */
 561 SCM
 562 scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1,
 563                                scm_t_bits data2, scm_t_bits data3)
 564 {
 565   /* Return a double cell.  */
 566   SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell),
 567                                           smob_gc_kind));
 568
 569   SCM_SET_CELL_WORD_3 (cell, data3);
 570   SCM_SET_CELL_WORD_2 (cell, data2);
 571   SCM_SET_CELL_WORD_1 (cell, data1);
 572   SCM_SET_CELL_WORD_0 (cell, tc);
 573
 574   return cell;
 575 }
 576
 577 \f
 578 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 579 void
 580 scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
 581 {
 582   SCM smob;
 583   size_t (* free_smob) (SCM);
 584
 585   smob = PTR2SCM (ptr);
 586 #if 0
 587   printf ("finalizing SMOB %p (smobnum: %u)\n",
 588           ptr, SCM_SMOBNUM (smob));
 589 #endif
 590
 591   free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
 592   if (free_smob)
 593     free_smob (smob);
 594 }
 595
 596 \f
 597 void
 598 scm_smob_prehistory ()
 599 {
 600   long i;
 601
 602   smob_gc_kind = GC_new_kind (GC_new_free_list (),
 603                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 604                               0,
 605                               /* Clear new objects.  As of version 7.1, libgc
 606                                  doesn't seem to support passing 0 here.  */
 607                               1);
 608
 609   scm_numsmob = 0;
 610   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 611     {
 612       scm_smobs[i].name       = 0;
 613       scm_smobs[i].size       = 0;
 614       scm_smobs[i].mark       = 0;
 615       scm_smobs[i].free       = 0;
 616       scm_smobs[i].print      = scm_smob_print;
 617       scm_smobs[i].equalp     = 0;
 618       scm_smobs[i].apply      = 0;
 619       scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
 620     }
 621
 622   tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 623 }
 624
 625 /*
 626   Local Variables:
 627   c-file-style: "gnu"
 628   End:
 629 */