diff options
author | Marius Vollmer <mvo@zagadka.de> | 2001-08-25 16:08:13 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2001-08-25 16:08:13 +0000 |
commit | 2e1711782d553c3fa96824ab3aed825ceb47f449 (patch) | |
tree | e7cb9c0b0d1b09c6e8f25dfd2da44e66b9bcb842 | |
parent | 969e8e458a052c8bb7d19c0e78d53e98957c1388 (diff) | |
download | guile-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.c | 2 | ||||
-rw-r--r-- | libguile/dynwind.h | 2 | ||||
-rw-r--r-- | libguile/eval.c | 105 |
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)): { |