diff options
Diffstat (limited to 'stdlib/source/lux/target/jvm/program/condition.lux')
-rw-r--r-- | stdlib/source/lux/target/jvm/program/condition.lux | 75 |
1 files changed, 75 insertions, 0 deletions
diff --git a/stdlib/source/lux/target/jvm/program/condition.lux b/stdlib/source/lux/target/jvm/program/condition.lux new file mode 100644 index 000000000..5769efc79 --- /dev/null +++ b/stdlib/source/lux/target/jvm/program/condition.lux @@ -0,0 +1,75 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)] + [monoid (#+ Monoid)]] + [control + ["." exception (#+ exception:)]] + [data + [number (#+ hex)] + ["." error (#+ Error)] + ["." binary] + [text + ["%" format (#+ format)]] + [format + [".F" binary (#+ Mutation Specification)]]]] + ["." // #_ + ["#." resources (#+ Resources)] + ["/#" // #_ + [encoding + ["#." unsigned (#+ U1 U2)]]]]) + +(type: #export Environment + {#resources Resources + #stack U2}) + +(type: #export Condition + (-> Environment (Error Environment))) + +(structure: #export monoid + (Monoid Condition) + + (def: identity (|>> #error.Success)) + + (def: (compose left right) + (function (_ environment) + (do error.monad + [environment (left environment)] + (right environment))))) + +(def: #export (produces amount env) + (-> Nat Condition) + (let [stack (n/+ amount + (///unsigned.nat (get@ #stack env))) + max-stack (n/max stack + (///unsigned.nat (get@ [#resources #//resources.max-stack] env)))] + (|> env + (set@ #stack (///unsigned.u2 stack)) + (set@ [#resources #//resources.max-stack] (///unsigned.u2 max-stack)) + #error.Success))) + +(exception: #export (cannot-pop-stack {stack-size Nat} + {wanted-pops Nat}) + (exception.report + ["Stack Size" (%.nat stack-size)] + ["Wanted Pops" (%.nat wanted-pops)])) + +(def: #export (consumes wanted-pops env) + (-> Nat Condition) + (let [stack-size (///unsigned.nat (get@ #stack env))] + (if (n/<= stack-size wanted-pops) + (#error.Success (update@ #stack + (|>> ///unsigned.nat (n/- wanted-pops) ///unsigned.u2) + env)) + (exception.throw ..cannot-pop-stack [stack-size wanted-pops])))) + +(type: #export Local U1) + +(def: #export (has-local local environment) + (-> Local Condition) + (let [max-locals (n/max (///unsigned.nat (get@ [#resources #//resources.max-locals] environment)) + (///unsigned.nat local))] + (|> environment + (set@ [#resources #//resources.max-locals] + (///unsigned.u2 max-locals)) + #error.Success))) |