secd_cod.js - Scala で TAPLを勉強しつつ LLVM コンパイラを作る日記

/*
secd_mem
*/
var maxReg = 10;
var regs = new Array(maxReg + 1);

function error(s) {
	printf("\n"+s+" !\n");
	flush();
	throw s;
}

function showStat() {
	printf("--- SECD stats: Loops= "+loopCnt+"\n");
}

/**
 * regs[s]のcarをregs[d]に入れる。
 */
function car(s, d) {
	regs[d] = regs[s][0]
}

/**
 * regs[s]のcarをregs[d]に入れる。
 */
function cdr(s, d) {
	regs[d]=regs[s][1]
}

/**
 * regs[s]をpopして、regs[d]に入れる。
 */
function pop(s, d) {
	//if (s != d) {
		var w = regs[s];
			regs[d] = w[0];
			regs[s] = w[1];
	//} else error("pop(x,x) is inpossible");
}


/**
 * ノードを作って、その中にregs[l]とregs[r]の値を格納してregs[d]に入れる。
 */
function cons(l, r, d) {
	regs[d] = [regs[l],regs[r]]
}

/**
 * regs[s]からregs[d]にリストの先頭を移動する。
 */
function roll(s, d) {
	if (s != d) {
		var w = regs[s];
		if (w instanceof Array) {
			regs[s] = w[1];
			regs[d] = [w[0],regs[d]];
		} else error("roll of an atom");
	} else error("roll(x,x) is inpossible");
}
 
/**
 * regs[s]からregs[d]にコピーする。
 */
function moveReg(s, d) {
	regs[d] = regs[s];
}

/**
 * regs[s]のcarにregs[d]をセットする｡
 */
function setCar(s, d) {
	var w = regs[s];
	if (w instanceof Array) {
		w[0] = regs[d];
	} else error("setCar to an atom");
}

/**
 * regs[reg]にTag:t,値vをセットする。
 */
function setAtom(reg, v) {
	regs[reg] = v;
}

function showReg(reg, limit, lnCase) {
	var cnt, lcnt;
	var depth, d0;

	function wr(s) {
		for (var i = 0; i < s.length; i++) {
			cnt++; lcnt++;
			if (cnt < limit) printf(s.charAt(i));
		}
	}

	function showAtom(R) {
		wr(""+R);
	}

	function showNode(v) {
		showReg_0(v[0]);
		showTail(v[1]);
	}
	function showTail(R) {
		if (cnt < limit) {
 			if(R instanceof Array){wr(" "); showNode(R);return;}
 			if(R == null) return;
 			wr("."); showAtom(R);
		}
	}
	function showReg_0(R) {
		if (cnt < limit) {
//			printf("koko="+typeof(R)+"\n");
			switch (typeof(R)) {
			case "object":
				if(R == null){ wr("NIL"); break;}

				if (lcnt - 3 * (depth - d0) > 40 && lnCase) {
					printf("\n"); lcnt = 0; d0 = depth;
					for (var i = 0; i < depth; i++) wr(" ");
				}
				wr("("); depth++; showNode(R); depth--; wr(")");
				break;
			case "number":
			case "string": showAtom(R); break;
			}
		}
	};
	cnt = 0; lcnt = 0; depth = 0; d0 = 0;
	showReg_0(regs[reg]);
}

/*
secd_str
*/

var fin;
var fout;
var specChas = {"(":1,")":1,".":1," ":1};
var	maxStr = 1000;


var w;

function init() {
	fout = "";
	fout1 = document.getElementById("fout");
	fin = "";
	w = ' ';
}
 

function newAtom(s, reg) {
	if (s == "NIL" || s == "nil") {
		setAtom(reg, null);
	} else {
		var n = Number(s);
		if ("" + n == s) {
			setAtom(reg, n);
		} else {
			setAtom(reg, s);
		}
	}
}

function getLex() {
	function rd() {
		if (fin=="") w = ')'; else { w = fin.charAt(0); fin = fin.substring(1); }
		if (w == '\r' || w == '\n' ) w = ' ';
	}
	while (w == ' ') {
		rd();
	}
	var s = "" + w;
	if (specChas[w]) {
		rd();
	} else {
		while (!(specChas[w])) {
			rd();
			if (!(w in specChas)) s = s + w;
		}
	}
	//printf("getLex \""+s+"\"\n");

	return s;
}

function readSExp(r0, r1) {
	//printf("readSExp "+r0+" "+r1+"\n");
	var s;

	function readSExp0() {
	//	printf("readSExp0\n");
		s = getLex();
		if (s == "(") readTail(); else newAtom(s, r0);
	//	printf("return readSExp0\n");
	}
	function readTail() {
		function tail0() {
			cons(r0, r1, r1);
			readTail();
			roll(r1, r0);
		}
		s = getLex();
		switch (s) {
		case "(":
			readTail(); tail0(); break;
		case ")":
			setAtom(r0, null); break;
		case ".":
			readSExp0(); s = getLex();
			if (s != ")") error("Bad S-Expresion");
			break;
		default:
			newAtom(s, r0);
			tail0();
			break;
		}
	};
	
	readSExp0();
	w = ' ';
}

