From b2fd5d250dbc7967189fe6defec4bbeb9824d7fa Mon Sep 17 00:00:00 2001 From: yoyo Date: Fri, 6 Sep 2024 18:18:30 +0900 Subject: [PATCH] add macro --- bltin.c | 9 ++++++ dat.h | 4 +++ eval.c | 97 ++++++++++++++++++++++++++++++++++++++++++-------------- fn.h | 2 +- gc.c | 4 ++- main.c | 6 +++- makefile | 2 +- obj.c | 7 ++-- 8 files changed, 100 insertions(+), 31 deletions(-) diff --git a/bltin.c b/bltin.c index b7f45f1..39c7ef6 100644 --- a/bltin.c +++ b/bltin.c @@ -16,11 +16,14 @@ Object Ne = (Object){.type=OBLTIN, .beg= "!="}; Object Eq = (Object){.type=OBLTIN, .beg= "=="}; Object Lambda= (Object){.type=OBLTIN, .beg="lambda"}; +Object Progn=(Object){.type=OBLTIN, .beg="progn"}; Object Car = (Object){.type=OBLTIN, .beg="car"}; Object Cdr = (Object){.type=OBLTIN, .beg="cdr"}; Object Quote= (Object){.type=OBLTIN, .beg="'"}; Object Cons = (Object){.type=OBLTIN, .beg="cons"}; Object Define= (Object){.type=OBLTIN, .beg="define"}; +Object Macro= (Object){.type=OBLTIN, .beg="macro"}; +Object Defn= (Object){.type=OBLTIN, .beg="defn"}; Object Setq = (Object){.type=OBLTIN, .beg="setq"}; Object If = (Object){.type=OBLTIN, .beg="if"}; @@ -29,7 +32,10 @@ extern Object* fnmul(Object *, Object *); extern Object* fndiv(Object *, Object *); extern Object* fnmod(Object *, Object *); extern Object* fnlambda(Object *, Object *); +extern Object* fnprogn(Object *, Object *); extern Object* fndefine(Object *, Object *); +extern Object* fnmacro(Object *, Object *); +extern Object* fndefn(Object *, Object *); extern Object* fnsetq(Object *, Object *); extern Object* fnundef(Object *, Object *); extern Object* fnquote(Object *, Object *); @@ -54,11 +60,14 @@ bltinlookup(Object *obj) Bltinfn fn; }bltins[] = { {&Lambda , fnlambda}, + {&Progn , fnprogn}, {&Plus , fnplus}, {&Mul , fnmul}, {&Mod , fnmod}, {&Div , fndiv}, {&Define ,fndefine}, + {&Macro ,fnmacro}, + {&Defn ,fndefn}, {&Setq ,fnsetq}, {&Quote ,fnquote}, {&Car ,fncar}, diff --git a/dat.h b/dat.h index c261c77..b134db8 100644 --- a/dat.h +++ b/dat.h @@ -13,6 +13,7 @@ enum OType OINT, OLAMBDA, OFUNC, + OMACRO, OENV, }; @@ -63,6 +64,9 @@ extern Object Cdr; extern Object Quote; extern Object Cons; extern Object Define; +extern Object Progn; +extern Object Macro; +extern Object Defn; extern Object Setq; extern Object Eq; extern Object Ne; diff --git a/eval.c b/eval.c index f8be81d..ac85839 100644 --- a/eval.c +++ b/eval.c @@ -37,22 +37,8 @@ find(Object *env, Object *obj) return 0; } -static Object* -enter(Object *env, Object *vars, Object *args) -{ - Object *map = &Nil; - for(;vars->type==OCELL; vars=vars->cdr,args=args->cdr){ - if(args->type!=OCELL) - error("Cna't apply function argment dose not match"); - Object *id = vars->car; - Object *val = args->car; - map = newacons(gc, id, val, map); - } - return newenv(gc, &Nil, map, env); -} - Object* -fnlambda(Object *env, Object *l) +_newfn(Object *env, Object *l, enum OType type) { if(l->type!=OCELL || islist(l->car)==0 || l->cdr->type!=OCELL) error("malformed function"); @@ -62,7 +48,46 @@ fnlambda(Object *env, Object *l) } Object *params = l->car; Object *body = l->cdr; - return newfn(gc, env, params, body); + return newfn(gc, env, params, body, type); +} + +Object* +fndefn(Object *env, Object *list) +{ + Object *fn = _newfn(env, list->cdr, OFUNC); + env->vars = newacons(gc, list->car, fn, env->vars); + return env->vars; +} + +Object* +fnlambda(Object *env, Object *l) +{ + return _newfn(env, l, OFUNC); +} + +Object* +fnmacro(Object *env, Object *l) +{ + Object *macro = _newfn(env, l->cdr, OMACRO); + env->vars = newacons(gc, l->car, macro, env->vars); + return env->vars; +} + +static Object* +progn(Object *env, Object *list) +{ + Object *r = 0; + for(Object *p=list; p!=&Nil; p=p->cdr){ + r = p->car; + r = eval(env, r); + } + return r; +} + +Object* +fnprogn(Object *env, Object *list) +{ + return progn(env, list); } Object* @@ -258,12 +283,11 @@ fnne(Object *env, Object *list) Object* fnif(Object *env, Object *list) { - if(list == 0 || list == &Nil) - error("Malformed if stmt"); - Object *t = eval(env, list->car->car); - if(istrue(t)) - return eval(env, list->car->cdr->car); - return fnif(env, list->cdr); + Object *test = list->car; + test = eval(env, test); + if(istrue(test)) return eval(env, list->cdr->car); + if(list->cdr->cdr == &Nil) return &Nil; + return eval(env, list->cdr->cdr->car); } static Object* @@ -278,16 +302,39 @@ evallist(Object *env, Object *list) return newcons(gc, car, cdr); } +static Object* +enter(Object *env, Object *vars, Object *args) +{ + Object *map = &Nil; + for(;vars->type==OCELL; vars=vars->cdr,args=args->cdr){ + if(args->type!=OCELL) + error("Cna't apply function argment dose not match"); + Object *id = vars->car; + Object *val = args->car; + 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=p->cdr){ r = p->car; - r = eval(env, r); + r = eval(nenv, r); } - return r; + return eval(env, r); } static Object* @@ -330,6 +377,8 @@ eval(Object *env, Object *obj) } case OCELL:{ Object *fn = eval(env, obj->car); + if(fn->type == OMACRO) + return applymacro(env, fn, obj->cdr); if(fn->type!=OFUNC&&fn->type!=OBLTIN) error("expected function type"); Object *res = apply(env, fn, obj->cdr); diff --git a/fn.h b/fn.h index 650868b..ef362f1 100644 --- a/fn.h +++ b/fn.h @@ -13,7 +13,7 @@ Object* newenv(GC *,Object*name, Object *vars, Object *up); Object* newacons(GC *,Object*, Object*, Object*); Object* newsymbol(GC *,char*, int); Object* newstr(GC *,int); -Object* newfn(GC *,Object *env, Object *params, Object *body); +Object* newfn(GC *,Object *env, Object *params, Object *body, enum OType type); /* gc.c */ GC* newgc(void *top, int cap); diff --git a/gc.c b/gc.c index ef7b81e..e6b362d 100644 --- a/gc.c +++ b/gc.c @@ -71,8 +71,9 @@ cloneobj(GC *dst, GC *src, Object *obj) p->vars = cloneobj(dst, src, obj->vars); p->up = cloneobj(dst, src, obj->up); break; + case OMACRO: case OFUNC: - obj->forward = p = newfn(dst, &Nil, &Nil, &Nil); + obj->forward = p = newfn(dst, &Nil, &Nil, &Nil, obj->type); p->params = cloneobj(dst, src, obj->params); p->body = cloneobj(dst, src, obj->body); p->env = cloneobj(dst, src, obj->env); @@ -132,6 +133,7 @@ mark(GC *gc, Object *obj) mark(gc, obj->vars); mark(gc, obj->up); break; + case OMACRO: case OFUNC: mark(gc, obj->params); mark(gc, obj->body); diff --git a/main.c b/main.c index e1b85fc..204edd5 100644 --- a/main.c +++ b/main.c @@ -38,6 +38,9 @@ SExprint(Object *obj) printf(""); SExprint(obj->vars); break; + case OMACRO: + printf(""); + goto func; case OLAMBDA: printf(""); goto func; @@ -70,6 +73,7 @@ loop(void) } while(1){ Object *res = nextexpr(); + printexpr(res); res = eval(env, res); printgc("status", gc); printf("=============res===========\n"); @@ -83,6 +87,6 @@ loop(void) int main(int argc, char *argv[]) { - gc = newgc(&argc, 500); + gc = newgc(&argc, 4000); loop(); } diff --git a/makefile b/makefile index d59439e..966bb34 100644 --- a/makefile +++ b/makefile @@ -10,7 +10,7 @@ OFILES=\ parser.o AS=$(CC) -c -CFLAGS=-c -g -O2 -Wall -std=c99 +CFLAGS=-c -g -O0 -Wall -std=c99 all: $(NAME) diff --git a/obj.c b/obj.c index 9ed888d..25b2a44 100644 --- a/obj.c +++ b/obj.c @@ -46,9 +46,10 @@ newacons(GC *gc, Object *x, Object *y, Object *z) } Object* -newfn(GC *gc, Object *env, Object *params, Object *body) +newfn(GC *gc, Object *env, Object *params, Object *body, enum OType type) { - Object *fn = newobj(gc, OFUNC, 0); + Object *fn = newobj(gc, type, 0); + fn->type = type; fn->params = params; fn->body = body; fn->env = env; @@ -61,7 +62,7 @@ newsymbol(GC *gc, char *str, int len) static Object *syms[] = { &Nil, &Minus, &Plus, &Mul, &Mod, &Div, &Ge, &Le, &Lt, &Gt, &Ne, &Lambda, &Car, &Cdr, &Quote, &Cons, - &Define, &Setq, &Eq, &If, + &Define, &Setq, &Eq, &If, &Defn, &Macro, &Progn, }; for(int i = 0; i < sizeof(syms)/sizeof(syms[0]); ++i){ Object *c = syms[i];