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

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<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                                                                   *
  ***************************************************************************/
@@ -103,6 +121,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<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>));
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                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) {}
@@ -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*>(); }
+	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;
 	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<const string, ASymbol*> {
-	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<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));
 	}
@@ -378,6 +391,13 @@ struct PEnv : private map<const string, ASymbol*> {
 		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;
+	}
 	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<const string, ASymbol*> {
 		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<const ASymbol*>();
-	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);