libguile/smob.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 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
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  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 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 #  include <config.h>
  22 #endif
  23
  24 #include <stdio.h>
  25 #include <errno.h>
  26
  27 #include "libguile/_scm.h"
  28
  29 #include "libguile/async.h"
  30 #include "libguile/objects.h"
  31 #include "libguile/goops.h"
  32 #include "libguile/ports.h"
  33
  34 #ifdef HAVE_MALLOC_H
  35 #include <malloc.h>
  36 #endif
  37
  38 #include "libguile/smob.h"
  39
  40 #include "libguile/boehm-gc.h"
  41 #include <gc/gc_mark.h>
  42
  43
  44 \f
  45
  46 /* scm_smobs scm_numsmob
  47  * implement a fixed sized array of smob records.
  48  * Indexes into this table are used when generating type
  49  * tags for smobjects (if you know a tag you can get an index and conversely).
  50  */
  51
  52 #define MAX_SMOB_COUNT 256
  53 long scm_numsmob;
  54 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
  55
  56 /* Lower 16 bit of data must be zero.
  57 */
  58 void
  59 scm_i_set_smob_flags (SCM x, scm_t_bits data)
  60 {
  61   SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
  62 }
  63
  64 void
  65 scm_assert_smob_type (scm_t_bits tag, SCM val)
  66 {
  67   if (!SCM_SMOB_PREDICATE (tag, val))
  68     scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
  69 }
  70
  71 /* {Mark}
  72  */
  73
  74 /* This function is vestigial.  It used to be the mark function's
  75    responsibility to set the mark bit on the smob or port, but now the
  76    generic marking routine in gc.c takes care of that, and a zero
  77    pointer for a mark function means "don't bother".  So you never
  78    need scm_mark0.
  79
  80    However, we leave it here because it's harmless to call it, and
  81    people out there have smob code that uses it, and there's no reason
  82    to make their links fail.  */
  83
  84 SCM
  85 scm_mark0 (SCM ptr SCM_UNUSED)
  86 {
  87   return SCM_BOOL_F;
  88 }
  89
  90 SCM
  91 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
  92    be used for real pairs. */
  93 scm_markcdr (SCM ptr)
  94 {
  95   return SCM_CELL_OBJECT_1 (ptr);
  96 }
  97
  98 /* {Free}
  99  */
 100
 101 size_t
 102 scm_free0 (SCM ptr SCM_UNUSED)
 103 {
 104   return 0;
 105 }
 106
 107 size_t
 108 scm_smob_free (SCM obj)
 109 {
 110   long n = SCM_SMOBNUM (obj);
 111   if (scm_smobs[n].size > 0)
 112     scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
 113                  scm_smobs[n].size, SCM_SMOBNAME (n));
 114   return 0;
 115 }
 116
 117 /* {Print}
 118  */
 119
 120 int
 121 scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 122 {
 123   long n = SCM_SMOBNUM (exp);
 124   scm_puts ("#<", port);
 125   scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 126   scm_putc (' ', port);
 127   if (scm_smobs[n].size)
 128     scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
 129   else
 130     scm_uintprint (SCM_UNPACK (exp), 16, port);
 131   scm_putc ('>', port);
 132   return 1;
 133 }
 134
 135 /* {Apply}
 136  */
 137
 138 #define SCM_SMOB_APPLY0(SMOB) \
 139   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
 140 #define SCM_SMOB_APPLY1(SMOB, A1) \
 141   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
 142 #define SCM_SMOB_APPLY2(SMOB, A1, A2) \
 143   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
 144 #define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
 145   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
 146
 147 static SCM
 148 scm_smob_apply_0_010 (SCM smob)
 149 {
 150   return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
 151 }
 152
 153 static SCM
 154 scm_smob_apply_0_020 (SCM smob)
 155 {
 156   return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
 157 }
 158
 159 static SCM
 160 scm_smob_apply_0_030 (SCM smob)
 161 {
 162   return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
 163 }
 164
 165 static SCM
 166 scm_smob_apply_0_001 (SCM smob)
 167 {
 168   return SCM_SMOB_APPLY1 (smob, SCM_EOL);
 169 }
 170
 171 static SCM
 172 scm_smob_apply_0_011 (SCM smob)
 173 {
 174   return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
 175 }
 176
 177 static SCM
 178 scm_smob_apply_0_021 (SCM smob)
 179 {
 180   return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
 181 }
 182
 183 static SCM
 184 scm_smob_apply_0_error (SCM smob)
 185 {
 186   scm_wrong_num_args (smob);
 187 }
 188
 189 static SCM
 190 scm_smob_apply_1_020 (SCM smob, SCM a1)
 191 {
 192   return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
 193 }
 194
 195 static SCM
 196 scm_smob_apply_1_030 (SCM smob, SCM a1)
 197 {
 198   return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
 199 }
 200
 201 static SCM
 202 scm_smob_apply_1_001 (SCM smob, SCM a1)
 203 {
 204   return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
 205 }
 206
 207 static SCM
 208 scm_smob_apply_1_011 (SCM smob, SCM a1)
 209 {
 210   return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
 211 }
 212
 213 static SCM
 214 scm_smob_apply_1_021 (SCM smob, SCM a1)
 215 {
 216   return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
 217 }
 218
 219 static SCM
 220 scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
 221 {
 222   scm_wrong_num_args (smob);
 223 }
 224
 225 static SCM
 226 scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
 227 {
 228   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
 229 }
 230
 231 static SCM
 232 scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
 233 {
 234   return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
 235 }
 236
 237 static SCM
 238 scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
 239 {
 240   return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
 241 }
 242
 243 static SCM
 244 scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
 245 {
 246   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
 247 }
 248
 249 static SCM
 250 scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
 251 {
 252   scm_wrong_num_args (smob);
 253 }
 254
 255 static SCM
 256 scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
 257 {
 258   if (!scm_is_null (SCM_CDR (rst)))
 259     scm_wrong_num_args (smob);
 260   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
 261 }
 262
 263 static SCM
 264 scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
 265 {
 266   return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
 267 }
 268
 269 static SCM
 270 scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
 271 {
 272   return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
 273 }
 274
 275 static SCM
 276 scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
 277 {
 278   return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
 279 }
 280
 281 static SCM
 282 scm_smob_apply_3_error (SCM smob,
 283                         SCM a1 SCM_UNUSED,
 284                         SCM a2 SCM_UNUSED,
 285                         SCM rst SCM_UNUSED)
 286 {
 287   scm_wrong_num_args (smob);
 288 }
 289
 290 \f
 291
 292 scm_t_bits
 293 scm_make_smob_type (char const *name, size_t size)
 294 #define FUNC_NAME "scm_make_smob_type"
 295 {
 296   long new_smob;
 297
 298   SCM_CRITICAL_SECTION_START;
 299   new_smob = scm_numsmob;
 300   if (scm_numsmob != MAX_SMOB_COUNT)
 301     ++scm_numsmob;
 302   SCM_CRITICAL_SECTION_END;
 303
 304   if (new_smob == MAX_SMOB_COUNT)
 305     scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
 306
 307   scm_smobs[new_smob].name = name;
 308   if (size != 0)
 309     {
 310       scm_smobs[new_smob].size = size;
 311       scm_smobs[new_smob].free = scm_smob_free;
 312     }
 313
 314   /* Make a class object if Goops is present. */
 315   if (scm_smob_class)
 316     scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
 317
 318   return scm_tc7_smob + new_smob * 256;
 319 }
 320 #undef FUNC_NAME
 321
 322
 323 void
 324 scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
 325 {
 326   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 327 }
 328
 329 void
 330 scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
 331 {
 332   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 333 }
 334
 335 void
 336 scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
 337 {
 338   scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
 339 }
 340
 341 void
 342 scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
 343 {
 344   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 345 }
 346
 347 void
 348 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
 349                     unsigned int req, unsigned int opt, unsigned int rst)
 350 {
 351   SCM (*apply_0) (SCM);
 352   SCM (*apply_1) (SCM, SCM);
 353   SCM (*apply_2) (SCM, SCM, SCM);
 354   SCM (*apply_3) (SCM, SCM, SCM, SCM);
 355   int type = SCM_GSUBR_MAKTYPE (req, opt, rst);
 356
 357   if (rst > 1 || req + opt + rst > 3)
 358     {
 359       puts ("Unsupported smob application type");
 360       abort ();
 361     }
 362
 363   switch (type)
 364     {
 365     case SCM_GSUBR_MAKTYPE (0, 0, 0):
 366       apply_0 = apply; break;
 367     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 368       apply_0 = scm_smob_apply_0_010; break;
 369     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 370       apply_0 = scm_smob_apply_0_020; break;
 371     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 372       apply_0 = scm_smob_apply_0_030; break;
 373     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 374       apply_0 = scm_smob_apply_0_001; break;
 375     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 376       apply_0 = scm_smob_apply_0_011; break;
 377     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 378       apply_0 = scm_smob_apply_0_021; break;
 379     default:
 380       apply_0 = scm_smob_apply_0_error; break;
 381     }
 382
 383   switch (type)
 384     {
 385     case SCM_GSUBR_MAKTYPE (1, 0, 0):
 386     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 387       apply_1 = apply; break;
 388     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 389     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 390       apply_1 = scm_smob_apply_1_020; break;
 391     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 392     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 393       apply_1 = scm_smob_apply_1_030; break;
 394     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 395       apply_1 = scm_smob_apply_1_001; break;
 396     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 397     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 398       apply_1 = scm_smob_apply_1_011; break;
 399     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 400     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 401       apply_1 = scm_smob_apply_1_021; break;
 402     default:
 403       apply_1 = scm_smob_apply_1_error; break;
 404     }
 405
 406   switch (type)
 407     {
 408     case SCM_GSUBR_MAKTYPE (2, 0, 0):
 409     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 410     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 411       apply_2 = apply; break;
 412     case SCM_GSUBR_MAKTYPE (2, 1, 0):
 413     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 414     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 415       apply_2 = scm_smob_apply_2_030; break;
 416     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 417       apply_2 = scm_smob_apply_2_001; break;
 418     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 419     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 420       apply_2 = scm_smob_apply_2_011; break;
 421     case SCM_GSUBR_MAKTYPE (2, 0, 1):
 422     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 423     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 424       apply_2 = scm_smob_apply_2_021; break;
 425     default:
 426       apply_2 = scm_smob_apply_2_error; break;
 427     }
 428
 429   switch (type)
 430     {
 431     case SCM_GSUBR_MAKTYPE (3, 0, 0):
 432     case SCM_GSUBR_MAKTYPE (2, 1, 0):
 433     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 434     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 435       apply_3 = scm_smob_apply_3_030; break;
 436     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 437       apply_3 = scm_smob_apply_3_001; break;
 438     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 439     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 440       apply_3 = scm_smob_apply_3_011; break;
 441     case SCM_GSUBR_MAKTYPE (2, 0, 1):
 442     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 443     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 444       apply_3 = scm_smob_apply_3_021; break;
 445     default:
 446       apply_3 = scm_smob_apply_3_error; break;
 447     }
 448
 449   scm_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
 450   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
 451   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
 452   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
 453   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
 454   scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
 455
 456   if (scm_smob_class)
 457     scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
 458 }
 459
 460 SCM
 461 scm_make_smob (scm_t_bits tc)
 462 {
 463   scm_t_bits n = SCM_TC2SMOBNUM (tc);
 464   size_t size = scm_smobs[n].size;
 465   scm_t_bits data = (size > 0
 466                      ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
 467                      : 0);
 468
 469   SCM_RETURN_NEWSMOB (tc, data);
 470 }
 471
 472 \f
 473 /* {Initialization for the type of free cells}
 474  */
 475
 476 static int
 477 free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 478 {
 479   char buf[100];
 480   sprintf (buf, "#<freed cell %p; GC missed a reference>",
 481            (void *) SCM_UNPACK (exp));
 482   scm_puts (buf, port);
 483
 484 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 485   if (scm_debug_cell_accesses_p)
 486     abort();
 487 #endif
 488
 489
 490   return 1;
 491 }
 492
 493 \f
 494 /* Marking SMOBs using user-supplied mark procedures.  */
 495
 496
 497 /* The freelist and GC kind used for SMOB types that provide a custom mark
 498    procedure.  */
 499 static void **smob_freelist = NULL;
 500 static int    smob_gc_kind = 0;
 501
 502
 503 /* The generic SMOB mark procedure that gets called for SMOBs allocated with
 504    `scm_i_new_smob_with_mark_proc ()'.  */
 505 static struct GC_ms_entry *
 506 smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 507            struct GC_ms_entry *mark_stack_limit, GC_word env)
 508 {
 509   register SCM cell;
 510   register scm_t_bits tc, smobnum;
 511
 512   cell = PTR2SCM (addr);
 513
 514   if (SCM_TYP7 (cell) != scm_tc7_smob)
 515     /* It is likely that the GC passed us a pointer to a free-list element
 516        which we must ignore (see warning in `gc/gc_mark.h').  */
 517     return mark_stack_ptr;
 518
 519   tc = SCM_CELL_WORD_0 (cell);
 520   smobnum = SCM_TC2SMOBNUM (tc);
 521
 522   if (smobnum >= scm_numsmob)
 523     /* The first word looks corrupt.  */
 524     abort ();
 525
 526   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
 527                                      mark_stack_ptr,
 528                                      mark_stack_limit, NULL);
 529   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
 530                                      mark_stack_ptr,
 531                                      mark_stack_limit, NULL);
 532   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
 533                                      mark_stack_ptr,
 534                                      mark_stack_limit, NULL);
 535
 536   if (scm_smobs[smobnum].mark)
 537     {
 538       SCM obj;
 539
 540       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 541       SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
 542
 543       /* Invoke the SMOB's mark procedure, which will in turn invoke
 544          `scm_gc_mark ()', which may modify `current_mark_stack_ptr'.  */
 545       obj = scm_smobs[smobnum].mark (cell);
 546
 547       mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
 548
 549       if (SCM_NIMP (obj))
 550         /* Mark the returned object.  */
 551         mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
 552                                            mark_stack_ptr,
 553                                            mark_stack_limit, NULL);
 554
 555       SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
 556       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
 557     }
 558
 559   return mark_stack_ptr;
 560
 561 }
 562
 563 /* Mark object O.  We assume that this function is only called during the
 564    mark phase, i.e., from within `smob_mark ()' or one of its
 565    descendents.  */
 566 void
 567 scm_gc_mark (SCM o)
 568 {
 569 #define CURRENT_MARK_PTR                                                 \
 570   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
 571 #define CURRENT_MARK_LIMIT                                                 \
 572   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
 573
 574   if (SCM_NIMP (o))
 575     {
 576       /* At this point, the `current_mark_*' fields of the current thread
 577          must be defined (they are set in `smob_mark ()').  */
 578       register struct GC_ms_entry *mark_stack_ptr;
 579
 580       if (!CURRENT_MARK_PTR)
 581         /* The function was not called from a mark procedure.  */
 582         abort ();
 583
 584       mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
 585                                          CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
 586                                          NULL);
 587       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 588     }
 589 #undef CURRENT_MARK_PTR
 590 #undef CURRENT_MARK_LIMIT
 591 }
 592
 593 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 594    provide a custom mark procedure and it will be honored.  */
 595 SCM
 596 scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1,
 597                                scm_t_bits data2, scm_t_bits data3)
 598 {
 599   /* Return a double cell.  */
 600   SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell),
 601                                           smob_gc_kind));
 602
 603   SCM_SET_CELL_WORD_3 (cell, data3);
 604   SCM_SET_CELL_WORD_2 (cell, data2);
 605   SCM_SET_CELL_WORD_1 (cell, data1);
 606   SCM_SET_CELL_WORD_0 (cell, tc);
 607
 608   return cell;
 609 }
 610
 611 \f
 612 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 613 void
 614 scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
 615 {
 616   SCM smob;
 617   size_t (* free_smob) (SCM);
 618
 619   smob = PTR2SCM (ptr);
 620 #if 0
 621   printf ("finalizing SMOB %p (smobnum: %u)\n",
 622           ptr, SCM_SMOBNUM (smob));
 623 #endif
 624
 625   free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
 626   if (free_smob)
 627     free_smob (smob);
 628 }
 629
 630 \f
 631 void
 632 scm_smob_prehistory ()
 633 {
 634   long i;
 635   scm_t_bits tc;
 636
 637   smob_freelist = GC_new_free_list ();
 638   smob_gc_kind = GC_new_kind ((void **)smob_freelist,
 639                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 640                               0, 0);
 641
 642   scm_numsmob = 0;
 643   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 644     {
 645       scm_smobs[i].name       = 0;
 646       scm_smobs[i].size       = 0;
 647       scm_smobs[i].mark       = 0;
 648       scm_smobs[i].free       = 0;
 649       scm_smobs[i].print      = scm_smob_print;
 650       scm_smobs[i].equalp     = 0;
 651       scm_smobs[i].apply      = 0;
 652       scm_smobs[i].apply_0    = 0;
 653       scm_smobs[i].apply_1    = 0;
 654       scm_smobs[i].apply_2    = 0;
 655       scm_smobs[i].apply_3    = 0;
 656       scm_smobs[i].gsubr_type = 0;
 657     }
 658
 659   /* WARNING: This scm_make_smob_type call must be done first.  */
 660   tc = scm_make_smob_type ("free", 0);
 661   scm_set_smob_print (tc, free_print);
 662 }
 663
 664 /*
 665   Local Variables:
 666   c-file-style: "gnu"
 667   End:
 668 */