Mercurial > repos > icfp2014
view code/lmc.tp @ 5:80e224fff567
Fix handling of true case in if:else
author | Michael Pavone <pavone@retrodev.com> |
---|---|
date | Fri, 25 Jul 2014 11:04:00 -0700 |
parents | eaf0a014d18b |
children | 0ab6eb5f0190 |
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 <- "" string <- { (if: label != "" { ";" . label . "\n " } else: { " " } ) . name . " " . (args join: " ") } } } _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 <- :expr { _exprHandlers ifget: (expr nodeType) :handler { handler: expr } else: { error: "Unhandled node type " . (expr nodeType) } } _exprHandlers set: (ast intlit) :expr { prog add: (inst: "LDC" #[(expr val)]) } _exprHandlers set: (ast sequence) :expr { count <- 0 foreach: (expr els) :idx el { compileExpr: el 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 { if: (expr op) = "|" { compileExpr: (expr left) compileExpr: (expr right) } else: { compileExpr: (expr right) compileExpr: (expr left) } _opNames ifget: (expr op) :i { prog add: (inst: i #[]) } else: { error: "operator " . (expr op) . " is not supported" } } _funHandlers <- dict hash _funHandlers set: "if:else" :args { compileExpr: (args value) 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 } 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 } prog setLabel: elabel } _funHandlers set: "isInteger?" :args { compileExpr: (args value) prog add: (inst: "ATOM" #[]) } _funHandlers set: "value" :args { compileExpr: (args value) prog add: (inst: "CAR" #[]) } _funHandlers set: "tail" :args { compileExpr: (args value) prog add: (inst: "CDR" #[]) } _exprHandlers set: (ast call) :expr { tc <- (expr tocall) if: (tc nodeType) = (ast sym) { _funHandlers ifget: (tc name) :handler { handler: (expr args) } else: { error: "function calls not implemented yet" } } else: { error: "call expression to value not implemented yet - " . tc } } #{ compile <- :code { res <- parser top: code if: res { outer <- res yield main_fun <- false others <- dict hash foreach: (outer messages) :idx msg { if: ((msg to) name) = "main" { main_fun <- msg assign } else: { others set: ((msg to) name) (msg assign) } } foreach: (main_fun expressions) :idx expr { compileExpr: expr } foreach: others :name fun { prog setLabel: name foreach: (fun expressions) :idx expr { compileExpr: expr } } 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" } } } }