diff options
author | David Robillard <d@drobilla.net> | 2009-06-28 23:29:27 +0000 |
---|---|---|
committer | David Robillard <d@drobilla.net> | 2009-06-28 23:29:27 +0000 |
commit | 2d925912c38c2557ac853fb1b6de5fd6e5d4c5b5 (patch) | |
tree | 2cba1e1d747218b1e9b1c55926e135cf21c8e586 /tuplr.cpp | |
parent | 84274ac380968df9fb49bcbf6f3d494536d7a548 (diff) | |
download | resp-2d925912c38c2557ac853fb1b6de5fd6e5d4c5b5.tar.gz resp-2d925912c38c2557ac853fb1b6de5fd6e5d4c5b5.tar.bz2 resp-2d925912c38c2557ac853fb1b6de5fd6e5d4c5b5.zip |
Move code into src directory.
git-svn-id: http://svn.drobilla.net/resp/tuplr@160 ad02d1e2-f140-0410-9f75-f8b11f17cedd
Diffstat (limited to 'tuplr.cpp')
-rw-r--r-- | tuplr.cpp | 471 |
1 files changed, 0 insertions, 471 deletions
diff --git a/tuplr.cpp b/tuplr.cpp deleted file mode 100644 index 7dd3e9b..0000000 --- a/tuplr.cpp +++ /dev/null @@ -1,471 +0,0 @@ -/* 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; -} - |