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 long 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 SCM_UNUSED)
  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 SCM_UNUSED)
 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 SCM_UNUSED)
 121 {
 122   long 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_list_1 (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 SCM_UNUSED)
 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_list_2 (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_list_1 (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_UNUSED, SCM a2 SCM_UNUSED)
 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,
 282                         SCM a1 SCM_UNUSED,
 283                         SCM a2 SCM_UNUSED,
 284                         SCM rst SCM_UNUSED)
 285 {
 286   scm_wrong_num_args (smob);
 287 }
 288
 289 \f
 290
 291 scm_t_bits
 292 scm_make_smob_type (char *name, size_t size)
 293 #define FUNC_NAME "scm_make_smob_type"
 294 {
 295   long new_smob;
 296
 297   SCM_ENTER_A_SECTION;  /* scm_numsmob */
 298   new_smob = scm_numsmob;
 299   if (scm_numsmob != MAX_SMOB_COUNT)
 300     ++scm_numsmob;
 301   SCM_EXIT_A_SECTION;
 302
 303   if (new_smob == MAX_SMOB_COUNT)
 304     scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
 305
 306   scm_smobs[new_smob].name = name;
 307   if (size != 0)
 308     {
 309       scm_smobs[new_smob].size = size;
 310       scm_smobs[new_smob].free = scm_smob_free;
 311     }
 312
 313   /* Make a class object if Goops is present. */
 314   if (scm_smob_class)
 315     scm_smob_class[new_smob] = scm_make_extended_class (name);
 316
 317   return scm_tc7_smob + new_smob * 256;
 318 }
 319 #undef FUNC_NAME
 320
 321
 322 void
 323 scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
 324 {
 325   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 326 }
 327
 328 void
 329 scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
 330 {
 331   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 332 }
 333
 334 void
 335 scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
 336 {
 337   scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
 338 }
 339
 340 void
 341 scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
 342 {
 343   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 344 }
 345
 346 void
 347 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
 348                     unsigned int req, unsigned int opt, unsigned int rst)
 349 {
 350   SCM (*apply_0) (SCM);
 351   SCM (*apply_1) (SCM, SCM);
 352   SCM (*apply_2) (SCM, SCM, SCM);
 353   SCM (*apply_3) (SCM, SCM, SCM, SCM);
 354   int type = SCM_GSUBR_MAKTYPE (req, opt, rst);
 355
 356   if (rst > 1 || req + opt + rst > 3)
 357     {
 358       puts ("Unsupported smob application type");
 359       abort ();
 360     }
 361
 362   switch (type)
 363     {
 364     case SCM_GSUBR_MAKTYPE (0, 0, 0):
 365       apply_0 = apply; break;
 366     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 367       apply_0 = scm_smob_apply_0_010; break;
 368     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 369       apply_0 = scm_smob_apply_0_020; break;
 370     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 371       apply_0 = scm_smob_apply_0_030; break;
 372     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 373       apply_0 = scm_smob_apply_0_001; break;
 374     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 375       apply_0 = scm_smob_apply_0_011; break;
 376     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 377       apply_0 = scm_smob_apply_0_021; break;
 378     default:
 379       apply_0 = scm_smob_apply_0_error; break;
 380     }
 381
 382   switch (type)
 383     {
 384     case SCM_GSUBR_MAKTYPE (1, 0, 0):
 385     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 386       apply_1 = apply; break;
 387     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 388     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 389       apply_1 = scm_smob_apply_1_020; break;
 390     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 391     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 392       apply_1 = scm_smob_apply_1_030; break;
 393     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 394       apply_1 = scm_smob_apply_1_001; break;
 395     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 396     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 397       apply_1 = scm_smob_apply_1_011; break;
 398     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 399     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 400       apply_1 = scm_smob_apply_1_021; break;
 401     default:
 402       apply_1 = scm_smob_apply_1_error; break;
 403     }
 404
 405   switch (type)
 406     {
 407     case SCM_GSUBR_MAKTYPE (2, 0, 0):
 408     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 409     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 410       apply_2 = apply; break;
 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_2 = scm_smob_apply_2_030; break;
 415     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 416       apply_2 = scm_smob_apply_2_001; break;
 417     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 418     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 419       apply_2 = scm_smob_apply_2_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_2 = scm_smob_apply_2_021; break;
 424     default:
 425       apply_2 = scm_smob_apply_2_error; break;
 426     }
 427
 428   switch (type)
 429     {
 430     case SCM_GSUBR_MAKTYPE (3, 0, 0):
 431     case SCM_GSUBR_MAKTYPE (2, 1, 0):
 432     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 433     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 434       apply_3 = scm_smob_apply_3_030; break;
 435     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 436       apply_3 = scm_smob_apply_3_001; break;
 437     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 438     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 439       apply_3 = scm_smob_apply_3_011; break;
 440     case SCM_GSUBR_MAKTYPE (2, 0, 1):
 441     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 442     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 443       apply_3 = scm_smob_apply_3_021; break;
 444     default:
 445       apply_3 = scm_smob_apply_3_error; break;
 446     }
 447
 448   scm_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
 449   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
 450   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
 451   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
 452   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
 453   scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
 454 }
 455
 456 SCM
 457 scm_make_smob (scm_t_bits tc)
 458 {
 459   long n = SCM_TC2SMOBNUM (tc);
 460   size_t size = scm_smobs[n].size;
 461   SCM z;
 462   SCM_NEWCELL (z);
 463   if (size != 0)
 464     {
 465 #if 0
 466       if (scm_smobs[n].mark != 0)
 467         {
 468           fprintf
 469             (stderr,
 470              "forbidden operation for smobs with GC data, use SCM_NEWSMOB\n");
 471           abort ();
 472         }
 473 #endif
 474       SCM_SET_SMOB_DATA (z, scm_must_malloc (size, SCM_SMOBNAME (n)));
 475     }
 476   SCM_SET_CELL_TYPE (z, tc);
 477   return z;
 478 }
 479
 480 \f
 481 /* {Deprecated stuff}
 482  */
 483
 484 #if (SCM_DEBUG_DEPRECATED == 0)
 485
 486 long
 487 scm_make_smob_type_mfpe (char *name, size_t size,
 488                         SCM (*mark) (SCM),
 489                         size_t (*free) (SCM),
 490                         int (*print) (SCM, SCM, scm_print_state *),
 491                         SCM (*equalp) (SCM, SCM))
 492 {
 493   long answer = scm_make_smob_type (name, size);
 494   scm_set_smob_mfpe (answer, mark, free, print, equalp);
 495   return answer;
 496 }
 497
 498 void
 499 scm_set_smob_mfpe (long tc,
 500                    SCM (*mark) (SCM),
 501                    size_t (*free) (SCM),
 502                    int (*print) (SCM, SCM, scm_print_state *),
 503                    SCM (*equalp) (SCM, SCM))
 504 {
 505   if (mark) scm_set_smob_mark (tc, mark);
 506   if (free) scm_set_smob_free (tc, free);
 507   if (print) scm_set_smob_print (tc, print);
 508   if (equalp) scm_set_smob_equalp (tc, equalp);
 509 }
 510
 511 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
 512
 513 \f
 514 /* {Initialization for i/o types, float, bignum, the type of free cells}
 515  */
 516
 517 static int
 518 free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 519 {
 520   char buf[100];
 521
 522   sprintf (buf, "#<freed cell %p; GC missed a reference>",
 523            (void *) SCM_UNPACK (exp));
 524   scm_puts (buf, port);
 525
 526   return 1;
 527 }
 528
 529 void
 530 scm_smob_prehistory ()
 531 {
 532   long i;
 533   scm_t_bits tc;
 534
 535   scm_numsmob = 0;
 536   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 537     {
 538       scm_smobs[i].name       = 0;
 539       scm_smobs[i].size       = 0;
 540       scm_smobs[i].mark       = 0;
 541       scm_smobs[i].free       = 0;
 542       scm_smobs[i].print      = scm_smob_print;
 543       scm_smobs[i].equalp     = 0;
 544       scm_smobs[i].apply      = 0;
 545       scm_smobs[i].apply_0    = 0;
 546       scm_smobs[i].apply_1    = 0;
 547       scm_smobs[i].apply_2    = 0;
 548       scm_smobs[i].apply_3    = 0;
 549       scm_smobs[i].gsubr_type = 0;
 550     }
 551
 552   /* WARNING: These scm_make_smob_type calls must be done in this order */
 553   tc = scm_make_smob_type ("free", 0);
 554   scm_set_smob_print (tc, free_print);
 555
 556   tc = scm_make_smob_type ("big", 0);  /* freed in gc */
 557   scm_set_smob_print (tc, scm_bigprint);
 558   scm_set_smob_equalp (tc, scm_bigequal);
 559
 560   tc = scm_make_smob_type ("real", 0);  /* freed in gc */
 561   scm_set_smob_print (tc, scm_print_real);
 562   scm_set_smob_equalp (tc, scm_real_equalp);
 563
 564   tc = scm_make_smob_type ("complex", 0);  /* freed in gc */
 565   scm_set_smob_print (tc, scm_print_complex);
 566   scm_set_smob_equalp (tc, scm_complex_equalp);
 567 }
 568
 569 /*
 570   Local Variables:
 571   c-file-style: "gnu"
 572   End:
 573 */