10 files changed, 257 insertions(+), 90 deletions(-)

M array.c
M dat.h
M error.c
M eval.c
M fns.h
M parse.c
M prim.c
M scan.c
M session.c
M util.c

@@ 226,6 226,11 @@ printfunc(Function *f) /* Doesn't really belong here.. */
 	char buf[2048]; /* TODO: fixed size :) */
 	char *p = buf;
 
+	if(f->ast == nil){
+		sprint(p, "%s", primsymb(f->prim));
+		return buf;
+	}
+	
 	p += sprint(p, "∇");
 	if(f->ast->funcresult)
 		p += sprint(p, "%s←", f->ast->funcresult->name);

@@ 161,6 161,7 @@ enum AstTag
 	AstName,
 	AstLocals,
 	AstAssign,
+	AstNiladic,
 	AstMonadic,
 	AstDyadic,
 	AstConst,


@@ 217,14 218,15 @@ enum Instr
 	IPushPrim,
 	ILookup,
 	IStrand,
+	INiladic,
 	IMonadic,
 	IDyadic,
-	IClear,
 	IParse,
-	IDone,
 	IReturn,
 	IAssign,
 	ILocal,
+	IPop,
+	IDisplay,
 };
 
 typedef struct ValueStack ValueStack;


@@ 268,8 270,10 @@ struct CallStack
 
 enum Valence
 {
-	Monadic = 1<<1,
-	Dyadic = 1<<2,
+	Niladic = 1,
+	Monadic = 2,
+	Dyadic = 4,
+	Variadic = 6,
 };
 
 typedef struct Function Function;


@@ 289,6 293,8 @@ enum ErrorNum
 	EAny, /* 0 = catch any error */
 	ESyntax,
 	EValue,
+	EInternal,
+	EDomain,
 
 	ErrorMax,
 };

@@ 64,6 64,8 @@ errdesc(void)
 	switch(c->num){
 	case ESyntax:	return "SYNTAX ERROR";
 	case EValue:	return "VALUE ERROR";
+	case EInternal:	return "INTERNAL ERROR";
+	case EDomain:	return "DOMAIN ERROR";
 	default:	return "ERROR ???";
 	}
 }

@@ 50,23 50,22 @@ emitlocal(ByteCode *c, Symtab *s, Ast *a, int assign)
 	if(assign){
 		emitbyte(c, IAssign);
 		emituvlong(c, id);
+		emitbyte(c, IPop);
 	}
 }
 
 static void
 codegensub(Session *s, Module *m, ByteCode *c, Ast *a)
 {
-	char *err;
 	uvlong i;
 
 	switch(a->tag){
 	case AstProg:
 		for(i = 0; i < a->childcount; i++){
-			if(i != 0)
-				emitbyte(c, IClear);
 			codegensub(s, m, c, a->children[i]);
+			emitbyte(c, IPop);
+			emitbyte(c, IDisplay);
 		}
-		emitbyte(c, IDone);
 		break;
 	case AstFunc:
 		/* Emit bytecode for the function body */


@@ 77,6 76,10 @@ codegensub(Session *s, Module *m, ByteCode *c, Ast *a)
 				fn->valence = Dyadic;
 			else if(fn->ast->funcrightarg)
 				fn->valence = Monadic;
+			else
+				fn->valence = Niladic;
+			if(fn->ast->funcresult)
+				fn->hasresult = 1;
 
 			fn->symbol = sym(m->symtab, a->funcname->name);
 			fn->code = alloc(DataByteCode);


@@ 90,7 93,7 @@ codegensub(Session *s, Module *m, ByteCode *c, Ast *a)
 				emitlocal(fn->code, m->symtab, fn->ast->funclocals->children[i], 0);
 			for(i = 0; i < a->childcount; i++){
 				codegensub(s, m, fn->code, a->children[i]);
-				emitbyte(fn->code, IClear);
+				emitbyte(fn->code, IPop);
 			}
 			if(fn->ast->funcresult)
 				codegensub(s, m, fn->code, fn->ast->funcresult);


@@ 99,10 102,6 @@ codegensub(Session *s, Module *m, ByteCode *c, Ast *a)
 			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);
 		}


