Skip to content

Commit 624ddea

Browse files
author
Docker
committed
Savepoint
1 parent 74b8119 commit 624ddea

File tree

4 files changed

+352
-38
lines changed

4 files changed

+352
-38
lines changed

‎src/Expr.lama‎

Lines changed: 62 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -63,8 +63,69 @@ fun evalList (c, exprs) {
6363
esac
6464
}
6565

66+
fun unref (s, v) {
67+
case v of
68+
Ref (x) -> s (x)
69+
| Val (n) -> n
70+
| _ -> failure ("Unexpected value: %s\n", v.string)
71+
esac
72+
}
73+
74+
fun ref (v) {
75+
case v of
76+
Ref (x) -> x
77+
| _ -> failure ("Expected reference, got: %s\n", v.string)
78+
esac
79+
}
80+
6681
fun eval (c@[s, w], expr) {
67-
failure ("evalExpr not implemented\n")
82+
case expr of
83+
Skip -> [c, None]
84+
| Read (Ref (x)) ->
85+
let [v, w] = w.readWorld in
86+
let nc = [s <- [x, v], w] in
87+
[nc, None]
88+
| Write (e) ->
89+
let [[s, w], v] = eval (c, e) in
90+
let nc = [s, writeWorld (s.unref (v), w)] in
91+
[nc, None]
92+
| Binop (op, e1, e2) ->
93+
let [nc, v1] = eval (c, e1) in
94+
let [nc, v2] = eval (nc, e2) in
95+
let res = evalOp (op, s.unref (v1), s.unref (v2)) in
96+
[nc, Val (res)]
97+
| Seq (e1, e2) ->
98+
let [nc, _] = eval (c, e1) in eval (nc, e2)
99+
| Ignore (e) ->
100+
let [nc, _] = eval (c, e) in [nc, None]
101+
| Assn (l, r) ->
102+
let [nc, lv] = eval (c, l) in
103+
let [[s, w], rv] = eval (nc, r) in
104+
let rv = s.unref (rv) in
105+
let nc = [s <- [lv.ref, rv], w] in
106+
[nc, Val (rv)]
107+
| Ref (x) -> [c, Ref (x)]
108+
| Var (x) -> [c, Val (s (x))]
109+
| Const (n) -> [c, Val (n)]
110+
| If (cnd, t, e) ->
111+
let [nc, v] = eval (c, cnd) in
112+
if s.unref (v) == 0
113+
then eval (nc, e)
114+
else eval (nc, t)
115+
fi
116+
| While (cnd, b) ->
117+
while let [[s, w], v] = eval (c, cnd) in
118+
c := [s, w]; s.unref (v) != 0 do
119+
let [nc, _] = eval (c, b) in c := nc
120+
od;
121+
[c, None]
122+
| DoWhile (b, cnd) ->
123+
do let [nc, _] = eval (c, b) in c := nc
124+
while let [[s, w], v] = eval (c, cnd) in
125+
c := [s, w]; s.unref (v) != 0
126+
od; [c, None]
127+
| _ -> failure ("Unknown expression %s\n", expr.string)
128+
esac
68129
}
69130

70131

‎src/Parser.lama‎

Lines changed: 75 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -37,46 +37,92 @@ fun assertVoid (atr, v, loc) {
3737
esac
3838
}
3939

40+
fun wrapVar (atr, x, loc) {
41+
case atr of
42+
Ref -> Ref (x)
43+
| Void -> Ignore (Var (x))
44+
| _ -> Var (x)
45+
esac
46+
}
47+
4048
-- A parser of "something" in brackets; l, r are left and right
4149
-- brackets as parsers, p --- a parser of "something"
4250
fun inbr (l, p, r) {
4351
syntax (-l p -r)
4452
}
4553

