static const wchar_t *block_name(C_procedure_t *block, obj_t *env)
{
if (block == b_eval)
return L"b_eval";
if (block == b_accum_operator)
return L"b_accum_operator";
if (block == b_accum_arg)
return L"b_accum_arg";
if (block == b_eval_sequence)
return L"b_eval_sequence";
if (block == NULL)
return L"NULL";
/* XXX Move this code into env.c. */
if (!env)
env = library_env(r6rs_library());
if (is_pair(env)) {
obj_t *frame = pair_car(env);
while (frame) {
obj_t *binding = pair_car(frame);
obj_t *value = binding_value(binding);
if (is_procedure(value) && procedure_is_C(value)) {
C_procedure_t *body;
body = (C_procedure_t *)procedure_body(value);
if (body == block) {
obj_t *name = symbol_name(binding_name(binding));
return string_value(name);
}
}
frame = pair_cdr(frame);
}
}
return L"<some-proc>";
}
extern cv_t c_apply_proc(obj_t cont, obj_t values)
{
assert(is_cont5(cont));
obj_t next = cont_cont(cont);
obj_t operator = cont5_arg1(cont);
obj_t saved_values = cont5_arg2(cont);
EVAL_LOG("op=%O values=%O operator=%O saved_values=%O",
operator, values, operator, saved_values);
obj_t arg_list = reverse_list(values);
if (procedure_is_C(operator)) {
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 new_values = CONS(make_uninitialized(), saved_values);
pair_set_car_nc(new_values, apply_proc(operator, arg_list));
return cv(next, new_values);
}
} else {
obj_t env = procedure_env(operator);
obj_t formals = procedure_args(operator);
obj_t actuals = arg_list;
obj_t new_env = make_closed_env(env, formals, actuals);
obj_t body = procedure_body(operator);
// Push a value for c_eval_seq to discard.
obj_t new_values = CONS(make_uninitialized(), saved_values);
return cv(make_cont4(c_eval_seq, next, new_env, body), new_values);
}
}
/////////////////////////////////////////////////////////////
//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;
}
obj_t *apply_procedure(obj_t *proc, obj_t *args)
{
PUSH_ROOT(proc);
PUSH_ROOT(args);
AUTO_ROOT(body, procedure_body(proc));
if (procedure_is_C(proc)) {
obj_t *env = F_ENV;
if (!procedure_is_special_form(proc))
env = procedure_env(proc);
GOTO_FRAME(make_short_frame, (C_procedure_t *)body, args, env);
}
AUTO_ROOT(new_env, make_env(procedure_env(proc)));
AUTO_ROOT(formals, procedure_args(proc));
AUTO_ROOT(actuals, args);
while (!is_null(formals) || !is_null(actuals)) {
if (is_null(formals)) {
printf_unchecked("calling %O\n", proc);
RAISE("too many args");
}
obj_t *formal, *actual;
if (is_pair(formals)) {
if (is_null(actuals)) {
printf_unchecked("proc=%O\n", proc);
RAISE("not enough args");
}
formal = pair_car(formals);
formals = pair_cdr(formals);
actual = pair_car(actuals);
actuals = pair_cdr(actuals);
} else {
formal = formals;
actual = actuals;
formals = actuals = NIL;
}
env_bind(new_env, formal, BT_LEXICAL, M_MUTABLE, actual);
}
GOTO(b_eval_sequence, body, new_env);
}
