diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/case.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/case.jvm.lux | 225 |
1 files changed, 225 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux new file mode 100644 index 000000000..a9ea4482a --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -0,0 +1,225 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data text/format) + [meta "meta/" Monad<Meta>]) + (luxc ["_" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst])) + (lang ["ls" synthesis])) + [../runtime]) + +(def: $Object $;Type ($t;class "java.lang.Object" (list))) + +(def: (pop-altI stack-depth) + (-> Nat $;Inst) + (case stack-depth + +0 id + +1 $i;POP + +2 $i;POP2 + _ ## (n.> +2) + (|>. $i;POP2 + (pop-altI (n.- +2 stack-depth))))) + +(def: peekI + $;Inst + (|>. $i;DUP + ($i;INVOKESTATIC hostL;runtime-class + "pm_peek" + ($t;method (list ../runtime;$Stack) + (#;Some $Object) + (list)) + false))) + +(def: popI + $;Inst + (|>. ($i;INVOKESTATIC hostL;runtime-class + "pm_pop" + ($t;method (list ../runtime;$Stack) + (#;Some ../runtime;$Stack) + (list)) + false))) + +(def: pushI + $;Inst + (|>. ($i;INVOKESTATIC hostL;runtime-class + "pm_push" + ($t;method (list ../runtime;$Stack $Object) + (#;Some ../runtime;$Stack) + (list)) + false))) + +(exception: #export Unrecognized-Path) + +(def: (generate-path' generate stack-depth @else @end path) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat $;Label $;Label ls;Path (Meta $;Inst)) + (case path + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (do meta;Monad<Meta> + [bodyI (generate bodyS)] + (wrap (|>. (pop-altI stack-depth) + bodyI + ($i;GOTO @end)))) + + (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))]) + (meta/wrap popI) + + (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))]) + (meta/wrap (|>. peekI + ($i;ASTORE register) + popI)) + + [_ (#;Bool value)] + (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] + (|>. peekI + ($i;unwrap #$;Boolean) + (jumpI @else)))) + + (^template [<tag> <prep>] + [_ (<tag> value)] + (meta/wrap (|>. peekI + ($i;unwrap #$;Long) + ($i;long (|> value <prep>)) + $i;LCMP + ($i;IFNE @else)))) + ([#;Nat (:! Int)] + [#;Int (: Int)] + [#;Deg (:! Int)]) + + [_ (#;Frac value)] + (meta/wrap (|>. peekI + ($i;unwrap #$;Double) + ($i;double value) + $i;DCMPL + ($i;IFNE @else))) + + [_ (#;Text value)] + (meta/wrap (|>. peekI + ($i;string value) + ($i;INVOKEVIRTUAL "java.lang.Object" + "equals" + ($t;method (list $Object) + (#;Some $t;boolean) + (list)) + false) + ($i;IFEQ @else))) + + (^template [<special> <method>] + (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))]) + (do meta;Monad<Meta> + [subI (generate-path' generate stack-depth @else @end subP)] + (wrap (case idx + +0 + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int 0) + $i;AALOAD + pushI + subI) + + _ + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int (nat-to-int idx)) + ($i;INVOKESTATIC hostL;runtime-class + <method> + ($t;method (list ../runtime;$Tuple $t;int) + (#;Some $Object) + (list)) + false) + pushI + subI))))) + (["lux case tuple left" "pm_left"] + ["lux case tuple right" "pm_right"]) + + (^template [<special> <flag>] + (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))]) + (do meta;Monad<Meta> + [subI (generate-path' generate stack-depth @else @end subP)] + (wrap (<| $i;with-label (function [@success]) + $i;with-label (function [@fail]) + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) + ($i;int (nat-to-int idx)) + <flag> + ($i;INVOKESTATIC hostL;runtime-class "pm_variant" + ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) + (#;Some ../runtime;$Datum) + (list)) + false) + $i;DUP + ($i;IFNULL @fail) + ($i;GOTO @success) + ($i;label @fail) + $i;POP + ($i;GOTO @else) + ($i;label @success) + pushI + subI))))) + (["lux case variant left" $i;NULL] + ["lux case variant right" ($i;string "")]) + + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))]) + (do meta;Monad<Meta> + [leftI (generate-path' generate stack-depth @else @end leftP) + rightI (generate-path' generate stack-depth @else @end rightP)] + (wrap (|>. leftI + rightI))) + + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))]) + (do meta;Monad<Meta> + [@alt-else $i;make-label + leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP) + rightI (generate-path' generate stack-depth @else @end rightP)] + (wrap (|>. $i;DUP + leftI + ($i;label @alt-else) + $i;POP + rightI))) + + _ + (_;throw Unrecognized-Path (%code path)))) + +(def: (generate-path generate path @end) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Path $;Label (Meta $;Inst)) + (do meta;Monad<Meta> + [@else $i;make-label + pathI (generate-path' generate +1 @else @end path)] + (wrap (|>. pathI + ($i;label @else) + $i;POP + ($i;INVOKESTATIC hostL;runtime-class + "pm_fail" + ($t;method (list) #;None (list)) + false) + $i;NULL + ($i;GOTO @end))))) + +(def: #export (generate-case generate valueS path) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Synthesis ls;Path (Meta $;Inst)) + (do meta;Monad<Meta> + [@end $i;make-label + valueI (generate valueS) + pathI (generate-path generate path @end)] + (wrap (|>. valueI + $i;NULL + $i;SWAP + pushI + pathI + ($i;label @end))))) + +(def: #export (generate-let generate register inputS exprS) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat ls;Synthesis ls;Synthesis (Meta $;Inst)) + (do meta;Monad<Meta> + [inputI (generate inputS) + exprI (generate exprS)] + (wrap (|>. inputI + ($i;ASTORE register) + exprI)))) |