From 545b524bda45f2087ac92cf58f6eaa78499332cf Mon Sep 17 00:00:00 2001 From: David Robillard Date: Thu, 18 Jun 2009 20:22:10 +0000 Subject: Primitive internal macro system (for implementing sugar). (def (f x) ...) sugar. git-svn-id: http://svn.drobilla.net/resp/tuplr@119 ad02d1e2-f140-0410-9f75-f8b11f17cedd --- test/ack.tpr | 9 ++++----- test/fac.tpr | 6 +++--- tuplr.cpp | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ tuplr.hpp | 31 +++++++++++++++++++++++++++---- typing.cpp | 6 +++--- 5 files changed, 86 insertions(+), 15 deletions(-) diff --git a/test/ack.tpr b/test/ack.tpr index 1fe38d5..76fb397 100644 --- a/test/ack.tpr +++ b/test/ack.tpr @@ -1,8 +1,7 @@ -(def ack - (fn (m n) - (if (= 0 m) (+ n 1) - (= 0 n) (ack (- m 1) 1) - (ack (- m 1) (ack m (- n 1)))))) +(def (ack m n) + (if (= 0 m) (+ n 1) + (= 0 n) (ack (- m 1) 1) + (ack (- m 1) (ack m (- n 1))))) (ack 3 10) diff --git a/test/fac.tpr b/test/fac.tpr index 77e4776..0fb687c 100644 --- a/test/fac.tpr +++ b/test/fac.tpr @@ -1,7 +1,7 @@ ; Factorial -(def fac (fn (n) +(def (fac n) (if (= 0 n) 1 - (* n (fac (- n 1)))))) + (* n (fac (- n 1))))) -(fac 5) +(fac 6) diff --git a/tuplr.cpp b/tuplr.cpp index 6e0571e..c13b9bc 100644 --- a/tuplr.cpp +++ b/tuplr.cpp @@ -28,6 +28,24 @@ using boost::format; Funcs AConsCall::funcs; +template +ostream& +operator<<(ostream& out, const Exp& exp) +{ + switch (exp.type) { + case Exp::ATOM: + out << exp.atom; + break; + case Exp::LIST: + out << "("; + for (size_t i = 0; i != exp.size(); ++i) + out << exp.at(i) << ((i != exp.size() - 1) ? " " : ""); + out << ")"; + break; + } + return out; +} + /*************************************************************************** * Lexer * ***************************************************************************/ @@ -102,6 +120,34 @@ readExpression(Cursor& cur, istream& in) } +/*************************************************************************** + * Macro Functions * + ***************************************************************************/ + +inline SExp +macDef(PEnv& penv, const SExp& exp) +{ + if (exp.size() != 3) throw Error("`def' requires exactly 2 arguments", exp.loc); + 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); + fnExp.push_back(exp.at(2)); + 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 * ***************************************************************************/ @@ -153,6 +199,9 @@ initLang(PEnv& penv, TEnv& tenv) penv.reg(false, "#t", PEnv::Handler(parseLiteral, &trueVal)); penv.reg(false, "#f", PEnv::Handler(parseLiteral, &falseVal)); + // Macros + penv.defmac("def", macDef); + // Special forms penv.reg(true, "fn", PEnv::Handler(parseFn)); penv.reg(true, "if", PEnv::Handler(parseCall)); diff --git a/tuplr.hpp b/tuplr.hpp index d6ceb4c..081428d 100644 --- a/tuplr.hpp +++ b/tuplr.hpp @@ -65,6 +65,9 @@ struct Exp : public std::vector< Exp > { Atom atom; }; +template +extern ostream& operator<<(ostream& out, const Exp& exp); + /// Lexical Address struct LAddr { LAddr(unsigned u=0, unsigned o=0) : up(u), over(o) {} @@ -315,7 +318,15 @@ struct ACall : public ATuple { /// Definition special form, e.g. "(def x 2)" struct ADefinition : public ACall { ADefinition(const SExp& e, const ATuple& t) : ACall(e, t) {} - ASymbol* sym() const { return at(1)->to(); } + ASymbol* sym() const { + ASymbol* sym = at(1)->to(); + if (!sym) { + ATuple* tup = at(1)->to(); + if (tup && !tup->empty()) + return tup->at(0)->to(); + } + return sym; + } void constrain(TEnv& tenv, Constraints& c) const; void lift(CEnv& cenv); CValue compile(CEnv& cenv); @@ -366,10 +377,12 @@ struct ACdrCall : public ACall { /// Parse Time Environment (really just a symbol table) struct PEnv : private map { - typedef AST* (*PF)(PEnv&, const SExp&, void*); // Parse Function + 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 aHandlers; ///< Atom parse functions map lHandlers; ///< List parse functions + map macros; ///< Macro functions void reg(bool list, const string& s, const Handler& h) { (list ? lHandlers : aHandlers).insert(make_pair(sym(s)->str(), h)); } @@ -378,6 +391,13 @@ struct PEnv : private map { map::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::const_iterator i = macros.find(s); + return (i != macros.end()) ? i->second : NULL; + } ASymbol* sym(const string& s, Cursor c=Cursor()) { const const_iterator i = find(s); return ((i != end()) @@ -395,9 +415,12 @@ struct PEnv : private map { if (exp.type == SExp::LIST) { if (exp.empty()) throw Error("call to empty list", exp.loc); if (exp.front().type == SExp::ATOM) { - const PEnv::Handler* h = handler(true, exp.front().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, exp, h->arg); + return h->func(*this, expanded, h->arg); } return new ACall(exp, parseTuple(exp)); // Parse as regular call } else if (isdigit(exp.atom[0])) { diff --git a/typing.cpp b/typing.cpp index da4f6ed..aba4449 100644 --- a/typing.cpp +++ b/typing.cpp @@ -150,9 +150,9 @@ void ADefinition::constrain(TEnv& tenv, Constraints& c) const { if (size() != 3) throw Error("`def' requires exactly 2 arguments", loc); - const ASymbol* sym = at(1)->to(); - if (!sym) - throw Error("`def' name is not a symbol", loc); + const ASymbol* sym = this->sym(); + if (!sym) throw Error("`def' has no symbol", loc); + AType* tvar = tenv.var(at(2)); tenv.def(sym, make_pair(at(2), tvar)); at(2)->constrain(tenv, c); -- cgit v1.2.1