From da48db629c4f554518af65bf7b47a316e8c9f85f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 18 Oct 2003 18:26:43 +0000 Subject: [PATCH] * libguile/eval.c (scm_m_cont, scm_m_at_call_with_values, scm_m_generalized_set_x): Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. (scm_m_generalized_set_x): Let scm_m_set_x handle the R5RS standard case. Make sure line and file information are copied to every created expression. * test-suite/tests/syntax.test (exception:bad-var): Removed. Adapted tests for 'set!' to the new way of error reporting. --- libguile/ChangeLog | 17 +++++++++-- libguile/eval.c | 58 +++++++++++++++++++++++++----------- test-suite/ChangeLog | 6 ++++ test-suite/tests/syntax.test | 19 +++++------- 4 files changed, 68 insertions(+), 32 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 07d41ee2e..0e1723db4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-10-18 Dirk Herrmann + + * eval.c (scm_m_cont, scm_m_at_call_with_values, + scm_m_generalized_set_x): Use ASSERT_SYNTAX to signal syntax + errors. Avoid unnecessary consing when creating the memoized + code. + + (scm_m_generalized_set_x): Let scm_m_set_x handle the R5RS + standard case. Make sure line and file information are copied to + every created expression. + 2003-10-18 Dirk Herrmann * eval.c (scm_m_set_x, scm_m_apply, scm_m_atbind): Use @@ -55,7 +66,7 @@ specific about the kind of error that was detected. Prepare for easier integration of changes for separated memoization. -2003-10-11 Dirk Herrmann +2003-10-12 Dirk Herrmann * eval.c (s_duplicate_binding): New static identifier. @@ -77,7 +88,7 @@ (SCM_CEVAL): Simplified handling of SCM_IM_IF forms. -2003-10-11 Dirk Herrmann +2003-10-12 Dirk Herrmann * eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New static identifiers. @@ -88,7 +99,7 @@ code, this way also making sure that file name, line number information etc. remain available. -2003-10-11 Dirk Herrmann +2003-10-12 Dirk Herrmann * eval.c (memoize_as_thunk_prototype): New static function. diff --git a/libguile/eval.c b/libguile/eval.c index b700e9e8b..1cfd88efe 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1579,13 +1579,15 @@ scm_m_atbind (SCM expr, SCM env) SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont); SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc); - SCM -scm_m_cont (SCM xorig, SCM env SCM_UNUSED) +scm_m_cont (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - s_expression, s_atcall_cc); - return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + + SCM_SETCAR (expr, SCM_IM_CONT); + return expr; } @@ -1593,11 +1595,14 @@ SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_ SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); SCM -scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED) +scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, - s_expression, s_at_call_with_values); - return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig)); + 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); + + SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES); + return expr; } @@ -1622,17 +1627,34 @@ SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x); SCM_SYMBOL (scm_sym_setter, "setter"); SCM -scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED) +scm_m_generalized_set_x (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (2 == scm_ilength (x), s_expression, s_set_x); - if (SCM_SYMBOLP (SCM_CAR (x))) - return scm_cons (SCM_IM_SET_X, x); - else if (SCM_CONSP (SCM_CAR (x))) - return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)), - scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x)))); + SCM target; + + 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); + + target = SCM_CAR (cdr_expr); + if (!SCM_CONSP (target)) + { + /* R5RS usage */ + return scm_m_set_x (expr, env); + } else - scm_misc_error (s_set_x, s_variable, SCM_EOL); + { + /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */ + + const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target)); + const SCM setter_proc = scm_cons_source (expr, scm_sym_setter, setter_proc_tail); + + const SCM cddr_expr = SCM_CDR (cdr_expr); + const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target), cddr_expr)); + + SCM_SETCAR (expr, setter_proc); + SCM_SETCDR (expr, setter_args); + return expr; + } } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e2b2843f1..a42891980 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2003-10-18 Dirk Herrmann + + * tests/syntax.test (exception:bad-var): Removed. + + Adapted tests for 'set!' to the new way of error reporting. + 2003-10-18 Dirk Herrmann * tests/dynamic-scope.test (exception:missing-expr): Introduced diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 38e85c9fb..82ff4d980 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -59,9 +59,6 @@ (define exception:bad-cond-clause (cons 'syntax-error "Bad cond clause")) -(define exception:bad-var - (cons 'misc-error "^bad variable")) - (with-test-prefix "expressions" @@ -611,44 +608,44 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(set!)" - exception:missing/extra-expr-misc + exception:missing/extra-expr (eval '(set!) (interaction-environment))) (pass-if-exception "(set! 1)" - exception:missing/extra-expr-misc + exception:missing/extra-expr (eval '(set! 1) (interaction-environment))) (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr-misc + exception:missing/extra-expr (eval '(set! 1 2 3) (interaction-environment)))) (with-test-prefix "bad variable" (pass-if-exception "(set! \"\" #t)" - exception:bad-var + exception:bad-variable (eval '(set! "" #t) (interaction-environment))) (pass-if-exception "(set! 1 #t)" - exception:bad-var + exception:bad-variable (eval '(set! 1 #t) (interaction-environment))) (pass-if-exception "(set! #t #f)" - exception:bad-var + exception:bad-variable (eval '(set! #t #f) (interaction-environment))) (pass-if-exception "(set! #f #t)" - exception:bad-var + exception:bad-variable (eval '(set! #f #t) (interaction-environment))) (pass-if-exception "(set! #\space #f)" - exception:bad-var + exception:bad-variable (eval '(set! #\space #f) (interaction-environment))))) -- 2.20.1