libguile/fluids.c

   1 /*      Copyright (C) 1996 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 #include <assert.h>
  43
  44 #include "_scm.h"
  45 #include "print.h"
  46 #include "smob.h"
  47 #include "fluids.h"
  48
  49 #define INITIAL_FLUIDS 10
  50
  51 static volatile int n_fluids;
  52 long scm_tc16_fluid;
  53
  54 SCM
  55 scm_make_initial_fluids ()
  56 {
  57   return scm_make_vector (SCM_MAKINUM (INITIAL_FLUIDS),
  58                           SCM_BOOL_F, SCM_BOOL_F);
  59 }
  60
  61 static void grow_fluids SCM_P ((scm_root_state *, int new_length));
  62 static void
  63 grow_fluids (root_state, new_length)
  64      scm_root_state *root_state;
  65      int new_length;
  66 {
  67   SCM old_fluids, new_fluids;
  68   int old_length, i;
  69
  70   old_fluids = root_state->fluids;
  71   assert (SCM_NIMP (old_fluids) && SCM_VECTORP (old_fluids));
  72   old_length = SCM_LENGTH (old_fluids);
  73   assert (old_length <= new_length);
  74   new_fluids = scm_make_vector (SCM_MAKINUM (new_length),
  75                                 SCM_BOOL_F, SCM_BOOL_F);
  76   i = 0;
  77   while (i < old_length)
  78     {
  79       SCM_VELTS(new_fluids)[i] = SCM_VELTS(old_fluids)[i];
  80       i++;
  81     }
  82   while (i < new_length)
  83     {
  84       SCM_VELTS(new_fluids)[i] = SCM_BOOL_F;
  85       i++;
  86     }
  87
  88   root_state->fluids = new_fluids;
  89 }
  90
  91 void
  92 scm_copy_fluids (root_state)
  93      scm_root_state *root_state;
  94 {
  95   grow_fluids (root_state, SCM_LENGTH(root_state->fluids));
  96 }
  97
  98 static int print_fluid SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
  99 static int
 100 print_fluid (exp, port, pstate)
 101      SCM exp;
 102      SCM port;
 103      scm_print_state *pstate;
 104 {
 105     scm_gen_puts (scm_regular_string, "#<fluid ", port);
 106     scm_intprint (SCM_FLUID_NUM (exp), 10, port);
 107     scm_gen_putc ('>', port);
 108     return 1;
 109 }
 110
 111 static scm_smobfuns fluid_smob = {
 112     scm_mark0,
 113     scm_free0,
 114     print_fluid
 115 };
 116
 117 static
 118 int next_fluid_num ()
 119 {
 120   int n;
 121 #ifdef USE_THREADS
 122   SCM_THREAD_CRITICAL_SECTION_START;
 123 #endif
 124   n = n_fluids++;
 125 #ifdef USE_THREADS
 126   SCM_THREAD_CRITICAL_SECTION_END;
 127 #endif
 128   return n;
 129 }
 130
 131 SCM_PROC (s_make_fluid, "make-fluid", 0, 0, 0, scm_make_fluid);
 132
 133 SCM
 134 scm_make_fluid ()
 135 {
 136   SCM z;
 137   int n;
 138
 139   SCM_DEFER_INTS;
 140   n = next_fluid_num ();
 141   SCM_NEWCELL (z);
 142   SCM_SETCAR (z, scm_tc16_fluid);
 143   SCM_SETCDR (z, n);
 144   SCM_ALLOW_INTS;
 145
 146   return z;
 147 }
 148
 149 SCM_PROC (s_fluid_ref, "fluid-ref", 1, 0, 0, scm_fluid_ref);
 150
 151 SCM
 152 scm_fluid_ref (fl)
 153      SCM fl;
 154 {
 155   int n;
 156
 157   SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), SCM_ARG1, fl, s_fluid_ref);
 158
 159   n = SCM_FLUID_NUM (fl);
 160   assert (n >= 0 && n < n_fluids);
 161
 162   if (SCM_LENGTH (scm_root->fluids) <= n)
 163     grow_fluids (scm_root, n+1);
 164   return SCM_VELTS(scm_root->fluids)[n];
 165 }
 166
 167 SCM_PROC (s_fluid_set_x, "fluid-set!", 2, 0, 0, scm_fluid_set_x);
 168
 169 SCM
 170 scm_fluid_set_x (fl, val)
 171      SCM fl;
 172      SCM val;
 173 {
 174   int n;
 175
 176   SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), SCM_ARG1, fl, s_fluid_set_x);
 177
 178   n = SCM_FLUID_NUM (fl);
 179   assert (n >= 0 && n < n_fluids);
 180
 181   if (SCM_LENGTH (scm_root->fluids) <= n)
 182     grow_fluids (scm_root, n+1);
 183   SCM_VELTS(scm_root->fluids)[n] = val;
 184   return val;
 185 }
 186
 187 void
 188 scm_init_fluids ()
 189 {
 190   scm_tc16_fluid = scm_newsmob(&fluid_smob);
 191 #include "fluids.x"
 192 }