add with-fluids objects and primitive syntax

* libguile/tags.h (scm_tc7_with_fluids): Allocate a tc7 for
  "with-fluids" objects, which will only live on the dynamic stack (wind
  list), not in normal scheme-land.

* libguile/fluids.h (SCM_WITH_FLUIDS_P, SCM_WITH_FLUIDS_LEN)
  (SCM_WITH_FLUIDS_NTH_FLUID, SCM_WITH_FLUIDS_NTH_VAL)
  (SCM_WITH_FLUIDS_SET_NTH_VAL): Add some accessors.
* libguile/fluids.c (scm_i_make_with_fluids, scm_i_swap_with_fluids):
  New internal functions.
  (scm_c_with_fluids, scm_c_with_fluid): Push with-fluids objects on the
  dynwind list, not winders.

* libguile/dynwind.c (scm_i_dowinds): Add cases for winding and
  unwinding with-fluids objects.

* libguile/memoize.h (scm_sym_with_fluids, SCM_M_BEGIN): New public
  data.
* libguile/memoize.c (scm_m_with_fluids): Define with-fluids as a
  primitive syntax.
  (unmemoize): Add with-fluids case.

* libguile/eval.c (eval):
* module/ice-9/eval.scm (primitive-eval): Add with-fluids cases.

* test-suite/tests/fluids.test
  ("fluids not modified if nonfluid passed to with-fluids"): Enable a
  now-passing test.

9 files changed, 201 insertions, 56 deletions

diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index 5eccb176f..18e38b995 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -257,6 +257,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
 	  if (WINDER_REWIND_P (wind_elt))
 	    WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 	}
+      else if (SCM_WITH_FLUIDS_P (wind_elt))
+	{
+          scm_i_swap_with_fluids (wind_elt,
+                                  SCM_I_CURRENT_THREAD->dynamic_state);
+	}
       else
 	{
 	  wind_key = SCM_CAR (wind_elt);
@@ -294,6 +299,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
 	  if (!WINDER_REWIND_P (wind_elt))
 	    WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 	}
+      else if (SCM_WITH_FLUIDS_P (wind_elt))
+	{
+          scm_i_swap_with_fluids (wind_elt,
+                                  SCM_I_CURRENT_THREAD->dynamic_state);
+	}
       else
 	{
 	  wind_key = SCM_CAR (wind_elt);
diff --git a/libguile/eval.c b/libguile/eval.c
index ea8a77153..48eb09e93 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -229,6 +229,28 @@ eval (SCM x, SCM env)
         return res;
       }
 
+    case SCM_M_WITH_FLUIDS:
+      {
+        long i, len;
+        SCM *fluidv, *valuesv, walk, wf, res;
+        len = scm_ilength (CAR (mx));
+        fluidv = alloca (sizeof (SCM)*len);
+        for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
+          fluidv[i] = eval (CAR (walk), env);
+        valuesv = alloca (sizeof (SCM)*len);
+        for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
+          valuesv[i] = eval (CAR (walk), env);
+        
+        wf = scm_i_make_with_fluids (len, fluidv, valuesv);
+        scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+        scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+        res = eval (CDDR (mx), env);
+        scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+        scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+        
+        return res;
+      }
+
     case SCM_M_APPLY:
       /* Evaluate the procedure to be applied.  */
       proc = eval (CAR (mx), env);
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 427d40640..c9ea68b8f 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -263,53 +263,90 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-static void
-swap_fluids (SCM data)
+static SCM
+apply_thunk (void *thunk)
 {
-  SCM fluids = SCM_CAR (data), vals = SCM_CDR (data);
-  
-  while (!SCM_NULL_OR_NIL_P (fluids))
+  return scm_call_0 (SCM_PACK (thunk));
+}
+
+SCM
+scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
+{
+  SCM ret;
+
+  /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
+     but N will usually be small, so perhaps that's OK. */
+  {
+    size_t i, j = n;
+
+    while (j--)
+      for (i = 0; i < j; i++)
+        if (fluids[i] == fluids[j])
+          {
+            vals[i] = vals[j]; /* later bindings win */
+            n--;
+            break;
+          }
+  }
+        
+  ret = scm_words (scm_tc7_with_fluids | (n << 8), 1 + n*2);
+  SCM_SET_CELL_WORD_1 (ret, n);
+
+  while (n--)
     {
-      SCM fl = SCM_CAR (fluids);
-      SCM old_val = scm_fluid_ref (fl);
-      scm_fluid_set_x (fl, SCM_CAR (vals));
-      SCM_SETCAR (vals, old_val);
-      fluids = SCM_CDR (fluids);
-      vals = SCM_CDR (vals);
+      if (SCM_UNLIKELY (!IS_FLUID (fluids[n])))
+        scm_wrong_type_arg ("with-fluids", 0, fluids[n]);
+      SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
+      SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
     }
+
+  return ret;
 }
