shithub: lpa

--- a/array.c

+++ b/array.c

@@ -151,6 +151,26 @@

 	return buf;

+char *

+printfunc(Function *f) /* Doesn't really belong here.. */

+{

+	char buf[2048]; /* TODO: fixed size :) */

+	char *p = buf;

+	p += sprint(p, "∇");

+	if(f->ast->funcresult)

+		p += sprint(p, "%s←", f->ast->funcresult->name);

+	if(f->ast->funcleftarg)

+		p += sprint(p, "%s ", f->ast->funcleftarg->name);

+	p += sprint(p, "%s", f->ast->funcname->name);

+	if(f->ast->funcrightarg)

+		p += sprint(p, " %s", f->ast->funcrightarg->name);

+	for(uvlong i = 0; i < f->ast->funclocals->childcount; i++)

+		p += sprint(p, ";%s", f->ast->funclocals->children[i]->name);

+	sprint(p, "\n∇");

+	return buf;

+}

 Array *

 simplifyarray(Array *a)

--- a/dat.h

+++ b/dat.h

@@ -13,6 +13,9 @@

 	DataAst,

 	DataByteCode,

 	DataValueStack,

+	DataCallStack,

+	DataFunction,

+	DataLocalList,

 	DataMax,

};

@@ -172,6 +175,8 @@

 	AstLater, /* parse at runtime */

};

+typedef struct ByteCode ByteCode;

 typedef struct Ast Ast;

 struct Ast

@@ -206,7 +211,6 @@

 	NameclassFunc, /* Function value */

};

-typedef struct ByteCode ByteCode;

 struct ByteCode

 	uvlong count;

@@ -221,10 +225,13 @@

 	IStrand,

 	IMonadic,

 	IDyadic,

+	ICall,

 	IClear,

 	IParse,

 	IDone,

-	IJump,

+	IReturn,

+	IAssign,

+	ILocal,

};

 typedef struct ValueStack ValueStack;

@@ -232,4 +239,45 @@

 	uvlong count;

 	void **values;

+};

+typedef struct Local Local;

+struct Local

+{

+	uvlong id;

+	void *value;

+};

+typedef struct LocalList LocalList;

+struct LocalList

+{

+	uvlong count;

+	Local *list;

+};

+typedef struct CallFrame CallFrame;

+struct CallFrame

+{

+	/* Values stored when the frame is pushed */

+	ByteCode *code;

+	uvlong offset;

+	/* Old values of symbols before they were localised */

+	LocalList *locals;

+};

+typedef struct CallStack CallStack;

+struct CallStack

+{

+	uvlong count;

+	CallFrame *frames;

+};

+typedef struct Function Function;

+struct Function

+{

+	Ast *ast;

+	uvlong symbol;

+	ByteCode *code;

+	int prim;

};

\ No newline at end of file

--- a/eval.c

+++ b/eval.c

@@ -39,6 +39,21 @@

 static void

+emitlocal(ByteCode *c, Symtab *s, Ast *a, int assign)

+{

+	if(a == nil)

+		return;

+	uvlong id = sym(s, a->name);

+	emitbyte(c, ILocal);

+	emituvlong(c, id);

+	if(assign){

+		emitbyte(c, IAssign);

+		emituvlong(c, id);

+	}

+}

+static void

 codegensub(Session *s, Module *m, ByteCode *c, Ast *a)

 	char *err;

@@ -53,6 +68,39 @@

 		emitbyte(c, IDone);

 		break;

+	case AstFunc:

+		/* Emit bytecode for the function body */

+		{

+			Function *fn = alloc(DataFunction);

+			fn->ast = a;

+			fn->symbol = sym(m->symtab, a->funcname->name);

+			fn->code = alloc(DataByteCode);

+			emitbyte(fn->code, IPushConst);

+			emitptr(fn->code, fn);

+			emitlocal(fn->code, m->symtab, fn->ast->funcname, 1);

+			emitlocal(fn->code, m->symtab, fn->ast->funcresult, 0);

+			emitlocal(fn->code, m->symtab, fn->ast->funcleftarg, 1);

+			emitlocal(fn->code, m->symtab, fn->ast->funcrightarg, 1);

+			for(i = 0; i < fn->ast->funclocals->childcount; i++)

+				emitlocal(fn->code, m->symtab, fn->ast->funclocals->children[i], 0);

+			for(i = 0; i < a->childcount; i++){

+				if(i != 0)

+					emitbyte(fn->code, IClear);

+				codegensub(s, m, fn->code, a->children[i]);

+			}

+			emitbyte(fn->code, IReturn);

+			emitbyte(c, IPushConst);

+			emitptr(c, fn);

+			/* push the value twice so defining a function yields a function value.. */

+			emitbyte(c, IPushConst);

+			emitptr(c, fn);

+			emitbyte(c, IAssign);

+			emituvlong(c, fn->symbol);

+		}

