view code/gqc.tp @ 55:194a1414e240

Partial implementation of Ghost-Quiche
author Michael Pavone <pavone@retrodev.com>
date Sun, 27 Jul 2014 16:26:56 -0700
parents
children fde898a3cbbe
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 { (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"
			}
		}
	}
}