Remove with-fluids; replaced by with-fluid* and inlined push-fluid primops

* libguile/vm-i-system.c (push-fluid, pop-fluid):
* doc/ref/vm.texi (Dynamic Environment Instructions): Rename wind-fluids
  to push-fluid, and unwind-fluids to pop-fluid.  They now only work on
  one fluid binding at a time.

* module/ice-9/boot-9.scm (with-fluid*): Implement in Scheme in terms of
  primcalls to push-fluid and pop-fluid.
  (custom-throw-handler, catch, with-throw-handler): Use with-fluid*
  instead of with-fluids, as with-fluids is no longer available before
  psyntax is loaded.
  (with-fluids): Define in Scheme in terms of with-fluid*.

* libguile/fluids.c (scm_with_fluid): Rename from scm_with_fluids, and
  don't expose to Scheme.

* libguile/eval.c (eval): Remove SCM_M_WITH_FLUIDS case.
* libguile/expand.c (expand_with_fluids): Remove with-fluids syntax.
  (DYNLET): Remove, no longer defining dynlet in the %expanded-vtables.
* libguile/expand.h: Remove dynlet definitions.
* module/ice-9/eval.scm (primitive-eval): Remove with-fluids case.
* libguile/memoize.c (do_push_fluid, do_pop_fluid): New primitive
  helpers, like wind and unwind.
  (memoize): Memoize wind and unwind primcalls.  Don't memoize dynlet to
  with-fluids.
  (scm_init_memoize): Initialize push_fluid and pop_fluid here.
* libguile/memoize.h (SCM_M_WITH_FLUIDS): Remove definition.

* module/ice-9/psyntax.scm (build-dynlet): Remove; this just supported
  with-fluids, which is now defined in boot-9.
* module/ice-9/psyntax-pp.scm: Regenerate.

* doc/ref/compiler.texi (Tree-IL):
* module/language/tree-il.scm:
* module/language/tree-il/analyze.scm:
* module/language/tree-il/canonicalize.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/cse.scm:
* module/language/tree-il/debug.scm:
* module/language/tree-il/effects.scm: Remove <dynlet>.  Add cases for
  primcalls to push-fluid and pop-fluid in compile-glil.scm and
  effects.scm.

* module/language/tree-il/peval.scm (peval): Factor out
  with-temporaries; probably a bad idea, but works for now.  Factor out
  make-begin0 (a better idea).  Inline primcalls to with-fluid*, and
  remove dynlet cases.

* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  Add with-fluid*.

doc/ref/compiler.texi

@@ -458,14 +458,6 @@ original binding names, @var{gensyms} are gensyms corresponding to the
 A version of @code{<let>} that creates recursive bindings, like
 Scheme's @code{letrec}, or @code{letrec*} if @var{in-order?} is true.
 @end deftp
-@deftp {Scheme Variable} <dynlet> fluids vals body
-@deftpx {External Representation} (dynlet @var{fluids} @var{vals} @var{body})
-Dynamic binding; the equivalent of Scheme's @code{with-fluids}.
-@var{fluids} should be a list of Tree-IL expressions that will
-evaluate to fluids, and @var{vals} a corresponding list of expressions
-to bind to the fluids during the dynamic extent of the evaluation of
-@var{body}.
-@end deftp
 @deftp {Scheme Variable} <prompt> tag body handler
 @deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler})
 A dynamic prompt. Instates a prompt named @var{tag}, an expression,

doc/ref/vm.texi

@@ -1120,18 +1120,17 @@ wind/unwind thunk pair. @code{unwind} instructions should be properly
 paired with their winding instructions, like @code{wind}.
 @end deffn
 
-@deffn Instruction wind-fluids n
+@deffn Instruction push-fluid
-Pop off @var{n} values and @var{n} fluids from the stack, in that order.
+Pop a value and a fluid from the stack, in that order.  Set the fluid
-Set the fluids to the values by creating a with-fluids object and
+to the value by creating a with-fluids object and pushing that object
-pushing that object on the dynamic stack. @xref{Fluids and Dynamic
+on the dynamic stack. @xref{Fluids and Dynamic States}.
-States}.
 @end deffn
 
-@deffn Instruction unwind-fluids
+@deffn Instruction pop-fluid
 Pop a with-fluids object from the dynamic stack, and swap the current
 values of its fluids with the saved values of its fluids. In this way,
 the dynamic environment is left as it was before the corresponding
-@code{wind-fluids} instruction was processed.
+@code{wind-fluid} instruction was processed.
 @end deffn
 
 @deffn Instruction fluid-ref

libguile/eval.c

@@ -40,7 +40,6 @@
 #include "libguile/eq.h"
 #include "libguile/expand.h"
 #include "libguile/feature.h"