+		break;

 	case AstName:

 		emitbyte(c, ILookup);

 		emituvlong(c, sym(m->symtab, a->name));

@@ -71,13 +119,19 @@

 	case AstMonadic:

 		codegensub(s, m, c, a->right);

 		codegensub(s, m, c, a->func);

-		emitbyte(c, IMonadic);

+		if(a->func->tag == AstPrim)

+			emitbyte(c, IMonadic);

+		else

+			emitbyte(c, ICall);

 		break;

 	case AstDyadic:

 		codegensub(s, m, c, a->right);

 		codegensub(s, m, c, a->left);

 		codegensub(s, m, c, a->func);

-		emitbyte(c, IDyadic);

+		if(a->func->tag == AstPrim)

+			emitbyte(c, IDyadic);

+		else

+			emitbyte(c, ICall);

 		break;

 	case AstPrim:

 		emitbyte(c, IPushPrim);

@@ -107,7 +161,7 @@

 static void

 pushval(ValueStack *s, void *v)

-	s->count += 1;

+	s->count++;

 	s->values = allocextra(s, s->count * sizeof(v));

 	s->values[s->count-1] = v;

@@ -121,15 +175,57 @@

 	return s->values[s->count];

+static void

+pushcall(CallStack *s, ByteCode *c, uvlong o)

+{

+	s->count++;

+	s->frames = allocextra(s, s->count * sizeof(CallFrame));

+	s->frames[s->count-1].code = c;

+	s->frames[s->count-1].offset = o;

+	s->frames[s->count-1].locals = alloc(DataLocalList);

+}

+static void

+popcall(CallStack *s, Symtab *t, ByteCode **c, uvlong *o)

+{

+	if(s->count == 0)

+		sysfatal("popcall on empty call stack");

+	s->count--; /* no realloc */

+	*c = s->frames[s->count].code;

+	*o = s->frames[s->count].offset;

+	LocalList *locals = s->frames[s->count].locals;

+	for(uvlong i = 0; i < locals->count; i++)

+		symset(t, locals->list[i].id, locals->list[i].value);

+}

+static void

+pushlocal(CallStack *c, Symtab *s, uvlong id)

+{

+	CallFrame f = c->frames[s->count-1];

+	f.locals->count++;

+	f.locals->list = allocextra(f.locals, sizeof(Local) * f.locals->count);

+	f.locals->list[f.locals->count-1].id = id;

+	f.locals->list[f.locals->count-1].value = symval(s, id);

+	symset(s, id, nil);

+}

 static void *

 evalbc(Session *s, Module *m, ByteCode *c)

 	ValueStack *values;

+	CallStack *calls;

+	ByteCode *newcode;

 	uvlong o, v;

-	int prim = 0;

+	Function *func;

 	void *r;

 	values = alloc(DataValueStack);

+	calls = alloc(DataCallStack);

 	debugbc(c);

 	o = 0;

@@ -144,7 +240,11 @@

 			break;

 		case IPushPrim:

 			o += getuvlong(c->instrs+o, &v);

-			prim = v;

+			{

+				Function *f = alloc(DataFunction);

+				f->prim = v;

+				pushval(values, f);

+			}

 			break;

 		case ILookup:

 			o += getuvlong(c->instrs+o, &v);

@@ -165,11 +265,20 @@

 			appendlog(s, "NOTE: monadic call acts like ⊢\n");

 			break;

 		case IDyadic:

-			USED(prim);

-			appendlog(s, "NOTE: dyadic call acts like ⊣\n");

+			appendlog(s, "NOTE: dyadic call acts like ⊢\n");

 			popval(values);

 			break;

-		case IClear:

+		case ICall:

+			func = popval(values);

+			newcode = func->code;

+call:

+			pushcall(calls, c, o);

+			c = newcode;

+			o = 0;

+			print("CALLED:\n");

+			debugbc(c);

+			break;

+		case IClear: /* TODO: get rid of this instruction. It shouldn't be there, and it is wrong */

 			while(values->count > 0)

 				popval(values);

 			break;

