. operator for destructuring Tuples (cons).

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

10 files changed, 81 insertions, 9 deletions

diff --git a/src/c.cpp b/src/c.cpp
index ae1b71d..4e9a49f 100644
--- a/src/c.cpp
+++ b/src/c.cpp
@@ -137,6 +137,7 @@ struct CEngine : public Engine {
 	CFunc compileFunction(CEnv& cenv, AFn* fn, const AType& argsT);
 
 	CVal compileTup(CEnv& cenv, const AType* type, const vector<CVal>& fields);
+	CVal compileDot(CEnv& cenv, CVal tup, int32_t index);
 	CVal compileLiteral(CEnv& cenv, AST* lit);
 	CVal compilePrimitive(CEnv& cenv, APrimitive* prim);
 	CVal compileIf(CEnv& cenv, AIf* aif);
@@ -170,6 +171,12 @@ CEngine::compileTup(CEnv& cenv, const AType* type, const vector<CVal>& fields)
 }
 
 CVal
+CEngine::compileDot(CEnv& cenv, CVal tup, int32_t index)
+{
+	return NULL;
+}
+
+CVal
 CEngine::compileLiteral(CEnv& cenv, AST* lit)
 {
 	return new Value(lit->str());
diff --git a/src/compile.cpp b/src/compile.cpp
index 797ae2e..2a716c2 100644
--- a/src/compile.cpp
+++ b/src/compile.cpp
@@ -96,6 +96,16 @@ ACons::compile(CEnv& cenv)
 }
 
 CVal
+ADot::compile(CEnv& cenv)
+{
+	const_iterator     i      = begin();
+	AST*               tup    = *++i;
+	ALiteral<int32_t>* index  = (*++i)->as<ALiteral<int32_t>*>();
+	CVal tupVal = tup->compile(cenv);
+	return cenv.engine()->compileDot(cenv, tupVal, index->val);
+}
+
+CVal
 APrimitive::compile(CEnv& cenv)
 {
 	return cenv.engine()->compilePrimitive(cenv, this);
diff --git a/src/constrain.cpp b/src/constrain.cpp
index b7d7a0d..36a82d1 100644
--- a/src/constrain.cpp
+++ b/src/constrain.cpp
@@ -185,6 +185,27 @@ ACons::constrain(TEnv& tenv, Constraints& c) const
 }
 
 void
+ADot::constrain(TEnv& tenv, Constraints& c) const
+{
+	THROW_IF(size() != 3, loc, "`.' requires exactly 2 arguments");
+	const_iterator     i   = begin();
+	AST*               obj = *++i;
+	ALiteral<int32_t>* idx = (*++i)->to<ALiteral<int32_t>*>();
+	THROW_IF(!idx, loc, "the 2nd argument to `.' must be a literal integer");
+	obj->constrain(tenv, c);
+
+	AType* retT = tenv.var(this);
+	c.constrain(tenv, this, retT);
+
+	AType* objT = tup<AType>(loc, tenv.Tup, 0);
+	for (int i = 0; i < idx->val; ++i)
+		objT->push_back(tenv.var());
+	objT->push_back(retT);
+	objT->push_back(tenv.ellipses);
+	c.constrain(tenv, obj, objT);
+}
+
+void
 APrimitive::constrain(TEnv& tenv, Constraints& c) const
 {
 	const string n = head()->to<const ASymbol*>()->str();
diff --git a/src/lift.cpp b/src/lift.cpp
index 499fadd..636757c 100644
--- a/src/lift.cpp
+++ b/src/lift.cpp
@@ -67,6 +67,12 @@ ACall::lift(CEnv& cenv)
 }
 
 void