4654
fun binop (op) {
47-
[syntax (pos -s[op]), fun (l, loc, r) {
48-
fun (a) {
49-
assertValue (a, Binop (op, l (Val), r (Val)), loc)
50-
}
51-
}
55+
[syntax (pos -s[op]),
56+
fun (l, loc, r) {
57+
fun (a) {
58+
assertValue (a, Binop (op, l (Val), r (Val)), loc)
59+
}
60+
}
5261
]
5362
}
5463

5564
var primary = memo $ eta syntax (
56-
-- decimal constant
57-
loc=pos x=decimal {fun (a) {assertValue (a, Const (stringInt (x)), loc)}} |
58-
59-
-- identifier
60-
x=lident {fun (a) {
61-
case a of
62-
Ref -> Ref (x)
63-
| Void -> Ignore (Var (x))
64-
| _ -> Var (x)
65-
esac
66-
}} |
67-
$(failure ("the rest of primary parsing in not implemented\n"))),
68-
basic = memo $ eta (expr ({[Right, {[s (":="),
69-
fun (l, loc, r) {
70-
fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)}
71-
}]}],
72-
[Left , map (binop, {"!!"})],
73-
[Left , map (binop, {"&&"})],
74-
[Nona , map (binop, {"==", "!=", "<", ">", "<=", ">="})],
75-
[Left , map (binop, {"+", "-"})],
76-
[Left , map (binop, {"*", "/", "%"})]
77-
},
78-
primary)),
79-
exp = memo $ eta syntax (basic | s1=basic s[";"] s2=exp {fun (a) {Seq (s1 (Void), s2 (a))}});
65+
-- decimal constant
66+
loc=pos x=decimal {fun (a) {
67+
assertValue (a, Const (stringInt (x)), loc)
68+
}} |
69+
-- identifier
70+
loc=pos x=lident {fun (a) {
71+
wrapVar (a, x, loc)
72+
}} |
73+
loc=pos kRead x=inbr[s("("), exp, s(")")] {fun(a) {
74+
assertVoid (a, Read (x (Ref)), loc)
75+
}} |
76+
loc=pos kWrite e=inbr[s("("), exp, s(")")] {fun(a) {
77+
assertVoid (a, Write (e (Val)), loc)
78+
}} |
79+
loc=pos kSkip {fun(a) {
80+
assertVoid (a, Skip, loc)
81+
}} |
82+
loc=pos kIf c=exp kThen t=exp e=elsePart {fun(a) {
83+
If (c (Val), t (a), e (a))
84+
}} |
85+
loc=pos kWhile c=exp kDo b=exp kOd {fun(a) {
86+
assertVoid (a, While (c (Val), b (Void)), loc)
87+
}} |
88+
loc=pos kDo b=exp kWhile c=exp kOd {fun(a) {
89+
assertVoid (a, DoWhile (b (Void), c (Val)), loc)
90+
}} |
91+
loc=pos kFor i=exp s[","] c=exp s[","] u=exp kDo b=exp kOd {fun(a) {
92+
let init = i (Void) in
93+
let cond = c (Val) in
94+
let update = u (Void) in
95+
let body = b (Void) in
96+
let code = Seq (init, While (cond, Seq (body, update))) in
97+
assertVoid (a, code, loc)
98+
}} |
99+
inbr [s("("), exp, s(")")]
100+
),
101+
elsePart = memo $ eta syntax (
102+
kElse e=exp kFi {e} |
103+
kElif c=exp kThen t=exp e=elsePart {fun (a) {
104+
If (c (Val), t (a), e (a))
105+
}} |
106+
kFi {fun (a) {assertVoid (a, Skip, loc)}}
107+
),
108+
basic = memo $ eta (expr ({
109+
[Right, {
110+
[s (":="),
111+
fun (l, loc, r) {
112+
fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)}
113+
}]}],
114+
[Left , map (binop, {"!!"})],
115+
[Left , map (binop, {"&&"})],
116+
[Nona , map (binop, {"==", "!=", "<", ">", "<=", ">="})],
117+
[Left , map (binop, {"+", "-"})],
118+
[Left , map (binop, {"*", "/", "%"})]
119+
},
120+
primary)),
121+
exp = memo $ eta syntax (
122+
basic | s1=basic s[";"] s2=exp {fun (a) {
123+
Seq (s1 (Void), s2 (a))
124+
}}
125+
);
80126

