int test_environment()
{
symbol *sa = new_symbol("a");
symbol *sb = new_symbol("b");
symbol *sc = new_symbol("c");
symbol *sx = new_symbol("x");
symbol *sy = new_symbol("y");
symbol *sz = new_symbol("z");
symbol *sn = new_symbol("n");
integer *i10 = new_integer(10);
integer *i20 = new_integer(20);
integer *i30 = new_integer(30);
integer *i40 = new_integer(40);
integer *i50 = new_integer(50);
integer *i60 = new_integer(60);
list *vara = cons(sa, cons(sb, cons(sc, NULL)));
list *varx = cons(sx, cons(sy, cons(sz, NULL)));
list *val10 = cons(i10, cons(i20, cons(i30, NULL)));
list *val40 = cons(i40, cons(i50, cons(i60, NULL)));
environment *env = NULL;
env = extend_env(vara, val10, env);
assert(generic_equal(lookup_var_val(sa, env), cons(sa, i10)));
assert(generic_equal(lookup_var_val(sb, env), cons(sb, i20)));
assert(generic_equal(lookup_var_val(sc, env), cons(sc, i30)));
env = define_var_val(sx, i40, env);
assert(generic_equal(lookup_var_val(sa, env), cons(sa, i10)));
assert(generic_equal(lookup_var_val(sb, env), cons(sb, i20)));
assert(generic_equal(lookup_var_val(sc, env), cons(sc, i30)));
assert(generic_equal(lookup_var_val(sx, env), cons(sx, i40)));
assert(generic_equal(lookup_var_val(sy, env), NULL));
env = set_var_val(sx, i50, env);
assert(generic_equal(lookup_var_val(sa, env), cons(sa, i10)));
assert(generic_equal(lookup_var_val(sb, env), cons(sb, i20)));
assert(generic_equal(lookup_var_val(sc, env), cons(sc, i30)));
assert(generic_equal(lookup_var_val(sx, env), cons(sx, i50)));
assert(generic_equal(lookup_var_val(sy, env), NULL));
env = extend_env(varx, val40, env);
assert(generic_equal(lookup_var_val(sa, env), cons(sa, i10)));
assert(generic_equal(lookup_var_val(sb, env), cons(sb, i20)));
assert(generic_equal(lookup_var_val(sc, env), cons(sc, i30)));
assert(generic_equal(lookup_var_val(sx, env), cons(sx, i40)));
assert(generic_equal(lookup_var_val(sy, env), cons(sy, i50)));
assert(generic_equal(lookup_var_val(sz, env), cons(sz, i60)));
assert(generic_equal(lookup_var_val(sn, env), NULL));
return 1;
}
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;
}
static void
exec_shell(const char *shell, int fallback)
{
char *sh;
const char *p;
extend_env(NULL);
if(start_login_process() < 0)
warn("login process");
start_logout_process();
p = strrchr(shell, '/');
if(p)
p++;
else
p = shell;
if (asprintf(&sh, "-%s", p) == -1)
errx(1, "Out of memory");
execle(shell, sh, NULL, env);
if(fallback){
warnx("Can't exec %s, trying %s",
shell, _PATH_BSHELL);
execle(_PATH_BSHELL, "-sh", NULL, env);
err(1, "%s", _PATH_BSHELL);
}
err(1, "%s", shell);
}
/////////////////////////////////////////////////////////////
//apply
//requires three arguments:proc , args & tail_context
////////////////////////////////////////////////////////////
cellpoint apply(void)
{
if (is_true(is_prim_proc(args_ref(1)))){
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = apply_prim_proc();
}else if (is_true(is_compound_proc(args_ref(1)))){
//if this application isn't in a tail context,
//then store the current_env
if (is_false(args_ref(3))){
stack_push(&env_stack, current_env);
}
/*for test
test the tail recursion
*/
// printf("call ");
// write(args_ref(1));
// newline();
// args_push(env_stack);
// printf("the length of env_stack: %d\n", get_integer(list_len()));
//calls procedure_parameters
args_push(args_ref(1));
reg = procedure_parameters();
stack_push(&vars_stack, reg);
//calls procedure_env
args_push(args_ref(1));
reg = procedure_env();
//calls extend_env
stack_push(&vars_stack, args_ref(2));
args_push(reg);
args_push(stack_pop(&vars_stack));
args_push(stack_pop(&vars_stack));
current_env = extend_env();
//calls procedure_body
args_push(args_ref(1));
reg = procedure_body();
//calls eval_lambda_body
args_push(reg);
reg = eval_lambda_body();
//if this application isn't in tail context,
//then restore the stored current_env
if (is_false(args_ref(3))){
current_env = stack_pop(&env_stack);
}
}else {
printf("Unknown procedure : ");
write(args_ref(1));
newline();
error_handler();
}
args_pop(3);
return reg;
}
Cell make_env(void) {
Cell e = extend_env(null, null, null);
define(atom("make"), primitive(make_primitive), e);
define(atom("car"), primitive(car_primitive), e);
define(atom("cdr"), primitive(cdr_primitive), e);
define(atom("type"), primitive(type_primitive), e);
define(atom("set-car!"), primitive(set_car_primitive), e);
define(atom("set-cdr!"), primitive(set_cdr_primitive), e);
define(atom("null?"), primitive(is_null_primitive), e);
define(atom("eq?"), primitive(is_eq_primitive), e);
define(atom("add1"), primitive(add1_primitive), e);
define(atom("sub1"), primitive(sub1_primitive), e);
define(atom("eval"), primitive(eval_primitive), e);
define(atom("read"), primitive(read_primitive), e);
define(atom("put"), primitive(put_primitive), e);
return e;
}
EVAL_INLINE lref_t apply(lref_t function, size_t argc, lref_t argv[], lref_t *env, lref_t *retval)
{
lref_t args[3];
if (SUBRP(function)) {
return subr_apply(function, argc, argv, env, retval);
} else if (CLOSUREP(function)) {
lref_t c_code = CLOSURE_CODE(function);
*env = extend_env(arg_list_from_buffer(argc, argv),
CAR(c_code),
CLOSURE_ENV(function));
return CDR(c_code); /* tail call */
} else if (argc > 0) {
if (HASHP(function) || STRUCTUREP(function)) {
args[0] = function;
args[1] = argv[0];
args[2] = (argc > 1) ? argv[1] : NIL;
*retval = lslot_ref(MAX2(argc + 1, 2), args);
return NIL;
} else if (SYMBOLP(function)) {
if (HASHP(argv[0]) || STRUCTUREP(argv[0])) {
args[0] = argv[0];
args[1] = function;
args[2] = (argc > 1) ? argv[1] : NIL;
*retval = lslot_ref(MAX2(argc + 1, 2), args);
return NIL;
}
}
}
vmerror_wrong_type(function);
return NIL;
}
EVAL_INLINE lref_t apply(lref_t function,
size_t argc, lref_t argv[],
lref_t * env, lref_t * retval)
{
if (SUBRP(function))
return subr_apply(function, argc, argv, env, retval);
if (CLOSUREP(function))
{
lref_t c_code = CLOSURE_CODE(function);
*env = extend_env(arg_list_from_buffer(argc, argv),
CAR(c_code),
CLOSURE_ENV(function));
return CDR(c_code); /* tail call */
}
vmerror_wrong_type(function);
return NIL;
}
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>");
}
