// local-heap-object?
scm_obj_t
subr_local_heap_object_pred(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc == 1) {
if (CELLP(argv[0])) {
return vm->m_heap->in_heap(argv[0]) ? scm_true : scm_false;
}
return scm_true;
}
wrong_number_of_arguments_violation(vm, "local-heap-object?", 1, 1, argc, argv);
return scm_undef;
#else
fatal("%s:%u local-heap-object? not supported on this build", __FILE__, __LINE__);
#endif
}
//function, args, environment!!
CELLP apply(CELLP func, CELLP args, CELLP env)
{
//printf("\nAPPLY: Current args: \n");//N//
//print_s(args, ESCON);//N//
//printf("\n");//N//
CELLP (*funcp)(), bodies, result = (CELLP)nil;
//CELLP bind();//N//
CELLP bind(CELLP keys, CELLP values, CELLP env);//N//
char funtype;
//printf("=%d= ", __LINE__);
//printf("apply func=");
//print_s(func, ESCOFF);
//printf(" args=");
//print_s(args, ESCOFF);
//printf(" env=");
//print_s(env, ESCOFF);
// printf("\nAPPLY: Current args: \n");//N//
// print_s(args, ESCON);//N//
//printf("\n");//N//
//function check
switch(func->id) {
case _ATOM:
//printf("=%d= ", __LINE__);
//if func is atom => maybe just func
funtype = ((ATOMP)func)->ftype;
if(funtype & _UD) {
//printf("=%d= ", __LINE__);
return error(UDF);
}
if(funtype & _SR) {
//printf("=%d= ", __LINE__);
funcp = (CELLP (*)())((ATOMP)func)->fptr;
if(funtype & _EA) {
//printf("=%d= ", __LINE__);
return (*(CELLP(*)(CELLP))funcp)(args);//N//
}
else {
//printf("=%d= ", __LINE__);
return (*(CELLP(*)(CELLP,CELLP))funcp)(args, env);//N//
}
}
func = ((ATOMP)func)->fptr;
//printf("=%d= ", __LINE__);
case _CELL:
//printf("=%d= ", __LINE__);
//printf("func=");
//print_s(func, ESCOFF);
//if func is cell => maybe lambda
//(lambda (x) <- this must be cell
if(func->cdr->id != _CELL) {
//printf("=%d= ", __LINE__);
return error(IFF);
}
//(lambda <- check!!
if(func->car == (CELLP)lambda) {
int q;//N//
//body (lambda (x) (hoge hoge) <- body!!
bodies = func->cdr->cdr;
stackcheck;
//lambda-argsの引き数のそれぞれにargsの値をbindするよ :-)!!
q = on(&args);//N//
on(&env);
on(&func);
on(&bodies);
*++sp = bind(func->cdr->car, args, env);//N//
off(q);//N//
ec;//N//
for(; bodies->id == _CELL; bodies = bodies->cdr) {
q = on(&args);
on(&env);
on(&func);
on(&bodies);
result = eval(bodies->car, *sp);//N//
off(q);//N//
ec;//N//
}
sp--;
//printf("=%d= ", __LINE__);
return result;
}
default:
//printf("=%d= ", __LINE__);
return error(IFF);
}
}
