libguile/smob.c

   1 /*      Copyright (C) 1995, 1996, 1998, 1999 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 "_scm.h"
  49
  50 #include "objects.h"
  51
  52 #ifdef HAVE_MALLOC_H
  53 #include <malloc.h>
  54 #endif
  55
  56 #include "smob.h"
  57
  58 \f
  59
  60 /* scm_smobs scm_numsmob
  61  * implement a dynamicly resized array of smob records.
  62  * Indexes into this table are used when generating type
  63  * tags for smobjects (if you know a tag you can get an index and conversely).
  64  */
  65 int scm_numsmob;
  66 scm_smob_descriptor *scm_smobs;
  67
  68 /* {Mark}
  69  */
  70
  71 /* This function is vestigial.  It used to be the mark function's
  72    responsibility to set the mark bit on the smob or port, but now the
  73    generic marking routine in gc.c takes care of that, and a zero
  74    pointer for a mark function means "don't bother".  So you never
  75    need scm_mark0.
  76
  77    However, we leave it here because it's harmless to call it, and
  78    people out there have smob code that uses it, and there's no reason
  79    to make their links fail.  */
  80
  81 SCM
  82 scm_mark0 (SCM ptr)
  83 {
  84   return SCM_BOOL_F;
  85 }
  86
  87 SCM
  88 scm_markcdr (SCM ptr)
  89 {
  90   return SCM_CDR (ptr);
  91 }
  92
  93 /* {Free}
  94  */
  95
  96 scm_sizet
  97 scm_free0 (SCM ptr)
  98 {
  99   return 0;
 100 }
 101
 102 scm_sizet
 103 scm_smob_free (SCM obj)
 104 {
 105   scm_must_free ((char *) SCM_CDR (obj));
 106   return scm_smobs[SCM_SMOBNUM (obj)].size;
 107 }
 108
 109 /* {Print}
 110  */
 111
 112 int
 113 scm_smob_print (SCM exp, SCM port, scm_print_state *pstate)
 114 {
 115   int n = SCM_SMOBNUM (exp);
 116   scm_puts ("#<", port);
 117   scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 118   scm_putc (' ', port);
 119   scm_intprint (scm_smobs[n].size ? SCM_CDR (exp) : exp, 16, port);
 120   scm_putc ('>', port);
 121   return 1;
 122 }
 123
 124 long
 125 scm_make_smob_type (char *name, scm_sizet size)
 126 {
 127   char *tmp;
 128   if (255 <= scm_numsmob)
 129     goto smoberr;
 130   SCM_DEFER_INTS;
 131   SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_smobs,
 132                                        (1 + scm_numsmob)
 133                                        * sizeof (scm_smob_descriptor)));
 134   if (tmp)
 135     {
 136       scm_smobs = (scm_smob_descriptor *) tmp;
 137       scm_smobs[scm_numsmob].name = name;
 138       scm_smobs[scm_numsmob].size = size;
 139       scm_smobs[scm_numsmob].mark = 0;
 140       scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free);
 141       scm_smobs[scm_numsmob].print = scm_smob_print;
 142       scm_smobs[scm_numsmob].equalp = 0;
 143       scm_numsmob++;
 144     }
 145   SCM_ALLOW_INTS;
 146   if (!tmp)
 147   smoberr:scm_wta (SCM_MAKINUM ((long) scm_numsmob),
 148                    (char *) SCM_NALLOC, "scm_make_smob_type");
 149   /* Make a class object if Goops is present. */
 150   if (scm_smob_class)
 151     scm_smob_class[scm_numsmob - 1]
 152       = scm_make_extended_class (SCM_SMOBNAME (scm_numsmob - 1));
 153   return scm_tc7_smob + (scm_numsmob - 1) * 256;
 154 }
 155
 156 long
 157 scm_make_smob_type_mfpe (char *name, scm_sizet size,
 158                         SCM (*mark) (SCM),
 159                         scm_sizet (*free) (SCM),
 160                         int (*print) (SCM, SCM, scm_print_state *),
 161                         SCM (*equalp) (SCM, SCM))
 162 {
 163   long answer = scm_make_smob_type (name, size);
 164   scm_set_smob_mfpe (answer, mark, free, print, equalp);
 165   return answer;
 166 }
 167
 168 void
 169 scm_set_smob_mark (long tc, SCM (*mark) (SCM))
 170 {
 171   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 172 }
 173
 174 void
 175 scm_set_smob_free (long tc, scm_sizet (*free) (SCM))
 176 {
 177   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 178 }
 179
 180 void
 181 scm_set_smob_print (long tc, int (*print) (SCM, SCM, scm_print_state*))
 182 {
 183   scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
 184 }
 185
 186 void
 187 scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM))
 188 {
 189   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 190 }
 191
 192 void
 193 scm_set_smob_mfpe (long tc,
 194                    SCM (*mark) (SCM),
 195                    scm_sizet (*free) (SCM),
 196                    int (*print) (SCM, SCM, scm_print_state *),
 197                    SCM (*equalp) (SCM, SCM))
 198 {
 199   if (mark) scm_set_smob_mark (tc, mark);
 200   if (free) scm_set_smob_free (tc, free);
 201   if (print) scm_set_smob_print (tc, print);
 202   if (equalp) scm_set_smob_equalp (tc, equalp);
 203 }
 204
 205 /* Deprecated function - use scm_make_smob_type, or scm_make_smob_type_mfpe
 206    instead. */
 207 long
 208 scm_newsmob (const scm_smobfuns *smob)
 209 {
 210   long tc = scm_make_smob_type (0, 0);
 211   scm_set_smob_mark (tc, smob->mark);
 212   scm_set_smob_free (tc, smob->free);
 213   scm_set_smob_print (tc, smob->print);
 214   scm_set_smob_equalp (tc, smob->equalp);
 215   return tc;
 216 }
 217
 218
 219 SCM
 220 scm_make_smob (long tc)
 221 {
 222   int n = SCM_TC2SMOBNUM (tc);
 223   scm_sizet size = scm_smobs[n].size;
 224   SCM z;
 225   SCM_NEWCELL (z);
 226   if (size != 0)
 227     {
 228 #if 0
 229       SCM_ASSERT (scm_smobs[n].mark == 0,
 230                   0,
 231                   "forbidden operation for smobs with GC data, use SCM_NEWSMOB",
 232                   SCM_SMOBNAME (n));
 233 #endif
 234       SCM_SET_SMOB_DATA (z, scm_must_malloc (size, SCM_SMOBNAME (n)));
 235     }
 236   SCM_SETCAR (z, tc);
 237   return z;
 238 }
 239
 240 \f
 241 /* {Initialization for i/o types, float, bignum, the type of free cells}
 242  */
 243
 244 static int
 245 freeprint (SCM exp,
 246            SCM port,
 247            scm_print_state *pstate)
 248 {
 249   char buf[100];
 250
 251   sprintf (buf, "#<freed cell %p; GC missed a reference>", (void *) exp);
 252   scm_puts (buf, port);
 253
 254   return 1;
 255 }
 256
 257
 258 void
 259 scm_smob_prehistory ()
 260 {
 261   scm_numsmob = 0;
 262   scm_smobs = ((scm_smob_descriptor *)
 263                malloc (7 * sizeof (scm_smob_descriptor)));
 264
 265   /* WARNING: These scm_make_smob_type calls must be done in this order */
 266   scm_make_smob_type_mfpe ("free", 0,
 267                           NULL, NULL, freeprint, NULL);
 268
 269   scm_make_smob_type_mfpe ("flo", 0,    /* freed in gc */
 270                           NULL, NULL, scm_floprint, scm_floequal);
 271
 272   scm_make_smob_type_mfpe ("bigpos", 0,     /* freed in gc */
 273                           NULL, NULL, scm_bigprint, scm_bigequal);
 274
 275   scm_make_smob_type_mfpe ("bigneg", 0,
 276                           NULL, NULL, scm_bigprint, scm_bigequal);
 277
 278   scm_make_smob_type("allocated", 0);
 279 }