+ADot::lift(CEnv& cenv)
+{
+	(*(begin() + 1))->lift(cenv);
+}
+
+void
 ADef::lift(CEnv& cenv)
 {
 	// Define stub first for recursion
diff --git a/src/llvm.cpp b/src/llvm.cpp
index bf00778..26b4bf2 100644
--- a/src/llvm.cpp
+++ b/src/llvm.cpp
@@ -169,6 +169,7 @@ struct LLVMEngine : public Engine {
 	CFunc compileFunction(CEnv& cenv, AFn* fn, const AType& argsT);
 
 	CVal compileTup(CEnv& cenv, const AType* type, const vector<CVal>& fields);
+	CVal compileDot(CEnv& cenv, CVal tup, int32_t index);
 	CVal compileLiteral(CEnv& cenv, AST* lit);
 	CVal compilePrimitive(CEnv& cenv, APrimitive* prim);
 	CVal compileIf(CEnv& cenv, AIf* aif);
@@ -231,8 +232,8 @@ LLVMEngine::compileTup(CEnv& cenv, const AType* type, const vector<CVal>& fields
 
 	// Allocate struct
 	Value* structSize = ConstantInt::get(Type::Int32Ty, bitsToBytes(s));
-	Value* mem        = builder.CreateCall(alloc, structSize, "tup");
-	Value* structPtr  = builder.CreateBitCast(mem, llType(type), "tupPtr");
+	Value* mem        = builder.CreateCall(alloc, structSize, "tupMem");
+	Value* structPtr  = builder.CreateBitCast(mem, llType(type), "tup");
 
 	// Set struct fields
 	size_t i = 0;
@@ -245,6 +246,13 @@ LLVMEngine::compileTup(CEnv& cenv, const AType* type, const vector<CVal>& fields
 }
 
 CVal
+LLVMEngine::compileDot(CEnv& cenv, CVal tup, int32_t index)
+{
+	Value* ptr = builder.CreateStructGEP(llVal(tup), index, "dotPtr");
+	return builder.CreateLoad(ptr, 0, "dotVal");
+}
+
+CVal
 LLVMEngine::compileLiteral(CEnv& cenv, AST* lit)
 {
 	ALiteral<int32_t>* ilit = dynamic_cast<ALiteral<int32_t>*>(lit);
diff --git a/src/parse.cpp b/src/parse.cpp
index a2dddd2..52d3d78 100644
--- a/src/parse.cpp
+++ b/src/parse.cpp
@@ -121,6 +121,7 @@ initLang(PEnv& penv, TEnv& tenv)
 	penv.reg(true, "fn",   PEnv::Handler(parseFn));
 	penv.reg(true, "if",   PEnv::Handler(parseCall<AIf>));
 	penv.reg(true, "cons", PEnv::Handler(parseCall<ACons>));
+	penv.reg(true, ".",    PEnv::Handler(parseCall<ADot>));
 	penv.reg(true, "def",  PEnv::Handler(parseCall<ADef>));
 
 	// Numeric primitives
diff --git a/src/tuplr.hpp b/src/tuplr.hpp
index 31585d2..18e8830 100644
--- a/src/tuplr.hpp
+++ b/src/tuplr.hpp
@@ -440,6 +440,13 @@ struct ACons : public ACall {
 	CVal compile(CEnv& cenv);
 };
 
+struct ADot : public ACall {
+	ADot(const ATuple* exp) : ACall(exp) {}
+	void constrain(TEnv& tenv, Constraints& c) const;
+	void lift(CEnv& cenv);
+	CVal compile(CEnv& cenv);
+};
+
 /// Primitive (builtin arithmetic function), e.g. "(+ 2 3)"
 struct APrimitive : public ACall {
 	APrimitive(const ATuple* exp) : ACall(exp) {}
@@ -563,13 +570,19 @@ inline ostream& operator<<(ostream& out, const Constraints& c) {
 /// Type-Time Environment
 struct TEnv : public Env<const ASymbol*, AType*> {
 	TEnv(PEnv& p) : penv(p), varID(1),
-			Fn(new AType(penv.sym("Fn"))), Tup(new AType(penv.sym("Tup"))) {
+			Fn(new AType(penv.sym("Fn"))),
+			Tup(new AType(penv.sym("Tup"))),
+			ellipses(new AType(penv.sym("...")))
+	{
 		Object::pool.addRoot(Fn);
 	}
 	AType* fresh(const ASymbol* sym) {
 		return def(sym, new AType(sym->loc, varID++));
 	}
 	AType* var(const AST* ast=0) {
+		if (!ast)
+			return new AType(Cursor(), varID++);
+
 		const ASymbol* sym = ast->to<const ASymbol*>();
 		if (sym)
 			return *ref(sym);
@@ -578,11 +591,7 @@ struct TEnv : public Env<const ASymbol*, AType*> {
 		if (v != vars.end())
 			return v->second;
 
-		AType* ret = new AType(ast ? ast->loc : Cursor(), varID++);
-		if (ast)
-			vars[ast] = ret;
-
-		return ret;
+		return (vars[ast] = new AType(ast->loc, varID++));
 	}
 	AType* named(const string& name) {
 		return *ref(penv.sym(name));
@@ -597,6 +606,7 @@ struct TEnv : public Env<const ASymbol*, AType*> {
 
 	AType* Fn;
 	AType* Tup;
+	AType* ellipses;
 };
 
 Subst unify(const Constraints& c);
@@ -619,6 +629,7 @@ struct Engine {
 	virtual void  eraseFunction(CEnv& cenv, CFunc f)                               = 0;
 	virtual CFunc compileFunction(CEnv& cenv, AFn* fn, const AType& argsT)         = 0;
 	virtual CVal  compileTup(CEnv& cenv, const AType* t, const vector<CVal>& f)    = 0;
+	virtual CVal  compileDot(CEnv& cenv, CVal tup, int32_t index)                  = 0;
 	virtual CVal  compileLiteral(CEnv& cenv, AST* lit)                             = 0;
 	virtual CVal  compileCall(CEnv& cenv, CFunc f, const vector<CVal>& args)       = 0;
 	virtual CVal  compilePrimitive(CEnv& cenv, APrimitive* prim)                   = 0;
@@ -649,6 +660,7 @@ struct CEnv {
 		ASymbol* sym = ast->to<ASymbol*>();
 		if (sym)
 			return *tenv.ref(sym);
+		assert(tenv.vars[ast]);
 		return tsubst.apply(subst.apply(tenv.vars[ast]))->to<AType*>();
 	}
 	void def(const ASymbol* sym, AST* c, AType* t, CVal v) {
diff --git a/src/unify.cpp b/src/unify.cpp
index 92957c0..5255f54 100644
--- a/src/unify.cpp
+++ b/src/unify.cpp
@@ -109,7 +109,9 @@ Constraints::replace(AType* s, AType* t)
 Subst
 unify(const Constraints& constraints)
 {
-	if (constraints.empty()) return Subst();
+	if (constraints.empty())
+		return Subst();
+
 	AType*      s  = constraints.begin()->first;
 	AType*      t  = constraints.begin()->second;
 	Constraints cp = constraints;
@@ -127,6 +129,8 @@ unify(const Constraints& constraints)
 		AType::iterator si = s->begin() + 1;
 		AType::iterator ti = t->begin() + 1;
 		for (; si != s->end() && ti != t->end(); ++si, ++ti) {
+			if ((*si)->str() == "..." || (*ti)->str() == "...")
+				return unify(cp);
 			AType* st = (*si)->to<AType*>();
 			AType* tt = (*ti)->to<AType*>();
 			assert(st && tt);
diff --git a/test.sh b/test.sh
index 9fd86f8..13d2b00 100755
--- a/test.sh
+++ b/test.sh
@@ -18,3 +18,4 @@ run './test/def.tpr'  '3 : Int'
 run './test/fac.tpr'  '720 : Int'
 run './test/poly.tpr'  '#t : Bool'
 run './test/nest.tpr' '6 : Int'
+run './test/tup.tpr' '3 : Int'
diff --git a/test/tup.tpr b/test/tup.tpr
new file mode 100644
index 0000000..ac32387
--- /dev/null
+++ b/test/tup.tpr
@@ -0,0 +1,2 @@
+(def t (cons 1 2 3 4 5))
+(. t 2)