Fancy error reporting for type errors, among other things.

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

4 files changed, 89 insertions, 76 deletions

diff --git a/llvm.cpp b/llvm.cpp
index b981d7d..a0ec539 100644
--- a/llvm.cpp
+++ b/llvm.cpp
@@ -190,12 +190,17 @@ compileFunction(CEnv& cenv, const std::string& name, const Type* retT, const AST
  * AST Code Generation                                                     *
  ***************************************************************************/
 
+void
+ASTSymbol::lift(CEnv& cenv)
+{
+	if (!cenv.code.ref(this))
+		throw Error((string("undefined symbol `") + cppstr + "'").c_str(), loc);
+}
+
 CValue
 ASTSymbol::compile(CEnv& cenv)
 {
-	AST** c = cenv.code.ref(this);
-	if (!c) throw Error((string("undefined symbol `") + cppstr + "'").c_str(), loc);
-	return cenv.compile(*c);
+	return cenv.compile(*cenv.code.ref(this));
 }
 
 void
@@ -356,14 +361,14 @@ ASTPrimitive::compile(CEnv& cenv)
 
 	// Binary arithmetic operations
 	Instruction::BinaryOps op = (Instruction::BinaryOps)0;
-	if (n == "+") op = Instruction::Add;
-	if (n == "-") op = Instruction::Sub;
-	if (n == "*") op = Instruction::Mul;
-	if (n == "&") op = Instruction::And;
-	if (n == "|") op = Instruction::Or;
-	if (n == "^") op = Instruction::Xor;
-	if (n == "/") op = isInt ? Instruction::SDiv : Instruction::FDiv;
-	if (n == "%") op = isInt ? Instruction::SRem : Instruction::FRem;
+	if (n == "+")   op = Instruction::Add;
+	if (n == "-")   op = Instruction::Sub;
+	if (n == "*")   op = Instruction::Mul;
+	if (n == "and") op = Instruction::And;
+	if (n == "or")  op = Instruction::Or;
+	if (n == "xor") op = Instruction::Xor;
+	if (n == "/")   op = isInt ? Instruction::SDiv : Instruction::FDiv;
+	if (n == "%")   op = isInt ? Instruction::SRem : Instruction::FRem;
 	if (op != 0) {
 		Value* val = cenv.engine.builder.CreateBinOp(op, a, b);
 		for (size_t i = 3; i < size(); ++i)
@@ -394,8 +399,8 @@ ASTConsCall::functionType(CEnv& cenv)
 {
 	ASTTuple* protTypes = new ASTTuple(cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), NULL);
 	AType* cellType = new AType(ASTTuple(cenv.penv.sym("Pair"),
-				cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), NULL));
-	return new AType(ASTTuple(cenv.penv.sym("Fn"), protTypes, cellType, NULL));
+				cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), NULL), Cursor());
+	return new AType(ASTTuple(cenv.penv.sym("Fn"), protTypes, cellType, NULL), loc);
 }
 
 void
diff --git a/tuplr.cpp b/tuplr.cpp
index 0200a36..22632ef 100644
--- a/tuplr.cpp
+++ b/tuplr.cpp
@@ -101,14 +101,14 @@ void
 initLang(PEnv& penv, TEnv& tenv)
 {
 	// Types
-	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")));
+	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()));
 
 	// Literals
 	static bool trueVal  = true;
 	static bool falseVal = false;
-	penv.reg(false, "#t",  PEnv::Handler(parseLiteral<bool>, &trueVal));
+	penv.reg(false, "#t", PEnv::Handler(parseLiteral<bool>, &trueVal));
 	penv.reg(false, "#f", PEnv::Handler(parseLiteral<bool>, &falseVal));
 
 	// Special forms
@@ -120,20 +120,20 @@ initLang(PEnv& penv, TEnv& tenv)
 	penv.reg(true, "cdr",  PEnv::Handler(parseCall<ASTCdrCall>));
 	
 	// Numeric primitives
-	penv.reg(true, "+",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "-",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "*",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "/",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "%",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "&",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "|",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "^",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "=",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "!=", PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, ">",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, ">=", PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "<",  PEnv::Handler(parseCall<ASTPrimitive>));
-	penv.reg(true, "<=", PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "+",   PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "-",   PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "*",   PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "/",   PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "%",   PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "and", PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "or",  PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "xor", PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "=",   PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "!=",  PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, ">",   PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, ">=",  PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "<",   PEnv::Handler(parseCall<ASTPrimitive>));
+	penv.reg(true, "<=",  PEnv::Handler(parseCall<ASTPrimitive>));
 }
 
 
