view code/lmc.tp @ 85:f420fabd0e44 default tip

One last README change
author Michael Pavone <pavone@retrodev.com>
date Mon, 28 Jul 2014 04:42:24 -0700
parents 0e1fc2b2832f
children
line wrap: on
line source

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

	_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 {
		prog add: (inst: "LDC" #[(expr val)])
	}
	
	_exprHandlers set: (ast sequence) :expr syms {
		count <- 0
		foreach: (expr els) :idx el {
			compileExpr: el syms: syms
			count <- count + 1
		}
		if: (expr array?) {
			count <- count - 1
		} else: {
			prog add: (inst: "LDC" #[0])
		}
		while: { count > 0} do: {
			prog add: (inst: "CONS" #[])
			count <- count - 1
		}
	}
	
	_opNames <- dict hash
	_opNames set: "+" "ADD"
	_opNames set: "-" "SUB"
	_opNames set: "*" "MUL"
	_opNames set: "/" "DIV"
	_opNames set: "|" "CONS"
	_opNames set: "=" "CEQ"
	_opNames set: ">" "CGT"
	_opNames set: ">=" "CGTE"
	
	_exprHandlers set: (ast binary) :expr syms {
		compileExpr: (expr left) syms: syms
		compileExpr: (expr right) syms: syms
		_opNames ifget: (expr op) :i {
			prog add: (inst: i #[])
		} else: {
			if: (expr op) = "<" {
				prog add: (inst: "CGTE" #[])
				prog add: (inst: "LDC" #[0])
				prog add: (inst: "CEQ" #[])
			} else: {
				if: (expr op) = "<=" {
					prog add: (inst: "CGT" #[])
					prog add: (inst: "LDC" #[0])
					prog add: (inst: "CEQ" #[])
				} else: {
					error: "operator " . (expr op) . " is not supported"
				}
			}
		}
	}
	
	_funHandlers <- dict hash
	_funHandlers set: "if:else" :args syms {
		compileExpr: (args value) syms: syms
		args <- args tail
		tlabel <- prog makeLabel: "true"
		flabel <- prog makeLabel: "false"
		elabel <- prog makeLabel: "end"
		prog add: (inst: "TSEL" #[
			tlabel 
			flabel
		])
		prog setLabel: tlabel
		foreach: ((args value) expressions) :idx expr {
			compileExpr: expr syms: syms
		}
		prog add: (inst: "LDC" #[1])
		prog add: (inst: "TSEL" #[
			elabel
			elabel
		])
		args <- args tail
		prog setLabel: flabel
		foreach: ((args value) expressions) :idx expr {
			compileExpr: expr syms: syms
		}
		prog setLabel: elabel
	}
	_funHandlers set: "while:do" :args syms {
		top <- prog makeLabel: "loop_top"
		body <- prog makeLabel: "loop_body"
		end <- prog makeLabel: "loop_end"
		cond <- args value
		prog setLabel: top
		foreach: (cond expressions) :idx expr {
			compileExpr: expr syms: syms
		}
		prog add: (inst: "TSEL" #[
			body
			end
		])
		prog setLabel: body
		blambda <- (args tail) value
		foreach: (blambda expressions) :idx expr {
			compileExpr: expr syms: syms
		}
		prog add: (inst: "LDC" #[1])
		prog add: (inst: "TSEL" #[
			top
			top
		])
		prog setLabel: end
	}
	_funHandlers set: "isInteger?" :args syms {
		compileExpr: (args value) syms: syms
		prog add: (inst: "ATOM" #[])
	}
	_funHandlers set: "empty?" :args syms {
		compileExpr: (args value) syms: syms
		prog add: (inst: "ATOM" #[])
	}
	_funHandlers set: "value" :args syms {
		compileExpr: (args value) syms: syms
		prog add: (inst: "CAR" #[])
	}
	_funHandlers set: "tail" :args syms {
		compileExpr: (args value) syms: syms
		prog add: (inst: "CDR" #[])
	}
	_funHandlers set: "not" :args syms {
		compileExpr: (args value) syms: syms
		prog add: (inst: "LDC" #[0])
		prog add: (inst: "CEQ" #[])
	}
	_funHandlers set: "print" :args syms {
		compileExpr: (args value) syms: syms
		prog add: (inst: "DBUG" #[])
	}
	
	_exprHandlers set: (ast call) :expr syms {
		tc <- (expr tocall)
		normal <- true
		if: (tc nodeType) = (ast sym) {
			_funHandlers ifget: (tc name) :handler {
				handler: (expr args) syms
				normal <- false
			} else: {
			}
		}
		if: normal {
			num <- 0
			foreach: (expr args) :idx arg {
				compileExpr: arg syms: syms
				num <- num + 1
			}
			compileExpr: tc syms: syms
			prog add: (inst: "AP" #[num])
		}
	}
	
	_exprHandlers set: (ast sym) :expr syms {
		syms ifDefined: (expr name) :info {
			frame <- if: (info isLocal?) { 0 } else: { info depth }
			prog add: (inst: "LD" #[
				frame
				(info def)
			])
		} else: {
			error: "symbol " . (expr name) . " is not defined"
		}
	}
	
	_exprHandlers set: (ast assignment) :expr syms {
		sym <- expr to
		syms ifDefined: (sym name) :info {
			frame <- if: (info isLocal?) { 0 } else: { info depth }
			compileExpr: (expr assign) syms: syms
			prog add: (inst: "ST" #[
				frame
				(info def)
			])
		} else: {
			error: "symbol " . (sym name) . " is not defined"
		}
	}
	
	compileLambda:syms <- :fname fun :syms {
		prog setLabel: fname
		argsyms <- symbols tableWithParent: syms
		foreach: (fun args) :idx el {
			argsyms define: (if: (el startsWith?: ":") { el from: 1 } else: { el }) idx
		}
		
		slot <- 0
		locsyms <- symbols tableWithParent: argsyms
		foreach: (fun expressions) :idx expr {
			if: (expr nodeType) = (ast assignment) {
				locsyms ifDefined: ((expr to) name) :sym {
					//already defined, nothing to do here
				} else: {
					locsyms define: ((expr to) name) slot
					slot <- slot + 1
				}
			}
		}
		fsyms <- if: slot > 0 {
			//allocate frame for locals
			prog add: (inst: "DUM" #[slot])
			i <- 0
			while: { i < slot } do: {
				prog add: (inst: "LDC" #[0])
				i <- i + 1
			}
			prologue_end <- prog makeLabel: fname . "_real"
			prog add: (inst: "LDF" #[prologue_end])
			prog add: (inst: "TRAP" #[slot])
			prog setLabel: prologue_end
			locsyms
		} else: { argsyms }
		
		foreach: (fun expressions) :idx expr {
			compileExpr: expr syms: fsyms
		}
		prog add: (inst: "RTN" #[])
	}
	
	_exprHandlers set: (ast lambda) :expr syms {
		fname <- prog makeLabel: "lambda"
		end <- prog makeLabel: "lambda_end"
		prog add: (inst: "LDC" #[1])
		prog add: (inst: "TSEL" #[
			end
			end
		])
		compileLambda: fname expr syms: syms
		prog setLabel: end
		prog add: (inst: "LDF" #[fname])
	}
	#{
		compile <- :code {
			res <- parser top: code
			if: res {
				outer <- res yield
				functions <- dict hash
				
				num <- 0
				syms <- symbols table
				
				dumaddr <- prog pc
				prog add: (inst: "DUM" #[0])
				
				slot <- 0
				mainArgs <- 0
				messageGroups <- [(outer messages)]
				while: { not: (messageGroups empty?) } do: {
					curMessages <- messageGroups value
					messageGroups <- messageGroups tail
					foreach: curMessages :idx msg {
						if: (msg nodeType) = (ast assignment) {
							num <- num + 1
							def <- msg assign
							sym <- (msg to) name
							
							if: (def nodeType) = (ast lambda) {
								prog add: (inst: "LDF" #[sym])
								functions set: sym def
								if: sym = "main" {
									mainArgs <- (def args) length
								}
							} else: {
								compileExpr: def syms: syms
							}
							syms define: sym slot
							slot <- slot + 1
						} else: {
							if: (msg nodeType) = (ast call) && ((msg tocall) nodeType) = (ast sym) && (
									((msg tocall) name) = "import:from"
							) {
								importSyms <- (((msg args) value) els) fold: (dict hash) with: :acc sym {
									acc set: (sym name) true
								}
								moduleName <- ((((msg args) tail) value) args) value
								moduleFile <- if: (moduleName nodeType) = (ast sym) {
									(moduleName name) . ".lm"
								} else: {
									if: ((moduleName val) endsWith?: ".lm") {
										moduleName val
									} else: {
										(moduleName val) . ".lm"
									}
								}
								f <- file open: moduleFile
								moduleRes <- parser top: (f readAll)
								if: moduleRes {
									newGroup <- []
									foreach: ((moduleRes yield) messages) :idx msg {
										if: (msg nodeType) = (ast assignment) {
											importSyms ifget: ((msg to) name) :jnk {
												newGroup <- msg | newGroup
											} else: {}
										}
									}
									messageGroups <- newGroup | messageGroups
								} else: {
									error: "Failed to parse module " . moduleFile . "!\n"
								}
							} else: {
								error: "Only assignments and import:from are allowed at the top level"
							}
						}
					}
				}
				(((prog instructions) get: dumaddr) args) set: 0 num
				after_env <- prog makeLabel: "after_env"
				prog add: (inst: "LDF" #[after_env])
				prog add: (inst: "TRAP" #[num])
				prog setLabel: after_env
				
				i <- 0
				while: { i < mainArgs } do: {
					prog add: (inst: "LD" #[
						1
						i
					])
					i <- i + 1
				}
				
				prog add: (inst: "LDF" #["main"])
				prog add: (inst: "TAP" #[mainArgs])
				
				foreach: functions :fname fun {
					compileLambda: fname fun syms: syms
				}
				print: prog
			} else: {
				error: "Parse failed!"
			}
		}

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