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 freelist and GC kind used for SMOB types that provide a custom mark
 500    procedure.  */
 501 static void **smob_freelist = NULL;
 502 static int    smob_gc_kind = 0;
 503
 504
 505 /* The generic SMOB mark procedure that gets called for SMOBs allocated with
 506    `scm_i_new_smob_with_mark_proc ()'.  */
 507 static struct GC_ms_entry *
 508 smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 509            struct GC_ms_entry *mark_stack_limit, GC_word env)
 510 {
 511   register SCM cell;
 512   register scm_t_bits tc, smobnum;
 513
 514   cell = PTR2SCM (addr);
 515
 516   if (SCM_TYP7 (cell) != scm_tc7_smob)
 517     /* It is likely that the GC passed us a pointer to a free-list element
 518        which we must ignore (see warning in `gc/gc_mark.h').  */
 519     return mark_stack_ptr;
 520
 521   tc = SCM_CELL_WORD_0 (cell);
 522   smobnum = SCM_TC2SMOBNUM (tc);
 523
 524   if (smobnum >= scm_numsmob)
 525     /* The first word looks corrupt.  */
 526     abort ();
 527
 528   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
 529                                      mark_stack_ptr,
 530                                      mark_stack_limit, NULL);
 531   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
 532                                      mark_stack_ptr,
 533                                      mark_stack_limit, NULL);
 534   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
 535                                      mark_stack_ptr,
 536                                      mark_stack_limit, NULL);
 537
 538   if (scm_smobs[smobnum].mark)
 539     {
 540       SCM obj;
 541
 542       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 543       SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
 544
 545       /* Invoke the SMOB's mark procedure, which will in turn invoke
 546          `scm_gc_mark ()', which may modify `current_mark_stack_ptr'.  */
 547       obj = scm_smobs[smobnum].mark (cell);
 548
 549       mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
 550
 551       if (SCM_NIMP (obj))
 552         /* Mark the returned object.  */
 553         mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
 554                                            mark_stack_ptr,
 555                                            mark_stack_limit, NULL);
 556
 557       SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
 558       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
 559     }
 560
 561   return mark_stack_ptr;
 562
 563 }
 564
 565 /* Mark object O.  We assume that this function is only called during the
 566    mark phase, i.e., from within `smob_mark ()' or one of its
 567    descendents.  */
 568 void
 569 scm_gc_mark (SCM o)
 570 {
 571 #define CURRENT_MARK_PTR                                                 \
 572   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
 573 #define CURRENT_MARK_LIMIT                                                 \
 574   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
 575
 576   if (SCM_NIMP (o))
 577     {
 578       /* At this point, the `current_mark_*' fields of the current thread
 579          must be defined (they are set in `smob_mark ()').  */
 580       register struct GC_ms_entry *mark_stack_ptr;
 581
 582       if (!CURRENT_MARK_PTR)
 583         /* The function was not called from a mark procedure.  */
 584         abort ();
 585
 586       mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
 587                                          CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
 588                                          NULL);
 589       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 590     }
 591 #undef CURRENT_MARK_PTR
 592 #undef CURRENT_MARK_LIMIT
 593 }
 594
 595 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 596    provide a custom mark procedure and it will be honored.  */
 597 SCM
 598 scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1,
 599                                scm_t_bits data2, scm_t_bits data3)
 600 {
 601   /* Return a double cell.  */
 602   SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell),
 603                                           smob_gc_kind));
 604
 605   SCM_SET_CELL_WORD_3 (cell, data3);
 606   SCM_SET_CELL_WORD_2 (cell, data2);
 607   SCM_SET_CELL_WORD_1 (cell, data1);
 608   SCM_SET_CELL_WORD_0 (cell, tc);
 609
 610   return cell;
 611 }
 612
 613 \f
 614 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 615 void
 616 scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
 617 {
 618   SCM smob;
 619   size_t (* free_smob) (SCM);
 620
 621   smob = PTR2SCM (ptr);
 622 #if 0
 623   printf ("finalizing SMOB %p (smobnum: %u)\n",
 624           ptr, SCM_SMOBNUM (smob));
 625 #endif
 626
 627   free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
 628   if (free_smob)
 629     free_smob (smob);
 630 }
 631
 632 \f
 633 void
 634 scm_smob_prehistory ()
 635 {
 636   long i;
 637   scm_t_bits tc;
 638
 639   smob_freelist = GC_new_free_list ();
 640   smob_gc_kind = GC_new_kind ((void **)smob_freelist,
 641                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 642                               0,
 643                               /* Clear new objects.  As of version 7.1, libgc
 644                                  doesn't seem to support passing 0 here.  */
 645                               1);
 646
 647   scm_numsmob = 0;
 648   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 649     {
 650       scm_smobs[i].name       = 0;
 651       scm_smobs[i].size       = 0;
 652       scm_smobs[i].mark       = 0;
 653       scm_smobs[i].free       = 0;
 654       scm_smobs[i].print      = scm_smob_print;
 655       scm_smobs[i].equalp     = 0;
 656       scm_smobs[i].apply      = 0;
 657       scm_smobs[i].apply_0    = 0;
 658       scm_smobs[i].apply_1    = 0;
 659       scm_smobs[i].apply_2    = 0;
 660       scm_smobs[i].apply_3    = 0;
 661       scm_smobs[i].gsubr_type = 0;
 662     }
 663
 664   /* WARNING: This scm_make_smob_type call must be done first.  */
 665   tc = scm_make_smob_type ("free", 0);
 666   scm_set_smob_print (tc, free_print);
 667 }
 668
 669 /*
 670   Local Variables:
 671   c-file-style: "gnu"
 672   End:
 673 */