From cc56ba80627e7e4061ce4d54045d62af7c85eda4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 11 Oct 2003 16:03:29 +0000 Subject: [PATCH] * libguile/eval.c (s_missing_expression, s_bad_variable): New static identifiers. (scm_m_define): Use ASSERT_SYNTAX to signal syntax errors. Prefer R5RS terminology for the naming of variables. Be more specific about the kind of error that was detected. Make sure file name, line number etc. are added to all freshly created expressions. Avoid unnecessary consing when creating the memoized code. * test-suite/tests/syntax.test (exception:missing-expr, exception:extra-expr): New. Adapted tests for 'begin' to the new way of error reporting. --- libguile/ChangeLog | 11 +++++++ libguile/eval.c | 64 +++++++++++++++++++++++++----------- test-suite/ChangeLog | 8 +++++ test-suite/tests/syntax.test | 14 ++++++-- 4 files changed, 75 insertions(+), 22 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 91e68a5ec..c9a32cb1f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-10-11 Dirk Herrmann + + * eval.c (s_missing_expression, s_bad_variable): New static + identifiers. + + (scm_m_define): Use ASSERT_SYNTAX to signal syntax errors. Prefer + R5RS terminology for the naming of variables. Be more specific + about the kind of error that was detected. Make sure file name, + line number etc. are added to all freshly created expressions. + Avoid unnecessary consing when creating the memoized code. + 2003-10-11 Dirk Herrmann * eval.c (s_extra_expression, s_misplaced_else_clause, diff --git a/libguile/eval.c b/libguile/eval.c index 38135b2c0..79dfc341f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -100,6 +100,10 @@ char *alloca (); * expression is expected, a 'Bad expression' error is signalled. */ static const char s_bad_expression[] = "Bad expression"; +/* If a form is detected that holds less expressions than are required in that + * contect, a 'Missing expression' error is signalled. */ +static const char s_missing_expression[] = "Missing expression in"; + /* If a form is detected that holds more expressions than are allowed in that * contect, an 'Extra expression' error is signalled. */ static const char s_extra_expression[] = "Extra expression in"; @@ -143,6 +147,10 @@ static const char s_bad_cond_clause[] = "Bad cond clause"; * error is signalled. */ static const char s_missing_recipient[] = "Missing recipient in"; +/* If in a position where a variable name is required some other object is + * detected, a 'Bad variable' error is signalled. */ +static const char s_bad_variable[] = "Bad variable"; + /* Signal a syntax error. We distinguish between the form that caused the * error and the enclosing expression. The error message will print out as @@ -868,42 +876,60 @@ SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS * module that does not implement this extension. */ SCM -scm_m_define (SCM x, SCM env) +scm_m_define (SCM expr, SCM env) { - SCM name; - x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (x) >= 2, s_expression, s_define); - name = SCM_CAR (x); - x = SCM_CDR (x); - while (SCM_CONSP (name)) + SCM body; + 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_missing_expression, expr); + + body = SCM_CDR (cdr_expr); + variable = SCM_CAR (cdr_expr); + while (SCM_CONSP (variable)) { - /* This while loop realizes function currying by variable nesting. */ - SCM formals = SCM_CDR (name); - x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x)); - name = SCM_CAR (name); + /* This while loop realizes function currying by variable nesting. + * Variable is known to be a nested-variable. In every iteration of the + * loop another level of lambda expression is created, starting with the + * innermost one. */ + const SCM formals = SCM_CDR (variable); + const SCM tail = scm_cons (formals, body); + + /* Add source properties to each new lambda expression: */ + const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail); + + body = scm_list_1 (lambda); + variable = SCM_CAR (variable); } - SCM_ASSYNT (SCM_SYMBOLP (name), s_variable, s_define); - SCM_ASSYNT (scm_ilength (x) == 1, s_expression, s_define); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); + if (SCM_TOP_LEVEL (env)) { SCM var; - x = scm_eval_car (x, env); + const SCM value = scm_eval_car (body, env); if (SCM_REC_PROCNAMES_P) { - SCM tmp = x; + SCM tmp = value; while (SCM_MACROP (tmp)) tmp = SCM_MACRO_CODE (tmp); if (SCM_CLOSUREP (tmp) /* Only the first definition determines the name. */ && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) - scm_set_procedure_property_x (tmp, scm_sym_name, name); + scm_set_procedure_property_x (tmp, scm_sym_name, variable); } - var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T); - SCM_VARIABLE_SET (var, x); + var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); return SCM_UNSPECIFIED; } else - return scm_cons2 (SCM_IM_DEFINE, name, x); + { + SCM_SETCAR (expr, SCM_IM_DEFINE); + SCM_SETCAR (cdr_expr, variable); + SCM_SETCDR (cdr_expr, body); + return expr; + } } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5faba54cd..f5b0bc24e 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2003-10-11 Dirk Herrmann + + * tests/syntax.test (exception:missing-expr, + exception:extra-expr): New. + + Adapted tests for 'begin' to the new way of error + reporting. + 2003-10-11 Dirk Herrmann * tests/syntax.test (exception:misplaced-else-clause, diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 048c6d8ef..2c6524744 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -23,6 +23,14 @@ (define exception:bad-expression (cons 'syntax-error "Bad expression")) + +(define exception:missing/extra-expr + (cons 'misc-error "^missing or extra expression")) +(define exception:missing-expr + (cons 'syntax-error "Missing expression")) +(define exception:extra-expr + (cons 'syntax-error "Extra expression")) + (define exception:bad-bindings (cons 'misc-error "^bad bindings")) (define exception:duplicate-bindings @@ -33,6 +41,7 @@ (cons 'misc-error "^bad formals")) (define exception:duplicate-formals (cons 'misc-error "^duplicate formals")) + (define exception:missing-clauses (cons 'syntax-error "Missing clauses")) (define exception:misplaced-else-clause @@ -43,10 +52,9 @@ (cons 'syntax-error "Bad case labels")) (define exception:bad-cond-clause (cons 'syntax-error "Bad cond clause")) + (define exception:bad-var (cons 'misc-error "^bad variable")) -(define exception:missing/extra-expr - (cons 'misc-error "^missing or extra expression")) (with-test-prefix "expressions" @@ -590,7 +598,7 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(define)" - exception:missing/extra-expr + exception:missing-expr (eval '(define) (interaction-environment))))) -- 2.20.1