@@ -186,15 +295,10 @@

 					appendlog(s, "\n");

 					return nil;

 				}else{

-					uvlong next = o;

-					uvlong start = c->count;

-					codegensub(s, m, c, a);

-					emitbyte(c, IJump);

-					emituvlong(c, next);

-					o = start; /* jump to new code */

-					/* TODO: this adds code every time the instruction is run */

-					print("updated bytecode:\n");

-					debugbc(c);

+					newcode = alloc(DataByteCode);

+					codegensub(s, m, newcode, a);

+					emitbyte(newcode, IReturn);

+					goto call;

 			break;

@@ -201,10 +305,19 @@

 		case IDone:

 			goto done;

 			break;

-		case IJump:

-			getuvlong(c->instrs+o, &v);

-			o = v;

+		case IReturn:

+			popcall(calls, m->symtab, &c, &o);

+			print("RETURNED TO (%ulld)\n", o);

+			debugbc(c);

 			break;

+		case IAssign:

+			o += getuvlong(c->instrs+o, &v);

+			symset(m->symtab, v, popval(values));

+			break;

+		case ILocal:

+			o += getuvlong(c->instrs+o, &v);

+			pushlocal(calls, m->symtab, v);

+			break;

 		default:

 			appendlog(s, "unknown instruction in evalbc\n");

 			return nil;

@@ -213,6 +326,8 @@

 done:

 	r = nil;

+	print("Final value stack size: %ulld\n", values->count);

+	print("Final call stack size: %ulld\n", calls->count);

 	if(values->count != 0)

 		r = popval(values);

 	return r;

--- a/fns.h

+++ b/fns.h

@@ -6,6 +6,7 @@

 void setshape(Array *, int, usize);

 Array *simplifyarray(Array *);

 char *printarray(Array *);

+char *printfunc(Function *);

 /* eval.c */

 void *eval(Session *s, Ast *);

--- a/fs.c

+++ b/fs.c

@@ -280,6 +280,11 @@

 		char *buf = requeststr(r);

 		void *v = parseval(session, buf, &err);

 		free(buf);

+		if(v && getalloctag(v) == DataFunction){

+			Function *f = v;

+			if(strcmp(symb->name, f->ast->funcname->name) != 0)

+				err = "Function name must match symbol name";

+		}

 		if(!err)

 			symset(symb->table, symb->id, v);

--- a/memory.c

+++ b/memory.c

@@ -36,6 +36,9 @@

 	[DataAst] = {.size = sizeof(Ast) },

 	[DataByteCode] = {.size = sizeof(ByteCode) },

 	[DataValueStack] = {.size = sizeof(ValueStack) },

+	[DataCallStack] = {.size = sizeof(CallStack) },

+	[DataFunction] = {.size = sizeof(Function) },

+	[DataLocalList] = {.size = sizeof(LocalList) },

};

 void *

--- a/parse.c

+++ b/parse.c

@@ -136,6 +136,9 @@

 		case DataArray:

 			class = NameclassArray;

 			break;

+		case DataFunction:

+			class = NameclassFunc;

+			break;

 		/* more cases here in the future */

 	}else{

@@ -193,6 +196,7 @@

 			parseseps(t, 1);

 	match(t, TokDel);

 	return func;

@@ -368,7 +372,6 @@

 static Ast *

 parsefunc(TokenList *t)

-	/* TODO: parse primitives as well */

 	Ast *func;

 	if(peek(t) == TokName && peekclass(t) == NameclassFunc)

 		func = parsename(t);

--- a/util.c

+++ b/util.c

@@ -159,11 +159,14 @@

 			print("STRAND %ulld\n", v);

 			break;

 		case IMonadic:

-			print("MONADIC\n");

+			print("MONADIC PRIM\n");

 			break;

 		case IDyadic:

-			print("DYADIC\n");

+			print("DYADIC PRIM\n");

 			break;

+		case ICall:

+			print("CALL\n");

+			break;

 		case IClear:

 			print("CLEAR\n");

 			break;

@@ -174,13 +177,21 @@

 		case IDone:

 			print("DONE\n");

 			break;

-		case IJump:

+		case IReturn:

+			print("RETURN\n");

+			break;

+		case IAssign:

 			o += getuvlong(c->instrs+o, &v);

-			print("JUMP %ulld\n", v);

+			print("ASSIGN %ulld\n", v);

 			break;

+		case ILocal:

+			o += getuvlong(c->instrs+o, &v);

+			print("LOCAL %ulld\n", v);

+			break;

 		default:

 			print("???");

 			return;

+	print("\n");

\ No newline at end of file

--- a/value.c

+++ b/value.c

@@ -18,6 +18,8 @@

 		switch(tag){

 		case DataArray:

 			return smprint("%s\n", printarray(v));

+		case DataFunction:

+			return smprint("%s\n", printfunc(v));

 		default:

 			return smprint("some value of type %d\n", tag);