-#include "libguile/fluids.h"
 #include "libguile/goops.h"
 #include "libguile/hash.h"
 #include "libguile/hashtab.h"
@@ -265,28 +264,6 @@ eval (SCM x, SCM env)
       scm_define (CAR (mx), EVAL1 (CDR (mx), env));
       return SCM_UNSPECIFIED;
 
-    case SCM_M_WITH_FLUIDS:
-      {
-        long i, len;
-        SCM *fluidv, *valuesv, walk, res;
-        scm_i_thread *thread = SCM_I_CURRENT_THREAD;
-
-        len = scm_ilength (CAR (mx));
-        fluidv = alloca (sizeof (SCM)*len);
-        for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
-          fluidv[i] = EVAL1 (CAR (walk), env);
-        valuesv = alloca (sizeof (SCM)*len);
-        for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
-          valuesv[i] = EVAL1 (CAR (walk), env);
-        
-        scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,
-                                  thread->dynamic_state);
-        res = eval (CDDR (mx), env);
-        scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
-        
-        return res;
-      }
-
     case SCM_M_APPLY:
       /* Evaluate the procedure to be applied.  */
       proc = EVAL1 (CAR (mx), env);

libguile/expand.c

@@ -88,8 +88,6 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
   SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
 #define LETREC(src, in_order_p, names, gensyms, vals, body) \
   SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
-#define DYNLET(src, fluids, vals, body) \
-  SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
 
 #define CAR(x)   SCM_CAR(x)
 #define CDR(x)   SCM_CDR(x)
@@ -155,7 +153,6 @@ SCM_SYNTAX ("@", expand_at);
 SCM_SYNTAX ("@@", expand_atat);
 SCM_SYNTAX ("begin", expand_begin);
 SCM_SYNTAX ("define", expand_define);
-SCM_SYNTAX ("with-fluids", expand_with_fluids);
 SCM_SYNTAX ("eval-when", expand_eval_when);
 SCM_SYNTAX ("if", expand_if);
 SCM_SYNTAX ("lambda", expand_lambda);
@@ -184,7 +181,6 @@ SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
 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_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");
@@ -564,30 +560,6 @@ expand_define (SCM expr, SCM env)
                           expand (CAR (body), env));
 }
 
-static SCM
-expand_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 (expand (CAR (binding), env), fluids);
-      vals = scm_cons (expand (CADR (binding), env), vals);
-    }
-
-  return DYNLET (scm_source_properties (expr),
-                 scm_reverse_x (fluids, SCM_UNDEFINED),
-                 scm_reverse_x (vals, SCM_UNDEFINED),
-                 expand_sequence (CDDR (expr), env));
-}
-
 static SCM
 expand_eval_when (SCM expr, SCM env)
 {
@@ -1262,7 +1234,6 @@ scm_init_expand ()
   DEFINE_NAMES (LAMBDA_CASE);
   DEFINE_NAMES (LET);
   DEFINE_NAMES (LETREC);
-  DEFINE_NAMES (DYNLET);
 
   scm_exp_vtable_vtable =
     scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),

libguile/expand.h

@@ -3,7 +3,7 @@
 #ifndef SCM_EXPAND_H
 #define SCM_EXPAND_H
 
-/* Copyright (C) 2010, 2011
+/* Copyright (C) 2010, 2011, 2013
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -54,7 +54,6 @@ typedef enum
     SCM_EXPANDED_LAMBDA_CASE,
     SCM_EXPANDED_LET,
     SCM_EXPANDED_LETREC,
-    SCM_EXPANDED_DYNLET,
     SCM_NUM_EXPANDED_TYPES,
   } scm_t_expanded_type;
 
@@ -331,20 +330,6 @@ enum
 #define SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) \
   scm_c_make_struct (exp_vtables[SCM_EXPANDED_LETREC], 0, SCM_NUM_EXPANDED_LETREC_FIELDS, SCM_UNPACK (src), SCM_UNPACK (in_order_p), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))
 
-#define SCM_EXPANDED_DYNLET_TYPE_NAME "dynlet"
-#define SCM_EXPANDED_DYNLET_FIELD_NAMES         \
-  { "src", "fluids", "vals", "body", }
-enum
-  {
-    SCM_EXPANDED_DYNLET_SRC,
-    SCM_EXPANDED_DYNLET_FLUIDS,
-    SCM_EXPANDED_DYNLET_VALS,
-    SCM_EXPANDED_DYNLET_BODY,
-    SCM_NUM_EXPANDED_DYNLET_FIELDS,
-  };
-#define SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body) \
-  scm_c_make_struct (exp_vtables[SCM_EXPANDED_DYNLET], 0, SCM_NUM_EXPANDED_DYNLET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (fluids), SCM_UNPACK (vals), SCM_UNPACK (body))
-
 #endif /* BUILDING_LIBGUILE */
 
 

