[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-57-g98eaef1
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-57-g98eaef1 |
|
Date: |
Fri, 28 Jun 2013 18:02:46 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=98eaef1b50db626c672646da58645c62407d0c1a
The branch, master has been updated
via 98eaef1b50db626c672646da58645c62407d0c1a (commit)
via c32b7c4cef1c63a677a1c447a0386e90ab2ecd42 (commit)
from 5e0253f19ef146c46a08fead9d70866f4baa9ca1 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 98eaef1b50db626c672646da58645c62407d0c1a
Author: Andy Wingo <address@hidden>
Date: Fri Jun 28 20:01:35 2013 +0200
Simplify dynstack API to only wind one fluid at a time
* libguile/dynstack.h (SCM_DYNSTACK_TYPE_WITH_FLUID): Rename from
with-fluids.
* libguile/dynstack.c (scm_dynstack_push_fluid):
(scm_dynstack_unwind_fluid): Change API to only wind/unwind one
fluid binding.
(WITH_FLUID_WORDS): New define, always 2 words (fluid and value box).
(WITH_FLUID_FLUID, WITH_FLUID_VALUE_BOX): New macros to get offsets of
fluid and value box.
(scm_dynstack_push_rewinder, scm_dynstack_push_unwinder): Use
WINDER_WORDS.
(scm_dynstack_push_dynwind): Use DYNWIND_WORDS.
(scm_dynstack_wind_1): Update for scm_swap_fluid API change.
* libguile/fluids.h:
* libguile/fluids.c (scm_prepare_fluids): Remove; no longer needed.
(scm_swap_fluid): Update to just swap one fluid binding.
(scm_c_with_fluids, scm_c_with_fluid): Update to use
scm_dynstack_push_fluid.
* libguile/memoize.c (do_push_fluid, do_pop_fluid): Adapt to API
change.
* libguile/vm-engine.c (rtl_vm_engine): Change wind-fluids / unwind-fluids
to push-fluid / pop-fluid, and actually enable. Woo!
* libguile/vm-i-system.c (push-fluid, pop-fluid): Update to new API.
commit c32b7c4cef1c63a677a1c447a0386e90ab2ecd42
Author: Andy Wingo <address@hidden>
Date: Fri Jun 28 19:47:03 2013 +0200
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*.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/compiler.texi | 8 --
doc/ref/vm.texi | 13 ++--
libguile/dynstack.c | 85 ++++++++++------------
libguile/dynstack.h | 16 ++---
libguile/eval.c | 23 ------
libguile/expand.c | 29 --------
libguile/expand.h | 17 +----
libguile/fluids.c | 93 +++++-------------------
libguile/fluids.h | 6 +-
libguile/memoize.c | 47 +++++++-----
libguile/memoize.h | 2 -
libguile/vm-engine.c | 29 +++-----
libguile/vm-i-system.c | 19 ++---
module/ice-9/boot-9.scm | 59 +++++++++++----
module/ice-9/eval.scm | 10 ---
module/ice-9/psyntax-pp.scm | 43 ++---------
module/ice-9/psyntax.scm | 15 ----
module/language/elisp/compile-tree-il.scm | 21 +++++-
module/language/scheme/decompile-tree-il.scm | 12 ---
module/language/tree-il.scm | 16 ----
module/language/tree-il/analyze.scm | 6 --
module/language/tree-il/canonicalize.scm | 2 -
module/language/tree-il/compile-glil.scm | 48 +------------
module/language/tree-il/cse.scm | 7 --
module/language/tree-il/debug.scm | 12 ---
module/language/tree-il/effects.scm | 15 +++--
module/language/tree-il/peval.scm | 101 ++++++++++++++------------
module/language/tree-il/primitives.scm | 2 +-
28 files changed, 259 insertions(+), 497 deletions(-)
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 408c108..553c270 100644
--- a/doc/ref/compiler.texi
+++ b/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
address@hidden {Scheme Variable} <dynlet> fluids vals body
address@hidden {External Representation} (dynlet @var{fluids} @var{vals}
@var{body})
-Dynamic binding; the equivalent of Scheme's @code{with-fluids}.
address@hidden 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
address@hidden
address@hidden 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,
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 76e3ab9..1e10eb0 100644
--- a/doc/ref/vm.texi
+++ b/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
address@hidden Instruction wind-fluids n
-Pop off @var{n} values and @var{n} fluids from the stack, in that order.
-Set the fluids to the values by creating a with-fluids object and
-pushing that object on the dynamic stack. @xref{Fluids and Dynamic
-States}.
address@hidden Instruction push-fluid
+Pop a value and a fluid from the stack, in that order. Set the fluid
+to the value by creating a with-fluids object and pushing that object
+on the dynamic stack. @xref{Fluids and Dynamic States}.
@end deffn
address@hidden Instruction unwind-fluids
address@hidden 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
address@hidden instruction was processed.
address@hidden instruction was processed.
@end deffn
@deffn Instruction fluid-ref
diff --git a/libguile/dynstack.c b/libguile/dynstack.c
index ce9a2fe..5f19a2b 100644
--- a/libguile/dynstack.c
+++ b/libguile/dynstack.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2012, 2013 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
@@ -49,8 +49,9 @@
#define DYNWIND_ENTER(top) (SCM_PACK ((top)[0]))
#define DYNWIND_LEAVE(top) (SCM_PACK ((top)[1]))
-#define WITH_FLUIDS_FLUIDS(top) ((SCM*)((top) + 1))
-#define WITH_FLUIDS_VALUES(top) ((SCM*)((top)[0]))
+#define WITH_FLUID_WORDS 2
+#define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
+#define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))
@@ -65,15 +66,6 @@ copy_scm_t_bits (scm_t_bits *dst, scm_t_bits *src, size_t n)
}
static void
-copy_scm (SCM *dst, SCM *src, size_t n)
-{
- size_t i;
-
- for (i = 0; i < n; i++)
- dst[i] = src[i];
-}
-
-static void
clear_scm_t_bits (scm_t_bits *items, size_t n)
{
size_t i;
@@ -147,7 +139,8 @@ scm_dynstack_push_rewinder (scm_t_dynstack *dynstack,
{
scm_t_bits *words;
- words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_REWINDER, flags, 2);
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_REWINDER, flags,
+ WINDER_WORDS);
words[0] = (scm_t_bits) proc;
words[1] = (scm_t_bits) data;
}
@@ -159,33 +152,34 @@ scm_dynstack_push_unwinder (scm_t_dynstack *dynstack,
{
scm_t_bits *words;
- words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_UNWINDER, flags, 2);
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_UNWINDER, flags,
+ WINDER_WORDS);
words[0] = (scm_t_bits) proc;
words[1] = (scm_t_bits) data;
}
-/* The fluids are stored on the stack. However, the values have to be
- stored on the heap, so that all continuations that capture this
- dynamic scope capture the same bindings. */
+/* The fluid is stored on the stack, but the value has to be stored on the
heap,
+ so that all continuations that capture this dynamic scope capture the same
+ binding. */
void
-scm_dynstack_push_fluids (scm_t_dynstack *dynstack, size_t n,
- SCM *fluids, SCM *values, SCM dynamic_state)
+scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
+ SCM dynamic_state)
{
scm_t_bits *words;
- SCM *heap_values;
+ SCM value_box;
+
+ if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)))
+ scm_wrong_type_arg ("with-fluid*", 0, fluid);
- n = scm_prepare_fluids (n, fluids, values);
- heap_values = scm_gc_malloc (n * sizeof (scm_t_bits), "with-fluids");
- copy_scm (heap_values, values, n);
+ value_box = scm_make_variable (value);
- words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUIDS,
- 0, n + 1);
- words[0] = (scm_t_bits) heap_values;
- copy_scm (WITH_FLUIDS_FLUIDS (words), fluids, n);
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUID, 0,
+ WITH_FLUID_WORDS);
+ words[0] = SCM_UNPACK (fluid);
+ words[1] = SCM_UNPACK (value_box);
/* Go ahead and swap them. */
- scm_swap_fluids (n, WITH_FLUIDS_FLUIDS (words), WITH_FLUIDS_VALUES (words),
- dynamic_state);
+ scm_swap_fluid (fluid, value_box, dynamic_state);
}
void
@@ -211,7 +205,8 @@ scm_dynstack_push_dynwind (scm_t_dynstack *dynstack, SCM
enter, SCM leave)
{
scm_t_bits *words;
- words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNWIND, 0, 2);
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNWIND, 0,
+ DYNWIND_WORDS);
words[0] = SCM_UNPACK (enter);
words[1] = SCM_UNPACK (leave);
}
@@ -296,10 +291,10 @@ scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits
*item)
WINDER_PROC (item) (WINDER_DATA (item));
break;
- case SCM_DYNSTACK_TYPE_WITH_FLUIDS:
- scm_swap_fluids (len - 1, WITH_FLUIDS_FLUIDS (item),
- WITH_FLUIDS_VALUES (item),
- SCM_I_CURRENT_THREAD->dynamic_state);
+ case SCM_DYNSTACK_TYPE_WITH_FLUID:
+ scm_swap_fluid (WITH_FLUID_FLUID (item),
+ WITH_FLUID_VALUE_BOX (item),
+ SCM_I_CURRENT_THREAD->dynamic_state);
break;
case SCM_DYNSTACK_TYPE_PROMPT:
@@ -328,12 +323,10 @@ scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
scm_t_bits tag;
scm_t_bits *words;
scm_t_dynstack_item_type type;
- size_t len;
tag = dynstack_pop (dynstack, &words);
type = SCM_DYNSTACK_TAG_TYPE (tag);
- len = SCM_DYNSTACK_TAG_LEN (tag);
switch (type)
{
@@ -349,11 +342,11 @@ scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
clear_scm_t_bits (words, WINDER_WORDS);
break;
- case SCM_DYNSTACK_TYPE_WITH_FLUIDS:
- scm_swap_fluids (len - 1, WITH_FLUIDS_FLUIDS (words),
- WITH_FLUIDS_VALUES (words),
- SCM_I_CURRENT_THREAD->dynamic_state);
- clear_scm_t_bits (words, len);
+ case SCM_DYNSTACK_TYPE_WITH_FLUID:
+ scm_swap_fluid (WITH_FLUID_FLUID (words),
+ WITH_FLUID_VALUE_BOX (words),
+ SCM_I_CURRENT_THREAD->dynamic_state);
+ clear_scm_t_bits (words, WITH_FLUID_WORDS);
break;
case SCM_DYNSTACK_TYPE_PROMPT:
@@ -532,7 +525,7 @@ scm_dynstack_unwind_frame (scm_t_dynstack *dynstack)
/* This function must not allocate. */
void
-scm_dynstack_unwind_fluids (scm_t_dynstack *dynstack, SCM dynamic_state)
+scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, SCM dynamic_state)
{
scm_t_bits tag, *words;
size_t len;
@@ -540,11 +533,11 @@ scm_dynstack_unwind_fluids (scm_t_dynstack *dynstack, SCM
dynamic_state)
tag = dynstack_pop (dynstack, &words);
len = SCM_DYNSTACK_TAG_LEN (tag);
- assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_WITH_FLUIDS);
- assert (len >= 1);
+ assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_WITH_FLUID);
+ assert (len == WITH_FLUID_WORDS);
- scm_swap_fluids (len - 1, WITH_FLUIDS_FLUIDS (words),
- WITH_FLUIDS_VALUES (words), dynamic_state);
+ scm_swap_fluid (WITH_FLUID_FLUID (words), WITH_FLUID_VALUE_BOX (words),
+ dynamic_state);
clear_scm_t_bits (words, len);
}
diff --git a/libguile/dynstack.h b/libguile/dynstack.h
index 207638e..c27c675 100644
--- a/libguile/dynstack.h
+++ b/libguile/dynstack.h
@@ -3,7 +3,7 @@
#ifndef SCM_DYNSTACK_H
#define SCM_DYNSTACK_H
-/* Copyright (C) 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2012, 2013 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
@@ -79,7 +79,7 @@ typedef enum {
SCM_DYNSTACK_TYPE_FRAME,
SCM_DYNSTACK_TYPE_UNWINDER,
SCM_DYNSTACK_TYPE_REWINDER,
- SCM_DYNSTACK_TYPE_WITH_FLUIDS,
+ SCM_DYNSTACK_TYPE_WITH_FLUID,
SCM_DYNSTACK_TYPE_PROMPT,
SCM_DYNSTACK_TYPE_DYNWIND,
} scm_t_dynstack_item_type;
@@ -148,11 +148,9 @@ SCM_INTERNAL void scm_dynstack_push_rewinder
(scm_t_dynstack *,
SCM_INTERNAL void scm_dynstack_push_unwinder (scm_t_dynstack *,
scm_t_dynstack_winder_flags,
scm_t_guard, void *);
-SCM_INTERNAL void scm_dynstack_push_fluids (scm_t_dynstack *,
- size_t,
- SCM *fluids,
- SCM *values,
- SCM dynamic_state);
+SCM_INTERNAL void scm_dynstack_push_fluid (scm_t_dynstack *,
+ SCM fluid, SCM value,
+ SCM dynamic_state);
SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *,
scm_t_dynstack_prompt_flags,
SCM key,
@@ -187,8 +185,8 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork
(scm_t_dynstack *,
scm_t_dynstack *);
SCM_INTERNAL void scm_dynstack_unwind_frame (scm_t_dynstack *);
-SCM_INTERNAL void scm_dynstack_unwind_fluids (scm_t_dynstack *dynstack,
- SCM dynamic_state);
+SCM_INTERNAL void scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack,
+ SCM dynamic_state);
SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM,
scm_t_dynstack_prompt_flags
*,
diff --git a/libguile/eval.c b/libguile/eval.c
index ca0f731..b245026 100644
--- a/libguile/eval.c
+++ b/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);
diff --git a/libguile/expand.c b/libguile/expand.c
index e5341b7..a8625ea 100644
--- a/libguile/expand.c
+++ b/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");
@@ -565,30 +561,6 @@ expand_define (SCM expr, SCM 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)
{
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
@@ -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"),
diff --git a/libguile/expand.h b/libguile/expand.h
index f5e7af5..8a578ae 100644
--- a/libguile/expand.h
+++ b/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 */
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 146854b..22d825b 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -302,52 +302,17 @@ apply_thunk (void *thunk)
return scm_call_0 (SCM_PACK (thunk));
}
-size_t
-scm_prepare_fluids (size_t n, SCM *fluids, SCM *values)
-{
- size_t j;
-
- /* 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. */
- for (j = n; j--;)
- {
- size_t i;
-
- if (SCM_UNLIKELY (!IS_FLUID (fluids[j])))
- scm_wrong_type_arg ("with-fluids", 0, fluids[j]);
-
- for (i = j; i--;)
- if (scm_is_eq (fluids[i], fluids[j]))
- {
- values[i] = values[j]; /* later bindings win */
- n--;
- fluids[j] = fluids[n];
- values[j] = values[n];
- break;
- }
- }
-
- return n;
-}
-
void
-scm_swap_fluids (size_t n, SCM *fluids, SCM *values, SCM dynstate)
+scm_swap_fluid (SCM fluid, SCM value_box, SCM dynstate)
{
- SCM fluid_vector;
- size_t i, max = 0;
+ SCM fluid_vector, tmp;
+ size_t fluid_num;
- fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
+ fluid_num = FLUID_NUM (fluid);
- /* 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 < n; i++)
- {
- size_t num = FLUID_NUM (fluids[i]);
- max = (max > num) ? max : num;
- }
+ fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
- if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector)))
+ if (SCM_UNLIKELY (fluid_num >= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector)))
{
/* Lazily grow the current thread's dynamic state. */
grow_dynamic_state (dynstate);
@@ -355,17 +320,9 @@ scm_swap_fluids (size_t n, SCM *fluids, SCM *values, SCM
dynstate)
fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
}
- /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
- for (i = 0; i < n; i++)
- {
- size_t fluid_num;
- SCM x;
-
- fluid_num = FLUID_NUM (fluids[i]);
- x = SCM_SIMPLE_VECTOR_REF (fluid_vector, fluid_num);
- SCM_SIMPLE_VECTOR_SET (fluid_vector, fluid_num, values[i]);
- values[i] = x;
- }
+ tmp = SCM_SIMPLE_VECTOR_REF (fluid_vector, fluid_num);
+ SCM_SIMPLE_VECTOR_SET (fluid_vector, fluid_num, SCM_VARIABLE_REF
(value_box));
+ SCM_VARIABLE_SET (value_box, tmp);
}
SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
@@ -387,7 +344,6 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (),
void *cdata)
{
SCM ans;
long flen, vlen, i;
- SCM *fluidsv, *valuesv;
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
@@ -395,39 +351,30 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc)
(), void *cdata)
if (flen != vlen)
scm_out_of_range (s_scm_with_fluids, values);
- if (SCM_UNLIKELY (flen == 0))
- return cproc (cdata);
-
- fluidsv = alloca (sizeof(SCM)*flen);
- valuesv = alloca (sizeof(SCM)*flen);
-
for (i = 0; i < flen; i++)
{
- fluidsv[i] = SCM_CAR (fluids);
+ scm_dynstack_push_fluid (&thread->dynstack,
+ SCM_CAR (fluids), SCM_CAR (values),
+ thread->dynamic_state);
fluids = SCM_CDR (fluids);
- valuesv[i] = SCM_CAR (values);
values = SCM_CDR (values);
}
- scm_dynstack_push_fluids (&thread->dynstack, flen, fluidsv, valuesv,
- thread->dynamic_state);
ans = cproc (cdata);
- scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
+
+ for (i = 0; i < flen; i++)
+ scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
return ans;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0,
- (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
+SCM
+scm_with_fluid (SCM fluid, SCM value, SCM thunk)
{
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)
@@ -436,10 +383,10 @@ scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (),
void *cdata)
SCM ans;
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
- scm_dynstack_push_fluids (&thread->dynstack, 1, &fluid, &value,
- thread->dynamic_state);
+ scm_dynstack_push_fluid (&thread->dynstack, fluid, value,
+ thread->dynamic_state);
ans = cproc (cdata);
- scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
+ scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
return ans;
}
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 2278772..a550d9a 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, 2010, 2011, 2012 Free
Software Foundation, Inc.
+/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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
@@ -59,9 +59,7 @@ SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
SCM_API SCM scm_fluid_unset_x (SCM fluid);
SCM_API SCM scm_fluid_bound_p (SCM fluid);
-SCM_INTERNAL size_t scm_prepare_fluids (size_t n, SCM *fluids, SCM *vals);
-SCM_INTERNAL void scm_swap_fluids (size_t n, SCM *fluids, SCM *vals,
- SCM dynamic_state);
+SCM_INTERNAL void scm_swap_fluid (SCM fluid, SCM value_box, SCM dynamic_state);
SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
SCM (*cproc)(void *), void *cdata);
diff --git a/libguile/memoize.c b/libguile/memoize.c
index e2c6bc6..daad14a 100644
--- a/libguile/memoize.c
+++ b/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_fluid (&thread->dynstack, 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_fluid (&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"));
}
diff --git a/libguile/memoize.h b/libguile/memoize.h
index ab7e777..7f7624f 100644
--- a/libguile/memoize.h
+++ b/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,
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index d070823..8b11e7f 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2519,39 +2519,34 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1);
}
- /* wind-fluids fluid-base:24 _:8 n:24 value0:24 0:8 ...
+ /* push-fluid fluid:12 value:12
*
* Dynamically bind N fluids to values. The fluids are expected to be
* allocated in a continguous range on the stack, starting from
* FLUID-BASE. The values do not have this restriction.
*/
- VM_DEFINE_OP (69, wind_fluids, "wind-fluids", OP2 (U8_U24, X8_R24))
-#if 0
+ VM_DEFINE_OP (69, push_fluid, "push-fluid", OP1 (U8_U12_U12))
{
- scm_t_uint32 fluid_base, n;
+ scm_t_uint32 fluid, value;
- SCM_UNPACK_RTL_24 (op, fluid_base);
- SCM_UNPACK_RTL_24 (ip[1], n);
+ SCM_UNPACK_RTL_12_12 (op, fluid, value);
- scm_dynstack_push_fluids_shuffled (¤t_thread->dynstack, n,
- &fp[fluid_base], fp, &ip[2],
- current_thread->dynamic_state);
- NEXT (n + 2);
+ scm_dynstack_push_fluid (¤t_thread->dynstack,
+ fp[fluid], fp[value],
+ current_thread->dynamic_state);
+ NEXT (1);
}
-#else
- abort();
-#endif
- /* unwind-fluids _:24
+ /* pop-fluid _:24
*
* Leave the dynamic extent of a with-fluids expression, restoring the
* fluids to their previous values.
*/
- VM_DEFINE_OP (70, unwind_fluids, "unwind-fluids", OP1 (U8_X24))
+ VM_DEFINE_OP (70, pop_fluid, "pop-fluid", OP1 (U8_X24))
{
/* This function must not allocate. */
- scm_dynstack_unwind_fluids (¤t_thread->dynstack,
- current_thread->dynamic_state);
+ scm_dynstack_unwind_fluid (¤t_thread->dynstack,
+ current_thread->dynamic_state);
NEXT (1);
}
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 9b24c92..248db9a 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1490,24 +1490,21 @@ 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;
- CHECK_UNDERFLOW ();
- scm_dynstack_push_fluids (¤t_thread->dynstack, n, sp + 1, sp + 1 + n,
- current_thread->dynamic_state);
- NULLSTACK (2 * n);
+ scm_dynstack_push_fluid (¤t_thread->dynstack, fluid, val,
+ current_thread->dynamic_state);
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 (¤t_thread->dynstack,
- current_thread->dynamic_state);
+ scm_dynstack_unwind_fluid (¤t_thread->dynstack,
+ current_thread->dynamic_state);
NEXT;
}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d6c4cfd..48aec49 100644
--- a/module/ice-9/boot-9.scm
+++ b/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}.
address@hidden 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)))
- (if (not (memq pre running))
- (apply pre thrown-k args))
- ;; fall through
- (if prompt-tag
- (apply abort-to-prompt prompt-tag thrown-k args)
- (apply prev thrown-k args))))
+ (with-fluid* %running-exception-handlers (cons pre running)
+ (lambda ()
+ (if (not (memq pre running))
+ (apply pre thrown-k args))
+ ;; fall through
+ (if prompt-tag
+ (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
- ((%exception-handler
- (if pre-unwind-handler
- (custom-throw-handler tag k pre-unwind-handler)
- (default-throw-handler tag k))))
- (thunk)))
+ (with-fluid* %exception-handler
+ (if pre-unwind-handler
+ (custom-throw-handler tag k pre-unwind-handler)
+ (default-throw-handler tag k))
+ 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
- (custom-throw-handler #f k pre-unwind-handler)))
- (thunk))))
+ (with-fluid* %exception-handler
+ (custom-throw-handler #f k pre-unwind-handler)
+ 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 ()
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 0e6aeac..bb1ce1e 100644
--- a/module/ice-9/eval.scm
+++ b/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)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index fe16ae4..3619412 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/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
- ((transformer-environment (lambda (k) (k e r w s rib mod))))
- (rebuild-macro-output
- (p (source-wrap e (anti-mark w) s mod))
- (gensym (string-append "m-" (session-id) "-")))))))
+ (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib
mod))))
+ (with-fluid*
+ t-1
+ t
+ (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 '())
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 515bef3..0ad3db5 100644
--- a/module/ice-9/psyntax.scm
+++ b/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 '())
diff --git a/module/language/elisp/compile-tree-il.scm
b/module/language/elisp/compile-tree-il.scm
index 1a4d00f..c0b5f88 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/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)
diff --git a/module/language/scheme/decompile-tree-il.scm
b/module/language/scheme/decompile-tree-il.scm
index 7dc55bf..dca969f 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/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)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1580142..16fdb96 100644
--- a/module/language/tree-il.scm
+++ b/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)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 673f68b..ca7cb80 100644
--- a/module/language/tree-il/analyze.scm
+++ b/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))
diff --git a/module/language/tree-il/canonicalize.scm
b/module/language/tree-il/canonicalize.scm
index b291eaa..9b0c0c8 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/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
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index c2dba52..96a06ab 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/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
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index ffddc19..656dd72 100644
--- a/module/language/tree-il/cse.scm
+++ b/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>)
diff --git a/module/language/tree-il/debug.scm
b/module/language/tree-il/debug.scm
index d5dab80..8ec573a 100644
--- a/module/language/tree-il/debug.scm
+++ b/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)
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index 374ab2c..467e436 100644
--- a/module/language/tree-il/effects.scm
+++ b/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.
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index bfd338d..5b9852b 100644
--- a/module/language/tree-il/peval.scm
+++ b/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)
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index cd95084..8cb090a 100644
--- a/module/language/tree-il/primitives.scm
+++ b/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
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-57-g98eaef1,
Andy Wingo <=