From 5b71814cafc45b93ad33edb16498861202c5ab12 Mon Sep 17 00:00:00 2001 From: yoyo Date: Thu, 12 Sep 2024 19:53:56 +0900 Subject: [PATCH] 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){