mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
* 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.
This commit is contained in:
parent
c3d948015a
commit
c86c440b17
4 changed files with 224 additions and 61 deletions
|
@ -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>
|
||||
|
||||
* snarf.h (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK,
|
||||
|
|
261
libguile/eval.c
261
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)
|
||||
|
|
|
@ -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>
|
||||
|
||||
* tests/syntax.test: Fixed test that checks for the correct
|
||||
|
|
|
@ -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))))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue