/////////////////////////////////////////////////////////////
//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;
}
void lisp_print(object exp, FILE *out)
{
unsigned long i, len;
char c;
char *str;
object *vptr;
switch (type_of(exp)) {
case T_NIL:
fprintf(out, "()");
break;
case T_FIXNUM:
fprintf(out, "%ld", fixnum_value(exp));
break;
case T_CHARACTER:
c = character_value(exp);
fprintf(out, "#\\");
switch (c) {
case '\n':
fprintf(out, "newline");
break;
case ' ':
fprintf(out, "space");
break;
default:
fprintf(out, "%c", c);
}
break;
case T_PAIR:
if (is_finite_list(exp, NULL)) {
fprintf(out, "(");
write_pair(exp, out);
fprintf(out, ")");
} else {
fprintf(out, "#<unprintable-structure>");
}
break;
case T_BOOLEAN:
fprintf(out, is_false(exp) ? "#f" : "#t");
break;
case T_STRING:
fprintf(out, "\"");
str = string_value(exp);
len = string_length(exp);
for (i = 0; i < len; i++) {
switch (str[i]) {
case '\n':
fprintf(out, "\\n");
break;
case '"':
fprintf(out, "\\\"");
break;
case '\\':
fprintf(out, "\\\\");
break;
default:
fprintf(out, "%c", str[i]);
}
}
fprintf(out, "\"");
break;
case T_VECTOR:
fprintf(out, "#(");
len = vector_length(exp);
vptr = vector_ptr(exp);
for (i = 0; i < len; i++) {
if (i)
fputc(' ', out);
lisp_print(*vptr++, out);
}
fprintf(out, ")");
break;
case T_SYMBOL:
fprintf(out, "%.*s", (int) string_length(symbol_string(exp)),
string_value(symbol_string(exp)));
break;
case T_FOREIGN_PTR:
fprintf(out, "#<foreign-pointer %p>", foreign_ptr_value(exp));
break;
case T_PRIMITIVE:
fprintf(out, "#<primitive-procedure %p>", primitive_implementation(exp));
break;
case T_PROCEDURE:
fprintf(out, "#<procedure ");
lisp_print(procedure_parameters(exp), out);
fprintf(out, ">");
break;
case T_EOF:
fprintf(out, "#<eof>");
break;
case T_PORT:
fprintf(out, "#<%s-port %p>",
is_input_port(exp) ? "input" : "output",
port_implementation(exp));
break;
case T_UNSPECIFIED:
/* actually, I could read this back... */
fprintf(out, "#<unspecified>");
break;
case T_MACRO:
fprintf(out, "#<macro ");
lisp_print(macro_parameters(exp), out);
fprintf(out, ">");
break;
case T_MAX_TYPE:
break;
}
}
