[ITMO] T06 Kudryavtsev Alexander

src/Expr.lama

@@ -52,29 +52,15 @@ public fun evalOp (op, l, r) {
 --        Call    (string, expr list)  |
 --        Ignore  (expr)
 
--- Helper function: checks that given name designates a regular variable in
--- a given state
-fun checkVar (state, name) {
-  case state.lookup (name) of
-    Var (_) -> skip
-  | _       -> error (sprintf ("the name ""%s"" does not designate a variable", name), getLoc (name))
-  esac
-}
-
--- Helper function: checks that given name designates a function in
--- a given state
-fun checkFun (state, name) {
-  case state.lookup (name) of
-    Fun (_, _) -> skip
-  | _          -> error (sprintf ("the name ""%s"" does not designate a function", name), getLoc (name))
-  esac
-}
-
 -- Helper function: adds a bunch of regular variables current scope
 fun addNames (state, names) {
   foldl (fun (s, name) {s.addName (name, Var (0))}, state, names)
 }
 
+fun addNamesValues (state, names, values) {
+  foldl (fun (s, [name, value]) { s.addName(name, value) }, state, zip(names, values))
+}
+
 -- Helper function: adds a function in current scope
 fun addFunction (state, name, args, body) {
   state.addName (name, Fun (args, body))
@@ -94,11 +80,118 @@ fun evalList (c, exprs) {
   esac
 }
 
-(* Assignment *)
+fun evalRef(c, expr) {
+  let [c, out] = eval(c, expr) in
+  case out of
+    Ref(x) -> [c, x]
+  | _ -> failure("Expected ref, got %s", out.string)
+  esac
+}
+
+fun evalVal(c, expr) {
+  let [c, out] = eval(c, expr) in
+  case out of
+    Val(x) -> [c, x]
+  | _ -> failure("Expected val, got %s", out.string)
+  esac
+}
+
+fun evalFun(c, expr) {
+  let [c, out] = eval(c, expr) in
+  case out of
+    Fun(u, f) -> [c, [u, f]]
+  | _ -> failure("Expected fun, got %s", out.string)
+  esac
+}
+
+fun evalObject(c, expr) {
+  let [c, out] = eval(c, expr) in
+  case out of
+    Val(x) -> [c, out]
+  | Fun(f) -> [c, out]
+  | _ -> failure("Expected obj, got %s", out.string)
+  esac
+}
+
+fun evalVoid(c, expr) {
+  let [c, out] = eval(c, expr) in
+  case out of
+    None -> [c, out]
+  | _ -> failure("Expected void, got %s", out.string)
+  esac
+}
+
 fun eval (c@[s, w], expr) {
-  failure ("evalExpr not implemented\n")
+  case expr of
+      Assn(to, from) ->
+        let [c, ref] = evalRef(c, to) in
+        let [[s, w], output] = evalObject(c, from) in
+        [[s <- [ref, output], w], output]
+    | Seq(fst, snd) ->
+        let [c, out] = evalVoid(c, fst) in eval(c, snd)
+    | Skip -> [c, None]
+    | Read(name) ->
+        let [out, w] = readWorld(w) in [[s <- [name, Val(out)], w], None]
+    | Write(expr) ->
+        let [[s, w], out] = evalVal(c, expr) in [[s, writeWorld(out, w)], None]
+    | If(cond, tru, fls) ->
+        let [c, check] = evalVal(c, cond) in
+        if check then eval(c, tru) else eval(c, fls) fi
+    | While(cond, code) -> (
+        var continue, temp;
+        temp := evalVal(c, cond); c := temp[0]; continue := temp[1];
+        while continue do
+          temp := evalVoid(c, code); c := temp[0];
+          temp := evalVal(c, cond); c := temp[0]; continue := temp[1]
+        od;
+        [c, None]
+      )
+    | DoWhile(cond, code) -> (
+        var continue = true, temp;
+        while continue do
+          temp := evalVoid(c, code); c := temp[0];
+          temp := evalVal(c, cond); c := temp[0]; continue := temp[1]
+        od;
+        [c, None]
+      )
+    | Var(name) -> [c, s.lookup(name)]
+    | Ref(name) -> [c, Ref(name)]
+    | Const(x) -> [c, Val(x)]
+    | Binop(op, left, right) ->
+      let [c, leftV] = evalVal(c, left) in
+      let [c, rightV] = evalVal(c, right) in
+      [c, Val(evalOp(op, leftV, rightV))]
+    | Ignore(expr) -> let [c, dropped] = eval(c, expr) in [c, None]
+    | Scope(decls, stmt) ->
+      let s = s.enterScope in
+      let c = evalDecls([s, w], decls) in
+      let [[s, w], x] = eval(c, stmt) in
+      let s = s.leaveScope in
+      [[s, w], x]
+    | Call(nm, args) ->
+      let [c, [argdefs, code]] = evalFun(c, Var(nm)) in
+      let [[s, w], xs] = c.evalList(args) in
+      let s1 = s in
+      let s = s.enterFunction in
+      let s = s.addNamesValues(argdefs, xs) in
+      let [[s, w], rv] = eval([s, w], code) in
+      let s = s1.leaveFunction(s.getGlobal) in
+      [[s, w], rv]
+    | _ -> failure("Unknown instruction: %s", expr.string)
+  esac
+}
+
+fun evalDecls(c, exprs) {
+  fun oneDecl(c@[s, w], expr) {
+    case expr of
+        Var(xs) -> let s = s.addNames(xs) in [s, w]
+      | Fun(nm, args, code) -> let s = s.addFunction(nm, args, code) in [s, w]
+      | _ -> failure("Unknown declaration: %s", expr.string)
+    esac
+  }
+
+  foldl(oneDecl, c, exprs)
 }
-(* End *)
 
 -- Evaluates a program with a given input and returns an output
 public fun evalExpr (input, expr) {

src/Parser.lama

@@ -57,6 +57,20 @@ fun binop (op) {
   ]
 }
 
+fun mkElifs(kind, elseBr, elifs) {
+   case elifs of
+     [] -> elseBr
+   | {} -> elseBr
+   | x:xs -> If(x[0](Val), x[1](kind), mkElifs(kind, elseBr, xs))
+   esac
+}
+fun getOrSkip(x, kind) {
+   case x of
+     None -> Skip
+   | Some(x) -> x(kind)
+   esac
+}
+
 -- Helper parser: parses a (possible empty) list of items separated by ","
 fun list0 (item) {
   list0By (item, s(","))
@@ -107,7 +121,8 @@ fun distributeScope (expr, exprConstructor) {
 
 var primary    = memo $ eta syntax (
                                       -- decimal constant
-                                      loc=pos x=decimal                                 {fun (a) {assertValue (a, Const (stringInt (x)), loc)}}     |
+                                      loc=pos x=decimal
+                                    {fun (a) { assertValue (a, Const (stringInt (x)), loc) }} |
 
                                       -- identifier
                                       loc=pos x=lident args=inbr[s("("), list0(syntax(e=exp {e(Val)})), s(")")]? {fun (a) {
@@ -121,7 +136,22 @@ var primary    = memo $ eta syntax (
                                                                                                                    esac
                                                                                                                 }} |
 (* Assignment *)
-                                      $(failure ("the rest of primary parsing in not implemented\n"))),
+
+                                  loc=pos kRead e=inbr[s("("), lident, s(")")]
+                                    {fun(a) { assertVoid(a, Read(e), loc) }} |
+                                  loc=pos kWrite e=inbr[s("("), scopeExpr, s(")")]
+                                    {fun(a) { assertVoid(a, Write(e(Val)), loc)}} |
+                                  kIf e=scopeExpr kThen tru=scopeExpr elifs=(-kElif scopeExpr -kThen scopeExpr)* fls=(-kElse scopeExpr)? kFi
+                                    {fun(a) { distributeScope(e(Val), fun(x) { If(x, tru(a), mkElifs(a, getOrSkip(fls, a), elifs))}) }} |
+                                  loc=pos kWhile e=scopeExpr kDo c=scopeExpr kOd
+                                    {fun(a) { assertVoid(a, While(e(Val), c(Void)), loc) }} |
+                                  loc=pos kDo c=scopeExpr kWhile e=scopeExpr kOd
+                                    {fun(a) { distributeScope(c(Void), fun(x) { assertVoid(a, DoWhile(e(Val), x), loc) }) }} |
+                                  loc=pos kSkip {fun(a) { assertVoid(a, Skip, loc) }} |
+                                  kFor ini=scopeExpr s[","] cond=scopeExpr s[","] act=scopeExpr kDo c=scopeExpr kOd
+                                    {fun(a) { distributeScope(ini(Void), fun(x) { Seq(x, While(cond(Val), Seq(c(Void), act(Void)))) }) } } |
+                                  e=inbr[s("("), scopeExpr, s(")")]
+                                  ),
 (* End *)
       basic      = memo $ eta (expr ({[Right, {[s (":="),
                                                 fun (l, loc, r) {

src/SM.lama

@@ -72,6 +72,44 @@ fun fromLabel (env, lab) {
   env [0] (lab)
 }
 
+
+fun pushS (c, value) {
+   c[0] := value : c[0]
+}
+fun popS (c) {
+   case c[0] of
+     {}    -> failure("empty stack")
+   | x: xs -> case x of
+                #val -> (
+                 c[0] := xs;
+                 x
+                )
+              | _ -> failure("Expected a value on stack, got %s", x.string)
+              esac
+   esac
+}
+fun topS (c) {
+   case c[0] of
+     {}    -> failure("empty stack")
+   | x: xs -> case x of
+                #val -> x
+              | _ -> failure("Expected a value on stack, got %s", x.string)
+              esac
+   esac
+}
+fun popRefS (c) {
+   case c[0] of
+     {}    -> failure("empty stack")
+   | x: xs -> case x of
+                #str -> (
+                 c[0] := xs;
+                 x
+                )
+              | _ -> failure("Expected a reference on stack, got %s", x.string)
+              esac
+   esac
+}
+
 -- Stack machine interpreter. Takes an environment, a world and a program,
 -- returns a final output
 fun eval (env, w, insns) {
@@ -119,7 +157,60 @@ fun eval (env, w, insns) {
   -- Core interpreter: takes a configuration and a program, returns a configuration
   (* Assignment *)
   fun eval (c@[st, cst, s, w], insns) {
-    failure ("SM interpreter is not implemented\n")
+
+   fun run(c, insn) {
+      var tgt = None;
+      case insn of
+         READ     -> (
+                        var value = readWorld(c[2]);
+
+                        c[2] := value[1];
+                        pushS(c, value[0])
+                     )
+      | WRITE    -> (c[2] := writeWorld(popS(c), c[2]))
+      | BINOP(s) -> pushS(c, evalOp(s, popS(c), popS(c)))
+      | LD(x)    -> pushS(c, c[1](x))
+      | LDA(x)   -> pushS(c, x)
+      | ST(x)    -> (c[1] := c[1] <- [x, topS(c)])
+      | STI      -> (
+        var value = popS(c);
+        var ref = popRefS(c);
+        c[1] := c[1] <- [ref, value];
+        pushS(c, value)
+      )
+      | CONST(n) -> pushS(c, n)
+      | LABEL(s) -> skip
+      | JMP(l)   -> (tgt := Some(l))
+      | CJMP(j, l) -> (
+         var value = popS(c);
+         case j of
+           "z"  -> if value == 0 then tgt := Some(l) else 0 fi
+         | "nz" -> if value == 0 then 0 else tgt := Some(l) fi
+         esac
+      )
+      | DUP     -> pushS(c, topS(c))
+      | DROP    -> popS(c)
+      esac;
+      -- printf("Exec %s, ended up with %s\n", insn.string, c.string);
+      [c, tgt]
+   }
+
+  fun evalInsns(c, insns) {
+   case insns of
+        [] -> c
+      | {} -> c
+      | x:xs -> (
+        let [c, tgt] = run(c, x) in
+        case tgt of
+          None -> evalInsns(c, xs)
+        | Some(x) -> evalInsns(c, env.fromLabel(x))
+        esac
+      )
+   esac
+  }
+
+  -- printf("%s\n", insns.string); c
+  evalInsns(c, insns)
   }
   (* End *)
 
@@ -362,10 +453,48 @@ public fun compileSM (stmt) {
   fun compile (lab, env, stmt) {
     case stmt of
       Skip              -> [false, env, emptyBuffer ()]
-    | Var    (x)        -> [false, env, singletonBuffer (LD (x))]
-    | Ref    (x)        -> [false, env, singletonBuffer (LDA (x))]
-    | Const  (n)        -> [false, env, singletonBuffer (CONST (n))]
-    | _                 ->  failure ("compileSM not implemented\n")
+    | Var   (x)         -> [false, env, singletonBuffer (LD (x))]
+    | Ref   (x)         -> [false, env, singletonBuffer (LDA (x))]
+    | Const (n)         -> [false, env, singletonBuffer (CONST (n))]
+    | Read  (x)         -> [false, env, singletonBuffer (READ) <+ ST(x) <+ DROP]
+    | Write (e)         -> let [labUsed, env, buf] = compile(lab, env, e) in [false, env, buf <+> label(lab, labUsed) <+ WRITE]
+    | Assn  (Ref(x), f) -> let [labUsed, env, buf] = compile(lab, env, f) in [false, env, buf <+> label(lab, labUsed) <+ ST(x)]
+    | Assn  (x, f)      -> let [lab2, env] = env.genLabel in
+                           let [labUsed, env, buf] = compile(lab, env, f) in
+                           let [lab2Used, env, buf2] = compile(lab2, env, x) in
+                           [false, env, buf2 <+> label(lab2, lab2Used) <+> buf <+> label(lab, labUsed) <+ STI]
+    | Binop (op, l, r)  -> let [lab2, env] = env.genLabel in
+                           let [labUsed, env, buf] = compile(lab, env, l) in
+                           let [lab2Used, env, buf2] = compile(lab2, env, r) in
+                           [false, env, buf2 <+> label(lab2, lab2Used) <+> buf <+> label(lab, labUsed) <+ BINOP(op)]
+    | Ignore(e)         -> let [labUsed, env, buf] = compile(lab, env, e) in [false, env, buf <+> label(lab, labUsed) <+ DROP]
+    | Seq   (l, r)      -> let [lab2, env] = env.genLabel in
+                           let [labUsed, env, buf] = compile(lab, env, r) in
+                           let [lab2Used, env, buf2] = compile(lab2, env, l) in
+                           [labUsed, env, buf2 <+> label(lab2, lab2Used) <+> buf]
+    | While(cond, code) ->
+      let [checkLab, env] = env.genLabel in
+      let [startLab, env] = env.genLabel in
+      let [_, env, codeIn] = compile(checkLab, env, code) in
+      let [labUsed, env, codeCond] = compile(lab, env, cond) in
+      [false, env, singletonBuffer(JMP(checkLab)) <+ LABEL(startLab) <+> codeIn <+ LABEL(checkLab) <+>
+        codeCond <+> label(lab, labUsed) <+ CJMP("nz", startLab)]
+    | DoWhile(cond, code) ->
+      let [checkLab, env] = env.genLabel in
+      let [startLab, env] = env.genLabel in
+      let [checkLabUsed, env, codeIn] = compile(checkLab, env, code) in
+      let [labUsed, env, codeCond] = compile(lab, env, cond) in
+      [false, env, emptyBuffer()                  <+ LABEL(startLab) <+> codeIn <+> label(checkLab, checkLabUsed) <+>
+        codeCond <+> label(lab, labUsed) <+ CJMP("nz", startLab)]
+    | If(cond, tru, fls) ->
+      let [truLab, env] = env.genLabel in
+      let [condLab, env] = env.genLabel in
+      let [_, env, codeFls] = compile(lab, env, fls) in
+      let [_, env, codeTru] = compile(lab, env, tru) in
+      let [labUsed, env, codeCond] = compile(condLab, env, cond) in
+      [true, env, codeCond <+> label(condLab, labUsed) <+ CJMP("nz", truLab) <+> codeFls <+ JMP(lab) <+
+        LABEL(truLab) <+> codeTru]  -- LABEL(lab) auto inserted
+    | _                 -> failure ("compileSM not implemented on %s\n", stmt.string)
     esac
   }