haXeで作るプログラミング言語(14)

haxe

Lisp相当のマクロが使えるように変更

今回の連載の最終回です。
Lisp相当のマクロを実装します。


マクロの定義はmac(変換前の式)変換後の式と書くことにします。


例)

mac(mul('a,'b))a*b

上のようにマクロを定義しておき、

mul(2,3)

とすると2*3が計算されて6が返されます。

		switch(a) {
		case op(l, tag, r):
			if(tag=="Smac()"){// マクロ取り出し
				macros.push(a);
				return nil;
			} else
			if(symStr(l)=="add" && tag=="M()") {
				var rr:Exp = r;
				switch(rr) {
				case op(aa, tag2, bb):
					if(tag2=="L,") {
						return op(macroExpand(aa,e),"L+",macroExpand(bb,e));
					}
				default:
				}
			}
			return op(macroExpand(l, e),tag,macroExpand(r,e));
		case fun(prm, body, env): return fun(macroExpand(prm,e), macroExpand(body,e), env);
		default: return a;
		}

以上のようにaddシンタックスシュガーの手前に処理を追加します。
macros.push(a)としてmacrosにmacro定義の式を保存します。


次に展開する処理を作成します。

		switch(e.get("macros")){
		case stk(stack): macros = stack;
			for(i in stack) {
				switch(i){
				case op(prms, tag, body):
					var back = env1;
					var m = new Hash<Exp>();
					m.set("parent", env(e));
					env1 = m;
					var rc = macroMatch(prms, a);

					if(rc) {
						var r= execute(body);
						env1 = back;
						return r;
					}
					env1 = back;
				default:
				}
			}
		default:
		}

以上のようにmacroExpand関数の最初にmacroの配列からマクロを取得して式とマッチングします。
マッチしたら式を実行して返します。


次にmacroMatch関数を作成します。この関数では、式全体を再帰的にたどって、aの式とbの式のマッチングを行います。１箇所でもマッチしないところがあればすぐにfalseを返します。

	function macroMatch(a:Exp, b:Exp):Bool {
		switch(a) {
		case ssym(n): env1.set(n,b); return true;
		case op(a1,a2,a3):
			switch(b){
			case op(b1,b2,b3): return (a2==b2)&&macroMatch(a1,b1)&&macroMatch(a3,b3);
			default: return false;
			}
		case nil:
			switch(b){
			case nil: return true;
			default: return false;
			}
		case vid:
			switch(b){
			case vid: return true;
			default: return false;
			}
		case num(n): 
			switch(b){
			case num(nb): return n == nb;
			default: return false;
			}
		case sym(s):
			switch(b){
			case sym(sb): return s == sb;
			default: return false;
			}
		case str(s):
			switch(b){
			case str(sb): return s == sb;
			default: return false;
			}
		default: return false;
		}
	}

これでLisp相当のマクロを実現できます。


まとめ


このように式をベースとするとマッチングのプログラムを小さく書くことができます。
結果的に簡単に強力なマクロを実現できます。


式をベースとした言語はHaskell,SML,Ocaml,Clean等と他にもありますが、
ポピュラーなC言語風の言語の多くは式をベースとしてません。
そのため、LISP級のマクロの導入は困難です。


現在の一般的な言語は、文字列からすぐに巨大な文法に則って構文解析を行います。
これは高速である反面、プログラムでプログラムを扱おうとした場合には規則が複雑なためプログラムも巨大になってしまうのです。


たとえば、Rubyの構文木を作成するプログラムがありますが、どれだけの人が利用しているでしょう？
ほとんど利用されていないのではないでしょうか？
その理由は、文法の巨大さにあるのです。


プログラミング言語の美しさの観点は個人によって違うと思います。
しかし、表現力が高く、プログラムをデータとして扱うことができて、実装が簡単であることが美しさの尺度であるとするなら、美しい言語が作れたのではないかと思います。


以上で、今回のお話はおしまいです。


