hw6 Аргунов Данил

regression/Embedding.meta

@@ -0,0 +1,80 @@
+-- A deep embedding of L0 into Lama
+import List;
+import Array;
+import Fun;
+import World;
+import Stmt;
+import State;
+import SM;
+import X86;
+
+-- Embeds expression operands: strings are 
+-- embedded into identifiers, integer constants --- into
+-- constants; non-operand expressions are left intact
+
+# define HASH #
+
+fun opnd (x) {
+  case x of
+    HASH string  -> Var   (x)
+  | HASH unboxed -> Const (x)
+  | _        -> x
+  esac
+}
+
+-- Redefinition of standard infix operators
+infix +  at +  (l, r) {Binop ("+",  opnd (l), opnd (r))}
+infix -  at -  (l, r) {Binop ("-",  opnd (l), opnd (r))}
+infix *  at *  (l, r) {Binop ("*",  opnd (l), opnd (r))}
+infix /  at /  (l, r) {Binop ("/",  opnd (l), opnd (r))}
+infix %  at %  (l, r) {Binop ("%",  opnd (l), opnd (r))}
+infix == at == (l, r) {Binop ("==", opnd (l), opnd (r))}
+infix != at != (l, r) {Binop ("!=", opnd (l), opnd (r))}
+infix <  at <  (l, r) {Binop ("<",  opnd (l), opnd (r))}
+infix <= at <= (l, r) {Binop ("<=", opnd (l), opnd (r))}
+infix >  at >  (l, r) {Binop (">",  opnd (l), opnd (r))}
+infix >= at >= (l, r) {Binop (">=", opnd (l), opnd (r))}
+infix && at && (l, r) {Binop ("&&", opnd (l), opnd (r))}
+infix !! at !! (l, r) {Binop ("!!", opnd (l), opnd (r))}
+
+-- Embeds "read" construct; x is expected to be a string (not a "Var")
+fun read (x) {
+  Read (x)
+}
+
+-- Embeds "write" construct; note, e is expression, thus it
+-- is embedded using "opnd"
+fun write (e) {
+  Write (opnd (e))
+}
+
+-- Embeds assignment operator; x is expected to be string, e is expression, this
+-- it is embeeded using "opnd"
+infix ::= before := (x, e) {
+  Assn (x, opnd (e))
+}
+
+-- Embeds sequential composition
+infixr >> before ::= (s1, s2) {
+  Seq (s1, s2)
+}
+
+-- Returns embedded program (thus, the file has to be recompiled as the
+-- program changes)
+fun program () {
+  PROGRAM_BODY
+}
+
+case sysargs of
+  [_] -> printf ("%s\n", compileX86 (compileSM (program ())))
+| _   ->
+  local input =
+    reverse (fix (fun (f) {fun (acc) {case readLine () of HASH unboxed -> acc | arg -> f (stringInt (arg) : acc) esac}}) ({}));
+
+  iter (fun (x) {printf ("%d\n", x)},
+        case sysargs[1] of
+          "-i" -> evalStmt (input, program ())
+        | "-s" -> evalSM (input, compileSM (program ()))
+        esac
+       )
+esac

src/Expr.lama

@@ -63,8 +63,56 @@ fun evalList (c, exprs) {
   esac
 }
 
+fun evalSeq(c, exprs) {
+  foldl (fun ([c, _], e) { eval (c, e) }, [c, Error], exprs)
+}
+
 fun eval (c@[s, w], expr) {
-  failure ("evalExpr not implemented\n")
+  case expr of
+    Assn (tgt, val) -> 
+      case evalList(c, {tgt, val}) of
+        [[s, w], {Ref (tgt), val}] -> [[s <- [tgt, val], w], val]
+      esac
+  | Seq (e1, e2) -> evalSeq (c, {e1, e2})
+  | Skip -> [c, Unit]
+  | Read (id) -> 
+      case readWorld (w) of
+        [val, w] -> [[s <- [id, val], w], Unit]
+      esac
+  | Write (e) ->
+      case eval (c, e) of
+        [[s, w], val] -> [[s, writeWorld (val, w)], Unit]
+      esac
+  | If (cond, thn, els) ->
+      case eval (c, cond) of
+        [c, 0] -> eval (c, els)
+      | [c, _] -> eval (c, thn)
+      esac
+  | whl@While (cond, body) ->
+      case eval (c, cond) of
+        [c, 0] -> [c, Unit]
+      | [c, _] ->
+        case evalList (c, {body, whl}) of
+          [c, _] -> [c, Unit]
+        esac
+      esac
+  | rpt@Repeat (body, cond) ->
+      case evalSeq (c, {body, cond}) of
+        [c, 0] -> eval (c, rpt)
+      | [c, _] -> [c, Unit]
+      esac
+  | Var (id) -> [c, s (id)]
+  | Ref (id) -> [c, Ref (id)]
+  | Const (val) -> [c, val]
+  | Binop (op, lhs, rhs) ->
+      case evalList (c, {lhs, rhs}) of
+        [c, {lhs, rhs}] -> [c, evalOp (op, lhs, rhs)]
+      esac
+  | Ignore (e) ->
+      case eval (c, e) of
+        [c, _] -> [c, Unit]
+      esac
+  esac
 }
 
 