diff --git a/tuplr.hpp b/tuplr.hpp
index 489868a..985bf2f 100644
--- a/tuplr.hpp
+++ b/tuplr.hpp
@@ -33,16 +33,6 @@ using boost::format;
 
 
 /***************************************************************************
- * Backend                                                                 *
- ***************************************************************************/
-
-typedef void* CValue;    ///< Compiled value (opaque)
-typedef void* CFunction; ///< Compiled function (opaque)
-
-struct CEngine; ///< Backend data (opaque)
-
-
-/***************************************************************************
  * Basic Utility Classes                                                   *
  ***************************************************************************/
 
@@ -51,6 +41,7 @@ extern std::ostream& out;
 
 struct Cursor {
 	Cursor(const string& n="", unsigned l=1, unsigned c=0) : name(n), line(l), col(c) {}
+	operator bool() const { return !(line == 1 && col == 0); }
 	string str() const { return (format("%1%:%2%:%3%") % name % line % col).str(); }
 	string   name;
 	unsigned line;
@@ -59,7 +50,7 @@ struct Cursor {
 
 struct Error {
 	Error(const string& m, Cursor c=Cursor()) : msg(m), loc(c) {}
-	const string what() const throw() { return loc.str() + ": error: " + msg; }
+	const string what() const throw() { return (loc ? loc.str() + ": " : "") + "error: " + msg; }
 	string msg;
 	Cursor loc;
 };
@@ -86,6 +77,15 @@ SExp readExpression(Cursor& cur, std::istream& in);
 
 
 /***************************************************************************
+ * Backend                                                                 *
+ ***************************************************************************/
+
+typedef void* CValue;    ///< Compiled value (opaque)
+typedef void* CFunction; ///< Compiled function (opaque)
+struct        CEngine;   ///< Backend data (opaque)
+
+
+/***************************************************************************
  * Abstract Syntax Tree                                                    *
  ***************************************************************************/
 
@@ -94,6 +94,7 @@ struct CEnv; ///< Compile-Time Environment
 
 /// Base class for all AST nodes
 struct AST {
+	AST(Cursor c=Cursor()) : loc(c) {}
 	virtual ~AST() {}
 	virtual string str()                    const = 0;
 	virtual bool   operator==(const AST& o) const = 0;
@@ -101,12 +102,13 @@ struct AST {
 	virtual void   constrain(TEnv& tenv)    const {}
 	virtual void   lift(CEnv& cenv)               {}
 	virtual CValue compile(CEnv& cenv)            = 0;
+	Cursor loc;
 };
 
 /// Literal value
 template<typename VT>
 struct ASTLiteral : public AST {
-	ASTLiteral(VT v) : val(v) {}
+	ASTLiteral(VT v, Cursor c) : AST(c), val(v) {}
 	bool operator==(const AST& rhs) const {
 		const ASTLiteral<VT>* r = dynamic_cast<const ASTLiteral<VT>*>(&rhs);
 		return (r && (val == r->val));
@@ -121,17 +123,17 @@ struct ASTLiteral : public AST {
 struct ASTSymbol : public AST {
 	bool   operator==(const AST& rhs) const { return this == &rhs; }
 	string str()                      const { return cppstr; }
+	void   lift(CEnv& cenv);
 	CValue compile(CEnv& cenv);
 private:
 	friend class PEnv;
-	ASTSymbol(const string& s, Cursor c=Cursor()) : loc(c), cppstr(s) {}
-	Cursor       loc;
+	ASTSymbol(const string& s, Cursor c) : AST(c), cppstr(s) {}
 	const string cppstr;
 };
 
 /// 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*>()) : vector<AST*>(t) {}
+	ASTTuple(const vector<AST*>& t=vector<AST*>(), Cursor c=Cursor()) : AST(c), vector<AST*>(t) {}
 	ASTTuple(size_t size) : vector<AST*>(size) {}
 	ASTTuple(AST* ast, ...) {
 		push_back(ast);
@@ -144,7 +146,7 @@ struct ASTTuple : public AST, public vector<AST*> {
 	string str() const {
 		string ret = "(";
 		for (size_t i = 0; i != size(); ++i)
-			ret += at(i)->str() + ((i != size() - 1) ? " " : "");
+			ret += (at(i) ? at(i)->str() : "NULL") + ((i != size() - 1) ? " " : "");
 		return ret + ")";
 	}
 	bool operator==(const AST& rhs) const {
@@ -173,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) : kind(VAR), id(i) {}
-	AType(ASTSymbol* s) : kind(PRIM), id(0) { push_back(s); }
-	AType(const ASTTuple& t) : ASTTuple(t), kind(EXPR), id(0) {}
+	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) {}
 	string str() const {
 		switch (kind) {
 		case VAR:  return (format("?%1%") % id).str();
@@ -243,7 +245,7 @@ private:
 
 /// Function call/application, e.g. "(func arg1 arg2)"
 struct ASTCall : public ASTTuple {
-	ASTCall(const SExp& e, const ASTTuple& t) : ASTTuple(t), exp(e) {}
+	ASTCall(const SExp& e, const ASTTuple& t) : ASTTuple(t, e.loc), exp(e) {}
 	void   constrain(TEnv& tenv) const;
 	void   lift(CEnv& cenv);
 	CValue compile(CEnv& cenv);
@@ -301,7 +303,7 @@ struct ASTCdrCall : public ASTCall {
  * Parser - S-Expressions (SExp) -> AST Nodes (AST)                        *
  ***************************************************************************/
 
-// Parse Time Environment (symbol table)
+/// Parse Time Environment (symbol table)
 struct PEnv : private map<const string, ASTSymbol*> {
 	typedef AST* (*PF)(PEnv&, const SExp&, void*); // Parse Function
 	struct Handler { Handler(PF f, void* a=0) : func(f), arg(a) {} PF func; void* arg; };
@@ -349,9 +351,9 @@ parseExpression(PEnv& penv, const SExp& exp)
 		return new ASTCall(exp, pmap(penv, exp.list)); // 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));
+			return new ASTLiteral<int32_t>(strtol(exp.atom.c_str(), NULL, 10), exp.loc);
 		else
-			return new ASTLiteral<float>(strtod(exp.atom.c_str(), NULL));
+			return new ASTLiteral<float>(strtod(exp.atom.c_str(), NULL), exp.loc);
 	} else {
 		const PEnv::Handler* handler = penv.handler(false, exp.atom);
 		if (handler) // Dispatch to atom parse function
@@ -371,7 +373,7 @@ template<typename T>
 inline AST*
 parseLiteral(PEnv& penv, const SExp& exp, void* arg)
 {
-	return new ASTLiteral<T>(*reinterpret_cast<T*>(arg));
+	return new ASTLiteral<T>(*reinterpret_cast<T*>(arg), exp.loc);
 }
 
 inline AST*
@@ -379,7 +381,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)),
+			new ASTTuple(pmap(penv, a->list), (*a++).loc),
 			parseExpression(penv, *a++));
 }
 
@@ -421,18 +423,22 @@ struct TSubst : public map<AType*, AType*> {
 /// Type-Time Environment
 struct TEnv : public Env<const AST*,AType*> {
 	TEnv(PEnv& p) : penv(p), varID(1) {}
-	typedef list< pair<AType*, AType*> > Constraints;
-	AType* var() { return new AType(varID++); }
+	struct Constraint : public pair<AType*,AType*> {
+		Constraint(AType* a, AType* b, Cursor c=Cursor()) : pair<AType*,AType*>(a, b), loc(c) {}
+		Cursor loc;
+	};
+	typedef list<Constraint> Constraints;
+	AType* var(Cursor c) { return new AType(varID++, c); }
 	AType* type(const AST* ast) {
 		AType** t = ref(ast);
-		return t ? *t : def(ast, var());
+		return t ? *t : def(ast, var(ast->loc));
 	}
 	AType* named(const string& name) {
 		return *ref(penv.sym(name));
 	}
 	void constrain(const AST* o, AType* t) {
 		assert(!dynamic_cast<const AType*>(o));
-		constraints.push_back(make_pair(type(o), t));
+		constraints.push_back(Constraint(type(o), t, o->loc));
 	}
 	void          solve() { apply(unify(constraints)); }
 	void          apply(const TSubst& substs);
diff --git a/typing.cpp b/typing.cpp
index 071e582..389edf0 100644
--- a/typing.cpp
+++ b/typing.cpp
@@ -17,7 +17,6 @@
 
 #include "tuplr.hpp"
 
-
 /***************************************************************************
  * AST Type Contraints                                                     *
  ***************************************************************************/
@@ -25,7 +24,7 @@
 void
 ASTTuple::constrain(TEnv& tenv) const
 {
-	AType* t = new AType(ASTTuple());
+	AType* t = new AType(ASTTuple(), loc);
 	FOREACH(const_iterator, p, *this) {
 		(*p)->constrain(tenv);
 		t->push_back(tenv.type(*p));
@@ -41,7 +40,7 @@ ASTClosure::constrain(TEnv& tenv) const
 	AType* protT = tenv.type(at(1));
 	AType* bodyT = tenv.type(at(2));
 	tenv.constrain(this, new AType(ASTTuple(
-			tenv.penv.sym("Fn"), protT, bodyT, 0)));
+			tenv.penv.sym("Fn"), protT, bodyT, 0), loc));
 }
 
 void
@@ -50,11 +49,11 @@ ASTCall::constrain(TEnv& tenv) const
 	FOREACH(const_iterator, p, *this)
 		(*p)->constrain(tenv);
 	AType* retT = tenv.type(this);
-	AType* argsT = new AType(ASTTuple());
+	AType* argsT = new AType(ASTTuple(), loc);
 	for (size_t i = 1; i < size(); ++i)
 		argsT->push_back(tenv.type(at(i)));
 	tenv.constrain(at(0), new AType(ASTTuple(
-			tenv.penv.sym("Fn"), argsT, retT, NULL)));
+			tenv.penv.sym("Fn"), argsT, retT, NULL), loc));
 }
 
 void
@@ -91,7 +90,7 @@ ASTPrimitive::constrain(TEnv& tenv) const
 		type = ARITHMETIC;
 	else if (n == "%")
 		type = BINARY;
-	else if (n == "&" || n == "|" || n == "^")
+	else if (n == "and" || n == "or" || n == "xor")
 		type = BITWISE;
 	else if (n == "=" || n == "!=" || n == ">" || n == ">=" || n == "<" || n == "<=")
 		type = COMPARISON;
@@ -106,13 +105,13 @@ ASTPrimitive::constrain(TEnv& tenv) const
 		if (size() < 3)
 			throw Error((format("`%1%' requires at least 2 arguments") % n).str(), exp.loc);
 		for (size_t i = 1; i < size(); ++i)
-			tenv.constrain(this, tenv.type(at(i)));
+			tenv.constrain(at(i), tenv.type(this));
 		break;
 	case BINARY:
 		if (size() != 3)
 			throw Error((format("`%1%' requires exactly 2 arguments") % n).str(), exp.loc);
-		tenv.constrain(this, tenv.type(at(1)));
-		tenv.constrain(this, tenv.type(at(2)));
+		tenv.constrain(at(1), tenv.type(this));
+		tenv.constrain(at(2), tenv.type(this));
 		break;
 	case BITWISE:
 		if (size() != 3)
@@ -127,13 +126,15 @@ ASTPrimitive::constrain(TEnv& tenv) const
 		tenv.constrain(this, tenv.named("Bool"));
 		tenv.constrain(at(1), tenv.type(at(2)));
 		break;
+	default:
+		throw Error((format("unknown primitive `%1%'") % n).str(), exp.loc);
 	}
 }
 
 void
 ASTConsCall::constrain(TEnv& tenv) const
 {
-	AType* t = new AType(ASTTuple(tenv.penv.sym("Pair"), 0));
+	AType* t = new AType(ASTTuple(tenv.penv.sym("Pair"), 0), loc);
 	for (size_t i = 1; i < size(); ++i) {
 		at(i)->constrain(tenv);
 		t->push_back(tenv.type(at(i)));
@@ -145,8 +146,8 @@ void
 ASTCarCall::constrain(TEnv& tenv) const
 {
 	at(1)->constrain(tenv);
-	AType* ct = tenv.var();
-	AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), ct, tenv.var(), 0));
+	AType* ct = tenv.var(loc);
+	AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), ct, tenv.var(at(2)->loc), 0), loc);
 	tenv.constrain(at(1), tt);
 	tenv.constrain(this, ct);
 }
@@ -155,8 +156,8 @@ void
 ASTCdrCall::constrain(TEnv& tenv) const
 {
 	at(1)->constrain(tenv);
-	AType* ct = tenv.var();
-	AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), tenv.var(), ct, 0));
+	AType* ct = tenv.var(loc);
+	AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), tenv.var(at(1)->loc), ct, 0), loc);
 	tenv.constrain(at(1), tt);
 	tenv.constrain(this, ct);
 }
@@ -227,11 +228,12 @@ TEnv::unify(const Constraints& constraints) // TAPL 22.4
 			AType* si = dynamic_cast<AType*>(s->at(i));
 			AType* ti = dynamic_cast<AType*>(t->at(i));
 			if (si && ti)
-				cp.push_back(make_pair(si, ti));
+				cp.push_back(Constraint(si, ti, si->loc));
 		}
 		return unify(cp);
 	} else {
-		throw Error("Type unification failed");
+		throw Error((format("type is `%1%' but should be `%2%'") % s->str() % t->str()).str(),
+				constraints.begin()->loc);
 	}
 }