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