Pairs. Kinda.

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

1 files changed, 141 insertions, 20 deletions

diff --git a/tuplr.cpp b/tuplr.cpp
index ada3073..ff30496 100644
--- a/tuplr.cpp
+++ b/tuplr.cpp
@@ -192,13 +192,13 @@ struct ASTTuple : public AST, public vector<AST*> {
 	bool isForm(const string& f) { return !empty() && at(0)->str() == f; }
 	bool   contains(AST* child) const;
 	void   constrain(TEnv& tenv) const;
-	Value* compile(CEnv& cenv) { return NULL; }
+	Value* compile(CEnv& cenv) { throw SyntaxError("Tuple compiled"); }
 };
 
 /// Type Expression, e.g. "(Int)" or "(Fn ((Int)) (Float))"
 struct AType : public ASTTuple {
 	AType(const ASTTuple& t) : ASTTuple(t), var(false), ctype(0) {}
-	AType(unsigned i) : var(true), ctype(0), id(i) {}
+	AType(unsigned i) : var(true), id(i), ctype(0) {}
 	AType(ASTSymbol* n, const Type* t) : var(false), ctype(t) {
 		push_back(n);
 	}
@@ -230,9 +230,22 @@ struct AType : public ASTTuple {
 			return ASTTuple::operator==(rhs);
 		return false;
 	}
+	const Type* type() {
+		if (at(0)->str() == "Pair") {
+			vector<const Type*> types;
+			for (size_t i = 1; i < size(); ++i) {
+				assert(dynamic_cast<AType*>(at(i)));
+				types.push_back(((AType*)at(i))->type());
+			}
+			return PointerType::get(StructType::get(types, false), 0);
+		} else {
+			return ctype;
+		}
+	};
 	bool        var;
-	const Type* ctype;
 	unsigned    id;
+private:
+	const Type* ctype;
 };
 
 /// Closure (first-class function with captured lexical bindings)
@@ -256,7 +269,7 @@ struct ASTCall : public ASTTuple {
 	Value* compile(CEnv& cenv);
 };
 