参考リンク

  1. epp http://staff.aist.go.jp/y-ichisugi/doc/newjdoc/index.html
    1. JavaのプリプロセッサでJavaをS式に変換し、操作した後、Javaに戻す仕組み
  2. 次世代プログラミング言語開発室 http://www.sun-inet.or.jp/~yaneurao/intensive/newlang/chap0000.html
    1. 非常に影響を受けた言語
  3. 10分で書ける、お手軽パーザー http://fxp.hp.infoseek.co.jp/arti/parser.html
    1. プログラミング言語の基本中の基本の作り方
  4. JavaScript で数式パーサを書いてみた。 http://d.hatena.ne.jp/amachang/20070829/1188400850
    1. 演算子順位法の考え方がわかりやすい
  5. Top Down Operator Precedence http://javascript.crockford.com/tdop/tdop.html
    1. 演算子順位法について
  6. ビューティフルコード http://www.amazon.co.jp/ビューティフルコード-Brian-Kernighan/dp/4873113636
    1. 上記 Top Down Operator Precedenceの和訳があります
  7. Clean Book 第六章 インタプリタ http://sky.zero.ad.jp/~zaa54437/programming/clean/CleanBook/part2/Chap6.html
    1. 関数型言語Cleanによる演算子順位法を使った式言語ベースでインタプリタを作成している例。
  8. 記号のパターンマッチング http://www.geocities.jp/m_hiroi/xyzzy_lisp/abclisp22.html
    1. マクロのマッチングで使っているの考え方
  9. D-Expressions: Lisp Power, Dylan Style http://people.csail.mit.edu/jrb/Projects/dexprs.pdf
    1. Appleの強力なマクロのある言語、Dylanのマクロ導入のためのD式
  10. 生け垣オートマトン: XML スキーマの形式的モデル http://www.xml.gr.jp/relax/hedge_nice_ja.html
    1. S式やC式は生垣だよなという
  11. [relax-users-j 01519] 二分木オートマトンによるRELAX Core の検証について http://www2.xml.gr.jp/log.html?MLID=relax-users-j&N=1519
    1. 2分木の文法のバリデーション方法を応用して式に適用すると楽に検証できそう
  12. Macro Tree Transducers and Their Complexity http://www.kmonos.net/pub/Presen/tohoku.ppt
    1. バリデーションだけじゃなくて、式を変換したりコンパイルしたりするにはMTTをつかうといいみたい


以下プログラムソースです。

enum Exp {
	vid;
	nil;
	num(d:Int);
	sym(sym:String);
	ssym(sym:String);
	str(d:String);
	stk(s:Array<Exp>);
	env(e:Hash<Exp>);
	op(l:Exp, tag:String, r:Exp);
	fun(prm:Exp, body:Exp, env:Hash<Exp>);
}

class Calc14 {
	static function main() {
		var c = new Calc14();
		trace(c.eval("mac(mul('a,'b))a*b  mul(add(1,2),3)"));
	}
	var opLs:Hash<Int>;
	var opRs:Hash<Int>;
	var opPs:Hash<String>;
	var opMs:Hash<Int>;
	var opSs:Hash<String>;
	var endPs:Hash<Int>;
	var opBs:Hash<Int>;

	function symStr(e:Exp):String {
		switch(e) {
		case sym(a):return a;
		default: return null;
		}
	}

	function new() {
		opLs = new Hash<Int>();
		opRs = new Hash<Int>();
		opPs = new Hash<String>();
		opMs = new Hash<Int>();
		endPs = new Hash<Int>();
		opSs = new Hash<String>();
		opBs = new Hash<Int>();
		opLs.set("+", 10);
		opLs.set("-", 10);
		opLs.set("*", 20);
		opLs.set("/", 20);
		opLs.set(">",190);
		opLs.set("<",190);
		opLs.set("else",1);
		opRs.set("=", 5);
		opPs.set("(",")");
		opPs.set("[","]");
		opPs.set("{","}");
		opMs.set("(", 200);
		opMs.set("{", 200);
		opMs.set("[", 200);
		endPs.set(")", 0);
		endPs.set("]", 0);
		endPs.set("}", 0);
		opSs.set("fun","(");
		opSs.set("if","(");
		opSs.set("mac","(");
		opBs.set("++", 30);
		opLs.set(",", 2);
		opBs.set(";", 1);
	}

	var src:String;
	var token:String;
	var token2:String;
	var ln:Bool;
	
