From 9a12d2ac9fcbbdb7954d58c67d5500dcf30f5301 Mon Sep 17 00:00:00 2001 From: yoyo Date: Thu, 12 Sep 2024 18:30:28 +0900 Subject: [PATCH 1/3] add frame --- bltin.c | 7 +-- dat.h | 16 +++++-- eval.c | 119 ++++++++++++++++++++++++++++++++------------------- fn.h | 5 ++- gc.c | 25 ++++++++--- lib/lib.lisp | 12 +++--- main.c | 6 ++- obj.c | 22 +++++++--- repl.c | 5 ++- 9 files changed, 141 insertions(+), 76 deletions(-) diff --git a/bltin.c b/bltin.c index 1d3a086..6b0e5e3 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="-"}; @@ -27,7 +28,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"}; @@ -39,7 +40,7 @@ extern Object* fnlambda(Object *, Object *); extern Object* fnlet(Object *, Object *); extern Object* fnprogn(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 *); @@ -72,7 +73,7 @@ bltinlookup(Object *obj) {&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..c7ccad7 100644 --- a/dat.h +++ b/dat.h @@ -13,6 +13,7 @@ enum OType OINT, OFUNC, OMACRO, + OFRAME, OENV, }; @@ -39,19 +40,26 @@ struct Object struct{ Object *params; Object *body; - Object *env; + Object *frame; /* running frame */ }; - /* env */ + /* Frame */ struct{ - Object *name; + Object *tag; /* block name */ + Object *local; /* local vars */ Object *up; - Object *vars; + }; + /* Env */ + struct{ + Object *frames; + Object *bp; + Object *sp; /* current */ }; }; }; extern GC *gc; extern Object Nil; +extern Object Top; extern Object Comma; extern Object Splice; extern Object Bquote; diff --git a/eval.c b/eval.c index 1548200..b0fce9b 100644 --- a/eval.c +++ b/eval.c @@ -1,5 +1,6 @@ #include "dat.h" #include "fn.h" +#include #define cdr(x) ((x)!= &Nil && (x)->type == OCELL ? (x)->cdr : &Nil) #define car(x) ((x)!= &Nil && (x)->type == OCELL ? (x)->car : &Nil) @@ -41,6 +42,7 @@ clone(Object *p) { switch(p->type){ default: panic("unreachable"); + case OFRAME: case OENV: case OSYMBOL: case OINT: @@ -49,7 +51,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,14 +65,16 @@ 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)); - } - error("not exist variable"); - return 0; + Object *res = 0; + for(Object *cur=env->sp->car; cur!=&Nil; cur=cur->up) + for(Object *p=cur->local; p!=&Nil; p=cdr(p)) + if(strequal(obj, car(car(p)))){ + res = p; + break; + } + if(res == 0) + error("not exist variable"); + return clone(cdr(car(res))); } static Object* @@ -83,18 +87,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, env->sp->car, 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 +109,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; } @@ -134,28 +139,49 @@ 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=env->sp->car; 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; } +static void +enter(Object *env, Object *tag, Object *local, Object *up) +{ + assert(env->bp != &Nil); + Object *frame = newframe(gc, tag, local, up); + env->sp = env->sp->cdr = newcons(gc, frame, &Nil); +} + +static void +leave(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; +} + Object* 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)); + enter(env, &Let, local, env->sp->car); + Object *res = progn(env, cdr(list)); + leave(env); + return res; } Object* @@ -164,7 +190,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 +232,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 +413,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 +426,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); + enter(env, tag, local,fn->frame); + Object *res = progn(env, fn->body); + leave(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); + enter(env, tag, local, fn->frame); + Object *r = progn(env, fn->body); + leave(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 +476,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 +486,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..07f2fda 100644 --- a/fn.h +++ b/fn.h @@ -12,11 +12,12 @@ 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* newframe(GC *gc, Object* tag, Object *local, 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, 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..19bf5c0 100644 --- a/gc.c +++ b/gc.c @@ -65,9 +65,15 @@ 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); + break; + case OFRAME: + obj->forward = p = newframe(dst, &Nil, &Nil, &Nil); + p->tag = cloneobj(dst, src, obj->tag); + p->local = cloneobj(dst, src, obj->local); p->up = cloneobj(dst, src, obj->up); break; case OMACRO: @@ -75,7 +81,7 @@ cloneobj(GC *dst, GC *src, Object *obj) 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; @@ -128,15 +134,20 @@ 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); + break; + case OFRAME: + mark(gc, obj->tag); + mark(gc, obj->local); mark(gc, obj->up); 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..17de461 100644 --- a/lib/lib.lisp +++ b/lib/lib.lisp @@ -1,7 +1,7 @@ -(macro defun (name args body) +(defmacro defun (name args body) `(define ,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..f26a1be 100644 --- a/main.c +++ b/main.c @@ -31,9 +31,13 @@ SExprint(Object *obj) case OSYMBOL: printf("%s", obj->beg); break; + case OFRAME: + printf(" %s\n", obj->tag->beg); + printexpr(obj->local); + break; case OENV: printf(""); - SExprint(obj->vars); + printexpr(obj->frames); break; case OMACRO: printf(""); diff --git a/obj.c b/obj.c index 8e1213e..dd214e8 100644 --- a/obj.c +++ b/obj.c @@ -29,15 +29,25 @@ newcons(GC *gc, Object *car, Object *cdr) } Object* -newenv(GC *gc, Object* name, Object *vars, Object *up) +newframe(GC *gc, Object* tag, Object *local, Object *up) { - Object *obj = newobj(gc, OENV, 0); - obj->name = name; + Object *obj = newobj(gc, OFRAME, 0); + obj->tag = tag; + obj->local = local; obj->up = up; - obj->vars = vars; 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 +56,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; } diff --git a/repl.c b/repl.c index 79a4e1d..e2bf01f 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); + Object *cons = newcons(gc, frame, &Nil); + Object *env = newenv(gc, cons, cons, cons); for(; *argv; ++argv){ FILE *f = fopen(*argv, "r"); if(f == 0) From 07300eff7caea370b56e4ce7dab39890ac8c0508 Mon Sep 17 00:00:00 2001 From: yoyo Date: Thu, 12 Sep 2024 19:01:13 +0900 Subject: [PATCH 2/3] fix eval.c:find logic --- eval.c | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/eval.c b/eval.c index b0fce9b..f309924 100644 --- a/eval.c +++ b/eval.c @@ -65,16 +65,12 @@ clone(Object *p) static Object* find(Object *env, Object *obj) { - Object *res = 0; for(Object *cur=env->sp->car; cur!=&Nil; cur=cur->up) for(Object *p=cur->local; p!=&Nil; p=cdr(p)) - if(strequal(obj, car(car(p)))){ - res = p; - break; - } - if(res == 0) - error("not exist variable"); - return clone(cdr(car(res))); + if(strequal(obj, car(car(p)))) + return clone(cdr(car(p))); + error("not exist variable"); + return 0; } static Object* From 5b71814cafc45b93ad33edb16498861202c5ab12 Mon Sep 17 00:00:00 2001 From: yoyo Date: Thu, 12 Sep 2024 19:53:56 +0900 Subject: [PATCH 3/3] add fnblock return-from --- bltin.c | 6 +++ dat.h | 20 ++++++++-- eval.c | 111 ++++++++++++++++++++++++++++++++++++++------------- fn.h | 3 +- gc.c | 21 +++++++++- lib/lib.lisp | 2 +- main.c | 8 +++- obj.c | 16 +++++++- repl.c | 2 +- 9 files changed, 148 insertions(+), 41 deletions(-) diff --git a/bltin.c b/bltin.c index 6b0e5e3..788bd98 100644 --- a/bltin.c +++ b/bltin.c @@ -21,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"}; @@ -39,6 +41,8 @@ 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* fndefmacro(Object *, Object *); extern Object* fnsetq(Object *, Object *); @@ -68,6 +72,8 @@ bltinlookup(Object *obj) }bltins[] = { {&Lambda , fnlambda}, {&Progn , fnprogn}, + {&Block , fnblock}, + {&RetFrom ,fnretfrom}, {&Plus , fnplus}, {&Mul , fnmul}, {&Mod , fnmod}, diff --git a/dat.h b/dat.h index c7ccad7..efc720e 100644 --- a/dat.h +++ b/dat.h @@ -13,6 +13,7 @@ enum OType OINT, OFUNC, OMACRO, + OBLOCK, OFRAME, OENV, }; @@ -36,23 +37,32 @@ struct Object char *ptr; char *end; }; + /* Block */ + struct{ + Object *_tag; + Object *_up; + Object *_body; + void *jmp; + }; /* function */ struct{ Object *params; - Object *body; Object *frame; /* running frame */ + Object *body; + Object *block; }; /* Frame */ struct{ - Object *tag; /* block name */ - Object *local; /* local vars */ + Object *tag; /* Frame enter name */ Object *up; + Object *local; /* local vars */ }; /* Env */ struct{ Object *frames; Object *bp; - Object *sp; /* current */ + Object *sp; /* current */ + Object *retval; /* for return-from */ }; }; }; @@ -60,6 +70,8 @@ struct Object 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 f309924..1787465 100644 --- a/eval.c +++ b/eval.c @@ -1,6 +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) @@ -20,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) { @@ -65,7 +96,7 @@ clone(Object *p) static Object* find(Object *env, Object *obj) { - for(Object *cur=env->sp->car; cur!=&Nil; cur=cur->up) + 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))); @@ -83,7 +114,7 @@ _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->sp->car, params, body, type); + return newfn(gc, curframe(env), params, body, type); } static void @@ -130,12 +161,55 @@ 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"); - for(Object *frame=env->sp->car; frame!=&Nil; frame=frame->up) + 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))); @@ -144,25 +218,6 @@ fnsetq(Object *env, Object *list) return 0; } -static void -enter(Object *env, Object *tag, Object *local, Object *up) -{ - assert(env->bp != &Nil); - Object *frame = newframe(gc, tag, local, up); - env->sp = env->sp->cdr = newcons(gc, frame, &Nil); -} - -static void -leave(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; -} - Object* fnlet(Object *env, Object *list) { @@ -174,9 +229,9 @@ fnlet(Object *env, Object *list) Object *val = eval(env, car(cdr(car(p)))); local = newacons(gc, id, val, local); } - enter(env, &Let, local, env->sp->car); + enterframe(env, &Let, local, curframe(env)); Object *res = progn(env, cdr(list)); - leave(env); + leaveframe(env); return res; } @@ -429,9 +484,9 @@ static Object* applyfn(Object *env, Object *tag, Object *fn, Object *args) { Object *local = applyargs(fn, args); - enter(env, tag, local,fn->frame); + enterframe(env, tag, local,fn->frame); Object *res = progn(env, fn->body); - leave(env); + leaveframe(env); return res; } @@ -439,9 +494,9 @@ static Object* applymacro(Object *env, Object *tag, Object* fn, Object *args) { Object *local = applyargs(fn, args); - enter(env, tag, local, fn->frame); + enterframe(env, tag, local, fn->frame); Object *r = progn(env, fn->body); - leave(env); + leaveframe(env); return eval(env, r); } diff --git a/fn.h b/fn.h index 07f2fda..bd4dd4a 100644 --- a/fn.h +++ b/fn.h @@ -13,7 +13,8 @@ Object* eval(Object *env, Object *expr); Object* newint(GC *,long); Object* newcons(GC *,Object*,Object*); Object* newenv(GC *gc, Object *frames, Object *bp, Object *sp); -Object* newframe(GC *gc, Object* tag, Object *local, Object *up); +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); diff --git a/gc.c b/gc.c index 19bf5c0..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; @@ -69,12 +70,21 @@ cloneobj(GC *dst, GC *src, Object *obj) 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); + 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: @@ -123,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; @@ -137,11 +147,18 @@ mark(GC *gc, Object *obj) 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: diff --git a/lib/lib.lisp b/lib/lib.lisp index 17de461..c958ee1 100644 --- a/lib/lib.lisp +++ b/lib/lib.lisp @@ -1,5 +1,5 @@ (defmacro defun (name args body) - `(define ,name (lambda ,args ,body))) + `(define ,name (block ,name (lambda ,args ,body)))) (defmacro cond (expr . rest) (if (not expr) diff --git a/main.c b/main.c index f26a1be..94c42d4 100644 --- a/main.c +++ b/main.c @@ -31,9 +31,13 @@ SExprint(Object *obj) case OSYMBOL: printf("%s", obj->beg); break; + case OBLOCK: + printf("\n\n", obj->tag->beg); + break; case OFRAME: - printf(" %s\n", obj->tag->beg); + printf("\n\n", obj->tag->beg); printexpr(obj->local); + printexpr(obj->block); break; case OENV: printf(""); @@ -64,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 dd214e8..38a7dd0 100644 --- a/obj.c +++ b/obj.c @@ -29,12 +29,24 @@ newcons(GC *gc, Object *car, Object *cdr) } Object* -newframe(GC *gc, Object* tag, Object *local, Object *up) +newblock(GC *gc, Object* tag, Object *up, Object *body, void *jmp) +{ + Object *obj = newobj(gc, OBLOCK, 0); + obj->tag = tag; + obj->up = up; + 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; } @@ -73,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 e2bf01f..1640ec9 100644 --- a/repl.c +++ b/repl.c @@ -66,7 +66,7 @@ readlib(FILE *f, Object *env) void lispmain(char *argv[]) { - Object *frame = newframe(gc, &Top, &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){