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 <stdlib.h>
  27 #include <errno.h>
  28
  29 #include "libguile/_scm.h"
  30
  31 #include "libguile/async.h"
  32 #include "libguile/goops.h"
  33 #include "libguile/instructions.h"
  34 #include "libguile/objcodes.h"
  35 #include "libguile/programs.h"
  36
  37 #include "libguile/smob.h"
  38
  39 #include "libguile/bdw-gc.h"
  40 #include <gc/gc_mark.h>
  41
  42
  43 \f
  44
  45 /* scm_smobs scm_numsmob
  46  * implement a fixed sized array of smob records.
  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  */
  50
  51 #define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT
  52
  53 long scm_numsmob;
  54 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
  55
  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
  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
  77 scm_mark0 (SCM ptr SCM_UNUSED)
  78 {
  79   return SCM_BOOL_F;
  80 }
  81
  82 SCM
  83 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
  84    be used for real pairs. */
  85 scm_markcdr (SCM ptr)
  86 {
  87   return SCM_CELL_OBJECT_1 (ptr);
  88 }
  89
  90 \f
  91 /* {Free}
  92  */
  93
  94 size_t
  95 scm_free0 (SCM ptr SCM_UNUSED)
  96 {
  97   return 0;
  98 }
  99
 100 \f
 101 /* {Print}
 102  */
 103
 104 int
 105 scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 106 {
 107   long n = SCM_SMOBNUM (exp);
 108   scm_puts ("#<", port);
 109   scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 110   scm_putc (' ', port);
 111   if (scm_smobs[n].size)
 112     scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
 113   else
 114     scm_uintprint (SCM_UNPACK (exp), 16, port);
 115   scm_putc ('>', port);
 116   return 1;
 117 }
 118
 119 \f
 120 /* {Apply}
 121  */
 122
 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
 130
 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                                      \
 255   SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
 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)]
 341
 342 static SCM
 343 scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
 344                              unsigned int rest)
 345 {
 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);
 350 }
 351
 352 \f
 353
 354 scm_t_bits
 355 scm_make_smob_type (char const *name, size_t size)
 356 #define FUNC_NAME "scm_make_smob_type"
 357 {
 358   long new_smob;
 359
 360   SCM_CRITICAL_SECTION_START;
 361   new_smob = scm_numsmob;
 362   if (scm_numsmob != MAX_SMOB_COUNT)
 363     ++scm_numsmob;
 364   SCM_CRITICAL_SECTION_END;
 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;
 370   scm_smobs[new_smob].size = size;
 371
 372   /* Make a class object if Goops is present. */
 373   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 374     scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
 375
 376   return scm_tc7_smob + new_smob * 256;
 377 }
 378 #undef FUNC_NAME
 379
 380
 381 void
 382 scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
 383 {
 384   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 385 }
 386
 387 void
 388 scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
 389 {
 390   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 391 }
 392
 393 void
 394 scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
 395 {
 396   scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
 397 }
 398
 399 void
 400 scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
 401 {
 402   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 403 }
 404
 405 void
 406 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
 407                     unsigned int req, unsigned int opt, unsigned int rst)
 408 {
 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);
 412
 413   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 414     scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
 415 }
 416
 417 static SCM tramp_weak_map = SCM_BOOL_F;
 418 static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 419
 420 SCM
 421 scm_i_smob_apply_trampoline (SCM smob)
 422 {
 423   SCM tramp;
 424
 425   scm_i_pthread_mutex_lock (&tramp_lock);
 426   tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
 427   scm_i_pthread_mutex_unlock (&tramp_lock);
 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_locale_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_i_pthread_mutex_lock (&tramp_lock);
 448       scm_hashq_set_x (tramp_weak_map, smob, tramp);
 449       scm_i_pthread_mutex_unlock (&tramp_lock);
 450       return tramp;
 451     }
 452 }
 453
 454 SCM
 455 scm_make_smob (scm_t_bits tc)
 456 {
 457   scm_t_bits n = SCM_TC2SMOBNUM (tc);
 458   size_t size = scm_smobs[n].size;
 459   scm_t_bits data = (size > 0
 460                      ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
 461                      : 0);
 462
 463   SCM_RETURN_NEWSMOB (tc, data);
 464 }
 465
 466
 467 \f
 468 /* Marking SMOBs using user-supplied mark procedures.  */
 469
 470
 471 /* The GC kind used for SMOB types that provide a custom mark procedure.  */
 472 static int smob_gc_kind;
 473
 474
 475 /* The generic SMOB mark procedure that gets called for SMOBs allocated with
 476    `scm_i_new_smob_with_mark_proc ()'.  */
 477 static struct GC_ms_entry *
 478 smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 479            struct GC_ms_entry *mark_stack_limit, GC_word env)
 480 {
 481   register SCM cell;
 482   register scm_t_bits tc, smobnum;
 483
 484   cell = PTR2SCM (addr);
 485
 486   if (SCM_TYP7 (cell) != scm_tc7_smob)
 487     /* It is likely that the GC passed us a pointer to a free-list element
 488        which we must ignore (see warning in `gc/gc_mark.h').  */
 489     return mark_stack_ptr;
 490
 491   tc = SCM_CELL_WORD_0 (cell);
 492   smobnum = SCM_TC2SMOBNUM (tc);
 493
 494   if (smobnum >= scm_numsmob)
 495     /* The first word looks corrupt.  */
 496     abort ();
 497
 498   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
 499                                      mark_stack_ptr,
 500                                      mark_stack_limit, NULL);
 501   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
 502                                      mark_stack_ptr,
 503                                      mark_stack_limit, NULL);
 504   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
 505                                      mark_stack_ptr,
 506                                      mark_stack_limit, NULL);
 507
 508   if (scm_smobs[smobnum].mark)
 509     {
 510       SCM obj;
 511
 512       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 513       SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
 514
 515       /* Invoke the SMOB's mark procedure, which will in turn invoke
 516          `scm_gc_mark ()', which may modify `current_mark_stack_ptr'.  */
 517       obj = scm_smobs[smobnum].mark (cell);
 518
 519       mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
 520
 521       if (SCM_NIMP (obj))
 522         /* Mark the returned object.  */
 523         mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
 524                                            mark_stack_ptr,
 525                                            mark_stack_limit, NULL);
 526
 527       SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
 528       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
 529     }
 530
 531   return mark_stack_ptr;
 532
 533 }
 534
 535 /* Mark object O.  We assume that this function is only called during the
 536    mark phase, i.e., from within `smob_mark ()' or one of its
 537    descendents.  */
 538 void
 539 scm_gc_mark (SCM o)
 540 {
 541 #define CURRENT_MARK_PTR                                                 \
 542   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
 543 #define CURRENT_MARK_LIMIT                                                 \
 544   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
 545
 546   if (SCM_NIMP (o))
 547     {
 548       /* At this point, the `current_mark_*' fields of the current thread
 549          must be defined (they are set in `smob_mark ()').  */
 550       register struct GC_ms_entry *mark_stack_ptr;
 551
 552       if (!CURRENT_MARK_PTR)
 553         /* The function was not called from a mark procedure.  */
 554         abort ();
 555
 556       mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
 557                                          CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
 558                                          NULL);
 559       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 560     }
 561 #undef CURRENT_MARK_PTR
 562 #undef CURRENT_MARK_LIMIT
 563 }
 564
 565 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 566    provide a custom mark procedure and it will be honored.  */
 567 SCM
 568 scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1,
 569                                scm_t_bits data2, scm_t_bits data3)
 570 {
 571   /* Return a double cell.  */
 572   SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell),
 573                                           smob_gc_kind));
 574
 575   SCM_SET_CELL_WORD_3 (cell, data3);
 576   SCM_SET_CELL_WORD_2 (cell, data2);
 577   SCM_SET_CELL_WORD_1 (cell, data1);
 578   SCM_SET_CELL_WORD_0 (cell, tc);
 579
 580   return cell;
 581 }
 582
 583 \f
 584 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 585 void
 586 scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
 587 {
 588   SCM smob;
 589   size_t (* free_smob) (SCM);
 590
 591   smob = PTR2SCM (ptr);
 592 #if 0
 593   printf ("finalizing SMOB %p (smobnum: %u)\n",
 594           ptr, SCM_SMOBNUM (smob));
 595 #endif
 596
 597   free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
 598   if (free_smob)
 599     free_smob (smob);
 600 }
 601
 602 \f
 603 void
 604 scm_smob_prehistory ()
 605 {
 606   long i;
 607
 608   smob_gc_kind = GC_new_kind (GC_new_free_list (),
 609                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 610                               0,
 611                               /* Clear new objects.  As of version 7.1, libgc
 612                                  doesn't seem to support passing 0 here.  */
 613                               1);
 614
 615   scm_numsmob = 0;
 616   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 617     {
 618       scm_smobs[i].name       = 0;
 619       scm_smobs[i].size       = 0;
 620       scm_smobs[i].mark       = 0;
 621       scm_smobs[i].free       = 0;
 622       scm_smobs[i].print      = scm_smob_print;
 623       scm_smobs[i].equalp     = 0;
 624       scm_smobs[i].apply      = 0;
 625       scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
 626     }
 627
 628   tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 629 }
 630
 631 /*
 632   Local Variables:
 633   c-file-style: "gnu"
 634   End:
 635 */