diff options
author | Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> | 2003-10-18 17:24:09 +0000 |
---|---|---|
committer | Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> | 2003-10-18 17:24:09 +0000 |
commit | 82b3e2c612f1d3ec45ce596d064512848e6b23e3 (patch) | |
tree | db9c1132e3b15953529fa7010b2844a55fcbe6c8 | |
parent | 216286857be77676b068f36ed96ea686de03a89e (diff) | |
download | guile-82b3e2c612f1d3ec45ce596d064512848e6b23e3.tar.gz |
* libguile/eval.c (scm_m_set_x, scm_m_apply, scm_m_atbind): Use
ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing
when creating the memoized code.
(scm_m_atbind): Reversed the order, in which the init expressions
are stored and executed. The order of execution is now equal to
the order in which the initializers of the let-forms are executed.
Use check_bindings and transform_bindings.
(SCM_CEVAL): Eliminated SCM_NIMP in favor of more appropriate
!SCM_NULLP. Added some comments.
* test-suite/tests/dynamic-scope.test (exception:missing-expr):
Introduced temporarily until all memoizers use the new way of error
reporting.
-rw-r--r-- | libguile/ChangeLog | 14 | ||||
-rw-r--r-- | libguile/eval.c | 128 | ||||
-rw-r--r-- | test-suite/ChangeLog | 6 | ||||
-rw-r--r-- | test-suite/tests/dynamic-scope.test | 10 |
4 files changed, 98 insertions, 60 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d557757d7..07d41ee2e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,19 @@ 2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de> + * eval.c (scm_m_set_x, scm_m_apply, scm_m_atbind): Use + ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing + when creating the memoized code. + + (scm_m_atbind): Reversed the order, in which the init expressions + are stored and executed. The order of execution is now equal to + the order in which the initializers of the let-forms are executed. + Use check_bindings and transform_bindings. + + (SCM_CEVAL): Eliminated SCM_NIMP in favor of more appropriate + !SCM_NULLP. Added some comments. + +2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de> + * eval.c: Sorted include files alphabetically. (scm_m_begin): Added comment. diff --git a/libguile/eval.c b/libguile/eval.c index ac5d006b6..b700e9e8b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1487,12 +1487,18 @@ static const char s_set_x[] = "set!"; SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x); SCM -scm_m_set_x (SCM xorig, SCM env SCM_UNUSED) +scm_m_set_x (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 2, s_expression, s_set_x); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), s_variable, s_set_x); - return scm_cons (SCM_IM_SET_X, x); + SCM variable; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + variable = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + + SCM_SETCAR (expr, SCM_IM_SET_X); + return expr; } @@ -1504,64 +1510,69 @@ SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); SCM -scm_m_apply (SCM xorig, SCM env SCM_UNUSED) +scm_m_apply (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, s_expression, s_atapply); - return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); -} - - -/* (@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. - - Think of this as `let' for dynamic scope. + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr); - It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...). + SCM_SETCAR (expr, SCM_IM_APPLY); + return expr; +} - XXX - also implement `@bind*'. -*/ SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind); +/* FIXME: The following explanation should go into the documentation: */ +/* (@bind ((var init) ...) body ...) will assign the values of the `init'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 `init's + * are evaluated before any `var' is set. + * + * Think of this as `let' for dynamic scope. + */ + +/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into + * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...). + * + * FIXME - also implement `@bind*'. + */ SCM -scm_m_atbind (SCM xorig, SCM env) +scm_m_atbind (SCM expr, SCM env) { - SCM x = SCM_CDR (xorig); - SCM top_level = scm_env_top_level (env); - SCM vars = SCM_EOL, var; - SCM exps = SCM_EOL; + SCM bindings; + SCM rvariables; + SCM inits; + SCM variable_idx; - SCM_ASSYNT (scm_ilength (x) > 1, s_expression, s_atbind); + const SCM top_level = scm_env_top_level (env); - x = SCM_CAR (x); - while (SCM_NIMP (x)) + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + bindings = SCM_CAR (cdr_expr); + check_bindings (bindings, expr); + transform_bindings (bindings, expr, &rvariables, &inits); + + for (variable_idx = rvariables; + !SCM_NULLP (variable_idx); + variable_idx = SCM_CDR (variable_idx)) { - SCM rest; - SCM sym_exp = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (sym_exp) == 2, s_bindings, s_atbind); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), 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_CAAR (rest))) - scm_misc_error (s_atbind, s_duplicate_bindings, SCM_EOL); - /* The first call to scm_sym2var will look beyond the current - module, while the second call wont. */ - var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F); - if (SCM_FALSEP (var)) - var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T); - vars = scm_cons (var, vars); - exps = scm_cons (SCM_CADR (sym_exp), exps); + /* The first call to scm_sym2var will look beyond the current module, + * while the second call wont. */ + const SCM variable = SCM_CAR (variable_idx); + SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F); + if (SCM_FALSEP (new_variable)) + new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T); + SCM_SETCAR (variable_idx, new_variable); } - return scm_cons (SCM_IM_BIND, - scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps), - SCM_CDDR (xorig))); + + SCM_SETCAR (expr, SCM_IM_BIND); + SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits)); + return expr; } @@ -3169,10 +3180,8 @@ dispatch: x = SCM_CDR (x); vars = SCM_CAAR (x); exps = SCM_CDAR (x); - vals = SCM_EOL; - - while (SCM_NIMP (exps)) + while (!SCM_NULLP (exps)) { vals = scm_cons (EVALCAR (exps, env), vals); exps = SCM_CDR (exps); @@ -3206,9 +3215,15 @@ dispatch: proc = EVALCAR (x, env); /* proc is the consumer. */ arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); if (SCM_VALUESP (arg1)) - arg1 = scm_struct_ref (arg1, SCM_INUM0); + { + /* The list of arguments is not copied. Rather, it is assumed + * that this has been done by the 'values' procedure. */ + arg1 = scm_struct_ref (arg1, SCM_INUM0); + } else - arg1 = scm_list_1 (arg1); + { + arg1 = scm_list_1 (arg1); + } PREP_APPLY (proc, arg1); goto apply_proc; } @@ -3221,6 +3236,7 @@ dispatch: default: proc = x; goto evapply; + case scm_tc7_vector: case scm_tc7_wvect: #if SCM_HAVE_ARRAYS diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 77cb1e1a1..e2b2843f1 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,5 +1,11 @@ 2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de> + * tests/dynamic-scope.test (exception:missing-expr): Introduced + temporarily until all memoizers use the new way of error + reporting. + +2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de> + * tests/syntax.test (exception:missing/extra-expr, exception:missing/extra-expr-misc): Renamed exception:missing/extra-expr to exception:missing/extra-expr-misc. diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test index 89f43ae6f..a8c56a9f0 100644 --- a/test-suite/tests/dynamic-scope.test +++ b/test-suite/tests/dynamic-scope.test @@ -22,10 +22,12 @@ :use-module (test-suite lib)) -(define exception:duplicate-binding - (cons 'misc-error "^duplicate bindings")) +(define exception:missing-expr + (cons 'syntax-error "Missing expression")) (define exception:bad-binding - (cons 'misc-error "^bad bindings")) + (cons 'syntax-error "Bad binding")) +(define exception:duplicate-binding + (cons 'syntax-error "Duplicate binding")) (define global-a 0) (define (fetch-global-a) global-a) @@ -47,7 +49,7 @@ (interaction-environment))) (pass-if-exception "@bind missing expression" - exception:missing-expression + exception:missing-expr (eval '(@bind ((global-a 1))) (interaction-environment))) |