//--------eval---------------
int eval(int addr){
int res;
if(atomp(addr)){
if(numberp(addr))
return(addr);
if(symbolp(addr)){
res = findsym(addr);
if(res == -1)
error(CANT_FIND_ERR, "eval", addr);
else
return(res);
}
}
else
if(listp(addr)){
if((symbolp(car(addr))) &&(HAS_NAME(car(addr),"quote")))
return(cadr(addr));
if(numberp(car(addr)))
error(ARG_SYM_ERR, "eval", addr);
if(subrp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
if(fsubrp(car(addr)))
return(apply(car(addr),cdr(addr)));
if(functionp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
}
error(CANT_FIND_ERR, "eval", addr);
return(0);
}
int eval(int addr){
int res;
if(atomp(addr)){
if(IS_NUMBER(addr))
return(addr);
if(IS_SYMBOL(addr)){
res = findsym(GET_NAME(addr));
switch(GET_TAG(res)){
case NUM: return(makenum(GET_NUMBER(res)));
case SYM: return(GET_BIND(res));
case LIS: return(GET_BIND(res));
}
}
}
else{
if(HAS_NAME(car(addr),"quote"))
return(cadr(addr));
if(subrp(car(addr)))
return(apply(symname(car(addr)),evlis(cdr(addr))));
if(fsubrp(car(addr)))
return(apply(symname(car(addr)),cdr(addr)));
if(lambdap(car(addr)))
return(apply(symname(car(addr)),evlis(cdr(addr))));
}
return(NIL);
}
//--------eval---------------
int eval(int addr){
int res;
//ctrl+cによる割り込みがあった場合
if(exit_flag == 1){
exit_flag = 0;
P = addr; //後で調べられるように退避
printf("exit eval by CTRL_C_EVENT\n"); fflush(stdout);
longjmp(buf,1);
}
if(atomp(addr)){
if(numberp(addr))
return(addr);
if(symbolp(addr)){
res = findsym(addr);
if(res == 0)
error(CANT_FIND_ERR, "eval", addr);
else
switch(GET_TAG(res)){
case NUM: return(res);
case SYM: return(res);
case LIS: return(res);
case SUBR: return(res);
case FSUBR: return(res);
case LAMBDA:return(GET_BIND(res));
}
}
}
else
if(listp(addr)){
if((symbolp(car(addr))) &&(HAS_NAME(car(addr),"quote")))
return(cadr(addr));
if(numberp(car(addr)))
error(ARG_SYM_ERR, "eval", addr);
if(subrp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
if(fsubrp(car(addr)))
return(apply(car(addr),cdr(addr)));
if(lambdap(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
}
error(CANT_FIND_ERR, "eval", addr);
}
int evlis(int addr){
int car_addr,cdr_addr;
if(IS_NIL(addr))
return(addr);
else{
car_addr = eval(car(addr));
cdr_addr = evlis(cdr(addr));
return(cons(car_addr,cdr_addr));
}
}
int evlis(int addr){
int car_addr,cdr_addr;
argpush(addr);
checkgbc();
if(IS_NIL(addr)){
argpop();
return(addr);
}
else{
car_addr = eval(car(addr));
argpush(car_addr);
cdr_addr = evlis(cdr(addr));
argpop();
argpop();
return(cons(car_addr,cdr_addr));
}
}
alloc_t *eval(alloc_t *e, alloc_t *a) {
eval_op_t eval_op = EVAL;
alloc_t *f;
int i;
/* These three functions are mutually recursive via tail-call.
* We could rewrite to "simplify" the control flow but it
* wouldn't make much difference in the compiled code.
* This way it reflects the Lisp code.
*/
for (i = 0; i < MAX_STEP; i++) {
switch (eval_op) {
case EVAL:
if (atom(e) != nil) {
return cdr(assoc(e, a));
} else if (atom(car(e)) != nil) {
if (eq(car(e), quote_symbol) != nil) {
return car(cdr(e));
} else if (eq(car(e), cond_symbol) != nil) {
eval_op = EVCON;
e = cdr(e);
} else {
eval_op = APPLY;
f = car(e);
e = evlis(cdr(e), a);
}
} else {
eval_op = APPLY;
f = car(e);
e = evlis(cdr(e), a);
}
break;
case APPLY:
if (f == nil) {
longjmp(fatal, ERROR_APPLY_ATOM);
}
if (atom(f) != nil) {
if (eq(f, car_symbol) != nil) {
return car(car(e));
} else if (eq(f, cdr_symbol) != nil) {
return cdr(car(e));
} else if (eq(f, cons_symbol) != nil) {
return cons(car(e), car(cdr(e)));
} else if (eq(f, atom_symbol) != nil) {
return atom(car(e));
} else if (eq(f, eq_symbol) != nil) {
return eq(car(e), car(cdr(e)));
} else {
/* eval_op = APPLY; */
f = eval(f, a);
}
} else if (eq(car(f), lambda_symbol) != nil) {
eval_op = EVAL;
a = pairlis(car(cdr(f)), e, a);
e = car(cdr(cdr(f)));
} else { /* eq(car(f), label_symbol) != nil */
/* eval_op = APPLY */
a = cons(cons(car(cdr(f)), car(cdr(cdr(f)))), a);
f = car(cdr(cdr(f)));
}
break;
default: /* EVCON */
if (e == nil) {
return nil;
} else if (eval(car(car(e)), a) != nil) {
eval_op = EVAL;
e = car(cdr(car(e)));
} else {
/* eval_op = EVCON */
e = cdr(e);
}
break;
}
}
longjmp(fatal, ERROR_STEP);
}
