[CUB] T04 Dashevskii

src/Expr.lama

@@ -1,9 +1,7 @@
 -- Expression evaluator
-
 import List;
 import State;
 
-
 -- The evaluator itself: takes a state and an expression,
 -- returns integer value
 --
@@ -13,6 +11,36 @@ import State;
 --        Const (int)                |
 --        Binop (string, expr, expr)
 
+public fun showExpr (expr) {
+  case expr of
+    Var (x) -> x
+  | Const (n) -> string (n)
+  | Binop (op, lhs, rhs) -> sprintf("(%s) %s (%s)", showExpr (lhs), op, showExpr (rhs))
+  esac
+}
+
+public fun evalBinop (op, x, y) {
+    case op of
+      "+" -> x + y
+    | "-" -> x - y
+    | "*" -> x * y
+    | "/" -> x / y
+    | "%" -> x % y
+    | "==" -> x == y
+    | "!=" -> x != y
+    | "<" -> x < y
+    | "<=" -> x <= y
+    | ">" -> x > y
+    | ">=" -> x >= y
+    | "&&" -> x && y
+    | "!!" -> x !! y
+    esac
+}
+
 public fun evalExpr (st, expr) {
-  failure ("evalExpr not implemented\n")
+    case expr of
+      Var(x)            -> st(x)
+    | Const(n)          -> n
+    | Binop(op, e1, e2) -> evalBinop(op, evalExpr(st, e1), evalExpr(st, e2))
+    esac
 }

src/Parser.lama

@@ -4,22 +4,68 @@ import Ostap;
 import Lexer;
 import List;
 import Fun;
-import Matcher;
 
 -- A parser of "something" in brackets; l, r are left and right
 -- brackets as parsers, p --- a parser of "something"
 fun inbr (l, p, r) {
   syntax (-l p -r)
 }
 
+fun binop (op) {[s (op), fun (x, op, y) {Binop (op, x, y)}]}
+
+fun binops (ops) {map (binop, ops)}
+
 -- Primary expression
 var primary = memo $ eta (decimal @ fun (x) {Const (stringInt (x))} |
                           lident  @ fun (x) {Var (x)} |
                           inbr (s ("("), exp, s (")"))),
-    exp = memo $ eta (failure ("expression parsing not implemented\n"));
+      exp = memo $ eta (
+        expr({
+            [Left, binops ({"!!", "&&"})],
+            [Nona, binops ({"==", "!=", "<", ">", "<=", ">="})],
+            [Left, binops ({"+", "-"})],
+            [Left, binops ({"*", "/", "%"})]
+          }, primary)
+      );
+
+-- read, write, skip, assn
+var stmt = memo $ eta syntax (
+  kIf c=exp kThen t=stmts elifs=elifsP e=maybeElseP kFi {foldr (
+    fun (acc, elem) {
+      let [c, body] = elem in
+        If (c, body, acc)
+    },
+    e,
+    {[c, t]} +++ elifs
+  )}                                                                          |
+  kWhile c=exp kDo body=stmts kOd                         {While (c, body)}   |
+  kDo body=stmts kWhile c=exp kOd                         {DoWhile (c, body)} |
+  kFor s1=stmts token[","] e=exp token[","] s2=stmts kDo s3=stmts kOd 
+                                        {Seq (s1, While (e, Seq (s3, s2)))}   |
+  kRead s["("] x=lident s[")"]                            {Read (x)}          |
+  kWrite s["("] e=exp s[")"]                              {Write (e)}         |
+  x=lident s[":="] e=exp                                  {Assn (x, e)}       |
+  kSkip                                                   {Skip}
+);
+
+var elifP = memo $ eta syntax (
+  s["elif"] c=exp s["then"] body=stmts {[c, body]}
+);
+
+var elifsP = memo $ eta syntax (
+  empty {{}} |
+  b=elifP bb=elifsP {{b} +++ bb}
+);
+
+var maybeElseP = memo $ eta syntax (
+  empty               {Skip} |
+  s["else"] body=stmts {body}
+);
 
