[ITMO] T05 Kudryavtsev Alexander

src/Driver.lama

@@ -17,13 +17,15 @@ import Manifest;
 -- returns an environment. The environment's interface is
 -- defined in the unit Manifest
 fun parseArgs (args) {
-  var mode   = ref (Comp),
-      infile = ref ({}),
-      smDump = ref (false);
+  var mode    = ref (Comp),
+      infile  = ref ({}),
+      smDump  = ref (false),
+      astDump = ref (false);
 
   fun setDump (m) {
     case m of
-      SM -> smDump ::= true
+        SM -> smDump ::= true
+      | AST -> astDump ::= true
     esac
   }
 
@@ -50,6 +52,7 @@ fun parseArgs (args) {
                  "-i"  -> setMode (Int)
                | "-s"  -> setMode (SM)
                | "-ds" -> setDump (SM)
+               | "-dt" -> setDump (AST)
                | fn    -> setInFile (fn)
                esac;
                rec (t)
@@ -59,7 +62,8 @@ fun parseArgs (args) {
 
   [fun () {deref (mode)},
    fun () {case deref(infile) of #val -> failure ("input file name not set\n") | fn -> fn esac},
-   fun () {deref (smDump)}
+   fun () {deref (smDump)},
+   fun () {deref (astDump)}
   ]        
 }
 
@@ -75,6 +79,7 @@ var args = parseArgs (arrayList (sysargs).tl);
 -- code generator
 case parseString (parse |> bypass (end), fread (args.getInFile)) of
   Succ (program) ->
+    dumpAST(args, program);
     case args.getMode of
       Comp -> compileX86 (args, peepSM (args, compileSM (program)))
     | mode ->

src/Expr.lama

@@ -63,14 +63,81 @@ fun evalList (c, exprs) {
   esac
 }
 
+fun evalRef(c, expr) {
+  let [c, out] = eval(c, expr) in
+  case out of
+    #str -> [c, out]
+  | _ -> failure("Expected ref, got %s", out.string)
+  esac
+}
+
+fun evalVal(c, expr) {
+  let [c, out] = eval(c, expr) in
+  case out of
+    #val -> [c, out]
+  | _ -> failure("Expected val, 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] = evalVal(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, 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(name)]
+    | Ref(name) -> [c, name]
+    | Const(x) -> [c, x]
+    | Binop(op, left, right) ->
+      let [c, leftV] = evalVal(c, left) in
+      let [c, rightV] = evalVal(c, right) in
+      [c, evalOp(op, leftV, rightV)]
+    | Ignore(expr) -> let [c, dropped] = eval(c, expr) in [c, None]
+    | _ -> failure("Unknown instruction: %s", expr.string)
+  esac
 }
 
 
 -- Evaluates a program with a given input and returns an output
 public fun evalExpr (input, expr) {
-  case eval ([emptyState, createWorld (input)], expr) of
+  -- failure("Evaluating %s\n", expr.string)
+
+  case evalVoid ([emptyState, createWorld (input)], expr) of
     [c, _] -> c.snd.getOutput
   esac
 }

src/Manifest.lama

@@ -16,6 +16,12 @@ public fun dumpSM (args, smCode) {
   fi
 }
 
+public fun dumpAST (args, astCode) {
+  if args [3] () then
+    fwrite (args.getBaseName ++ ".ast", astCode.string)
+  fi
+}
+
 public fun getBaseName (args) {
   force (lazy ((var name = args.getInFile;
                if (matchSubString (name, ".lama", name.length - 5))

src/Parser.lama

@@ -52,9 +52,24 @@ 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
+}
+
 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
                                   x=lident                                          {fun (a) {
@@ -64,7 +79,22 @@ var primary  = memo $ eta syntax (
                                                                                        | _    -> Var (x)
                                                                                        esac
                                                                                     }} |
-                                  $(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("("), exp, s(")")]
+                                    {fun(a) { assertVoid(a, Write(e(Val)), loc)}} |
+                                  kIf e=exp kThen tru=exp elifs=(-kElif exp -kThen exp)* fls=(-kElse exp)? kFi
+                                    {fun(a) { If(e(Val), tru(a), mkElifs(a, getOrSkip(fls, a), elifs))}} |
+                                  loc=pos kWhile e=exp kDo c=exp kOd
+                                    {fun(a) { assertVoid(a, While(e(Val), c(Void)), loc) }} |
+                                  loc=pos kDo c=exp kWhile e=exp kOd
+                                    {fun(a) { assertVoid(a, DoWhile(e(Val), c(Void)), loc) }} |
+                                  loc=pos kSkip {fun(a) { assertVoid(a, Skip, loc) }} |
+                                  kFor ini=exp s[","] cond=exp s[","] act=exp kDo c=exp kOd
+                                    {fun(a) { Seq(ini(Void), While(cond(Val), Seq(c(Void), act(Void))))} } |
+                                  e=inbr[s("("), exp, s(")")]
+                                  ),
     basic    = memo $ eta (expr ({[Right, {[s (":="),
                                             fun (l, loc, r) {
                                               fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)}

src/SM.lama

@@ -57,10 +57,100 @@ 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, an SM-configuration and a program,
 -- returns a final configuration
 fun eval (env, c, insns) {
-  failure ("SM eval 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)
 }
 
 -- Runs a stack machine for a given input and a given program, returns an output
@@ -112,10 +202,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
   }