81127
-- Public top-level parser
82128
public parse = syntax (s=exp {s (Void)});

‎src/SM.lama‎

Lines changed: 121 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -60,9 +60,63 @@ fun fromLabel (env, lab) {
6060
-- Stack machine interpreter. Takes an environment, an SM-configuration and a program,
6161
-- returns a final configuration
6262
fun eval (env, c, insns) {
63-
failure ("SM eval not implemented\n")
63+
let impl = fix (fun (rec) {
64+
fun ([c, insns]) {
65+
case insns of
66+
{} -> c
67+
| i : tl ->
68+
let [c, next] = evalInsn (c, i) in
69+
let insnsNext = case next of
70+
Some (label) -> fromLabel (env, label)
71+
| _ -> tl
72+
esac in rec ([c, insnsNext])
73+
esac
74+
}
75+
}) in impl ([c, insns])
6476
}
6577

78+
fun evalInsn (c@[stack, state, world], insn) {
79+
fun noJmp (c) {
80+
[c, None]
81+
}
82+
83+
fun jmp (c, label) {
84+
[c, Some (label)]
85+
}
86+
87+
case insn of
88+
READ -> let [v, w] = world.readWorld in
89+
[v : stack, state, w].noJmp
90+
| WRITE -> let v : rest = stack in
91+
[rest, state, v.writeWorld(world)].noJmp
92+
| BINOP(s) -> let r : rest = stack in
93+
let l : rest = rest in
94+
let v = evalOp(s, l, r) in
95+
[v : rest, state, world].noJmp
96+
| LD(x) -> let v = x.state in
97+
[v : stack, state, world].noJmp
98+
| LDA(x) -> [Ref (x) : stack, state, world].noJmp
99+
| ST(x) -> let v : _ = stack in
100+
[stack, state <- [x, v], world].noJmp
101+
| STI -> let v : Ref(x) : rest = stack in
102+
[v : rest, state <- [x, v], world].noJmp
103+
| CONST(n) -> [n : stack, state, world].noJmp
104+
| LABEL(l) -> c.noJmp
105+
| JMP(l) -> c.jmp (l)
106+
| CJMP(cnd, l) ->
107+
let v : rest = stack in
108+
let nc = [rest, state, world] in
109+
case cnd of
110+
"z" -> if v == 0 then nc.jmp (l) else nc.noJmp fi
111+
| "nz" -> if v != 0 then nc.jmp (l) else nc.noJmp fi
112+
| _ -> failure ("Unknown condition %s\n", cnd.string)
113+
esac
114+
| DROP -> let _ : rest = stack in [rest, state, world].noJmp
115+
| _ -> failure ("Unknown instruction %s\n", insn.string)
116+
esac
117+
}
118+
119+
66120
-- Runs a stack machine for a given input and a given program, returns an output
67121
public fun evalSM (input, insns) {
68122
eval (initEvalEnv (insns), [{}, emptyState, createWorld (input)], insns)[2].getOutput
@@ -111,11 +165,72 @@ public fun compileSM (stmt) {
111165

112166
fun compile (lab, env, stmt) {
113167
case stmt of
114-
Skip -> [false, env, emptyBuffer ()]
115-
| Var (x) -> [false, env, singletonBuffer (LD (x))]
116-
| Ref (x) -> [false, env, singletonBuffer (LDA (x))]
117-
| Const (n) -> [false, env, singletonBuffer (CONST (n))]
118-
| _ -> failure ("compileSM not implemented\n")
168+
Skip -> [false, env, emptyBuffer ()]
169+
| Var (x) -> [false, env, singletonBuffer (LD (x))]
170+
| Ref (x) -> [false, env, singletonBuffer (LDA (x))]
171+
| Const (n) -> [false, env, singletonBuffer (CONST (n))]
172+
| Seq (s1, s2) ->
173+
let [s2Lab, env] = env.genLabel in
174+
let [s2LabUsed, env, s1Code] = compile (s2Lab, env, s1) in
175+
let [labUsed, env, s2Code] = compile (lab, env, s2) in
176+
[labUsed, env, s1Code <+> label (s2Lab, s2LabUsed) <+> s2Code]
177+
| If (c, t, e) ->
178+
let [cLab, env] = env.genLabel in
179+
let [cLabUsed, env, cCode] = compile (cLab, env, c) in
180+
let [_, env, tCode] = compile (lab, env, t) in
181+
let [_, env, eCode] = compile (lab, env, e) in
182+
let [eLab, env] = env.genLabel in
183+
let code = cCode <+> label (cLab, cLabUsed) <+
184+
CJMP("z", eLab) <+> tCode <+ JMP (lab) <+
185+
LABEL (eLab) <+> eCode in
186+
[true, env, code]
187+
| While (c, b) ->
188+
let [cLab, sLab, env] = env.genLabels (2) in
189+
let [cLabUsed, env, cCode] = compile (cLab, env, c) in
190+
let [_, env, bCode] = compile (sLab, env, b) in
191+
let code = singletonBuffer (LABEL (sLab)) <+> cCode <+>
192+
label (cLab, cLabUsed) <+ CJMP("z", lab) <+>
193+
bCode <+ JMP (sLab) in
194+
[true, env, code]
195+
| DoWhile (b, c) ->
196+
let [cLab, sLab, eLab, env] = env.genLabels (3) in
197+
let [eLabUsed, env, cCode] = compile (eLab, env, c) in
198+
let [cLabUsed, env, bCode ] = compile (cLab, env, b) in
199+
let code = singletonBuffer (LABEL (sLab)) <+> bCode <+>
200+
label (cLab, cLabUsed) <+> cCode <+>
201+
label (eLab, eLabUsed) <+ CJMP("nz", sLab) in
202+
[false, env, code]
203+
| Read (e) ->
204+
let [eLab, env] = env.genLabel in
205+
let [eLabUsed, env, eCode] = compile (eLab, env, e) in
206+
let code = eCode <+> label (eLab, eLabUsed) <+ READ <+ STI <+ DROP in
207+
[false, env, code]
208+
| Write (e) ->
209+
let [eLab, env] = env.genLabel in
210+
let [eLabUsed, env, eCode] = compile (eLab, env, e) in
211+
let code = eCode <+> label (eLab, eLabUsed) <+ WRITE in
212+
[false, env, code]
213+
| Ignore (e) ->
214+
let [eLab, env] = env.genLabel in
215+
let [eLabUsed, env, eCode] = compile (eLab, env, e) in
216+
[false, env, eCode <+> label (eLab, eLabUsed) <+ DROP]
217+
| Assn (l, r) ->
218+
let [lLab, rLab, env] = env.genLabels (2) in
219+
let [rLabUsed, env, rCode] = compile (rLab, env, r) in
220+
let [lLabUsed, env, lCode] = compile (lLab, env, l) in
221+
let code = lCode <+> label (lLab, lLabUsed) <+>
222+
rCode <+> label (rLab, rLabUsed) <+
223+
STI in
224+
[false, env, code]
225+
| Binop (op, l, r) ->
226+
let [lLab, rLab, env] = env.genLabels (2) in
227+
let [rLabUsed, env, rCode] = compile (rLab, env, r) in
228+
let [lLabUsed, env, lCode] = compile (lLab, env, l) in
229+
let code = lCode <+> label (lLab, lLabUsed) <+>
230+
rCode <+> label (rLab, rLabUsed) <+
231+
BINOP (op) in
232+
[false, env, code]
233+
| _ -> failure ("Unexpected expression %s\n", stmt.string)
119234
esac
120235
}
121236

0 commit comments

Comments
 (0)