libguile/fluids.c

@@ -418,16 +418,12 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0, 
+SCM
-	    (SCM fluid, SCM value, SCM thunk),
+scm_with_fluid (SCM fluid, SCM value, SCM thunk)
-	    "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
-	    "@var{thunk} must be a procedure with no argument.")
-#define FUNC_NAME s_scm_with_fluid
 {
   return scm_c_with_fluid (fluid, value,
 			   apply_thunk, (void *) SCM_UNPACK (thunk));
 }
-#undef FUNC_NAME
 
 SCM
 scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)

libguile/memoize.c

@@ -63,6 +63,8 @@ SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
 /* Primitives not exposed to general Scheme. */
 static SCM wind;
 static SCM unwind;
+static SCM push_fluid;
+static SCM pop_fluid;
 
 static SCM
 do_wind (SCM in, SCM out)
@@ -78,6 +80,23 @@ do_unwind (void)
   return SCM_UNSPECIFIED;
 }
 
+static SCM
+do_push_fluid (SCM fluid, SCM val)
+{
+  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+  scm_dynstack_push_fluids (&thread->dynstack, 1, &fluid, &val,
+                            thread->dynamic_state);
+  return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_pop_fluid (void)
+{
+  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+  scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
+  return SCM_UNSPECIFIED;
+}
+
 
 
 
@@ -109,8 +128,6 @@ scm_t_bits scm_tc16_memoized;
   MAKMEMO (SCM_M_QUOTE, exp)
 #define MAKMEMO_DEFINE(var, val) \
   MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
-#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
-  MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
 #define MAKMEMO_APPLY(proc, args)\
   MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
 #define MAKMEMO_CONT(proc) \
@@ -146,7 +163,6 @@ static const char *const memoized_tags[] =
   "let",
   "quote",
   "define",
-  "with-fluids",
   "apply",
   "call/cc",
   "call-with-values",
@@ -298,6 +314,12 @@ memoize (SCM exp, SCM env)
         else if (nargs == 0
                  && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
           return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
+        else if (nargs == 2
+                 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
+          return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
+        else if (nargs == 0
+                 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
+          return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
         else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
           return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
         else
@@ -511,11 +533,6 @@ memoize (SCM exp, SCM env)
           }
       }
 
-    case SCM_EXPANDED_DYNLET:
-      return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
-                                  memoize_exps (REF (exp, DYNLET, VALS), env),
-                                  memoize (REF (exp, DYNLET, BODY), env));
-
     default:
       abort ();
     }
@@ -611,18 +628,6 @@ unmemoize (const SCM expr)
                          unmemoize (CAR (args)), unmemoize (CDR (args)));
     case SCM_M_DEFINE:
       return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (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)));
@@ -859,6 +864,8 @@ scm_init_memoize ()
 
   wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
   unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
+  push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
+  pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
 
   list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
 }

libguile/memoize.h

@@ -44,7 +44,6 @@ 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;
@@ -73,7 +72,6 @@ enum
     SCM_M_LET,
     SCM_M_QUOTE,
     SCM_M_DEFINE,
-    SCM_M_WITH_FLUIDS,
     SCM_M_APPLY,
     SCM_M_CONT,
     SCM_M_CALL_WITH_VALUES,

libguile/vm-i-system.c

