diff --git a/bltin.c b/bltin.c index 1d3a086..788bd98 100644 --- a/bltin.c +++ b/bltin.c @@ -2,6 +2,7 @@ #include "fn.h" Object Nil = (Object){.type=OSYMBOL, .beg="nil"}; +Object Top = (Object){.type=OSYMBOL, .beg="top"}; Object Splice= (Object){.type=OSYMBOL, .beg="@"}; Object Comma= (Object){.type=OSYMBOL, .beg=","}; Object Minus= (Object){.type=OBLTIN, .beg="-"}; @@ -20,6 +21,8 @@ Object Not = (Object){.type=OBLTIN, .beg= "not"}; Object Bquote= (Object){.type=OBLTIN, .beg="`"}; Object Lambda= (Object){.type=OBLTIN, .beg="lambda"}; +Object Block= (Object){.type=OBLTIN, .beg="block"}; +Object RetFrom = (Object){.type=OBLTIN, .beg="return-from"}; Object Let= (Object){.type=OBLTIN, .beg="let"}; Object Progn=(Object){.type=OBLTIN, .beg="progn"}; Object Car = (Object){.type=OBLTIN, .beg="car"}; @@ -27,7 +30,7 @@ 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 Macro= (Object){.type=OBLTIN, .beg="defmacro"}; Object Setq = (Object){.type=OBLTIN, .beg="setq"}; Object If = (Object){.type=OBLTIN, .beg="if"}; @@ -38,8 +41,10 @@ extern Object* fnmod(Object *, Object *); extern Object* fnlambda(Object *, Object *); extern Object* fnlet(Object *, Object *); extern Object* fnprogn(Object *, Object *); +extern Object* fnblock(Object *, Object *); +extern Object* fnretfrom(Object *, Object *); extern Object* fndefine(Object *, Object *); -extern Object* fnmacro(Object *, Object *); +extern Object* fndefmacro(Object *, Object *); extern Object* fnsetq(Object *, Object *); extern Object* fnundef(Object *, Object *); extern Object* fnquote(Object *, Object *); @@ -67,12 +72,14 @@ bltinlookup(Object *obj) }bltins[] = { {&Lambda , fnlambda}, {&Progn , fnprogn}, + {&Block , fnblock}, + {&RetFrom ,fnretfrom}, {&Plus , fnplus}, {&Mul , fnmul}, {&Mod , fnmod}, {&Div , fndiv}, {&Define ,fndefine}, - {&Macro ,fnmacro}, + {&Macro ,fndefmacro}, {&Setq ,fnsetq}, {&Let ,fnlet}, {&Quote ,fnquote}, diff --git a/dat.h b/dat.h index cfd3dc2..efc720e 100644 --- a/dat.h +++ b/dat.h @@ -13,6 +13,8 @@ enum OType OINT, OFUNC, OMACRO, + OBLOCK, + OFRAME, OENV, }; @@ -35,23 +37,41 @@ struct Object char *ptr; char *end; }; + /* Block */ + struct{ + Object *_tag; + Object *_up; + Object *_body; + void *jmp; + }; /* function */ struct{ Object *params; + Object *frame; /* running frame */ Object *body; - Object *env; + Object *block; }; - /* env */ + /* Frame */ struct{ - Object *name; + Object *tag; /* Frame enter name */ Object *up; - Object *vars; + Object *local; /* local vars */ + }; + /* Env */ + struct{ + Object *frames; + Object *bp; + Object *sp; /* current */ + Object *retval; /* for return-from */ }; }; }; extern GC *gc; extern Object Nil; +extern Object Top; +extern Object Block; +extern Object RetFrom; extern Object Comma; extern Object Splice; extern Object Bquote; diff --git a/eval.c b/eval.c index 1548200..1787465 100644 --- a/eval.c +++ b/eval.c @@ -1,5 +1,8 @@ #include "dat.h" #include "fn.h" +#include +#include +#include #define cdr(x) ((x)!= &Nil && (x)->type == OCELL ? (x)->cdr : &Nil) #define car(x) ((x)!= &Nil && (x)->type == OCELL ? (x)->car : &Nil) @@ -19,6 +22,35 @@ static char *typtab[] = { static Object* evallist(Object *env, Object *list); +static Object* curblock(Object *env) { return env->sp->car->block; } +static Object* curframe(Object *env) { return env->sp->car; } + +static int +_streq(Object *a, Object *b) +{ + int la = strlen(a->beg); + return la == strlen(b->beg) && memcmp(a->beg, b->beg, la) == 0; +} + +static void +enterframe(Object *env, Object *tag, Object *local, Object *up) +{ + assert(env->bp != &Nil); + Object *frame = newframe(gc, tag, local, up, curblock(env)); + env->sp = env->sp->cdr = newcons(gc, frame, &Nil); +} + +static void +leaveframe(Object *env) +{ + assert(env->sp != env->bp); + Object *p = env->bp; + while(cdr(p) != env->sp) + p = p->cdr; + p->cdr = &Nil; + env->sp = p; +} + static int exprlen(Object *expr) { @@ -41,6 +73,7 @@ clone(Object *p) { switch(p->type){ default: panic("unreachable"); + case OFRAME: case OENV: case OSYMBOL: case OINT: @@ -49,7 +82,7 @@ clone(Object *p) return p; case OMACRO: case OFUNC: - return newfn(gc, p->env, clone(p->params), clone(p->body), p->type); + return newfn(gc, p->frame, clone(p->params), clone(p->body), p->type); case OCELL: return newcons(gc, clone(p->car), clone(p->cdr)); case OSTRING:{ @@ -63,12 +96,10 @@ clone(Object *p) 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)); - } + for(Object *cur=curframe(env); cur!=&Nil; cur=cur->up) + for(Object *p=cur->local; p!=&Nil; p=cdr(p)) + if(strequal(obj, car(car(p)))) + return clone(cdr(car(p))); error("not exist variable"); return 0; } @@ -83,18 +114,19 @@ _newfn(Object *env, Object *l, enum OType type) error("parameter is not IDNET"); Object *params = l->car; Object *body = l->cdr; - return newfn(gc, env, params, body, type); + return newfn(gc, curframe(env), params, body, type); } -static Object* +static void defvar(Object *env, Object *id, Object *val) { if(id->type != OIDENT) error("can't define, already using id"); - for(Object *p=env->vars; p!=&Nil; p=cdr(p)) + Object *frame = env->bp->car; + for(Object *p=frame->local; 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); + frame->local = newacons(gc, id, val, frame->local); } Object* @@ -104,12 +136,12 @@ fnlambda(Object *env, Object *l) } Object* -fnmacro(Object *env, Object *l) +fndefmacro(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); + defvar(env, l->car, macro); return macro; } @@ -129,17 +161,59 @@ fnprogn(Object *env, Object *list) return progn(env, list); } +Object* +fnblock(Object *env, Object *list) +{ + if(list->type != OCELL) + error("Malformed block"); + Object *tag = car(list); + Object *body = cdr(list); + Object *frame = curframe(env); + jmp_buf jmp; + Object *b = frame->block = newblock(gc, tag, curblock(env), body, &jmp); + Object *res = 0; + + if(setjmp(jmp) == 1){ + res = env->retval; + env->retval = 0; + Object *p = curblock(env); + for(;p!=b; p=p->up) + assert(p->tag != &Top); + curframe(env)->block = p->up; + return res; + } + + res = progn(env, body); + frame->block = frame->block->up; + return res; +} + +Object* +fnretfrom(Object *env, Object *list) +{ + if(list->type != OCELL) + error("Malformed return-from"); + Object *tag = car(list); + Object *p = curblock(env); + for(; p!= &Top; p=p->up) + if(_streq(p->tag, tag)){ + env->retval = eval(env, car(cdr(list))); + longjmp(*(jmp_buf*)p->jmp, 1); + } + error("can't excute return-from"); + return 0; +} + Object* fnsetq(Object *env, Object *list) { if(list->type != OCELL || exprlen(list)!=2 || list->car->type!=OIDENT) error("Malformed setq"); - Object *cur = env; - Object *p = &Nil; - for(; cur!=&Nil; cur=cur->up) - for(p=cur->vars; p!=&Nil; p=cdr(p)) + for(Object *frame=curframe(env); frame!=&Nil; frame=frame->up) + for(Object *p=frame->local; p!=&Nil; p=cdr(p)) if(strequal(list->car, car(car(p)))) - return p->car->cdr = eval(env, car(cdr(list))); + return p->car->cdr = eval(env, car(cdr(list))); + error("setq not exist variable"); return 0; } @@ -149,13 +223,16 @@ fnlet(Object *env, Object *list) { if(exprlen(list) < 2) error("let (vars) bodys"); - Object *nenv = newenv(gc, &Nil, &Nil, env) ; - for(Object *p=list->car; p!=&Nil; p=cdr(p)){ - Object *var = car(car(p)); + Object *local = &Nil; + for(Object *p=car(list); p!=&Nil; p=cdr(p)){ + Object *id = car(car(p)); Object *val = eval(env, car(cdr(car(p)))); - nenv->vars = defvar(nenv, var, val); + local = newacons(gc, id, val, local); } - return progn(nenv, cdr(list)); + enterframe(env, &Let, local, curframe(env)); + Object *res = progn(env, cdr(list)); + leaveframe(env); + return res; } Object* @@ -164,7 +241,7 @@ fndefine(Object *env, Object *list) if(exprlen(list)!=2) error("Malformed define"); Object *val = eval(env, car(cdr(list))); - env->vars = defvar(env, car(list), val); + defvar(env, car(list), val); return val; } @@ -206,7 +283,7 @@ fnbquote(Object *env, Object *list) { if(exprlen(list) != 1) error("Malformed fnbquote"); - return evalcomma(env, list->car); + return evalcomma(env, car(list)); } Object* @@ -387,9 +464,10 @@ evallist(Object *env, Object *list) } static Object* -enter(Object *env, Object *vars, Object *args) +applyargs(Object *fn, Object *args) { Object *map = &Nil; + Object *vars = fn->params; for(;vars->type==OCELL; vars=cdr(vars), args=cdr(args)){ if(args != &Nil && args->type!=OCELL) error("Cna't apply function argment dose not match"); @@ -399,44 +477,45 @@ enter(Object *env, Object *vars, Object *args) } if(vars != &Nil) map = newacons(gc, vars, args, map); - return newenv(gc, &Nil, map, env); + return map; } static Object* -applyfn(Object *fn, Object *args) +applyfn(Object *env, Object *tag, Object *fn, Object *args) { - Object *env = enter(fn->env, fn->params, args); - return progn(env, fn->body); + Object *local = applyargs(fn, args); + enterframe(env, tag, local,fn->frame); + Object *res = progn(env, fn->body); + leaveframe(env); + return res; } static Object* -applymacro(Object *env, Object* fn, Object *args) +applymacro(Object *env, Object *tag, 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)); - } + Object *local = applyargs(fn, args); + enterframe(env, tag, local, fn->frame); + Object *r = progn(env, fn->body); + leaveframe(env); return eval(env, r); } static Object* -apply(Object *env, Object *fn, Object *args) +apply(Object *env, Object *tag, 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); + return 0; case OBLTIN:{ Bltinfn blt = bltinlookup(fn); return blt(env, args); } + case OMACRO: + return applymacro(env, tag, fn, args); case OFUNC:{ Object *elist = evallist(env, args); - Object*res = applyfn(fn, elist); + Object*res = applyfn(env, tag, fn, elist); return res; } } @@ -448,6 +527,7 @@ eval(Object *env, Object *obj) switch(obj->type){ default: error("eval: can't eval type"); + return 0; case OSTRING: case OINT: case OBLTIN: @@ -457,7 +537,7 @@ eval(Object *env, Object *obj) return find(env, obj); case OCELL:{ Object *fn = eval(env, obj->car); - Object *res = apply(env, fn, obj->cdr); + Object *res = apply(env, obj->car, fn, obj->cdr); return res; } } diff --git a/fn.h b/fn.h index 76002f0..bd4dd4a 100644 --- a/fn.h +++ b/fn.h @@ -12,11 +12,13 @@ Object* eval(Object *env, Object *expr); /* new */ Object* newint(GC *,long); Object* newcons(GC *,Object*,Object*); -Object* newenv(GC *,Object*name, Object *vars, Object *up); +Object* newenv(GC *gc, Object *frames, Object *bp, Object *sp); +Object* newblock(GC *gc, Object* tag, Object *up, Object *body, void *jmp); +Object* newframe(GC *gc, Object* tag, Object *local, Object *up, Object *block); Object* newacons(GC *,Object*, Object*, Object*); Object* newsymbol(GC *,char*, int); Object* newstr(GC *,int); -Object* newfn(GC *,Object *env, Object *params, Object *body, enum OType type); +Object* newfn(GC *,Object *frame, Object *params, Object *body, enum OType type); /* gc.c */ GC* newgc(void *top, int cap); diff --git a/gc.c b/gc.c index 24d3677..834260b 100644 --- a/gc.c +++ b/gc.c @@ -42,6 +42,7 @@ findobj(GC *gc, uintptr_t *stk) static Object* cloneobj(GC *dst, GC *src, Object *obj) { + if(obj==0)return 0; if(obj->type==OBLTIN||obj->type==OSYMBOL) return obj; if(obj->flag&FORWARD) return obj->forward; @@ -65,17 +66,32 @@ cloneobj(GC *dst, GC *src, Object *obj) p->cdr = cloneobj(dst, src, obj->cdr); break; case OENV: - obj->forward = p = newenv(dst, &Nil, &Nil, &Nil); - p->name = cloneobj(dst, src, obj->name); - p->vars = cloneobj(dst, src, obj->vars); + obj->forward = p = newenv(dst,&Nil, &Nil, &Nil); + p->frames = cloneobj(dst, src, obj->frames); + p->bp = cloneobj(dst, src, obj->bp); + p->sp = cloneobj(dst, src, obj->sp); + p->retval = cloneobj(dst, src, obj->retval); + break; + case OBLOCK: + obj->forward = p = newblock(dst, &Nil, &Nil, &Nil, obj->jmp); + p->tag = cloneobj(dst, src, obj->tag); p->up = cloneobj(dst, src, obj->up); + p->body = cloneobj(dst, src, obj->body); + p->jmp = obj->jmp; + break; + case OFRAME: + obj->forward = p = newframe(dst, &Nil, &Nil, &Nil, &Nil); + p->tag = cloneobj(dst, src, obj->tag); + p->local = cloneobj(dst, src, obj->local); + p->up = cloneobj(dst, src, obj->up); + p->block = cloneobj(dst, src, obj->block); break; case OMACRO: case OFUNC: 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); + p->frame = cloneobj(dst, src, obj->frame); break; } return p; @@ -117,7 +133,7 @@ gcraise(GC *src) static void mark(GC *gc, Object *obj) { - if(obj->flag&USING||obj->type==ONONE||obj->type==OSYMBOL||obj->type==OBLTIN) + if(obj==0||obj->flag&USING||obj->type==ONONE||obj->type==OSYMBOL||obj->type==OBLTIN) return; obj->flag = USING; @@ -128,15 +144,27 @@ mark(GC *gc, Object *obj) mark(gc, obj->cdr); break; case OENV: - mark(gc, obj->name); - mark(gc, obj->vars); + mark(gc, obj->frames); + mark(gc, obj->bp); + mark(gc, obj->sp); + mark(gc, obj->retval); + break; + case OBLOCK: + mark(gc, obj->tag); mark(gc, obj->up); + mark(gc, obj->body); + break; + case OFRAME: + mark(gc, obj->tag); + mark(gc, obj->local); + mark(gc, obj->up); + mark(gc, obj->block); break; case OMACRO: case OFUNC: mark(gc, obj->params); mark(gc, obj->body); - mark(gc, obj->env); + mark(gc, obj->frame); break; } } diff --git a/lib/lib.lisp b/lib/lib.lisp index f9ba664..c958ee1 100644 --- a/lib/lib.lisp +++ b/lib/lib.lisp @@ -1,7 +1,7 @@ -(macro defun (name args body) - `(define ,name (lambda ,args ,body))) +(defmacro defun (name args body) + `(define ,name (block ,name (lambda ,args ,body)))) -(macro cond (expr . rest) +(defmacro cond (expr . rest) (if (not expr) nil (let ((test (car expr))) @@ -9,22 +9,22 @@ (progn ,test ,@(cdr expr)) (cond ,@rest))))) -(macro and (expr . rest) +(defmacro and (expr . rest) (if (not rest) expr (if (cond (not expr) nil) `(and ,@rest)))) -(macro or (expr . rest) +(defmacro or (expr . rest) (if rest (cond (expr) (`(or ,@rest))) expr)) -(macro when (test . rest) +(defmacro when (test . rest) `(if ,test (progn ,@rest))) -(macro unless (test . rest) +(defmacro unless (test . rest) `(if (not ,test) (progn ,@rest))) diff --git a/main.c b/main.c index e943d04..94c42d4 100644 --- a/main.c +++ b/main.c @@ -31,9 +31,17 @@ SExprint(Object *obj) case OSYMBOL: printf("%s", obj->beg); break; + case OBLOCK: + printf("\n\n", obj->tag->beg); + break; + case OFRAME: + printf("\n\n", obj->tag->beg); + printexpr(obj->local); + printexpr(obj->block); + break; case OENV: printf(""); - SExprint(obj->vars); + printexpr(obj->frames); break; case OMACRO: printf(""); @@ -60,7 +68,7 @@ int main(int argc, char *argv[]) { *argv = "lib/lib.lisp"; - gc = newgc(&argc, 400); + gc = newgc(&argc, 24000); lispmain(argv); panic("unreachable"); } diff --git a/obj.c b/obj.c index 8e1213e..38a7dd0 100644 --- a/obj.c +++ b/obj.c @@ -29,15 +29,37 @@ newcons(GC *gc, Object *car, Object *cdr) } Object* -newenv(GC *gc, Object* name, Object *vars, Object *up) +newblock(GC *gc, Object* tag, Object *up, Object *body, void *jmp) { - Object *obj = newobj(gc, OENV, 0); - obj->name = name; + Object *obj = newobj(gc, OBLOCK, 0); + obj->tag = tag; obj->up = up; - obj->vars = vars; + obj->body = body; + obj->jmp = jmp; return obj; } +Object* +newframe(GC *gc, Object* tag, Object *local, Object *up, Object *block) +{ + Object *obj = newobj(gc, OFRAME, 0); + obj->tag = tag; + obj->local = local; + obj->up = up; + obj->block = block; + return obj; +} + +Object* +newenv(GC *gc, Object *frames, Object *bp, Object *sp) +{ + Object *env = newobj(gc, OENV, 0); + env->frames = frames; + env->bp = bp; + env->sp = sp; + return env; +} + Object* newacons(GC *gc, Object *x, Object *y, Object *z) { @@ -46,13 +68,13 @@ newacons(GC *gc, Object *x, Object *y, Object *z) } Object* -newfn(GC *gc, Object *env, Object *params, Object *body, enum OType type) +newfn(GC *gc, Object *frame, Object *params, Object *body, enum OType type) { Object *fn = newobj(gc, type, 0); fn->type = type; fn->params = params; fn->body = body; - fn->env = env; + fn->frame = frame; return fn; } @@ -63,7 +85,7 @@ newsymbol(GC *gc, char *str, int len) &Nil, &Minus, &Plus, &Mul, &Mod, &Div, &Ge, &Le, &Lt, &Gt, &Ne, &Lambda, &Car, &Cdr, &Quote, &Cons, &Define, &Setq, &Eq, &If, &Macro, &Progn, &Bquote, - &Comma, &Not, &Splice, &Let, + &Comma, &Not, &Splice, &Let, &Block, &RetFrom, }; for(int i = 0; i < sizeof(syms)/sizeof(syms[0]); ++i){ Object *c = syms[i]; diff --git a/repl.c b/repl.c index 79a4e1d..1640ec9 100644 --- a/repl.c +++ b/repl.c @@ -46,7 +46,6 @@ repl(Object *env, FILE *f, char *pre) Object *res = nextexpr(f); res = eval(env, res); printexpr(res); - printgc("status", gc); } } @@ -67,7 +66,9 @@ readlib(FILE *f, Object *env) void lispmain(char *argv[]) { - Object *env = newenv(gc , &Nil, &Nil, &Nil); + Object *frame = newframe(gc, &Top, &Nil, &Nil, &Top); + Object *cons = newcons(gc, frame, &Nil); + Object *env = newenv(gc, cons, cons, cons); for(; *argv; ++argv){ FILE *f = fopen(*argv, "r"); if(f == 0)