Homework 2.0

src/Expr.lama

@@ -14,5 +14,28 @@ import State;
 --        Binop (string, expr, expr)
 
 public fun evalExpr (st, expr) {
-  failure ("evalExpr not implemented\n")
+  case expr of
+    Var (name) -> st (name)
+  | Const (num) -> num
+  | Binop (op, l, r) -> evalOp (op, evalExpr (st, l), evalExpr (st, r))
+  esac
+}
+
+public fun evalOp (op, l, r) {
+  case op of
+    "+"  -> l +  r
+  | "-"  -> l -  r
+  | "*"  -> l *  r
+  | "/"  -> l /  r
+  | "%"  -> l %  r
+  | "==" -> l == r
+  | "!=" -> l != r
+  | "<"  -> l <  r
+  | "<=" -> l <= r
+  | ">"  -> l >  r
+  | ">=" -> l >= r
+  | "&&" -> l && r
+  | "!!" -> l !! r
+  | _    -> failure ("unknown operation %s\n", op)
+  esac
 }

src/SM.lama

@@ -24,26 +24,78 @@ public fun showSM (prg) {
   map (fun (i) {showSMInsn (i) ++ "\n"}, prg).stringcat
 }
 
+fun evalInsn (c, i) {
+  case i of
+    READ      -> case readWorld (c.trd) of [z, w_] -> c . onFst (fun (st) { z : st }) . onTrd (fun (_) { w_ }) esac
+  | WRITE     -> case c.fst of z : st -> c . onFst (fun (_) { st }) . onTrd (fun (w) { writeWorld (z, w) }) esac
+  | BINOP (s) -> case c.fst of y : x : st -> c . onFst (fun (_) { evalOp (s, x, y) : st }) esac
+  | LD    (x) -> c . onFst (fun (st) { (c.snd) (x) : st })
+  | ST    (x) -> case c.fst of z : st -> c . onFst (fun (_) { st }) . onSnd (fun (s) { s <- [x, z] }) esac
+  | CONST (n) -> c . onFst (fun (st) { n : st })
+  esac
+}
+
 -- Stack machine interpreter. Takes an SM-configuration and a program,
 -- returns a final configuration
 fun eval (c, insns) {
-  failure ("SM eval not implemented\n")
+  case insns of
+    {} -> c
+  | insn : oinsns -> c . evalInsn (insn) . eval (oinsns)
+  esac
 }
 
 -- Runs a stack machine for a given input and a given program, returns an output
 public fun evalSM (input, insns) {
   eval ([{}, emptyState, createWorld (input)], insns)[2].getOutput
 }
 
