libguile/smob.c

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