function readSFrom(fname, r) {
	fin = readFile(fname);
	printf("readSFrom "+r+"\n");
	readSExp(r, maxReg);
//	fin.close();
}
function flush(){
	fout1.value=fout;
}
function writeSTo(fname, r) {
	flush();
	fout="";
	fout1 = document.getElementById(fname);
	showReg(r, 99999, true);
	fout += "\n";
	flush();
}
/*
secd_cod
*/
var	s = 0;
var	e = 1;
var	c = 2;
var	d = 3;
var	w1 = 4;
var	w2 = 5;
// SECD commands:
var	LD = 1;
var	LDC = 2;
var	LDF = 3;
var	APP = 4;
var	RTN = 5;
var	DUM = 6;
var	RAP = 7;
var	SEL = 8;
var	JOIN = 9;
var	CAR = 10;
var	CDR = 11;
var	ATOM = 12;
var	CONS = 13;
var	EQ = 14;
var	ADD = 15;
var	SUB = 16;
var	MUL = 17;
var	DIV = 18;
var	REM = 19;
var	LEQ = 20;
var	STOP = 21;

var loopCnt = 0;
var printCnt = 0;
function printf(str) {
	printCnt++;
	if(printCnt >= 100){flush(); printCnt = 0;}
	fout += str;
}
function showSECD() {
	printf(loopCnt + ":");
	printf("S = "); showReg(s, 120, false); printf("\n");
	printf("E = "); showReg(e, 120, false); printf("\n");
	printf("C = "); showReg(c, 120, false); printf("\n");
	printf("D = "); showReg(d, 120, false); printf("\n");
	// readln();
}

function secdLoop() {
	var cmd;
	function appCmd(noRec) {
		cons(c, d, d);
		if (noRec) {
			cons(e, d, d);
		} else {
			cdr(e, w1);
			cons(w1, d, d);
		}
		pop(s, e);
		pop(e, c);
		if (noRec) {
			roll(s, e);
		} else {
			pop(s, w1);
			setCar(e, w1);
		}
		cons(s, d, d);
		setAtom(s, null);
	}

	function selCmd() {
		pop(s, w1);
		if (typeof(regs[w1]) != "string") error("If exp is not boolean (T/F)");
		var s1 = regs[w1]
		if (s1=="T"|| s1 == "t") { 
			pop(c, w1);
			pop(c, w2);
		} else {
			pop(c, w2);
			pop(c, w1);
		}
		cons(c, d, d);
		moveReg(w1, c);
	}
	function loadValue() {
		pop(c, w1);
		pop(w1, w2);
		if (typeof(regs[w1])!="number") error("Bad LD second argument "+regs[w1]+" "+typeof(regs[w1])); 
		if (typeof(regs[w2])!="number") error("Bad LD furst argument");
		var level = regs[w2]; 
		moveReg(e, w2);
		while (level > 0) {
			cdr(w2, w2);
			level--;
		}
		car(w2, w2);
		level = regs[w1];
		while (level > 0) {
			cdr(w2,w2);
			level--;
		}
		car(w2, w1);
		cons(w1, s, s);
	}
	function uniCmd() {
		pop(s, w1); 
		switch (cmd) {
		case CAR: car(w1, w1); break;
		case CDR: cdr(w1, w1); break;
		case ATOM: if (typeof(regs[w1])  == "string") /* != node */ newAtom("T", w1); else newAtom("F", w1);
		}
		cons(w1, s, s);
	}

	function binCmd() {
		pop(s, w1);
		pop(s, w2);
		switch (cmd) {
		case CONS: cons(w1, w2, w1); break;
		case EQ: if (regs[w2] == regs[w1])
					newAtom("T", w1); else newAtom("F", w1); break;
		}
		cons(w1, s, s);
	}
	function binIntCmd() {
		pop(s, w1);
		pop(s, w2);
	 	if (typeof(regs[w1]) != "number")
			error("Second argument must be int"); 
	 	if (typeof(regs[w2]) != "number")
			error("Furst argument must be int"); 
		switch (cmd) {
		case ADD: regs[w1] = regs[w2] + regs[w1]; break;
		case SUB: regs[w1] = regs[w2] - regs[w1]; break;
		case MUL: regs[w1] = regs[w2] * regs[w1]; break;
		case DIV: regs[w1] = regs[w2] / regs[w1]; break;
		case REM: regs[w1] = regs[w2] % regs[w1]; break;
		case LEQ: if (regs[w2] <= regs[w1])
					newAtom("T", w1); else newAtom("F", w1); break;
		}
		cons(w1, s, s);
	}
	for(;;){
//		showSECD();
		loopCnt++;
		pop(c, w1);
		cmd = regs[w1];
		switch (cmd) {
		case STOP: cons(w1,c,c); return;
		case LD: loadValue(); break;
		case LDC: roll(c, s); break;
		case LDF: pop(c, w1); cons(w1, e, w1); cons(w1, s, s); break;
		case APP: appCmd(true); break;
		case RTN: pop(s, w1); pop(d, s); cons(w1, s, s); pop(d, e); pop(d, c); break;
		case DUM: setAtom(w1, null); cons(w1, e, e); break;
		case RAP: appCmd(false); break;
		case SEL: selCmd(); break;
		case JOIN: pop(d, c); break;
		case CAR:
		case CDR:
		case ATOM: uniCmd(); break;
		case CONS:
		case EQ: binCmd(); break;
		case ADD:
		case SUB:
		case MUL:
		case DIV:
		case REM:
		case LEQ: binIntCmd(); break;
		default: error("Command not found at the top of C");
		}
		if(loopCnt % 1000 == 999) return "next"
	}
}
function readFile(filename) {
	var http;
	try{
		http = new XMLHttpRequest();
	} catch(e) {
		http = new ActiveXObject("Microsoft.XMLHTTP");
	}
	http.open("GET", filename, false);
	http.send(null);
	return http.responseText;
}