Mercurial > repos > icfp2014
view code/lmc.tp @ 76:47eb447a74cc
Don't chase ghosts we can't catch
author | Michael Pavone <pavone@retrodev.com> |
---|---|
date | Mon, 28 Jul 2014 02:57:56 -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" } } } }