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 \f
  42
  43 /* scm_smobs scm_numsmob
  44  * implement a fixed sized array of smob records.
  45  * Indexes into this table are used when generating type
  46  * tags for smobjects (if you know a tag you can get an index and conversely).
  47  */
  48
  49 #define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT
  50
  51 long scm_numsmob;
  52 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
  53
  54 /* Lower 16 bit of data must be zero.
  55 */
  56 void
  57 scm_i_set_smob_flags (SCM x, scm_t_bits data)
  58 {
  59   SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
  60 }
  61
  62 void
  63 scm_assert_smob_type (scm_t_bits tag, SCM val)
  64 {
  65   if (!SCM_SMOB_PREDICATE (tag, val))
  66     scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
  67 }
  68
  69 /* {Mark}
  70  */
  71
  72 /* This function is vestigial.  It used to be the mark function's
  73    responsibility to set the mark bit on the smob or port, but now the
  74    generic marking routine in gc.c takes care of that, and a zero
  75    pointer for a mark function means "don't bother".  So you never
  76    need scm_mark0.
  77
  78    However, we leave it here because it's harmless to call it, and
  79    people out there have smob code that uses it, and there's no reason
  80    to make their links fail.  */
  81
  82 SCM
  83 scm_mark0 (SCM ptr SCM_UNUSED)
  84 {
  85   return SCM_BOOL_F;
  86 }
  87
  88 SCM
  89 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
  90    be used for real pairs. */
  91 scm_markcdr (SCM ptr)
  92 {
  93   return SCM_CELL_OBJECT_1 (ptr);
  94 }
  95
  96 /* {Free}
  97  */
  98
  99 size_t
 100 scm_free0 (SCM ptr SCM_UNUSED)
 101 {
 102   return 0;
 103 }
 104
 105 size_t
 106 scm_smob_free (SCM obj)
 107 {
 108   long n = SCM_SMOBNUM (obj);
 109   if (scm_smobs[n].size > 0)
 110     scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
 111                  scm_smobs[n].size, SCM_SMOBNAME (n));
 112   return 0;
 113 }
 114
 115 /* {Print}
 116  */
 117
 118 int
 119 scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 120 {
 121   long n = SCM_SMOBNUM (exp);
 122   scm_puts ("#<", port);
 123   scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 124   scm_putc (' ', port);
 125   if (scm_smobs[n].size)
 126     scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
 127   else
 128     scm_uintprint (SCM_UNPACK (exp), 16, port);
 129   scm_putc ('>', port);
 130   return 1;
 131 }
 132
 133 /* {Apply}
 134  */
 135
 136 #define SCM_SMOB_APPLY0(SMOB) \
 137   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
 138 #define SCM_SMOB_APPLY1(SMOB, A1) \
 139   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
 140 #define SCM_SMOB_APPLY2(SMOB, A1, A2) \
 141   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
 142 #define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
 143   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
 144
 145 static SCM
 146 scm_smob_apply_0_010 (SCM smob)
 147 {
 148   return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
 149 }
 150
 151 static SCM
 152 scm_smob_apply_0_020 (SCM smob)
 153 {
 154   return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
 155 }
 156
 157 static SCM
 158 scm_smob_apply_0_030 (SCM smob)
 159 {
 160   return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
 161 }
 162
 163 static SCM
 164 scm_smob_apply_0_001 (SCM smob)
 165 {
 166   return SCM_SMOB_APPLY1 (smob, SCM_EOL);
 167 }
 168
 169 static SCM
 170 scm_smob_apply_0_011 (SCM smob)
 171 {
 172   return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
 173 }
 174
 175 static SCM
 176 scm_smob_apply_0_021 (SCM smob)
 177 {
 178   return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
 179 }
 180
 181 static SCM
 182 scm_smob_apply_0_error (SCM smob)
 183 {
 184   scm_wrong_num_args (smob);
 185 }
 186
 187 static SCM
 188 scm_smob_apply_1_020 (SCM smob, SCM a1)
 189 {
 190   return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
 191 }
 192
 193 static SCM
 194 scm_smob_apply_1_030 (SCM smob, SCM a1)
 195 {
 196   return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
 197 }
 198
 199 static SCM
 200 scm_smob_apply_1_001 (SCM smob, SCM a1)
 201 {
 202   return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
 203 }
 204
 205 static SCM
 206 scm_smob_apply_1_011 (SCM smob, SCM a1)
 207 {
 208   return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
 209 }
 210
 211 static SCM
 212 scm_smob_apply_1_021 (SCM smob, SCM a1)
 213 {
 214   return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
 215 }
 216
 217 static SCM
 218 scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
 219 {
 220   scm_wrong_num_args (smob);
 221 }
 222
 223 static SCM
 224 scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
 225 {
 226   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
 227 }
 228
 229 static SCM
 230 scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
 231 {
 232   return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
 233 }
 234
 235 static SCM
 236 scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
 237 {
 238   return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
 239 }
 240
 241 static SCM
 242 scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
 243 {
 244   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
 245 }
 246
 247 static SCM
 248 scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
 249 {
 250   scm_wrong_num_args (smob);
 251 }
 252
 253 static SCM
 254 scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
 255 {
 256   if (!scm_is_null (SCM_CDR (rst)))
 257     scm_wrong_num_args (smob);
 258   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
 259 }
 260
 261 static SCM
 262 scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
 263 {
 264   return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
 265 }
 266
 267 static SCM
 268 scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
 269 {
 270   return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
 271 }
 272
 273 static SCM
 274 scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
 275 {
 276   return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
 277 }
 278
 279 static SCM
 280 scm_smob_apply_3_error (SCM smob,
 281                         SCM a1 SCM_UNUSED,
 282                         SCM a2 SCM_UNUSED,
 283                         SCM rst SCM_UNUSED)
 284 {
 285   scm_wrong_num_args (smob);
 286 }
 287
 288 \f
 289
 290 scm_t_bits
 291 scm_make_smob_type (char const *name, size_t size)
 292 #define FUNC_NAME "scm_make_smob_type"
 293 {
 294   long new_smob;
 295
 296   SCM_CRITICAL_SECTION_START;
 297   new_smob = scm_numsmob;
 298   if (scm_numsmob != MAX_SMOB_COUNT)
 299     ++scm_numsmob;
 300   SCM_CRITICAL_SECTION_END;
 301
 302   if (new_smob == MAX_SMOB_COUNT)
 303     scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
 304
 305   scm_smobs[new_smob].name = name;
 306   if (size != 0)
 307     {
 308       scm_smobs[new_smob].size = size;
 309       scm_smobs[new_smob].free = scm_smob_free;
 310     }
 311
 312   /* Make a class object if Goops is present. */
 313   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 314     scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
 315
 316   return scm_tc7_smob + new_smob * 256;
 317 }
 318 #undef FUNC_NAME
 319
 320
 321 void
 322 scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
 323 {
 324   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 325 }
 326
 327 void
 328 scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
 329 {
 330   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 331 }
 332
 333 void
 334 scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
 335 {
 336   scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
 337 }
 338
 339 void
 340 scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
 341 {
 342   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 343 }
 344
 345 void
 346 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
 347                     unsigned int req, unsigned int opt, unsigned int rst)
 348 {
 349   SCM (*apply_0) (SCM);
 350   SCM (*apply_1) (SCM, SCM);
 351   SCM (*apply_2) (SCM, SCM, SCM);
 352   SCM (*apply_3) (SCM, SCM, SCM, SCM);
 353   int type = SCM_GSUBR_MAKTYPE (req, opt, rst);
 354
 355   if (rst > 1 || req + opt + rst > 3)
 356     {
 357       puts ("Unsupported smob application type");
 358       abort ();
 359     }
 360
 361   switch (type)
 362     {
 363     case SCM_GSUBR_MAKTYPE (0, 0, 0):
 364       apply_0 = apply; break;
 365     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 366       apply_0 = scm_smob_apply_0_010; break;
 367     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 368       apply_0 = scm_smob_apply_0_020; break;
 369     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 370       apply_0 = scm_smob_apply_0_030; break;
 371     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 372       apply_0 = scm_smob_apply_0_001; break;
 373     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 374       apply_0 = scm_smob_apply_0_011; break;
 375     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 376       apply_0 = scm_smob_apply_0_021; break;
 377     default:
 378       apply_0 = scm_smob_apply_0_error; break;
 379     }
 380
 381   switch (type)
 382     {
 383     case SCM_GSUBR_MAKTYPE (1, 0, 0):
 384     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 385       apply_1 = apply; break;
 386     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 387     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 388       apply_1 = scm_smob_apply_1_020; break;
 389     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 390     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 391       apply_1 = scm_smob_apply_1_030; break;
 392     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 393       apply_1 = scm_smob_apply_1_001; break;
 394     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 395     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 396       apply_1 = scm_smob_apply_1_011; break;
 397     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 398     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 399       apply_1 = scm_smob_apply_1_021; break;
 400     default:
 401       apply_1 = scm_smob_apply_1_error; break;
 402     }
 403
 404   switch (type)
 405     {
 406     case SCM_GSUBR_MAKTYPE (2, 0, 0):
 407     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 408     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 409       apply_2 = apply; break;
 410     case SCM_GSUBR_MAKTYPE (2, 1, 0):
 411     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 412     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 413       apply_2 = scm_smob_apply_2_030; break;
 414     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 415       apply_2 = scm_smob_apply_2_001; break;
 416     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 417     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 418       apply_2 = scm_smob_apply_2_011; break;
 419     case SCM_GSUBR_MAKTYPE (2, 0, 1):
 420     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 421     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 422       apply_2 = scm_smob_apply_2_021; break;
 423     default:
 424       apply_2 = scm_smob_apply_2_error; break;
 425     }
 426
 427   switch (type)
 428     {
 429     case SCM_GSUBR_MAKTYPE (3, 0, 0):
 430     case SCM_GSUBR_MAKTYPE (2, 1, 0):
 431     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 432     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 433       apply_3 = scm_smob_apply_3_030; break;
 434     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 435       apply_3 = scm_smob_apply_3_001; break;
 436     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 437     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 438       apply_3 = scm_smob_apply_3_011; break;
 439     case SCM_GSUBR_MAKTYPE (2, 0, 1):
 440     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 441     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 442       apply_3 = scm_smob_apply_3_021; break;
 443     default:
 444       apply_3 = scm_smob_apply_3_error; break;
 445     }
 446
 447   scm_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
 448   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
 449   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
 450   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
 451   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
 452   scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
 453
 454   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 455     scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
 456 }
 457
 458 SCM
 459 scm_make_smob (scm_t_bits tc)
 460 {
 461   long n = SCM_TC2SMOBNUM (tc);
 462   size_t size = scm_smobs[n].size;
 463   scm_t_bits data = (size > 0
 464                      ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
 465                      : 0);
 466   return scm_cell (tc, data);
 467 }
 468
 469 \f
 470 /* {Initialization for the type of free cells}
 471  */
 472
 473 static int
 474 free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 475 {
 476   char buf[100];
 477   sprintf (buf, "#<freed cell %p; GC missed a reference>",
 478            (void *) SCM_UNPACK (exp));
 479   scm_puts (buf, port);
 480
 481 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 482   if (scm_debug_cell_accesses_p)
 483     abort();
 484 #endif
 485
 486
 487   return 1;
 488 }
 489
 490 void
 491 scm_smob_prehistory ()
 492 {
 493   long i;
 494   scm_t_bits tc;
 495
 496   scm_numsmob = 0;
 497   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 498     {
 499       scm_smobs[i].name       = 0;
 500       scm_smobs[i].size       = 0;
 501       scm_smobs[i].mark       = 0;
 502       scm_smobs[i].free       = 0;
 503       scm_smobs[i].print      = scm_smob_print;
 504       scm_smobs[i].equalp     = 0;
 505       scm_smobs[i].apply      = 0;
 506       scm_smobs[i].apply_0    = 0;
 507       scm_smobs[i].apply_1    = 0;
 508       scm_smobs[i].apply_2    = 0;
 509       scm_smobs[i].apply_3    = 0;
 510       scm_smobs[i].gsubr_type = 0;
 511     }
 512
 513   /* WARNING: This scm_make_smob_type call must be done first.  */
 514   tc = scm_make_smob_type ("free", 0);
 515   scm_set_smob_print (tc, free_print);
 516 }
 517
 518 /*
 519   Local Variables:
 520   c-file-style: "gnu"
 521   End:
 522 */