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)))))