libguile/smob.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001 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
  45 #include <stdio.h>
  46 #include <errno.h>
  47
  48 #include "libguile/_scm.h"
  49
  50 #include "libguile/objects.h"
  51 #include "libguile/ports.h"
  52
  53 #ifdef HAVE_MALLOC_H
  54 #include <malloc.h>
  55 #endif
  56
  57 #include "libguile/smob.h"
  58
  59 \f
  60
  61 /* scm_smobs scm_numsmob
  62  * implement a fixed sized array of smob records.
  63  * Indexes into this table are used when generating type
  64  * tags for smobjects (if you know a tag you can get an index and conversely).
  65  */
  66
  67 #define MAX_SMOB_COUNT 256
  68 long scm_numsmob;
  69 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
  70
  71 /* {Mark}
  72  */
  73
  74 /* This function is vestigial.  It used to be the mark function's
  75    responsibility to set the mark bit on the smob or port, but now the
  76    generic marking routine in gc.c takes care of that, and a zero
  77    pointer for a mark function means "don't bother".  So you never
  78    need scm_mark0.
  79
  80    However, we leave it here because it's harmless to call it, and
  81    people out there have smob code that uses it, and there's no reason
  82    to make their links fail.  */
  83
  84 SCM
  85 scm_mark0 (SCM ptr SCM_UNUSED)
  86 {
  87   return SCM_BOOL_F;
  88 }
  89
  90 SCM
  91 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
  92    be used for real pairs. */
  93 scm_markcdr (SCM ptr)
  94 {
  95   return SCM_CELL_OBJECT_1 (ptr);
  96 }
  97
  98 /* {Free}
  99  */
 100
 101 size_t
 102 scm_free0 (SCM ptr SCM_UNUSED)
 103 {
 104   return 0;
 105 }
 106
 107 size_t
 108 scm_smob_free (SCM obj)
 109 {
 110   scm_must_free ((char *) SCM_CELL_WORD_1 (obj));
 111   return scm_smobs[SCM_SMOBNUM (obj)].size;
 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_intprint (SCM_CELL_WORD_1 (exp), 16, port);
 126   else
 127     scm_intprint (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_NULLP (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 *name, size_t size)
 291 #define FUNC_NAME "scm_make_smob_type"
 292 {
 293   long new_smob;
 294
 295   SCM_ENTER_A_SECTION;  /* scm_numsmob */
 296   new_smob = scm_numsmob;
 297   if (scm_numsmob != MAX_SMOB_COUNT)
 298     ++scm_numsmob;
 299   SCM_EXIT_A_SECTION;
 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_smob_class)
 313     scm_smob_class[new_smob] = scm_make_extended_class (name);
 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
 454 SCM
 455 scm_make_smob (scm_t_bits tc)
 456 {
 457   long n = SCM_TC2SMOBNUM (tc);
 458   size_t size = scm_smobs[n].size;
 459   SCM z;
 460   SCM_NEWCELL (z);
 461   if (size != 0)
 462     {
 463 #if 0
 464       if (scm_smobs[n].mark != 0)
 465         {
 466           fprintf
 467             (stderr,
 468              "forbidden operation for smobs with GC data, use SCM_NEWSMOB\n");
 469           abort ();
 470         }
 471 #endif
 472       SCM_SET_SMOB_DATA (z, scm_must_malloc (size, SCM_SMOBNAME (n)));
 473     }
 474   SCM_SET_CELL_TYPE (z, tc);
 475   return z;
 476 }
 477
 478 \f
 479 /* {Deprecated stuff}
 480  */
 481
 482 #if (SCM_DEBUG_DEPRECATED == 0)
 483
 484 long
 485 scm_make_smob_type_mfpe (char *name, size_t size,
 486                         SCM (*mark) (SCM),
 487                         size_t (*free) (SCM),
 488                         int (*print) (SCM, SCM, scm_print_state *),
 489                         SCM (*equalp) (SCM, SCM))
 490 {
 491   long answer = scm_make_smob_type (name, size);
 492   scm_set_smob_mfpe (answer, mark, free, print, equalp);
 493   return answer;
 494 }
 495
 496 void
 497 scm_set_smob_mfpe (long tc,
 498                    SCM (*mark) (SCM),
 499                    size_t (*free) (SCM),
 500                    int (*print) (SCM, SCM, scm_print_state *),
 501                    SCM (*equalp) (SCM, SCM))
 502 {
 503   if (mark) scm_set_smob_mark (tc, mark);
 504   if (free) scm_set_smob_free (tc, free);
 505   if (print) scm_set_smob_print (tc, print);
 506   if (equalp) scm_set_smob_equalp (tc, equalp);
 507 }
 508
 509 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
 510
 511 \f
 512 /* {Initialization for i/o types, float, bignum, the type of free cells}
 513  */
 514
 515 static int
 516 free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 517 {
 518   char buf[100];
 519
 520   sprintf (buf, "#<freed cell %p; GC missed a reference>",
 521            (void *) SCM_UNPACK (exp));
 522   scm_puts (buf, port);
 523
 524   return 1;
 525 }
 526
 527 void
 528 scm_smob_prehistory ()
 529 {
 530   long i;
 531   scm_t_bits tc;
 532
 533   scm_numsmob = 0;
 534   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 535     {
 536       scm_smobs[i].name       = 0;
 537       scm_smobs[i].size       = 0;
 538       scm_smobs[i].mark       = 0;
 539       scm_smobs[i].free       = 0;
 540       scm_smobs[i].print      = scm_smob_print;
 541       scm_smobs[i].equalp     = 0;
 542       scm_smobs[i].apply      = 0;
 543       scm_smobs[i].apply_0    = 0;
 544       scm_smobs[i].apply_1    = 0;
 545       scm_smobs[i].apply_2    = 0;
 546       scm_smobs[i].apply_3    = 0;
 547       scm_smobs[i].gsubr_type = 0;
 548     }
 549
 550   /* WARNING: These scm_make_smob_type calls must be done in this order */
 551   tc = scm_make_smob_type ("free", 0);
 552   scm_set_smob_print (tc, free_print);
 553
 554   tc = scm_make_smob_type ("big", 0);  /* freed in gc */
 555   scm_set_smob_print (tc, scm_bigprint);
 556   scm_set_smob_equalp (tc, scm_bigequal);
 557
 558   tc = scm_make_smob_type ("real", 0);  /* freed in gc */
 559   scm_set_smob_print (tc, scm_print_real);
 560   scm_set_smob_equalp (tc, scm_real_equalp);
 561
 562   tc = scm_make_smob_type ("complex", 0);  /* freed in gc */
 563   scm_set_smob_print (tc, scm_print_complex);
 564   scm_set_smob_equalp (tc, scm_complex_equalp);
 565 }
 566
 567 /*
 568   Local Variables:
 569   c-file-style: "gnu"
 570   End:
 571 */