summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-06-28 19:47:03 +0200
committerAndy Wingo <wingo@pobox.com>2013-06-28 19:52:09 +0200
commitc32b7c4cef1c63a677a1c447a0386e90ab2ecd42 (patch)
treea1e1aad96639736f3e18c48a73a6f9d1fd24bacc /libguile
parent5e0253f19ef146c46a08fead9d70866f4baa9ca1 (diff)
downloadguile-c32b7c4cef1c63a677a1c447a0386e90ab2ecd42.tar.gz
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*.
Diffstat (limited to 'libguile')
-rw-r--r--libguile/eval.c23
-rw-r--r--libguile/expand.c29
-rw-r--r--libguile/expand.h17
-rw-r--r--libguile/fluids.c8
-rw-r--r--libguile/memoize.c47
-rw-r--r--libguile/memoize.h2
-rw-r--r--libguile/vm-i-system.c13
7 files changed, 35 insertions, 104 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index ca0f731f9..b245026f0 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 e5341b7f1..a8625eafa 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 f5e7af5d4..8a578ae54 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 146854b96..1199451b2 100644
--- a/libguile/fluids.c
+++ b/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 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)
diff --git a/libguile/memoize.c b/libguile/memoize.c
index e2c6bc65c..7dca50bd2 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_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"));
}
diff --git a/libguile/memoize.h b/libguile/memoize.h
index ab7e777fe..7f7624fd3 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-i-system.c b/libguile/vm-i-system.c
index 9b24c9295..442350d40 100644
--- a/libguile/vm-i-system.c
+++ b/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;
- CHECK_UNDERFLOW ();
- scm_dynstack_push_fluids (&current_thread->dynstack, n, sp + 1, sp + 1 + n,
+ scm_dynstack_push_fluids (&current_thread->dynstack, 1, &fluid, &val,
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,