@@ -1490,20 +1490,17 @@ VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (91, wind_fluids, "wind-fluids", 1, -1, 0)
+VM_DEFINE_INSTRUCTION (91, push_fluid, "push-fluid", 0, 2, 0)
 {
-  unsigned n = FETCH ();
+  SCM fluid, val;
-  
+  POP2 (val, fluid);
   SYNC_REGISTER ();
-  sp -= 2 * n;
+  scm_dynstack_push_fluids (&current_thread->dynstack, 1, &fluid, &val,
-  CHECK_UNDERFLOW ();
-  scm_dynstack_push_fluids (&current_thread->dynstack, n, sp + 1, sp + 1 + n,
                             current_thread->dynamic_state);
-  NULLSTACK (2 * n);
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (92, unwind_fluids, "unwind-fluids", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (92, pop_fluid, "pop-fluid", 0, 0, 0)
 {
   /* This function must not allocate.  */
   scm_dynstack_unwind_fluids (&current_thread->dynstack,

module/ice-9/boot-9.scm

@@ -66,6 +66,14 @@
 (define (abort-to-prompt tag . args)
   (abort-to-prompt* tag args))
 
+(define (with-fluid* fluid val thunk)
+  "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
+@var{thunk} must be a procedure of no arguments."
+  ((@@ primitive push-fluid) fluid val)
+  (call-with-values thunk
+    (lambda vals
+      ((@@ primitive pop-fluid))
+      (apply values vals))))
 
 ;; Define catch and with-throw-handler, using some common helper routines and a
 ;; shared fluid. Hide the helpers in a lexical contour.
@@ -99,13 +107,14 @@
       (lambda (thrown-k . args)
         (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
             (let ((running (fluid-ref %running-exception-handlers)))
-              (with-fluids ((%running-exception-handlers (cons pre running)))
+              (with-fluid* %running-exception-handlers (cons pre running)
-                (if (not (memq pre running))
+                (lambda ()
-                    (apply pre thrown-k args))
+                  (if (not (memq pre running))
-                ;; fall through
+                      (apply pre thrown-k args))
-                (if prompt-tag
+                  ;; fall through
-                    (apply abort-to-prompt prompt-tag thrown-k args)
+                  (if prompt-tag
-                    (apply prev thrown-k args))))
+                      (apply abort-to-prompt prompt-tag thrown-k args)
+                      (apply prev thrown-k args)))))
             (apply prev thrown-k args)))))
 
   (set! catch
@@ -151,12 +160,11 @@ non-locally, that exit determines the continuation."
             (call-with-prompt
              tag
              (lambda ()
-               (with-fluids
+               (with-fluid* %exception-handler
-                   ((%exception-handler
+                   (if pre-unwind-handler
-                     (if pre-unwind-handler
+                       (custom-throw-handler tag k pre-unwind-handler)
-                         (custom-throw-handler tag k pre-unwind-handler)
+                       (default-throw-handler tag k))
-                         (default-throw-handler tag k))))
+                 thunk))
-                 (thunk)))
              (lambda (cont k . args)
                (apply handler k args))))))
 
@@ -168,9 +176,9 @@ for key @var{k}, then invoke @var{thunk}."
               (scm-error 'wrong-type-arg "with-throw-handler"
                          "Wrong type argument in position ~a: ~a"
                          (list 1 k) (list k)))
