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 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include <errno.h>
  49
  50 #include "libguile/_scm.h"
  51
  52 #include "libguile/objects.h"
  53 #include "libguile/ports.h"
  54
  55 #ifdef HAVE_MALLOC_H
  56 #include <malloc.h>
  57 #endif
  58
  59 #include "libguile/smob.h"
  60
  61 \f
  62
  63 /* scm_smobs scm_numsmob
  64  * implement a fixed sized array of smob records.
  65  * Indexes into this table are used when generating type
  66  * tags for smobjects (if you know a tag you can get an index and conversely).
  67  */
  68
  69 #define MAX_SMOB_COUNT 256
  70 scm_bits_t scm_numsmob;
  71 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
  72
  73 /* {Mark}
  74  */
  75
  76 /* This function is vestigial.  It used to be the mark function's
  77    responsibility to set the mark bit on the smob or port, but now the
  78    generic marking routine in gc.c takes care of that, and a zero
  79    pointer for a mark function means "don't bother".  So you never
  80    need scm_mark0.
  81
  82    However, we leave it here because it's harmless to call it, and
  83    people out there have smob code that uses it, and there's no reason
  84    to make their links fail.  */
  85
  86 SCM
  87 scm_mark0 (SCM ptr)
  88 {
  89   return SCM_BOOL_F;
  90 }
  91
  92 SCM
  93 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
  94    be used for real pairs. */
  95 scm_markcdr (SCM ptr)
  96 {
  97   return SCM_CELL_OBJECT_1 (ptr);
  98 }
  99
 100 /* {Free}
 101  */
 102
 103 size_t
 104 scm_free0 (SCM ptr)
 105 {
 106   return 0;
 107 }
 108
 109 size_t
 110 scm_smob_free (SCM obj)
 111 {
 112   scm_must_free ((char *) SCM_CELL_WORD_1 (obj));
 113   return scm_smobs[SCM_SMOBNUM (obj)].size;
 114 }
 115
 116 /* {Print}
 117  */
 118
 119 int
 120 scm_smob_print (SCM exp, SCM port, scm_print_state *pstate)
 121 {
 122   size_t n = SCM_SMOBNUM (exp);
 123   scm_puts ("#<", port);
 124   scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 125   scm_putc (' ', port);
 126   if (scm_smobs[n].size)
 127     scm_intprint (SCM_CELL_WORD_1 (exp), 16, port);
 128   else
 129     scm_intprint (SCM_UNPACK (exp), 16, port);
 130   scm_putc ('>', port);
 131   return 1;
 132 }
 133
 134 /* {Apply}
 135  */
 136
 137 #define SCM_SMOB_APPLY0(SMOB) \
 138   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
 139 #define SCM_SMOB_APPLY1(SMOB,A1) \
 140   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
 141 #define SCM_SMOB_APPLY2(SMOB,A1,A2) \
 142   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
 143 #define SCM_SMOB_APPLY3(SMOB,A1,A2,A3) \
 144   SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
 145
 146 static SCM
 147 scm_smob_apply_0_010 (SCM smob)
 148 {
 149   return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
 150 }
 151
 152 static SCM
 153 scm_smob_apply_0_020 (SCM smob)
 154 {
 155   return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
 156 }
 157
 158 static SCM
 159 scm_smob_apply_0_030 (SCM smob)
 160 {
 161   return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
 162 }
 163
 164 static SCM
 165 scm_smob_apply_0_001 (SCM smob)
 166 {
 167   return SCM_SMOB_APPLY1 (smob, SCM_EOL);
 168 }
 169
 170 static SCM
 171 scm_smob_apply_0_011 (SCM smob)
 172 {
 173   return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
 174 }
 175
 176 static SCM
 177 scm_smob_apply_0_021 (SCM smob)
 178 {
 179   return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
 180 }
 181
 182 static SCM
 183 scm_smob_apply_0_error (SCM smob)
 184 {
 185   scm_wrong_num_args (smob);
 186 }
 187
 188 static SCM
 189 scm_smob_apply_1_020 (SCM smob, SCM a1)
 190 {
 191   return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
 192 }
 193
 194 static SCM
 195 scm_smob_apply_1_030 (SCM smob, SCM a1)
 196 {
 197   return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
 198 }
 199
 200 static SCM
 201 scm_smob_apply_1_001 (SCM smob, SCM a1)
 202 {
 203   return SCM_SMOB_APPLY1 (smob, SCM_LIST1 (a1));
 204 }
 205
 206 static SCM
 207 scm_smob_apply_1_011 (SCM smob, SCM a1)
 208 {
 209   return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
 210 }
 211
 212 static SCM
 213 scm_smob_apply_1_021 (SCM smob, SCM a1)
 214 {
 215   return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
 216 }
 217
 218 static SCM
 219 scm_smob_apply_1_error (SCM smob, SCM a1)
 220 {
 221   scm_wrong_num_args (smob);
 222 }
 223
 224 static SCM
 225 scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
 226 {
 227   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
 228 }
 229
 230 static SCM
 231 scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
 232 {
 233   return SCM_SMOB_APPLY1 (smob, SCM_LIST2 (a1, a2));
 234 }
 235
 236 static SCM
 237 scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
 238 {
 239   return SCM_SMOB_APPLY2 (smob, a1, SCM_LIST1 (a2));
 240 }
 241
 242 static SCM
 243 scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
 244 {
 245   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
 246 }
 247
 248 static SCM
 249 scm_smob_apply_2_error (SCM smob, SCM a1, SCM a2)
 250 {
 251   scm_wrong_num_args (smob);
 252 }
 253
 254 static SCM
 255 scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
 256 {
 257   if (!SCM_NULLP (SCM_CDR (rst)))
 258     scm_wrong_num_args (smob);
 259   return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
 260 }
 261
 262 static SCM
 263 scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
 264 {
 265   return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
 266 }
 267
 268 static SCM
 269 scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
 270 {
 271   return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
 272 }
 273
 274 static SCM
 275 scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
 276 {
 277   return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
 278 }
 279
 280 static SCM
 281 scm_smob_apply_3_error (SCM smob, SCM a1, SCM a2, SCM rst)
 282 {
 283   scm_wrong_num_args (smob);
 284 }
 285
 286 \f
 287
 288 scm_bits_t
 289 scm_make_smob_type (char *name, size_t size)
 290 #define FUNC_NAME "scm_make_smob_type"
 291 {
 292   size_t new_smob;
 293
 294   SCM_ENTER_A_SECTION;  /* scm_numsmob */
 295   new_smob = scm_numsmob;
 296   if (scm_numsmob != MAX_SMOB_COUNT)
 297     ++scm_numsmob;
 298   SCM_EXIT_A_SECTION;
 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);
 313
 314   return scm_tc7_smob + new_smob * 256;
 315 }
 316 #undef FUNC_NAME
 317
 318
 319 void
 320 scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM))
 321 {
 322   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 323 }
 324
 325 void
 326 scm_set_smob_free (scm_bits_t tc, size_t (*free) (SCM))
 327 {
 328   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 329 }
 330
 331 void
 332 scm_set_smob_print (scm_bits_t 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_bits_t tc, SCM (*equalp) (SCM, SCM))
 339 {
 340   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 341 }
 342
 343 void
 344 scm_set_smob_apply (scm_bits_t 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
 453 SCM
 454 scm_make_smob (scm_bits_t tc)
 455 {
 456   size_t n = SCM_TC2SMOBNUM (tc);
 457   size_t size = scm_smobs[n].size;
 458   SCM z;
 459   SCM_NEWCELL (z);
 460   if (size != 0)
 461     {
 462 #if 0
 463       if (scm_smobs[n].mark != 0)
 464         {
 465           fprintf
 466             (stderr,
 467              "forbidden operation for smobs with GC data, use SCM_NEWSMOB\n");
 468           abort ();
 469         }
 470 #endif
 471       SCM_SET_SMOB_DATA (z, scm_must_malloc (size, SCM_SMOBNAME (n)));
 472     }
 473   SCM_SET_CELL_TYPE (z, tc);
 474   return z;
 475 }
 476
 477 \f
 478 /* {Deprecated stuff}
 479  */
 480
 481 #if (SCM_DEBUG_DEPRECATED == 0)
 482
 483 long
 484 scm_make_smob_type_mfpe (char *name, size_t size,
 485                         SCM (*mark) (SCM),
 486                         size_t (*free) (SCM),
 487                         int (*print) (SCM, SCM, scm_print_state *),
 488                         SCM (*equalp) (SCM, SCM))
 489 {
 490   scm_bits_t answer = scm_make_smob_type (name, size);
 491   scm_set_smob_mfpe (answer, mark, free, print, equalp);
 492   return answer;
 493 }
 494
 495 void
 496 scm_set_smob_mfpe (long tc,
 497                    SCM (*mark) (SCM),
 498                    size_t (*free) (SCM),
 499                    int (*print) (SCM, SCM, scm_print_state *),
 500                    SCM (*equalp) (SCM, SCM))
 501 {
 502   if (mark) scm_set_smob_mark (tc, mark);
 503   if (free) scm_set_smob_free (tc, free);
 504   if (print) scm_set_smob_print (tc, print);
 505   if (equalp) scm_set_smob_equalp (tc, equalp);
 506 }
 507
 508 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
 509
 510 \f
 511 /* {Initialization for i/o types, float, bignum, the type of free cells}
 512  */
 513
 514 static int
 515 free_print (SCM exp, SCM port, scm_print_state *pstate)
 516 {
 517   char buf[100];
 518
 519   sprintf (buf, "#<freed cell %p; GC missed a reference>",
 520            (void *) SCM_UNPACK (exp));
 521   scm_puts (buf, port);
 522
 523   return 1;
 524 }
 525
 526 void
 527 scm_smob_prehistory ()
 528 {
 529   size_t i;
 530   scm_bits_t tc;
 531
 532   scm_numsmob = 0;
 533   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 534     {
 535       scm_smobs[i].name       = 0;
 536       scm_smobs[i].size       = 0;
 537       scm_smobs[i].mark       = 0;
 538       scm_smobs[i].free       = 0;
 539       scm_smobs[i].print      = scm_smob_print;
 540       scm_smobs[i].equalp     = 0;
 541       scm_smobs[i].apply      = 0;
 542       scm_smobs[i].apply_0    = 0;
 543       scm_smobs[i].apply_1    = 0;
 544       scm_smobs[i].apply_2    = 0;
 545       scm_smobs[i].apply_3    = 0;
 546       scm_smobs[i].gsubr_type = 0;
 547     }
 548
 549   /* WARNING: These scm_make_smob_type calls must be done in this order */
 550   tc = scm_make_smob_type ("free", 0);
 551   scm_set_smob_print (tc, free_print);
 552
 553   tc = scm_make_smob_type ("big", 0);  /* freed in gc */
 554   scm_set_smob_print (tc, scm_bigprint);
 555   scm_set_smob_equalp (tc, scm_bigequal);
 556
 557   tc = scm_make_smob_type ("real", 0);  /* freed in gc */
 558   scm_set_smob_print (tc, scm_print_real);
 559   scm_set_smob_equalp (tc, scm_real_equalp);
 560
 561   tc = scm_make_smob_type ("complex", 0);  /* freed in gc */
 562   scm_set_smob_print (tc, scm_print_complex);
 563   scm_set_smob_equalp (tc, scm_complex_equalp);
 564 }
 565
 566 /*
 567   Local Variables:
 568   c-file-style: "gnu"
 569   End:
 570 */