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