-          (with-fluids ((%exception-handler
+          (with-fluid* %exception-handler
-                         (custom-throw-handler #f k pre-unwind-handler)))
+              (custom-throw-handler #f k pre-unwind-handler)
-            (thunk))))
+            thunk)))
 
   (set! throw
         (lambda (key . args)
@@ -702,6 +710,25 @@ file with the given name already exists, the effect is unspecified."
 (define-syntax-rule (delay exp)
   (make-promise (lambda () exp)))
 
+(define-syntax with-fluids
+  (lambda (stx)
+    (define (emit-with-fluids bindings body)
+      (syntax-case bindings ()
+        (()
+         body)
+        (((f v) . bindings)
+         #`(with-fluid* f v
+             (lambda ()
+               #,(emit-with-fluids #'bindings body))))))
+    (syntax-case stx ()
+      ((_ ((fluid val) ...) exp exp* ...)
+       (with-syntax (((fluid-tmp ...) (generate-temporaries #'(fluid ...)))
+                     ((val-tmp ...) (generate-temporaries #'(val ...))))
+         #`(let ((fluid-tmp fluid) ...)
+             (let ((val-tmp val) ...)
+               #,(emit-with-fluids #'((fluid-tmp val-tmp) ...)
+                                   #'(begin exp exp* ...)))))))))
+
 (define-syntax current-source-location
   (lambda (x)
     (syntax-case x ()

module/ice-9/eval.scm

@@ -203,7 +203,6 @@
 ;;;       module-ref: 14468
 ;;;           define: 1259
 ;;;     toplevel-set: 328
-;;;      with-fluids: 0
 ;;;          call/cc: 0
 ;;;       module-set: 0
 ;;;
@@ -462,15 +461,6 @@
                                                          env))))
           (eval x env)))
       
-        (('with-fluids (fluids vals . exp))
-         (let* ((fluids (map (lambda (x) (eval x env)) fluids))
-                (vals (map (lambda (x) (eval x env)) vals)))
-           (let lp ((fluids fluids) (vals vals))
-             (if (null? fluids)
-                 (eval exp env)
-                 (with-fluids (((car fluids) (car vals)))
-                   (lp (cdr fluids) (cdr vals)))))))
-        
         (('call-with-prompt (tag thunk . handler))
          (call-with-prompt
           (eval tag env)

module/ice-9/psyntax-pp.scm

@@ -94,15 +94,6 @@
          gensyms
          vals
          body)))
-   (make-dynlet
-     (lambda (src fluids vals body)
-       (make-struct
-         (vector-ref %expanded-vtables 18)
-         0
-         src
-         fluids
-         vals
-         body)))
    (lambda?
      (lambda (x)
        (and (struct? x)
@@ -152,9 +143,6 @@
    (build-conditional
      (lambda (source test-exp then-exp else-exp)
        (make-conditional source test-exp then-exp else-exp)))
-   (build-dynlet
-     (lambda (source fluids vals body)
-       (make-dynlet source fluids vals body)))
    (build-lexical-reference
      (lambda (type source name var) (make-lexical-ref source name var)))
    (build-lexical-assignment
@@ -983,11 +971,14 @@
                        (source-wrap e w (cdr w) mod)
                        x))
                     (else (decorate-source x s))))))
-         (with-fluids
+         (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod))))
-           ((transformer-environment (lambda (k) (k e r w s rib mod))))
+           (with-fluid*
-           (rebuild-macro-output
+             t-1
-             (p (source-wrap e (anti-mark w) s mod))
+             t
-             (gensym (string-append "m-" (session-id) "-")))))))
+             (lambda ()
+               (rebuild-macro-output
+                 (p (source-wrap e (anti-mark w) s mod))
+                 (gensym (string-append "m-" (session-id) "-")))))))))
    (expand-body
      (lambda (body outer-form r w mod)
        (let* ((r (cons '("placeholder" placeholder) r))
@@ -2102,24 +2093,6 @@
                 #f
                 "source expression failed to match any pattern"
                 tmp)))))))
-  (global-extend
-    'core
-    'with-fluids
-    (lambda (e r w s mod)
-      (let* ((tmp-1 e)
-             (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
-        (if tmp
-          (apply (lambda (fluid val b b*)
-                   (build-dynlet
-                     s
-                     (map (lambda (x) (expand x r w mod)) fluid)
-                     (map (lambda (x) (expand x r w mod)) val)
-                     (expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
-                 tmp)
-          (syntax-violation
-            #f
-            "source expression failed to match any pattern"
-            tmp-1)))))
   (global-extend 'begin 'begin '())
   (global-extend 'define 'define '())
   (global-extend 'define-syntax 'define-syntax '())

module/ice-9/psyntax.scm

@@ -325,10 +325,6 @@
       (lambda (source test-exp then-exp else-exp)
         (make-conditional source test-exp then-exp else-exp)))
   
-    (define build-dynlet
-      (lambda (source fluids vals body)
-        (make-dynlet source fluids vals body)))
-  
     (define build-lexical-reference
       (lambda (type source name var)
         (make-lexical-ref source name var)))
@@ -2422,17 +2418,6 @@
                          (expand #'then r w mod)
                          (expand #'else r w mod))))))
 
-    (global-extend 'core 'with-fluids
-                   (lambda (e r w s mod)
-                     (syntax-case e ()
-                       ((_ ((fluid val) ...) b b* ...)
-                        (build-dynlet
-                         s
-                         (map (lambda (x) (expand x r w mod)) #'(fluid ...))
-                         (map (lambda (x) (expand x r w mod)) #'(val ...))
-                         (expand-body #'(b b* ...)
-                                      (source-wrap e w s mod) r w mod))))))
-  
     (global-extend 'begin 'begin '())
 
     (global-extend 'define 'define '())

module/language/elisp/compile-tree-il.scm

@@ -1,6 +1,6 @@
 ;;; Guile Emacs Lisp
 
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
 
 ;; This program is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -297,6 +297,25 @@
                meta
                (make-lambda-case #f req opt rest #f init vars body #f)))
 
+(define (make-dynlet src fluids vals body)
+  (let ((f (map (lambda (x) (gensym "fluid ")) fluids))
+        (v (map (lambda (x) (gensym "valud ")) vals)))
+    (make-let src (map (lambda (_) 'fluid) fluids) f fluids
+              (make-let src (map (lambda (_) 'val) vals) v vals
+                        (let lp ((f f) (v v))
+                          (if (null? f)
+                              body
+                              (make-primcall
+                               src 'with-fluid*
+                               (list (make-lexical-ref #f 'fluid (car f))
+                                     (make-lexical-ref #f 'val (car v))
+                                     (make-lambda
+                                      src '()
+                                      (make-lambda-case
+                                       src '() #f #f #f '() '()
+                                       (lp (cdr f) (cdr v))
+                                       #f))))))))))
+
 (define (compile-lambda loc meta args body)
   (receive (valid? req-ids opt-ids rest-id)
            (parse-lambda-list args)

module/language/scheme/decompile-tree-il.scm

@@ -432,12 +432,6 @@
          `(call-with-values (lambda () ,@(recurse-body exp))
             ,(recurse (make-lambda #f '() body))))
 
-        ((<dynlet> fluids vals body)
-         `(with-fluids ,(map list
-                             (map recurse fluids)
-                             (map recurse vals))
-            ,@(recurse-body body)))
-
         ((<prompt> tag body handler)
          `(call-with-prompt
            ,(recurse tag)
@@ -750,12 +744,6 @@
              (primitive 'call-with-values)
              (recurse exp) (recurse body))
 
-            ((<dynlet> fluids vals body)
-             (primitive 'with-fluids)
-             (for-each recurse fluids)
-             (for-each recurse vals)
-             (recurse body))
-
             ((<prompt> tag body handler)
              (primitive 'call-with-prompt)
              (primitive 'lambda)

module/language/tree-il.scm

@@ -46,7 +46,6 @@
             <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
             <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
             <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
-            <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
             <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
             <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
 
@@ -128,7 +127,6 @@
   ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
   ;; (<let> names gensyms vals body)
   ;; (<letrec> in-order? names gensyms vals body)
-  ;; (<dynlet> fluids vals body)
 
 (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
   (<fix> names gensyms vals body)
@@ -243,9 +241,6 @@
      (('let-values exp body)
       (make-let-values loc (retrans exp) (retrans body)))
 
-     (('dynlet fluids vals body)
-      (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
-
      (('prompt tag body handler)
       (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
      
@@ -324,10 +319,6 @@
     (($ <let-values> src exp body)
      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 
-    (($ <dynlet> src fluids vals body)
-     `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
-              ,(unparse-tree-il body)))
-
     (($ <prompt> src tag body handler)
      `(prompt ,(unparse-tree-il tag)
               ,(unparse-tree-il body)
@@ -398,10 +389,6 @@
               (($ <let-values> src exp body)
                (let*-values (((seed ...) (foldts exp seed ...)))
                  (foldts body seed ...)))
-              (($ <dynlet> src fluids vals body)
-               (let*-values (((seed ...) (fold-values foldts fluids seed ...))
-                             ((seed ...) (fold-values foldts vals seed ...)))
-                 (foldts body seed ...)))
               (($ <prompt> src tag body handler)
                (let*-values (((seed ...) (foldts tag seed ...))
                              ((seed ...) (foldts body seed ...)))
@@ -492,9 +479,6 @@ This is an implementation of `foldts' as described by Andy Wingo in
        (($ <let-values> src exp body)
         (make-let-values src (lp exp) (lp body)))
 
-       (($ <dynlet> src fluids vals body)
-        (make-dynlet src (map lp fluids) (map lp vals) (lp body)))
-
        (($ <prompt> src tag body handler)
         (make-prompt src (lp tag) (lp body) (lp handler)))
 

module/language/tree-il/analyze.scm

@@ -337,9 +337,6 @@
       ((<let-values> exp body)
        (lset-union eq? (step exp) (step body)))
       
-      ((<dynlet> fluids vals body)
-       (apply lset-union eq? (step body) (map step (append fluids vals))))
-      
       ((<prompt> tag body handler)
        (lset-union eq? (step tag) (step body) (step-tail handler)))
       
@@ -502,9 +499,6 @@
       ((<let-values> exp body)
        (max (recur exp) (recur body)))
       
-      ((<dynlet> fluids vals body)
-       (apply max (recur body) (map recur (append fluids vals))))
-      
       ((<prompt> tag body handler)
        (let ((cont-var (and (lambda-case? handler)
                             (pair? (lambda-case-gensyms handler))

module/language/tree-il/canonicalize.scm

@@ -40,8 +40,6 @@
         body)
        (($ <fix> src () () () body)
         body)
-       (($ <dynlet> src () () body)
-        body)
        (($ <lambda> src meta #f)
         ;; Give a body to case-lambda with no clauses.
         (make-lambda

module/language/tree-il/compile-glil.scm

@@ -139,6 +139,8 @@
 
    ((wind . 2) . wind)
    ((unwind . 0) . unwind)
+   ((push-fluid . 2) . push-fluid)
+   ((pop-fluid . 0) . pop-fluid)
 
    ((bytevector-u8-ref . 2) . bv-u8-ref)
    ((bytevector-u8-set! . 3) . bv-u8-set)
@@ -945,52 +947,6 @@
             (clear-stack-slots context gensyms)
             (emit-code #f (make-glil-unbind))))))
 
-      ((<dynlet> src fluids vals body)
-       (for-each comp-push fluids)
-       (for-each comp-push vals)
-       (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
-
-       (case context
-         ((tail)
-          (let ((MV (make-label)))
-            ;; NB: in tail case, it is possible to preserve asymptotic tail
-            ;; recursion, via merging unwind-fluids structures -- but we'd need
-            ;; to compile in the body twice (once in tail context, assuming the
-            ;; caller unwinds, and once with this trampoline thing, unwinding
-            ;; ourselves).
-            (comp-vals body MV)
-            ;; one value: unwind and return
-            (emit-code #f (make-glil-call 'unwind-fluids 0))
-            (emit-code #f (make-glil-call 'return 1))
-            
-            (emit-label MV)
-            ;; multiple values: unwind and return values
-            (emit-code #f (make-glil-call 'unwind-fluids 0))
-            (emit-code #f (make-glil-call 'return/nvalues 1))))
-         
-         ((push)
-          (comp-push body)
-          (emit-code #f (make-glil-call 'unwind-fluids 0)))
-         
-         ((vals)
-          (let ((MV (make-label)))
-            (comp-vals body MV)
-            ;; one value: push 1 and fall through to MV case
-            (emit-code #f (make-glil-const 1))
-            
-            (emit-label MV)
-            ;; multiple values: unwind and goto MVRA
-            (emit-code #f (make-glil-call 'unwind-fluids 0))
-            (emit-branch #f 'br MVRA)))
-         
-         ((drop)
-          ;; compile body, discarding values. then unwind...
-          (comp-drop body)
-          (emit-code #f (make-glil-call 'unwind-fluids 0))
-          ;; and fall through, or goto RA if there is one.
-          (if RA
-              (emit-branch #f 'br RA)))))
-
       ;; What's the deal here? The deal is that we are compiling the start of a
       ;; delimited continuation. We try to avoid heap allocation in the normal
       ;; case; so the body is an expression, not a thunk, and we try to render

module/language/tree-il/cse.scm

@@ -442,13 +442,6 @@
                      ((consumer db**) (visit consumer (concat db* db) env ctx)))
          (return (make-let-values src producer consumer)
                  (concat db** db*))))
-      (($ <dynlet> src fluids vals body)
-       (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
-                     ((vals db**) (parallel-visit vals db env 'value))
-                     ((body db***) (visit body (concat db** (concat db* db))
-                                          env ctx)))
-         (return (make-dynlet src fluids vals body)
-                 (concat db*** (concat db** db*)))))
       (($ <toplevel-ref>)
        (return exp vlist-null))
       (($ <module-ref>)

module/language/tree-il/debug.scm

@@ -204,18 +204,6 @@
          (error "name should be symbol" exp))
         (else
          (visit exp env))))
-      (($ <dynlet> src fluids vals body)
-       (cond
-        ((not (list? fluids))
-         (error "fluids should be list" exp))
-        ((not (list? vals))
-         (error "vals should be list" exp))
-        ((not (= (length fluids) (length vals)))
-         (error "mismatch in fluids/vals" exp))
-        (else
-         (for-each (cut visit <> env) fluids)
-         (for-each (cut visit <> env) vals)
-         (visit body env))))
       (($ <conditional> src condition subsequent alternate)
        (visit condition env)
        (visit subsequent env)

module/language/tree-il/effects.scm

@@ -211,12 +211,6 @@ of an expression."
            (logior (compute-effects producer)
                    (compute-effects consumer)
                    (cause &type-check)))
-          (($ <dynlet> _ fluids vals body)
-           (logior (accumulate-effects fluids)
-                   (accumulate-effects vals)
-                   (cause &type-check)
-                   (cause &fluid)
-                   (compute-effects body)))
           (($ <toplevel-ref>)
            (logior &toplevel
                    (cause &type-check)))
@@ -284,6 +278,15 @@ of an expression."
                    (cause &type-check)
                    (cause &fluid)))
 
+          (($ <primcall> _ 'push-fluid (fluid val))
+           (logior (compute-effects fluid)
+                   (compute-effects val)
+                   (cause &type-check)
+                   (cause &fluid)))
+
+          (($ <primcall> _ 'pop-fluid ())
+           (logior (cause &fluid)))
+
           ;; Primitives that are normally effect-free, but which might
           ;; cause type checks, allocate memory, or access mutable
           ;; memory.  FIXME: expand, to be more precise.

module/language/tree-il/peval.scm

@@ -433,6 +433,47 @@ top-level bindings from ENV and return the resulting expression."
   (define (lexical-refcount sym)
     (var-refcount (lookup-var sym)))
 
+  (define (with-temporaries src exps refcount can-copy? k)
+    (let* ((pairs (map (match-lambda
+                        ((and exp (? can-copy?))
+                         (cons #f exp))
+                        (exp
+                         (let ((sym (gensym "tmp ")))
+                           (record-new-temporary! 'tmp sym refcount)
+                           (cons sym exp))))
+                       exps))
+           (tmps (filter car pairs)))
+      (match tmps
+        (() (k exps))
+        (tmps
+         (make-let src
+                   (make-list (length tmps) 'tmp)
+                   (map car tmps)
+                   (map cdr tmps)
+                   (k (map (match-lambda
+                            ((#f . val) val)
+                            ((sym . _)
+                             (make-lexical-ref #f 'tmp sym)))
+                           pairs)))))))
+
+  (define (make-begin0 src first second)
+    (make-let-values
+     src
+     first
+     (let ((vals (gensym "vals ")))
+       (record-new-temporary! 'vals vals 1)
+       (make-lambda-case
+        #f
+        '() #f 'vals #f '() (list vals)
+        (make-seq
+         src
+         second
+         (make-primcall #f 'apply
+                        (list
+                         (make-primitive-ref #f 'values)
+                         (make-lexical-ref #f 'vals vals))))
+        #f))))
+
   ;; ORIG has been alpha-renamed to NEW.  Analyze NEW and record a link
   ;; from it to ORIG.
   ;;
@@ -559,10 +600,6 @@ top-level bindings from ENV and return the resulting expression."
                 (make-let-values src exp
                                  (make-lambda-case src2 req opt rest kw
                                                    inits gensyms body #f)))))
-        (($ <dynlet> src fluids vals body)
-         (let ((body (loop body)))
-           (and body
-                (make-dynlet src fluids vals body))))
         (($ <seq> src head tail)
          (let ((tail (loop tail)))
            (and tail (make-seq src head tail)))))))
@@ -994,9 +1031,6 @@ top-level bindings from ENV and return the resulting expression."
                    (else #f))))
                (_ #f))
              (make-let-values lv-src producer (for-tail consumer)))))
-      (($ <dynlet> src fluids vals body)
-       (make-dynlet src (map for-value fluids) (map for-value vals)
-                    (for-tail body)))
       (($ <toplevel-ref> src (? effect-free-primitive? name))
        exp)
       (($ <toplevel-ref>)
@@ -1108,48 +1142,9 @@ top-level bindings from ENV and return the resulting expression."
        (for-tail (make-let-values src (make-call src producer '())
                                   consumer)))
       (($ <primcall> src 'dynamic-wind (w thunk u))
-       (define (with-temporaries exps refcount k)
-         (let* ((pairs (map (match-lambda
-                             ((and exp (? constant-expression?))
-                              (cons #f exp))
-                             (exp
-                              (let ((sym (gensym "tmp ")))
-                                (record-new-temporary! 'tmp sym refcount)
-                                (cons sym exp))))
-                            exps))
-                (tmps (filter car pairs)))
-           (match tmps
-             (() (k exps))
-             (tmps
-              (make-let src
-                        (make-list (length tmps) 'tmp)
-                        (map car tmps)
-                        (map cdr tmps)
-                        (k (map (match-lambda
-                                 ((#f . val) val)
-                                 ((sym . _)
-                                  (make-lexical-ref #f 'tmp sym)))
-                                pairs)))))))
-       (define (make-begin0 src first second)
-         (make-let-values
-          src
-          first
-          (let ((vals (gensym "vals ")))
-            (record-new-temporary! 'vals vals 1)
-            (make-lambda-case
-             #f
-             '() #f 'vals #f '() (list vals)
-             (make-seq
-              src
-              second
-              (make-primcall #f 'apply
-                             (list
-                              (make-primitive-ref #f 'values)
-                              (make-lexical-ref #f 'vals vals))))
-             #f))))
        (for-tail
         (with-temporaries
-         (list w u) 2
+         src (list w u) 2 constant-expression?
          (match-lambda
           ((w u)
            (make-seq
@@ -1176,6 +1171,18 @@ top-level bindings from ENV and return the resulting expression."
                                    (make-primcall src 'unwind '())
                                    (make-call src u '())))))))))
 
+      (($ <primcall> src 'with-fluid* (f v thunk))
+       (for-tail
+        (with-temporaries
+         src (list f v thunk) 1 constant-expression?
+         (match-lambda
+          ((f v thunk)
+           (make-seq src
+                     (make-primcall src 'push-fluid (list f v))
+                     (make-begin0 src
+                                  (make-call src thunk '())
+                                  (make-primcall src 'pop-fluid '()))))))))
+
       (($ <primcall> src 'values exps)
        (cond
         ((null? exps)

module/language/tree-il/primitives.scm

@@ -76,7 +76,7 @@
     variable-ref variable-set!
     variable-bound?
 
-    fluid-ref fluid-set!
+    fluid-ref fluid-set! with-fluid*
 
     call-with-prompt
     abort-to-prompt* abort-to-prompt