view code/gqc.tp @ 58:d35601d47db1

Implement if:else in gqc
author Michael Pavone <pavone@retrodev.com>
date Sun, 27 Jul 2014 20:03:34 -0700
parents fde898a3cbbe
children 2a5d7308e1df
line wrap: on
line source

{
	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"
			}
		}
	}
}