diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ef4405ed8..8cf3adeac 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,24 @@ +2004-04-22 Dirk Herrmann + + * eval.c (s_macro_keyword): New static identifier. + + (scm_m_define): Change order to first create binding and + evaluating the expression afterwards. + + (scm_m_set_x): Memoize complete set! expression. Only leave + symbols if no binding exists at memoization time. Throw error if + assigning to a syntactic keyword. + + (lazy_memoize_variable): New function. + + (CEVAL): When execution set!, perform lazy memoization if + unmemoized symbol is detected. + + * modules.c (module_variable): Return variables with unbound + value. + + * tags.h: Fix comment. + 2004-04-25 Kevin Ryde * chars.c (scm_char_upcase, scm_char_downcase, scm_c_upcase, @@ -245,7 +266,6 @@ (copy_tree): Corrected typo in comment. ->>>>>>> 1.2042 2004-03-28 Han-Wen Nienhuys * eval.c (s_scm_copy_tree): idem. diff --git a/libguile/eval.c b/libguile/eval.c index 7f34b74e8..83d2e5bcc 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -144,6 +144,10 @@ static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; * is signalled. */ static const char s_bad_define[] = "Bad define placement"; +/* If a macro keyword is detected in a place where macro keywords are not + * allowed, a 'Misplaced syntactic keyword' error is signalled. */ +static const char s_macro_keyword[] = "Misplaced syntactic keyword"; + /* 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. */ @@ -1194,6 +1198,10 @@ canonicalize_define (const SCM expr) return expr; } +/* According to section 5.2.1 of R5RS we first have to make sure that the + * variable is bound, and then perform the (set! variable expression) + * operation. This means, that within the expression we may already assign + * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */ SCM scm_m_define (SCM expr, SCM env) { @@ -1203,10 +1211,10 @@ scm_m_define (SCM expr, SCM env) const SCM canonical_definition = canonicalize_define (expr); const SCM cdr_canonical_definition = SCM_CDR (canonical_definition); const SCM variable = SCM_CAR (cdr_canonical_definition); - const SCM body = SCM_CDR (cdr_canonical_definition); - const SCM value = scm_eval_car (body, env); + const SCM location + = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); + const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env); - SCM var; if (SCM_REC_PROCNAMES_P) { SCM tmp = value; @@ -1218,8 +1226,7 @@ scm_m_define (SCM expr, SCM env) scm_set_procedure_property_x (tmp, scm_sym_name, variable); } - var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); - SCM_VARIABLE_SET (var, value); + SCM_VARIABLE_SET (location, value); return SCM_UNSPECIFIED; } @@ -1779,15 +1786,23 @@ SCM scm_m_set_x (SCM expr, SCM env SCM_UNUSED) { SCM variable; + SCM new_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_expression, expr); variable = SCM_CAR (cdr_expr); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable) || SCM_VARIABLEP (variable), - s_bad_variable, variable, expr); + + /* Memoize the variable form. */ + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + new_variable = lookup_symbol (variable, env); + ASSERT_SYNTAX (!SCM_MACROP (new_variable), s_macro_keyword, variable); + /* Leave the memoization of unbound symbols to lazy memoization: */ + if (SCM_UNBNDP (new_variable)) + new_variable = variable; SCM_SETCAR (expr, SCM_IM_SET_X); + SCM_SETCAR (cdr_expr, new_variable); return expr; } @@ -2612,6 +2627,22 @@ static SCM deval (SCM x, SCM env); SCM_REC_MUTEX (source_mutex); +/* During execution, look up a symbol in the top level of the given local + * environment and return the corresponding variable object. If no binding + * for the symbol can be found, an 'Unbound variable' error is signalled. */ +static SCM +lazy_memoize_variable (const SCM symbol, const SCM environment) +{ + const SCM top_level = scm_env_top_level (environment); + const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F); + + if (SCM_FALSEP (variable)) + error_unbound_variable (symbol); + else + return variable; +} + + SCM scm_eval_car (SCM pair, SCM env) { @@ -3327,8 +3358,13 @@ dispatch: location = scm_ilookup (variable, env); else if (SCM_VARIABLEP (variable)) location = SCM_VARIABLE_LOC (variable); - else /* (SCM_SYMBOLP (variable)) is known to be true */ - location = scm_lookupcar (x, env, 1); + else + { + /* (SCM_SYMBOLP (variable)) is known to be true */ + variable = lazy_memoize_variable (variable, env); + SCM_SETCAR (x, variable); + location = SCM_VARIABLE_LOC (variable); + } x = SCM_CDR (x); *location = EVALCAR (x, env); } diff --git a/libguile/modules.c b/libguile/modules.c index 7d578dcd6..951ee413e 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -277,7 +277,7 @@ static SCM module_variable (SCM module, SCM sym) { #define SCM_BOUND_THING_P(b) \ - (SCM_VARIABLEP (b) && !SCM_UNBNDP (SCM_VARIABLE_REF (b))) + (!SCM_FALSEP (b)) /* 1. Check module obarray */ SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); diff --git a/libguile/tags.h b/libguile/tags.h index 21fcc8167..9b06cdc63 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -325,8 +325,8 @@ typedef unsigned long scm_t_bits; * tc8 (for objects with tc3==100): * 00000-100: special objects ('flags') * 00001-100: characters - * 00010-100: evaluator byte codes ('ilocs') - * 00011-100: evaluator byte codes ('isyms') + * 00010-100: evaluator byte codes ('isyms') + * 00011-100: evaluator byte codes ('ilocs') * * * Summary of type codes on the heap diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 9973168d0..0053f9dde 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-04-26 Dirk Herrmann + + * tests/syntax.test: Add test case to check the correct handling + of define expressions. + 2004-04-25 Kevin Ryde * tests/socket.test: New file, exercising inet-ntop. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 36a3c1660..668ea429d 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -592,6 +592,16 @@ (with-test-prefix "top-level define" + (pass-if "binding is created before expression is evaluated" + (= (eval '(begin + (define foo + (begin + (set! foo 1) + (+ foo 1))) + foo) + (interaction-environment)) + 2)) + (with-test-prefix "currying" (pass-if "(define ((foo)) #f)"