Preliminary syntax-rules macro implementation.

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

1 files changed, 148 insertions, 18 deletions

diff --git a/src/expand.cpp b/src/expand.cpp
index 0cbe118..3c562fa 100644
--- a/src/expand.cpp
+++ b/src/expand.cpp
@@ -23,9 +23,86 @@
 
 using namespace std;
 
-static inline const ATuple*
+static bool
+match(PEnv&                 penv,
+      Subst&                subst,
+      std::set<std::string> keywords,
+      const AST*            p,
+      const AST*            e,
+      bool                  bind)
+{
+	if (p->to_tuple() && e->to_tuple()) {
+		ATuple::const_iterator pi      = p->as_tuple()->begin();
+		ATuple::const_iterator ei      = e->as_tuple()->begin();
+		ATuple::const_iterator prev_pi = pi;
+		if (!match(penv, subst, keywords, *pi++, *ei++, true)) {
+			return false;
+		}
+		for (; pi != p->as_tuple()->end() && ei != e->as_tuple()->end();
+		     ++pi, ++ei, ++prev_pi) {
+			if (is_dots(*pi)) {
+				List out;
+				for (; ei != e->as_tuple()->end(); ++ei) {
+					if (match(penv, subst, keywords, *prev_pi, *ei, false)) {
+						out.push_back(*ei);
+					} else {
+						return false;
+					}
+				}
+				subst.add(*pi, out);
+				++pi;
+				break;
+			} else if (!match(penv, subst, keywords, *pi, *ei, true)) {
+				return false;
+			}
+		}
+		if ((pi != p->as_tuple()->end()) || (ei != e->as_tuple()->end()))
+			return false;
+	} else if (p->to_symbol()) {
+		if (keywords.count(p->str())) {
+			if (!e->to_symbol() || e->str() != p->str()) {
+				return false;  // Keyword mismatch
+			}
+		} else if (p->as_symbol()->str() != "_" && bind) {
+			subst.add(p, e);  // Symbol p match with symbol e
+		} // else _, ... matches with everything but creates no bindings
+	} else {
+		THROW_IF(p->tag() != e->tag(), e->loc, "expr type mismatch");
+		return false;  // Recursive list p mismatch with list e
+	}
+
+	return true;
+}
+
+static const AST*
+apply_mac(PEnv& penv, const Macro& mac, const ATuple* exp)
+{
+	const AST* out = exp;
+	for (auto r : mac.rules) {
+		Subst subst;
+		if (match(penv, subst, mac.keywords, r.pattern, out, true)) {
+			return subst.apply(r.templ);
+		}
+	}
+	return out;
+}
+
+static const AST*
 expand_list(PEnv& penv, const ATuple* e)
 {
+	// Attempt to match against macro rule
+	const ASymbol* sym = e->fst()->to_symbol();
+	if (sym) {
+		PEnv::Macros::const_iterator m = penv.macros.find(sym->str());
+		if (m != penv.macros.end()) {
+			const AST* out = apply_mac(penv, m->second, e);
+			if (out) {
+				return out;
+			}
+		}
+	}
+
+	// No match, try to expand children
 	List ret;
 	FOREACHP(ATuple::const_iterator, i, e)
 		ret.push_back(penv.expand(*i));
@@ -33,8 +110,8 @@ expand_list(PEnv& penv, const ATuple* e)
 	return ret.head;
 }
 
-static inline const AST*
-expand_fn(PEnv& penv, const AST* exp, void* arg)
+static const AST*
+expand_fn(PEnv& penv, const AST* exp)
 {
 	const ATuple* tup = exp->to_tuple();
 	ATuple::const_iterator a = tup->begin();
@@ -48,8 +125,8 @@ expand_fn(PEnv& penv, const AST* exp, void* arg)
 	return ret.head;
 }
 
-static inline const AST*
-expand_def(PEnv& penv, const AST* exp, void* arg)
+static const AST*
+expand_def(PEnv& penv, const AST* exp)
 {
 	const ATuple* tup = exp->as_tuple();
 	THROW_IF(tup->list_len() < 3, tup->loc, "`def' requires at least 2 arguments");
@@ -72,7 +149,7 @@ expand_def(PEnv& penv, const AST* exp, void* arg)
 		for (++i; i != tup->end(); ++i)
 			fnExp.push_back(*i);
 		fnExp.head->loc = exp->loc;
-		
+
 		List ret;
 		ret.push_back(tup->fst());
 		ret.push_back(pat->fst());
@@ -85,21 +162,74 @@ expand_def(PEnv& penv, const AST* exp, void* arg)
 	}
 }
 
+static const AST*
+expand_mac(PEnv& penv, const AST* exp)
+{
+	const ATuple* tup = exp->as_tuple();
+	THROW_IF(tup->list_len() < 3, tup->loc,
+	         "`define-syntax' requires at least 2 arguments");
+
+	ATuple::const_iterator i   = tup->begin();
+	const ASymbol*         sym = (*(++i))->as_symbol();
+	THROW_IF(!sym, (*i)->loc, "expected symbol");
+
+	const ATuple* xform = (*(++i))->as_tuple();
+	THROW_IF(!xform, (*i)->loc, "expected list expression");
+
+	const ASymbol* form = xform->fst()->as_symbol();
+	THROW_IF(!form || form->str() != "syntax-rules",
+	         form->loc, "expected syntax-rules");
+
+	Macro macro;
+	const ATuple* keywords = xform->frst()->as_tuple();
+	for (auto k : *keywords) {
+		THROW_IF(!k->to_symbol(), k->loc, "keyword must be a symbol");
+		macro.keywords.insert(k->as_symbol()->str());
+	}
+
+	for (ATuple::const_iterator r = xform->iter_at(2);
+	     r != xform->end();
+	     ++r) {
+		const ATuple* rule = (*r)->as_tuple();
+		const ATuple* pat   = rule->fst()->as_tuple();
+		const ATuple* plate = rule->frst()->as_tuple();
+
+		macro.rules.push_back(Macro::Rule(pat, plate));
+	}
+
+	penv.macros.insert(std::make_pair(sym->str(), macro));
+
+	return NULL;
+}
+
 const AST*
 PEnv::expand(const AST* exp)
 {
-	const ATuple* tup = exp->to_tuple();
-	if (!tup)
-		return exp;
-	
-	THROW_IF(tup->empty(), exp->loc, "Call to empty list");
-
-	if (is_form(tup, "define"))
-		return expand_def(*this, exp, NULL);
-	else if (is_form(tup, "lambda"))
-		return expand_fn(*this, exp, NULL);
-	else
-		return expand_list(*this, tup);
+	while (true) {
+		const AST*    out = exp;
+		const ATuple* tup = out->to_tuple();
+		if (!tup)
+			return out;
+
+		THROW_IF(tup->empty(), exp->loc, "Call to empty list");
+
+		if (is_form(tup, "define"))
+			out = expand_def(*this, out);
+		else if (is_form(tup, "define-syntax"))
+			return expand_mac(*this, out);
+		else if (is_form(tup, "lambda"))
+			out = expand_fn(*this, out);
+		else
+			out = expand_list(*this, tup);
+
+		const bool done = !out || *out == *exp;
+		exp = out;
+		if (done) {
+			break;
+		}
+	}
+
+	return exp;
 }