Preliminary work on algebraic data types and run-time typing.

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

1 files changed, 74 insertions, 5 deletions

diff --git a/src/constrain.cpp b/src/constrain.cpp
index e5a8dc4..ef8e3bf 100644
--- a/src/constrain.cpp
+++ b/src/constrain.cpp
@@ -185,15 +185,84 @@ AIf::constrain(TEnv& tenv, Constraints& c) const throw(Error)
 }
 
 void
+AMatch::constrain(TEnv& tenv, Constraints& c) const throw(Error)
+{
+	THROW_IF(size() < 5, loc, "`match' requires at least 4 arguments");
+	const AST*   matchee  = (*(begin() + 1));
+	const AType* retT     = tenv.var();
+	const AType* matcheeT = NULL;// = tup<AType>(loc, tenv.U, 0);
+	matchee->constrain(tenv, c);
+	for (const_iterator i = begin() + 2; i != end();) {
+		const AST*    exp     = *i++;
+		const ATuple* pattern = exp->to<const ATuple*>();
+		THROW_IF(!pattern, exp->loc, "pattern expression expected");
+		const ASymbol* name = (*pattern->begin())->to<const ASymbol*>();
+		THROW_IF(!name, (*pattern->begin())->loc, "pattern does not start with a symbol");
+
+		const AType* consT = *tenv.ref(name);
+
+		if (!matcheeT) {
+			const AType* headT = consT->head()->as<const AType*>();
+			matcheeT = tup<AType>(loc, const_cast<AType*>(headT), 0);
+		}
+
+		THROW_IF(i == end(), pattern->loc, "missing pattern body");
+		const AST* body = *i++;
+		body->constrain(tenv, c);
+		c.constrain(tenv, body, retT); 
+	}
+	c.constrain(tenv, this, retT);
+	c.constrain(tenv, matchee, matcheeT);
+}
+
+void
+ADefType::constrain(TEnv& tenv, Constraints& c) const throw(Error)
+{
+	THROW_IF(size() < 3, loc, "`def-type' requires at least 2 arguments");
+	const_iterator i = begin() + 1;
+	const ATuple* prot = (*i)->to<const ATuple*>();
+	THROW_IF(!prot, (*i)->loc, "first argument of `def-type' is not a tuple");
+	const ASymbol* sym = (*prot->begin())->as<const ASymbol*>();
+	THROW_IF(!sym, (*prot->begin())->loc, "type name is not a symbol");
+	THROW_IF(tenv.ref(sym), loc, "type redefinition");
+	AType* type = tup<AType>(loc, tenv.U, 0);
+	for (const_iterator i = begin() + 2; i != end(); ++i) {
+		const ATuple*  exp   = (*i)->as<const ATuple*>();
+		const ASymbol* tag   = (*exp->begin())->as<const ASymbol*>();
+		AType*         consT = new AType(exp->loc, AType::EXPR);
+		consT->push_back(new AType(const_cast<ASymbol*>(sym), AType::NAME));
+		for (ATuple::const_iterator i = exp->begin(); i != exp->end(); ++i) {
+			const ASymbol* sym = (*i)->to<const ASymbol*>();
+			THROW_IF(!sym, (*i)->loc, "type expression element is not a symbol");
+			consT->push_back(new AType(const_cast<ASymbol*>(sym), AType::NAME));
+		}
+		type->push_back(consT);
+		tenv.def(tag, consT);
+	}
+	tenv.def(sym, type);
+}
+
+void
 ACons::constrain(TEnv& tenv, Constraints& c) const throw(Error)
 {
-	ASymbol* sym  = (*begin())->as<ASymbol*>();
-	AType*   type = tup<AType>(loc, new AType(sym), 0);
-	for (const_iterator i = begin() + 1; i != end(); ++i) {
+	const ASymbol* sym  = (*begin())->as<const ASymbol*>();
+	const AType*   type = NULL;
+
+	for (const_iterator i = begin() + 1; i != end(); ++i)
 		(*i)->constrain(tenv, c);
-		type->push_back(const_cast<AType*>(tenv.var(*i)));
-	}
 
+	if (sym->cppstr == "Tup") {
+		AType* tupT = tup<AType>(loc, tenv.Tup, 0);
+		for (const_iterator i = begin() + 1; i != end(); ++i) {
+			tupT->push_back(const_cast<AType*>(tenv.var(*i)));
+		}
+		type = tupT;
+	} else {
+		const AType** consTRef = tenv.ref(sym);
+		THROW_IF(!consTRef, loc, (format("call to undefined constructor `%1%'") % sym->cppstr).str());
+		const AType* consT = *consTRef;
+		type = tup<AType>(loc, const_cast<AType*>(consT->head()->as<const AType*>()), 0);
+	}
 	c.constrain(tenv, this, type);
 }