src/Parser.lama

@@ -52,7 +52,15 @@ fun binop (op) {
   ]
 }
 
-local primary  = memo $ eta syntax (
+local ifNoKw = memo $ eta syntax (
+  cond=exp kThen thn=exp els=(
+    -kElse exp -kFi     |
+    -kElif ifNoKw        |
+    loc=pos kFi {fun (a) { assertVoid(a, Skip, loc) }}
+  ) {fun (a) { If (cond (Val), thn (a), els (a)) }}
+);
+
+local primary = memo $ eta syntax (
                                     -- decimal constant
                                     loc=pos x=decimal                                 {fun (a) {assertValue (a, Const (stringInt (x)), loc)}}     |
 
@@ -64,8 +72,17 @@ local primary  = memo $ eta syntax (
                                                                                          | _    -> Var (x)
                                                                                          esac
                                                                                       }} |
-                                    $(failure ("the rest of primary parsing in not implemented\n"))),
-      basic    = memo $ eta (expr ({[Right, singleton ([s (":="),
+                                    inbr[s("("), exp, s(")")] |
+                                    loc=pos kSkip {fun (a) { assertVoid(a, Skip, loc) }} |
+                                    loc=pos kRead id=inbr[s("("), lident, s(")")] {fun (a) { assertVoid(a, Read (id), loc) }} |
+                                    loc=pos kWrite e=inbr[s("("), exp, s(")")] {fun (a) { assertVoid(a, Write (e (Val)), loc) }} |
+                                    -kIf ifNoKw |
+                                    loc=pos kWhile cond=exp kDo body=exp kOd {fun (a) { assertVoid(a, While (cond (Val), body (Void)), loc) }} |
+                                    loc=pos kFor init=exp s[","] cond=exp s[","] step=exp kDo body=exp kOd
+                                      {fun (a) { assertVoid(a, Seq (init (Void), While (cond (Val), Seq (body (Void), step (Void)))), loc) }} |
+                                    loc=pos kRepeat body=exp kUntil cond=basic {fun (a) { assertVoid(a, Repeat (body (Void), cond (Val)), loc) }}
+                                    ),
+      basic   = memo $ eta (expr ({[Right, singleton ([s (":="),
                                                         fun (l, loc, r) {
                                                           fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)}
                                                         }])],
@@ -75,8 +92,12 @@ local primary  = memo $ eta syntax (
                                     [Left , map (binop, {"+", "-"})],
                                     [Left , map (binop, {"*", "/", "%"})]
                                    },
-                                   primary)),
-      exp      = memo $ eta syntax (basic | s1=basic s[";"] s2=exp {fun (a) {Seq (s1 (Void), s2 (a))}});
+                                   primary)
+                            ),
+      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=exp {s (Void)});
+
+-- Use this for debugging:
+-- public parse = syntax (s=exp {local ast = s (Void); printf("AST is:\n%s\n", ast.string); ast});

src/SM.lama

@@ -59,8 +59,44 @@ 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, c@[stack, state, w], insns) {
+  case insns of
+    {}             -> c
+  | i : is         -> 
+    case i of
+      JMP (l)        -> eval (env, c, fromLabel (env, l))
+    | CJMP (cond, l) -> 
+        case stack of v : vs -> {
+          fun isCondTrue (cond, value) {
+            case cond of
+              "nz" -> value != 0
+            | "z"  -> value == 0
+            esac
+          }
+          eval (env, [vs, state, w],
+            case isCondTrue(cond, v) of
+              0 -> is
+            | _ -> fromLabel (env, l)
+            esac
+          )
+        } esac
+    | _ ->
+        eval (env,
+          case i of
+              CONST (n)  -> [n : stack, state, w]
+            | BINOP (op) -> case stack of v1 : v2 : vs -> [evalOp (op, v1, v2) : vs, state, w] esac
+            | LD (x)     -> [state (x) : stack, state, w]
+            | ST (x)     -> case stack of v : vs -> [vs, state <- [x, v], w] esac
+            | READ       -> case readWorld (w) of [v, w1] -> [v : stack, state, w1] esac
+            | WRITE      -> case stack of v : vs -> [vs, state, writeWorld (v, w)] esac
+            | LABEL (s)  -> c
+            | LDA (id)   -> [Ref (id) : stack, state, w]
+            | STI        -> case stack of v : (Ref (id)) : vs -> [v : vs, state <- [id, v], w] esac
+            | DROP       -> case stack of _ : vs -> [vs, state, w] esac
+          esac,
+        is)
+    esac
+  esac
 }
 
 -- Runs a stack machine for a given input and a given program, returns an output
