From 195598d60fec7a9ea2096143d853fab8232b5138 Mon Sep 17 00:00:00 2001 From: David Robillard Date: Fri, 16 Oct 2009 03:20:22 +0000 Subject: . operator for destructuring Tuples (cons). git-svn-id: http://svn.drobilla.net/resp/tuplr@236 ad02d1e2-f140-0410-9f75-f8b11f17cedd --- src/c.cpp | 7 +++++++ src/compile.cpp | 10 ++++++++++ src/constrain.cpp | 21 +++++++++++++++++++++ src/lift.cpp | 6 ++++++ src/llvm.cpp | 12 ++++++++++-- src/parse.cpp | 1 + src/tuplr.hpp | 24 ++++++++++++++++++------ src/unify.cpp | 6 +++++- test.sh | 1 + test/tup.tpr | 2 ++ 10 files changed, 81 insertions(+), 9 deletions(-) create mode 100644 test/tup.tpr 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& 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); @@ -169,6 +170,12 @@ CEngine::compileTup(CEnv& cenv, const AType* type, const vector& fields) return NULL; } +CVal +CEngine::compileDot(CEnv& cenv, CVal tup, int32_t index) +{ + return NULL; +} + CVal CEngine::compileLiteral(CEnv& cenv, AST* lit) { diff --git a/src/compile.cpp b/src/compile.cpp index 797ae2e..2a716c2 100644 --- a/src/compile.cpp +++ b/src/compile.cpp @@ -95,6 +95,16 @@ ACons::compile(CEnv& cenv) return cenv.engine()->compileTup(cenv, type, fields); } +CVal +ADot::compile(CEnv& cenv) +{ + const_iterator i = begin(); + AST* tup = *++i; + ALiteral* index = (*++i)->as*>(); + CVal tupVal = tup->compile(cenv); + return cenv.engine()->compileDot(cenv, tupVal, index->val); +} + CVal APrimitive::compile(CEnv& cenv) { diff --git a/src/constrain.cpp b/src/constrain.cpp index b7d7a0d..36a82d1 100644 --- a/src/constrain.cpp +++ b/src/constrain.cpp @@ -184,6 +184,27 @@ ACons::constrain(TEnv& tenv, Constraints& c) const c.constrain(tenv, this, type); } +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* idx = (*++i)->to*>(); + 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(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 { diff --git a/src/lift.cpp b/src/lift.cpp index 499fadd..636757c 100644 --- a/src/lift.cpp +++ b/src/lift.cpp @@ -66,6 +66,12 @@ ACall::lift(CEnv& cenv) cenv.engine()->compileFunction(cenv, c, argsT); // Lift called closure } +void +ADot::lift(CEnv& cenv) +{ + (*(begin() + 1))->lift(cenv); +} + void ADef::lift(CEnv& cenv) { 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& 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& 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; @@ -244,6 +245,13 @@ LLVMEngine::compileTup(CEnv& cenv, const AType* type, const vector& fields return structPtr; } +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) { 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)); penv.reg(true, "cons", PEnv::Handler(parseCall)); + penv.reg(true, ".", PEnv::Handler(parseCall)); penv.reg(true, "def", PEnv::Handler(parseCall)); // 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 { 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(); if (sym) return *ref(sym); @@ -578,11 +591,7 @@ struct TEnv : public Env { 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 { 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& 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& args) = 0; virtual CVal compilePrimitive(CEnv& cenv, APrimitive* prim) = 0; @@ -649,6 +660,7 @@ struct CEnv { ASymbol* sym = ast->to(); if (sym) return *tenv.ref(sym); + assert(tenv.vars[ast]); return tsubst.apply(subst.apply(tenv.vars[ast]))->to(); } 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* tt = (*ti)->to(); 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) -- cgit v1.2.1