int test_eval()
{
symbol *sa = new_symbol("a");
symbol *sb = new_symbol("b");
symbol *sc = new_symbol("c");
symbol *plus = new_symbol("+");
prim_proc *proc = new_prim_proc(proc_plus_integer);
integer *i10 = new_integer(10);
integer *i20 = new_integer(20);
integer *i30 = new_integer(30);
integer *i60 = new_integer(60);
list *vara = cons(sa, cons(sb, cons(sc, NULL)));
list *val10 = cons(i10, cons(i20, cons(i30, NULL)));
list *plus_i = cons(plus, val10);
environment *env = NULL;
env = extend_env(vara, val10, env);
assert(generic_equal(eval(sa, env), i10));
assert(generic_equal(eval(i10, env), i10));
define_var_val(plus, proc, env);
assert(generic_equal(car(list_of_values(val10, env)), i10));
assert(generic_equal(eval(plus_i, env), i60));
return 1;
}
//one arg: ops
static cellpoint list_of_values(void)
{
args_push(args_ref(1));
reg = no_operands();
if (is_true(reg)){
reg = NIL;
}else {
//get the first operand
args_push(args_ref(1));
reg = first_operand();
//eval the first operand with tail_context is a_false
args_push(a_false);
args_push(reg);
reg = eval();
stack_push(&vars_stack, reg);
//eval the rest operands
args_push(args_ref(1));
reg = rest_operands();
args_push(reg);
reg = list_of_values();
reg = cons(stack_pop(&vars_stack), reg);
}
args_pop(1);
return reg;
}
extern li_object *li_eval(li_object *exp, li_object *env) {
li_object *seq, *proc, *args;
int done;
done = 0;
while (!li_is_self_evaluating(exp) && !done) {
li_stack_trace_push(exp);
if (li_is_symbol(exp)) {
exp = li_environment_lookup(env, exp);
done = 1;
} else if (li_is_quoted(exp)) {
check_special_form(li_cdr(exp) && !li_cddr(exp), exp);
exp = li_cadr(exp);
done = 1;
} else if (li_is_quasiquoted(exp)) {
check_special_form(li_cdr(exp) && !li_cddr(exp), exp);
exp = eval_quasiquote(li_cadr(exp), env);
done = 1;
} else if (li_is_application(exp)) {
proc = li_eval(li_car(exp), env);
args = li_cdr(exp);
if (li_is_procedure(proc))
args = list_of_values(args, env);
if (li_is_lambda(proc)) {
env = extend_environment(li_to_lambda(proc).vars, args,
li_to_lambda(proc).env);
for (seq = li_to_lambda(proc).body; seq && li_cdr(seq);
seq = li_cdr(seq))
li_eval(li_car(seq), env);
exp = li_car(seq);
} else if (li_is_macro(proc)) {
exp = expand_macro(proc, args);
} else if (li_is_primitive_procedure(proc)) {
exp = li_to_primitive_procedure(proc)(args);
done = 1;
} else if (li_is_special_form(proc)) {
exp = li_to_special_form(proc)(args, env);
} else {
li_error("not applicable", proc);
}
} else {
li_error("unknown expression type", exp);
}
li_stack_trace_pop();
}
return exp;
}
static pSlipObject list_of_values(pSlip gd, pSlipObject exps, pSlipEnvironment env)
{
if (is_no_operands(gd, exps) == S_TRUE)
{
return gd->singleton_EmptyList;
}
else
{
pSlipObject x;
x = slip_eval(gd, first_operand(exps), env);
if (x == NULL)
x = gd->singleton_Nil;
return cons(gd, x, list_of_values(gd, rest_operands(exps), env));
}
}
object *eval(object *exp, object *env) {
object *procedure;
object *arguments;
object *result;
bool tailcall = false;
do {
if (is_self_evaluating(exp))
return exp;
if (is_variable(exp))
return lookup_variable_value(exp, env);
if (is_quoted(exp))
return 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)) {
exp = is_true(eval(if_predicate(exp), env)) ? if_consequent(exp) : if_alternative(exp);
tailcall = true;
continue;
}
if (is_lambda(exp))
return make_compound_proc(lambda_parameters(exp), lambda_body(exp), env);
if (is_begin(exp)) {
exp = begin_actions(exp);
while (!is_last_exp(exp)) {
eval(first_exp(exp), env);
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_cond(exp)) {
exp = cond_to_if(exp);
tailcall = true;
continue;
}
if (is_let(exp)) {
exp = let_to_application(exp);
tailcall = true;
continue;
}
if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty(exp))
return make_boolean(true);
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_false(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty(exp)) {
return make_boolean(false);
}
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_true(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_application(exp)) {
procedure = eval(operator(exp), env);
arguments = list_of_values(operands(exp), env);
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == eval_proc) {
exp = eval_expression(arguments);
env = eval_environment(arguments);
tailcall = true;
continue;
}
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == apply_proc) {
procedure = apply_operator(arguments);
arguments = apply_operands(arguments);
}
if (is_primitive_proc(procedure))
return (procedure->data.primitive_proc.fn)(arguments);
if (is_compound_proc(procedure)) {
env = extend_environment(procedure->data.compound_proc.parameters, arguments, procedure->data.compound_proc.env);
exp = make_begin(procedure->data.compound_proc.body);
tailcall = true;
continue;
}
return make_error(342, "unknown procedure type");
} // is_application()
} while (tailcall);
fprintf(stderr, "cannot eval unknown expression type\n");
exit(EXIT_FAILURE);
}
object *list_of_values(object *exps, object *env) {
return is_no_operands(exps) ?
empty_list() :
cons(eval(first_operand(exps), env), list_of_values(rest_operands(exps), env));
}
static pSlipObject slip_eval(pSlip gd, pSlipObject exp, pSlipEnvironment env)
{
pSlipObject proc;
pSlipObject args;
tailcall:
if (is_self_evaluating(exp) == S_TRUE)
{
return exp;
}
else if (is_variable(exp) == S_TRUE)
{
return lookup_variable_value(gd, exp, env);
}
else if (is_quoted(gd, exp) == S_TRUE)
{
return text_of_quotation(exp);
}
else if (is_assignment(gd, exp) == S_TRUE)
{
return eval_assignment(gd, exp, env);
}
else if (is_definition(gd, exp) == S_TRUE)
{
return eval_definition(gd, exp, env);
}
else if (is_if(gd, exp) == S_TRUE)
{
exp = is_true(gd, slip_eval(gd, if_predicate(exp), env)) == S_TRUE ? if_consequent(exp) : if_alternative(gd, exp);
goto tailcall;
}
else if (is_lambda(gd, exp) == S_TRUE)
{
return s_NewCompoundProc(gd, lambda_parameters(exp), lambda_body(exp), env);
}
else if (is_begin(gd, exp) == S_TRUE)
{
exp = begin_actions(exp);
while (!is_last_exp(gd, exp))
{
slip_eval(gd, first_exp(exp), env);
exp = rest_exps(exp);
}
exp = first_exp(exp);
goto tailcall;
}
else if (is_cond(gd, exp) == S_TRUE)
{
exp = cond_to_if(gd, exp);
goto tailcall;
}
else if (is_let(gd, exp) == S_TRUE)
{
exp = let_to_application(gd, exp);
goto tailcall;
}
else if (is_application(exp) == S_TRUE)
{
proc = slip_eval(gd, slip_operator(exp), env);
if (proc == NULL)
return gd->singleton_False;
if (proc->type == eType_PRIMITIVE_PROC || proc->type == eType_COMPOUND_PROC)
{
args = list_of_values(gd, operands(exp), env);
if (args == NULL)
return gd->singleton_False;
if (sIsObject_PrimitiveProc(proc) == S_TRUE)
{
return proc->data.prim_proc.func(gd, args);
}
else if (sIsObject_CompoundProc(proc) == S_TRUE)
{
env = setup_environment(gd, proc->data.comp_proc.env, proc->data.comp_proc.params, args);
exp = make_begin(gd, proc->data.comp_proc.code);
goto tailcall;
}
else
{
throw_error(gd, "unknown procedure type\n");
return gd->singleton_False;
}
}
else
return proc;
}
else
{
throw_error(gd, "cannot eval unknown expression type\n");
return NULL;
}
throw_error(gd, "what??\n");
return NULL;
}
///////////////////////////////////////////////////////////////////
//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;
}