From c86c440b17cc85d57015b63802d7e10c60c5deaa Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 15 Nov 2003 12:27:54 +0000 Subject: [PATCH] * libguile/eval.c (s_mixed_body_forms): New static identifier. (canonicalize_define, scm_m_define): The check for a bad expression is performed in canonicalize_define now. (try_macro_lookup, expand_user_macros, is_system_macro_p): New static helper functions for m_expand_body. (m_expand_body): Use ASSERT_SYNTAX to signal syntax errors. Only expand user defined macros. Fixed handling of the definition/ expression boundary. Fixed handling of definitions grouped with 'begin. Use canonicalize_define to expand definitions. * test-suite/tests/syntax.test: Tests that check for the correct handling of internal defines with begin work now. --- libguile/ChangeLog | 15 ++ libguile/eval.c | 261 +++++++++++++++++++++++++++-------- test-suite/ChangeLog | 5 + test-suite/tests/syntax.test | 4 +- 4 files changed, 224 insertions(+), 61 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d25655c6b..afc488cb5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2003-11-15 Dirk Herrmann + + * eval.c (s_mixed_body_forms): New static identifier. + + (canonicalize_define, scm_m_define): The check for a bad + expression is performed in canonicalize_define now. + + (try_macro_lookup, expand_user_macros, is_system_macro_p): New + static helper functions for m_expand_body. + + (m_expand_body): Use ASSERT_SYNTAX to signal syntax errors. Only + expand user defined macros. Fixed handling of the definition/ + expression boundary. Fixed handling of definitions grouped with + 'begin. Use canonicalize_define to expand definitions. + 2003-11-13 Marius Vollmer * snarf.h (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK, diff --git a/libguile/eval.c b/libguile/eval.c index 793a28ce2..6b8e336b6 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -115,12 +115,6 @@ static const char s_expression[] = "Missing or extra expression in"; * context, a 'Missing expression' error is signalled. */ static const char s_missing_expression[] = "Missing expression in"; -/* A body may hold an arbitrary number of internal defines, followed by a - * non-empty sequence of expressions. If a body with an empty sequence of - * expressions is detected, a 'Missing body expression' error is signalled. - */ -static const char s_missing_body_expression[] = "Missing body expression in"; - /* If a form is detected that holds more expressions than are allowed in that * context, an 'Extra expression' error is signalled. */ static const char s_extra_expression[] = "Extra expression in"; @@ -132,6 +126,21 @@ static const char s_extra_expression[] = "Extra expression in"; * do so, you need to quote the empty list like (quote ()) or '(). */ static const char s_empty_combination[] = "Illegal empty combination"; +/* A body may hold an arbitrary number of internal defines, followed by a + * non-empty sequence of expressions. If a body with an empty sequence of + * expressions is detected, a 'Missing body expression' error is signalled. + */ +static const char s_missing_body_expression[] = "Missing body expression in"; + +/* A body may hold an arbitrary number of internal defines, followed by a + * non-empty sequence of expressions. Each the definitions and the + * expressions may be grouped arbitraryly with begin, but it is not allowed to + * mix definitions and expressions. If a define form in a body mixes + * definitions and expressions, a 'Mixed definitions and expressions' error is + * signalled. + */ +static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; + /* Case or cond expressions must have at least one clause. If a case or cond * expression without any clauses is detected, a 'Missing clauses' error is * signalled. */ @@ -896,6 +905,7 @@ canonicalize_define (const SCM expr) 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); @@ -931,8 +941,6 @@ scm_m_define (SCM expr, SCM env) SCM cdr_canonical_definition; SCM body; - ASSERT_SYNTAX (scm_ilength (expr) >= 0, s_bad_expression, expr); - canonical_definition = canonicalize_define (expr); cdr_canonical_definition = SCM_CDR (canonical_definition); body = SCM_CDR (cdr_canonical_definition); @@ -1828,65 +1836,200 @@ scm_m_undefine (SCM expr, SCM env) #endif +/* The function m_expand_body memoizes a proper list of expressions forming a + * body. This function takes care of dealing with internal defines and + * transforming them into an equivalent letrec expression. */ + +/* This is a helper function for m_expand_body. It helps to figure out whether + * an expression denotes a syntactic keyword. */ static SCM -m_expand_body (const SCM xorig, const SCM env) +try_macro_lookup (const SCM expr, const SCM env) { - SCM x = SCM_CDR (xorig), defs = SCM_EOL; - - while (SCM_NIMP (x)) + if (SCM_SYMBOLP (expr)) { - SCM form = SCM_CAR (x); - if (!SCM_CONSP (form)) - break; - if (!SCM_SYMBOLP (SCM_CAR (form))) - break; - - form = scm_macroexp (scm_cons_source (form, - SCM_CAR (form), - SCM_CDR (form)), - env); - - if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form))) - { - defs = scm_cons (SCM_CDR (form), defs); - x = SCM_CDR (x); - } - else if (!SCM_IMP (defs)) - { - break; - } - else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form))) - { - x = scm_append (scm_list_2 (SCM_CDR (form), SCM_CDR (x))); - } - else - { - x = scm_cons (form, SCM_CDR (x)); - break; - } - } - - /* FIXME: xorig is already partially memoized and does not hold information - * about the file location. */ - ASSERT_SYNTAX (SCM_CONSP (x), s_missing_body_expression, xorig); - - if (!SCM_NULLP (defs)) - { - SCM rvars, inits, body, letrec; - check_bindings (defs, xorig); - transform_bindings (defs, xorig, &rvars, &inits); - body = m_body (SCM_IM_DEFINE, x); - letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); - SCM_SETCAR (xorig, letrec); - SCM_SETCDR (xorig, SCM_EOL); + const SCM tmp_pair = scm_list_1 (expr); + const SCM value = *scm_lookupcar1 (tmp_pair, env, 0); + return value; } else { - SCM_SETCAR (xorig, SCM_CAR (x)); - SCM_SETCDR (xorig, SCM_CDR (x)); + return SCM_UNDEFINED; + } +} + +/* This is a helper function for m_expand_body. It expands user macros, + * because for the correct translation of a body we need to know whether they + * expand to a definition. */ +static SCM +expand_user_macros (SCM expr, const SCM env) +{ + while (SCM_CONSP (expr)) + { + const SCM car_expr = SCM_CAR (expr); + const SCM new_car = expand_user_macros (car_expr, env); + const SCM value = try_macro_lookup (new_car, env); + + if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2) + { + /* User macros transform code into code. */ + expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env); + /* We need to reiterate on the transformed code. */ + } + else + { + /* No user macro: return. */ + SCM_SETCAR (expr, new_car); + return expr; + } } - return xorig; + return expr; +} + +/* This is a helper function for m_expand_body. It determines if a given form + * represents an application of a given built-in macro. The built-in macro to + * check for is identified by its syntactic keyword. The form is an + * application of the given macro if looking up the car of the form in the + * given environment actually returns the built-in macro. */ +static int +is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env) +{ + if (SCM_CONSP (form)) + { + const SCM car_form = SCM_CAR (form); + const SCM value = try_macro_lookup (car_form, env); + if (SCM_BUILTIN_MACRO_P (value)) + { + const SCM macro_name = scm_macro_name (value); + return SCM_EQ_P (macro_name, syntactic_keyword); + } + } + + return 0; +} + +static SCM +m_expand_body (const SCM forms, const SCM env) +{ + /* The first body form can be skipped since it is known to be the ISYM that + * was prepended to the body by m_body. */ + SCM cdr_forms = SCM_CDR (forms); + SCM form_idx = cdr_forms; + SCM definitions = SCM_EOL; + SCM sequence = SCM_EOL; + + /* According to R5RS, the list of body forms consists of two parts: a number + * (maybe zero) of definitions, followed by a non-empty sequence of + * expressions. Each the definitions and the expressions may be grouped + * arbitrarily with begin, but it is not allowed to mix definitions and + * expressions. The task of the following loop therefore is to split the + * list of body forms into the list of definitions and the sequence of + * expressions. */ + while (!SCM_NULLP (form_idx)) + { + const SCM form = SCM_CAR (form_idx); + const SCM new_form = expand_user_macros (form, env); + if (is_system_macro_p (scm_sym_define, new_form, env)) + { + definitions = scm_cons (new_form, definitions); + form_idx = SCM_CDR (form_idx); + } + else if (is_system_macro_p (scm_sym_begin, new_form, env)) + { + /* We have encountered a group of forms. This has to be either a + * (possibly empty) group of (possibly further grouped) definitions, + * or a non-empty group of (possibly further grouped) + * expressions. */ + const SCM grouped_forms = SCM_CDR (new_form); + unsigned int found_definition = 0; + unsigned int found_expression = 0; + SCM grouped_form_idx = grouped_forms; + while (!found_expression && !SCM_NULLP (grouped_form_idx)) + { + const SCM inner_form = SCM_CAR (grouped_form_idx); + const SCM new_inner_form = expand_user_macros (inner_form, env); + if (is_system_macro_p (scm_sym_define, new_inner_form, env)) + { + found_definition = 1; + definitions = scm_cons (new_inner_form, definitions); + grouped_form_idx = SCM_CDR (grouped_form_idx); + } + else if (is_system_macro_p (scm_sym_begin, new_inner_form, env)) + { + const SCM inner_group = SCM_CDR (new_inner_form); + grouped_form_idx + = scm_append (scm_list_2 (inner_group, + SCM_CDR (grouped_form_idx))); + } + else + { + /* The group marks the start of the expressions of the body. + * We have to make sure that within the same group we have + * not encountered a definition before. */ + ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form); + found_expression = 1; + grouped_form_idx = SCM_EOL; + } + } + + /* We have finished processing the group. If we have not yet + * encountered an expression we continue processing the forms of the + * body to collect further definition forms. Otherwise, the group + * marks the start of the sequence of expressions of the body. */ + if (!found_expression) + { + form_idx = SCM_CDR (form_idx); + } + else + { + sequence = form_idx; + form_idx = SCM_EOL; + } + } + else + { + /* We have detected a form which is no definition. This marks the + * start of the sequence of expressions of the body. */ + sequence = form_idx; + form_idx = SCM_EOL; + } + } + + /* FIXME: forms does not hold information about the file location. */ + ASSERT_SYNTAX (SCM_CONSP (sequence), s_missing_body_expression, cdr_forms); + + if (!SCM_NULLP (definitions)) + { + SCM definition_idx; + SCM letrec_tail; + SCM letrec_expression; + SCM new_letrec_expression; + SCM new_body; + + SCM bindings = SCM_EOL; + for (definition_idx = definitions; + !SCM_NULLP (definition_idx); + definition_idx = SCM_CDR (definition_idx)) + { + const SCM definition = SCM_CAR (definition_idx); + const SCM canonical_definition = canonicalize_define (definition); + const SCM binding = SCM_CDR (canonical_definition); + bindings = scm_cons (binding, bindings); + }; + + letrec_tail = scm_cons (bindings, sequence); + /* FIXME: forms does not hold information about the file location. */ + letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail); + new_letrec_expression = scm_m_letrec (letrec_expression, env); + new_body = scm_list_1 (new_letrec_expression); + return new_body; + } + else + { + SCM_SETCAR (forms, SCM_CAR (sequence)); + SCM_SETCDR (forms, SCM_CDR (sequence)); + return forms; + } } #if (SCM_ENABLE_DEPRECATED == 1) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d254c1b62..63238d5f7 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-11-15 Dirk Herrmann + + * tests/syntax.test: Tests that check for the correct handling of + internal defines with begin work now. + 2003-11-15 Dirk Herrmann * tests/syntax.test: Fixed test that checks for the correct diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index d6ce13deb..e7a6458fb 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -619,7 +619,7 @@ (eq? 'c (a 2) (a 5)))) (interaction-environment))) - (expect-fail "internal defines with begin" + (pass-if "internal defines with begin" (false-if-exception (eval '(let ((a identity) (b identity) (c identity)) (define (a x) (if (= x 0) 'a (b (- x 1)))) @@ -631,7 +631,7 @@ (eq? 'c (a 2) (a 5)))) (interaction-environment)))) - (expect-fail "internal defines with empty begin" + (pass-if "internal defines with empty begin" (false-if-exception (eval '(let ((a identity) (b identity) (c identity)) (define (a x) (if (= x 0) 'a (b (- x 1))))