clisp/eval.c

#include "dat.h"
#include "fn.h"

#define cdr(x) ((x)!= &Nil && (x)->type == OCELL ? (x)->cdr : &Nil)
#define car(x) ((x)!= &Nil && (x)->type == OCELL ? (x)->car : &Nil)

static char *typtab[] = {
	[ONONE] = "error",
	[OBLTIN] = "bltin",
	[OSYMBOL] = "symbol",
	[OCELL] = "cell",
	[OIDENT] = "ident",
	[OSTRING] = "string",
	[OINT] = "int",
	[OFUNC] = "func",
	[OMACRO] = "macro",
	[OENV] = "env",
};

static Object* evallist(Object *env, Object *list);

static int
exprlen(Object *expr)
{
	int l = 0;
	while(expr != &Nil){
		expr = cdr(expr);
		l += 1;
	}
	return l;
}

static int
islist(Object *obj)
{
	return obj == &Nil || obj->type == OCELL;
}

static Object*
clone(Object *p)
{
	switch(p->type){
	default: panic("unreachable");
	case OENV:
	case OSYMBOL:
	case OINT:
	case OIDENT:
	case OBLTIN:
		return p;
	case OMACRO:
	case OFUNC:
		return newfn(gc, p->env, clone(p->params), clone(p->body), p->type);
	case OCELL:
		return newcons(gc, clone(p->car), clone(p->cdr));
	case OSTRING:{
		Object *s = newstr(gc, p->end - p->beg);
		strinit(s, p);
		return s;
		}
	}
}

static Object*
find(Object *env, Object *obj)
{
	for(Object *cur=env; cur!=&Nil; cur=cur->up)
	for(Object *p=cur->vars; p!=&Nil; p=cdr(p)){
		Object *v = car(p);
		if(strequal(obj, car(v)))
			return clone(cdr(v));
	}
	error("not exist variable");
	return 0;
}

static Object*
_newfn(Object *env, Object *l, enum OType type)
{
	if(l->type!=OCELL || islist(l->car)==0 || l->cdr->type!=OCELL)
		error("malformed function");
	for(Object *p=l->car; p->type==OCELL; p=cdr(p))
		if(p->car->type!=OIDENT)
			error("parameter is not IDNET");
	Object *params = l->car;
	Object *body = l->cdr;
	return newfn(gc, env, params, body, type);
}

static Object* 
defvar(Object *env, Object *id, Object *val)
{
	for(Object *p=env->vars; p!=&Nil; p=cdr(p))
		if(strequal(id, car(car(p))))
			error("already exist variable. use setq plz...");
	return newacons(gc, id, val, env->vars);
}

Object*
fnlambda(Object *env, Object *l)
{
	return _newfn(env, l, OFUNC);
}

Object*
fnmacro(Object *env, Object *l)
{
	if(l->type != OCELL)
		error("Malformed macro");
	Object *macro = _newfn(env, l->cdr, OMACRO);
	env->vars = defvar(env, l->car, macro);
	return macro;
}

static Object*
progn(Object *env, Object *list)
{
	Object *r = &Nil;
	for(Object *p=list; p!=&Nil; p=cdr(p)){
		r = eval(env, car(p));
	}
	return r;
}

Object*
fnprogn(Object *env, Object *list)
{
	return progn(env, list);
}

Object*
fnsetq(Object *env, Object *list)
{
	if(exprlen(list)!=2 || list->car->type!=OIDENT)
		error("Malformed setq");
	Object *cur = env;
	Object *p = 0;
	for(; cur!=&Nil; cur=cur->up)
	for(p=cur->vars; p!=&Nil; p=p->cdr)
		if(strequal(list->car, p->car->car))
				goto found;
	error("setq not exist variable");
found:;
	return p->car->cdr = eval(env, list->cdr->car);	
}

Object*
fndefine(Object *env, Object *list)
{
	if(exprlen(list)!=2 || list->car->type!=OIDENT)
		error("Malformed define");
	Object *val = eval(env, list->cdr->car);
	env->vars = defvar(env, list->car, val);
	return val;
}

Object*
fnquote(Object *env, Object *list)
{
	if(exprlen(list)!=1)
		error("Malformed quote");
    return list->car;
}

static Object*
evalcomma(Object *env, Object *p)
{
	if(p->type != OCELL)
		return p;
	if(p->car == &Comma){
		if(car(cdr(p)) == &Splice){
			return newcons(gc, &Splice, eval(env, p->cdr->cdr));
		}else
			return eval(env, p->cdr);
	}
	p->car = evalcomma(env, p->car);
	p->cdr = evalcomma(env, p->cdr);
	if(car(car(p)) == &Splice){
		Object *i = p->car;
		while(cdr(i) != &Nil)
			i = i->cdr;
		if(i->type == OCELL){
			i->cdr = p->cdr;
			return p->car->cdr;
		}
		p->car = i;
	}
	return p;
}

Object*
fnbquote(Object *env, Object *list)
{
	if(exprlen(list) != 1)
		error("Malformed fnbquote");	
	return evalcomma(env, list->car);
}

Object*
fncar(Object *env, Object *list)
{
    list = evallist(env, list);
    if(exprlen(list) < 1)
		error("car: expected list");
	return car(car(list));
}

Object*
fncdr(Object *env, Object *list)
{
    list = evallist(env, list);
    if(exprlen(list) < 1)
		error("cdr: expected list");
	return cdr(car(list));
}