+  
+void
+scm_i_swap_with_fluids (SCM wf, SCM dynstate)
+{
+  SCM fluids;
+  size_t i, max = 0;
 
-/* Swap the fluid values in reverse order.  This is important when the
-   same fluid appears multiple times in the fluids list.
-*/
+  fluids = DYNAMIC_STATE_FLUIDS (dynstate);
 
-static void
-swap_fluids_reverse_aux (SCM fluids, SCM vals)
-{
-  if (!SCM_NULL_OR_NIL_P (fluids))
+  /* We could cache the max in the with-fluids, but that would take more mem,
+     and we're touching all the fluids anyway, so this per-swap traversal should
+     be OK. */
+  for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
     {
-      SCM fl, old_val;
-
-      swap_fluids_reverse_aux (SCM_CDR (fluids), SCM_CDR (vals));
-      fl = SCM_CAR (fluids);
-      old_val = scm_fluid_ref (fl);
-      scm_fluid_set_x (fl, SCM_CAR (vals));
-      SCM_SETCAR (vals, old_val);
+      size_t num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
+      max = (max > num) ? max : num;
     }
-}
 
-static void
-swap_fluids_reverse (SCM data)
-{
-  swap_fluids_reverse_aux (SCM_CAR (data), SCM_CDR (data));
-}
+  if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+    {
+      /* We should only get there when the current thread's dynamic state turns
+         out to be too small compared to the set of currently allocated
+         fluids. */
+      assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
 
-static SCM
-apply_thunk (void *thunk)
-{
-  return scm_call_0 (SCM_PACK (thunk));
-}
+      /* Lazily grow the current thread's dynamic state.  */
+      grow_dynamic_state (dynstate);
 
+      fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+    }
+
+  /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
+  for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
+    {
+      size_t fluid_num;
+      SCM x;
+      
+      fluid_num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
+      x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num);
+      SCM_SIMPLE_VECTOR_SET (fluids, fluid_num,
+                             SCM_WITH_FLUIDS_NTH_VAL (wf, i));
+      SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x);
+    }
+}
+  
 SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, 
 	    (SCM fluids, SCM values, SCM thunk),
 	    "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
@@ -327,26 +364,36 @@ SCM
 scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
 #define FUNC_NAME "scm_c_with_fluids"
 {
-  SCM ans, data;
-  long flen, vlen;
+  SCM wf, ans;
+  long flen, vlen, i;
+  SCM *fluidsv, *valuesv;
 
   SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
   SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
   if (flen != vlen)
     scm_out_of_range (s_scm_with_fluids, values);
 
-  if (flen == 1)
-    return scm_c_with_fluid (SCM_CAR (fluids), SCM_CAR (values),
-			     cproc, cdata);
+  if (SCM_UNLIKELY (flen == 0))
+    return cproc (cdata);
+
+  fluidsv = alloca (sizeof(SCM)*flen);
+  valuesv = alloca (sizeof(SCM)*flen);
   
-  data = scm_cons (fluids, values);
-  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
-  scm_dynwind_rewind_handler_with_scm (swap_fluids, data,
-				     SCM_F_WIND_EXPLICITLY);
-  scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse, data,
-				     SCM_F_WIND_EXPLICITLY);
+  for (i = 0; i < flen; i++)
+    {
+      fluidsv[i] = SCM_CAR (fluids);
+      fluids = SCM_CDR (fluids);
+      valuesv[i] = SCM_CAR (values);
+      values = SCM_CDR (values);
+    }
+
+  wf = scm_i_make_with_fluids (flen, fluidsv, valuesv);
+  scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+  scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
   ans = cproc (cdata);
