libguile/smob.c

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