Object*
fncons(Object *env, Object *list)
{
    if(exprlen(list) != 2)
        error("Malformoed cons");
    list = evallist(env, list);
    if(list->type != OCELL)
    	error("cons:bad list");
    list->cdr = car(list->cdr);
    return list;
}

Object*
fnplus(Object *env, Object *list)
{
	long sum = 0;
    Object *p=evallist(env, list);
    for(;p!=&Nil; p=cdr(p)){
		if(p->car->type != OINT)
			error("+ take only number");
		sum += p->car->num;
	}
	return newint(gc, sum);
}

Object*
fnmul(Object *env, Object *list)
{
    Object *p = evallist(env, list);
    if(car(p)->type != OINT)
		error("* take only [INT]");
	long sum = p->car->num;
    for(p=p->cdr;p!=&Nil; p=cdr(p)){
		if(car(p)->type != OINT)
			error("* take only [INT]");
		sum *= p->car->num;
	}
	return newint(gc, sum);
}

Object*
fndiv(Object *env, Object *list)
{
    Object *p=evallist(env, list);
    if(p->car->type != OINT)
		error("/ take only [INT]");
	long sum = p->car->num;
    for(p=p->cdr;p!=&Nil; p=cdr(p)){
		if(car(p)->type != OINT)
			error("/ take only [INT]");
        if(p->car->num == 0)
            error("Can't div zero");
		sum /= p->car->num;
	}
	return newint(gc, sum);
}

Object*
fnmod(Object *env, Object *list)
{
    Object *p=evallist(env, list);
	if(p->car->type != OINT)
		error("%% take only [INT]");
	long sum = p->car->num;
    for(p=p->cdr;p!=&Nil; p=cdr(p)){
		if(car(p)->type != OINT)
			error("%% take only [INT]");
        if(p->car->num == 0)
            error("Can't mod zero");
		sum %= p->car->num;
	}
	return newint(gc, sum);
}

static long
cmp(Object *env, Object *list)
{
    Object *a = eval(env, car(list));
    Object *b = eval(env, car(cdr(list)));
	if(a->type != OINT || b->type != OINT)
		error("cmp only take [INT]");
	return a->num - b->num;	
}

static Object*
_newint(int n)
{
	if(n == 0)
		return &Nil;
	return newint(gc, 1);
}

Object*
fnnot(Object *env, Object *list)
{
	if(exprlen(list) != 1)
		error("Malformed not");
	return _newint(eval(env, car(list)) == &Nil);
}

Object*
fneq(Object *env, Object *list)
{
	return _newint(cmp(env, list) == 0);
}

Object*
fnge(Object *env, Object *list)
{
	return _newint(cmp(env, list) >= 0);
}

Object*
fngt(Object *env, Object *list)
{
	return _newint(cmp(env, list) > 0);
}

Object*
fnle(Object *env, Object *list)
{
	return _newint(cmp(env, list) <= 0);
}

Object*
fnlt(Object *env, Object *list)
{
	return _newint(cmp(env, list) < 0);
}

Object*
fnne(Object *env, Object *list)
{
	return _newint(cmp(env, list) != 0);
}

Object*
fnif(Object *env, Object *list)
{
	if(cdr(list)->type != OCELL)
		error("Malformed if stmt");
	Object *test = list->car;
	Object *then = car(cdr(list));
	Object *else_ = car(cdr(cdr(list)));
	if(eval(env, test)!=&Nil)
		return eval(env, then);
	return eval(env, else_);
}

static Object*
evallist(Object *env, Object *list)
{
	if(list == &Nil)
		return &Nil;
	Object *car = eval(env, car(list));
	Object *cdr = evallist(env, cdr(list));
	return newcons(gc, car, cdr);
}

static Object*
enter(Object *env, Object *vars, Object *args)
{
	Object *map = &Nil;
	for(;vars->type==OCELL; vars=cdr(vars), args=cdr(args)){
		if(args->type!=OCELL)
			error("Cna't apply function argment dose not match");
		Object *id  = car(vars);
		Object *val = car(args);
		map = newacons(gc, id, val, map);
	}
	if(vars != &Nil)
		map = newacons(gc, vars, args, map);
	return newenv(gc, &Nil, map, env);
}

static Object*
applyfn(Object *fn, Object *args)
{
	Object *env = enter(fn->env, fn->params, args);
	return progn(env, fn->body);
}

static Object*
applymacro(Object *env, Object* fn, Object *args)
{
	Object *nenv = enter(fn->env, fn->params, args);
	Object *r = 0;
	for(Object *p=fn->body; p!=&Nil; p=cdr(p)){
		r = eval(nenv, car(p));
	}
	return eval(env, r);
}

static Object*
apply(Object *env, Object *fn, Object *args)
{
	if(islist(args) == 0)
		error("apply:args is not list type");
	switch(fn->type){
	default:
		error("apply:can't eval type");
    case OMACRO:
    	return applymacro(env, fn, args);
	case OBLTIN:{
            Bltinfn blt = bltinlookup(fn);
            return blt(env, args);
        }
	case OFUNC:{
			Object *elist = evallist(env, args);
			Object*res = applyfn(fn, elist);
			return res;
		}
	}
}

Object*
eval(Object *env, Object *obj)
{
	switch(obj->type){
	default:
		error("eval: can't eval type");
	case OSTRING:
	case OINT:
	case OBLTIN:
	case OSYMBOL:
		return obj;
	case OIDENT:
			return find(env, obj);
	case OCELL:{
			Object *fn = eval(env, obj->car);
			Object *res = apply(env, fn, obj->cdr);
			return res;
		}
	}
}