summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2001-08-25 16:08:13 +0000
committerMarius Vollmer <mvo@zagadka.de>2001-08-25 16:08:13 +0000
commit2e1711782d553c3fa96824ab3aed825ceb47f449 (patch)
treee7cb9c0b0d1b09c6e8f25dfd2da44e66b9bcb842
parent969e8e458a052c8bb7d19c0e78d53e98957c1388 (diff)
downloadguile-2e1711782d553c3fa96824ab3aed825ceb47f449.tar.gz
* eval.c (scm_m_atbind): Redesigned to behvae like `let', but with
dynamic scope. * dynwind.h (scm_swap_bindings): Declare. * dynwind.c (scm_swap_bindings): Make non-static.
-rw-r--r--libguile/dynwind.c2
-rw-r--r--libguile/dynwind.h2
-rw-r--r--libguile/eval.c105
3 files changed, 65 insertions, 44 deletions
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index 889c0d4fb..d093861cf 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -184,7 +184,7 @@ SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
#undef FUNC_NAME
#endif
-static void
+void
scm_swap_bindings (SCM vars, SCM vals)
{
SCM tmp;
diff --git a/libguile/dynwind.h b/libguile/dynwind.h
index 9f457f636..f956ea456 100644
--- a/libguile/dynwind.h
+++ b/libguile/dynwind.h
@@ -59,6 +59,8 @@ extern SCM scm_internal_dynamic_wind (scm_t_guard before,
extern void scm_dowinds (SCM to, long delta);
extern void scm_init_dynwind (void);
+extern void scm_swap_bindings (SCM vars, SCM vals);
+
#ifdef GUILE_DEBUG
extern SCM scm_wind_chain (void);
#endif /*GUILE_DEBUG*/
diff --git a/libguile/eval.c b/libguile/eval.c
index f598f370d..b896814d2 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1112,32 +1112,53 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
return x;
}
+/* (@bind ((var exp) ...) body ...)
+
+ This will assign the values of the `exp's to the global variables
+ named by `var's (symbols, not evaluated), creating them if they
+ don't exist, executes body, and then restores the previous values of
+ the `var's. Additionally, whenever control leaves body, the values
+ of the `var's are saved and restored when control returns. It is an
+ error when a symbol appears more than once among the `var's.
+ All `exp's are evaluated before any `var' is set.
+
+ This of this as `let' for dynamic scope.
+
+ It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
+
+ XXX - also implement `@bind*'.
+*/
+
SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
SCM
scm_m_atbind (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, "@bind");
+ SCM top_level = scm_env_top_level (env);
+ SCM vars = SCM_EOL;
+ SCM exps = SCM_EOL;
+
+ SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, s_atbind);
- if (SCM_IMP (env))
- env = SCM_BOOL_F;
- else
- {
- while (SCM_NIMP (SCM_CDR (env)))
- env = SCM_CDR (env);
- env = SCM_CAR (env);
- if (SCM_CONSP (env))
- env = SCM_BOOL_F;
- }
-
x = SCM_CAR (x);
while (SCM_NIMP (x))
{
- SCM_SETCAR (x, scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T));
+ SCM rest;
+ SCM sym_exp = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (sym_exp) == 2, scm_s_bindings, s_atbind);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), scm_s_bindings, s_atbind);
x = SCM_CDR (x);
+ for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest))
+ if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAR (SCM_CAR (rest))))
+ scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL);
+ vars = scm_cons (scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T),
+ vars);
+ exps = scm_cons (SCM_CADR (sym_exp), exps);
}
- return scm_cons (SCM_IM_BIND, SCM_CDR (xorig));
+ return scm_cons (SCM_IM_BIND,
+ scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps),
+ SCM_CDDR (xorig)));
}
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values);
@@ -2411,39 +2432,37 @@ dispatch:
: SCM_INUM0)
case (SCM_ISYMNUM (SCM_IM_BIND)):
- x = SCM_CDR (x);
+ {
+ SCM vars, exps, vals;
- t.arg1 = SCM_CAR (x);
- arg2 = SCM_CDAR (env);
- while (SCM_NIMP (arg2))
- {
- proc = SCM_VARIABLE_REF (SCM_CAR (t.arg1));
- SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2));
- SCM_SETCAR (arg2, proc);
- t.arg1 = SCM_CDR (t.arg1);
- arg2 = SCM_CDR (arg2);
- }
- t.arg1 = SCM_CAR (x);
- scm_dynwinds = scm_acons (t.arg1, SCM_CDAR (env), scm_dynwinds);
+ x = SCM_CDR (x);
+ vars = SCM_CAAR (x);
+ exps = SCM_CDAR (x);
+
+ vals = SCM_EOL;
+
+ while (SCM_NIMP (exps))
+ {
+ vals = scm_cons (EVALCAR (exps, env), vals);
+ exps = SCM_CDR (exps);
+ }
+
+ scm_swap_bindings (vars, vals);
+ scm_dynwinds = scm_acons (vars, vals, scm_dynwinds);
- arg2 = x = SCM_CDR (x);
- while (!SCM_NULLP (arg2 = SCM_CDR (arg2)))
- {
- SIDEVAL (SCM_CAR (x), env);
- x = arg2;
- }
- proc = EVALCAR (x, env);
+ arg2 = x = SCM_CDR (x);
+ while (!SCM_NULLP (arg2 = SCM_CDR (arg2)))
+ {
+ SIDEVAL (SCM_CAR (x), env);
+ x = arg2;
+ }
+ proc = EVALCAR (x, env);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- arg2 = SCM_CDAR (env);
- while (SCM_NIMP (arg2))
- {
- SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2));
- t.arg1 = SCM_CDR (t.arg1);
- arg2 = SCM_CDR (arg2);
- }
+ scm_dynwinds = SCM_CDR (scm_dynwinds);
+ scm_swap_bindings (vars, vals);
- RETURN (proc);
+ RETURN (proc)
+ }
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
{