Preliminary syntax-rules macro implementation.

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

9 files changed, 249 insertions, 72 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;
 }
 
 
diff --git a/src/parse.cpp b/src/parse.cpp
index b61b971..ce69a72 100644
--- a/src/parse.cpp
+++ b/src/parse.cpp
@@ -96,7 +96,11 @@ read_list(PEnv& penv, Cursor& cur, istream& in)
 		skip_space(cur, in);
 		if (in.peek() == ')') {
 			eat_char(cur, in, ')');
-			list.head->loc = loc;
+			if (!list.head) {
+				list.head = new ATuple(cur);
+			} else {
+				list.head->loc = loc;
+			}
 			return list.head;
 		} else {
 			list.push_back(penv.parse(cur, in));
diff --git a/src/pprint.cpp b/src/pprint.cpp
index ff19331..2a8a62d 100644
--- a/src/pprint.cpp
+++ b/src/pprint.cpp
@@ -194,25 +194,6 @@ print_to(ostream& out, const AST* ast, unsigned indent, CEnv* cenv, bool types)
 		} else if (form == "if") {
 			print_list(out, tup, i, indent + 4, cenv, types, true);
 
-		} else if (form == "let") {
-			out << "(";
-			const ATuple* vars = (*i)->as_tuple();
-			for (ATuple::const_iterator v = vars->begin(); v != vars->end();) {
-				out << (*v);
-				print_annotation(out, *v, indent, cenv, types);
-
-				out << " " << (*++v);
-
-				if (++v != vars->end())
-					newline(out, indent + 6);
-				else
-					out << ")";
-			}
-			newline(out, indent + 2);
-			print_list(out, tup, tup->iter_at(2), indent + 2, cenv, false, false);
-			out << ")";
-			//print_annotation(out, tup->list_last(), indent, cenv, types);
-
 		} else if (form == "match") {
 			out << (*i++);
 			newline(out, indent + 2);
diff --git a/src/repl.cpp b/src/repl.cpp
index 9709656..afa81e9 100644
--- a/src/repl.cpp
+++ b/src/repl.cpp
@@ -29,22 +29,35 @@
 
 using namespace std;
 
-static bool
-readParseType(CEnv& cenv, Cursor& cursor, istream& is, const AST*& exp, const AST*& ast)
+static inline const AST*
+dump(CEnv& cenv, const Code& code)
+{
+	for (Code::const_iterator i = code.begin(); i != code.end(); ++i)
+		pprint(cout, *i, &cenv, (cenv.args.find("-a") != cenv.args.end()));
+	return 0;
+}
+
+static const AST*
+readExpand(PEnv& penv, Cursor& cursor, istream& is, const AST*& exp)
 {
 	try {
-		exp = cenv.penv.parse(cursor, is);
+		exp = penv.parse(cursor, is);
 	} catch (Error e) {
 		cerr << e.what() << endl;
 		is.ignore(std::numeric_limits<std::streamsize>::max(), '\n'); // Skip REPL junk
 		throw e;
 	}
 
-	if (!exp || (exp->to_tuple() && exp->to_tuple()->empty()))
-		return false;
+	if (!exp) {
+		return NULL;
+	}
 
-	ast = cenv.penv.expand(exp); // Parse input
+	return penv.expand(exp);
+}
 
+static bool
+constrainUnify(CEnv& cenv, const AST* ast)
+{
 	Constraints c(cenv.tsubst);
 	resp_constrain(cenv.tenv, c, ast); // Constrain types
 	cenv.tsubst = unify(c);
@@ -72,14 +85,6 @@ callPrintCollect(CEnv& cenv, CFunc f, const AST* result, const AST* resultT, boo
 	Object::pool.collect(Object::pool.roots());
 }
 
-static inline const AST*
-dump(CEnv& cenv, const Code& code)
-{
-	for (Code::const_iterator i = code.begin(); i != code.end(); ++i)
-		pprint(cout, *i, &cenv, (cenv.args.find("-a") != cenv.args.end()));
-	return 0;
-}
-
 const AST*
 compile(CEnv& cenv, const Code& parsed, Code& defs, bool& hasMain, const char* mainName)
 {
@@ -177,18 +182,28 @@ eval(CEnv& cenv, Cursor& cursor, istream& is, bool execute)
 	const AST* ast = NULL;
 
 	try {
-		// Parse and type all expressions
-		Code parsed;
-		while (readParseType(cenv, cursor, is, exp, ast))
-			parsed.push_back(ast);
+		// Read and expand all expressions
+		Code expanded;
+		while (!is.eof()) {
+			if ((ast = readExpand(cenv.penv, cursor, is, exp)))
+				expanded.push_back(ast);
+		}
+		if (cenv.args.find("-E") != cenv.args.end()) {
+			dump(cenv, expanded);
+			return 0;
+		}
+
+		// Type constrain and unify expanded code
+		for (auto e : expanded)
+			constrainUnify(cenv, e);
 		if (cenv.args.find("-T") != cenv.args.end()) {
-			dump(cenv, parsed);
+			dump(cenv, expanded);
 			return 0;
 		}
 
 		Code defs;
 		bool hasMain = false;
-		const AST* retT = compile(cenv, parsed, defs, hasMain, "main");
+		const AST* retT = compile(cenv, expanded, defs, hasMain, "main");
 		if (cenv.args.find("-F") != cenv.args.end()) {
 			dump(cenv, defs);
 			return 0;
@@ -230,16 +245,29 @@ repl(CEnv& cenv)
 		Cursor cursor("(stdin)", 1, 1);
 
 		try {
-			if (!readParseType(cenv, cursor, std::cin, exp, ast))
+			// Read and expand expression
+			Code expanded;
+			if ((ast = readExpand(cenv.penv, cursor, std::cin, exp)))
+				expanded.push_back(ast);
+			else
 				break;
+			if (cenv.args.find("-E") != cenv.args.end()) {
+				dump(cenv, expanded);
+				return 0;
+			}
+
+			// Type constrain and unify expanded code
+			for (auto e : expanded)
+				constrainUnify(cenv, e);
+			if (cenv.args.find("-T") != cenv.args.end()) {
+				dump(cenv, expanded);
+				return 0;
+			}
 
-			Code parsed;
-			parsed.push_back(ast);
-				
 			Code defs;
 			bool hasMain;
 			const std::string replName = cenv.penv.gensymstr("_repl");
-			const AST* retT = compile(cenv, parsed, defs, hasMain, replName.c_str());
+			const AST* retT = compile(cenv, expanded, defs, hasMain, replName.c_str());
 			if (cenv.args.find("-F") != cenv.args.end()) {
 				dump(cenv, defs);
 				continue;
diff --git a/src/resp.cpp b/src/resp.cpp
index 51e5ea6..c37fd3d 100644
--- a/src/resp.cpp
+++ b/src/resp.cpp
@@ -76,6 +76,7 @@ print_usage(char* name, bool error)
 	os << "  -o FILE          Compile output to FILE (don't run)"        << endl;
 	os << "  -r               Enter REPL after evaluating files"         << endl;
 	os << "  -P               Parse only"                                << endl;
+	os << "  -E               Expand macros only"                        << endl;
 	os << "  -T               Type check only"                           << endl;
 	os << "  -R               Reduce to simpler forms only"              << endl;
 	os << "  -C               Convert to CPS only"                       << endl;
@@ -107,6 +108,7 @@ main(int argc, char** argv)
 		           || !strncmp(argv[i], "-R", 3)
 		           || !strncmp(argv[i], "-S", 3)
 		           || !strncmp(argv[i], "-T", 3)
+		           || !strncmp(argv[i], "-E", 3)
 		           || !strncmp(argv[i], "-a", 3)
 		           || !strncmp(argv[i], "-g", 3)
 		           || !strncmp(argv[i], "-r", 3)) {
diff --git a/src/resp.hpp b/src/resp.hpp
index e572473..fd861aa 100644
--- a/src/resp.hpp
+++ b/src/resp.hpp
@@ -490,6 +490,17 @@ ostream& operator<<(ostream& out, const Env<V>& env) {
  * Parser: S-Expressions (SExp) -> AST Nodes (AST)                         *
  ***************************************************************************/
 
+struct Macro {
+	struct Rule {
+		Rule(const ATuple* p, const ATuple* t) : pattern(p), templ(t) {}
+		const ATuple* pattern;
+		const ATuple* templ;
+	};
+
+	std::set<std::string> keywords;
+	std::list<Rule>       rules;
+};
+
 /// Parse Time Environment (really just a symbol table)
 struct PEnv : private map<const string, const char*> {
 	PEnv() : symID(0) {}
@@ -514,6 +525,9 @@ struct PEnv : private map<const string, const char*> {
 	typedef std::set<std::string> Primitives;
 	Primitives primitives;
 
+	typedef std::map<const std::string, Macro> Macros;
+	Macros macros;
+
 	unsigned symID;
 };
 
@@ -528,6 +542,11 @@ struct Constraint : public pair<const AST*,const AST*> {
 		: pair<const AST*, const AST*>(a, b) {}
 };
 
+static inline bool
+is_dots(const AST* exp) {
+	return (exp->to_symbol() && exp->as_symbol()->str() == "...");
+}
+
 /// Type substitution
 struct Subst : public list<Constraint> {
 	Subst(const AST* s=0, const AST* t=0) {
@@ -550,8 +569,18 @@ struct Subst : public list<Constraint> {
 			if (in->as_tuple()->empty())
 				return in;
 			List out;
-			for (ATuple::const_iterator i = in->as_tuple()->begin(); i != in->as_tuple()->end(); ++i)
-				out.push_back(apply(*i));
+			for (auto i : *in->as_tuple()) {
+				if (is_dots(i)) {
+					const_iterator o = find(i);
+					if (o != end()) {
+						for (auto j : *o->second->as_tuple()) {
+							out.push_back(apply(j));
+						}
+					}
+				} else {
+					out.push_back(apply(i));
+				}
+			}
 			if (out.head)
 				out.head->loc = in->loc;
 			return out.head;
diff --git a/src/unify.cpp b/src/unify.cpp
index 48ae1dd..aeb024f 100644
--- a/src/unify.cpp
+++ b/src/unify.cpp
@@ -129,13 +129,6 @@ Constraints::replace(const AST* s, const AST* t)
 	}
 	return *this;
 }
-
-static inline bool
-is_dots(const AST* type)
-{
-	return (AType::is_name(type) && type->as_symbol()->str() == "...");
-}
-
 /// Unify a type constraint set (TAPL 22.4)
 Subst
 unify(const Constraints& constraints)
diff --git a/test/mac.scm b/test/mac.scm
new file mode 100644
index 0000000..d5df7f3
--- /dev/null
+++ b/test/mac.scm
@@ -0,0 +1,8 @@
+(define-syntax and
+  (syntax-rules ()
+    ((and) #t)
+    ((and test) test)
+    ((and test1 test2 ...)
+     (if test1 (and test2 ...) #f))))
+
+(and (= 1 1) (= 2 2) #t #t (= 1 4))
diff --git a/wscript b/wscript
index ffd1da4..a04555f 100644
--- a/wscript
+++ b/wscript
@@ -40,6 +40,7 @@ def configure(conf):
     autowaf.display_header('Resp Configuration')
 
     conf.env.append_unique('CFLAGS', '-std=c99')
+    conf.env.append_unique('CXXFLAGS', '-std=c++11')
 
     conf.check_cfg(
         path         = 'llvm-config-3.1',
@@ -96,6 +97,7 @@ def test(ctx):
             Logs.error("ERROR:    %s" % prog)
 
     # Basic lexical sanity
+    run_test('./test/mac.scm',         '#f : Bool')
     run_test('./test/def.scm',         '4 : Int')
     run_test('./test/deffn.scm',       '3 : Int')
     run_test('./test/inlinefn.scm',    '2 : Int')