@@ 127,6 126,10 @@ codegensub(Session *s, Module *m, ByteCode *c, Ast *a)
 		emitbyte(c, IStrand);
 		emituvlong(c, a->childcount);
 		break;
+	case AstNiladic:
+		codegensub(s, m, c, a->func);
+		emitbyte(c, INiladic);
+		break;
 	case AstMonadic:
 		codegensub(s, m, c, a->right);
 		codegensub(s, m, c, a->func);


@@ 147,9 150,7 @@ codegensub(Session *s, Module *m, ByteCode *c, Ast *a)
 		emitptr(c, a->tokens);
 		break;
 	default:
-		err = smprint("Don't know how to do codegen for ast type %d\n", a->tag);
-		appendlog(s, err);
-		free(err);
+		error(EInternal, "Don't know how to do codegen for ast type %d", a->tag);
 		break;
 	}
 


@@ 175,11 176,19 @@ static void *
 popval(ValueStack *s)
 {
 	if(s->count == 0)
-		sysfatal("popval on empty value stack");
+		error(EInternal, "popval on empty value stack");
 	s->count--; /* no realloc */
 	return s->values[s->count];
 }
 
+static void *
+peekval(ValueStack *s)
+{
+	if(s->count == 0)
+		error(EInternal, "peekval on empty value stack");
+	return s->values[s->count-1];
+}
+
 static void
 pushcall(CallStack *s, ByteCode *newcode, ByteCode **c, uvlong *o)
 {


@@ 197,7 206,7 @@ static void
 popcall(CallStack *s, Symtab *t, ByteCode **c, uvlong *o)
 {
 	if(s->count == 0)
-		sysfatal("popcall on empty call stack");
+		error(EInternal, "popcall on empty call stack");
 	s->count--; /* no realloc */
 	*c = s->frames[s->count].code;
 	*o = s->frames[s->count].offset;


@@ 220,6 229,26 @@ pushlocal(CallStack *c, Symtab *s, uvlong id)
 	symset(s, id, nil);
 }
 
+static int
+nextinstr(CallStack *calls, ByteCode *c, uvlong o)
+{
+	if(o < c->count && c->instrs[o] != IReturn)
+		return c->instrs[o];
+	if(calls->count == 0)
+		return -1;
+	else{
+		CallFrame f = calls->frames[calls->count-1];
+		return f.code->instrs[f.offset];
+	}
+}
+
+static void
+checkarray(void *val)
+{
+	if(val == nil || getalloctag(val) != DataArray)
+		error(EDomain, "non-array value where an array was expected");
+}
+
 static void *
 evalbc(Session *s, Module *m, ByteCode *c)
 {


@@ 230,12 259,11 @@ evalbc(Session *s, Module *m, ByteCode *c)
 	uvlong o, v;
 	Function *func;
 	void *r;
+	Array *x, *y, *z;
 
 	values = alloc(DataValueStack);
 	calls = alloc(DataCallStack);
 
-	debugbc(c);
-
 	o = 0;
 	while(o < c->count){
 		int instr = c->instrs[o];


@@ 252,6 280,7 @@ evalbc(Session *s, Module *m, ByteCode *c)
 				Function *f = alloc(DataFunction);
 				f->prim = v;
 				f->valence = primvalence(v);
+				f->hasresult = 1;
 				pushval(values, f);
 			}
 			break;


@@ 259,10 288,8 @@ evalbc(Session *s, Module *m, ByteCode *c)
 			o += getuvlong(c->instrs+o, &v);
 			{
 				void *val = symval(m->symtab, v);
-				if(val == nil){
-					appendlog(s, "VALUE ERROR\n");
-					return nil;
-				}
+				if(val == nil)
+					error(EValue, "%s is undefined", symname(m->symtab, v));
 				pushval(values, val);
 			}
 			break;


@@ 271,46 298,84 @@ evalbc(Session *s, Module *m, ByteCode *c)
 			{
 				Array *x = allocarray(TypeArray, 1, v);
 				setshape(x, 0, v);
-				for(uvlong i = 0; i < v; i++)
-					setarray(x, i, popval(values));
+				for(uvlong i = 0; i < v; i++){
+					z = popval(values);
+					checkarray(z);
+					setarray(x, i, z);
+				}
 				x = simplifyarray(x);
 				pushval(values, x);
 			}
 			break;
-		case IMonadic:
+		case INiladic:
 			func = popval(values);
-			if(!(func->valence & Monadic)){
-				appendlog(s, "ERROR: Function not monadic!\n");
-				return nil;
+			if(func->valence != Niladic){
+				int next = nextinstr(calls, c, o);
+				if(next == IAssign || IPop){
+					pushval(values, func);
+					break;
+				}else
+					error(ESyntax, "Function %s is not niladic", funcname(func));
 			}
 
-			if(func->code)
+			if(func->code){
+				if(!func->hasresult){
+					if(nextinstr(calls, c, o) == IPop)
+						pushval(values, nil); /* fake result */
+					else
+						error(ESyntax, "Function %s does not produce a result", funcname(func));
+				}
 				pushcall(calls, func->code, &c, &o);
-			else{
-				Array *y = popval(values);
-				Array *z = primmonad(func->prim, y);
+			}else{
+				z = primnilad(func->prim);
 				pushval(values, z);
 			}
 			break;
-		case IDyadic:
+		case IMonadic:
+			/* FIXME: more duplicated code with INiladic and IDyadic than i would like */
 			func = popval(values);
-			if(!(func->valence & Dyadic)){
-				appendlog(s, "ERROR: Function not dyadic!\n");
-				return nil;
-			}
-
-			if(func->code)
+			y = popval(values);
+			if(!(func->valence & Monadic))
+				error(ESyntax, "Function %s is not monadic", funcname(func));
+			checkarray(y);
+
+			if(func->code){
+				if(!func->hasresult){
+					if(nextinstr(calls, c, o) == IPop)
+						pushval(values, nil); /* fake result */
+					else
+						error(ESyntax, "Function %s does not produce a result", funcname(func));
+				}
+				pushval(values, y);
 				pushcall(calls, func->code, &c, &o);
-			else{
-				Array *x = popval(values);
-				Array *y = popval(values);
-				Array *z = primdyad(func->prim, x, y);
+			}else{
+				z = primmonad(func->prim, y);
 				pushval(values, z);
 			}
 			break;
-		case IClear: /* TODO: get rid of this instruction. It shouldn't be there, and it is wrong */
-			while(values->count > 0)
-				popval(values);
+		case IDyadic:
+			func = popval(values);
+			x = popval(values);
+			y = popval(values);
+			if(!(func->valence & Dyadic))
+				error(ESyntax, "Function %s is not dyadic", funcname(func));
+			checkarray(x);
+			checkarray(y);
+
+			if(func->code){
+				if(!func->hasresult){
+					if(nextinstr(calls, c, o) == IPop)
+						pushval(values, nil); /* fake result */
+					else
+						error(ESyntax, "Function %s does not produce a result", funcname(func));
+				}
+				pushval(values, y);
+				pushval(values, x);
+				pushcall(calls, func->code, &c, &o);
+			}else{
+				z = primdyad(func->prim, x, y);
+				pushval(values, z);
+			}
 			break;
 		case IParse:
 			/* parse at runtime and emit code */


@@ 324,31 389,44 @@ evalbc(Session *s, Module *m, ByteCode *c)
 				pushcall(calls, newcode, &c, &o);
 			}
 			break;
-		case IDone:
-			goto done;
-			break;
 		case IReturn:
 			popcall(calls, m->symtab, &c, &o);
 			break;
 		case IAssign:
 			o += getuvlong(c->instrs+o, &v);
-			symset(m->symtab, v, popval(values));
+			{
+				void *val = popval(values);
+				symset(m->symtab, v, val);
+
+				if(nextinstr(calls, c, o) == IPop)
+					val = nil;
+				pushval(values, val);
+			}
 			break;
 		case ILocal:
 			o += getuvlong(c->instrs+o, &v);
 			pushlocal(calls, m->symtab, v);
 			break;
+		case IPop:
+			r = popval(values);
+			if(nextinstr(calls, c, o) == IDisplay && r != nil)
+				appendlog(s, printval(r));
+			break;
+		case IDisplay:
+			/* nothing to do, IPop checks for it */
+			break;
 		default:
-			appendlog(s, "unknown instruction in evalbc\n");
-			return nil;
+			error(EInternal, "unknown instruction in evalbc: %d", instr);
 		}
 	}
 
-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)
+	if(values->count > 1)
+		error(EInternal, "Value stack size is %ulld", values->count);
+	if(calls->count > 0)
+		error(EInternal, "Call stack size is %ulld", calls->count);
+
+	if(values->count == 1)
 		r = popval(values);
 	return r;
 }

