Typing improvements.

More location information.


git-svn-id: http://svn.drobilla.net/resp/tuplr@67 ad02d1e2-f140-0410-9f75-f8b11f17cedd

4 files changed, 55 insertions, 40 deletions

diff --git a/llvm.cpp b/llvm.cpp
index a0ec539..1717160 100644
--- a/llvm.cpp
+++ b/llvm.cpp
@@ -67,8 +67,6 @@ lltype(AType* t)
 			for (size_t i = 1; i < t->size(); ++i)
 				types.push_back(lltype(dynamic_cast<AType*>(t->at(i))));
 			return PointerType::get(StructType::get(types, false), 0);
-		} else {
-			throw Error(string("Unknown composite type `") + t->str() + "'");
 		}
 	}
 	return NULL; // not reached
@@ -237,6 +235,29 @@ ASTClosure::lift(CEnv& cenv)
 	cenv.pop();
 }
 
+template<typename T>
+T
+checked_cast(AST* ast)
+{
+	T t = dynamic_cast<T>(ast);
+	if (!t)
+		throw Error((format("internal error: `%1%' should be a `%2%'")
+				% typeid(ast).name() % typeid(T).name()).str(), ast->loc);
+	return t;
+}
+
+static
+AST*
+maybeLookup(CEnv& cenv, AST* ast)
+{
+	ASTSymbol* s = dynamic_cast<ASTSymbol*>(ast);
+	if (s) {
+		AST** val = cenv.code.ref(s);
+		if (val) return *val;
+	}
+	return ast;
+}
+
 CValue
 ASTClosure::compile(CEnv& cenv)
 {
@@ -246,17 +267,13 @@ ASTClosure::compile(CEnv& cenv)
 void
 ASTCall::lift(CEnv& cenv)
 {
-	ASTClosure* c = dynamic_cast<ASTClosure*>(at(0));
-	if (!c) {
-		AST** val = cenv.code.ref(at(0));
-		c = (val) ? dynamic_cast<ASTClosure*>(*val) : c;
-	}
-
+	ASTClosure* c = dynamic_cast<ASTClosure*>(maybeLookup(cenv, at(0)));
+	
 	// Lift arguments
 	for (size_t i = 1; i < size(); ++i)
 		at(i)->lift(cenv);
-
-	if (!c) return;
+	
+	if (!c) return; // Primitive
 
 	// Extend environment with bound and typed parameters
 	cenv.push();
@@ -266,7 +283,7 @@ ASTCall::lift(CEnv& cenv)
 		throw Error((format("too few arguments to function `%1%'") % at(0)->str()).str(), exp.loc);
 
 	for (size_t i = 1; i < size(); ++i)
-		cenv.code.def(c->prot()->at(i-1), at(i));
+		cenv.code.def(checked_cast<ASTSymbol*>(c->prot()->at(i-1)), at(i));
 
 	c->lift(cenv); // Lift called closure
 	cenv.pop(); // Restore environment
@@ -275,13 +292,7 @@ ASTCall::lift(CEnv& cenv)
 CValue
 ASTCall::compile(CEnv& cenv)
 {
-	ASTClosure* c = dynamic_cast<ASTClosure*>(at(0));
-	if (!c) {
-		AST** val = cenv.code.ref(at(0));
-		c = (val) ? dynamic_cast<ASTClosure*>(*val) : c;
-	}
-
-	assert(c);
+	AST*      c = maybeLookup(cenv, at(0));
 	Function* f = dynamic_cast<Function*>(LLVal(cenv.compile(c)));
 	if (!f) throw Error("callee failed to compile", exp.loc);
 
@@ -295,7 +306,7 @@ ASTCall::compile(CEnv& cenv)
 void
 ASTDefinition::lift(CEnv& cenv)
 {
-	if (cenv.code.ref((ASTSymbol*)at(1)))
+	if (cenv.code.ref(checked_cast<ASTSymbol*>(at(1))))
 		throw Error(string("`") + at(1)->str() + "' redefined", exp.loc);
 	cenv.code.def((ASTSymbol*)at(1), at(2)); // Define first for recursion
 	at(2)->lift(cenv);
@@ -465,8 +476,8 @@ ASTConsCall::compile(CEnv& cenv)
 CValue
 ASTCarCall::compile(CEnv& cenv)
 {
-	AST**  arg  = cenv.code.ref(at(1));
-	Value* sP   = LLVal(arg ? (*arg)->compile(cenv) : at(1)->compile(cenv));
+	AST*   arg  = maybeLookup(cenv, at(1));
+	Value* sP   = LLVal(cenv.compile(arg));
 	Value* s    = cenv.engine.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair");
 	Value* carP = cenv.engine.builder.CreateStructGEP(s, 0, "car");
 	return cenv.engine.builder.CreateLoad(carP);
@@ -475,8 +486,8 @@ ASTCarCall::compile(CEnv& cenv)
 CValue
 ASTCdrCall::compile(CEnv& cenv)
 {
-	AST**  arg  = cenv.code.ref(at(1));
-	Value* sP   = LLVal(arg ? (*arg)->compile(cenv) : at(1)->compile(cenv));
+	AST*   arg  = maybeLookup(cenv, at(1));
+	Value* sP   = LLVal(cenv.compile(arg));
 	Value* s    = cenv.engine.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair");
 	Value* cdrP = cenv.engine.builder.CreateStructGEP(s, 1, "cdr");
 	return cenv.engine.builder.CreateLoad(cdrP);
diff --git a/tuplr.cpp b/tuplr.cpp
index 22632ef..c726cc6 100644
--- a/tuplr.cpp
+++ b/tuplr.cpp
@@ -101,9 +101,9 @@ void
 initLang(PEnv& penv, TEnv& tenv)
 {
 	// Types
-	tenv.def(penv.sym("Bool"),  new AType(penv.sym("Bool"), Cursor()));
-	tenv.def(penv.sym("Int"),   new AType(penv.sym("Int"), Cursor()));
-	tenv.def(penv.sym("Float"), new AType(penv.sym("Float"), Cursor()));
+	tenv.def(penv.sym("Bool"),  new AType(penv.sym("Bool")));
+	tenv.def(penv.sym("Int"),   new AType(penv.sym("Int")));
+	tenv.def(penv.sym("Float"), new AType(penv.sym("Float")));
 
 	// Literals
 	static bool trueVal  = true;
diff --git a/tuplr.hpp b/tuplr.hpp
index 985bf2f..54f48b2 100644
--- a/tuplr.hpp
+++ b/tuplr.hpp
@@ -134,7 +134,7 @@ private:
 /// Tuple (heterogeneous sequence of fixed length), e.g. "(a b c)"
 struct ASTTuple : public AST, public vector<AST*> {
 	ASTTuple(const vector<AST*>& t=vector<AST*>(), Cursor c=Cursor()) : AST(c), vector<AST*>(t) {}
-	ASTTuple(size_t size) : vector<AST*>(size) {}
+	ASTTuple(size_t size, Cursor c) : AST(c), vector<AST*>(size) {}
 	ASTTuple(AST* ast, ...) {
 		push_back(ast);
 		va_list args;
@@ -175,9 +175,9 @@ struct ASTTuple : public AST, public vector<AST*> {
 
 /// Type Expression, e.g. "Int", "(Fn (Int Int) Float)"
 struct AType : public ASTTuple {
-	AType(unsigned i, Cursor c) : kind(VAR), id(i) {}
-	AType(ASTSymbol* s, Cursor c) : kind(PRIM), id(0) { push_back(s); }
-	AType(const ASTTuple& t, Cursor c) : ASTTuple(t), kind(EXPR), id(0) {}
+	AType(unsigned i, Cursor c=Cursor()) : ASTTuple(0, c), kind(VAR), id(i) {}
+	AType(ASTSymbol* s) : ASTTuple(0, s->loc), kind(PRIM), id(0) { push_back(s); }
+	AType(const ASTTuple& t, Cursor c) : ASTTuple(t, c), kind(EXPR), id(0) {}
 	string str() const {
 		switch (kind) {
 		case VAR:  return (format("?%1%") % id).str();
@@ -329,11 +329,12 @@ struct PEnv : private map<const string, ASTSymbol*> {
 static AST* parseExpression(PEnv& penv, const SExp& exp);
 
 static ASTTuple
-pmap(PEnv& penv, const SExp::List& l)
+pmap(PEnv& penv, const SExp& e)
 {
-	ASTTuple ret(l.size());
+	assert(e.type == SExp::LIST);
+	ASTTuple ret(e.list.size(), e.loc);
 	size_t n = 0;
-	FOREACH(SExp::List::const_iterator, i, l)
+	FOREACH(SExp::List::const_iterator, i, e.list)
 		ret[n++] = parseExpression(penv, *i);
 	return ret;
 }
@@ -348,7 +349,7 @@ parseExpression(PEnv& penv, const SExp& exp)
 			if (handler) // Dispatch to list parse function
 				return handler->func(penv, exp, handler->arg);
 		}
-		return new ASTCall(exp, pmap(penv, exp.list)); // Parse as regular call
+		return new ASTCall(exp, pmap(penv, exp)); // Parse as regular call
 	} else if (isdigit(exp.atom[0])) {
 		if (exp.atom.find('.') == string::npos)
 			return new ASTLiteral<int32_t>(strtol(exp.atom.c_str(), NULL, 10), exp.loc);
@@ -366,7 +367,7 @@ template<typename C>
 inline AST*
 parseCall(PEnv& penv, const SExp& exp, void* arg)
 {
-	return new C(exp, pmap(penv, exp.list));
+	return new C(exp, pmap(penv, exp));
 }
 
 template<typename T>
@@ -381,7 +382,7 @@ parseFn(PEnv& penv, const SExp& exp, void* arg)
 {
 	SExp::List::const_iterator a = exp.list.begin(); ++a;
 	return new ASTClosure(
-			new ASTTuple(pmap(penv, a->list), (*a++).loc),
+			new ASTTuple(pmap(penv, *a), (*a++).loc),
 			parseExpression(penv, *a++));
 }
 
@@ -428,7 +429,7 @@ struct TEnv : public Env<const AST*,AType*> {
 		Cursor loc;
 	};
 	typedef list<Constraint> Constraints;
-	AType* var(Cursor c) { return new AType(varID++, c); }
+	AType* var(Cursor c=Cursor()) { return new AType(varID++, c); }
 	AType* type(const AST* ast) {
 		AType** t = ref(ast);
 		return t ? *t : def(ast, var(ast->loc));
@@ -461,7 +462,7 @@ struct CEnv {
 	CEnv(PEnv& p, TEnv& t, CEngine& engine);
 	~CEnv();
 	
-	typedef Env<const AST*, AST*>   Code;
+	typedef Env<const ASTSymbol*, AST*>   Code;
 	typedef Env<const AST*, CValue> Vals;
 	
 	string gensym(const char* s="_") { return (format("%s%d") % s % symID++).str(); }
diff --git a/typing.cpp b/typing.cpp
index 389edf0..c9febda 100644
--- a/typing.cpp
+++ b/typing.cpp
@@ -134,6 +134,7 @@ ASTPrimitive::constrain(TEnv& tenv) const
 void
 ASTConsCall::constrain(TEnv& tenv) const
 {
+	if (size() != 3) throw Error("`cons' requires exactly 2 arguments", loc);
 	AType* t = new AType(ASTTuple(tenv.penv.sym("Pair"), 0), loc);
 	for (size_t i = 1; i < size(); ++i) {
 		at(i)->constrain(tenv);
@@ -145,9 +146,10 @@ ASTConsCall::constrain(TEnv& tenv) const
 void
 ASTCarCall::constrain(TEnv& tenv) const
 {
+	if (size() != 2) throw Error("`car' requires exactly 1 argument", loc);
 	at(1)->constrain(tenv);
 	AType* ct = tenv.var(loc);
-	AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), ct, tenv.var(at(2)->loc), 0), loc);
+	AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), ct, tenv.var(), 0), loc);
 	tenv.constrain(at(1), tt);
 	tenv.constrain(this, ct);
 }
@@ -155,9 +157,10 @@ ASTCarCall::constrain(TEnv& tenv) const
 void
 ASTCdrCall::constrain(TEnv& tenv) const
 {
+	if (size() != 2) throw Error("`cdr' requires exactly 1 argument", loc);
 	at(1)->constrain(tenv);
 	AType* ct = tenv.var(loc);
-	AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), tenv.var(at(1)->loc), ct, 0), loc);
+	AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), tenv.var(), ct, 0), loc);
 	tenv.constrain(at(1), tt);
 	tenv.constrain(this, ct);
 }