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