OBJECT_PTR lit_id_metacont_fn(metacont_closure_t *mcls, reg_closure_t *cls)
{
if(is_quoted_expression(mcls->closed_vals[0]))
{
OBJECT_PTR i_sym = gensym();
return list(3,
LET,
list(1, list(2, i_sym, mcls->closed_vals[0])),
cls->fn(cls, i_sym));
}
else
return cls->fn(cls, mcls->closed_vals[0]);
}
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");
}
metacont_closure_t *mcps(OBJECT_PTR exp)
{
if(is_atom(exp) || is_quoted_expression(exp))
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = lit_id_metacont_fn;
mcls->nof_closed_vals = 1;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = exp;
return mcls;
}
OBJECT_PTR car_exp = car(exp);
if(car_exp == LAMBDA)
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = lambda_metacont_fn;
mcls->nof_closed_vals = 2;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = second(exp);
mcls->closed_vals[1] = third(exp);
return mcls;
}
if(car_exp == LET)
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = let_metacont_fn;
mcls->nof_closed_vals = 2;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = second(exp);
mcls->closed_vals[1] = third(exp);
return mcls;
}
if(primop(car_exp))
{
if(car_exp == RETURN_FROM)
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = return_from_metacont_fn;
mcls->nof_closed_vals = 1;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = exp;
return mcls;
}
else if(car_exp == THROW)
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = throw_metacont_fn;
mcls->nof_closed_vals = 1;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = second(exp);
return mcls;
}
else if(car_exp == CALL_CC)
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = call_cc_metacont_fn;
mcls->nof_closed_vals = 1;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = second(exp);
return mcls;
}
else if(car_exp == BREAK)
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = break_metacont_fn;
mcls->nof_closed_vals = 0;
mcls->closed_vals = NULL;
return mcls;
}
else
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = primop_metacont_fn;
mcls->nof_closed_vals = 2;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = car_exp; //operator
mcls->closed_vals[1] = cdr(exp); //operands
return mcls;
}
}
if(car_exp == IF)
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = if_metacont_fn;
mcls->nof_closed_vals = 3;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = second(exp);
mcls->closed_vals[1] = third(exp);
mcls->closed_vals[2] = fourth(exp);
return mcls;
}
#ifdef WIN32
if(car_exp == ERROR1)
#else
if(car_exp == ERROR)
#endif
{
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = error_metacont_fn;
mcls->nof_closed_vals = 1;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = second(exp);
return mcls;
}
//it is an application
metacont_closure_t *mcls = (metacont_closure_t *)GC_MALLOC(sizeof(metacont_closure_t));
mcls->mfn = app_metacont_fn;
mcls->nof_closed_vals = 1;
mcls->closed_vals = (OBJECT_PTR *)GC_MALLOC(mcls->nof_closed_vals * sizeof(OBJECT_PTR));
mcls->closed_vals[0] = exp;
return mcls;
}