@@ 43,11 43,13 @@ char *primsymb(int);
 int primclass(int);
 int primvalence(int);
 int primid(char *);
+Array *primnilad(int);
 Array *primmonad(int, Array *);
 Array *primdyad(int, Array *, Array *);
 
 /* scan.c */
 TokenList *scan(char *);
+char *printtok(Token);
 
 /* session.c */
 void initsessions(void);


@@ 74,6 76,7 @@ void trim(char *);
 void debugast(Ast *, int);
 void debugbc(ByteCode *);
 int getuvlong(u8int *, uvlong *);
+char *funcname(Function *);
 
 /* value.c */
 char *printval(void *);

@@ 60,7 60,7 @@ static void
 match(TokenList *tokens, int tag)
 {
 	if(peek(tokens) != tag)
-		error(ESyntax, "Unexpected token (match failed)");
+		error(ESyntax, "Unexpected token: %s", printtok(tokens->tokens[tokens->offset]));
 	tokens->offset++;
 }
 


@@ 258,7 258,6 @@ parseexpr(TokenList *t, Symtab *symtab, Ast *func)
 		class = nameclass(name, symtab, func);
 		t->tokens[i].nameclass = class;
 		if(class == 0){ /* We don't know how to parse it until runtime */
-			print("nameclass 0 name: %s funcname: %s\n", name, func ? func->funcname->name : "<no func>");
 			if(symtab)
 				error(EValue, "%s is undefined", name);
 


@@ 300,13 299,17 @@ again:
 	if(peekclass(t) == NameclassFunc){
 func:
 		expr = alloc(DataAst);
-		if(val){
-			expr->tag = AstDyadic;
-			expr->left = val;
-		}else
-			expr->tag = AstMonadic;
 		expr->func = parsefunc(t);
-		expr->right = parseexprsub(t);
+		if(val == nil && (isexprsep(t) || peek(t) == TokRparen))
+			expr->tag = AstNiladic;
+		else{
+			if(val){
+				expr->tag = AstDyadic;
+				expr->left = val;
+			}else
+				expr->tag = AstMonadic;
+			expr->right = parseexprsub(t);
+		}
 		val = expr;
 		goto end;
 	}

@@ 17,13 17,14 @@ static Array *primfn_right(Array *, Array *);
 struct {
 	char *spelling;
 	int nameclass;
+	Array *(*nilad)(void);
 	Array *(*monad)(Array *);
 	Array *(*dyad)(Array *, Array *);
 } primspecs[] = {
-	"⊢", NameclassFunc, primfn_same, primfn_right,
-	"⊣", NameclassFunc, primfn_same, primfn_left,
-	"+", NameclassFunc, nil, nil,
-	"-", NameclassFunc, nil, nil,
+	"⊢", NameclassFunc, nil, primfn_same, primfn_right,
+	"⊣", NameclassFunc, nil, primfn_same, primfn_left,
+	"+", NameclassFunc, nil, nil, nil,
+	"-", NameclassFunc, nil, nil, nil,
 };
 
 char *


@@ 61,14 62,21 @@ primid(char *s)
 }
 
 Array *
