add fnblock return-from

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},

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;

eval.c

@@ -1,6 +1,8 @@
 #include "dat.h"
 #include "fn.h"
 #include <assert.h>
+#include <setjmp.h>
+#include <string.h>
 
 #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);
 }
 

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);

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:

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)

main.c

@@ -31,9 +31,13 @@ SExprint(Object *obj)
 	case OSYMBOL:
 		printf("%s", obj->beg);
 		break;
+	case OBLOCK:
+		printf("\n<block-%s>\n", obj->tag->beg);
+		break;
 	case OFRAME:
-		printf("<frame> %s\n", obj->tag->beg);
+		printf("\n<frame-%s>\n", obj->tag->beg);
 		printexpr(obj->local);
+		printexpr(obj->block);
 		break;
 	case OENV:
 		printf("<env>");
@@ -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");
 }

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];

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){