(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
(data text/format)
[macro "macro/" Monad])
(luxc ["_" lang]
(lang [".L" host]
(host ["$" jvm]
(jvm ["$t" type]
["$i" inst]))
["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 {message Text})
message)
(def: (translate-path' translate 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 macro.Monad
[bodyI (translate bodyS)]
(wrap (|>> (pop-altI stack-depth)
bodyI
($i.GOTO @end))))
(^ [_ (#.Form (list [_ (#.Text "lux case pop")]))])
(macro/wrap popI)
(^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))])
(macro/wrap (|>> peekI
($i.ASTORE register)))
[_ (#.Bit value)]
(macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)]
(|>> peekI
($i.unwrap #$.Boolean)
(jumpI @else))))
[_ (#.Int value)]
(macro/wrap (|>> peekI
($i.unwrap #$.Long)
($i.long value)
$i.LCMP
($i.IFNE @else)))
[_ (#.Frac value)]
(macro/wrap (|>> peekI
($i.unwrap #$.Double)
($i.double value)
$i.DCMPL
($i.IFNE @else)))
[_ (#.Text value)]
(macro/wrap (|>> peekI
($i.string value)
($i.INVOKEVIRTUAL "java.lang.Object"
"equals"
($t.method (list $Object)
(#.Some $t.boolean)
(list))
false)
($i.IFEQ @else)))
(^template [ ]
(^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))])
(macro/wrap (case idx
+0
(|>> peekI
($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
($i.int 0)
$i.AALOAD
pushI)
_
(|>> peekI
($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
($i.int (.int idx))
($i.INVOKESTATIC hostL.runtime-class
($t.method (list //runtime.$Tuple $t.int)
(#.Some $Object)
(list))
false)
pushI))))
(["lux case tuple left" "pm_left"]
["lux case tuple right" "pm_right"])
(^template [ ]
(^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))])
(macro/wrap (<| $i.with-label (function (_ @success))
$i.with-label (function (_ @fail))
(|>> peekI
($i.CHECKCAST ($t.descriptor //runtime.$Variant))
($i.int (.int idx))
($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))))
(["lux case variant left" $i.NULL]
["lux case variant right" ($i.string "")])
(^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))])
(do macro.Monad
[leftI (translate-path' translate stack-depth @else @end leftP)
rightI (translate-path' translate stack-depth @else @end rightP)]
(wrap (|>> leftI
rightI)))
(^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))])
(do macro.Monad
[@alt-else $i.make-label
leftI (translate-path' translate (inc stack-depth) @alt-else @end leftP)
rightI (translate-path' translate stack-depth @else @end rightP)]
(wrap (|>> $i.DUP
leftI
($i.label @alt-else)
$i.POP
rightI)))
_
(_.throw Unrecognized-Path (%code path))))
(def: (translate-path translate path @end)
(-> (-> ls.Synthesis (Meta $.Inst))
ls.Path $.Label (Meta $.Inst))
(do macro.Monad
[@else $i.make-label
pathI (translate-path' translate +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 (translate-if testI thenI elseI)
(-> $.Inst $.Inst $.Inst $.Inst)
(<| $i.with-label (function (_ @else))
$i.with-label (function (_ @end))
(|>> testI
($i.unwrap #$.Boolean)
($i.IFEQ @else)
thenI
($i.GOTO @end)
($i.label @else)
elseI
($i.label @end))))
(def: #export (translate-case translate valueS path)
(-> (-> ls.Synthesis (Meta $.Inst))
ls.Synthesis ls.Path (Meta $.Inst))
(do macro.Monad
[@end $i.make-label
valueI (translate valueS)
pathI (translate-path translate path @end)]
(wrap (|>> valueI
$i.NULL
$i.SWAP
pushI
pathI
($i.label @end)))))
(def: #export (translate-let translate register inputS exprS)
(-> (-> ls.Synthesis (Meta $.Inst))
Nat ls.Synthesis ls.Synthesis (Meta $.Inst))
(do macro.Monad
[inputI (translate inputS)
exprI (translate exprS)]
(wrap (|>> inputI
($i.ASTORE register)
exprI))))