-var stmt = memo $ eta (failure ("statement parsing not implemented\n"));
-
+var stmts = memo $ eta syntax (
+  st=stmt                  {st}            |
+  st=stmt s[";"] sts=stmts {Seq (st, sts)}
+);
 
 -- Public top-level parser
-public parse = stmt;
+public parse = stmts;

src/SM.lama

@@ -13,37 +13,39 @@ import Buffer;
 -- string representation.
 public fun showSMInsn (i) {
   case i of
-    READ         -> sprintf ("READ")
-  | WRITE        -> sprintf ("WRITE")
-  | BINOP (s)    -> sprintf ("BINOP %s", s)
-  | LD    (x)    -> sprintf ("LD %s", x)
-  | ST    (x)    -> sprintf ("ST %s", x)
-  | CONST (n)    -> sprintf ("CONST %d", n)
-  | LABEL (s)    -> sprintf ("LABEL %s", s)
-  | JMP   (l)    -> sprintf ("JMP %s", l)
-  | CJMP  (c, l) -> sprintf ("CJMP %s, %s", c, l)
+    READ      -> sprintf("READ")
+  | WRITE     -> sprintf("WRITE")
+  | BINOP (s) -> sprintf("BINOP %s", s)
+  -- load value onto the stack
+  | LD (x)    -> sprintf("LD %s", x)
+  -- pop from the stack and store popped value
+  | ST (x)    -> sprintf("ST %s", x)
+  | CONST (n) -> sprintf("CONST %d", n)
+  | LABEL (l) -> sprintf("LABEL %d", l)
+  | JMP (l)   -> sprintf("JMP %d", l)
+  | CJMP (c, l) -> sprintf("JMP %s %d", c, l)
   esac
 }
 
 public fun showSM (prg) {
-  map (fun (i) {showSMInsn (i) ++ "\n"}, prg).stringcat
+  map(fun (i) {showSMInsn(i) ++ "\n"}, prg).stringcat
 }
 
 -- Evaluation environment: keeps a mapping between labels and (sub)programs
 fun initEvalEnv (insns) {
   var map =
     fix (fun (rec) {
-          fun ([m, insns]) {
-            case insns of
-              {}               -> m
-            | LABEL (lab) : tl -> rec ([addMap (m, lab, insns), tl])
-            | _ : tl           -> rec ([m, tl])
-            esac
-          }
-        }) $ [emptyMap (compare), insns];
+      fun ([m, insns]) {
+        case insns of
+          {}               -> m
+        | LABEL (lab) : tl -> rec ([addMap (m, lab, insns), tl])
+        | _ : tl           -> rec ([m, tl])
+        esac
+      }
+    }) $ [emptyMap (compare), insns];
 
   [fun (l) {
-     case findMap (map, l) of Some (insns) -> insns esac
+    case findMap (map, l) of Some (insns) -> insns esac
   }]
 }
 
