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 SCM
 129 scm_smob_apply_0 (SCM smob)
 130 {
 131   int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type;
 132   switch (type)
 133     {
 134     case SCM_GSUBR_MAKTYPE (0, 0, 0):
 135       return SCM_SMOB_DESCRIPTOR (smob).apply ();
 136     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 137       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_UNDEFINED);
 138     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 139       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_EOL);
 140     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 141       return SCM_SMOB_DESCRIPTOR (smob).apply (smob,
 142                                                SCM_UNDEFINED,
 143                                                SCM_UNDEFINED);
 144     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 145       return SCM_SMOB_DESCRIPTOR (smob).apply (smob,
 146                                                SCM_UNDEFINED,
 147                                                SCM_EOL);
 148     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 149       return SCM_SMOB_DESCRIPTOR (smob).apply (smob,
 150                                                SCM_UNDEFINED,
 151                                                SCM_UNDEFINED,
 152                                                SCM_UNDEFINED);
 153     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 154       return SCM_SMOB_DESCRIPTOR (smob).apply (smob,
 155                                                SCM_UNDEFINED,
 156                                                SCM_UNDEFINED,
 157                                                SCM_EOL);
 158     default:
 159       if (SCM_GSUBR_REQ (type) > 0)
 160         scm_wrong_num_args (smob);
 161       scm_misc_error ("scm_smob_apply_0",
 162                       "Unsupported smob application: ~S",
 163                       SCM_LIST1 (smob));
 164     }
 165 }
 166
 167 SCM
 168 scm_smob_apply_1 (SCM smob, SCM a1)
 169 {
 170   int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type;
 171   switch (type)
 172     {
 173     case SCM_GSUBR_MAKTYPE (0, 0, 0):
 174       scm_wrong_num_args (smob);
 175     case SCM_GSUBR_MAKTYPE (1, 0, 0):
 176     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 177       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1);
 178     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 179       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_LIST1 (a1));
 180     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 181     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 182       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_UNDEFINED);
 183     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 184     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 185       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_EOL);
 186     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 187     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 188       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1,
 189                                                SCM_UNDEFINED,
 190                                                SCM_UNDEFINED);
 191     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 192     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 193       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1,
 194                                                SCM_UNDEFINED,
 195                                                SCM_EOL);
 196     default:
 197       if (SCM_GSUBR_REQ (type) > 1)
 198         scm_wrong_num_args (smob);
 199       scm_misc_error ("scm_smob_apply_1",
 200                       "Unsupported smob application: ~S",
 201                       SCM_LIST1 (smob));
 202     }
 203 }
 204
 205 SCM
 206 scm_smob_apply_2 (SCM smob, SCM a1, SCM a2)
 207 {
 208   int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type;
 209   switch (type)
 210     {
 211     case SCM_GSUBR_MAKTYPE (0, 0, 0):
 212     case SCM_GSUBR_MAKTYPE (1, 0, 0):
 213     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 214       scm_wrong_num_args (smob);
 215     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 216       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_LIST2 (a1, a2));
 217     case SCM_GSUBR_MAKTYPE (2, 0, 0):
 218     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 219     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 220       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2);
 221     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 222     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 223       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_LIST1 (a2));
 224     case SCM_GSUBR_MAKTYPE (2, 1, 0):
 225     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 226     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 227       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_UNDEFINED);
 228     case SCM_GSUBR_MAKTYPE (2, 0, 1):
 229     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 230     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 231       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_EOL);
 232     default:
 233       if (SCM_GSUBR_REQ (type) > 2)
 234         scm_wrong_num_args (smob);
 235       scm_misc_error ("scm_smob_apply_2",
 236                       "Unsupported smob application: ~S",
 237                       SCM_LIST1 (smob));
 238     }
 239 }
 240
 241 SCM
 242 scm_smob_apply_3 (SCM smob, SCM a1, SCM a2, SCM rest)
 243 {
 244   int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type;
 245   switch (type)
 246     {
 247     case SCM_GSUBR_MAKTYPE (0, 0, 0):
 248     case SCM_GSUBR_MAKTYPE (1, 0, 0):
 249     case SCM_GSUBR_MAKTYPE (0, 1, 0):
 250     case SCM_GSUBR_MAKTYPE (2, 0, 0):
 251     case SCM_GSUBR_MAKTYPE (1, 1, 0):
 252     case SCM_GSUBR_MAKTYPE (0, 2, 0):
 253       scm_wrong_num_args (smob);
 254     case SCM_GSUBR_MAKTYPE (0, 0, 1):
 255       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, scm_cons (a1, scm_cons (a2, rest)));
 256     case SCM_GSUBR_MAKTYPE (1, 0, 1):
 257     case SCM_GSUBR_MAKTYPE (0, 1, 1):
 258       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, scm_cons (a2, rest));
 259     case SCM_GSUBR_MAKTYPE (3, 0, 0):
 260     case SCM_GSUBR_MAKTYPE (2, 1, 0):
 261     case SCM_GSUBR_MAKTYPE (1, 2, 0):
 262     case SCM_GSUBR_MAKTYPE (0, 3, 0):
 263       if (!SCM_NULLP (SCM_CDR (rest)))
 264         scm_wrong_num_args (smob);
 265       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_CAR (rest));
 266     case SCM_GSUBR_MAKTYPE (2, 0, 1):
 267     case SCM_GSUBR_MAKTYPE (1, 1, 1):
 268     case SCM_GSUBR_MAKTYPE (0, 2, 1):
 269       return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, rest);
 270     default:
 271       if (SCM_GSUBR_REQ (type) > 3)
 272         scm_wrong_num_args (smob);
 273       scm_misc_error ("scm_smob_apply_3",
 274                       "Unsupported smob application: ~S",
 275                       SCM_LIST1 (smob));
 276     }
 277 }
 278
 279 long
 280 scm_make_smob_type (char *name, scm_sizet size)
 281 {
 282   char *tmp;
 283   if (255 <= scm_numsmob)
 284     goto smoberr;
 285   SCM_DEFER_INTS;
 286   SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_smobs,
 287                                        (1 + scm_numsmob)
 288                                        * sizeof (scm_smob_descriptor)));
 289   if (tmp)
 290     {
 291       scm_smobs = (scm_smob_descriptor *) tmp;
 292       scm_smobs[scm_numsmob].name = name;
 293       scm_smobs[scm_numsmob].size = size;
 294       scm_smobs[scm_numsmob].mark = 0;
 295       scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free);
 296       scm_smobs[scm_numsmob].print = scm_smob_print;
 297       scm_smobs[scm_numsmob].equalp = 0;
 298       scm_smobs[scm_numsmob].apply = 0;
 299       scm_smobs[scm_numsmob].gsubr_type = 0;
 300       scm_numsmob++;
 301     }
 302   SCM_ALLOW_INTS;
 303   if (!tmp)
 304     {
 305     smoberr:
 306       scm_memory_error ("scm_make_smob_type");
 307     }
 308   /* Make a class object if Goops is present. */
 309   if (scm_smob_class)
 310     scm_smob_class[scm_numsmob - 1]
 311       = scm_make_extended_class (SCM_SMOBNAME (scm_numsmob - 1));
 312   return scm_tc7_smob + (scm_numsmob - 1) * 256;
 313 }
 314
 315 long
 316 scm_make_smob_type_mfpe (char *name, scm_sizet size,
 317                         SCM (*mark) (SCM),
 318                         scm_sizet (*free) (SCM),
 319                         int (*print) (SCM, SCM, scm_print_state *),
 320                         SCM (*equalp) (SCM, SCM))
 321 {
 322   long answer = scm_make_smob_type (name, size);
 323   scm_set_smob_mfpe (answer, mark, free, print, equalp);
 324   return answer;
 325 }
 326
 327 void
 328 scm_set_smob_mark (long tc, SCM (*mark) (SCM))
 329 {
 330   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 331 }
 332
 333 void
 334 scm_set_smob_free (long tc, scm_sizet (*free) (SCM))
 335 {
 336   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 337 }
 338
 339 void
 340 scm_set_smob_print (long tc, int (*print) (SCM, SCM, scm_print_state*))
 341 {
 342   scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
 343 }
 344
 345 void
 346 scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM))
 347 {
 348   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 349 }
 350
 351 void
 352 scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst)
 353 {
 354   scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
 355   scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = SCM_GSUBR_MAKTYPE (req, opt, rst);
 356 }
 357
 358 void
 359 scm_set_smob_mfpe (long tc,
 360                    SCM (*mark) (SCM),
 361                    scm_sizet (*free) (SCM),
 362                    int (*print) (SCM, SCM, scm_print_state *),
 363                    SCM (*equalp) (SCM, SCM))
 364 {
 365   if (mark) scm_set_smob_mark (tc, mark);
 366   if (free) scm_set_smob_free (tc, free);
 367   if (print) scm_set_smob_print (tc, print);
 368   if (equalp) scm_set_smob_equalp (tc, equalp);
 369 }
 370
 371
 372 SCM
 373 scm_make_smob (long tc)
 374 {
 375   int n = SCM_TC2SMOBNUM (tc);
 376   scm_sizet size = scm_smobs[n].size;
 377   SCM z;
 378   SCM_NEWCELL (z);
 379   if (size != 0)
 380     {
 381 #if 0
 382       SCM_ASSERT (scm_smobs[n].mark == 0,
 383                   0,
 384                   "forbidden operation for smobs with GC data, use SCM_NEWSMOB",
 385                   SCM_SMOBNAME (n));
 386 #endif
 387       SCM_SET_SMOB_DATA (z, scm_must_malloc (size, SCM_SMOBNAME (n)));
 388     }
 389   SCM_SET_CELL_TYPE (z, tc);
 390   return z;
 391 }
 392
 393 \f
 394 /* {Initialization for i/o types, float, bignum, the type of free cells}
 395  */
 396
 397 static int
 398 freeprint (SCM exp,
 399            SCM port,
 400            scm_print_state *pstate)
 401 {
 402   char buf[100];
 403
 404   sprintf (buf, "#<freed cell %p; GC missed a reference>", (void *) SCM_UNPACK (exp));
 405   scm_puts (buf, port);
 406
 407   return 1;
 408 }
 409
 410
 411 void
 412 scm_smob_prehistory ()
 413 {
 414   scm_numsmob = 0;
 415   scm_smobs = ((scm_smob_descriptor *)
 416                malloc (7 * sizeof (scm_smob_descriptor)));
 417
 418   /* WARNING: These scm_make_smob_type calls must be done in this order */
 419   scm_make_smob_type_mfpe ("free", 0,
 420                           NULL, NULL, freeprint, NULL);
 421
 422   scm_make_smob_type_mfpe ("big", 0,     /* freed in gc */
 423                           NULL, NULL, scm_bigprint, scm_bigequal);
 424
 425   scm_make_smob_type_mfpe ("real", 0,    /* freed in gc */
 426                            NULL, NULL, scm_print_real, scm_real_equalp);
 427
 428   scm_make_smob_type_mfpe ("complex", 0,    /* freed in gc */
 429                            NULL, NULL, scm_print_complex, scm_complex_equalp);
 430
 431   scm_make_smob_type ("allocated", 0);
 432 }
 433
 434 /*
 435   Local Variables:
 436   c-file-style: "gnu"
 437   End:
 438 */