@@ -102,5 +138,89 @@ fun genLabels (env, n) {
 -- Takes an expression, returns a list of stack machine
 -- instructions.
 public fun compileSM (stmt) {
-  failure ("compileSM not implemented\n")
+  fun compileImpl (env, stmt) { 
+    case stmt of
+      Assn (tgt, e)       ->
+        case compileImpl (env, tgt) of [env, smTgt] ->
+          case compileImpl (env, e) of [env, smVal] ->
+            [env, {smTgt, smVal, STI}]
+          esac
+        esac
+    | Seq (e1, e2)        -> 
+        case compileImpl (env, e1) of [env, sm1] ->
+          case compileImpl (env, e2) of [env, sm2] ->
+            [env, {sm1, sm2}]
+          esac
+        esac
+    | Skip                -> [env, {}]
+    | Read (x)            -> [env, {READ, ST (x)}]
+    | Write (e)           ->
+        case compileImpl (env, e) of [env, sm] ->
+          [env, {sm, WRITE}]
+        esac
+    | If (cond, thn, els) -> 
+        case compileImpl (env, cond) of [env, smCond] ->
+          case genLabels (env, 2) of [labelEls, labelEnd, env] ->
+            case compileImpl (env, thn) of [env, smThn] ->
+              case compileImpl (env, els) of [env, smEls] ->
+                [env,
+                  { smCond
+                  , CJMP ("z", labelEls)
+                  , smThn
+                  , JMP (labelEnd)
+                  , LABEL (labelEls)
+                  , smEls
+                  , LABEL (labelEnd)
+                  }
+                ]
+              esac
+            esac
+          esac
+        esac
+    | While (cond, body) ->
+        case compileImpl (env, cond) of [env, smCond] ->
+          case genLabels (env, 2) of [labelBody, labelCond, env] ->
+            case compileImpl (env, body) of [env, smBody] ->
+              [env,
+                { JMP (labelCond)
+                , LABEL (labelBody)
+                , smBody
+                , LABEL (labelCond)
+                , smCond
+                , CJMP ("nz", labelBody)
+                }
+              ]
+            esac
+          esac
+        esac
+    | Repeat (body, cond) ->
+        case compileImpl (env, cond) of [env, smCond] ->
+          case genLabels (env, 1) of [labelBody, env] ->
+            case compileImpl (env, body) of [env, smBody] ->
+              [env,
+                { LABEL (labelBody)
+                , smBody
+                , smCond
+                , CJMP ("z", labelBody)
+                }
+              ]
+            esac
+          esac
+        esac
+    | Var (id) -> [env, singleton (LD (id))]
+    | Ref (id) -> [env, singleton (LDA (id))]
+    | Const (n) -> [env, singleton (CONST (n))]
+    | Binop (op, lhs, rhs) ->
+        case compileImpl (env, lhs) of [env, smLhs] ->
+          case compileImpl (env, rhs) of [env, smRhs] ->
+            [env, {smRhs, smLhs, BINOP (op)}]
+          esac
+        esac
+    | Ignore (e) ->
+        case compileImpl (env, e) of [env, sm] ->
+          [env, {sm, DROP}]
+        esac
+    esac
+  }
+  deepFlatten (compileImpl (initCompEnv (), stmt)[1])
 }

src/Stmt.lama

@@ -0,0 +1,53 @@
+-- Statement evaluator.
+
+import State;
+import Expr;
+import World;
+
+-- Evaluates a statement "stmt" in a configuration "c".
+-- A configuration is a pair of a state "s" and a world "w".
+-- Returns a final configuration (if any)
+--
+-- 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)       |
+--        Repeat (stmt, expr)
+
+fun eval (c, stmt) {
+  case c of [s, w] ->
+    case stmt of
+      Read (x)     -> case readWorld (w) of [v, w1] -> [s <- [x, v], w1] esac
+    | Write (e)    -> [s, writeWorld (evalExpr (s, e), w)]
+    | Assn (x, e)  -> [s <- [x, evalExpr (s, e)], w]
+    | Seq (s1, s2) -> eval (eval (c, s1), s2)
+        | Skip         -> [s, w]
+    | If (cond, thn, els) -> case evalExpr (s, cond) of
+                               0 -> eval (c, els)
+                             | _ -> eval (c, thn)
+                             esac
+    | whl @ While (cond, body) -> case evalExpr (s, cond) of
+                                    0 -> [s, w]
+                                  | _ -> eval (eval (c, body), whl)
+                                  esac
+    | rpt @ Repeat (body, cond) -> {
+      case eval (c, body) of c1 @ [s1, w1] ->
+        case evalExpr (s1, cond) of
+          0 -> eval (c1, rpt)
+        | _ -> c1
+        esac
+      esac
+    }
+    esac
+  esac
+}
+
+-- Evaluates a program with a given input and returns an output
+public fun evalStmt (input, stmt) {
+  eval ([emptyState, createWorld (input)], stmt).snd.getOutput
+}