+-- Functions for work with state of Stack machine
+fun onFst (triple, f) {
+  case triple of
+    [x, y, z] -> [f (x), y, z]
+  | _ -> failure ("object is not a triple\n")
+  esac
+}
+
+fun onSnd (triple, f) {
+  case triple of
+    [x, y, z] -> [x, f (y), z]
+  | _ -> failure ("object is not a triple\n")
+  esac
+}
+
+fun onTrd (triple, f) {
+  case triple of
+    [x, y, z] -> [x, y, f (z)]
+  | _ -> failure ("object is not a triple\n")
+  esac
+}
+
+fun trd (object) {
+  case object of
+    [_, _, z] -> z
+  esac
+}
+
 -- Compiles an expression into a stack machine code.
 -- Takes an expression, returns a list of stack machine instructions
 fun compileExpr (expr) {
-  failure ("compileExpr not implemented\n")
+  case expr of
+    Var (name) -> { LD (name) }
+  | Const (num) -> { CONST (num) }
+  | Binop (op, l, r) -> compileExpr (l) +++ compileExpr (r) +++ { 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) {
-  failure ("compileSM not implemented\n")
+  case stmt of
+    Assn (name, expr) -> compileExpr (expr) +++ { ST (name) }
+  | Seq (stmt1, stmt2) -> compileSM (stmt1) +++ compileSM (stmt2)
+  | Skip -> {}
+  | Read (name) -> { READ, ST (name) }
+  | Write (expr) -> compileExpr (expr) +++ { WRITE }
+  esac
 }

src/Stmt.lama

@@ -17,7 +17,28 @@ import World;
 --        Write  (expr)             |
 
 fun eval (c, stmt) {
-  failure ("Stmt eval not implemented\n")
+  case stmt of
+    Assn (name, expr) -> c . onFst (fun (s) { s <- [name, evalExpr (s, expr) ] })
+  | Seq (stmt1, stmt2) -> c . eval (stmt1) . eval (stmt2)
+  | Skip -> c
+  | Read (name) -> case readWorld (c.snd) of [z, w_] -> c . onFst (fun (s) { s <- [name, z] }) . onSnd (fun (_) { w_ }) esac
+  | Write (expr) -> c . onSnd (fun (w) { writeWorld (evalExpr(c.fst, expr), w) })
+  esac
+}
+
+-- Functions for work with state of Statement evaluator
+fun onFst (pair, f) {
+  case pair of
+    [x, y] -> [f (x), y]
+  | _  -> failure ("object is not a pair\n")
+  esac
+}
+
+fun onSnd (pair, f) {
+  case pair of
+    [x, y] -> [x, f (y)]
+  | _  -> failure ("object is not a pair\n")
+  esac
 }
 
 -- Evaluates a program with a given input and returns an output

src/X86.lama

@@ -46,7 +46,7 @@ var wordSize = 4;
 --   Call  (string)             -- calls a function by its name 
 --   Ret                        -- returns from a function
 --   Meta  (string)             -- metainformation (declarations, etc.)
-                                                               
+
 -- Machine instruction printer
 fun insnString (insn) {
 
@@ -253,25 +253,54 @@ fun memOpnd (opnd) {
 -- Generates a move between locations, using
 -- intermediate register if needed
 fun move (from, to) {
-  if memOpnd (from) && memOpnd (to)
-  then singletonBuffer (Mov (from, eax)) <+ Mov (eax, to)
-  else singletonBuffer (Mov (from, to))
+  if from.compare(to) == 0
+  then emptyBuffer ()
+  else
+    if memOpnd (from) && memOpnd (to)
+    then singletonBuffer (Mov (from, eax)) <+ Mov (eax, to)
+    else singletonBuffer (Mov (from, to))
+    fi
   fi
 }
 
--- Gets a suffix for Set instruction from
--- source language comparison operator
-fun suffix (op) {
-  case op of
-    "<"  -> "l"
-  | "<=" -> "le"
-  | "==" -> "e"
-  | "!=" -> "ne"
-  | ">=" -> "ge"
-  | ">"  -> "g"
+-- Generates an operation with optional moving of arguments to %eax and %edx
+-- (for operation which can't work with two arbitrary memory cells)
+fun binop (op, l, r) {
+  case (
+    if memOpnd (l)
+    then [fun (code) { move (l, edx) <+> code }, edx]
+    else [id, l]
+    fi) of [fCode, l2] ->
+      case (
+        if op.compare("*") == 0 && memOpnd (r)
+        then [fun (code) { fCode (move (r, eax) <+> code <+> move (eax, r)) }, eax]
+        else [fCode, r]
+        fi) of [fCode, r2] ->
+          Binop (op, l2, r2) . singletonBuffer . fCode
+      esac
   esac
 }
 
+-- Gets a one-byte subregister of given four-byte register
+fun set (op, R (i)) {
+  Set (
+    case op of
+      "<"  -> "l"
+    | "<=" -> "le"
+    | "==" -> "e"
+    | "!=" -> "ne"
+    | ">=" -> "ge"
+    | ">"  -> "g"
+    esac,
+    case regs[i] of
+      "%ebx" -> "%bl"
+    | "%ecx" -> "%cl"
+    | "%eax" -> "%al"
+    | "%edx" -> "%dl"
+    esac
+  ) . singletonBuffer
+}
+
 -- Compiles stack machine code into a list of x86 instructions. Takes an environment
 -- and stack machine code, returns an updated environment and x86 code.
 fun compile (env, code) {
@@ -287,11 +316,62 @@ fun compile (env, code) {
           case env.pop of
             [s, env] -> [env, code <+ Push (s) <+ Call ("Lwrite") <+ Pop (eax)]
           esac
-      | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string)
+      | BINOP (s) ->
+          case env.pop2 of [y, x, env] ->
+            case env.allocate of [z, env] ->
+              [env, code <+> compileOp(s, x, y, z)]
+            esac
+          esac
+      | LD    (x) ->
+          case env.allocate of [s, env] ->
+            [env, code <+> move (env.loc (x), s)]
+          esac
+      | ST    (x) ->
+          case env.addGlobal (x) of env ->
+            case env.pop of [v, env] ->
+              [env, code <+> move (v, env.loc (x))]
+            esac
+          esac
+      | CONST (n) ->
+          case env.allocate of [s, env] ->
+            [env, code <+> move (L (n), s)]
+          esac
       esac
     }, [env, emptyBuffer ()], code)
 }
 
+-- Compile operation x (+) y = z
+fun compileOp (op, x, y, z) {
+  case op of
+    "+"  ->
+      binop ("+", y, x) <+> move (x, z)
+  | "-"  ->
+      binop ("-", y, x) <+> move (x, z)
+  | "*"  ->
+      binop ("*", y, x) <+> move (x, z)
+  | "/"  ->
+      move (x, eax) <+ Cltd <+ IDiv (y) <+> move (eax, z)
+  | "%"  ->
+      move (x, eax) <+ Cltd <+ IDiv (y) <+> move (edx, z)
+  | "==" ->
+      move (L (0), eax) <+> binop ("cmp", y, x) <+> set ("==", eax) <+> move (eax, z)
+  | "!=" ->
+      move (L (0), eax) <+> binop ("cmp", y, x) <+> set ("!=", eax) <+> move (eax, z)
+  | "<"  ->
+      move (L (0), eax) <+> binop ("cmp", y, x) <+> set ("<",  eax) <+> move (eax, z)
+  | "<=" ->
+      move (L (0), eax) <+> binop ("cmp", y, x) <+> set ("<=", eax) <+> move (eax, z)
+  | ">"  ->
+      move (L (0), eax) <+> binop ("cmp", y, x) <+> set (">",  eax) <+> move (eax, z)
+  | ">=" ->
+      move (L (0), eax) <+> binop ("cmp", y, x) <+> set (">=", eax) <+> move (eax, z)
+  | "&&" ->
+      move (L (0), eax) <+> binop ("cmp", L (0), x) <+> set ("!=", eax) <+> move (L (0), edx) <+> binop ("cmp", L (0), y) <+> set ("!=", edx) <+> binop ("&&", edx, eax) <+> move (eax, z)
+  | "!!" ->
+      move (L (0), eax) <+> binop ("cmp", L (0), x) <+> set ("!=", eax) <+> move (L (0), edx) <+> binop ("cmp", L (0), y) <+> set ("!=", edx) <+> binop ("!!", edx, eax) <+> move (eax, z)
+  esac
+}
+
 -- A top-level codegeneration function. Takes a stack machine program
 -- and returns x86 listing as a string
 public fun compileX86 (code) {