-  scm_dynwind_end ();
+  scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+  scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+
   return ans;
 }
 #undef FUNC_NAME
@@ -366,12 +413,15 @@ SCM
 scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
 #define FUNC_NAME "scm_c_with_fluid"
 {
-  SCM ans;
+  SCM ans, wf;
 
-  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
-  scm_dynwind_fluid (fluid, value);
+  wf = scm_i_make_with_fluids (1, &fluid, &value);
+  scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+  scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
   ans = cproc (cdata);
-  scm_dynwind_end ();
+  scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+  scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+
   return ans;
 }
 #undef FUNC_NAME
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 3a651fbf8..7aefd478f 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -3,7 +3,7 @@
 #ifndef SCM_FLUIDS_H
 #define SCM_FLUIDS_H
 
-/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -27,6 +27,18 @@
 #include "libguile/root.h"
 #include "libguile/vectors.h"
 
+/* These "with-fluids" objects live on the dynamic stack, and record previous
+   values of fluids. Guile uses shallow binding, so the current fluid values are
+   always in the same place for a given thread, in the dynamic-state vector.
+ */
+
+#define SCM_WITH_FLUIDS_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_with_fluids)
+#define SCM_WITH_FLUIDS_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8)
+#define SCM_WITH_FLUIDS_NTH_FLUID(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2))
+#define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2))
+#define SCM_WITH_FLUIDS_SET_NTH_VAL(x,n,v) (SCM_SET_CELL_OBJECT ((x), 2 + (n)*2, (v)))
+
+
 /* Fluids.
 
    Fluids are objects of a certain type that can hold one SCM value per
@@ -56,6 +68,9 @@ SCM_API SCM scm_fluid_p (SCM fl);
 SCM_API SCM scm_fluid_ref (SCM fluid);
 SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
 
+SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals);
+SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state);
+
 SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
 			       SCM (*cproc)(void *), void *cdata);
 SCM_API SCM scm_c_with_fluid (SCM fluid, SCM val,
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 8fd1595ff..4c1a1017b 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -201,6 +201,8 @@ scm_t_bits scm_tc16_memoized;
   MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
 #define MAKMEMO_DYNWIND(in, expr, out) \
   MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
+#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
+  MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
 #define MAKMEMO_APPLY(exp) \
   MAKMEMO (SCM_M_APPLY, exp)
 #define MAKMEMO_CONT(proc) \
@@ -234,6 +236,7 @@ static const char *const memoized_tags[] =
   "quote",
   "define",
   "dynwind",
+  "with-fluids",
   "apply",
   "call/cc",
   "call-with-values",
@@ -265,6 +268,7 @@ static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
 static SCM scm_m_cond (SCM xorig, SCM env);
 static SCM scm_m_define (SCM x, SCM env);
 static SCM scm_m_at_dynamic_wind (SCM xorig, SCM env);
+static SCM scm_m_with_fluids (SCM xorig, SCM env);
 static SCM scm_m_eval_when (SCM xorig, SCM env);
 static SCM scm_m_if (SCM xorig, SCM env);
 static SCM scm_m_lambda (SCM xorig, SCM env);
@@ -401,6 +405,7 @@ SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_m_at_call_with_value
 SCM_SYNTAX (s_cond, "cond", scm_m_cond);
 SCM_SYNTAX (s_define, "define", scm_m_define);
 SCM_SYNTAX (s_at_dynamic_wind, "@dynamic-wind", scm_m_at_dynamic_wind);
+SCM_SYNTAX (s_with_fluids, "with-fluids", scm_m_with_fluids);
 SCM_SYNTAX (s_eval_when, "eval-when", scm_m_eval_when);
 SCM_SYNTAX (s_if, "if", scm_m_if);
 SCM_SYNTAX (s_lambda, "lambda", scm_m_lambda);
@@ -425,6 +430,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
 SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
 SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
 SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
+SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
 SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
 SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
 SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
@@ -636,6 +642,29 @@ scm_m_at_dynamic_wind (SCM expr, SCM env)
 }
 
 static SCM
+scm_m_with_fluids (SCM expr, SCM env)
+{
+  SCM binds, fluids, vals;
+  ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+  binds = CADR (expr);
+  ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
+  for (fluids = SCM_EOL, vals = SCM_EOL;
+       scm_is_pair (binds);
+       binds = CDR (binds))
+    {
+      SCM binding = CAR (binds);
+      ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
+                       binding, expr);
+      fluids = scm_cons (memoize (CAR (binding), env), fluids);
+      vals = scm_cons (memoize (CADR (binding), env), vals);
+    }
+
+  return MAKMEMO_WITH_FLUIDS (scm_reverse_x (fluids, SCM_UNDEFINED),
+                              scm_reverse_x (vals, SCM_UNDEFINED),
+                              memoize_sequence (CDDR (expr), env));
+}
+
+static SCM
 scm_m_eval_when (SCM expr, SCM env)
 {
   ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
@@ -1083,6 +1112,18 @@ unmemoize (const SCM expr)
                          unmemoize (CAR (args)),
                          unmemoize (CADR (args)),
                          unmemoize (CDDR (args)));
+    case SCM_M_WITH_FLUIDS:
+      {
+        SCM binds = SCM_EOL, fluids, vals;
+        for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
+             fluids = CDR (fluids), vals = CDR (vals))
+          binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
+                                        unmemoize (CAR (vals))),
+                            binds);
+        return scm_list_3 (scm_sym_with_fluids,
+                           scm_reverse_x (binds, SCM_UNDEFINED),
+                           unmemoize (CDDR (args)));
+      }
     case SCM_M_IF:
       return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
                          unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 25b88aaa2..818cdbd83 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -44,6 +44,7 @@ SCM_API SCM scm_sym_quote;
 SCM_API SCM scm_sym_quasiquote;
 SCM_API SCM scm_sym_unquote;
 SCM_API SCM scm_sym_uq_splicing;
+SCM_API SCM scm_sym_with_fluids;
 
 SCM_API SCM scm_sym_at;
 SCM_API SCM scm_sym_atat;
@@ -77,6 +78,7 @@ enum
     SCM_M_QUOTE,
     SCM_M_DEFINE,
     SCM_M_DYNWIND,
+    SCM_M_WITH_FLUIDS,
     SCM_M_APPLY,
     SCM_M_CONT,
     SCM_M_CALL_WITH_VALUES,
diff --git a/libguile/tags.h b/libguile/tags.h
index e98f96535..2e6dea22e 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -422,7 +422,7 @@ typedef scm_t_uintptr scm_t_bits;
 #define scm_tc7_vm_cont		71
 
 #define scm_tc7_prompt		61
-#define scm_tc7_unused_21	63
+#define scm_tc7_with_fluids	63
 #define scm_tc7_unused_19	69
 #define scm_tc7_program		79
 #define scm_tc7_unused_9	85
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 454fc4f69..0e02cbc75 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -304,6 +304,11 @@
                        (lambda () (eval exp env))
                        (eval out env)))
         
+        (('with-fluids (fluids vals . exp))
+         (let* ((fluids (map (lambda (x) (eval x env)) fluids))
+                (vals (map (lambda (x) (eval x env)) vals)))
+           (with-fluids* fluids vals (lambda () (eval exp env)))))
+        
         (('call/cc proc)
          (call/cc (eval proc env)))
 
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index 6eb5095f3..f00fdc480 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -35,7 +35,7 @@
     (with-fluids ((c #t))
       c))
   
-  (expect-fail "fluids not modified if nonfluid passed to with-fluids"
+  (pass-if "fluids not modified if nonfluid passed to with-fluids"
     (catch 'wrong-type-arg
       (lambda ()
         (with-fluids ((a #t)