[ITMO] T07 Svetlana Antoshkina

src/Expr.lama

@@ -101,11 +101,63 @@ fun evalList (c, exprs) {
   esac
 }
 
-(* Assignment *)
-fun eval (c@[s, w], expr) {
-  failure ("evalExpr not implemented\n")
+fun evalDecls(c, exprs) {
+  fun evalDecl(c@[s, w], e) {
+    case e of
+        Var(x) -> let s = s.addNames(x) in [s, w]
+      | Fun(name, args, body) -> let s = s.addFunction(name, args, body) in [s, w]
+    esac
+  }
+
+  foldl(evalDecl, c, exprs)
+}
+
+fun evalArgs(s, args) {
+  fun evalArg(s, [name, Val (value)]) {
+    s.addName(name, value) 
+  }
+
+  foldl(evalArg, s, args)
 }
-(* End *)
+
+(* Assignment *)
+fun eval (c@[st, w], expr) {
+  case expr of
+    Assn (expr1, expr2) -> let [c@[st, w], {Ref (x), Val (v)}] = evalList(c, {expr1, expr2}) in [[st <- [x, v], w], Val (v)]
+    | Seq (expr1, expr2) -> let [c1, v] = eval(c, expr1) in eval(c1, expr2)
+    | Skip -> [c, Void]
+    | Read (x) -> let [r, w] = readWorld(w) in [[st <- [x, r], w], Void]
+    | Write (e) -> let [c@[st1, w1], Val (v)] = eval(c, e) in [[st1, writeWorld(v, w1)], v]
+    | If (cond, expr1, expr2) -> let [c, Val (v)] = eval(c, cond) in if v then eval(c, expr1) else eval(c, expr2) fi
+    | While (cond, body) -> 
+      let [c1, Val (n)] = eval(c, cond) in 
+      if n != 0
+      then
+        let [c2, _] = eval(c1, body) in
+        eval(c2, While(cond, body))
+      else
+        [c1, 0]
+      fi
+    | DoWhile (cond, body) -> evalList(c, {body, While (cond, body)})
+    | Var (x) -> [c, Val (st.lookup(x))]
+    | Ref (x) -> [c, Ref (x)]
+    | Const (n) -> [c, Val (n)]
+    | Binop (op, expr1, expr2) -> let [c, {Val (l), Val (r)}] = evalList(c, {expr1, expr2}) in [c, Val (evalOp(op, l, r))]
+    | Ignore (expr1) -> let [c, v] = eval(c, expr1) in [c, Void]
+    | Scope (decl, stmt) -> 
+      let st = st.enterScope in
+      let c@[st, w] = evalDecls([st, w], decl) in
+      let [[st, w], x] = eval(c, stmt) in
+      [[st.leaveScope, w], x]
+    | Call (name, args) -> 
+      let Fun (argNames, body) = st.lookup(name) in
+      let [c@[st, w], vs] = c.evalList(args) in
+      let stIn = st.enterFunction in
+      let stIn = evalArgs(stIn, zip(argNames, vs)) in
+      let [[stIn, w], v] = eval([stIn, w], body) in
+      [[st.leaveFunction(stIn.getGlobal), w], v]
+  esac
+}(* End *)
 
 -- Evaluates a program with a given input and returns an output
 public fun evalExpr (input, expr) {

src/Parser.lama

@@ -57,6 +57,12 @@ fun binop (op) {
   ]
 }
 
+--var elseStmt = memo $ eta syntax (
+--  kElif e=exp kThen s1=exp s2=elseStmt {fun (a) {If(e(Val), s1(a), s2(a))}} |
+--  kElse s2=exp kFi {fun (a) {s2(a)}} |
+--  kFi {fun (a) {assertVoid(a, Skip, loc)}}
+--);
+
 -- Helper parser: parses a (possible empty) list of items separated by ","
 fun list0 (item) {
   list0By (item, s(","))
@@ -106,35 +112,53 @@ fun distributeScope (expr, exprConstructor) {
 }
 
 var primary    = memo $ eta syntax (
-                                      -- decimal constant
-                                      loc=pos x=decimal                                 {fun (a) {assertValue (a, Const (stringInt (x)), loc)}}     |
-
-                                      -- identifier
-                                      x=lident args=inbr[s("("), list0(syntax(e=exp {e(Val)})), s(")")]? {fun (a) {
-                                                                                                            case args of
-                                                                                                              None -> case a of
-                                                                                                                        Ref  -> Ref (x)
-                                                                                                                      | Void -> Ignore (Var (x))
-                                                                                                                      | _    -> Var (x)
-                                                                                                                      esac
-                                                                                                            | Some (args) -> assertValue (a, Call (x, args))
-                                                                                                            esac
-                                                                                                         }} |
-(* Assignment *)
-                                      $(failure ("the rest of primary parsing in not implemented\n"))),
-(* End *)
-      basic      = memo $ eta (expr ({[Right, {[s (":="),
-                                                fun (l, loc, r) {
-                                                  fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)}
-                                                }]}],
-                                      [Left , map (binop, {"!!"})],
-                                      [Left , map (binop, {"&&"})],
-                                      [Nona , map (binop, {"==", "!=", "<", ">", "<=", ">="})],
-                                      [Left , map (binop, {"+", "-"})],
-                                      [Left , map (binop, {"*", "/", "%"})]
-                                     },
-                                     primary)),
-      scopeExpr  = memo $ eta syntax (ds=definition* e=exp? {fun (a) {fun (e) {
+      -- decimal constant
+      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) {
+          case args of
+            None -> case a of
+                      Ref  -> Ref (x)
+                    | Void -> Ignore (Var (x))
+                    | _    -> Var (x)
+                    esac
+          | Some (args) -> assertValue (a, Call (x, args), loc)
+          esac
+        }
+      } |
+      inbr[s("("), scopeExpr, s(")")] |
+      kSkip {fun (a) {assertVoid(a, Skip, loc)}} |
+      kRead x=inbr[s("("), lident, s(")")] {fun (a) {assertVoid(a, Read (x), loc)}} |
+      kWrite x=inbr[s("("), scopeExpr, s(")")] {fun (a) {assertVoid(a, Write (x(Val)), loc)}} |
+      loc=pos kIf e=scopeExpr kThen s1=scopeExpr s2=elseStmt {fun (a) {If(e(Val), s1(a), s2(a))}} |
+      loc=pos kThen {fun (a) {assertVoid(a, Skip, loc)}} |
+      loc=pos kWhile e=scopeExpr kDo s=scopeExpr kOd {fun (a) {assertVoid(a, While (e(Val), s(Void)), loc)}} |
+      loc=pos kDo s=scopeExpr kWhile e=scopeExpr kOd {fun (a) {
+        distributeScope(s(Void), fun(s) {assertVoid(a, DoWhile(e(Val), s), loc)})
+      }} |
+      loc=pos kFor s1=scopeExpr s[","] e=scopeExpr s[","] s2=scopeExpr kDo s=scopeExpr kOd {fun (a) {
+        distributeScope(s1(Void), fun (s1) {assertVoid(a, Seq(s1, While (e(Val), Seq(s(Void), s2(Void)))), loc)})
+      }}
+    ),
+    elseStmt = memo $ eta syntax (
+      kElif e=scopeExpr kThen s1=scopeExpr s2=elseStmt {fun (a) {If(e(Val), s1(a), s2(a))}} |
+      kElse s2=scopeExpr kFi {fun (a) {s2(a)}} |
+      kFi {fun (a) {assertVoid(a, Skip, loc)}}
+    ),
+    basic    = memo $ eta (expr ({[Right, {[s (":="),
+                                            fun (l, loc, r) {
+                                              fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)}
+                                            }]}],
+                                  [Left , map (binop, {"!!"})],
+                                  [Left , map (binop, {"&&"})],
+                                  [Nona , map (binop, {"==", "!=", "<", ">", "<=", ">="})],
+                                  [Left , map (binop, {"+", "-"})],
+                                  [Left , map (binop, {"*", "/", "%"})]
+                                 },
+                                 primary)),
+    scopeExpr  = memo $ eta syntax (ds=definition* e=exp? {fun (a) {fun (e) {
                                                                         case ds of
                                                                           {} -> e
                                                                         | _  -> expandScope (ds, e) 
@@ -144,14 +168,14 @@ var primary    = memo $ eta syntax (
                                                                          | _        -> Skip
                                                                          esac)
                                                                       }}),
-      definition = memo $ eta syntax (kVar ds=list[syntax (lident (s["="] e=basic {e (Val)})?)] s[";"] {Var (ds)} |
-                                      kFun name=lident
-                                           args=inbr[s("("), list0 (lident), s(")")]
-                                           body=inbr[s("{"), scopeExpr, s("}")] {
-                                           Fun (name, args, body (Weak))
-                                      }
-                                     ),                                    
-      exp        = memo $ eta syntax (basic | s1=basic s[";"] s2=exp {fun (a) {Seq (s1 (Void), s2 (a))}});
+    definition = memo $ eta syntax (kVar ds=list[syntax (lident (s["="] e=basic {e (Val)})?)] s[";"] {Var (ds)} |
+                                    kFun name=lident
+                                          args=inbr[s("("), list0 (lident), s(")")]
+                                          body=inbr[s("{"), scopeExpr, s("}")] {
+                                          Fun (name, args, body (Weak))
+                                    }
+                                    ),   
+    exp      = memo $ eta syntax (basic | s1=basic s[";"] s2=exp {fun (a) {Seq (s1 (Void), s2 (a))}});
 
 -- Public top-level parser
 public parse = syntax (s=scopeExpr {s (Void)});

src/SM.lama

@@ -118,8 +118,44 @@ 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 eval (c@[stack, call_stack, st, w], insns) {
+    case insns of
+      i:rest -> case i of
+          READ      -> let [n, w1] = readWorld(w) in eval([n:stack, call_stack, st, w1], rest)
+        | WRITE     -> let v:stack1 = stack in eval([stack1, call_stack, st, writeWorld(v, w)], rest)
+        | BINOP(op) -> let v2:v1:stack1 = stack in eval([evalOp(op, v1, v2):stack1, call_stack, st, w], rest)
+        | LD(x)     -> eval([lookup(st, x):stack, call_stack, st, w], rest)
+        | LDA(x)    -> eval([Ref(x):stack, call_stack, st, w], rest)
+        | ST(x)     -> let v:stack1 = stack in assign(st, x, v); eval(c, rest)
+        | STI       -> let v:Ref(ref):stack1 = stack in assign(st, ref, v); eval([v:stack1, call_stack, st, w], rest)
+        | CONST(n)  -> eval([n:stack, call_stack, st, w], rest)
+        | LABEL (s) -> eval(c, rest)
+        | JMP (l)   -> eval(c, fromLabel(env, l))
+        | CJMP (c, l) -> 
+          let v:stack1 = stack in
+          case c of
+            "z"  -> if v == 0 then eval([stack1, call_stack, st, w], fromLabel(env, l)) else eval([stack1, call_stack, st, w], rest) fi
+          | "nz" -> if v != 0 then eval([stack1, call_stack, st, w], fromLabel(env, l)) else eval([stack1, call_stack, st, w], rest) fi
+          esac
+        | DROP      -> let _:stack1 = stack in eval([stack1, call_stack, st, w], rest)
+        | BEGIN (f, nargs, nlocals) ->
+          let [stack1, args] = take (stack, nargs) in
+          let st1 = makeState (nargs, nlocals) in
+          let [st1, _] = foldl (fun ([st1, i], arg) {
+            assign (st1, Arg (i), arg);
+            [st1, i + 1]
+          }, [st1, 0], args) in
+          eval([stack1, call_stack, st1, w], rest)
+        | END -> 
+          case call_stack of 
+            [st, insns] : call_stack -> eval ([stack, call_stack, st, w], insns)
+            | {} -> c
+          esac
+        | GLOBAL (x) -> assign (st, Glb(x), 0); eval(c, rest)
+        | CALL (f, _) -> eval ([stack, [st, rest]:call_stack, st, w], fromLabel (env, f))
+        esac
+      | {} -> c
+    esac
   }
   (* End *)
 
@@ -349,6 +385,17 @@ fun addVars (env, names) {
 --    (use env.addArg).
 
 -- Compiles an expression into a stack machine code.
+-- Takes an expression, returns a list of stack machine instructions
+fun compileExpr (expr) {
+   case expr of
+     Var(x) -> singletonBuffer(LD(x))
+   | Const(n) -> singletonBuffer (CONST(n))
+   | Binop(op, e1, e2) -> compileExpr(e1) <+> compileExpr(e2) <+> singletonBuffer(BINOP(op))
+   esac
+}
+
+-- Compiles a statement into a stack machine code.
+-- Takes a statement, returns a list of stack machine
 -- Takes an expression, returns a list of stack machine
 -- instructions.
 public fun compileSM (stmt) {
@@ -361,9 +408,10 @@ public fun compileSM (stmt) {
 
   fun compileMany (lab, env, exprs) {
     case exprs of
-      {e}    -> compile (lab, env, e)
+      {}     -> [false, env, emptyBuffer ()]
+    | {e}    -> compile (lab, env, e)
     | e : es ->
-        case env.genLabel of
+        case genLabel (env) of
           [eLab, env] ->
             case compile (eLab, env, e) of
               [eUsed, env, eCode] ->
@@ -377,11 +425,108 @@ 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")
+      Skip           -> [false, env, emptyBuffer ()]
+    | Var   (x)      -> [false, env, singletonBuffer (LD (lookupVar(env, x)))]
+    | Ref   (x)      -> [false, env, singletonBuffer (LDA (lookupVar(env, x)))]
+    | Const (n)      -> [false, env, singletonBuffer (CONST (n))]
+    | Read  (x)      -> [false, env, singletonBuffer (READ) <+ ST (lookupVar(env, x)) <+ DROP]
+    | Write (e)      -> 
+        let [wLab, env] = genLabel(env) in
+        let [wLabUsed, env, code] = compile (wLab, env, e) in
+        [false, env, code <+> label (wLab, wLabUsed) <+ WRITE]
+    | Assn  (x, e)   ->
+        let [xLab, eLab, env] = genLabels(env, 2) in
+        let [xLabUsed, env, xCode] = compile(xLab, env, x) in
+        let [eLabUsed, env, eCode] = compile(eLab, env, e) in
+        [false, env, xCode <+> label(xLab, xLabUsed) <+> eCode <+> label(eLab, eLabUsed) <+ STI]
+    | Assn  (Ref(x), e) -> 
+        let [labUsed, env, code] = compile(lab, env, e) in 
+        [false, env, code <+> label(lab, labUsed) <+ ST(lookupVar(env, x))]
+    | Seq   (s1, s2) -> 
+        let [s2Lab, env] = genLabel(env) in
+        let [s2LabUsed, env, s1Code] = compile (s2Lab, env, s1) in
+        let [labUsed, env, s2Code] = compile (lab, env, s2) in 
+        [labUsed, env, s1Code <+> label (s2Lab, s2LabUsed) <+> s2Code]
+    | If(expr, s1, s2) -> 
+        let [condLab, elseLab, env] = genLabels(env, 2) in
+        let [condLabUsed, env, condCode] = compile (condLab, env, expr) in
+        let [_, env, thenBody] = compile (lab, env, s1) in
+        let [_, env, elseBody] = compile (lab, env, s2) in
+          [true, env, 
+            condCode
+            <+> label(condLab, condLabUsed)
+            <+ CJMP ("z", elseLab) 
+            <+> thenBody 
+            <+ JMP (lab) 
+            <+ LABEL (elseLab) 
+            <+> elseBody
+          ]
+    | While(expr, s)  -> 
+        let [condLab, bodyLab, env] = genLabels(env, 2) in
+        let [_, env, cond] = compile (condLab, env, s) in
+        let [_, env, body] = compile (bodyLab, env, expr) in
+          [false, env, 
+            singletonBuffer (JMP (condLab))
+            <+ LABEL (bodyLab) 
+            <+> cond
+            <+ LABEL (condLab)  
+            <+> body
+            <+ CJMP ("nz", bodyLab)
+          ]
+    | DoWhile(expr, s) -> 
+        compile(lab, env, Seq(s, While(expr, s)))
+    | Binop (op, l, r) -> 
+        let [lLab, rLab, env] = genLabels(env, 2) in
+        let [lLabUsed, env, lCode] = compile(lLab, env, l) in
+        let [rLabUsed, env, rCode] = compile(rLab, env, r) in
+        [false, env, lCode <+> label(lLab, lLabUsed) <+> rCode <+> label(rLab, rLabUsed) <+ BINOP(op)]
+    | Ignore(expr)     -> 
+        let [labUsed, env, code] = compile(lab, env, expr) in 
+        [false, env, code <+> label(lab, labUsed) <+ DROP]
+    | Scope (defs, e) ->
+        let env = beginScope(env) in    
+        let env = foldl(fun (env, def) {
+          case def of
+              Var(names) -> addVars(env, names)
+            | Fun(name, args, _) ->
+              let [l, env] = genFunLabel(env, name) in
+              addFun(env, name, l, size(args))
+          esac
+        }, env, defs) in        
+        let env = foldl(fun (env, def) {
+          case def of
+              Var(_) -> env
+            | Fun(name, args, body) ->
+              let [l, env] = genFunLabel(env, name) in
+              rememberFun(env, l, args, body)
+          esac
+        }, env, defs) in        
+        let globalDefs = 
+          if isGlobal(env) then
+            foldl(fun (code, def) {
+              case def of
+                Var(names) ->
+                  foldl(fun (code, name) {
+                    code <+ GLOBAL(name)
+                  }, code, names)
+              | Fun(_, _, _) -> code
+              esac
+            }, emptyBuffer(), defs)
+          else emptyBuffer()
+        fi in
+        let [labUsed, env, code] = compile(lab, env, e) in
+        let env = endScope(env) in
+        [labUsed, env, globalDefs <+> code]
+    | Call (name, exprs) ->
+        let Fun (l, na) = lookupFun(env, name) in
+        case exprs of
+          {} -> [false, env, singletonBuffer (CALL (l, na))]
+        | _ -> 
+          let [argsLab, env] = genLabel(env) in
+          let [argsLabUsed, env, argsCode] = compileMany (argsLab, env, exprs) in
+          [false, env, argsCode <+> label (argsLab, argsLabUsed) <+ CALL (l, na)]
+        esac
+    | _                 ->  failure ("compileSM not implemented\n")
     esac
   }