libguile/smob.c

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