extern cv_t c_eval(obj_t cont, obj_t values)
{
assert(is_cont4(cont));
obj_t expr = cont4_arg(cont);
EVAL_LOG("expr=%O", expr);
COULD_RETRY();
if (is_self_evaluating(expr))
return cv(cont_cont(cont), CONS(expr, values));
else if (is_symbol(expr)) {
obj_t env = cont_env(cont);
obj_t val = env_lookup(env, expr);
return cv(cont_cont(cont), CONS(val, values));
#if !OLD_ENV
} else if (is_env_ref(expr)) {
return cv(cont_cont(cont),
CONS(env_ref_lookup(cont_env(cont), expr), values));
#endif
} else if (is_application(expr)) {
obj_t operator = application_operator(expr);
obj_t env = cont_env(cont);
obj_t second = make_cont4(c_eval_operator,
cont_cont(cont),
env,
expr);
obj_t first = make_cont4(c_eval, second, env, operator);
return cv(first, values);
}
SYNTAX_ERROR(expr, expr, "must be expression");
}
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");
}
Cell eval(Cell exp, Cell env) {
if (is_self_evaluating(exp)) {
return exp;
} else if (is_atom(exp)) {
return lookup(exp, env);
} else if (is_tagged(exp, atom("define"))) {
return define(car(cdr(exp)), eval(car(cdr(cdr(exp))), env), env);
} else if (is_tagged(exp, atom("set!"))) {
return set(car(cdr(exp)), eval(car(cdr(cdr(exp))), env), env);
} else if (is_tagged(exp, atom("if"))) {
Cell cond = eval(car(cdr(exp)), env);
if (is_atom(cond) && is_eq(cond, atom("#f"))) {
exp = car(cdr(cdr(cdr(exp))));
} else {
exp = car(cdr(cdr(exp)));
}
return eval(exp, env);
} else if (is_tagged(exp, atom("vau"))) {
return procedure(exp, env);
} else if (is_pair(exp)) {
Cell proc = eval(car(exp), env);
if (is_primitive(proc)) {
return (proc->primitive)(eval_operands(cdr(exp), env));
} else if (is_procedure(proc)) {
Cell src = car(proc);
Cell e = car(cdr(cdr(src)));
Cell para = cons(e, cons(car(cdr(src)), null));
Cell args = cons(env, cons(cdr(exp), null));
Cell body = car(cdr(cdr(cdr(src))));
return eval(body, extend_env(para, args, cdr(proc)));
}
}
fprintf(stderr, "eval illegal state\n");
return atom("#<void>");
}
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);
}
static OBJ analyze_r(const struct analyze_t *arg)
{
OBJ op;
OBJ ret;
struct analyze_t new_arg;
new_arg = *arg;
ret = OBJ_NULL;
if (is_self_evaluating(new_arg.sexp))
ret = new_arg.sexp;
else if (is_variable(new_arg.sexp))
ret = analyze_variable_cell(new_arg.sexp,new_arg.env,new_arg.macro,new_arg.params,new_arg.macro_expand_env);
else if(obj_pairp(new_arg.sexp))
{
if(obj_pairp(car(new_arg.sexp)))
{
new_arg.sexp = car(new_arg.sexp);
op = fake_eval(&new_arg);
new_arg = *arg;
}
else
op = analyze_variable_value(car(new_arg.sexp),new_arg.env,new_arg.macro,new_arg.params,new_arg.macro_expand_env);
if(op == OBJ_NULL) /* error handle---fixme!! */
return OBJ_NULL;
if(obj_corep(op))
{
switch(obj_core_type(op))
{
case DEFINE:
case DEFINE_SYNTAX:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_define(&new_arg);
break;
case SET:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_set(&new_arg);
break;
case IF:
ret = analyze_if(cdr(new_arg.sexp),new_arg.env,new_arg.tail);
break;
case QUOTE:
ret = obj_make_quote(cadr(new_arg.sexp));
break;
case BEGIN:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_begin(&new_arg);
break;
case LAMBDA:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_lambda(&new_arg);
break;
case SYNTAX_RULES:
ret = analyze_syntax_rules(cdr(new_arg.sexp),new_arg.env);
break;
default:
fprintf(stderr,"unknown core tag\n");
}
}
else if(obj_syntaxp(op))
{
OBJ params;
OBJ data;
OBJ patten;
OBJ template;
int match;
match = 0;
data = obj_syntax_data(op);
while(obj_pairp(data))
{
patten = caar(data);
//TODO check number of arguments given to builtins
object_t *eval(object_t *exp, object_t *env) {
char comeback = 1;
while(comeback) {
comeback = 0;
if(is_self_evaluating(exp)) {
return exp;
}
if(list_begins_with(exp, quote_symbol)) {
return cadr(exp);
}
// (define... )
if(list_begins_with(exp, define_symbol)) {
object_t *var = cadr(exp);
// (define a b)
if(issymbol(var)) {
object_t *val = caddr(exp);
return define_var(env, var, val);
}
// (define (a ...) ...) TODO use scheme macro
if(ispair(var)) {
object_t *name = car(cadr(exp)),
*formals = cdr(cadr(exp)),
*body = cddr(exp),
*lambda = cons(lambda_symbol,
cons(formals, body));
exp = cons(define_symbol,
cons(name, cons(lambda, empty_list)));
comeback = 1;
continue;
}
fprintf(stderr, "Syntax error.\n");
exit(-1);
}
// (set! a b)
if(list_begins_with(exp, set_symbol)) {
object_t *var = cadr(exp);
object_t *val = caddr(exp);
return set_var(env, var, val);
}
// (if c a b)
if(list_begins_with(exp, if_symbol)) {
exp = eval_if(env, cadr(exp), caddr(exp), cadddr(exp));
comeback = 1;
continue;
}
// (cond ...)
if(list_begins_with(exp, cond_symbol)) {
object_t *tail = cons(void_symbol, empty_list);
object_t *ifs = tail; //empty_list;
object_t *rules = reverse_list(cdr(exp));
while(!isemptylist(rules)) {
object_t *rule = car(rules),
*condition = car(rule),
*consequence = cadr(rule);
if(isemptylist(consequence)) {
consequence = cons(void_obj, empty_list);
}
ifs = cons(if_symbol,
cons(condition,
cons(consequence,
cons(ifs, empty_list))));
rules = cdr(rules);
}
exp = ifs;
comeback = 1;
continue;
}
// (begin ...)
if(list_begins_with(exp, begin_symbol)) {
object_t *result = empty_list, *exps;
for(exps = cdr(exp); ! isemptylist(exps); exps = cdr(exps)) {
result = eval(car(exps), env);
}
return result;
}
if(list_begins_with(exp, lambda_symbol)) {
object_t *fn = cons(begin_symbol,
cdr(cdr(exp)));
return make_compound_proc(empty_list, cadr(exp),
fn,
env);
}
// (let ...)
if(list_begins_with(exp, let_symbol)) {
//if(! issymbol(cadr(exp)))
object_t *bindings = cadr(exp);
object_t *body = cddr(exp);
object_t *formals = empty_list;
object_t *values = empty_list;
while(!isemptylist(bindings)) {
formals = cons(caar(bindings), formals);
values = cons(cadr(car(bindings)), values);
bindings = cdr(bindings);
}
exp = cons(cons(lambda_symbol, cons(formals, body)),
values);
comeback = 1;
continue;
}
if(issymbol(exp)) {
return var_get_value(env, exp);
}
if(ispair(exp)) {
object_t *exp_car = car(exp);
object_t *fn = eval(exp_car, env); //var_get_value(env, car);
if(!iscallable(fn)) {
fprintf(stderr, "object_t is not callable\n");
exit(-1);
}
object_t *args = cdr(exp);
object_t *evaluated_args = evaluate_list(env, args, empty_list);
if(isprimitiveproc(fn)) {
return fn->value.prim_proc.fn(evaluated_args);
} else if(iscompoundproc(fn)) {
object_t *fn_formals = fn->value.compound_proc.formals;
object_t *fn_body = fn->value.compound_proc.body;
object_t *fn_env = fn->value.compound_proc.env;
ARGS_EQ(evaluated_args, list_size(fn_formals));
exp = fn_body;
env = extend_environment(fn_formals, evaluated_args, fn_env);
comeback = 1;
continue;
}
assert(0);
}
}
fprintf(stderr, "Unable to evaluate expression: \n");
write(exp);
exit(-1);
}
object *bs_eval(object *exp, object *env)
{
tailcall:
if (is_empty_list(exp)) {
error("unable to evaluate empty list");
} else if (is_self_evaluating(exp)) {
return exp;
} else if (is_variable(exp)) {
return lookup_variable_value(exp, env);
} else if (is_quoted(exp)) {
return quoted_expression(exp);
} else if (is_assignment(exp)) {
return eval_assignment(exp, env);
} else if (is_definition(exp)) {
return eval_definition(exp, env);
} else if (is_if(exp)) {
if (is_true(bs_eval(if_predicate(exp), env))) {
exp = if_consequent(exp);
} else {
exp = if_alternate(exp);
}
goto tailcall;
} else if (is_lambda(exp)) {
return make_compound_proc(lambda_parameters(exp),
lambda_body(exp),
env);
} else if (is_begin(exp)) {
exp = begin_actions(exp);
if (is_empty_list(exp)) {
error("empty begin block");
}
while (!is_empty_list(cdr(exp))) {
bs_eval(car(exp), env);
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_cond(exp)) {
exp = cond_to_if(exp);
goto tailcall;
} else if (is_let(exp)) {
exp = let_to_application(exp);
goto tailcall;
} else if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(1);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_false(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(0);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_true(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_application(exp)) {
object *procedure = bs_eval(application_operator(exp), env);
object *parameters = eval_parameters(application_operands(exp), env);
// handle eval specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == eval_proc) {
exp = eval_expression(parameters);
env = eval_environment(parameters);
goto tailcall;
}
// handle apply specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == apply_proc) {
procedure = apply_operator(parameters);
parameters = apply_operands(parameters);
}
if (is_primitive_proc(procedure)) {
return (procedure->value.primitive_proc)(parameters);
} else if (is_compound_proc(procedure)) {
env = extend_environment(
procedure->value.compound_proc.parameters,
parameters,
procedure->value.compound_proc.env);
exp = make_begin(procedure->value.compound_proc.body);
goto tailcall;
} else {
error("unable to apply unknown procedure type");
}
} else {
error("unable to evaluate expression");
}
}
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;
}
