aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/target/jvm/program/condition.lux
blob: 5769efc79b70935a95a558f653cbafe35d70691b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
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)))