aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--llvm.cpp31
-rw-r--r--tuplr.cpp36
-rw-r--r--tuplr.hpp64
-rw-r--r--typing.cpp34
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);
}
}
generated by cgit v1.2.1 (git 2.18.0) at 2024-07-01 23:01:59 +0000