static cv_t c_eval_operator(obj_t cont, obj_t values) { assert(is_cont4(cont)); obj_t appl = cont4_arg(cont); obj_t operator = CAR(values); EVAL_LOG("appl=%O operator=%O", appl, operator); COULD_RETRY(); if (!is_procedure(operator)) SYNTAX_ERROR(operator, operator, "must be procedure"); if (!procedure_args_evaluated(operator)) { assert(procedure_is_C(operator) && "implement Scheme special forms"); if (procedure_is_raw(operator)) { return ((cont_proc_t)procedure_code(operator))(cont, values); } else { // N.B., call proc after all other allocations. obj_t arg_list = application_operands(appl); obj_t new_values = CONS(make_uninitialized(), CDR(values)); pair_set_car(new_values, apply_proc(operator, arg_list)); return cv(cont_cont(cont), new_values); } } obj_t arg_list = reverse_list(application_operands(appl)); cont = make_cont5(c_apply_proc, cont_cont(cont), cont_env(cont), operator, CDR(values)); while (!is_null(arg_list)) { cont = make_cont4(c_eval, cont, cont_env(cont), CAR(arg_list)); arg_list = CDR(arg_list); } return cv(cont, EMPTY_LIST); }
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"); } }