libguile/smob.c

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