-/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
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, "=>");
proc = SCM_CAR (x);
SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case);
SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0
- || SCM_EQ_P (scm_sym_else, SCM_CAR (proc)),
+ || (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))
+ && SCM_NULLP (SCM_CDR (x))),
xorig, scm_s_clauses, s_case);
}
return scm_cons (SCM_IM_CASE, cdrx);
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)
{
}
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))
SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
(SCM setting),
- "")
+ "Option interface for the evaluation options. Instead of using\n"
+ "this procedure directly, use the procedures @code{eval-enable},\n"
+ "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
#define FUNC_NAME s_scm_eval_options_interface
{
SCM ans;
SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
(SCM setting),
- "")
+ "Option interface for the evaluator trap options.")
#define FUNC_NAME s_scm_evaluator_traps
{
SCM ans;
x = SCM_CDR (x);
begin:
+ /* If we are on toplevel with a lookup closure, we need to sync
+ with the current module. */
+ 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)))
+ {
+ EVALCAR (x, env);
+ x = t.arg1;
+ {
+ SCM p = scm_current_module_lookup_closure ();
+ if (p != SCM_CAR(env))
+ env = scm_top_level_env (p);
+ }
+ }
+ 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)))
{
if (SCM_ISYMP (SCM_CAR (x)))
{
x = scm_m_expand_body (x, env);
- goto begin;
+ goto nontoplevel_begin;
}
+ else
+ 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)))
{
SCM_ASRTGO (SCM_NIMP (proc), badfun);
PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
ENTER_APPLY;
+ if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
+ goto umwrongnumargs;
goto evap1;
}
}
if (SCM_NULLP (x))
RETURN (SCM_UNSPECIFIED);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
+ goto nontoplevel_begin;
case SCM_BIT8(SCM_IM_IF):
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):
}
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):
if (SCM_IMP (proc))
{
env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- goto cdrxnoap;
+ goto nontoplevel_cdrxnoap;
}
do
{
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);
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;
SCM_ASRTGO (SCM_NIMP (proc), badfun);
PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
ENTER_APPLY;
+ if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
+ goto umwrongnumargs;
goto evap1;
case (SCM_ISYMNUM (SCM_IM_DELAY)):
arg2,
SCM_CMETHOD_ENV (z));
x = SCM_CMETHOD_CODE (z);
- goto cdrxbegin;
+ goto nontoplevel_cdrxbegin;
next_method:
i = (i + 1) & mask;
} while (i != end);
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)
{
#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)
{
scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
x = SCM_CODE (proc);
- goto cdrxbegin;
+ goto nontoplevel_cdrxbegin;
}
}
#ifdef SCM_CAUTIOUS
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);
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)
they're referring to, send me a patch to this comment. */
SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
- (SCM lst),
- "")
+ (SCM lst),
+ "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
+ "conses the @var{arg1} @dots{} arguments onto the front of\n"
+ "@var{args}, and returns the resulting list. Note that\n"
+ "@var{args} is a list; thus, the argument to this function is\n"
+ "a list whose last element is a list.\n"
+ "Note: Rather than do new consing, @code{apply:nconc2last}\n"
+ "destroys its argument, so use with care.")
#define FUNC_NAME s_scm_nconc2last
{
SCM *lloc;
SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs);
RETURN (SCM_SUBRF (proc) ())
case scm_tc7_subr_1:
+ SCM_ASRTGO (!SCM_UNBNDP (arg1), wrongnumargs);
case scm_tc7_subr_1o:
SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
RETURN (SCM_SUBRF (proc) (arg1))
RETURN (arg1)
}
case scm_tc7_subr_3:
+ SCM_ASRTGO (SCM_NNULLP (args)
+ && SCM_NNULLP (SCM_CDR (args))
+ && SCM_NULLP (SCM_CDDR (args)),
+ wrongnumargs);
RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
case scm_tc7_lsubr:
#ifdef DEVAL
proc = scm_m_expand_body (proc, args);
goto again;
}
+ else
+ SCM_EVALIM2 (SCM_CAR (proc));
}
else
SCM_CEVAL (SCM_CAR (proc), args);
if (SCM_VECTORP (obj))
{
scm_sizet i = SCM_VECTOR_LENGTH (obj);
- ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
+ ans = scm_c_make_vector (i, SCM_UNSPECIFIED);
while (i--)
SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]);
return ans;
#undef FUNC_NAME
+/* We have three levels of EVAL here:
+
+ - scm_i_eval (exp, env)
+
+ evaluates EXP in environment ENV. ENV is a lexical environment
+ structure as used by the actual tree code evaluator. When ENV is
+ a top-level environment, then changes to the current module are
+ tracked by modifying ENV so that it continues to be in sync with
+ the current module.
+
+ - scm_primitive_eval (exp)
+
+ evaluates EXP in the top-level environment as determined by the
+ current module. This is done by constructing a suitable
+ environment and calling scm_i_eval. Thus, changes to the
+ top-level module are tracked normally.
+
+ - scm_eval (exp, mod)
+
+ evaluates EXP while MOD is the current module. Thius is done by
+ setting the current module to MOD, invoking scm_primitive_eval on
+ EXP, and then restoring the current module to the value it had
+ previously. That is, while EXP is evaluated, changes to the
+ current module are tracked, but these changes do not persist when
+ scm_eval returns.
+
+ For each level of evals, there are two variants, distinguished by a
+ _x suffix: the ordinary variant does not modify EXP while the _x
+ variant can destructively modify EXP into something completely
+ unintelligible. A Scheme data structure passed as EXP to one of the
+ _x variants should not ever be used again for anything. So when in
+ doubt, use the ordinary variant.
+
+*/
+
SCM scm_system_transformer;
+/* XXX - scm_i_eval is meant to be useable for evaluation in
+ non-toplevel environments, for example when used by the debugger.
+ Can the system transform deal with this? */
+
SCM
scm_i_eval_x (SCM exp, SCM env)
{
SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer));
if (SCM_NIMP (transformer))
exp = scm_apply (transformer, exp, scm_listofnull);
- return SCM_XEVAL (scm_copy_tree (exp), env);
+ exp = scm_copy_tree (exp);
+ return SCM_XEVAL (exp, env);
}
SCM
-scm_eval_x (SCM exp, SCM module)
+scm_primitive_eval_x (SCM exp)
{
- return scm_i_eval_x (exp,
- scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module)));
+ SCM env = scm_top_level_env (scm_current_module_lookup_closure ());
+ return scm_i_eval_x (exp, env);
}
+SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
+ (SCM exp),
+ "Evaluate @var{exp} in the top-level environment specified by\n"
+ "the current module.")
+#define FUNC_NAME s_scm_primitive_eval
+{
+ SCM env = scm_top_level_env (scm_current_module_lookup_closure ());
+ return scm_i_eval (exp, env);
+}
+#undef FUNC_NAME
+
/* Eval does not take the second arg optionally. This is intentional
* in order to be R5RS compatible, and to prepare for the new module
* system, where we would like to make the choice of evaluation
- * environment explicit.
- */
+ * environment explicit. */
static void
change_environment (void *data)
{
SCM pair = SCM_PACK (data);
SCM new_module = SCM_CAR (pair);
- SCM old_module = scm_selected_module ();
+ SCM old_module = scm_current_module ();
SCM_SETCDR (pair, old_module);
- scm_select_module (new_module);
-}
-
-
-static SCM
-inner_eval (void *data)
-{
- SCM pair = SCM_PACK (data);
- SCM exp = SCM_CAR (pair);
- SCM env = SCM_CDR (pair);
- SCM result = scm_i_eval (exp, env);
- return result;
+ scm_set_current_module (new_module);
}
{
SCM pair = SCM_PACK (data);
SCM old_module = SCM_CDR (pair);
- SCM new_module = scm_selected_module ();
+ SCM new_module = scm_current_module ();
SCM_SETCAR (pair, new_module);
- scm_select_module (old_module);
+ scm_set_current_module (old_module);
}
+static SCM
+inner_eval_x (void *data)
+{
+ return scm_primitive_eval_x (SCM_PACK(data));
+}
-SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
- (SCM exp, SCM environment),
- "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
- "environment given by @var{environment specifier}.")
-#define FUNC_NAME s_scm_eval
+SCM
+scm_eval_x (SCM exp, SCM module)
+#define FUNC_NAME "eval!"
{
- SCM copied_exp;
- SCM env_closure;
+ SCM_VALIDATE_MODULE (2, module);
- SCM_VALIDATE_MODULE (2, environment);
+ return scm_internal_dynamic_wind
+ (change_environment, inner_eval_x, restore_environment,
+ (void *) SCM_UNPACK (exp),
+ (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
+}
+#undef FUNC_NAME
- copied_exp = scm_copy_tree (exp);
- env_closure = scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment));
+static SCM
+inner_eval (void *data)
+{
+ return scm_primitive_eval (SCM_PACK(data));
+}
+
+SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
+ (SCM exp, SCM module),
+ "Evaluate @var{exp}, a list representing a Scheme expression,\n"
+ "in the top-level environment specified by @var{module}.\n"
+ "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
+ "@var{module} is made the current module. The current module\n"
+ "is reset to its previous value when @var{eval} returns.")
+#define FUNC_NAME s_scm_eval
+{
+ SCM_VALIDATE_MODULE (2, module);
return scm_internal_dynamic_wind
(change_environment, inner_eval, restore_environment,
- (void *) SCM_UNPACK (scm_cons (copied_exp, env_closure)),
- (void *) SCM_UNPACK (scm_cons (environment, SCM_BOOL_F)));
+ (void *) SCM_UNPACK (exp),
+ (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
}
#undef FUNC_NAME
#if (SCM_DEBUG_DEPRECATED == 0)
-/* Use scm_selected_module () or scm_interaction_environment ()
+/* Use scm_current_module () or scm_interaction_environment ()
* instead. The former is the module selected during loading of code.
* The latter is the module in which the user of this thread currently
* types expressions.
/* Avoid using this functionality altogether (except for implementing
* libguile, where you can use scm_i_eval or scm_i_eval_x).
*
- * Applications should use either C level scm_eval_x or Scheme scm_eval. */
+ * Applications should use either C level scm_eval_x or Scheme
+ * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
SCM
scm_eval_3 (SCM obj, int copyp, SCM env)
SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0,
(SCM obj, SCM env_thunk),
- "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
- "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
- "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
+ "Evaluate @var{exp}, a Scheme expression, in the environment\n"
+ "designated by @var{lookup}, a symbol-lookup function."
+ "Do not use this version of eval, it does not play well\n"
+ "with the module system. Use @code{eval} or\n"
+ "@code{primitive-eval} instead.")
#define FUNC_NAME s_scm_eval2
{
return scm_i_eval (obj, scm_top_level_env (env_thunk));
HCoop / bpt / guile.git / blobdiff