+primnilad(int id)
+{
+	if(primspecs[id].nilad)
+		return primspecs[id].nilad();
+	else
+		error(EInternal, "primitive %s has no niladic definition", primsymb(id));
+}
+
+Array *
 primmonad(int id, Array *y)
 {
 	if(primspecs[id].monad)
 		return primspecs[id].monad(y);
-	else{
-		print("primitive %s has no monadic definition! (acts like ⊢)\n", primsymb(id));
-		return y;
-	}
+	else
+		error(EInternal, "primitive %s has no monadic definition", primsymb(id));
 }
 
 Array *


@@ 76,10 84,8 @@ primdyad(int id, Array *x, Array *y)
 {
 	if(primspecs[id].dyad)
 		return primspecs[id].dyad(x, y);
-	else{
-		print("primitive %s has no dyadic definition! (acts like ⊣)\n", primsymb(id));
-		return x;
-	}
+	else
+		error(EInternal, "primitive %s has no dyadic definition", primsymb(id));
 }
 
 /* monadic functions */

@@ 83,4 83,60 @@ next:
 	}
 	newtok(tokens, TokEnd);
 	return tokens;
+}
+
+char *
+printtok(Token t)
+{
+	char buf[1024];
+	char *p = buf;
+
+	switch(t.tag){
+	case TokNumber:
+		sprint(p, "number");
+		break;
+	case TokName: 
+		sprint(p, "name");
+		break;
+	case TokLparen:
+		sprint(p, "(");
+		break;
+	case TokRparen:
+		sprint(p, ")");
+		break;
+	case TokLbrack:
+		sprint(p, "[");
+		break;
+	case TokRbrack:
+		sprint(p, "]");
+		break;
+	case TokLbrace:
+		sprint(p, "{");
+		break;
+	case TokRbrace:
+		sprint(p, "}");
+		break;
+	case TokNewline:
+		sprint(p, "newline");
+		break;
+	case TokDiamond:
+		sprint(p, "⋄");
+		break;
+	case TokPrimitive:
+		sprint(p, "primitive");
+		break;
+	case TokDel:
+		sprint(p, "∇");
+		break;
+	case TokLarrow:
+		sprint(p, "←");
+		break;
+	case TokSemi:
+		sprint(p, ";");
+		break;
+	default:
+		sprint(p, "???");
+	}
+
+	return buf;
 }=