-/// Definition special form, e.g. "(def x 2)" or "(def (next y) (+ y 1))"
+/// Definition special form, e.g. "(def x 2)"
 struct ASTDefinition : public ASTCall {
 	ASTDefinition(const ASTTuple& t) : ASTCall(t) {}
 	void   constrain(TEnv& tenv) const;
@@ -280,6 +293,27 @@ struct ASTPrimitive : public ASTCall {
 	unsigned arg;
 };
 
+/// Cons special form, e.g. "(cons 1 2)"
+struct ASTConsCall : public ASTCall {
+	ASTConsCall(const ASTTuple& t) : ASTCall(t) {}
+	void   constrain(TEnv& tenv) const;
+	Value* compile(CEnv& cenv);
+};
+
+/// Car special form, e.g. "(car p)"
+struct ASTCarCall : public ASTCall {
+	ASTCarCall(const ASTTuple& t) : ASTCall(t) {}
+	void   constrain(TEnv& tenv) const;
+	Value* compile(CEnv& cenv);
+};
+
+/// Cdr special form, e.g. "(cdr p)"
+struct ASTCdrCall : public ASTCall {
+	ASTCdrCall(const ASTTuple& t) : ASTCall(t) {}
+	void   constrain(TEnv& tenv) const;
+	Value* compile(CEnv& cenv);
+};
+
 
 /***************************************************************************
  * Parser - S-Expressions (SExp) -> AST Nodes (AST)                        *
@@ -366,6 +400,18 @@ parseFn(PEnv& penv, const SExp::List& c, UD)
 			parseExpression(penv, *a++));
 }
 
+static AST*
+parseCons(PEnv& penv, const SExp::List& c, UD)
+	{ return new ASTConsCall(pmap(penv, c)); }
+
+static AST*
+parseCar(PEnv& penv, const SExp::List& c, UD)
+	{ return new ASTCarCall(pmap(penv, c)); }
+
+static AST*
+parseCdr(PEnv& penv, const SExp::List& c, UD)
+	{ return new ASTCdrCall(pmap(penv, c)); }
+
 
 /***************************************************************************
  * Generic Lexical Environment                                             *
@@ -511,6 +557,37 @@ ASTPrimitive::constrain(TEnv& tenv) const
 	}
 }
 
+void
+ASTConsCall::constrain(TEnv& tenv) const
+{
+	AType* t = new AType(ASTTuple(tenv.penv.sym("Pair"), 0));
+	for (size_t i = 1; i < size(); ++i) {
+		at(i)->constrain(tenv);
+		t->push_back(tenv.type(at(i)));
+	}
+	tenv.constrain(this, t);
+}
+
+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));
+	tenv.constrain(at(1), tt);
+	tenv.constrain(this, ct);
+}
+
+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));
+	tenv.constrain(at(1), tt);
+	tenv.constrain(this, ct);
+}
+
 static void
 substitute(ASTTuple* tup, AST* from, AST* to)
 {
@@ -577,7 +654,8 @@ TEnv::unify(const Constraints& constraints) // TAPL 22.4
 	} else if (t->var && !s->contains(t)) {
 		substConstraints(cp, t, s);
 		return compose(unify(cp), TSubst(t, s));
-	} else if (s->isForm("Fn") && t->isForm("Fn")) {
+	} else if ((s->isForm("Fn") && t->isForm("Fn"))
+			|| (s->isForm("Pair") && t->isForm("Pair"))) {
 		AType* s1 = dynamic_cast<AType*>(s->at(1));
 		AType* t1 = dynamic_cast<AType*>(t->at(1));
 		AType* s2 = dynamic_cast<AType*>(s->at(2));
@@ -666,9 +744,9 @@ compileFunction(CEnv& cenv, const std::string& name, ASTTuple& prot, const Type*
 
 	vector<const Type*> cprot;
 	for (size_t i = 0; i < prot.size(); ++i) {
-		const AType* at = cenv.tenv.type(prot.at(i));
-		if (!at->ctype || at->var) throw CompileError("Parameter is untyped");
-		cprot.push_back(at->ctype);
+		AType* at = cenv.tenv.type(prot.at(i));
+		if (!at->type() || at->var) throw CompileError("Parameter is untyped");
+		cprot.push_back(at->type());
 	}
 
 	if (!retT) throw CompileError("Return is untyped");
@@ -693,7 +771,7 @@ ASTSymbol::compile(CEnv& cenv)
 {
 	AST** c = cenv.code.ref(this);
 	if (!c) throw SyntaxError((string("Undefined symbol: ") + cppstr).c_str());
-	return cenv.vals.def(this, cenv.compile(*c));
+	return cenv.compile(*c);
 }
 
 void
@@ -709,7 +787,7 @@ ASTClosure::lift(CEnv& cenv)
 	cenv.push();
 
 	// Write function declaration
-	Function* f = compileFunction(cenv, cenv.gensym("_fn"), *prot, cenv.tenv.type(at(2))->ctype);
+	Function* f = compileFunction(cenv, cenv.gensym("_fn"), *prot, cenv.tenv.type(at(2))->type());
 	BasicBlock* bb = BasicBlock::Create("entry", f);
 	cenv.builder.SetInsertPoint(bb);
 
@@ -784,7 +862,7 @@ ASTCall::compile(CEnv& cenv)
 
 	vector<Value*> params(size() - 1);
 	for (size_t i = 1; i < size(); ++i)
-	params[i-1] = cenv.compile(at(i));
+		params[i-1] = cenv.compile(at(i));
 
 	return cenv.builder.CreateCall(f, params.begin(), params.end(), "calltmp");
 }
@@ -842,7 +920,7 @@ ASTIf::compile(CEnv& cenv)
 	// Emit merge block (Phi node)
 	parent->getBasicBlockList().push_back(mergeBB);
 	cenv.builder.SetInsertPoint(mergeBB);
-	PHINode* pn = cenv.builder.CreatePHI(cenv.tenv.type(this)->ctype, "ifval");
+	PHINode* pn = cenv.builder.CreatePHI(cenv.tenv.type(this)->type(), "ifval");
 
 	for (Branches::iterator i = branches.begin(); i != branches.end(); ++i)
 		pn->addIncoming(i->first, i->second);
@@ -886,6 +964,43 @@ ASTPrimitive::compile(CEnv& cenv)
 	throw CompileError("Unknown primitive");
 }
 
+Value*
+ASTConsCall::compile(CEnv& cenv)
+{
+	vector<const Type*> types;
+	for (size_t i = 1; i < size(); ++i)
+		types.push_back(cenv.tenv.type(at(i))->type());
+
+	StructType* t = StructType::get(types, false);
+	Value* sP = cenv.builder.CreateMalloc(t);
+	Value* s = cenv.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair");
+	Value* carP = cenv.builder.CreateStructGEP(s, 0, "car");
+	Value* cdrP = cenv.builder.CreateStructGEP(s, 1, "cdr");
+	cenv.builder.CreateStore(cenv.compile(at(1)), carP);
+	cenv.builder.CreateStore(cenv.compile(at(2)), cdrP);
+	return sP;
+}
+
+Value*
+ASTCarCall::compile(CEnv& cenv)
+{
+	AST**  arg  = cenv.code.ref(at(1));
+	Value* sP   = arg ? (*arg)->compile(cenv) : at(1)->compile(cenv);
+	Value* s    = cenv.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair");
+	Value* carP = cenv.builder.CreateStructGEP(s, 0, "car");
+	return cenv.builder.CreateLoad(carP);
+}
+
+Value*
+ASTCdrCall::compile(CEnv& cenv)
+{
+	AST**  arg  = cenv.code.ref(at(1));
+	Value* sP   = arg ? (*arg)->compile(cenv) : at(1)->compile(cenv);
+	Value* s    = cenv.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair");
+	Value* cdrP = cenv.builder.CreateStructGEP(s, 1, "cdr");
+	return cenv.builder.CreateLoad(cdrP);
+}
+
 
 /***************************************************************************
  * REPL                                                                    *
@@ -896,9 +1011,12 @@ main()
 {
 #define PRIM(O, A) PEnv::Parser(parsePrim, Op(Instruction:: O, A))
 	PEnv penv;
-	penv.reg("fn",  PEnv::Parser(parseFn,   Op()));
-	penv.reg("if",  PEnv::Parser(parseIf,   Op()));
-	penv.reg("def", PEnv::Parser(parseDef,  Op()));
+	penv.reg("fn",   PEnv::Parser(parseFn,   Op()));
+	penv.reg("if",   PEnv::Parser(parseIf,   Op()));
+	penv.reg("def",  PEnv::Parser(parseDef,  Op()));
+	penv.reg("cons", PEnv::Parser(parseCons, Op()));
+	penv.reg("car", PEnv::Parser(parseCar, Op()));
+	penv.reg("cdr", PEnv::Parser(parseCdr, Op()));
 	penv.reg("+",   PRIM(Add,  0));
 	penv.reg("-",   PRIM(Sub,  0));
 	penv.reg("*",   PRIM(Mul,  0));
@@ -934,6 +1052,7 @@ main()
 		try {
 			AST* body = parseExpression(penv, exp); // Parse input
 			body->constrain(cenv.tenv); // Constrain types
+	
 			cenv.tenv.solve(); // Solve and apply type constraints
 
 			AType* bodyT = cenv.tenv.type(body);
@@ -942,10 +1061,10 @@ main()
 
 			body->lift(cenv);
 
-			if (bodyT->ctype) {
+			if (bodyT->type()) {
 				// Create anonymous function to insert code into.
 				ASTTuple* prot = new ASTTuple();
-				Function* f = compileFunction(cenv, cenv.gensym("_repl"), *prot, bodyT->ctype);
+				Function* f = compileFunction(cenv, cenv.gensym("_repl"), *prot, bodyT->type());
 				BasicBlock* bb = BasicBlock::Create("entry", f);
 				cenv.builder.SetInsertPoint(bb);
 				try {
@@ -957,12 +1076,14 @@ main()
 					throw e;
 				}
 				void* fp = engine->getPointerToFunction(f);
-				if (bodyT->ctype == Type::Int32Ty)
+				if (bodyT->type() == Type::Int32Ty)
 					std::cout << ";  " << ((int32_t (*)())fp)();
-				else if (bodyT->ctype == Type::FloatTy)
+				else if (bodyT->type() == Type::FloatTy)
 					std::cout << ";  " << ((float (*)())fp)();
-				else if (bodyT->ctype == Type::Int1Ty)
+				else if (bodyT->type() == Type::Int1Ty)
 					std::cout << ";  " << ((bool (*)())fp)();
+				else
+					std::cout << ";  " << ((void* (*)())fp)();
 			} else {
 				Value* val = cenv.compile(body);
 				std::cout << ";   " << val;