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 \f
 475 /* {Initialization for the type of free cells}
 476  */
 477
 478 static int
 479 free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 480 {
 481   char buf[100];
 482   sprintf (buf, "#<freed cell %p; GC missed a reference>",
 483            (void *) SCM_UNPACK (exp));
 484   scm_puts (buf, port);
 485
 486 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 487   if (scm_debug_cell_accesses_p)
 488     abort();
 489 #endif
 490
 491
 492   return 1;
 493 }
 494
 495 \f
 496 /* Marking SMOBs using user-supplied mark procedures.  */
 497
 498
 499 /* The GC kind used for SMOB types that provide a custom mark procedure.  */
 500 static int smob_gc_kind;
 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_gc_kind = GC_new_kind (GC_new_free_list (),
 638                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 639                               0,
 640                               /* Clear new objects.  As of version 7.1, libgc
 641                                  doesn't seem to support passing 0 here.  */
 642                               1);
 643
 644   scm_numsmob = 0;
 645   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 646     {
 647       scm_smobs[i].name       = 0;
 648       scm_smobs[i].size       = 0;
 649       scm_smobs[i].mark       = 0;
 650       scm_smobs[i].free       = 0;
 651       scm_smobs[i].print      = scm_smob_print;
 652       scm_smobs[i].equalp     = 0;
 653       scm_smobs[i].apply      = 0;
 654       scm_smobs[i].apply_0    = 0;
 655       scm_smobs[i].apply_1    = 0;
 656       scm_smobs[i].apply_2    = 0;
 657       scm_smobs[i].apply_3    = 0;
 658       scm_smobs[i].gsubr_type = 0;
 659     }
 660
 661   /* WARNING: This scm_make_smob_type call must be done first.  */
 662   tc = scm_make_smob_type ("free", 0);
 663   scm_set_smob_print (tc, free_print);
 664 }
 665
 666 /*
 667   Local Variables:
 668   c-file-style: "gnu"
 669   End:
 670 */