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>"); }