\ No newline at end of file

@@ 42,7 42,7 @@ sessionproc(void *arg)
 
 		if(strlen(buf) > 0 && buf[0] == ')')
 			systemcmd(s, buf+1, 0);
-		else{	
+		else{
 			if(trap(EAny)){
 				appendlog(s, errdesc());
 				appendlog(s, ": ");


@@ 53,11 53,7 @@ sessionproc(void *arg)
 
 			TokenList *tokens = scan(buf);
 			Ast *ast = parse(tokens, 0);
-			debugast(ast, 0);
-			void *val = eval(s, ast);
-			if(val)
-				appendlog(s, printval(val));
-
+			eval(s, ast);
 			endtrap();
 		}
 	}

@@ 158,22 158,19 @@ debugbc(ByteCode *c)
 			o += getuvlong(c->instrs+o, &v);
 			print("STRAND %ulld\n", v);
 			break;
+		case INiladic:
+			print("NILADIC CALL\n");
+			break;
 		case IMonadic:
 			print("MONADIC CALL\n");
 			break;
 		case IDyadic:
 			print("DYADIC CALL\n");
 			break;
-		case IClear:
-			print("CLEAR\n");
-			break;
 		case IParse:
 			o += getuvlong(c->instrs+o, &v);
 			print("PARSE %ulld\n", v);
 			break;
-		case IDone:
-			print("DONE\n");
-			break;
 		case IReturn:
 			print("RETURN\n");
 			break;


@@ 185,10 182,25 @@ debugbc(ByteCode *c)
 			o += getuvlong(c->instrs+o, &v);
 			print("LOCAL %ulld\n", v);
 			break;
+		case IPop:
+			print("POP\n");
+			break;
+		case IDisplay:
+			print("DISPLAY\n");
+			break;
 		default:
 			print("???");
 			return;
 		}
 	}
 	print("\n");
+}
+
+char *
+funcname(Function *f)
+{
+	if(f->ast)
+		return f->ast->funcname->name;
+	else
+		return primsymb(f->prim);
 }=
\ No newline at end of file