aboutsummaryrefslogtreecommitdiffstats
path: root/tuplr.hpp
diff options
context:
space:
mode:
Diffstat (limited to 'tuplr.hpp')
-rw-r--r--tuplr.hpp210
1 files changed, 148 insertions, 62 deletions
diff --git a/tuplr.hpp b/tuplr.hpp
index a16072d..4d714d4 100644
--- a/tuplr.hpp
+++ b/tuplr.hpp
@@ -67,25 +67,53 @@ struct Exp {
List list;
};
+/// Lexical Address
+struct LAddr {
+ LAddr(unsigned u=0, unsigned o=0) : up(u), over(o) {}
+ operator bool() const { return !(up == 0 && over == 0); }
+ unsigned up, over;
+};
+
+inline ostream& operator<<(ostream& out, const LAddr& addr) {
+ out << addr.up << ":" << addr.over;
+ return out;
+}
+
/// Generic Lexical Environment
template<typename K, typename V>
-struct Env : public list< map<K,V> > {
- typedef map<K,V> Frame;
+struct Env : public list< vector< pair<K,V> > > {
+ typedef vector< pair<K,V> > Frame;
Env() : list<Frame>(1) {}
- void push() { list<Frame>::push_front(Frame()); }
- void pop() { assert(!this->empty()); list<Frame>::pop_front(); }
+ void push(Frame f=Frame()) { list<Frame>::push_front(f); }
+ void pop() { assert(!this->empty()); list<Frame>::pop_front(); }
const V& def(const K& k, const V& v) {
- typename Frame::iterator existing = this->front().find(k);
- if (existing != this->front().end() && existing->second != v)
- throw Error("redefinition");
- return (this->front()[k] = v);
+ for (typename Frame::iterator b = this->begin()->begin(); b != this->begin()->end(); ++b)
+ if (b->first == k)
+ return (b->second = v);
+ this->front().push_back(make_pair(k, v));
+ return v;
+ }
+ V* ref(const K& key) {
+ for (typename Env::iterator f = this->begin(); f != this->end(); ++f)
+ for (typename Frame::iterator b = f->begin(); b != f->end(); ++b)
+ if (b->first == key)
+ return &b->second;
+ return NULL;
}
- V* ref(const K& name) {
- typename Frame::iterator s;
- for (typename Env::iterator i = this->begin(); i != this->end(); ++i)
- if ((s = i ->find(name)) != i->end())
- return &s->second;
- return 0;
+ LAddr lookup(const K& key) const {
+ unsigned up = 0;
+ for (typename Env::const_iterator f = this->begin(); f != this->end(); ++f, ++up)
+ for (unsigned over = 0; over < f->size(); ++over)
+ if ((*f)[over].first == key)
+ return LAddr(up + 1, over + 1);
+ return LAddr();
+ }
+ V& deref(LAddr addr) {
+ assert(addr);
+ typename Env::iterator f = this->begin();
+ for (unsigned u = 1; u < addr.up; ++u, ++f) { assert(f != this->end()); }
+ assert(f->size() > addr.over - 1);
+ return (*f)[addr.over - 1].second;
}
};
@@ -112,10 +140,13 @@ typedef void* CEngine; ///< Compiler Engine (opaque)
* Abstract Syntax Tree *
***************************************************************************/
-struct TEnv; ///< Type-Time Environment
-struct CEnv; ///< Compile-Time Environment
-
+struct Constraint; ///< Type Constraint
+struct TEnv; ///< Type-Time Environment
+struct CEnv; ///< Compile-Time Environment
struct AST;
+struct Constraints;
+struct Subst;
+
extern ostream& operator<<(ostream& out, const AST* ast);
/// Base class for all AST nodes
@@ -124,7 +155,7 @@ struct AST {
virtual ~AST() {}
virtual bool operator==(const AST& o) const = 0;
virtual bool contains(const AST* child) const { return false; }
- virtual void constrain(TEnv& tenv) const {}
+ virtual void constrain(TEnv& tenv, Constraints& c) {}
virtual void lift(CEnv& cenv) {}
string str() const { ostringstream ss; ss << this; return ss.str(); }
Cursor loc;
@@ -141,7 +172,7 @@ struct ALiteral : public AST {
const ALiteral<VT>* r = dynamic_cast<const ALiteral<VT>*>(&rhs);
return (r && (val == r->val));
}
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
CValue compile(CEnv& cenv);
const VT val;
};
@@ -149,13 +180,16 @@ struct ALiteral : public AST {
/// Symbol, e.g. "a"
struct ASymbol : public AST {
bool operator==(const AST& rhs) const { return this == &rhs; }
- void lift(CEnv& cenv);
+ void lookup(TEnv& tenv);
+ void constrain(TEnv& tenv, Constraints& c);
CValue compile(CEnv& cenv);
+ LAddr addr;
private:
friend class PEnv;
ASymbol(const string& s, Cursor c) : AST(c), cppstr(s) {}
friend ostream& operator<<(ostream&, const AST*);
const string cppstr;
+
};
/// Tuple (heterogeneous sequence of fixed length), e.g. "(a b c)"
@@ -163,6 +197,8 @@ struct ATuple : public AST, public vector<AST*> {
ATuple(const vector<AST*>& t=vector<AST*>(), Cursor c=Cursor()) : AST(c), vector<AST*>(t) {}
ATuple(size_t size, Cursor c) : AST(c), vector<AST*>(size) {}
ATuple(Cursor c, AST* ast, ...) : AST(c) {
+ if (!ast)
+ return;
va_list args; va_start(args, ast);
push_back(ast);
for (AST* a = va_arg(args, AST*); a; a = va_arg(args, AST*))
@@ -189,23 +225,23 @@ struct ATuple : public AST, public vector<AST*> {
return true;
return false;
}
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
CValue compile(CEnv& cenv) { throw Error("tuple compiled"); }
};
/// Type Expression, e.g. "Int", "(Fn (Int Int) Float)"
struct AType : public ATuple {
- AType(unsigned i, Cursor c=Cursor()) : ATuple(0, c), kind(VAR), id(i) {}
+ AType(unsigned i, LAddr a, Cursor c=Cursor()) : ATuple(0, c), kind(VAR), addr(a), id(i) {}
AType(ASymbol* s) : ATuple(0, s->loc), kind(PRIM), id(0) { push_back(s); }
AType(const ATuple& t, Cursor c) : ATuple(t, c), kind(EXPR), id(0) {}
AType(Cursor c, AST* ast, ...) : ATuple(0, c), kind(EXPR), id(0) {
va_list args; va_start(args, ast);
+ if (!ast) return;
push_back(ast);
for (AST* a = va_arg(args, AST*); a; a = va_arg(args, AST*))
push_back(a);
va_end(args);
}
- void constrain(TEnv& tenv) const {}
CValue compile(CEnv& cenv) { return NULL; }
bool var() const { return kind == VAR; }
bool concrete() const {
@@ -234,6 +270,7 @@ struct AType : public ATuple {
return false; // never reached
}
enum { VAR, PRIM, EXPR } kind;
+ LAddr addr;
unsigned id;
};
@@ -249,22 +286,25 @@ struct Funcs : public list< pair<AType*, CFunction> > {
/// Closure (first-class function with captured lexical bindings)
struct AClosure : public ATuple {
- AClosure(Cursor c, ASymbol* fn, ATuple* p, AST* b, const string& n="")
- : ATuple(c, fn, p, b, NULL), name(n) {}
+ AClosure(Cursor c, ASymbol* fn, ATuple* p, const string& n="")
+ : ATuple(c, fn, p, NULL), type(0), subst(0), name(n) {}
bool operator==(const AST& rhs) const { return this == &rhs; }
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
void lift(CEnv& cenv);
+ void liftPoly(CEnv& cenv, const vector<AType*>& argsT);
CValue compile(CEnv& cenv);
ATuple* prot() const { return dynamic_cast<ATuple*>(at(1)); }
-private:
+ AType* type;
Funcs funcs;
+ Subst* subst;
+private:
string name;
};
/// Function call/application, e.g. "(func arg1 arg2)"
struct ACall : public ATuple {
ACall(const SExp& e, const ATuple& t) : ATuple(t, e.loc) {}
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
void lift(CEnv& cenv);
CValue compile(CEnv& cenv);
};
@@ -272,7 +312,8 @@ struct ACall : public ATuple {
/// Definition special form, e.g. "(def x 2)"
struct ADefinition : public ACall {
ADefinition(const SExp& e, const ATuple& t) : ACall(e, t) {}
- void constrain(TEnv& tenv) const;
+ ASymbol* sym() const { return dynamic_cast<ASymbol*>(at(1)); }
+ void constrain(TEnv& tenv, Constraints& c);
void lift(CEnv& cenv);
CValue compile(CEnv& cenv);
};
@@ -280,14 +321,14 @@ struct ADefinition : public ACall {
/// Conditional special form, e.g. "(if cond thenexp elseexp)"
struct AIf : public ACall {
AIf(const SExp& e, const ATuple& t) : ACall(e, t) {}
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
CValue compile(CEnv& cenv);
};
/// Primitive (builtin arithmetic function), e.g. "(+ 2 3)"
struct APrimitive : public ACall {
APrimitive(const SExp& e, const ATuple& t) : ACall(e, t) {}
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
CValue compile(CEnv& cenv);
};
@@ -295,7 +336,7 @@ struct APrimitive : public ACall {
struct AConsCall : public ACall {
AConsCall(const SExp& e, const ATuple& t) : ACall(e, t) {}
AType* functionType(CEnv& cenv);
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
void lift(CEnv& cenv);
CValue compile(CEnv& cenv);
static Funcs funcs;
@@ -304,14 +345,14 @@ struct AConsCall : public ACall {
/// Car special form, e.g. "(car p)"
struct ACarCall : public ACall {
ACarCall(const SExp& e, const ATuple& t) : ACall(e, t) {}
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
CValue compile(CEnv& cenv);
};
/// Cdr special form, e.g. "(cdr p)"
struct ACdrCall : public ACall {
ACdrCall(const SExp& e, const ATuple& t) : ACall(e, t) {}
- void constrain(TEnv& tenv) const;
+ void constrain(TEnv& tenv, Constraints& c);
CValue compile(CEnv& cenv);
};
@@ -375,33 +416,70 @@ struct PEnv : private map<const string, ASymbol*> {
* Typing *
***************************************************************************/
+struct Constraint : public pair<AType*,AType*> {
+ Constraint(AType* a, AType* b, Cursor c) : pair<AType*,AType*>(a, b), loc(c) {}
+ Cursor loc;
+};
+
+struct Constraints : public list<Constraint> {
+ void constrain(TEnv& tenv, const AST* o, AType* t);
+};
+
+inline ostream& operator<<(ostream& out, const Constraints& c) {
+ for (Constraints::const_iterator i = c.begin(); i != c.end(); ++i)
+ out << i->first << " : " << i->second << endl;
+ return out;
+}
+
+struct Subst : public map<const AType*,AType*> {
+ Subst(AType* s=0, AType* t=0) { if (s && t) insert(make_pair(s, t)); }
+ static Subst compose(const Subst& delta, const Subst& gamma);
+ AST* apply(AST* ast) const {
+ AType* in = dynamic_cast<AType*>(ast);
+ if (!in) return ast;
+ if (in->kind == AType::EXPR) {
+ AType* out = new AType(in->loc, NULL);
+ for (size_t i = 0; i < in->size(); ++i)
+ out->push_back(apply(in->at(i)));
+ return out;
+ } else {
+ const_iterator i;
+ while ((i = find(in)) != end())
+ in = i->second;
+ return in;
+ }
+ }
+};
+
/// Type-Time Environment
struct TEnv : public Env<const AST*,AType*> {
TEnv(PEnv& p) : penv(p), varID(1) {}
- struct Constraint : public pair<AType*,AType*> {
- Constraint(AType* a, AType* b, Cursor c) : pair<AType*,AType*>(a, b), loc(c) {}
- Cursor loc;
- };
- struct Subst : public map<AType*, AType*> {
- Subst(AType* s=0, AType* t=0) { if (s && t) insert(make_pair(s, t)); }
- };
- typedef list<Constraint> Constraints;
- 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));
+
+ AType* fresh(const ASymbol* sym) {
+ assert(sym);
+ return def(sym, new AType(varID++, LAddr(), sym->loc));
+ }
+ AType* var(const AST* ast=0) {
+ const ASymbol* sym = dynamic_cast<const ASymbol*>(ast);
+ if (sym)
+ return deref(lookup(sym));
+
+ map<const AST*, AType*>::iterator v = vars.find(ast);
+ if (v != vars.end())
+ return v->second;
+
+ AType* ret = new AType(varID++, LAddr(), ast ? ast->loc : Cursor());
+ if (ast)
+ vars[ast] = ret;
+
+ return ret;
}
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(Constraint(type(o), t, o->loc));
- }
- void solve() { apply(unify(constraints)); }
- void apply(const Subst& substs);
static Subst unify(const Constraints& c);
+ map<const AST*, AType*> vars;
PEnv& penv;
Constraints constraints;
unsigned varID;
@@ -422,21 +500,29 @@ struct CEnv {
CEngine engine();
string gensym(const char* s="_") { return (format("%s%d") % s % symID++).str(); }
- void push() { code.push(); vals.push(); }
- void pop() { code.pop(); vals.pop(); }
+ void push() { code.push(); vals.push(); tenv.push(); }
+ void pop() { code.pop(); vals.pop(); tenv.pop(); }
void precompile(AST* obj, CValue value) { vals.def(obj, value); }
CValue compile(AST* obj);
void optimise(CFunction f);
void write(std::ostream& os);
+ AType* type(AST* ast, const Subst& subst = Subst()) const {
+ ASymbol* sym = dynamic_cast<ASymbol*>(ast);
+ if (sym)
+ return tenv.deref(sym->addr);
+ return dynamic_cast<AType*>(tsubst.apply(subst.apply(tenv.vars[ast])));
+ }
- ostream& out;
- ostream& err;
- PEnv& penv;
- TEnv& tenv;
- Code code;
- Vals vals;
- unsigned symID;
- CFunction alloc;
+ ostream& out;
+ ostream& err;
+ PEnv& penv;
+ TEnv& tenv;
+ Code code;
+ Vals vals;
+
+ unsigned symID;
+ CFunction alloc;
+ Subst tsubst;
private:
struct PImpl; ///< Private Implementation
generated by cgit v1.2.1 (git 2.18.0) at 2024-07-06 21:52:00 +0000