aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cps.cpp136
-rw-r--r--src/gc.cpp92
-rw-r--r--src/gclib.cpp41
-rw-r--r--src/llvm.cpp544
-rw-r--r--src/tuplr.cpp471
-rw-r--r--src/tuplr.hpp654
-rw-r--r--src/typing.cpp232
-rw-r--r--src/unify.cpp94
-rw-r--r--src/write.cpp97
9 files changed, 2361 insertions, 0 deletions
diff --git a/src/cps.cpp b/src/cps.cpp
new file mode 100644
index 0000000..8df11c2
--- /dev/null
+++ b/src/cps.cpp
@@ -0,0 +1,136 @@
+/* Tuplr Type Inferencing
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <set>
+#include "tuplr.hpp"
+
+/***************************************************************************
+ * CPS Conversion *
+ ***************************************************************************/
+
+/** (cps x cont) => (cont x) */
+AST*
+AST::cps(TEnv& tenv, AST* cont)
+{
+ return tup<ACall>(loc, cont, this, 0);
+}
+
+/** (cps (fn (a ...) body) cont) => (cont (fn (a ... k) (cps body k))*/
+AST*
+AFn::cps(TEnv& tenv, AST* cont)
+{
+ ATuple* copyProt = new ATuple(prot()->loc, *prot());
+ ASymbol* contArg = tenv.penv.gensym("_k");
+ copyProt->push_back(contArg);
+ AFn* copy = tup<AFn>(loc, tenv.penv.sym("fn"), copyProt, 0);
+ const_iterator p = begin();
+ ++(++p);
+ for (; p != end(); ++p)
+ copy->push_back((*p)->cps(tenv, contArg));
+ return tup<ACall>(loc, cont, copy, 0);
+}
+
+AST*
+APrimitive::cps(TEnv& tenv, AST* cont)
+{
+ return value() ? tup<ACall>(loc, cont, this, 0) : ACall::cps(tenv, cont);
+}
+
+/** (cps (f a b ...)) => (a (fn (x) (b (fn (y) ... (cont (f x y ...)) */
+AST*
+ACall::cps(TEnv& tenv, AST* cont)
+{
+ std::vector< std::pair<AFn*, AST*> > funcs;
+ AFn* fn = NULL;
+ ASymbol* arg = NULL;
+
+ // Make a continuation for each element (operator and arguments)
+ // Argument evaluation continuations are not themselves in CPS.
+ // Each makes a tail call to the next, and the last makes a tail
+ // call to the continuation of this call
+ ssize_t firstFn = -1;
+ for (size_t i = 0; i < size(); ++i) {
+ if (!at(i)->to<ATuple*>()) {
+ funcs.push_back(make_pair((AFn*)NULL, at(i)));
+ } else {
+ arg = tenv.penv.gensym("a");
+
+ if (firstFn == -1)
+ firstFn = i;
+
+ AFn* thisFn = tup<AFn>(loc, tenv.penv.sym("fn"),
+ tup<ATuple>(at(i)->loc, arg, 0),
+ 0);
+
+ if (fn)
+ fn->push_back(at(i)->cps(tenv, thisFn));
+
+ funcs.push_back(make_pair(thisFn, arg));
+ fn = thisFn;
+ }
+ }
+
+ if (firstFn != -1) {
+ // Call this call's callee in the last argument evaluator
+ ACall* call = tup<ACall>(loc, 0);
+ assert(funcs.size() == size());
+ for (size_t i = 0; i < funcs.size(); ++i)
+ call->push_back(funcs[i].second);
+
+ assert(fn);
+ fn->push_back(call->cps(tenv, cont));
+ return at(firstFn)->cps(tenv, funcs[firstFn].first);
+ } else {
+ assert(at(0)->value());
+ ACall* ret = tup<ACall>(loc, 0);
+ for (size_t i = 0; i < size(); ++i)
+ ret->push_back(at(i));
+ if (!to<APrimitive*>())
+ ret->push_back(cont);
+ return ret;
+ }
+}
+
+/** (cps (def x y)) => (y (fn (x) (cont))) */
+AST*
+ADef::cps(TEnv& tenv, AST* cont)
+{
+ AST* val = at(2)->cps(tenv, cont);
+ ACall* valCall = val->to<ACall*>();
+ assert(valCall);
+ return tup<ADef>(loc, tenv.penv.sym("def"), sym(), valCall->at(1), 0);
+}
+
+/** (cps (if c t ... e)) => */
+AST*
+AIf::cps(TEnv& tenv, AST* cont)
+{
+ ASymbol* argSym = tenv.penv.gensym("c");
+ if (at(1)->value()) {
+ return tup<AIf>(loc, tenv.penv.sym("if"), at(1),
+ at(2)->cps(tenv, cont),
+ at(3)->cps(tenv, cont), 0);
+ } else {
+ AFn* contFn = tup<AFn>(loc, tenv.penv.sym("fn"),
+ tup<ATuple>(at(1)->loc, argSym, tenv.penv.gensym("_k"), 0),
+ tup<AIf>(loc, tenv.penv.sym("if"), argSym,
+ at(2)->cps(tenv, cont),
+ at(3)->cps(tenv, cont), 0));
+ return at(1)->cps(tenv, contFn);
+ }
+}
+
diff --git a/src/gc.cpp b/src/gc.cpp
new file mode 100644
index 0000000..3964324
--- /dev/null
+++ b/src/gc.cpp
@@ -0,0 +1,92 @@
+/* Tuplr: A programming language
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <cassert>
+#include <set>
+#include <iostream>
+#include "tuplr.hpp"
+
+using namespace std;
+
+void*
+GC::alloc(size_t size, GC::Tag tag)
+{
+ size += (4 - (size % 4)); // Align to 32-bits
+ size += sizeof(Object::Header);
+ void* ret = malloc(size);
+ ((Object::Header*)ret)->mark = 0;
+ ((Object::Header*)ret)->tag = tag;
+ ret = (char*)ret + sizeof(Object::Header);
+ _heap.push_back((Object*)ret);
+ return ret;
+}
+
+inline void
+mark(const Object* obj)
+{
+ if (!obj || obj->marked())
+ return;
+
+ obj->mark(true);
+ switch (obj->tag()) {
+ case GC::TAG_FRAME:
+ break;
+ case GC::TAG_AST:
+ const ATuple* tup = dynamic_cast<const ATuple*>((AST*)obj);
+ if (tup)
+ FOREACH(ATuple::const_iterator, i, *tup)
+ mark(*i);
+ break;
+ }
+}
+
+void
+GC::collect(const Roots& roots)
+{
+ //const size_t oldSize = _heap.size();
+
+ for (Roots::const_iterator i = roots.begin(); i != roots.end(); ++i)
+ mark(*i);
+
+ for (Heap::iterator i = _heap.begin(); i != _heap.end();) {
+ assert((*i)->tag() == GC::TAG_AST || (*i)->tag() == GC::TAG_FRAME);
+ Heap::iterator next = i;
+ ++next;
+
+ if ((*i)->marked()) {
+ (*i)->mark(false);
+ } else {
+ switch ((*i)->tag()) {
+ case GC::TAG_FRAME:
+ free((char*)(*i) - sizeof(Object::Header));
+ _heap.erase(i);
+ break;
+ case GC::TAG_AST:
+ AST* ast = (AST*)*i;
+ if (!ast->to<AType*>()) { // FIXME
+ (ast)->~AST();
+ free((char*)(*i) - sizeof(Object::Header));
+ _heap.erase(i);
+ }
+ break;
+ }
+ }
+ i = next;
+ }
+ //std::cerr << "[GC] Collect " << oldSize << " => " << _heap.size() << endl;
+}
+
diff --git a/src/gclib.cpp b/src/gclib.cpp
new file mode 100644
index 0000000..8c9f140
--- /dev/null
+++ b/src/gclib.cpp
@@ -0,0 +1,41 @@
+/* Tuplr: A programming language
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "tuplr.hpp"
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+extern "C" {
+
+void*
+tuplr_gc_allocate(unsigned size, uint8_t tag)
+{
+ static const size_t COLLECT_SIZE = 8 * 1024 * 1024; // 8 MiB
+
+ static size_t allocated = 0;
+ allocated += size;
+ if (allocated > COLLECT_SIZE) {
+ Object::pool.collect(Object::pool.roots());
+ allocated = 0;
+ }
+
+ return Object::pool.alloc(size, (GC::Tag)tag);
+}
+
+}
+
diff --git a/src/llvm.cpp b/src/llvm.cpp
new file mode 100644
index 0000000..b5e397e
--- /dev/null
+++ b/src/llvm.cpp
@@ -0,0 +1,544 @@
+/* Tuplr: A programming language
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <map>
+#include <sstream>
+#include <boost/format.hpp>
+#include "llvm/Analysis/Verifier.h"
+#include "llvm/Assembly/AsmAnnotationWriter.h"
+#include "llvm/DerivedTypes.h"
+#include "llvm/ExecutionEngine/ExecutionEngine.h"
+#include "llvm/Instructions.h"
+#include "llvm/Module.h"
+#include "llvm/ModuleProvider.h"
+#include "llvm/PassManager.h"
+#include "llvm/Support/IRBuilder.h"
+#include "llvm/Target/TargetData.h"
+#include "llvm/Transforms/Scalar.h"
+#include "tuplr.hpp"
+
+using namespace llvm;
+using namespace std;
+using boost::format;
+
+static inline Value* llVal(CValue v) { return static_cast<Value*>(v); }
+static inline Function* llFunc(CFunction f) { return static_cast<Function*>(f); }
+
+static const Type*
+llType(const AType* t)
+{
+ if (t->kind == AType::PRIM) {
+ if (t->at(0)->str() == "Nothing") return Type::VoidTy;
+ if (t->at(0)->str() == "Bool") return Type::Int1Ty;
+ if (t->at(0)->str() == "Int") return Type::Int32Ty;
+ if (t->at(0)->str() == "Float") return Type::FloatTy;
+ throw Error(t->loc, string("Unknown primitive type `") + t->str() + "'");
+ /*} else if (t->kind == AType::EXPR && t->at(0)->str() == "Fn") {
+ AType* retT = t->at(2)->as<AType*>();
+ if (!llType(retT))
+ return NULL;
+
+ vector<const Type*> cprot;
+ const ATuple* prot = t->at(1)->to<ATuple*>();
+ for (size_t i = 0; i < prot->size(); ++i) {
+ AType* at = prot->at(i)->to<AType*>();
+ const Type* lt = llType(at);
+ if (lt)
+ cprot.push_back(lt);
+ else
+ return NULL;
+ }
+
+ FunctionType* fT = FunctionType::get(llType(retT), cprot, false);
+ return PointerType::get(fT, 0);
+ */
+ }
+ return NULL; // non-primitive type
+}
+
+
+/***************************************************************************
+ * LLVM Engine *
+ ***************************************************************************/
+
+struct LLVMEngine : public Engine {
+ LLVMEngine()
+ : module(new Module("tuplr"))
+ , engine(ExecutionEngine::create(module))
+ , emp(module)
+ , opt(&emp)
+ {
+ // Set up optimiser pipeline
+ const TargetData* target = engine->getTargetData();
+ opt.add(new TargetData(*target)); // Register target arch
+ opt.add(createInstructionCombiningPass()); // Simple optimizations
+ opt.add(createReassociatePass()); // Reassociate expressions
+ opt.add(createGVNPass()); // Eliminate Common Subexpressions
+ opt.add(createCFGSimplificationPass()); // Simplify control flow
+
+ // Declare host provided allocation primitive
+ std::vector<const Type*> argsT(1, Type::Int32Ty); // unsigned size
+ argsT.push_back(Type::Int8Ty); // char tag
+ FunctionType* funcT = FunctionType::get(PointerType::get(Type::Int8Ty, 0), argsT, false);
+ alloc = Function::Create(funcT, Function::ExternalLinkage,
+ "tuplr_gc_allocate", module);
+ }
+
+ CFunction startFunction(CEnv& cenv,
+ const std::string& name, const AType* retT, const ATuple& argsT,
+ const vector<string> argNames)
+ {
+ Function::LinkageTypes linkage = Function::ExternalLinkage;
+
+ vector<const Type*> cprot;
+ for (size_t i = 0; i < argsT.size(); ++i) {
+ AType* at = argsT.at(i)->as<AType*>();
+ THROW_IF(!llType(at), Cursor(), string("parameter has non-concrete type ")
+ + at->str())
+ cprot.push_back(llType(at));
+ }
+
+ THROW_IF(!llType(retT), Cursor(), "return has non-concrete type");
+ FunctionType* fT = FunctionType::get(llType(retT), cprot, false);
+ Function* f = Function::Create(fT, linkage, name, module);
+
+ // Note f->getName() may be different from name
+ // however LLVM chooses to mangle is fine, we keep a pointer
+
+ // Set argument names in generated code
+ Function::arg_iterator a = f->arg_begin();
+ if (!argNames.empty())
+ for (size_t i = 0; i != argsT.size(); ++a, ++i)
+ a->setName(argNames.at(i));
+
+ BasicBlock* bb = BasicBlock::Create("entry", f);
+ builder.SetInsertPoint(bb);
+
+ return f;
+ }
+
+ void finishFunction(CEnv& cenv, CFunction f, const AType* retT, CValue ret) {
+ if (retT->concrete()) {
+ Value* retVal = llVal(ret);
+ builder.CreateRet(retVal);
+ } else {
+ builder.CreateRetVoid();
+ }
+
+ /*std::cerr << "MODULE {" << endl;
+ module->dump();
+ std::cerr << "}" << endl;*/
+ verifyFunction(*static_cast<Function*>(f));
+ if (cenv.args.find("-g") == cenv.args.end())
+ opt.run(*static_cast<Function*>(f));
+ }
+
+ void eraseFunction(CEnv& cenv, CFunction f) {
+ if (f)
+ llFunc(f)->eraseFromParent();
+ }
+
+ void writeModule(CEnv& cenv, std::ostream& os) {
+ AssemblyAnnotationWriter writer;
+ module->print(os, &writer);
+ }
+
+ const string call(CEnv& cenv, CFunction f, AType* retT) {
+ void* fp = engine->getPointerToFunction(llFunc(f));
+ const Type* t = llType(retT);
+ THROW_IF(!fp, Cursor(), "unable to get function pointer");
+ THROW_IF(!t, Cursor(), "function with non-concrete return type called");
+
+ std::stringstream ss;
+ if (t == Type::Int32Ty)
+ ss << ((int32_t (*)())fp)();
+ else if (t == Type::FloatTy)
+ ss << showpoint << ((float (*)())fp)();
+ else if (t == Type::Int1Ty)
+ ss << (((bool (*)())fp)() ? "#t" : "#f");
+ else
+ ss << ((void* (*)())fp)();
+ return ss.str();
+ }
+
+ Module* module;
+ ExecutionEngine* engine;
+ IRBuilder<> builder;
+ CFunction alloc;
+ ExistingModuleProvider emp;
+ FunctionPassManager opt;
+};
+
+static LLVMEngine*
+llEngine(CEnv& cenv)
+{
+ return reinterpret_cast<LLVMEngine*>(cenv.engine());
+}
+
+/// Shared library entry point
+Engine*
+tuplr_new_engine()
+{
+ return new LLVMEngine();
+}
+
+/// Shared library entry point
+void
+tuplr_free_engine(Engine* engine)
+{
+ delete (LLVMEngine*)engine;
+}
+
+
+/***************************************************************************
+ * Code Generation *
+ ***************************************************************************/
+
+#define LITERAL(CT, NAME, COMPILED) \
+template<> CValue ALiteral<CT>::compile(CEnv& cenv) { return (COMPILED); } \
+template<> void \
+ALiteral<CT>::constrain(TEnv& tenv, Constraints& c) const { \
+ c.constrain(tenv, this, tenv.named(NAME)); \
+}
+
+/// Literal template instantiations
+LITERAL(int32_t, "Int", ConstantInt::get(Type::Int32Ty, val, true))
+LITERAL(float, "Float", ConstantFP::get(Type::FloatTy, val))
+LITERAL(bool, "Bool", ConstantInt::get(Type::Int1Ty, val, false))
+
+CValue
+ASymbol::compile(CEnv& cenv)
+{
+ return cenv.vals.ref(this);
+}
+
+void
+AFn::lift(CEnv& cenv)
+{
+ cenv.push();
+ for (const_iterator p = prot()->begin(); p != prot()->end(); ++p)
+ cenv.def((*p)->as<ASymbol*>(), *p, NULL, NULL);
+
+ // Lift body
+ for (size_t i = 2; i < size(); ++i)
+ at(i)->lift(cenv);
+
+ cenv.pop();
+
+ AType* type = cenv.type(this);
+ if (impls.find(type) || !type->concrete())
+ return;
+
+ AType* protT = type->at(1)->as<AType*>();
+ liftCall(cenv, *protT);
+}
+
+void
+AFn::liftCall(CEnv& cenv, const AType& argsT)
+{
+ TEnv::GenericTypes::const_iterator gt = cenv.tenv.genericTypes.find(this);
+ assert(gt != cenv.tenv.genericTypes.end());
+ AType* genericType = new AType(*gt->second);
+ AType* thisType = genericType;
+ Subst argsSubst;
+
+ if (!genericType->concrete()) {
+ // Build substitution to apply to generic type
+ assert(argsT.size() == prot()->size());
+ ATuple* genericProtT = gt->second->at(1)->as<ATuple*>();
+ for (size_t i = 0; i < argsT.size(); ++i) {
+ const AType* genericArgT = genericProtT->at(i)->to<const AType*>();
+ AType* callArgT = argsT.at(i)->to<AType*>();
+ assert(genericArgT);
+ assert(callArgT);
+ if (callArgT->kind == AType::EXPR) {
+ assert(genericArgT->kind == AType::EXPR);
+ assert(callArgT->size() == genericArgT->size());
+ for (size_t i = 0; i < callArgT->size(); ++i) {
+ AType* gT = genericArgT->at(i)->to<AType*>();
+ AType* aT = callArgT->at(i)->to<AType*>();
+ if (gT && aT)
+ argsSubst.add(gT, aT);
+ }
+ } else {
+ argsSubst.add(genericArgT, callArgT);
+ }
+ }
+
+ // Apply substitution to get concrete type for this call
+ thisType = argsSubst.apply(genericType)->as<AType*>();
+ THROW_IF(!thisType->concrete(), loc,
+ string("unable to resolve concrete type for function :: ")
+ + thisType->str() + "\n" + this->str());
+ }
+
+ Object::pool.addRoot(thisType);
+ if (impls.find(thisType))
+ return;
+
+ ATuple* protT = thisType->at(1)->as<ATuple*>();
+
+ vector<string> argNames;
+ for (size_t i = 0; i < prot()->size(); ++i) {
+ argNames.push_back(prot()->at(i)->str());
+ }
+
+ // Write function declaration
+ const string name = (this->name == "") ? cenv.penv.gensymstr("_fn") : this->name;
+ Function* f = llFunc(cenv.engine()->startFunction(cenv, name,
+ thisType->at(thisType->size()-1)->to<AType*>(),
+ *protT, argNames));
+
+ cenv.push();
+ Subst oldSubst = cenv.tsubst;
+ cenv.tsubst = Subst::compose(cenv.tsubst, Subst::compose(argsSubst, subst));
+
+//#define EXPLICIT_STACK_FRAMES 1
+
+#ifdef EXPLICIT_STACK_FRAMES
+ vector<const Type*> types;
+ types.push_back(Type::Int8Ty);
+ types.push_back(Type::Int8Ty);
+ size_t s = 16; // stack frame size in bits
+#endif
+
+ // Bind argument values in CEnv
+ vector<Value*> args;
+ const_iterator p = prot()->begin();
+ size_t i = 0;
+ for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++p, ++i) {
+ AType* t = protT->at(i)->as<AType*>();
+ const Type* lt = llType(t);
+ THROW_IF(!lt, loc, "untyped parameter\n");
+ cenv.def((*p)->as<ASymbol*>(), *p, t, &*a);
+#ifdef EXPLICIT_STACK_FRAMES
+ types.push_back(lt);
+ s += std::max(lt->getPrimitiveSizeInBits(), unsigned(8));
+#endif
+ }
+
+
+#ifdef EXPLICIT_STACK_FRAMES
+ IRBuilder<> builder = llEngine(cenv)->builder;
+
+ // Scan out definitions
+ for (size_t i = 0; i < size(); ++i) {
+ ADef* def = at(i)->to<ADef*>();
+ if (def) {
+ const Type* lt = llType(cenv.type(def->at(2)));
+ THROW_IF(!lt, loc, "untyped definition\n");
+ types.push_back(lt);
+ s += std::max(lt->getPrimitiveSizeInBits(), unsigned(8));
+ }
+ }
+
+ // Create stack frame
+ StructType* frameT = StructType::get(types, false);
+ Value* tag = ConstantInt::get(Type::Int8Ty, GC::TAG_FRAME);
+ Value* frameSize = ConstantInt::get(Type::Int32Ty, s / 8);
+ Value* frame = builder.CreateCall2(llVal(cenv.alloc), frameSize, tag, "frame");
+ Value* framePtr = builder.CreateBitCast(frame, PointerType::get(frameT, 0));
+
+ // Bind parameter values in stack frame
+ i = 2;
+ for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++i) {
+ Value* v = builder.CreateStructGEP(framePtr, i, "arg");
+ builder.CreateStore(&*a, v);
+ }
+#endif
+
+ // Write function body
+ try {
+ // Define value first for recursion
+ cenv.precompile(this, f);
+ impls.push_back(make_pair(thisType, f));
+ CValue retVal = NULL;
+ for (size_t i = 2; i < size(); ++i)
+ retVal = cenv.compile(at(i));
+ cenv.engine()->finishFunction(cenv, f, cenv.type(at(size()-1)), retVal);
+ } catch (Error& e) {
+ f->eraseFromParent(); // Error reading body, remove function
+ cenv.pop();
+ throw e;
+ }
+ cenv.tsubst = oldSubst;
+ cenv.pop();
+}
+
+CValue
+AFn::compile(CEnv& cenv)
+{
+ return NULL;
+}
+
+void
+ACall::lift(CEnv& cenv)
+{
+ AFn* c = cenv.tenv.resolve(at(0))->to<AFn*>();
+ AType argsT(loc, NULL);
+
+ // Lift arguments
+ for (size_t i = 1; i < size(); ++i) {
+ at(i)->lift(cenv);
+ argsT.push_back(cenv.type(at(i)));
+ }
+
+ if (!c) return; // Primitive
+
+ if (c->prot()->size() < size() - 1)
+ throw Error(loc, (format("too many arguments to function `%1%'") % at(0)->str()).str());
+ if (c->prot()->size() > size() - 1)
+ throw Error(loc, (format("too few arguments to function `%1%'") % at(0)->str()).str());
+
+ c->liftCall(cenv, argsT); // Lift called closure
+}
+
+CValue
+ACall::compile(CEnv& cenv)
+{
+ AFn* c = cenv.tenv.resolve(at(0))->to<AFn*>();
+
+ if (!c) return NULL; // Primitive
+
+ AType protT(loc, NULL);
+ vector<const Type*> types;
+ for (size_t i = 1; i < size(); ++i) {
+ protT.push_back(cenv.type(at(i)));
+ types.push_back(llType(cenv.type(at(i))));
+ }
+
+ TEnv::GenericTypes::const_iterator gt = cenv.tenv.genericTypes.find(c);
+ assert(gt != cenv.tenv.genericTypes.end());
+ AType fnT(loc, cenv.penv.sym("Fn"), &protT, cenv.type(this), 0);
+ Function* f = (Function*)c->impls.find(&fnT);
+ THROW_IF(!f, loc, (format("callee failed to compile for type %1%") % fnT.str()).str());
+
+ vector<Value*> params(size() - 1);
+ for (size_t i = 0; i < types.size(); ++i)
+ params[i] = llVal(cenv.compile(at(i+1)));
+
+ return llEngine(cenv)->builder.CreateCall(f, params.begin(), params.end());
+}
+
+void
+ADef::lift(CEnv& cenv)
+{
+ // Define stub first for recursion
+ cenv.def(sym(), at(2), cenv.type(at(2)), NULL);
+ AFn* c = at(2)->to<AFn*>();
+ if (c)
+ c->name = sym()->str();
+ at(2)->lift(cenv);
+}
+
+CValue
+ADef::compile(CEnv& cenv)
+{
+ // Define stub first for recursion
+ cenv.def(sym(), at(2), cenv.type(at(2)), NULL);
+ CValue val = cenv.compile(at(size() - 1));
+ cenv.vals.def(sym(), val);
+ return val;
+}
+
+CValue
+AIf::compile(CEnv& cenv)
+{
+ typedef vector< pair<Value*, BasicBlock*> > Branches;
+ Function* parent = llEngine(cenv)->builder.GetInsertBlock()->getParent();
+ BasicBlock* mergeBB = BasicBlock::Create("endif");
+ BasicBlock* nextBB = NULL;
+ Branches branches;
+ for (size_t i = 1; i < size() - 1; i += 2) {
+ Value* condV = llVal(cenv.compile(at(i)));
+ BasicBlock* thenBB = BasicBlock::Create((format("then%1%") % ((i+1)/2)).str());
+
+ nextBB = BasicBlock::Create((format("else%1%") % ((i+1)/2)).str());
+
+ llEngine(cenv)->builder.CreateCondBr(condV, thenBB, nextBB);
+
+ // Emit then block for this condition
+ parent->getBasicBlockList().push_back(thenBB);
+ llEngine(cenv)->builder.SetInsertPoint(thenBB);
+ Value* thenV = llVal(cenv.compile(at(i+1)));
+ llEngine(cenv)->builder.CreateBr(mergeBB);
+ branches.push_back(make_pair(thenV, llEngine(cenv)->builder.GetInsertBlock()));
+
+ parent->getBasicBlockList().push_back(nextBB);
+ llEngine(cenv)->builder.SetInsertPoint(nextBB);
+ }
+
+ // Emit final else block
+ llEngine(cenv)->builder.SetInsertPoint(nextBB);
+ Value* elseV = llVal(cenv.compile(at(size() - 1)));
+ llEngine(cenv)->builder.CreateBr(mergeBB);
+ branches.push_back(make_pair(elseV, llEngine(cenv)->builder.GetInsertBlock()));
+
+ // Emit merge block (Phi node)
+ parent->getBasicBlockList().push_back(mergeBB);
+ llEngine(cenv)->builder.SetInsertPoint(mergeBB);
+ PHINode* pn = llEngine(cenv)->builder.CreatePHI(llType(cenv.type(this)), "ifval");
+
+ FOREACH(Branches::iterator, i, branches)
+ pn->addIncoming(i->first, i->second);
+
+ return pn;
+}
+
+CValue
+APrimitive::compile(CEnv& cenv)
+{
+ Value* a = llVal(cenv.compile(at(1)));
+ Value* b = llVal(cenv.compile(at(2)));
+ bool isFloat = cenv.type(at(1))->str() == "Float";
+ const string n = at(0)->to<ASymbol*>()->str();
+
+ // 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 == "and") op = Instruction::And;
+ if (n == "or") op = Instruction::Or;
+ if (n == "xor") op = Instruction::Xor;
+ if (n == "/") op = isFloat ? Instruction::FDiv : Instruction::SDiv;
+ if (n == "%") op = isFloat ? Instruction::FRem : Instruction::SRem;
+ if (op != 0) {
+ Value* val = llEngine(cenv)->builder.CreateBinOp(op, a, b);
+ for (size_t i = 3; i < size(); ++i)
+ val = llEngine(cenv)->builder.CreateBinOp(op, val, llVal(cenv.compile(at(i))));
+ return val;
+ }
+
+ // Comparison operations
+ CmpInst::Predicate pred = (CmpInst::Predicate)0;
+ if (n == "=") pred = isFloat ? CmpInst::FCMP_OEQ : CmpInst::ICMP_EQ ;
+ if (n == "!=") pred = isFloat ? CmpInst::FCMP_ONE : CmpInst::ICMP_NE ;
+ if (n == ">") pred = isFloat ? CmpInst::FCMP_OGT : CmpInst::ICMP_SGT;
+ if (n == ">=") pred = isFloat ? CmpInst::FCMP_OGE : CmpInst::ICMP_SGE;
+ if (n == "<") pred = isFloat ? CmpInst::FCMP_OLT : CmpInst::ICMP_SLT;
+ if (n == "<=") pred = isFloat ? CmpInst::FCMP_OLE : CmpInst::ICMP_SLE;
+ if (pred != 0) {
+ if (isFloat)
+ return llEngine(cenv)->builder.CreateFCmp(pred, a, b);
+ else
+ return llEngine(cenv)->builder.CreateICmp(pred, a, b);
+ }
+
+ throw Error(loc, "unknown primitive");
+}
+
diff --git a/src/tuplr.cpp b/src/tuplr.cpp
new file mode 100644
index 0000000..7dd3e9b
--- /dev/null
+++ b/src/tuplr.cpp
@@ -0,0 +1,471 @@
+/* Tuplr: A programming language
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <cerrno>
+#include <cstring>
+#include <fstream>
+#include <set>
+#include <sstream>
+#include <stack>
+#include "tuplr.hpp"
+
+using namespace std;
+using boost::format;
+
+GC Object::pool;
+
+template<typename Atom>
+ostream&
+operator<<(ostream& out, const Exp<Atom>& exp)
+{
+ switch (exp.type) {
+ case Exp<Atom>::ATOM:
+ out << exp.atom;
+ break;
+ case Exp<Atom>::LIST:
+ out << "(";
+ for (size_t i = 0; i != exp.size(); ++i)
+ out << exp.at(i) << ((i != exp.size() - 1) ? " " : "");
+ out << ")";
+ break;
+ }
+ return out;
+}
+
+
+/***************************************************************************
+ * Lexer *
+ ***************************************************************************/
+
+inline int
+readChar(Cursor& cur, istream& in)
+{
+ int ch = in.get();
+ switch (ch) {
+ case '\n': ++cur.line; cur.col = 0; break;
+ default: ++cur.col;
+ }
+ return ch;
+}
+
+SExp
+readExpression(Cursor& cur, istream& in)
+{
+#define PUSH(s, t) { if (t != "") { s.top().push_back(SExp(loc, t)); t = ""; } }
+#define YIELD(s, t) { if (s.empty()) { return SExp(loc, t); } else PUSH(s, t) }
+ stack<SExp> stk;
+ string tok;
+ Cursor loc; // start of tok
+ while (int c = readChar(cur, in)) {
+ switch (c) {
+ case EOF:
+ THROW_IF(!stk.empty(), cur, "unexpected end of file")
+ return SExp(cur);
+ case ';':
+ while ((c = readChar(cur, in)) != '\n') {}
+ case '\n': case ' ': case '\t':
+ if (tok != "") YIELD(stk, tok);
+ break;
+ case '"':
+ loc = cur;
+ do { tok.push_back(c); } while ((c = readChar(cur, in)) != '"');
+ YIELD(stk, tok + '"');
+ break;
+ case '(':
+ stk.push(SExp(cur));
+ break;
+ case ')':
+ switch (stk.size()) {
+ case 0:
+ throw Error(cur, "unexpected `)'");
+ case 1:
+ PUSH(stk, tok);
+ return stk.top();
+ default:
+ PUSH(stk, tok);
+ SExp l = stk.top();
+ stk.pop();
+ stk.top().push_back(l);
+ }
+ break;
+ case '#':
+ if (in.peek() == '|') {
+ while (!(readChar(cur, in) == '|' && readChar(cur, in) == '#')) {}
+ break;
+ }
+ default:
+ if (tok == "") loc = cur;
+ tok += c;
+ }
+ }
+ switch (stk.size()) {
+ case 0: return SExp(loc, tok);
+ case 1: return stk.top();
+ default: throw Error(cur, "missing `)'");
+ }
+ return SExp(cur);
+}
+
+
+/***************************************************************************
+ * Macro Functions *
+ ***************************************************************************/
+
+inline SExp
+macDef(PEnv& penv, const SExp& exp)
+{
+ THROW_IF(exp.size() < 3, exp.loc, "[MAC] `def' requires at least 2 arguments")
+ if (exp.at(1).type == SExp::ATOM) {
+ return exp;
+ } else {
+ // (def (f x) y) => (def f (fn (x) y))
+ SExp argsExp(exp.loc);
+ for (size_t i = 1; i < exp.at(1).size(); ++i)
+ argsExp.push_back(exp.at(1).at(i));
+ SExp fnExp(exp.at(2).loc);
+ fnExp.push_back(SExp(exp.at(2).loc, "fn"));
+ fnExp.push_back(argsExp);
+ for (size_t i = 2; i < exp.size(); ++i)
+ fnExp.push_back(exp.at(i));
+ SExp ret(exp.loc);
+ ret.push_back(exp.at(0));
+ ret.push_back(exp.at(1).at(0));
+ ret.push_back(fnExp);
+ return ret;
+ }
+}
+
+
+/***************************************************************************
+ * Parser Functions *
+ ***************************************************************************/
+
+template<typename C>
+inline AST*
+parseCall(PEnv& penv, const SExp& exp, void* arg)
+{
+ return new C(exp, penv.parseTuple(exp));
+}
+
+template<typename T>
+inline AST*
+parseLiteral(PEnv& penv, const SExp& exp, void* arg)
+{
+ return new ALiteral<T>(*reinterpret_cast<T*>(arg), exp.loc);
+}
+
+inline AST*
+parseFn(PEnv& penv, const SExp& exp, void* arg)
+{
+ if (exp.size() < 2)
+ throw Error(exp.loc, "Missing function parameters and body");
+ else if (exp.size() < 3)
+ throw Error(exp.loc, "Missing function body");
+ SExp::const_iterator a = exp.begin(); ++a;
+ AFn* ret = tup<AFn>(exp.loc, penv.sym("fn"), new ATuple(penv.parseTuple(*a++)), 0);
+ while (a != exp.end())
+ ret->push_back(penv.parse(*a++));
+ return ret;
+}
+
+
+/***************************************************************************
+ * Standard Definitions *
+ ***************************************************************************/
+
+void
+initLang(PEnv& penv, TEnv& tenv)
+{
+ // Types
+ tenv.def(penv.sym("Nothing"), make_pair((AST*)0, new AType(penv.sym("Nothing"))));
+ tenv.def(penv.sym("Bool"), make_pair((AST*)0, new AType(penv.sym("Bool"))));
+ tenv.def(penv.sym("Int"), make_pair((AST*)0, new AType(penv.sym("Int"))));
+ tenv.def(penv.sym("Float"), make_pair((AST*)0, new AType(penv.sym("Float"))));
+
+ // 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));
+
+ // Macros
+ penv.defmac("def", macDef);
+
+ // Special forms
+ penv.reg(true, "fn", PEnv::Handler(parseFn));
+ penv.reg(true, "if", PEnv::Handler(parseCall<AIf>));
+ penv.reg(true, "def", PEnv::Handler(parseCall<ADef>));
+
+ // Numeric primitives
+ penv.reg(true, "+", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "-", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "*", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "/", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "%", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "and", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "or", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "xor", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "=", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "!=", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, ">", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, ">=", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "<", PEnv::Handler(parseCall<APrimitive>));
+ penv.reg(true, "<=", PEnv::Handler(parseCall<APrimitive>));
+}
+
+
+/***************************************************************************
+ * EVAL/REPL *
+ ***************************************************************************/
+
+int
+eval(CEnv& cenv, const string& name, istream& is)
+{
+ AST* result = NULL;
+ AType* resultType = NULL;
+ list< pair<SExp, AST*> > exprs;
+ Cursor cursor(name);
+ try {
+ while (true) {
+ SExp exp = readExpression(cursor, is);
+ if (exp.type == SExp::LIST && exp.empty())
+ break;
+
+ result = cenv.penv.parse(exp); // Parse input
+ Constraints c;
+ result->constrain(cenv.tenv, c); // Constrain types
+ cenv.tsubst = Subst::compose(cenv.tsubst, TEnv::unify(c)); // Solve type constraints
+ resultType = cenv.type(result);
+ result->lift(cenv); // Lift functions
+ exprs.push_back(make_pair(exp, result));
+
+ // Add definitions as GC roots
+ if (result->to<ADef*>())
+ cenv.lock(result);
+
+ // Add types in type substition as GC roots
+ for (Subst::iterator i = cenv.tsubst.begin(); i != cenv.tsubst.end(); ++i) {
+ Object::pool.addRoot(i->first);
+ Object::pool.addRoot(i->second);
+ }
+ }
+
+ // Print CPS form
+ CValue val = NULL;
+ /*for (list< pair<SExp, AST*> >::const_iterator i = exprs.begin(); i != exprs.end(); ++i) {
+ cout << "; CPS" << endl;
+ pprint(cout, i->second->cps(cenv.tenv, cenv.penv.sym("cont")));
+ }*/
+
+ if (resultType->concrete()) {
+ // Create function for top-level of program
+ CFunction f = cenv.engine()->startFunction(cenv, "main", resultType, ATuple(cursor));
+
+ // Compile all expressions into it
+ for (list< pair<SExp, AST*> >::const_iterator i = exprs.begin(); i != exprs.end(); ++i)
+ val = cenv.compile(i->second);
+
+ // Finish and call it
+ cenv.engine()->finishFunction(cenv, f, resultType, val);
+ cenv.out << cenv.engine()->call(cenv, f, resultType);
+ }
+ cenv.out << " : " << resultType << endl;
+
+ Object::pool.collect(Object::pool.roots());
+
+ if (cenv.args.find("-d") != cenv.args.end())
+ cenv.engine()->writeModule(cenv, cenv.out);
+
+ } catch (Error& e) {
+ cenv.err << e.what() << endl;
+ return 1;
+ }
+ return 0;
+}
+
+int
+repl(CEnv& cenv)
+{
+ while (1) {
+ cenv.out << "() ";
+ cenv.out.flush();
+ Cursor cursor("(stdin)");
+
+ try {
+ SExp exp = readExpression(cursor, std::cin);
+ if (exp.type == SExp::LIST && exp.empty())
+ break;
+
+ AST* body = cenv.penv.parse(exp); // Parse input
+ Constraints c;
+ body->constrain(cenv.tenv, c); // Constrain types
+
+ Subst oldSubst = cenv.tsubst;
+ cenv.tsubst = Subst::compose(cenv.tsubst, TEnv::unify(c)); // Solve type constraints
+
+ AType* bodyT = cenv.type(body);
+ THROW_IF(!bodyT, cursor, "call to untyped body")
+
+ body->lift(cenv);
+
+ CFunction f = NULL;
+ try {
+ // Create anonymous function to insert code into
+ f = cenv.engine()->startFunction(cenv, cenv.penv.gensymstr("_repl"), bodyT, ATuple(cursor));
+ CValue retVal = cenv.compile(body);
+ cenv.engine()->finishFunction(cenv, f, bodyT, retVal);
+ cenv.out << cenv.engine()->call(cenv, f, bodyT);
+ } catch (Error& e) {
+ ADef* def = body->to<ADef*>();
+ if (def)
+ cenv.out << def->sym();
+ else
+ cenv.out << "?";
+ cenv.engine()->eraseFunction(cenv, f);
+ }
+ cenv.out << " : " << cenv.type(body) << endl;
+
+ // Add definitions as GC roots
+ if (body->to<ADef*>())
+ cenv.lock(body);
+
+ Object::pool.collect(Object::pool.roots());
+
+ cenv.tsubst = oldSubst;
+ if (cenv.args.find("-d") != cenv.args.end())
+ cenv.engine()->writeModule(cenv, cenv.out);
+
+ } catch (Error& e) {
+ cenv.err << e.what() << endl;
+ }
+ }
+ return 0;
+}
+
+
+/***************************************************************************
+ * MAIN *
+ ***************************************************************************/
+
+int
+print_usage(char* name, bool error)
+{
+ ostream& os = error ? cerr : cout;
+ os << "Usage: " << name << " [OPTION]... [FILE]..." << endl;
+ os << "Evaluate and/or compile Tuplr code" << endl;
+ os << endl;
+ os << " -h Display this help and exit" << endl;
+ os << " -r Enter REPL after evaluating files" << endl;
+ os << " -p Pretty-print input only" << endl;
+ os << " -g Debug (disable optimisation)" << endl;
+ os << " -d Dump assembly output" << endl;
+ os << " -e EXPRESSION Evaluate EXPRESSION" << endl;
+ os << " -o FILE Write output to FILE" << endl;
+ return error ? 1 : 0;
+}
+
+int
+main(int argc, char** argv)
+{
+ PEnv penv;
+ TEnv tenv(penv);
+ initLang(penv, tenv);
+
+ Engine* engine = tuplr_new_engine();
+ CEnv* cenv = new CEnv(penv, tenv, engine);
+
+ cenv->push();
+ Object::pool.lock();
+
+ map<string,string> args;
+ list<string> files;
+ for (int i = 1; i < argc; ++i) {
+ if (!strncmp(argv[i], "-h", 3)) {
+ return print_usage(argv[0], false);
+ } else if (argv[i][0] != '-') {
+ files.push_back(argv[i]);
+ } else if (!strncmp(argv[i], "-r", 3)
+ || !strncmp(argv[i], "-p", 3)
+ || !strncmp(argv[i], "-g", 3)
+ || !strncmp(argv[i], "-d", 3)) {
+ args.insert(make_pair(argv[i], ""));
+ } else if (i == argc-1 || argv[i+1][0] == '-') {
+ return print_usage(argv[0], true);
+ } else {
+ args.insert(make_pair(argv[i], argv[i+1]));
+ ++i;
+ }
+ }
+
+ cenv->args = args;
+
+ int ret = 0;
+
+ string output;
+ map<string,string>::const_iterator a = args.find("-o");
+ if (a != args.end())
+ output = a->second;
+
+ a = args.find("-p");
+ if (a != args.end()) {
+ ifstream is(files.front().c_str());
+ if (is.good()) {
+ Cursor loc;
+ SExp exp = readExpression(loc, is);
+ AST* ast = penv.parse(exp);
+ pprint(cout, ast);
+ }
+ return 0;
+ }
+
+ a = args.find("-e");
+ if (a != args.end()) {
+ istringstream is(a->second);
+ ret = eval(*cenv, "(command line)", is);
+ }
+
+ for (list<string>::iterator f = files.begin(); f != files.end(); ++f) {
+ ifstream is(f->c_str());
+ if (is.good()) {
+ ret = ret | eval(*cenv, *f, is);
+ } else {
+ cerr << argv[0] << ": " << *f << ": " << strerror(errno) << endl;
+ ++ret;
+ }
+ is.close();
+ }
+
+ if (args.find("-r") != args.end() || (files.empty() && args.find("-e") == args.end()))
+ ret = repl(*cenv);
+
+ if (output != "") {
+ ofstream os(output.c_str());
+ if (os.good()) {
+ cenv->engine()->writeModule(*cenv, os);
+ } else {
+ cerr << argv[0] << ": " << a->second << ": " << strerror(errno) << endl;
+ ++ret;
+ }
+ os.close();
+ }
+
+ delete cenv;
+ tuplr_free_engine(engine);
+
+ return ret;
+}
+
diff --git a/src/tuplr.hpp b/src/tuplr.hpp
new file mode 100644
index 0000000..5275dfd
--- /dev/null
+++ b/src/tuplr.hpp
@@ -0,0 +1,654 @@
+/* Tuplr: A programming language
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef TUPLR_HPP
+#define TUPLR_HPP
+
+#include <stdarg.h>
+#include <iostream>
+#include <list>
+#include <map>
+#include <set>
+#include <sstream>
+#include <string>
+#include <vector>
+#include <boost/format.hpp>
+
+#define FOREACH(IT, i, c) for (IT i = (c).begin(); i != (c).end(); ++i)
+#define THROW_IF(cond, error, ...) { if (cond) throw Error(error, __VA_ARGS__); }
+
+using namespace std;
+using boost::format;
+
+
+/***************************************************************************
+ * Basic Utility Classes *
+ ***************************************************************************/
+
+/// Location in textual code
+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;
+ unsigned col;
+};
+
+/// Compiler error
+struct Error {
+ Error(Cursor c, const string& m) : loc(c), msg(m) {}
+ const string what() const { return (loc ? loc.str() + ": " : "") + "error: " + msg; }
+ Cursor loc;
+ string msg;
+};
+
+/// Expression ::= Atom | (SubExp*)
+template<typename Atom>
+struct Exp : public std::vector< Exp<Atom> > {
+ Exp(Cursor c) : type(LIST), loc(c) {}
+ Exp(Cursor c, const Atom& a) : type(ATOM), loc(c), atom(a) {}
+ enum { ATOM, LIST } type;
+ Cursor loc;
+ Atom atom;
+};
+
+template<typename Atom>
+extern ostream& operator<<(ostream& out, const Exp<Atom>& exp);
+
+/// 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;
+};
+
+/// Generic Lexical Environment
+template<typename K, typename V>
+struct Env : public list< vector< pair<K,V> > > {
+ typedef vector< pair<K,V> > Frame;
+ Env() : list<Frame>(1) {}
+ virtual void push(Frame f=Frame()) { list<Frame>::push_front(f); }
+ virtual void pop() { assert(!this->empty()); list<Frame>::pop_front(); }
+ const V& def(const K& k, const V& 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;
+ }
+ 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;
+ }
+};
+
+
+/***************************************************************************
+ * Lexer: Text (istream) -> S-Expressions (SExp) *
+ ***************************************************************************/
+
+typedef Exp<string> SExp; ///< Textual S-Expression
+
+SExp readExpression(Cursor& cur, std::istream& in);
+
+
+/***************************************************************************
+ * Backend Types *
+ ***************************************************************************/
+
+typedef void* CValue; ///< Compiled value (opaque)
+typedef void* CFunction; ///< Compiled function (opaque)
+
+
+/***************************************************************************
+ * Garbage Collector *
+ ***************************************************************************/
+
+struct Object; ///< Object (AST nodes and runtime data)
+
+struct GC {
+ enum Tag {
+ TAG_AST = 2, ///< Abstract syntax tree node
+ TAG_FRAME = 4 ///< Stack frame
+ };
+ typedef std::list<const Object*> Roots;
+ typedef std::list<Object*> Heap;
+ void* alloc(size_t size, Tag tag);
+ void collect(const Roots& roots);
+ void addRoot(const Object* obj) { if (obj) _roots.push_back(obj); }
+ void lock() { _roots.insert(_roots.end(), _heap.begin(), _heap.end()); }
+ const Roots& roots() const { return _roots; }
+private:
+ Heap _heap;
+ Roots _roots;
+};
+
+/// Dynamic (garbage-collected) object
+struct Object {
+ struct Header {
+ uint8_t mark;
+ uint8_t tag;
+ };
+
+ /// Always allocated with pool.alloc, so this - sizeof(Header) is a valid Header*.
+ inline Header* header() const { return (Header*)((char*)this - sizeof(Header)); }
+
+ inline bool marked() const { return header()->mark != 0; }
+ inline void mark(bool b) const { header()->mark = 1; }
+ inline GC::Tag tag() const { return (GC::Tag)header()->tag; }
+
+ static void* operator new(size_t size) { return pool.alloc(size, GC::TAG_AST); }
+ static void operator delete(void* ptr) {}
+ static GC pool;
+};
+
+
+/***************************************************************************
+ * Abstract Syntax Tree *
+ ***************************************************************************/
+
+struct Constraint; ///< Type Constraint
+struct TEnv; ///< Type-Time Environment
+struct Constraints; ///< Type Constraints
+struct Subst; ///< Type substitutions
+struct CEnv; ///< Compile-Time Environment
+
+struct AST;
+extern ostream& operator<<(ostream& out, const AST* ast);
+
+/// Base class for all AST nodes
+struct AST : public Object {
+ AST(Cursor c=Cursor()) : loc(c) {}
+ virtual ~AST() {}
+ virtual bool value() const { return true; }
+ virtual bool operator==(const AST& o) const = 0;
+ virtual bool contains(const AST* child) const { return false; }
+ virtual void constrain(TEnv& tenv, Constraints& c) const {}
+ virtual AST* cps(TEnv& tenv, AST* cont);
+ virtual void lift(CEnv& cenv) {}
+ virtual CValue compile(CEnv& cenv) = 0;
+ string str() const { ostringstream ss; ss << this; return ss.str(); }
+ template<typename T> T to() { return dynamic_cast<T>(this); }
+ template<typename T> T to() const { return dynamic_cast<T>(this); }
+ template<typename T> T as() {
+ T t = dynamic_cast<T>(this);
+ if (!t) throw Error(loc, "internal error: bad cast");
+ return t;
+ }
+ Cursor loc;
+};
+
+template<typename T>
+static T* tup(Cursor c, AST* ast, ...)
+{
+ va_list args;
+ va_start(args, ast);
+ T* ret = new T(c, ast, args);
+ va_end(args);
+ return ret;
+}
+
+/// Literal value
+template<typename VT>
+struct ALiteral : public AST {
+ ALiteral(VT v, Cursor c) : AST(c), val(v) {}
+ bool operator==(const AST& rhs) const {
+ const ALiteral<VT>* r = rhs.to<const ALiteral<VT>*>();
+ return (r && (val == r->val));
+ }
+ void constrain(TEnv& tenv, Constraints& c) const;
+ CValue compile(CEnv& cenv);
+ const VT val;
+};
+
+/// Symbol, e.g. "a"
+struct ASymbol : public AST {
+ bool operator==(const AST& rhs) const { return this == &rhs; }
+ void constrain(TEnv& tenv, Constraints& c) const;
+ CValue compile(CEnv& cenv);
+ mutable LAddr addr;
+ const string cppstr;
+private:
+ friend class PEnv;
+ ASymbol(const string& s, Cursor c) : AST(c), cppstr(s) {}
+};
+
+/// Tuple (heterogeneous sequence of fixed length), e.g. "(a b c)"
+struct ATuple : public AST, public vector<AST*> {
+ ATuple(Cursor c, const vector<AST*>& v=vector<AST*>()) : AST(c), vector<AST*>(v) {}
+ ATuple(Cursor c, AST* ast, va_list args) : AST(c) {
+ if (!ast) return;
+ push_back(ast);
+ for (AST* a = va_arg(args, AST*); a; a = va_arg(args, AST*))
+ push_back(a);
+ }
+ bool value() const { return false; }
+ bool operator==(const AST& rhs) const {
+ const ATuple* rt = rhs.to<const ATuple*>();
+ if (!rt || rt->size() != size()) return false;
+ const_iterator l = begin();
+ FOREACH(const_iterator, r, *rt)
+ if (!(*(*l++) == *(*r)))
+ return false;
+ return true;
+ }
+ bool contains(AST* child) const {
+ if (*this == *child) return true;
+ FOREACH(const_iterator, p, *this)
+ if (**p == *child || (*p)->contains(child))
+ return true;
+ return false;
+ }
+ void constrain(TEnv& tenv, Constraints& c) const;
+ void lift(CEnv& cenv) { FOREACH(iterator, t, *this) (*t)->lift(cenv); }
+
+ CValue compile(CEnv& cenv) { throw Error(loc, "tuple compiled"); }
+};
+
+/// Type Expression, e.g. "Int", "(Fn (Int Int) Float)"
+struct AType : public ATuple {
+ AType(ASymbol* s) : ATuple(s->loc), kind(PRIM), id(0) { push_back(s); }
+ AType(Cursor c, unsigned i, LAddr a) : ATuple(c), kind(VAR), id(i) {}
+ AType(Cursor c, AST* ast, ...) : ATuple(c), kind(EXPR), id(0) {
+ 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*))
+ push_back(a);
+ va_end(args);
+ }
+ AType(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args), kind(EXPR), id(0) {}
+ CValue compile(CEnv& cenv) { return NULL; }
+ bool var() const { return kind == VAR; }
+ bool concrete() const {
+ switch (kind) {
+ case VAR: return false;
+ case PRIM: return at(0)->str() != "Nothing";
+ case EXPR:
+ FOREACH(const_iterator, t, *this) {
+ AType* kid = (*t)->to<AType*>();
+ if (kid && !kid->concrete())
+ return false;
+ }
+ }
+ return true;
+ }
+ bool operator==(const AST& rhs) const {
+ const AType* rt = rhs.to<const AType*>();
+ if (!rt || kind != rt->kind)
+ return false;
+ else
+ switch (kind) {
+ case VAR: return id == rt->id;
+ case PRIM: return at(0)->str() == rt->at(0)->str();
+ case EXPR: return ATuple::operator==(rhs);
+ }
+ return false; // never reached
+ }
+ enum { VAR, PRIM, EXPR } kind;
+ unsigned id;
+};
+
+/// Type substitution
+struct Subst : public list< pair<const AType*,AType*> > {
+ Subst(AType* s=0, AType* t=0) { if (s && t) { assert(s != t); push_back(make_pair(s, t)); } }
+ static Subst compose(const Subst& delta, const Subst& gamma);
+ void add(const AType* from, AType* to) { push_back(make_pair(from, to)); }
+ const_iterator find(const AType* t) const {
+ for (const_iterator j = begin(); j != end(); ++j)
+ if (*j->first == *t)
+ return j;
+ return end();
+ }
+ AST* apply(AST* ast) const {
+ AType* in = ast->to<AType*>();
+ if (!in) return ast;
+ if (in->kind == AType::EXPR) {
+ AType* out = tup<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 = find(in);
+ if (i != end()) {
+ AST* out = i->second;
+ AType* outT = out->to<AType*>();
+ if (outT && outT->kind == AType::EXPR && !outT->concrete())
+ out = apply(out);
+ return out;
+ } else {
+ return in;
+ }
+ }
+ }
+};
+
+inline ostream& operator<<(ostream& out, const Subst& s) {
+ for (Subst::const_iterator i = s.begin(); i != s.end(); ++i)
+ out << i->first << " => " << i->second << endl;
+ return out;
+}
+
+/// Fn (first-class function with captured lexical bindings)
+struct AFn : public ATuple {
+ AFn(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args) {}
+ bool operator==(const AST& rhs) const { return this == &rhs; }
+ void constrain(TEnv& tenv, Constraints& c) const;
+ AST* cps(TEnv& tenv, AST* cont);
+ void lift(CEnv& cenv);
+ void liftCall(CEnv& cenv, const AType& argsT);
+ CValue compile(CEnv& cenv);
+ ATuple* prot() const { return at(1)->to<ATuple*>(); }
+ /// System level implementations of this (polymorphic) fn
+ struct Impls : public list< pair<AType*, CFunction> > {
+ CFunction find(AType* type) const {
+ for (const_iterator f = begin(); f != end(); ++f)
+ if (*f->first == *type)
+ return f->second;
+ return NULL;
+ }
+ };
+ Impls impls;
+ mutable Subst subst;
+ string name;
+};
+
+/// Function call/application, e.g. "(func arg1 arg2)"
+struct ACall : public ATuple {
+ ACall(const SExp& e, const ATuple& t) : ATuple(e.loc, t) {}
+ ACall(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args) {}
+ void constrain(TEnv& tenv, Constraints& c) const;
+ AST* cps(TEnv& tenv, AST* cont);
+ void lift(CEnv& cenv);
+ CValue compile(CEnv& cenv);
+};
+
+/// Definition special form, e.g. "(def x 2)"
+struct ADef : public ACall {
+ ADef(const SExp& e, const ATuple& t) : ACall(e, t) {}
+ ADef(Cursor c, AST* ast, va_list args) : ACall(c, ast, args) {}
+ ASymbol* sym() const {
+ ASymbol* sym = at(1)->to<ASymbol*>();
+ if (!sym) {
+ ATuple* tup = at(1)->to<ATuple*>();
+ if (tup && !tup->empty())
+ return tup->at(0)->to<ASymbol*>();
+ }
+ return sym;
+ }
+ void constrain(TEnv& tenv, Constraints& c) const;
+ AST* cps(TEnv& tenv, AST* cont);
+ void lift(CEnv& cenv);
+ CValue compile(CEnv& cenv);
+};
+
+/// Conditional special form, e.g. "(if cond thenexp elseexp)"
+struct AIf : public ACall {
+ AIf(const SExp& e, const ATuple& t) : ACall(e, t) {}
+ AIf(Cursor c, AST* ast, va_list args) : ACall(c, ast, args) {}
+ void constrain(TEnv& tenv, Constraints& c) const;
+ AST* cps(TEnv& tenv, AST* cont);
+ 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) {}
+ bool value() const {
+ for (size_t i = 1; i < size(); ++i)
+ if (!at(i)->value())
+ return false;;
+ return true;
+ }
+ void constrain(TEnv& tenv, Constraints& c) const;
+ AST* cps(TEnv& tenv, AST* cont);
+ CValue compile(CEnv& cenv);
+};
+
+
+/***************************************************************************
+ * Parser: S-Expressions (SExp) -> AST Nodes (AST) *
+ ***************************************************************************/
+
+/// Parse Time Environment (really just a symbol table)
+struct PEnv : private map<const string, ASymbol*> {
+ PEnv() : symID(0) {}
+ typedef AST* (*PF)(PEnv&, const SExp&, void*); ///< Parse Function
+ typedef SExp (*MF)(PEnv&, const SExp&); ///< Macro Function
+ struct Handler { Handler(PF f, void* a=0) : func(f), arg(a) {} PF func; void* arg; };
+ map<const string, Handler> aHandlers; ///< Atom parse functions
+ map<const string, Handler> lHandlers; ///< List parse functions
+ map<const string, MF> macros; ///< Macro functions
+ void reg(bool list, const string& s, const Handler& h) {
+ (list ? lHandlers : aHandlers).insert(make_pair(sym(s)->str(), h));
+ }
+ const Handler* handler(bool list, const string& s) const {
+ const map<const string, Handler>& handlers = list ? lHandlers : aHandlers;
+ map<string, Handler>::const_iterator i = handlers.find(s);
+ return (i != handlers.end()) ? &i->second : NULL;
+ }
+ void defmac(const string& s, const MF f) {
+ macros.insert(make_pair(s, f));
+ }
+ MF mac(const string& s) const {
+ map<string, MF>::const_iterator i = macros.find(s);
+ return (i != macros.end()) ? i->second : NULL;
+ }
+ string gensymstr(const char* s="_") { return (format("%s%d") % s % symID++).str(); }
+ ASymbol* gensym(const char* s="_") { return sym(gensymstr(s)); }
+ ASymbol* sym(const string& s, Cursor c=Cursor()) {
+ const const_iterator i = find(s);
+ if (i != end()) {
+ return i->second;
+ } else {
+ ASymbol* sym = new ASymbol(s, c);
+ insert(make_pair(s, sym));
+ return sym;
+ }
+ }
+ ATuple parseTuple(const SExp& e) {
+ ATuple ret(e.loc, vector<AST*>(e.size()));
+ size_t n = 0;
+ FOREACH(SExp::const_iterator, i, e)
+ ret[n++] = parse(*i);
+ return ret;
+ }
+ AST* parse(const SExp& exp) {
+ if (exp.type == SExp::LIST) {
+ if (exp.empty()) throw Error(exp.loc, "call to empty list");
+ if (exp.front().type == SExp::ATOM) {
+ MF mf = mac(exp.front().atom);
+ SExp expanded = (mf ? mf(*this, exp) : exp);
+
+ const PEnv::Handler* h = handler(true, expanded.front().atom);
+ if (h)
+ return h->func(*this, expanded, h->arg);
+ }
+ return new ACall(exp, parseTuple(exp)); // Parse as regular call
+ } else if (isdigit(exp.atom[0])) {
+ if (exp.atom.find('.') == string::npos)
+ return new ALiteral<int32_t>(strtol(exp.atom.c_str(), NULL, 10), exp.loc);
+ else
+ return new ALiteral<float>(strtod(exp.atom.c_str(), NULL), exp.loc);
+ } else {
+ const PEnv::Handler* h = handler(false, exp.atom);
+ if (h)
+ return h->func(*this, exp, h->arg);
+ }
+ return sym(exp.atom, exp.loc);
+ }
+ unsigned symID;
+};
+
+
+/***************************************************************************
+ * 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;
+}
+
+/// Type-Time Environment
+struct TEnv : public Env< const ASymbol*, pair<AST*, AType*> > {
+ TEnv(PEnv& p) : penv(p), varID(1) {}
+ AType* fresh(const ASymbol* sym) {
+ assert(sym);
+ AType* ret = new AType(sym->loc, varID++, LAddr());
+ def(sym, make_pair((AST*)NULL, ret));
+ return ret;
+ }
+ AType* var(const AST* ast=0) {
+ const ASymbol* sym = ast->to<const ASymbol*>();
+ if (sym)
+ return deref(lookup(sym)).second;
+
+ Vars::iterator v = vars.find(ast);
+ if (v != vars.end())
+ return v->second;
+
+ AType* ret = new AType(ast ? ast->loc : Cursor(), varID++, LAddr());
+ if (ast)
+ vars[ast] = ret;
+
+ return ret;
+ }
+ AType* named(const string& name) {
+ return ref(penv.sym(name))->second;
+ }
+ AST* resolve(AST* ast) {
+ ASymbol* sym = ast->to<ASymbol*>();
+ return (sym && sym->addr) ? ref(sym)->first : ast;
+ }
+
+ static Subst unify(const Constraints& c);
+
+ typedef map<const AST*, AType*> Vars;
+ typedef map<const AFn*, const AType*> GenericTypes;
+ Vars vars;
+ GenericTypes genericTypes;
+ PEnv& penv;
+ unsigned varID;
+};
+
+
+/***************************************************************************
+ * Code Generation *
+ ***************************************************************************/
+
+struct Engine {
+ virtual CFunction startFunction(CEnv& cenv, const std::string& name,
+ const AType* retT, const ATuple& argsT,
+ const vector<string> argNames=vector<string>()) = 0;
+
+ virtual void finishFunction(CEnv& cenv, CFunction f, const AType* retT, CValue ret) = 0;
+ virtual void eraseFunction(CEnv& cenv, CFunction f) = 0;
+ virtual void writeModule(CEnv& cenv, std::ostream& os) = 0;
+
+ virtual const string call(CEnv& cenv, CFunction f, AType* retT) = 0;
+};
+
+Engine* tuplr_new_engine();
+void tuplr_free_engine(Engine* engine);
+
+/// Compile-Time Environment
+struct CEnv {
+ CEnv(PEnv& p, TEnv& t, Engine* e, ostream& os=std::cout, ostream& es=std::cerr)
+ : out(os), err(es), penv(p), tenv(t), _engine(e)
+ {}
+
+ ~CEnv() { Object::pool.collect(GC::Roots()); }
+
+ typedef Env<const AST*, CValue> Vals;
+
+ Engine* engine() { return _engine; }
+ void push() { tenv.push(); vals.push(); }
+ void pop() { tenv.pop(); vals.pop(); }
+ void precompile(AST* obj, CValue value) { vals.def(obj, value); }
+ CValue compile(AST* obj) {
+ CValue* v = vals.ref(obj);
+ return (v && *v) ? *v : vals.def(obj, obj->compile(*this));
+ }
+ void lock(AST* ast) { Object::pool.addRoot(ast); Object::pool.addRoot(type(ast)); }
+ AType* type(AST* ast, const Subst& subst = Subst()) const {
+ ASymbol* sym = ast->to<ASymbol*>();
+ if (sym)
+ return sym->addr ? tenv.deref(sym->addr).second : NULL;
+ return tsubst.apply(subst.apply(tenv.vars[ast]))->to<AType*>();
+ }
+ void def(ASymbol* sym, AST* c, AType* t, CValue v) {
+ tenv.def(sym, make_pair(c, t));
+ vals.def(sym, v);
+ }
+
+ ostream& out;
+ ostream& err;
+ PEnv& penv;
+ TEnv& tenv;
+ Vals vals;
+
+ Subst tsubst;
+
+ map<string,string> args;
+
+private:
+ Engine* _engine;
+};
+
+
+/***************************************************************************
+ * EVAL/REPL/MAIN *
+ ***************************************************************************/
+
+void pprint(std::ostream& out, const AST* ast);
+void initLang(PEnv& penv, TEnv& tenv);
+int eval(CEnv& cenv, const string& name, istream& is);
+int repl(CEnv& cenv);
+
+#endif // TUPLR_HPP
+
diff --git a/src/typing.cpp b/src/typing.cpp
new file mode 100644
index 0000000..5791fdc
--- /dev/null
+++ b/src/typing.cpp
@@ -0,0 +1,232 @@
+/* Tuplr Type Inferencing
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <set>
+#include "tuplr.hpp"
+
+void
+Constraints::constrain(TEnv& tenv, const AST* o, AType* t)
+{
+ assert(!o->to<const AType*>());
+ push_back(Constraint(tenv.var(o), t, o->loc));
+}
+
+
+/***************************************************************************
+ * AST Type Constraints *
+ ***************************************************************************/
+
+void
+ASymbol::constrain(TEnv& tenv, Constraints& c) const
+{
+ addr = tenv.lookup(this);
+ if (!addr)
+ throw Error(loc, (format("undefined symbol `%1%'") % cppstr).str());
+ c.push_back(Constraint(tenv.var(this), tenv.deref(addr).second, loc));
+}
+
+void
+ATuple::constrain(TEnv& tenv, Constraints& c) const
+{
+ AType* t = tup<AType>(loc, NULL);
+ FOREACH(const_iterator, p, *this) {
+ (*p)->constrain(tenv, c);
+ t->push_back(tenv.var(*p));
+ }
+ c.push_back(Constraint(tenv.var(this), t, loc));
+}
+
+void
+AFn::constrain(TEnv& tenv, Constraints& c) const
+{
+ const AType* genericType;
+ TEnv::GenericTypes::const_iterator gt = tenv.genericTypes.find(this);
+ if (gt != tenv.genericTypes.end()) {
+ genericType = gt->second;
+ } else {
+ set<ASymbol*> defined;
+ TEnv::Frame frame;
+
+ // Add parameters to environment frame
+ for (size_t i = 0; i < prot()->size(); ++i) {
+ ASymbol* sym = prot()->at(i)->to<ASymbol*>();
+ if (!sym)
+ throw Error(prot()->at(i)->loc, "parameter name is not a symbol");
+ if (defined.find(sym) != defined.end())
+ throw Error(sym->loc, (format("duplicate parameter `%1%'") % sym->str()).str());
+ defined.insert(sym);
+ frame.push_back(make_pair(sym, make_pair((AST*)NULL, (AType*)NULL)));
+ }
+
+ // Add internal definitions to environment frame
+ size_t e = 2;
+ for (; e < size(); ++e) {
+ AST* exp = at(e);
+ ADef* def = exp->to<ADef*>();
+ if (def) {
+ ASymbol* sym = def->sym();
+ if (defined.find(sym) != defined.end())
+ throw Error(def->loc, (format("`%1%' defined twice") % sym->str()).str());
+ defined.insert(def->sym());
+ frame.push_back(make_pair(def->sym(), make_pair(def->at(2), (AType*)NULL)));
+ }
+ }
+
+ tenv.push(frame);
+
+ Constraints cp;
+ cp.push_back(Constraint(tenv.var(this), tenv.var(), loc));
+
+ AType* protT = tup<AType>(loc, NULL);
+ for (size_t i = 0; i < prot()->size(); ++i) {
+ AType* tvar = tenv.fresh(prot()->at(i)->to<ASymbol*>());
+ protT->push_back(tvar);
+ assert(frame[i].first == prot()->at(i));
+ frame[i].second.first = prot()->at(i);
+ frame[i].second.second = tvar;
+ }
+ c.push_back(Constraint(tenv.var(at(1)), protT, at(1)->loc));
+
+ for (size_t i = 2; i < size(); ++i)
+ at(i)->constrain(tenv, cp);
+
+ AType* bodyT = tenv.var(at(e-1));
+ Subst tsubst = TEnv::unify(cp);
+ genericType = tup<AType>(loc, tenv.penv.sym("Fn"),
+ tsubst.apply(protT), tsubst.apply(bodyT), 0);
+ tenv.genericTypes.insert(make_pair(this, genericType));
+ Object::pool.addRoot(genericType);
+
+ tenv.pop();
+ subst = tsubst;
+ }
+
+ AType* t = new AType(*genericType); // FIXME: deep copy
+ c.constrain(tenv, this, t);
+}
+
+void
+ACall::constrain(TEnv& tenv, Constraints& c) const
+{
+ at(0)->constrain(tenv, c);
+ for (size_t i = 1; i < size(); ++i)
+ at(i)->constrain(tenv, c);
+
+ AST* callee = tenv.resolve(at(0));
+ AFn* closure = callee->to<AFn*>();
+ if (closure) {
+ if (size() - 1 != closure->prot()->size())
+ throw Error(loc, "incorrect number of arguments");
+ TEnv::GenericTypes::iterator gt = tenv.genericTypes.find(closure);
+ if (gt != tenv.genericTypes.end()) {
+ for (size_t i = 1; i < size(); ++i)
+ c.constrain(tenv, at(i), gt->second->at(1)->as<ATuple*>()->at(i-1)->as<AType*>());
+ AType* retT = tenv.var(this);
+ c.constrain(tenv, at(0), tup<AType>(at(0)->loc, tenv.penv.sym("Fn"), tenv.var(), retT, 0));
+ c.constrain(tenv, this, retT);
+ return;
+ }
+ }
+ AType* argsT = tup<AType>(loc, 0);
+ for (size_t i = 1; i < size(); ++i)
+ argsT->push_back(tenv.var(at(i)));
+ AType* retT = tenv.var();
+ c.constrain(tenv, at(0), tup<AType>(at(0)->loc, tenv.penv.sym("Fn"), argsT, retT, 0));
+ c.constrain(tenv, this, retT);
+}
+
+void
+ADef::constrain(TEnv& tenv, Constraints& c) const
+{
+ THROW_IF(size() != 3, loc, "`def' requires exactly 2 arguments");
+ const ASymbol* sym = this->sym();
+ THROW_IF(!sym, loc, "`def' has no symbol")
+
+ AType* tvar = tenv.var(at(2));
+ tenv.def(sym, make_pair(at(2), tvar));
+ at(2)->constrain(tenv, c);
+ c.constrain(tenv, this, tvar);
+}
+
+void
+AIf::constrain(TEnv& tenv, Constraints& c) const
+{
+ THROW_IF(size() < 4, loc, "`if' requires at least 3 arguments");
+ THROW_IF(size() % 2 != 0, loc, "`if' missing final else clause")
+ for (size_t i = 1; i < size(); ++i)
+ at(i)->constrain(tenv, c);
+ AType* retT = tenv.var(this);
+ for (size_t i = 1; i < size(); i += 2) {
+ if (i == size() - 1) {
+ c.constrain(tenv, at(i), retT);
+ } else {
+ c.constrain(tenv, at(i), tenv.named("Bool"));
+ c.constrain(tenv, at(i+1), retT);
+ }
+ }
+}
+
+void
+APrimitive::constrain(TEnv& tenv, Constraints& c) const
+{
+ const string n = at(0)->to<ASymbol*>()->str();
+ enum { ARITHMETIC, BINARY, LOGICAL, COMPARISON } type;
+ if (n == "+" || n == "-" || n == "*" || n == "/")
+ type = ARITHMETIC;
+ else if (n == "%")
+ type = BINARY;
+ else if (n == "and" || n == "or" || n == "xor")
+ type = LOGICAL;
+ else if (n == "=" || n == "!=" || n == ">" || n == ">=" || n == "<" || n == "<=")
+ type = COMPARISON;
+ else
+ throw Error(loc, (format("unknown primitive `%1%'") % n).str());
+
+ for (size_t i = 1; i < size(); ++i)
+ at(i)->constrain(tenv, c);
+
+ switch (type) {
+ case ARITHMETIC:
+ if (size() < 3)
+ throw Error(loc, (format("`%1%' requires at least 2 arguments") % n).str());
+ for (size_t i = 1; i < size(); ++i)
+ c.constrain(tenv, at(i), tenv.var(this));
+ break;
+ case BINARY:
+ if (size() != 3)
+ throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str());
+ c.constrain(tenv, at(1), tenv.var(this));
+ c.constrain(tenv, at(2), tenv.var(this));
+ break;
+ case LOGICAL:
+ if (size() != 3)
+ throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str());
+ c.constrain(tenv, this, tenv.named("Bool"));
+ c.constrain(tenv, at(1), tenv.named("Bool"));
+ c.constrain(tenv, at(2), tenv.named("Bool"));
+ break;
+ case COMPARISON:
+ if (size() != 3)
+ throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str());
+ c.constrain(tenv, this, tenv.named("Bool"));
+ c.constrain(tenv, at(1), tenv.var(at(2)));
+ break;
+ default:
+ throw Error(loc, (format("unknown primitive `%1%'") % n).str());
+ }
+}
+
diff --git a/src/unify.cpp b/src/unify.cpp
new file mode 100644
index 0000000..2a8e6a0
--- /dev/null
+++ b/src/unify.cpp
@@ -0,0 +1,94 @@
+/* Tuplr Unification
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <set>
+#include "tuplr.hpp"
+
+/***************************************************************************
+ * Type Inference/Substitution *
+ ***************************************************************************/
+
+static void
+substitute(ATuple* tup, const AST* from, AST* to)
+{
+ if (!tup) return;
+ for (size_t i = 0; i < tup->size(); ++i)
+ if (*tup->at(i) == *from)
+ tup->at(i) = to;
+ else if (tup->at(i) != to)
+ substitute(tup->at(i)->to<ATuple*>(), from, to);
+}
+
+Subst
+Subst::compose(const Subst& delta, const Subst& gamma) // TAPL 22.1.1
+{
+ Subst r;
+ for (Subst::const_iterator g = gamma.begin(); g != gamma.end(); ++g) {
+ Subst::const_iterator d = delta.find(g->second);
+ r.add(g->first, ((d != delta.end()) ? d : g)->second);
+ }
+ for (Subst::const_iterator d = delta.begin(); d != delta.end(); ++d) {
+ if (gamma.find(d->first) == gamma.end())
+ r.add(d->first, d->second);
+ }
+ return r;
+}
+
+void
+substConstraints(Constraints& constraints, AType* s, AType* t)
+{
+ for (Constraints::iterator c = constraints.begin(); c != constraints.end();) {
+ Constraints::iterator next = c; ++next;
+ if (*c->first == *s) c->first = t;
+ if (*c->second == *s) c->second = t;
+ substitute(c->first, s, t);
+ substitute(c->second, s, t);
+ c = next;
+ }
+}
+
+Subst
+TEnv::unify(const Constraints& constraints) // TAPL 22.4
+{
+ if (constraints.empty()) return Subst();
+ AType* s = constraints.begin()->first;
+ AType* t = constraints.begin()->second;
+ Constraints cp = constraints;
+ cp.erase(cp.begin());
+
+ if (*s == *t) {
+ return unify(cp);
+ } else if (s->var() && !t->contains(s)) {
+ substConstraints(cp, s, t);
+ return Subst::compose(unify(cp), Subst(s, t));
+ } else if (t->var() && !s->contains(t)) {
+ substConstraints(cp, t, s);
+ return Subst::compose(unify(cp), Subst(t, s));
+ } else if (s->kind == AType::EXPR && s->kind == t->kind && s->size() == t->size()) {
+ for (size_t i = 0; i < s->size(); ++i) {
+ AType* si = s->at(i)->to<AType*>();
+ AType* ti = t->at(i)->to<AType*>();
+ if (si && ti)
+ cp.push_back(Constraint(si, ti, si->loc));
+ }
+ return unify(cp);
+ } else {
+ throw Error(s->loc ? s->loc : t->loc,
+ (format("type is `%1%' but should be `%2%'") % s->str() % t->str()).str());
+ }
+}
+
diff --git a/src/write.cpp b/src/write.cpp
new file mode 100644
index 0000000..04e3401
--- /dev/null
+++ b/src/write.cpp
@@ -0,0 +1,97 @@
+/* Tuplr Serialisation
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "tuplr.hpp"
+
+ostream&
+operator<<(ostream& out, const AST* ast)
+{
+ const ALiteral<float>* flit = ast->to<const ALiteral<float>*>();
+ if (flit)
+ return out << showpoint << flit->val;
+
+ const ALiteral<int32_t>* ilit = ast->to<const ALiteral<int32_t>*>();
+ if (ilit)
+ return out << ilit->val;
+
+ const ALiteral<bool>* blit = ast->to<const ALiteral<bool>*>();
+ if (blit)
+ return out << (blit->val ? "#t" : "#f");
+
+ const ASymbol* sym = ast->to<const ASymbol*>();
+ if (sym)
+ return out << sym->cppstr;
+
+ const AType* type = ast->to<const AType*>();
+ if (type) {
+ switch (type->kind) {
+ case AType::VAR: return out << "?" << type->id;
+ case AType::PRIM: return out << type->at(0);
+ case AType::EXPR: break; // will catch Tuple case below
+ }
+ }
+
+ const ATuple* tup = ast->to<const ATuple*>();
+ if (tup) {
+ out << "(";
+ for (size_t i = 0; i != tup->size(); ++i)
+ out << tup->at(i) << ((i != tup->size() - 1) ? " " : "");
+ return out << ")";
+ }
+
+ return out << "?";
+}
+
+void
+pprint_internal(ostream& out, const AST* ast, unsigned indent)
+{
+ const ATuple* tup = ast->to<const ATuple*>();
+ if (tup && tup->size() > 0) {
+ const string head = tup->at(0)->str();
+ ASymbol* headSym = tup->at(0)->to<ASymbol*>();
+ out << "(";
+ pprint_internal(out, tup->at(0), indent);
+ unsigned child_indent = indent;
+ if (tup->size() > 1) {
+ out << " ";
+ if (headSym && headSym->cppstr == "fn") {
+ out << tup->at(1);
+ child_indent = indent + 4;
+ } else {
+ child_indent += head.length() + 1;
+ pprint_internal(out, tup->at(1), child_indent);
+ }
+ }
+ for (size_t i = 2; i < tup->size(); ++i) {
+ out << endl << string().insert(0, child_indent, ' ');
+ pprint_internal(out, tup->at(i), child_indent);
+ }
+ out << ")";
+ if (headSym && headSym->cppstr == "fn")
+ out << endl << string().insert(0, indent + 4, ' ');
+ } else {
+ out << ast;
+ }
+}
+
+void
+pprint(ostream& out, const AST* ast)
+{
+ pprint_internal(out, ast, 0);
+ out << endl;
+}
+
generated by cgit v1.2.1 (git 2.18.0) at 2025-02-08 03:37:20 +0000