Union _with_open_driver(ExAtom *env, Cell *args)
{
ArgsIsAtLeast1<IsSymbol> checker(args);
checker.check();
Symbol *driver_sym;
driver_sym = checker.get0();
Cell *body;
body = checker.getRemains();
if ( body == Cell::NIL ) {
throw std::runtime_error("no body.");
}
ExAtom *new_env;
if ( driver_sym->name == "root" ) {
new_env = environment::getSystemRootEnvironment();
} else {
Union u_new_env;
bool find_flag;
u_new_env = environment::getValue(env, *driver_sym, &find_flag);
if ( !find_flag ) {
throw std::runtime_error("no driver name.");
}
new_env = u_new_env.getEnvironmentExAtom();
if ( new_env == 0 ) {
throw std::runtime_error("no driver.");
}
}
return eval_sequence(new_env, body);
}
// see note for eval_sequence, below
struct object *
eval(struct pair *form, struct environment *env)
{
struct pair *seq = make_pair(&form->obj, &NIL->obj);
struct object *ret = eval_sequence(seq, env);
dealloc_obj(&seq->obj);
return ret;
}
object_t apply(object_t p, object_t argl) {
proc_t proc = obj_get_proc(p);
if(isprimitiveproc(proc)) /* primitive procedure */
return (proc->fn)(argl);
else {
object_t extended = extend_environment(lambda_params(p), argl, lambda_env(p));
return eval_sequence(lambda_body(p), &extended);
}
}
data_t *apply(const data_t *proc, const data_t *args) {
data_t *out;
if(is_primitive_procedure(proc))
return apply_primitive_procedure(proc, args);
if(is_compound_procedure(proc)) {
out = eval_sequence(
get_procedure_body(proc),
extend_environment(get_procedure_parameters(proc),
args,
get_procedure_environment(proc)));
return out;
}
printf("Unknown procedure type -- APPLY\n");
return make_symbol("error");
}
data_t *eval(const data_t *exp, data_t *env) {
if(eval_plz_die) {
eval_plz_die = 0;
ExitThread(0);
}
if(is_self_evaluating(exp))
return (data_t*)exp;
if(is_variable(exp))
return lookup_variable_value(exp, env);
if(is_quoted_expression(exp))
return get_text_of_quotation(exp);
if(is_assignment(exp))
return eval_assignment(exp, env);
if(is_definition(exp))
return eval_definition(exp, env);
if(is_if(exp))
return eval_if(exp, env);
if(is_lambda(exp))
return make_procedure(get_lambda_parameters(exp), get_lambda_body(exp), env);
if(is_begin(exp))
return eval_sequence(get_begin_actions(exp), env);
if(is_cond(exp))
return eval(cond_to_if(exp), env);
if(is_letrec(exp))
return eval(letrec_to_let(exp), env);
if(is_let_star(exp))
return eval(let_star_to_nested_lets(exp), env);
if(is_let(exp))
return eval(let_to_combination(exp), env);
if(is_application(exp))
return apply(
eval(get_operator(exp), env),
get_list_of_values(get_operands(exp), env));
printf("Unknown expression type -- EVAL '");
return make_symbol("error");
}
static data_t *eval_sequence(const data_t *exps, data_t *env) {
if(is_last_exp(exps))
return eval(get_first_exp(exps), env);
eval(get_first_exp(exps), env);
return eval_sequence(get_rest_exps(exps), env);
}
///////////////////////////////////////////////////////////////////
//eval
//requires two arguments:exp & tail_context
///////////////////////////////////////////////////////////////////
cellpoint eval(void)
{
if (is_true(is_self_evaluating(args_ref(1)))){
reg = args_ref(1);
}else if (is_true(is_variable(args_ref(1)))){
reg = args_ref(1);
args_push(current_env);
args_push(reg);
reg = lookup_var_val();
}else if (is_true(is_quoted(args_ref(1)))){
args_push(args_ref(1));
reg = quotation_text();
}else if (is_true(is_assignment(args_ref(1)))){
args_push(args_ref(1));
reg = eval_assignment();
}else if (is_true(is_definition(args_ref(1)))){
args_push(args_ref(1));
reg = eval_definition();
}else if (is_true(is_if(args_ref(1)))){
//eval if expression with the second argument (tail_context)
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_if();
}else if (is_true(is_lambda(args_ref(1)))){
args_push(args_ref(1));
reg = eval_lambda();
}else if (is_true(is_begin(args_ref(1)))){
args_push(args_ref(1));
reg = begin_actions();
//eval the actions of begin exp with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
reg = eval_sequence();
}else if (is_true(is_cond(args_ref(1)))){
args_push(args_ref(1));
reg = cond_2_if();
//eval the exp with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_and(args_ref(1)))){
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_and();
}else if (is_true(is_or(args_ref(1)))){
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_or();
}else if (is_true(is_let(args_ref(1)))){
//convert let to combination
args_push(args_ref(1));
reg = let_2_combination();
//evals the combination
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_letstar(args_ref(1)))){
//convert let* to nested lets
args_push(args_ref(1));
reg = letstar_2_nested_lets();
//evals the nested lets
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_application(args_ref(1)))){
//computes operator
args_push(args_ref(1));
reg = operator();
args_push(a_false);
args_push(reg);
reg = eval();
stack_push(&vars_stack, reg);
//computes operands
args_push(args_ref(1));
reg = operands();
args_push(reg);
reg = list_of_values();
//calls apply with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
args_push(stack_pop(&vars_stack));
reg = apply();
}else {
printf("Unknown expression type -- EVAL\n");
error_handler();
}
args_pop(2);
return reg;
}
