libguile/smob.c

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