summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2003-10-18 17:24:09 +0000
committerDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2003-10-18 17:24:09 +0000
commit82b3e2c612f1d3ec45ce596d064512848e6b23e3 (patch)
treedb9c1132e3b15953529fa7010b2844a55fcbe6c8
parent216286857be77676b068f36ed96ea686de03a89e (diff)
downloadguile-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/ChangeLog14
-rw-r--r--libguile/eval.c128
-rw-r--r--test-suite/ChangeLog6
-rw-r--r--test-suite/tests/dynamic-scope.test10
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)))