Homework 3.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/Parser.lama

@@ -11,13 +11,31 @@ fun inbr (l, p, r) {
   syntax (-l p -r)
 }
 
+fun inbrP (p) {
+  inbr (s ("("), p, s (")"))
+}
+
 -- Primary expression
 var primary = memo $ eta syntax (x=decimal {Const (stringInt (x))} |
                                  x=lident  {Var (x)}               |
-                                 inbr[s("("), exp, s(")")]),
-      exp = memo $ eta (failure ("expression parsing not implemented\n"));
-
-var stmt = memo $ eta (failure ("statement parsing not implemented\n"));
+                                 inbrP[exp]),
+    exp = memo $ eta (expr ({[Left,  {[s ("!!"), fun (l, _, r) { Binop ("!!", l, r) }]}],
+                             [Left,  {[s ("&&"), fun (l, _, r) { Binop ("&&", l, r) }]}],
+                             [Nona,  {[s ("=="), fun (l, _, r) { Binop ("==", l, r) }],
+                                      [s ("!="), fun (l, _, r) { Binop ("!=", l, r) }],
+                                      [s ("<="), fun (l, _, r) { Binop ("<=", l, r) }],
+                                      [s ("<"),  fun (l, _, r) { Binop ("<",  l, r) }],
+                                      [s (">="), fun (l, _, r) { Binop (">=", l, r) }],
+                                      [s (">"),  fun (l, _, r) { Binop (">",  l, r) }]}],
+                             [Left,  {[s ("+"),  fun (l, _, r) { Binop ("+",  l, r) }],
+                                      [s ("-"),  fun (l, _, r) { Binop ("-",  l, r) }]}],
+                             [Left,  {[s ("*"),  fun (l, _, r) { Binop ("*",  l, r) }],
+                                      [s ("/"),  fun (l, _, r) { Binop ("/",  l, r) }],
+                                      [s ("%"),  fun (l, _, r) { Binop ("%",  l, r) }]}]}, primary)),
+    baseStmt = memo $ eta syntax (l=lident -s[":="] r=exp { Assn (l, r) } |
+                                  -kRead v=inbrP[lident] { Read (v) } |
+                                  -kWrite e=inbrP[exp] { Write (e) }),
+    stmt = memo $ eta (expr ({[Right, {[s (";"), fun (l, _, r) { Seq (l, r) }]}]}, baseStmt));
 
 
 -- Public top-level parser

src/SM.lama

@@ -24,27 +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
+-- 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

@@ -254,25 +254,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) {
@@ -288,11 +317,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 driver's environment and a stack machine program,
 -- compiles the program into machine code, and compiles the machine code into an executable
 public fun compileX86 (args, code) {
@@ -303,7 +383,7 @@ public fun compileX86 (args, code) {
                        #val  -> "../runtime/"
                      | path  -> path
                      esac ++ "/runtime.o";
-       
+
        fwrite (asmFile,
                map (insnString, 
                     getBuffer $
@@ -316,7 +396,7 @@ public fun compileX86 (args, code) {
                         epilogue ()
                       )
                     ).stringcat);
-                    
+
        system ({"gcc -g -m32 -o ", args.getBaseName, " ", runtime, " ", asmFile}.stringcat)
   esac
 }