	function lex():String {
		var r : EReg = ~/^[\t ]*([\r\n]*)[\t \r\n]*([0-9]+|[,;\[\]{}()]|[+*\-\/=<>]+|'?[a-zA-Z_][a-zA-Z0-9]*|"([^"]*|\\.)")/;
		token2 = token;
		if(r.match(src)){
			if(r.matched(1).length > 0) {
				ln = true;
			} else {
				ln = false;
			}
			token = r.matched(2);
			src = src.substr(r.matched(0).length);
			return token2;
		}
		token = "";
		return token2;
	}

	function eval(str:String):Exp {
		var exp = parse(str);

		trace(exp);
		env1 = new Hash<Exp>();
		var stk1 = new Array<Exp>();
		env1.set("macros", stk(stk1));
		exp = macroExpand(exp, env1);
		trace(exp);
		return execute(exp);
	}
	function macroExpand(a:Exp, e:Hash<Exp>):Exp {
		var macros=null;
		switch(e.get("macros")){
		case stk(stack): macros = stack;
			for(i in stack) {
				switch(i){
				case op(prms, tag, body):
					var back = env1;
					var m = new Hash<Exp>();
					m.set("parent", env(e));
					env1 = m;
					var rc = macroMatch(prms, a);

					if(rc) {
						var r= execute(body);
						env1 = back;
						return r;
					}
					env1 = back;
				default:
				}
			}
		default:
		}

		switch(a) {
		case op(l, tag, r):
			if(tag=="Smac()"){// マクロ取り出し
				macros.push(a);
				return nil;
			} else
			if(symStr(l)=="add" && tag=="M()") {
				var rr:Exp = r;
				switch(rr) {
				case op(aa, tag2, bb):
					if(tag2=="L,") {
						return op(macroExpand(aa,e),"L+",macroExpand(bb,e));
					}
				default:
				}
			}
			return op(macroExpand(l, e),tag,macroExpand(r,e));
		case fun(prm, body, env): return fun(macroExpand(prm,e), macroExpand(body,e), env);
		default: return a;
		}
	}


	function macroMatch(a:Exp, b:Exp):Bool {
		switch(a) {
		case ssym(n): env1.set(n,b); return true;
		case op(a1,a2,a3):
			switch(b){
			case op(b1,b2,b3): return (a2==b2)&&macroMatch(a1,b1)&&macroMatch(a3,b3);
			default: return false;
			}
		case nil:
			switch(b){
			case nil: return true;
			default: return false;
			}
		case vid:
			switch(b){
			case vid: return true;
			default: return false;
			}
		case num(n): 
			switch(b){
			case num(nb): return n == nb;
			default: return false;
			}
		case sym(s):
			switch(b){
			case sym(sb): return s == sb;
			default: return false;
			}
		case str(s):
			switch(b){
			case str(sb): return s == sb;
			default: return false;
			}
		default: return false;
		}
	}

	function parse(str:String):Exp {
		src = str;
		lex();
		
		return exp();
	}

	function eat(e:String):String {
		var t = lex();
		if(t != e) throw ("expect error " + e);
		return t;
	}
	function exp() {
		var rc = expn(0);
		while (token != "" && token != "}" && token != ")" && token != "]") {
			rc = op(rc, "@", expn(0));
		}
		return rc;
	}
	function expn(p:Int):Exp {
		if(endPs.exists(token)) return vid;
		var tk = lex();
		var numReg : EReg = ~/[0-9]+/;
		var t:Exp;

		if (opSs.exists(tk) && opSs.get(tk) == token) {
			var p1 = lex();
			var e = exp();
			var op2 = eat(opPs.get(p1));
			t = op(e, "S"+tk+p1+op2, expn(0));
		} else
		if(opPs.exists(tk + "")) {
			var t2 = exp();
			if(lex() != opPs.get(tk)) throw ("error");
			t = op(nil, "P"+tk+opPs.get(tk), t2);
		} else if(numReg.match(tk)) {
			t = num(Std.parseInt(tk));
		} else if(tk.substr(0,1)=="'"){
			t = ssym(tk.substr(1));
		} else {
			t = sym(tk);
		}

		var tagp:Int;
		while(true) {
			if(!ln && opMs.exists(token) && (tagp = opMs.get(token)) >= p) {
				var tag = lex();
				var e = exp();
				var tag2 = eat(opPs.get(tag));
				t = op(t, "M"+tag+tag2, e);
				continue;
			}
			if(opBs.exists(token) && (tagp = opBs.get(token)) >= p) {
				var tag = lex();
				t = op(t, "B"+tag, nil);
				p = tagp;
				continue;
			}
			if(opLs.exists(token) && (tagp = opLs.get(token)) > p) {
				var tag = lex();
				t = op(t, "L"+tag, expn(tagp));
				continue;
			}
			if(opRs.exists(token) && (tagp = opRs.get(token)) >= p) {
				var tag = lex();
				t = op(t, "R"+tag, expn(tagp));
				continue;
			}
			break;
		}
		return t;
	}

	var env1:Hash<Exp>;
	function getEnv(env:Hash<Exp>, name):Exp {
		if (env.exists(name)) {
			return env.get(name);
		}
		if (env.exists("parent")) {
			switch (env.get("parent")) {
			case env(p): return getEnv(p, name);
			default: nil;
			}
		}
		return nil;
	}

	function putEnv(env:Hash<Exp>, name, value):Exp {
		var rc = put1(env, name, value);
		if(rc == nil) {
			env.set(name, value);
			return value;
		} else {
			return rc;
		}
	}
	function put1(env:Hash<Exp>, name, value) {
		if (env.exists(name)) {
			env.set(name, value);
			return value;
		}
		if (env.exists("parent")) {
			switch (env.get("parent")) {
			case env(e): return put1(e, name, value);
			default: return nil;
			}
		}
		return nil;
	}

	function bind(env1:Hash<Exp>, prm:Exp, l:Exp):Void{
		switch(prm) {
		case sym(p):
//			trace("set "+p+" "+l);
			env1.set(p,l); return;
		case op(p,t,ps):
			switch(l){
			case op(lp, lt, lps):
				bind(env1, p, lp);
				bind(env1, ps, lps);
			default: throw "error";
			}
		default: throw "error";
		}
	}

	function execute(exp:Exp):Exp {
//		trace("execute***"+exp);
		switch(exp) {
		case ssym(s): return exp;
		case stk(s): return exp;
		case fun(a,b,c): return exp;
		case str(d): return exp;
		case vid: return num(0);
		case nil: return num(0);
		case num(d): return num(d);
		case sym(d): return getEnv(env1, d);
		case op(l, tag, r):
			switch(tag){
			case "P{}": return execute(r);
			case "Sif()":
				var l1 = execute(l);
				switch(r) {
				case op(l2, tag2, r2):
					if(tag2 == "Lelse") {
						switch(l1){
						case num(n):
							if(n != 0) return execute(l2);
						default:
						}
						return execute(r2);
					}
				default:
				}
				switch(l1){
				case num(n):
					if(n != 0) return execute(r);
				default:
				}
				return nil;

			case "Sfun()": return fun(l, r, env1);
			case "P()": return execute(r);
			case "B;": return execute(l);
			default:
			}
			var d = symStr(l);
			if(d != ""){
				switch(tag){
				case "R=":
					var rc = execute(r);
					putEnv(env1, d, rc);
					return rc;
				case "M()":
					if(d=="println"){
						var r = execute(r);
						trace(r);
						return r;
					}
				case "B++":
					var dt = getEnv(env1, d);
					switch(dt){
					case num(b):
						putEnv(env1, d, num(b + 1));
						return dt;
					default:
					}
				default:
				}
			}
			// 左辺を評価
			var a = execute(l);
			switch (a) {
			case num(a):
				var b = execute(r);
				switch(b){
				case num(b):
					switch (tag) {
					case "L+": return num(a + b);
					case "L-": return num(a - b);
					case "L*": return num(a * b);
					case "L/": return num(cast(a / b, Int));
					case "L>": return num(b - a);
					case "L<": return num(a - b);
					case "@": return num(b);
					}
					default:
				}
			default:
			}
			switch(tag) {
			case "@": return execute(r);
			case "M()":
				switch(a){
				case fun(prm,body, ee):
					var back = env1;
					env1 = new Hash<Exp>();
					bind(env1, prm, r);
					env1.set("parent", env(ee));
					a = execute(body);
					env1 = back;
					return a;
				default:
				}
			default:
			}
			return a;
		case env(e): return exp;
		}
	}
}