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