aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/constrain.cpp115
-rw-r--r--src/gc.cpp6
-rw-r--r--src/lift.cpp8
-rw-r--r--src/parse.cpp13
-rw-r--r--src/repl.cpp2
-rw-r--r--src/resp.hpp40
-rw-r--r--src/resp_gc.cpp2
7 files changed, 99 insertions, 87 deletions
diff --git a/src/constrain.cpp b/src/constrain.cpp
index 8d16218..0383f20 100644
--- a/src/constrain.cpp
+++ b/src/constrain.cpp
@@ -22,35 +22,12 @@
#include <set>
#include "resp.hpp"
-#define CONSTRAIN_LITERAL(CT, NAME) \
-template<> void \
-ALiteral<CT>::constrain(TEnv& tenv, Constraints& c) const throw(Error) { \
- c.constrain(tenv, this, tenv.named(NAME)); \
-}
-
-// Literal template instantiations
-CONSTRAIN_LITERAL(int32_t, "Int")
-CONSTRAIN_LITERAL(float, "Float")
-CONSTRAIN_LITERAL(bool, "Bool")
-
-void
-AString::constrain(TEnv& tenv, Constraints& c) const throw(Error)
-{
- c.constrain(tenv, this, tenv.named("String"));
-}
-
-void
-ALexeme::constrain(TEnv& tenv, Constraints& c) const throw(Error)
-{
- c.constrain(tenv, this, tenv.named("Lexeme"));
-}
-
-void
-ASymbol::constrain(TEnv& tenv, Constraints& c) const throw(Error)
+static void
+constrain_symbol(TEnv& tenv, Constraints& c, const ASymbol* sym) throw(Error)
{
- const AType** ref = tenv.ref(this);
- THROW_IF(!ref, loc, (format("undefined symbol `%1%'") % cppstr).str());
- c.constrain(tenv, this, *ref);
+ const AType** ref = tenv.ref(sym);
+ THROW_IF(!ref, sym->loc, (format("undefined symbol `%1%'") % sym->cppstr).str());
+ c.constrain(tenv, sym, *ref);
}
static void
@@ -80,7 +57,7 @@ constrain_fn(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
// Add internal definitions to environment frame
for (++i; i != call->end(); ++i) {
- const AST* exp = *i;
+ const AST* exp = *i;
const ATuple* call = exp->to<const ATuple*>();
if (call && is_form(call, "def")) {
const ASymbol* sym = call->list_ref(1)->as<const ASymbol*>();
@@ -96,7 +73,7 @@ constrain_fn(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
const AST* exp = NULL;
for (i = call->iter_at(2); i != call->end(); ++i) {
exp = *i;
- exp->constrain(tenv, c);
+ resp_constrain(tenv, c, exp);
}
const AType* bodyT = tenv.var(exp);
@@ -118,7 +95,7 @@ constrain_def(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
const AType* tvar = tenv.var(body);
tenv.def(sym, tvar);
- body->constrain(tenv, c);
+ resp_constrain(tenv, c, body);
c.constrain(tenv, sym, tvar);
c.constrain(tenv, call, tenv.named("Nothing"));
}
@@ -158,7 +135,7 @@ constrain_match(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
const AST* matchee = call->list_ref(1);
const AType* retT = tenv.var();
const AType* matcheeT = NULL;// = tup<AType>(loc, tenv.U, 0);
- matchee->constrain(tenv, c);
+ resp_constrain(tenv, c, matchee);
for (ATuple::const_iterator i = call->iter_at(2); i != call->end();) {
const AST* exp = *i++;
const ATuple* pattern = exp->to<const ATuple*>();
@@ -175,7 +152,7 @@ constrain_match(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
THROW_IF(i == call->end(), pattern->loc, "missing pattern body");
const AST* body = *i++;
- body->constrain(tenv, c);
+ resp_constrain(tenv, c, body);
c.constrain(tenv, body, retT);
}
c.constrain(tenv, call, retT);
@@ -188,7 +165,7 @@ constrain_if(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
THROW_IF(call->list_len() < 4, call->loc, "`if' requires at least 3 arguments");
THROW_IF(call->list_len() % 2 != 0, call->loc, "`if' missing final else clause");
for (ATuple::const_iterator i = call->iter_at(1); i != call->end(); ++i)
- (*i)->constrain(tenv, c);
+ resp_constrain(tenv, c, *i);
const AType* retT = tenv.var(call);
for (ATuple::const_iterator i = call->iter_at(1); true; ++i) {
ATuple::const_iterator next = i;
@@ -211,7 +188,7 @@ constrain_cons(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
const AType* type = NULL;
for (ATuple::const_iterator i = call->iter_at(1); i != call->end(); ++i)
- (*i)->constrain(tenv, c);
+ resp_constrain(tenv, c, *i);
if (sym->cppstr == "Tup") {
TList tupT(new AType(tenv.Tup, NULL, call->loc));
@@ -237,7 +214,7 @@ constrain_dot(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
const AST* obj = *++i;
const ALiteral<int32_t>* idx = (*++i)->to<const ALiteral<int32_t>*>();
THROW_IF(!idx, call->loc, "the 2nd argument to `.' must be a literal integer");
- obj->constrain(tenv, c);
+ resp_constrain(tenv, c, obj);
const AType* retT = tenv.var(call);
c.constrain(tenv, call, retT);
@@ -254,7 +231,7 @@ static void
constrain_quote(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
{
c.constrain(tenv, call, tenv.named("Quote"));
- call->list_ref(1)->constrain(tenv, c);
+ resp_constrain(tenv, c, call->list_ref(1));
}
static void
@@ -263,7 +240,7 @@ constrain_call(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
const AST* const head = call->head();
for (ATuple::const_iterator i = call->begin(); i != call->end(); ++i)
- (*i)->constrain(tenv, c);
+ resp_constrain(tenv, c, *i);
const AType* fnType = tenv.var(head);
if (fnType->kind != AType::VAR) {
@@ -305,7 +282,7 @@ constrain_primitive(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
ATuple::const_iterator i = call->begin();
for (++i; i != call->end(); ++i)
- (*i)->constrain(tenv, c);
+ resp_constrain(tenv, c, *i);
i = call->begin();
@@ -342,34 +319,64 @@ constrain_primitive(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
}
}
-void
-ATuple::constrain(TEnv& tenv, Constraints& c) const throw(Error)
+static void
+constrain_tuple(TEnv& tenv, Constraints& c, const ATuple* tup) throw(Error)
{
- const ASymbol* const sym = head()->to<const ASymbol*>();
+ const ASymbol* const sym = tup->head()->to<const ASymbol*>();
if (!sym) {
- constrain_call(tenv, c, this);
+ constrain_call(tenv, c, tup);
return;
}
const std::string form = sym->cppstr;
- if (is_primitive(tenv.penv, this))
- constrain_primitive(tenv, c, this);
+ if (is_primitive(tenv.penv, tup))
+ constrain_primitive(tenv, c, tup);
else if (form == "fn")
- constrain_fn(tenv, c, this);
+ constrain_fn(tenv, c, tup);
else if (form == "def")
- constrain_def(tenv, c, this);
+ constrain_def(tenv, c, tup);
else if (form == "def-type")
- constrain_def_type(tenv, c, this);
+ constrain_def_type(tenv, c, tup);
else if (form == "match")
- constrain_match(tenv, c, this);
+ constrain_match(tenv, c, tup);
else if (form == "if")
- constrain_if(tenv, c, this);
+ constrain_if(tenv, c, tup);
else if (form == "cons" || isupper(form[0]))
- constrain_cons(tenv, c, this);
+ constrain_cons(tenv, c, tup);
else if (form == ".")
- constrain_dot(tenv, c, this);
+ constrain_dot(tenv, c, tup);
else if (form == "quote")
- constrain_quote(tenv, c, this);
+ constrain_quote(tenv, c, tup);
else
- constrain_call(tenv, c, this);
+ constrain_call(tenv, c, tup);
+}
+
+void
+resp_constrain(TEnv& tenv, Constraints& c, const AST* ast) throw(Error)
+{
+ switch (ast->tag()) {
+ case T_UNKNOWN:
+ break;
+ case T_BOOL:
+ c.constrain(tenv, ast, tenv.named("Bool"));
+ break;
+ case T_FLOAT:
+ c.constrain(tenv, ast, tenv.named("Float"));
+ break;
+ case T_INT32:
+ c.constrain(tenv, ast, tenv.named("Int"));
+ break;
+ case T_LEXEME:
+ c.constrain(tenv, ast, tenv.named("Lexeme"));
+ break;
+ case T_STRING:
+ c.constrain(tenv, ast, tenv.named("String"));
+ break;
+ case T_SYMBOL:
+ constrain_symbol(tenv, c, ast->as<const ASymbol*>());
+ break;
+ case T_TUPLE:
+ constrain_tuple(tenv, c, ast->as<const ATuple*>());
+ break;
+ }
}
diff --git a/src/gc.cpp b/src/gc.cpp
index 1cbeeff..8ed0fb2 100644
--- a/src/gc.cpp
+++ b/src/gc.cpp
@@ -43,7 +43,7 @@ GC::alloc(size_t size)
size += (4 - (size % 4)); // Align to 32-bits
size += sizeof(Object::Header);
void* ret = tlsf_malloc((tlsf_t*)_pool, size);
- ((Object::Header*)ret)->tag = Object::AST;
+ ((Object::Header*)ret)->tag = T_UNKNOWN;
ret = (char*)ret + sizeof(Object::Header);
_heap.push_back((Object*)ret);
return ret;
@@ -56,7 +56,7 @@ mark(const Object* obj)
return;
obj->mark(true);
- if (obj->tag() == Object::AST) {
+ if (obj->tag() != T_UNKNOWN) {
const ATuple* tup = ((const AST*)obj)->to<const ATuple*>();
if (tup)
FOREACHP(ATuple::const_iterator, i, tup)
@@ -80,7 +80,7 @@ GC::collect(const Roots& roots)
(*i)->mark(false);
assert(!(*i)->marked());
} else {
- if ((*i)->tag() == Object::AST)
+ if ((*i)->tag() != T_UNKNOWN)
((AST*)*i)->~AST();
tlsf_free((tlsf_t*)_pool, ((char*)(*i) - sizeof(Object::Header)));
diff --git a/src/lift.cpp b/src/lift.cpp
index f39239e..df34d7a 100644
--- a/src/lift.cpp
+++ b/src/lift.cpp
@@ -41,8 +41,8 @@ lift_symbol(CEnv& cenv, Code& code, ASymbol* sym) throw()
// Replace symbol with code to access free variable from closure
return tup<ATuple>(sym->loc, cenv.penv.sym("."),
- cenv.penv.sym("_me"),
- new ALiteral<int32_t>(index, Cursor()),
+ cenv.penv.sym("_me"),
+ new ALiteral<int32_t>(T_INT32, index, Cursor()),
NULL);
} else {
return sym;
@@ -165,8 +165,8 @@ lift_call(CEnv& cenv, Code& code, ATuple* call) throw()
} else {
// Call to a closure, prepend code to access implementation function
ATuple* getFn = tup<ATuple>(call->loc, cenv.penv.sym("."),
- copy.head->head(),
- new ALiteral<int32_t>(0, Cursor()), NULL);
+ copy.head->head(),
+ new ALiteral<int32_t>(T_INT32, 0, Cursor()), NULL);
const AType* calleeT = cenv.type(copy.head->head());
assert(**calleeT->begin() == *cenv.tenv.Tup);
const AType* implT = calleeT->list_ref(1)->as<const AType*>();
diff --git a/src/parse.cpp b/src/parse.cpp
index bbf3ca9..78aae69 100644
--- a/src/parse.cpp
+++ b/src/parse.cpp
@@ -68,9 +68,9 @@ PEnv::parse(const AST* exp)
if (isdigit((*lex)[0])) {
const std::string& s = *lex;
if (s.find('.') == string::npos)
- return new ALiteral<int32_t>(strtol(s.c_str(), NULL, 10), exp->loc);
+ return new ALiteral<int32_t>(T_INT32, strtol(s.c_str(), NULL, 10), exp->loc);
else
- return new ALiteral<float>(strtod(s.c_str(), NULL), exp->loc);
+ return new ALiteral<float>(T_FLOAT, strtod(s.c_str(), NULL), exp->loc);
} else if ((*lex)[0] == '\"') {
return new AString(exp->loc, lex->substr(1, lex->length() - 2));
} else {
@@ -134,11 +134,10 @@ parseCall(PEnv& penv, const AST* exp, void* arg)
return parseTuple(penv, exp->to<const ATuple*>());
}
-template<typename T>
inline AST*
-parseLiteral(PEnv& penv, const AST* exp, void* arg)
+parseBool(PEnv& penv, const AST* exp, void* arg)
{
- return new ALiteral<T>(*reinterpret_cast<T*>(arg), exp->loc);
+ return new ALiteral<bool>(T_BOOL, *reinterpret_cast<bool*>(arg), exp->loc);
}
inline AST*
@@ -187,8 +186,8 @@ initLang(PEnv& penv, TEnv& tenv)
// Literals
static bool trueVal = true;
static bool falseVal = false;
- penv.reg(false, "#t", PEnv::Handler(parseLiteral<bool>, &trueVal));
- penv.reg(false, "#f", PEnv::Handler(parseLiteral<bool>, &falseVal));
+ penv.reg(false, "#t", PEnv::Handler(parseBool, &trueVal));
+ penv.reg(false, "#f", PEnv::Handler(parseBool, &falseVal));
// Macros
penv.defmac("def", macDef);
diff --git a/src/repl.cpp b/src/repl.cpp
index 4fdbb53..f6f8a26 100644
--- a/src/repl.cpp
+++ b/src/repl.cpp
@@ -42,7 +42,7 @@ readParseType(CEnv& cenv, Cursor& cursor, istream& is, AST*& exp, AST*& ast)
ast = cenv.penv.parse(exp); // Parse input
Constraints c(cenv.tsubst);
- ast->constrain(cenv.tenv, c); // Constrain types
+ resp_constrain(cenv.tenv, c, ast); // Constrain types
//cout << "(CONSTRAINTS " << endl << c << ")" << endl;
diff --git a/src/resp.hpp b/src/resp.hpp
index 724ed5d..7383cdd 100644
--- a/src/resp.hpp
+++ b/src/resp.hpp
@@ -133,6 +133,17 @@ typedef void* CFunc; ///< Compiled function (opaque)
struct Object;
+enum Tag {
+ T_UNKNOWN = 1<<1,
+ T_BOOL = 1<<2,
+ T_FLOAT = 1<<3,
+ T_INT32 = 1<<4,
+ T_LEXEME = 1<<5,
+ T_STRING = 1<<6,
+ T_SYMBOL = 1<<7,
+ T_TUPLE = 1<<8
+};
+
/// Garbage collector
struct GC {
typedef std::list<const Object*> Roots;
@@ -152,8 +163,6 @@ private:
/// Garbage collected object (including AST and runtime data)
struct Object {
- enum Tag { OBJECT = 1<<1, AST = 1<<2 };
-
struct Header {
uint32_t tag; ///< Rightmost bit is mark
};
@@ -198,10 +207,9 @@ typedef list<AST*> Code;
/// Base class for all AST nodes
struct AST : public Object {
- AST(Cursor c=Cursor()) : loc(c) {}
+ AST(Tag t, Cursor c=Cursor()) : loc(c) { this->tag(t); }
virtual ~AST() {}
virtual bool operator==(const AST& o) const = 0;
- virtual void constrain(TEnv& tenv, Constraints& c) const throw(Error) {}
string str() const { ostringstream ss; ss << this; return ss.str(); }
template<typename T> T to() { return dynamic_cast<T>(this); }
template<typename T> T const to() const { return dynamic_cast<T const>(this); }
@@ -229,52 +237,48 @@ static T* tup(Cursor c, AST* ast, ...)
/// Literal value
template<typename T>
struct ALiteral : public AST {
- ALiteral(T v, Cursor c) : AST(c), val(v) {}
+ ALiteral(Tag tag, T v, Cursor c) : AST(tag, c), val(v) {}
bool operator==(const AST& rhs) const {
const ALiteral<T>* r = rhs.to<const ALiteral<T>*>();
return (r && (val == r->val));
}
- void constrain(TEnv& tenv, Constraints& c) const throw(Error);
const T val;
};
/// Lexeme (any atom in the CST, e.g. "a", "3.4", ""hello"", etc.)
struct ALexeme : public AST, public std::string {
- ALexeme(Cursor c, const string& s) : AST(c), std::string(s) {}
+ ALexeme(Cursor c, const string& s) : AST(T_LEXEME, c), std::string(s) {}
bool operator==(const AST& rhs) const { return this == &rhs; }
- void constrain(TEnv& tenv, Constraints& c) const throw(Error);
};
/// String, e.g. ""a""
struct AString : public AST, public std::string {
- AString(Cursor c, const string& s) : AST(c), std::string(s) {}
+ AString(Cursor c, const string& s) : AST(T_STRING, c), std::string(s) {}
bool operator==(const AST& rhs) const { return this == &rhs; }
- void constrain(TEnv& tenv, Constraints& c) const throw(Error);
};
/// Symbol, e.g. "a"
struct ASymbol : public AST {
bool operator==(const AST& rhs) const { return this == &rhs; }
- void constrain(TEnv& tenv, Constraints& c) const throw(Error);
const string cppstr;
private:
friend class PEnv;
- ASymbol(const string& s, Cursor c) : AST(c), cppstr(s) {}
+ ASymbol(const string& s, Cursor c) : AST(T_SYMBOL, c), cppstr(s) {}
};
/// Tuple (heterogeneous sequence of fixed length), e.g. "(a b c)"
struct ATuple : public AST {
- ATuple(Cursor c) : AST(c), _len(0), _vec(0) {}
- ATuple(const ATuple& exp) : AST(exp.loc), _len(exp._len) {
+ ATuple(Cursor c) : AST(T_TUPLE, c), _len(0), _vec(0) {}
+ ATuple(const ATuple& exp) : AST(T_TUPLE, exp.loc), _len(exp._len) {
_vec = (AST**)malloc(sizeof(AST*) * _len);
memcpy(_vec, exp._vec, sizeof(AST*) * _len);
}
- ATuple(AST* first, AST* rest, Cursor c=Cursor()) : AST(c), _len(2) {
+ ATuple(AST* first, AST* rest, Cursor c=Cursor()) : AST(T_TUPLE, c), _len(2) {
_vec = (AST**)malloc(sizeof(AST*) * _len);
_vec[0] = first;
_vec[1] = rest;
}
- ATuple(Cursor c, AST* ast, va_list args) : AST(c), _len(0), _vec(0) {
+ ATuple(Cursor c, AST* ast, va_list args) : AST(T_TUPLE, c), _len(0), _vec(0) {
if (!ast) return;
_len = 2;
@@ -416,7 +420,6 @@ struct ATuple : public AST {
return false;
return true;
}
- void constrain(TEnv& tenv, Constraints& c) const throw(Error);
const ATuple* prot() const { return list_ref(1)->as<const ATuple*>(); }
ATuple* prot() { return list_ref(1)->as<ATuple*>(); }
@@ -848,8 +851,11 @@ void pprint(std::ostream& out, const AST* ast, CEnv* cenv, bool types);
void initLang(PEnv& penv, TEnv& tenv);
int eval(CEnv& cenv, Cursor& cursor, istream& is, bool execute);
int repl(CEnv& cenv);
+
+void resp_constrain(TEnv& tenv, Constraints& c, const AST* ast) throw(Error);
AST* resp_lift(CEnv& cenv, Code& code, AST* ast) throw();
CVal resp_compile(CEnv& cenv, const AST* ast) throw();
+
bool is_form(const AST* ast, const std::string& form);
bool is_primitive(const PEnv& penv, const AST* ast);
diff --git a/src/resp_gc.cpp b/src/resp_gc.cpp
index 4be07fb..288c491 100644
--- a/src/resp_gc.cpp
+++ b/src/resp_gc.cpp
@@ -40,7 +40,7 @@ resp_gc_allocate(unsigned size)
void* mem = Object::pool.alloc(size);
Object* obj = new (mem) Object();
- obj->tag(Object::OBJECT);
+ obj->tag(T_UNKNOWN);
return mem;
}
generated by cgit v1.2.1 (git 2.18.0) at 2024-06-28 23:41:17 +0000