libguile/fluids.c

   1 /* Copyright (C) 1996,1997,2000,2001, 2004 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_i_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_i_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 static void
 156 swap_fluids (SCM data)
 157 {
 158   SCM fluids = SCM_CAR (data), vals = SCM_CDR (data);
 159
 160   while (!SCM_NULL_OR_NIL_P (fluids))
 161     {
 162       SCM fl = SCM_CAR (fluids);
 163       SCM old_val = scm_fluid_ref (fl);
 164       scm_fluid_set_x (fl, SCM_CAR (vals));
 165       SCM_SETCAR (vals, old_val);
 166       fluids = SCM_CDR (fluids);
 167       vals = SCM_CDR (vals);
 168     }
 169 }
 170
 171 /* Swap the fluid values in reverse order.  This is important when the
 172 same fluid appears multiple times in the fluids list. */
 173
 174 static void
 175 swap_fluids_reverse_aux (SCM fluids, SCM vals)
 176 {
 177   if (!SCM_NULL_OR_NIL_P (fluids))
 178     {
 179       SCM fl, old_val;
 180
 181       swap_fluids_reverse_aux (SCM_CDR (fluids), SCM_CDR (vals));
 182       fl = SCM_CAR (fluids);
 183       old_val = scm_fluid_ref (fl);
 184       scm_fluid_set_x (fl, SCM_CAR (vals));
 185       SCM_SETCAR (vals, old_val);
 186     }
 187 }
 188
 189 static void
 190 swap_fluids_reverse (SCM data)
 191 {
 192   swap_fluids_reverse_aux (SCM_CAR (data), SCM_CDR (data));
 193 }
 194
 195 static SCM
 196 apply_thunk (void *thunk)
 197 {
 198   return scm_call_0 (SCM_PACK (thunk));
 199 }
 200
 201 SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
 202             (SCM fluids, SCM values, SCM thunk),
 203             "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
 204             "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
 205             "number of their values to be applied.  Each substitution is done\n"
 206             "one after another.  @var{thunk} must be a procedure with no argument.")
 207 #define FUNC_NAME s_scm_with_fluids
 208 {
 209   return scm_c_with_fluids (fluids, values,
 210                             apply_thunk, (void *) SCM_UNPACK (thunk));
 211 }
 212 #undef FUNC_NAME
 213
 214 SCM
 215 scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
 216 #define FUNC_NAME "scm_c_with_fluids"
 217 {
 218   SCM ans, data;
 219   long flen, vlen;
 220
 221   SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
 222   SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
 223   if (flen != vlen)
 224     scm_out_of_range (s_scm_with_fluids, values);
 225
 226   if (flen == 1)
 227     return scm_c_with_fluid (SCM_CAR (fluids), SCM_CAR (values),
 228                              cproc, cdata);
 229
 230   data = scm_cons (fluids, values);
 231   scm_frame_begin (SCM_F_FRAME_REWINDABLE);
 232   scm_frame_rewind_handler_with_scm (swap_fluids, data,
 233                                      SCM_F_WIND_EXPLICITLY);
 234   scm_frame_unwind_handler_with_scm (swap_fluids_reverse, data,
 235                                      SCM_F_WIND_EXPLICITLY);
 236   ans = cproc (cdata);
 237   scm_frame_end ();
 238   return ans;
 239 }
 240 #undef FUNC_NAME
 241
 242 SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0,
 243             (SCM fluid, SCM value, SCM thunk),
 244             "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
 245             "@var{thunk} must be a procedure with no argument.")
 246 #define FUNC_NAME s_scm_with_fluid
 247 {
 248   return scm_c_with_fluid (fluid, value,
 249                            apply_thunk, (void *) SCM_UNPACK (thunk));
 250 }
 251 #undef FUNC_NAME
 252
 253 SCM
 254 scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
 255 #define FUNC_NAME "scm_c_with_fluid"
 256 {
 257   SCM ans;
 258
 259   scm_frame_begin (SCM_F_FRAME_REWINDABLE);
 260   scm_frame_fluid (fluid, value);
 261   ans = cproc (cdata);
 262   scm_frame_end ();
 263   return ans;
 264 }
 265 #undef FUNC_NAME
 266
 267 static void
 268 swap_fluid (SCM data)
 269 {
 270   SCM f = SCM_CAR (data);
 271   SCM t = scm_fluid_ref (f);
 272   scm_fluid_set_x (f, SCM_CDR (data));
 273   SCM_SETCDR (data, t);
 274 }
 275
 276 void
 277 scm_frame_fluid (SCM fluid, SCM value)
 278 {
 279   SCM data = scm_cons (fluid, value);
 280   scm_frame_rewind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
 281   scm_frame_unwind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
 282 }
 283
 284 void
 285 scm_init_fluids ()
 286 {
 287   scm_tc16_fluid = scm_make_smob_type ("fluid", 0);
 288   scm_set_smob_print (scm_tc16_fluid, fluid_print);
 289 #include "libguile/fluids.x"
 290 }
 291
 292 /*
 293   Local Variables:
 294   c-file-style: "gnu"
 295   End:
 296 */