mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
Code Activity

* libguile/eval.c (s_mixed_body_forms): New static identifier.

Browse source 
(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.
This commit is contained in:
Dirk Herrmann 2003-11-15 12:27:54 +00:00
parent c3d948015a
commit c86c440b17
4 changed files with 224 additions and 61 deletions
Download patch file Download diff file Expand all files Collapse all files

15
libguile/ChangeLog
View file

@ -1,3 +1,18 @@
2003-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
* 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 <mvo@zagadka.de> 2003-11-13 Marius Vollmer <mvo@zagadka.de>
* snarf.h (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK, * snarf.h (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK,

249
libguile/eval.c
View file

@ -115,12 +115,6 @@ static const char s_expression[] = "Missing or extra expression in";
* context, a 'Missing expression' error is signalled. */ * context, a 'Missing expression' error is signalled. */
static const char s_missing_expression[] = "Missing expression in"; 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 /* If a form is detected that holds more expressions than are allowed in that
* context, an 'Extra expression' error is signalled. */ * context, an 'Extra expression' error is signalled. */
static const char s_extra_expression[] = "Extra expression in"; 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 '(). */ * do so, you need to quote the empty list like (quote ()) or '(). */
static const char s_empty_combination[] = "Illegal empty combination"; 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 /* 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 * expression without any clauses is detected, a 'Missing clauses' error is
* signalled. */ * signalled. */
@ -896,6 +905,7 @@ canonicalize_define (const SCM expr)
SCM variable; SCM variable;
const SCM cdr_expr = SCM_CDR (expr); 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); ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
body = SCM_CDR (cdr_expr); body = SCM_CDR (cdr_expr);
@ -931,8 +941,6 @@ scm_m_define (SCM expr, SCM env)
SCM cdr_canonical_definition; SCM cdr_canonical_definition;
SCM body; SCM body;
ASSERT_SYNTAX (scm_ilength (expr) >= 0, s_bad_expression, expr);
canonical_definition = canonicalize_define (expr); canonical_definition = canonicalize_define (expr);
cdr_canonical_definition = SCM_CDR (canonical_definition); cdr_canonical_definition = SCM_CDR (canonical_definition);
body = SCM_CDR (cdr_canonical_definition); body = SCM_CDR (cdr_canonical_definition);
@ -1828,65 +1836,200 @@ scm_m_undefine (SCM expr, SCM env)
#endif #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 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; if (SCM_SYMBOLP (expr))
while (SCM_NIMP (x))
{ {
SCM form = SCM_CAR (x); const SCM tmp_pair = scm_list_1 (expr);
if (!SCM_CONSP (form)) const SCM value = *scm_lookupcar1 (tmp_pair, env, 0);
break; return value;
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 else
{ {
x = scm_cons (form, SCM_CDR (x)); return SCM_UNDEFINED;
break;
}
} }
}
/* FIXME: xorig is already partially memoized and does not hold information /* This is a helper function for m_expand_body. It expands user macros,
* about the file location. */ * because for the correct translation of a body we need to know whether they
ASSERT_SYNTAX (SCM_CONSP (x), s_missing_body_expression, xorig); * expand to a definition. */
static SCM
if (!SCM_NULLP (defs)) expand_user_macros (SCM expr, const SCM env)
{
while (SCM_CONSP (expr))
{ {
SCM rvars, inits, body, letrec; const SCM car_expr = SCM_CAR (expr);
check_bindings (defs, xorig); const SCM new_car = expand_user_macros (car_expr, env);
transform_bindings (defs, xorig, &rvars, &inits); const SCM value = try_macro_lookup (new_car, env);
body = m_body (SCM_IM_DEFINE, x);
letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2)
SCM_SETCAR (xorig, letrec); {
SCM_SETCDR (xorig, SCM_EOL); /* 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 else
{ {
SCM_SETCAR (xorig, SCM_CAR (x)); /* No user macro: return. */
SCM_SETCDR (xorig, SCM_CDR (x)); 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) #if (SCM_ENABLE_DEPRECATED == 1)

5
test-suite/ChangeLog
View file

@ -1,3 +1,8 @@
2003-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
* tests/syntax.test: Tests that check for the correct handling of
internal defines with begin work now.
2003-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de> 2003-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
* tests/syntax.test: Fixed test that checks for the correct * tests/syntax.test: Fixed test that checks for the correct

4
test-suite/tests/syntax.test
View file

@ -619,7 +619,7 @@
(eq? 'c (a 2) (a 5)))) (eq? 'c (a 2) (a 5))))
(interaction-environment))) (interaction-environment)))
(expect-fail "internal defines with begin" (pass-if "internal defines with begin"
(false-if-exception (false-if-exception
(eval '(let ((a identity) (b identity) (c identity)) (eval '(let ((a identity) (b identity) (c identity))
(define (a x) (if (= x 0) 'a (b (- x 1)))) (define (a x) (if (= x 0) 'a (b (- x 1))))
@ -631,7 +631,7 @@
(eq? 'c (a 2) (a 5)))) (eq? 'c (a 2) (a 5))))
(interaction-environment)))) (interaction-environment))))
(expect-fail "internal defines with empty begin" (pass-if "internal defines with empty begin"
(false-if-exception (false-if-exception
(eval '(let ((a identity) (b identity) (c identity)) (eval '(let ((a identity) (b identity) (c identity))
(define (a x) (if (= x 0) 'a (b (- x 1)))) (define (a x) (if (= x 0) 'a (b (- x 1))))