@@ -54,10 +56,36 @@ fun fromLabel (env, lab) {
 
 -- Stack machine interpreter. Takes an environment, an SM-configuration and a program,
 -- returns a final configuration
-fun eval (env, c, insns) {
-  failure ("SM eval not implemented\n")
+fun eval (env, [stack, state, world], insns) {
+  case insns of
+    {} -> [stack, state, world]
+  | ins:insns -> case ins of
+      READ        -> let [n, newWorld] = readWorld (world) in
+                        eval (env, [n:stack, state, newWorld], insns)
+    | WRITE       -> let n:newStack = stack in
+                        eval (env, [newStack, state, writeWorld (n, world)], insns)
+    | BINOP (s)   -> let x:y:newStack = stack in
+                        eval (env, [evalBinop (s, x, y) : newStack, state, world], insns)
+    | LD (s)      -> eval (env, [state (s) : stack, state, world], insns)
+    | ST (s)      -> let n:newStack = stack in
+                        eval (env, [newStack, state <- [s, n], world], insns)
+    | CONST (n)   -> eval (env, [n:stack, state, world], insns)
+    | LABEL (l)   -> eval (env, [stack, state, world], insns)
+    | JMP (l)     -> eval (env, [stack, state, world], fromLabel (env, l))
+    | CJMP (c, l) -> let n:newStack = stack in
+                        let cv = case c of
+                            "z"  -> stack.hd == 0
+                          | "nz" -> stack.hd != 0
+                          esac
+                        in
+                          if cv then
+                            eval (env, [newStack, state, world], fromLabel (env, l))
+                          else
+                            eval (env, [newStack, state, world], insns)
+                          fi
+    esac
+  esac
 }
-
 -- Runs a stack machine for a given input and a given program, returns an output
 public fun evalSM (input, insns) {
   eval (initEvalEnv (insns), [{}, emptyState, createWorld (input)], insns)[2].getOutput
@@ -66,7 +94,7 @@ public fun evalSM (input, insns) {
 -- Compilation environment: generates labels
 fun makeCompEnv (n) {
   [fun () {
-     [sprintf ("L%d", n), makeCompEnv (n+1)]
+    [sprintf ("L%d", n), makeCompEnv (n+1)]
   }]
 }
 
@@ -85,23 +113,25 @@ fun genLabels (env, n) {
     if n == 0
     then {env}
     else case env.genLabel of
-           [lab, env] -> lab : inner (env, n-1)
-         esac
+        [lab, env] -> lab : inner (env, n-1)
+      esac
     fi
   }
 
   listArray (inner (env, n))
 }
 
 -- Compiles an expression into a stack machine code.
--- Takes an expression, returns a list of stack machine instructions
+-- Takes an expression, returns a list (of, possibly, lists)
+-- of stack machine instructions
 fun compileExpr (expr) {
-  failure ("compileExpr not implemented\n")
+  case expr of
+    Var(x) -> singletonBuffer (LD (x))
+  | Const(n) -> singletonBuffer (CONST (n))
+  | Binop(op, e1, e2) -> compileExpr(e2) <+> compileExpr(e1) <+ BINOP (op)
+  esac
 }
 
--- Compiles a statement into a stack machine code.
--- Takes a statement, returns a list of stack machine
--- instructions.
 public fun compileSM (stmt) {
   -- Generates a buffer with an optional label
   --    lab     --- the name of the label
@@ -114,7 +144,7 @@ public fun compileSM (stmt) {
   }
 
   -- Generates SM code for a given statement
-  --    lab  --- a label th go to after the statement is executed
+  --    lab  --- a label to go to after the statement is executed
   --    env  --- compilation environment
   --    stmt --- a statement to generate SM code for
   -- Returns a triple:
@@ -123,28 +153,40 @@ public fun compileSM (stmt) {
   --    code buffer  
   fun compile (lab, env, stmt) {
     case stmt of
-      Skip           -> [false, env, emptyBuffer ()]
-    | Read  (x)      -> [false, env, singletonBuffer (READ) <+ ST (x)]
-    | Write (e)      -> [false, env, compileExpr (e) <+ WRITE]
-    | Assn  (x, e)   -> [false, env, compileExpr (e) <+ ST (x)]
-    | Seq   (s1, s2) ->
+      Skip            -> [false, env, emptyBuffer ()]
+    | Read  (x)       -> [false, env, singletonBuffer (READ) <+ ST (x)]
+    | Write (e)       -> [false, env, compileExpr (e) <+ WRITE]
+    | Assn  (x, e)    -> [false, env, compileExpr (e) <+ ST (x)]
+    | Seq   (s1, s2)  ->
         case env.genLabel of
           [s2Lab, env] ->
-             case compile (s2Lab, env, s1) of
-               [s2LabUsed, env, s1Code] ->
-                  case compile (lab, env, s2) of
-                    [labUsed, env, s2Code] -> [labUsed, env, s1Code <+> label (s2Lab, s2LabUsed) <+> s2Code]
-                  esac
-             esac
+            case compile (s2Lab, env, s1) of
+              [s2LabUsed, env, s1Code] ->
+                case compile (lab, env, s2) of
+                  [labUsed, env, s2Code] -> [labUsed, env, s1Code <+> label (s2Lab, s2LabUsed) <+> s2Code]
+                esac
+            esac
         esac
-    | _              -> failure ("compileSM not implemented\n")
+    | If   (c, t, e)  ->
+        let [flab, env] = env.genLabel in
+          let [_, env, tcode] = compile (lab, env, t) in
+            let [_, env, fcode] = compile (lab, env, e) in
+              [true, env, compileExpr (c) <+ CJMP ("z", flab) <+> tcode <+ JMP (lab) <+ LABEL (flab) <+> fcode]
+    | While (c, body) ->
+        let [clab, env] = env.genLabel in
+          let [_, env, bcode] = compile (clab, env, body) in
+            [true, env, label (clab, true) <+> compileExpr (c) <+ CJMP ("z", lab) <+> bcode <+ JMP (clab)]
+    | DoWhile (c, body) ->
+        let [clab, env] = env.genLabel in
+          let [_, env, bcode] = compile (clab, env, body) in
+            [false, env, label (clab, true) <+> bcode <+> compileExpr (c) <+ CJMP ("nz", clab)]
     esac
   }  
 
   case initCompEnv ().genLabel of
     [endLab, env] ->
-       case compile (endLab, env, stmt) of
-         [endLabUsed, _, code] -> getBuffer $  code <+> label (endLab, endLabUsed)
-       esac
+      case compile (endLab, env, stmt) of
+        [endLabUsed, _, code] -> getBuffer $  code <+> label (endLab, endLabUsed)
+      esac
   esac
 }

src/Stmt.lama

@@ -1,5 +1,4 @@
 -- Statement evaluator.
-
 import State;
 import Expr;
 import World;
@@ -10,20 +9,46 @@ import World;
 --
 -- A statement is represented by a data structure of the following shape:
 --
--- stmt = Assn    (string, expr)     |
---        Seq     (stmt, stmt)       |
---        Skip                       |
---        Read    (string)           |
---        Write   (expr)             |
---        If      (expr, stmt, stmt) |
---        While   (expr, stmt)       |
+-- stmt = Assn   (string, expr)     |
+--        Seq    (stmt, stmt)       |
+--        Skip                      |
+--        Read   (string)           |
+--        Write  (expr)             |
+--        If     (expr, stmt, stmt) |
+--        While  (expr, stmt)       |
 --        DoWhile (stmt, expr)
-
-fun eval (c, stmt) {
-  failure ("Stmt eval not implemented\n")
+public fun showStmt (stmt) {
+   case stmt of
+     Assn (x, e)    -> x ++ " := " ++ showExpr (e)
+   | Seq (s, ss)    -> showStmt (s) ++ ";\n" ++ showStmt (ss)
+   | Skip           -> "skip"
+   | Read (x)       -> sprintf ("read(%s)", x)
+   | Write (e)      -> sprintf ("write(%s)", showExpr (e))
+   | If (c, t, e)   -> sprintf ("if %s then\n%s else\n%s\nfi", showExpr (c), showStmt (t), showStmt (e))
+   | While (c, b)   -> sprintf ("while %s do\n%s\nod", showExpr (c), showStmt (b))
+   | DoWhile (c, b) -> sprintf ("do\n%s\nwhile %s od", showStmt (b), showExpr (c))
+   esac
 }
 
+fun eval ([st, world], stmt) {
+  case stmt of
+    Assn (x, e)        -> [st <- [x, evalExpr(st, e)], world]
+  | Seq (stmt1, stmt2) -> eval(eval([st, world], stmt1), stmt2)
+  | Skip               -> [st, world]
+  | Read (x)           -> let [v, newWorld] = readWorld(world) in [st <- [x, v], newWorld]
+  | Write (e)          -> [st, writeWorld(evalExpr(st, e), world)]
+  | If (c, t, e)       -> case evalExpr (st, c) of
+                            0 -> eval ([st, world], e)
+                          | _ -> eval ([st, world], t)
+                          esac
+  | While (c, b)       -> case evalExpr (st, c) of
+                            0 -> [st, world]
+                          | _ -> eval ([st, world], Seq (b, While (c, b)))
+                          esac
+  | DoWhile (c, b)     -> eval ([st, world], Seq (b, While (c, b)))
+   esac
+}
 -- Evaluates a program with a given input and returns an output
 public fun evalStmt (input, stmt) {
-  eval ([emptyState, createWorld (input)], stmt).snd.getOutput
+   eval([emptyState, createWorld(input)], stmt).snd.getOutput
 }