# HG changeset patch
# User William Morgan <billjunk@mrgn.org>
# Date 1406537980 25200
# Node ID 428c1daefca9147fcd4b20e4fdc554fc0054a44c
# Parent  c17380c8bac34bc69439ee329c1acfa8f88034b4# Parent  d35601d47db17e83436f6498853539b12659a3d5
merge

diff -r c17380c8bac3 -r 428c1daefca9 code/gqc.tp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/code/gqc.tp	Mon Jul 28 01:59:40 2014 -0700
@@ -0,0 +1,671 @@
+{
+	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 { (not: (reg?: other)) || _num != (other num) }
+			= <- :other { (reg?: other) && _num = (other num) }
+		}
+	}
+	inst <- :_name _args {
+		#{
+			name <- _name
+			args <- _args
+			translateLabels <- :labelDict {
+				missing <- #[]
+				args <- args map: :arg {
+					if: (object does: arg understand?: "isString?") && (arg isString?) {
+						labelDict get: arg else: {
+							missing append: arg
+							arg
+						}
+					} else: {
+						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
+	_allTemp <- [
+		reg: 2
+		reg: 3
+		reg: 4
+		reg: 5
+		reg: 6
+	]
+	_tempRegs <- _allTemp
+	
+	_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
+	}
+	
+	_funHandlers <- dict hash
+	//provide symbolic names for all the interupt routines
+	_funHandlers set: "debug" :args syms {
+		prog add: (inst: "INT" #[8])
+		0
+	}
+	_funHandlers set: "direction!" :args syms {
+		dir <- args value
+		startTempRegs <- _tempRegs
+		v <- compileExpr: dir syms: syms
+		_tempRegs <- startTempRegs
+		if: (reg: 0) != v {	
+			prog add: (inst: "MOV" #[
+				reg: 0
+				v
+			])
+		}
+		prog add: (inst: "INT" #[0])
+		0
+	}
+	_funHandlers set: "lambdamanPos" :args syms {
+		prog add: (inst: "INT" #[1])
+		reg: 0
+	}
+	_funHandlers set: "lambdaman2Pos" :args syms {
+		prog add: (inst: "INT" #[2])
+		reg: 0
+	}
+	_funHandlers set: "me" :args syms {
+		prog add: (inst: "INT" #[3])
+		reg: 0
+	}
+	foreach: #["ghostStartPos" "ghostPos" "ghostStatus"] :idx name {
+		intNum <- idx + 4
+		_funHandlers set: name :args syms {
+			ghostIdx <- args value
+			startTempRegs <- _tempRegs
+			v <- compileExpr: ghostIdx syms: syms
+			_tempRegs <- startTempRegs
+			if: (reg: 0) != v {	
+				prog add: (inst: "MOV" #[
+					reg: 0
+					v
+				])
+			}
+			prog add: (inst: "INT" #[intNum])
+			reg: 0
+		}
+	}
+	_funHandlers set: "mapContentsAt" :args syms {
+		x <- args value
+		y <- (args tail) value
+		startTempRegs <- _tempRegs
+		x <- compileExpr: x syms: syms
+		y <- compileExpr: y syms: syms
+		_tempRegs <- startTempRegs
+		if: (reg: 0) != x {
+			prog add: (inst: "MOV" #[	
+				reg: 0
+				x
+			])
+		}
+		if: (reg: 1) != y {
+			prog add: (inst: "MOV" #[	
+				reg: 1
+				y
+			])
+		}
+		prog add: (inst: "INT" #[7])
+		reg: 0
+	}
+	
+	//allow access to raw instructions
+	foreach: #["MOV" "INC" "DEC" "ADD" "SUB" "MUL" "DIV" "AND" "OR" "XOR" "JLT" "JEQ" "JGT" "HLT"] :idx instName {
+		_funHandlers set: instName :args syms {
+			saveTempRegs <- _tempRegs
+			args <- args map: :arg { compileExpr: arg syms: syms }
+			prog add: (inst: instName args)
+		}
+	}
+	
+	_funHandlers set: "while:do" :args syms {
+		cond <- ((args value) expressions) value
+		body <- ((args tail) value) expressions
+		
+		if: (cond nodeType) = (ast binary) {
+			top <- prog makeLabel: "loop_top"
+			end <- prog makeLabel: "loop_end"
+			prog setLabel: top
+			
+			saveTempRegs <- _tempRegs
+			l <- compileExpr: (cond left) syms: syms
+			r <- compileExpr: (cond right) syms: syms
+			_tempRegs <- saveTempRegs
+			
+			ok <- true
+			//we need the inverse check in the instruction since a true condition
+			//means continue the loop, whereas we need a jump instruction that jumps
+			//only when it is time to exit
+			if: (cond op) = ">=" {
+				prog add: (inst: "JLT" #[
+					end
+					l
+					r
+				])
+			} else: {
+				if: (cond op) = "<=" {
+					prog add: (inst: "JGT" #[
+						end
+						l
+						r
+					])
+				} else: {
+					if: (cond op) = "!=" {
+						prog add: (inst: "JEQ" #[
+							end
+							l
+							r
+						])
+					} else: {
+						if: (cond op) = ">" {
+							bodyLbl <- prog makeLabel: "loop_body"
+							prog add: (inst: "JGT" #[
+								bodyLbl
+								l
+								r
+							])
+							prog add: (inst: "MOV" #[
+								reg: 8
+								end
+							])
+							prog setLabel: bodyLbl
+						} else: {
+							if: (cond op) = "<" {
+								bodyLbl <- prog makeLabel: "loop_body"
+								prog add: (inst: "JLT" #[
+									bodyLbl
+									l
+									r
+								])
+								prog add: (inst: "MOV" #[
+									reg: 8
+									end
+								])
+								prog setLabel: bodyLbl
+							}  else: {
+								bodyLbl <- prog makeLabel: "loop_body"
+								if: (cond op) = "=" {
+									prog add: (inst: "JEQ" #[
+										bodyLbl
+										l
+										r
+									])
+									prog add: (inst: "MOV" #[
+										reg: 8
+										end
+									])
+									prog setLabel: bodyLbl
+								} else: {
+									ok <- false
+								}
+							}
+						}
+					}
+				}
+			}
+			if: ok {
+				//TODO: do 2 passes for labels to allow forward references
+				foreach: body :idx expr {
+					if: (expr nodeType) = (ast sym) {
+						//allow using bare symbols to define labels
+						lbl <- prog makeLabel: (expr name)
+						prog setLabel: lbl
+						syms define: (expr name) lbl
+					} else: {
+						saveTempRegsExpr <- _tempRegs
+						v <- compileExpr: expr syms: syms
+						_tempRegs <- saveTempRegsExpr
+					}
+				}
+				prog add: (inst: "MOV" #[
+					reg: 8
+					top
+				])
+				prog setLabel: end
+			} else: {
+				error: "Condition parameter to while:do must be a comparison operator expression"
+			}
+		} else: {
+			error: "Condition parameter to while:do must be a comparison operator expression"
+		}
+	}
+	
+	_funHandlers set: "if:else" :args syms {
+		cond <- (args value)
+		trueBody <- ((args tail) value) expressions
+		falseBody <- (((args tail) tail) value) expressions
+		
+		if: (cond nodeType) = (ast binary) {
+			trueLbl <- prog makeLabel: "true"
+			falseLbl <- prog makeLabel: "false"
+			endLbl <- prog makeLabel: "end"
+			
+			saveTempRegs <- _tempRegs
+			l <- compileExpr: (cond left) syms: syms
+			r <- compileExpr: (cond right) syms: syms
+			_tempRegs <- saveTempRegs
+			
+			ok <- true
+			
+			if: (cond op) = ">=" {
+				prog add: (inst: "JLT" #[
+					falseLbl
+					l
+					r
+				])
+			} else: {
+				if: (cond op) = "<=" {
+					prog add: (inst: "JGT" #[
+						falseLbl
+						l
+						r
+					])
+				} else: {
+					if: (cond op) = "!=" {
+						prog add: (inst: "JEQ" #[
+							falseLbl
+							l
+							r
+						])
+					} else: {
+						if: (cond op) = ">" {
+							prog add: (inst: "JGT" #[
+								trueLbl
+								l
+								r
+							])
+							prog add: (inst: "MOV" #[
+								reg: 8
+								falseLbl
+							])
+						} else: {
+							if: (cond op) = "<" {
+								prog add: (inst: "JLT" #[
+									trueLbl
+									l
+									r
+								])
+								prog add: (inst: "MOV" #[
+									reg: 8
+									falseLbl
+								])
+							}  else: {
+								bodyLbl <- prog makeLabel: "loop_body"
+								if: (cond op) = "=" {
+									prog add: (inst: "JEQ" #[
+										trueLbl
+										l
+										r
+									])
+									prog add: (inst: "MOV" #[
+										reg: 8
+										falseLbl
+									])
+								} else: {
+									ok <- false
+								}
+							}
+						}
+					}
+				}
+			}
+			if: ok {
+				prog setLabel: trueLbl
+				//TODO: do 2 passes for labels to allow forward references
+				foreach: trueBody :idx expr {
+					if: (expr nodeType) = (ast sym) {
+						//allow using bare symbols to define labels
+						lbl <- prog makeLabel: (expr name)
+						prog setLabel: lbl
+						syms define: (expr name) lbl
+					} else: {
+						saveTempRegsExpr <- _tempRegs
+						v <- compileExpr: expr syms: syms
+						_tempRegs <- saveTempRegsExpr
+					}
+				}
+				prog add: (inst: "MOV" #[
+					reg: 8
+					endLbl
+				])
+				prog setLabel: falseLbl
+				//TODO: do 2 passes for labels to allow forward references
+				foreach: falseBody :idx expr {
+					if: (expr nodeType) = (ast sym) {
+						//allow using bare symbols to define labels
+						lbl <- prog makeLabel: (expr name)
+						prog setLabel: lbl
+						syms define: (expr name) lbl
+					} else: {
+						saveTempRegsExpr <- _tempRegs
+						v <- compileExpr: expr syms: syms
+						_tempRegs <- saveTempRegsExpr
+					}
+				}
+				prog setLabel: endLbl
+			} else: {
+				error: "Condition parameter to if:else must be a comparison operator expression"
+			}
+		} else: {
+			error: "Condition parameter to if:else must be a comparison operator expression"
+		}
+	}
+	
+	_exprHandlers set: (ast call) :expr syms {
+		tc <- (expr tocall)
+		if: (tc nodeType) = (ast sym) {
+			_funHandlers ifget: (tc name) :handler {
+				handler: (expr args) syms
+			} else: {
+				syms ifDefined: (tc name) :info {
+					saveTempRegs <- _tempRegs
+					funArgs <- (expr args) map: :arg { compileExpr: arg syms: syms}
+					_tempRegs <- saveTempRegs
+				
+					//save registers that need it
+					needSave <- _allTemp filter: :r {
+						not: (_tempRegs contains?: r)
+					}
+					foreach: needSave :idx r {
+						prog add: (inst: "DEC" #[(reg: 7)])
+						prog add: (inst: "MOV" #[
+							mem: (reg: 7)
+							r
+						])
+					}
+					after <- prog makeLabel: "after_call"
+					//save PC value after call
+					prog add: (inst: "DEC" #[(reg: 7)])
+					prog add: (inst: "MOV" #[
+						mem: (reg: 7)
+						after
+					])
+					//put arguments into the appropriate registers
+					passregs <- _allTemp
+					foreach: funArgs :idx arg {
+						passreg <- passregs value
+						passregs <- passregs tail
+						if: passreg != arg {
+							//there's a potential for clobbering argument temp regs
+							//but there's no time to figure out a good solution
+							prog add: (inst: "MOV" #[
+								passreg
+								arg
+							])
+						} else: {
+							print: "Skipping MOV for argument: " . arg . "\n"
+						}
+					}
+					//jump to function
+					prog add: (inst: "MOV" #[	
+						reg: 8
+						info def
+					])
+					prog setLabel: after
+					//adjust PC
+					prog add: (inst: "INC" #[(reg: 7)])
+					
+					//restore registers that were saved earlier
+					foreach: (reverse: needSave) :idx r {
+						prog add: (inst: "MOV" #[
+							r
+							mem: (reg: 7)
+						])
+						prog add: (inst: "INC" #[(reg: 7)])
+					}
+					reg: 0
+				} else: {
+					error: "Function " . (tc name) . " is not defined"
+				}
+			}
+		} else: {
+			error: "Calling expressions is not supported in"
+		}
+	}
+	
+	
+	_compileFun <- :fName fun globsyms {
+		syms <- symbols tableWithParent: globsyms
+		
+		saveTempRegs <- _tempRegs
+		foreach: (fun args) :idx arg {
+			argname <- (if: (arg startsWith?: ":") { arg from: 1 } else: { arg })
+			r <- _tempRegs value
+			_tempRegs <- _tempRegs tail
+			syms define: argname r
+		}
+		
+		lastexpr <- ((fun expressions) length) - 1
+		
+		//TODO: do 2 passes for labels to allow forward references
+		foreach: (fun expressions) :idx expr {
+			if: idx != lastexpr && (expr nodeType) = (ast sym) {
+				//allow using bare symbols to define labels
+				prog setLabel: (expr name)
+				syms define: (expr name) (expr name)
+			} else: {
+				saveTempRegsExpr <- _tempRegs
+				v <- compileExpr: expr syms: syms
+				_tempRegs <- saveTempRegsExpr
+				if: idx = lastexpr && (fName != "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
+				//define symbols for all registers
+				//for low level shenanigans
+				i <- 0
+				while: { i < 9 } do: {
+					r <- reg: i
+					syms define: (string: r) r
+					i <- i + 1
+				}
+				//define symbols for interrupt return values
+				syms define: "xCoord" (reg: 0)
+				syms define: "yCoord" (reg: 1)
+				syms define: "vitality" (reg: 0)
+				syms define: "direction" (reg: 1)
+				
+				//process top level assignments
+				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
+						_compileFun: 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