libguile/fluids.c

   1 /* Copyright (C) 1996,1997,2000,2001 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18
  19
  20 #include "libguile/_scm.h"
  21 #include "libguile/print.h"
  22 #include "libguile/smob.h"
  23 #include "libguile/dynwind.h"
  24 #include "libguile/fluids.h"
  25 #include "libguile/alist.h"
  26 #include "libguile/eval.h"
  27 #include "libguile/ports.h"
  28 #include "libguile/deprecation.h"
  29 #include "libguile/lang.h"
  30
  31 #define INITIAL_FLUIDS 10
  32 #include "libguile/validate.h"
  33
  34 static volatile long n_fluids;
  35 scm_t_bits scm_tc16_fluid;
  36
  37 SCM
  38 scm_make_initial_fluids ()
  39 {
  40   return scm_c_make_vector (INITIAL_FLUIDS, SCM_BOOL_F);
  41 }
  42
  43 static void
  44 grow_fluids (scm_root_state *root_state, int new_length)
  45 {
  46   SCM old_fluids, new_fluids;
  47   long old_length, i;
  48
  49   old_fluids = root_state->fluids;
  50   old_length = SCM_VECTOR_LENGTH (old_fluids);
  51   new_fluids = scm_c_make_vector (new_length, SCM_BOOL_F);
  52   i = 0;
  53   while (i < old_length)
  54     {
  55       SCM_VECTOR_SET (new_fluids, i, SCM_VELTS(old_fluids)[i]);
  56       i++;
  57     }
  58   while (i < new_length)
  59     {
  60       SCM_VECTOR_SET (new_fluids, i, SCM_BOOL_F);
  61       i++;
  62     }
  63
  64   root_state->fluids = new_fluids;
  65 }
  66
  67 void
  68 scm_copy_fluids (scm_root_state *root_state)
  69 {
  70   grow_fluids (root_state, SCM_VECTOR_LENGTH (root_state->fluids));
  71 }
  72
  73 static int
  74 fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  75 {
  76   scm_puts ("#<fluid ", port);
  77   scm_intprint ((int) SCM_FLUID_NUM (exp), 10, port);
  78   scm_putc ('>', port);
  79   return 1;
  80 }
  81
  82 static long
  83 next_fluid_num ()
  84 {
  85   long n;
  86   SCM_CRITICAL_SECTION_START;
  87   n = n_fluids++;
  88   SCM_CRITICAL_SECTION_END;
  89   return n;
  90 }
  91
  92 SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
  93             (),
  94             "Return a newly created fluid.\n"
  95             "Fluids are objects of a certain type (a smob) that can hold one SCM\n"
  96             "value per dynamic root.  That is, modifications to this value are\n"
  97             "only visible to code that executes within the same dynamic root as\n"
  98             "the modifying code.  When a new dynamic root is constructed, it\n"
  99             "inherits the values from its parent.  Because each thread executes\n"
 100             "in its own dynamic root, you can use fluids for thread local storage.")
 101 #define FUNC_NAME s_scm_make_fluid
 102 {
 103   long n;
 104
 105   n = next_fluid_num ();
 106   SCM_RETURN_NEWSMOB (scm_tc16_fluid, n);
 107 }
 108 #undef FUNC_NAME
 109
 110 SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
 111             (SCM obj),
 112             "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
 113             "@code{#f}.")
 114 #define FUNC_NAME s_scm_fluid_p
 115 {
 116   return SCM_BOOL(SCM_FLUIDP (obj));
 117 }
 118 #undef FUNC_NAME
 119
 120 SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
 121             (SCM fluid),
 122             "Return the value associated with @var{fluid} in the current\n"
 123             "dynamic root.  If @var{fluid} has not been set, then return\n"
 124             "@code{#f}.")
 125 #define FUNC_NAME s_scm_fluid_ref
 126 {
 127   unsigned long int n;
 128
 129   SCM_VALIDATE_FLUID (1, fluid);
 130   n = SCM_FLUID_NUM (fluid);
 131
 132   if (SCM_VECTOR_LENGTH (scm_root->fluids) <= n)
 133     grow_fluids (scm_root, n+1);
 134   return SCM_VELTS (scm_root->fluids)[n];
 135 }
 136 #undef FUNC_NAME
 137
 138 SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
 139             (SCM fluid, SCM value),
 140             "Set the value associated with @var{fluid} in the current dynamic root.")
 141 #define FUNC_NAME s_scm_fluid_set_x
 142 {
 143   unsigned long int n;
 144
 145   SCM_VALIDATE_FLUID (1, fluid);
 146   n = SCM_FLUID_NUM (fluid);
 147
 148   if (SCM_VECTOR_LENGTH (scm_root->fluids) <= n)
 149     grow_fluids (scm_root, n+1);
 150   SCM_VECTOR_SET (scm_root->fluids, n, value);
 151   return SCM_UNSPECIFIED;
 152 }
 153 #undef FUNC_NAME
 154
 155 void
 156 scm_swap_fluids (SCM fluids, SCM vals)
 157 {
 158   while (!SCM_NULL_OR_NIL_P (fluids))
 159     {
 160       SCM fl = SCM_CAR (fluids);
 161       SCM old_val = scm_fluid_ref (fl);
 162       scm_fluid_set_x (fl, SCM_CAR (vals));
 163       SCM_SETCAR (vals, old_val);
 164       fluids = SCM_CDR (fluids);
 165       vals = SCM_CDR (vals);
 166     }
 167 }
 168
 169 /* Swap the fluid values in reverse order.  This is important when the
 170 same fluid appears multiple times in the fluids list. */
 171
 172 void
 173 scm_swap_fluids_reverse (SCM fluids, SCM vals)
 174 {
 175   if (!SCM_NULL_OR_NIL_P (fluids))
 176     {
 177       SCM fl, old_val;
 178
 179       scm_swap_fluids_reverse (SCM_CDR (fluids), SCM_CDR (vals));
 180       fl = SCM_CAR (fluids);
 181       old_val = scm_fluid_ref (fl);
 182       scm_fluid_set_x (fl, SCM_CAR (vals));
 183       SCM_SETCAR (vals, old_val);
 184     }
 185 }
 186
 187
 188 static SCM
 189 apply_thunk (void *thunk)
 190 {
 191   return scm_call_0 (SCM_PACK (thunk));
 192 }
 193
 194 SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
 195             (SCM fluids, SCM values, SCM thunk),
 196             "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
 197             "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
 198             "number of their values to be applied.  Each substitution is done\n"
 199             "one after another.  @var{thunk} must be a procedure with no argument.")
 200 #define FUNC_NAME s_scm_with_fluids
 201 {
 202   return scm_c_with_fluids (fluids, values, apply_thunk, (void *) SCM_UNPACK (thunk));
 203 }
 204 #undef FUNC_NAME
 205
 206 SCM
 207 scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
 208 #define FUNC_NAME "scm_c_with_fluids"
 209 {
 210   SCM ans;
 211   long flen, vlen;
 212
 213   SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
 214   SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
 215   if (flen != vlen)
 216     scm_out_of_range (s_scm_with_fluids, values);
 217
 218   scm_swap_fluids (fluids, values);
 219   scm_dynwinds = scm_acons (fluids, values, scm_dynwinds);
 220   ans = cproc (cdata);
 221   scm_dynwinds = SCM_CDR (scm_dynwinds);
 222   scm_swap_fluids_reverse (fluids, values);
 223   return ans;
 224 }
 225 #undef FUNC_NAME
 226
 227 SCM
 228 scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
 229 #define FUNC_NAME "scm_c_with_fluid"
 230 {
 231   return scm_c_with_fluids (scm_list_1 (fluid), scm_list_1 (value),
 232                             cproc, cdata);
 233 }
 234 #undef FUNC_NAME
 235
 236 void
 237 scm_init_fluids ()
 238 {
 239   scm_tc16_fluid = scm_make_smob_type ("fluid", 0);
 240   scm_set_smob_print (scm_tc16_fluid, fluid_print);
 241 #include "libguile/fluids.x"
 242 }
 243
 244 /*
 245   Local Variables:
 246   c-file-style: "gnu"
 247   End:
 248 */