# HG changeset patch
# User Michael Pavone <pavone@retrodev.com>
# Date 1406503616 25200
# Node ID 194a1414e240ae6a05809e162844ea9ef91202dc
# Parent  ec87d53603dd3e460cd0039d11c1fb89b4304312
Partial implementation of Ghost-Quiche

diff -r ec87d53603dd -r 194a1414e240 code/gqc.tp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/code/gqc.tp	Sun Jul 27 16:26:56 2014 -0700
@@ -0,0 +1,260 @@
+{
+	mem <- :_addr {
+		#{
+			addr <- { _addr }
+			string <- { "[" . _addr . "]" }
+			isReg? <- { false }
+		}
+	}
+	reg? <- :val {
+		(object does: val understand?: "isReg?") && (val isReg?)
+	}
+	reg <- :_num {
+		#{
+			num <- { _num }
+			string <- { (#["a" "b" "c" "d" "e" "f" "g" "h" "pc"]) get: _num }
+			isReg? <- { true }
+			!= <- :other { (reg?: other) && _num != (other num) }
+			= <- :other { (reg?: other) && _num = (other num) }
+		}
+	}
+	inst <- :_name _args {
+		#{
+			name <- _name
+			args <- _args
+			translateLabels <- :labelDict {
+				missing <- #[]
+				foreach: args :idx arg {
+					if: (object does: arg understand?: "isString?") && (arg isString?) {
+						labelDict ifget: arg :translated {
+							args set: idx translated
+						} else: {
+							missing append: arg
+						}
+					}
+				}
+				missing
+			}
+			label <- ""
+			comment <- ""
+			string <- {
+				(if: label != "" { ";" . label . "\n  " } else: { "  " }
+				) . name . " " . (args join: ", ") . (
+				if: comment = "" { "" } else: { " ;" . comment})
+			}
+		}
+	}
+	_nextLabel <- 0
+	_setLabel <- :inst {
+		inst
+	}
+	prog <- #{
+		instructions <- #[]
+		add <- :inst {
+			instructions append: (_setLabel: inst)
+		}
+		makeLabel <- :suffix {
+			num <- _nextLabel
+			_nextLabel <- _nextLabel + 1
+			"" . num . "_" . suffix
+		}
+		labels <- dict hash
+		setLabel <- :name {
+			labels set: name pc
+			_setLabel <- :inst {
+				_setLabel <- :i { i }
+				inst label!: name
+			}
+		}
+		pc <- { instructions length }
+		print <- {
+			foreach: instructions :idx i {
+				missing <- i translateLabels: labels
+				if: (missing length) > 0 {
+					error: "Undefined labels " . (missing join: ", ") . " at address " . idx
+				}
+				print: (string: i) . "\n"
+			}
+			
+		}
+	}
+	error <- :msg {
+		(file stderr) write: "Error - " . msg . "\n"
+	}
+	_nextVar <- 0
+	//a and b are reserved for int/return values
+	//h is reserved as a stack pointer
+	_tempRegs <- [
+		reg: 2
+		reg: 3
+		reg: 4
+		reg: 5
+		reg: 6
+	]
+	
+	_exprHandlers <- dict hash
+	
+	compileExpr:syms <- :expr :syms {
+		_exprHandlers ifget: (expr nodeType) :handler {
+			handler: expr syms
+		} else: {
+			error: "Unhandled node type " . (expr nodeType)
+		}
+	}
+	
+	_exprHandlers set: (ast intlit) :expr syms {
+		expr val
+	}
+	
+	_opNames <- dict hash
+	_opNames set: "+" "ADD"
+	_opNames set: "-" "SUB"
+	_opNames set: "*" "MUL"
+	_opNames set: "/" "DIV"
+	_opNames set: "and" "AND"
+	_opNames set: "or" "OR"
+	_opNames set: "xor" "XOR"
+	
+	_exprHandlers set: (ast binary) :expr syms {
+		startTempRegs <- _tempRegs
+		l <- compileExpr: (expr left) syms: syms
+		r <- compileExpr: (expr right) syms: syms
+		dest <- l
+		if: (reg?: l) {
+			_tempRegs <- startTempRegs filter: :r { r != l }
+		} else: {		
+			dest <- startTempRegs value
+			prog add: (inst: "MOV" #[
+				dest
+				l
+			])
+			_tempRegs <- startTempRegs tail
+		}
+		_opNames ifget: (expr op) :i {
+			prog add: (inst: i #[
+				dest
+				r
+			])
+			dest
+		} else: {
+			error: "operator " . (expr op) . " is not supported"
+		}
+	}
+	
+	_exprHandlers set: (ast sym) :expr syms {
+		syms ifDefined: (expr name) :info {
+			info def
+		} else: {
+			error: "symbol " . (expr name) . " is not defined"
+		}
+	}
+	
+	_exprHandlers set: (ast assignment) :expr syms {
+		sym <- expr to
+		syms ifDefined: (sym name) :info {
+		} else: {
+			syms define: (sym name) (mem: _nextVar)
+			_nextVar <- _nextVar + 1
+		}
+		info <- syms find: (sym name) else: {
+			error: "this should never happen!"
+		}
+		startTempRegs <- _tempRegs
+		v <- compileExpr: (expr assign) syms: syms
+		_tempRegs <- startTempRegs
+		dest <- info def
+		prog add: (inst: "MOV" #[
+			dest
+			v
+		])
+		dest
+	}
+	
+	_compileFun <- :name fun globsyms {
+		syms <- symbols tableWithParent: globsyms
+		
+		saveTempRegs <- _tempRegs
+		foreach: (fun args) :idx arg {
+			argname <- (if: (arg startsWith?: ":") { arg from: 1 } else: { arg })
+			reg <- _tempRegs value
+			_tempRegs <- _tempRegs tail
+			syms define: argname reg
+		}
+		
+		lastexpr <- ((fun expressions) length) - 1
+		
+		foreach: (fun expressions) :idx expr {
+			saveTempRegsExpr <- _tempRegs
+			v <- compileExpr: expr syms: syms
+			_tempRegs <- saveTempRegsExpr
+			if: idx = lastexpr && (name != "main") {
+				//move result to a register
+				prog add: (inst: "MOV" #[
+					reg: 0
+					v
+				])
+				//return instruction
+				prog add: (inst: "MOV" #[
+					reg: 8
+					mem: (reg: 7)
+				])
+			}
+		}
+		saveTempRegs <- _tempRegs
+	}
+	
+	#{
+		compile <- :code {
+			res <- parser top: code
+			if: res {
+				outer <- res yield
+				functions <- dict hash
+				syms <- symbols table
+				foreach: (outer messages) :idx msg {
+					if: (msg nodeType) = (ast assignment) {
+						def <- msg assign
+						sym <- (msg to) name
+						
+						if: (def nodeType) = (ast lambda) {
+							functions set: sym def
+							syms define: sym sym
+						} else: {
+							compileExpr: msg syms: syms
+						}
+					} else: {
+						error: "Only assignments are allowed at the top level"
+					}
+				}
+				
+				functions ifget: "main" :def {
+					prog setLabel: "main"
+					_compileFun: "main" def syms
+				} else: {
+					error: "Program must have a main function!"
+				}
+				prog add: (inst: "HLT" #[])
+				
+				foreach: functions :name def {
+					if: name != "main" {
+						prog setLabel: name
+						_comipleFun: name def syms
+					}
+				}
+				print: prog
+			}
+		}
+		
+		compileFile <- :filename {
+			f <- file open: filename
+			compile: (f readAll)
+		}
+		
+		main <- :args {
+			if: (args length) > 1 {
+				compileFile: (args get: 1)
+			} else: {
+				print: "Usage lmc FILE\n"
+			}
+		}
+	}
+}
\ No newline at end of file