object *setup_environment(void) {
object *initial_env;
initial_env = extend_environment(
the_empty_list,
the_empty_list,
the_empty_environment);
return initial_env;
}
static li_object *expand_macro(li_object *mac, li_object *args) {
li_object *env, *ret, *seq;
ret = li_null;
env = extend_environment(li_to_macro(mac).vars, args, li_to_macro(mac).env);
for (seq = li_to_macro(mac).body; seq; seq = li_cdr(seq))
ret = li_eval(li_car(seq), env);
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);
}
}
item setup_environment(){
item initial_env = extend_environment(primitive_procedure_names(), primitive_procedure_objects(), the_empty_environment());
item t, f;
t.type = f.type = t_number;
t.content.number = 1;
f.content.number = 0;
define_variable(make_item("true"), t, initial_env);
define_variable(make_item("false"), f, initial_env);
return initial_env;
}
sexp eval_application(sexp operator, sexp operands) {
if (is_primitive(operator))
return (primitive_C_proc(operator))(operands);
if (is_compound(operator)) {
sexp body = compound_proc_body(operator);
sexp vars = compound_proc_parameters(operator);
sexp def_env = compound_proc_environment(operator);
sexp object = make_pair(S("begin"), body);
sexp env = extend_environment(vars, operands, def_env);
return eval_object(object, env);
}
fprintf(stderr, "Unknown operator type %d\n", operator->type);
exit(1);
}
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");
}
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;
}
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_t *setup_environment() {
object_t *env = extend_environment(empty_list, empty_list,
empty_list);
return env;
}
//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");
}
}
sexp eval_object(sexp object, sexp environment) {
tail_loop:
if (is_quote_form(object)) return quotation_text(object);
if (is_variable_form(object))
return get_variable_value(object, environment);
if (is_define_form(object)) {
/* sexp value = eval_object(definition_value(object), environment); */
/* add_binding(definition_variable(object), value, environment); */
/* return value; */
return eval_object(define2set(object), environment);
}
if (is_assignment_form(object)) {
sexp value = eval_object(assignment_value(object), environment);
set_binding(assignment_variable(object), value, environment);
return value;
}
if (is_if_form(object)) {
sexp test_part = if_test_part(object);
sexp then_part = if_then_part(object);
sexp else_part = if_else_part(object);
if (!is_false(eval_object(test_part, environment))) {
object = then_part;
} else {
object = else_part;
}
goto tail_loop;
}
if (is_lambda_form(object)) {
sexp parameters = lambda_parameters(object);
sexp body = lambda_body(object);
return make_lambda_procedure(parameters, body, environment);
}
if (is_begin_form(object)) {
return eval_begin(object, environment);
}
if (is_cond_form(object)) {
object = cond2if(object);
goto tail_loop;
}
if (is_let_form(object)) {
object = let2lambda(object);
goto tail_loop;
}
if (is_and_form(object)) {
sexp tests = and_tests(object);
if (is_null(tests))
return make_true();
while (is_pair(pair_cdr(tests))) {
sexp result = eval_object(pair_car(tests), environment);
if (is_false(result))
return make_false();
tests = pair_cdr(tests);
}
return eval_object(pair_car(tests), environment);
}
if (is_or_form(object)) {
sexp tests = or_tests(object);
if (is_null(tests))
return make_false();
while (is_pair(pair_cdr(tests))) {
sexp result = eval_object(pair_car(tests), environment);
if (!is_false(result))
return result;
tests = pair_cdr(tests);
}
return eval_object(pair_car(tests), environment);
}
if (is_macro_form(object)) {
sexp pars = macro_parameters(object);
sexp body = macro_body(object);
return make_macro_procedure(pars, body, environment);
}
if (is_application_form(object)) {
sexp operator = application_operator(object);
sexp operands = application_operands(object);
operator = eval_object(operator, environment);
if (!is_function(operator) && !is_macro(operator)) {
fprintf(stderr, "Illegal functional object ");
write_object(operator, make_file_out_port(stderr));
fprintf(stderr, " from ");
write_object(pair_car(object), make_file_out_port(stderr));
fputc('\n', stderr);
exit(1);
}
/* Expand the macro before evaluating arguments */
if (is_macro(operator)) {
sexp body = macro_proc_body(operator);
sexp vars = macro_proc_pars(operator);
sexp def_env = macro_proc_env(operator);
sexp object = make_pair(S("begin"), body);
sexp env = extend_environment(vars, operands, def_env);
sexp exp = eval_object(object, env);
return eval_object(exp, environment);
}
operands = eval_arguments(operands, environment);
/* if (is_apply(operator)) { */
/* operator = pair_car(operands); */
/* operands = apply_operands_conc(pair_cdr(operands)); */
/* } */
if (is_eval(operator)) {
environment = pair_cadr(operands);
object = pair_car(operands);
goto tail_loop;
}
return eval_application(operator, operands);
} else return object;
}
