From 5280aacabcc96b4178a8c0b02226fa5665324339 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 15:10:37 +0000 Subject: [PATCH] * eval.h (SCM_EVALIM2): New macro. Use it when a immediate, literal constant should be evaluated. * eval.c (scm_s_duplicate_formals): New error message string. (scm_c_improper_memq): New function. (scm_m_lambda): Check for duplicate arguments. (scm_ceval, scm_deval): When executing a body: only cons a new toplevel environment frame when it is different from the existing one; use EVALCAR instead of SIDEVAL so that we can properly check for empty combinations; use SCM_EVALIM2 for the same reason in the non-toplevel loop. (nontoplevel_cdrxnoap, nontoplevel_cdrxbegin, nontoplevel_begin): New labels with the meaning of their non-"nontoplevel" partners, but they are used when it is known that the body is not evaluated at top-level. (scm_apply, scm_dapply): use SCM_EVALIM2 to get proper error reporting for empty combinations. --- libguile/eval.c | 89 ++++++++++++++++++++++++++++++++++--------------- libguile/eval.h | 15 ++++++--- 2 files changed, 73 insertions(+), 31 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index bc9491d6b..549d7b474 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -448,6 +448,7 @@ const char scm_s_bindings[] = "bad bindings"; const char scm_s_variable[] = "bad variable"; const char scm_s_clauses[] = "bad or missing clauses"; const char scm_s_formals[] = "bad formals"; +const char scm_s_duplicate_formals[] = "duplicate formals"; SCM_GLOBAL_SYMBOL (scm_sym_dot, "."); SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); @@ -635,6 +636,21 @@ scm_m_cond (SCM xorig, SCM env) SCM_SYNTAX(s_lambda, "lambda", scm_makmmacro, scm_m_lambda); SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda); +/* Return #t if OBJ is `eq?' to one of the elements of LIST or to the + cdr of the last cons. (Thus, LIST is not required to be a proper + list and when OBJ also found in the improper ending.) */ + +static int +scm_c_improper_memq (SCM obj, SCM list) +{ + for (; SCM_CONSP (list); list = SCM_CDR (list)) + { + if (SCM_EQ_P (SCM_CAR (list), obj)) + return SCM_BOOL_T; + } + return SCM_EQ_P (list, obj); +} + SCM scm_m_lambda (SCM xorig, SCM env) { @@ -663,6 +679,8 @@ scm_m_lambda (SCM xorig, SCM env) } if (!SCM_SYMBOLP (SCM_CAR (proc))) goto badforms; + else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc))) + scm_wta (xorig, scm_s_duplicate_formals, s_lambda); proc = SCM_CDR (proc); } if (SCM_NNULLP (proc)) @@ -1911,34 +1929,49 @@ dispatch: if (SCM_CONSP(env) && !SCM_CONSP(SCM_CAR(env))) { t.arg1 = x; + { + SCM p = scm_current_module_lookup_closure (); + if (p != SCM_CAR(env)) + env = scm_top_level_env (p); + } while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { - env = scm_top_level_env (scm_current_module_lookup_closure ()); - SIDEVAL (SCM_CAR(x), env); + EVALCAR (x, env); x = t.arg1; + { + SCM p = scm_current_module_lookup_closure (); + if (p != SCM_CAR(env)) + env = scm_top_level_env (p); + } } - /* once more, for the last form */ - env = scm_top_level_env (scm_current_module_lookup_closure ()); + goto carloop; } else + goto nontoplevel_begin; + + nontoplevel_cdrxnoap: + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + nontoplevel_cdrxbegin: + x = SCM_CDR (x); + nontoplevel_begin: + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { - t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + if (SCM_IMP (SCM_CAR (x))) { - if (SCM_IMP (SCM_CAR (x))) + if (SCM_ISYMP (SCM_CAR (x))) { - if (SCM_ISYMP (SCM_CAR (x))) - { - x = scm_m_expand_body (x, env); - goto begin; - } + x = scm_m_expand_body (x, env); + goto nontoplevel_begin; } else - SCM_CEVAL (SCM_CAR (x), env); - x = t.arg1; + SCM_EVALIM2 (SCM_CAR(x)); } + else + SCM_CEVAL (SCM_CAR (x), env); + x = t.arg1; } - + carloop: /* scm_eval car of last form in list */ if (SCM_NCELLP (SCM_CAR (x))) { @@ -2041,7 +2074,7 @@ dispatch: if (SCM_NULLP (x)) RETURN (SCM_UNSPECIFIED); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; + goto nontoplevel_begin; case SCM_BIT8(SCM_IM_IF): @@ -2067,7 +2100,7 @@ dispatch: while (SCM_NIMP (proc = SCM_CDR (proc))); env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); x = SCM_CDR (x); - goto cdrxnoap; + goto nontoplevel_cdrxnoap; case SCM_BIT8(SCM_IM_LETREC): @@ -2082,7 +2115,7 @@ dispatch: } while (SCM_NIMP (proc = SCM_CDR (proc))); SCM_SETCDR (SCM_CAR (env), t.arg1); - goto cdrxnoap; + goto nontoplevel_cdrxnoap; case SCM_BIT8(SCM_IM_LETSTAR): @@ -2091,7 +2124,7 @@ dispatch: if (SCM_IMP (proc)) { env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); - goto cdrxnoap; + goto nontoplevel_cdrxnoap; } do { @@ -2100,7 +2133,7 @@ dispatch: env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env); } while (SCM_NIMP (proc = SCM_CDR (proc))); - goto cdrxnoap; + goto nontoplevel_cdrxnoap; case SCM_BIT8(SCM_IM_OR): x = SCM_CDR (x); @@ -2197,7 +2230,7 @@ dispatch: env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc)); x = SCM_CODE (proc); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; } proc = scm_f_apply; goto evapply; @@ -2310,7 +2343,7 @@ dispatch: arg2, SCM_CMETHOD_ENV (z)); x = SCM_CMETHOD_CODE (z); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; next_method: i = (i + 1) & mask; } while (i != end); @@ -2631,7 +2664,7 @@ evapply: case scm_tcs_closures: x = SCM_CODE (proc); env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc)); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { @@ -2786,7 +2819,7 @@ evapply: #else env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif - goto cdrxbegin; + goto nontoplevel_cdrxbegin; case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { @@ -2953,7 +2986,7 @@ evapply: scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc)); #endif x = SCM_CODE (proc); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; } } #ifdef SCM_CAUTIOUS @@ -3031,7 +3064,7 @@ evapply: debug.info->a.args, SCM_ENV (proc)); x = SCM_CODE (proc); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; #else /* DEVAL */ case scm_tc7_subr_3: SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); @@ -3103,7 +3136,7 @@ evapply: scm_eval_args (x, env, proc)), SCM_ENV (proc)); x = SCM_CODE (proc); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; #endif /* DEVAL */ case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) @@ -3443,6 +3476,8 @@ tail: proc = scm_m_expand_body (proc, args); goto again; } + else + SCM_EVALIM2 (SCM_CAR (proc)); } else SCM_CEVAL (SCM_CAR (proc), args); diff --git a/libguile/eval.h b/libguile/eval.h index 880cd5d5b..450a7f754 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -97,14 +97,19 @@ extern SCM scm_eval_options_interface (SCM setting); * * For an explanation of symbols containing "EVAL", see beginning of eval.c. */ +#define SCM_EVALIM2(x) (((x) == SCM_EOL) \ + ? scm_wta ((x), scm_s_expression, NULL) \ + : (x)) #ifdef MEMOIZE_LOCALS -#define SCM_EVALIM(x, env) (SCM_ILOCP (x) ? *scm_ilookup ((x), env) : x) +#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \ + ? *scm_ilookup ((x), env) \ + : SCM_EVALIM2(x)) #else -#define SCM_EVALIM(x, env) x +#define SCM_EVALIM(x, env) SCM_EVALIM2(x) #endif #ifdef DEBUG_EXTENSIONS #define SCM_XEVAL(x, env) (SCM_IMP (x) \ - ? (x) \ + ? SCM_EVALIM2(x) \ : (*scm_ceval_ptr) ((x), (env))) #define SCM_XEVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \ ? (SCM_IMP (SCM_CAR (x)) \ @@ -114,7 +119,9 @@ extern SCM scm_eval_options_interface (SCM setting); ? *scm_lookupcar (x, env, 1) \ : (*scm_ceval_ptr) (SCM_CAR (x), env))) #else -#define SCM_XEVAL(x, env) (SCM_IMP (x) ? (x) : scm_ceval ((x), (env))) +#define SCM_XEVAL(x, env) (SCM_IMP (x) \ + ? SCM_EVALIM2(x) \ + : scm_ceval ((x), (env))) #define SCM_XEVALCAR(x, env) EVALCAR (x, env) #endif /* DEBUG_EXTENSIONS */