Implement control flow compiler

src/Expr.lama

@@ -13,6 +13,28 @@ import State;
 --        Const (int)                |
 --        Binop (string, expr, expr)
 
+public fun evalBinop (left, right, bop) {
+  case bop of
+    "+" -> left + right
+  | "-" -> left - right
+  | "*" -> left * right
+  | "/" -> left / right
+  | "%" -> left % right
+  | "!!" -> left !! right
+  | "&&" -> left && right
+  | "==" -> left == right
+  | "!=" -> left != right
+  | "<=" -> left <= right
+  | "<" -> left < right
+  | ">=" -> left >= right
+  | ">" -> left > right
+  esac
+}
+
 public fun evalExpr (st, expr) {
-  failure ("evalExpr not implemented\n")
+  case expr of 
+    Var (varName) -> st(varName)
+  | Const (n) -> n
+  | Binop (bop, left, right) -> evalBinop(evalExpr(st, left), evalExpr(st, right), bop)
+  esac
 }

src/Parser.lama

@@ -12,14 +12,46 @@ fun inbr (l, p, r) {
   syntax (-l p -r)
 }
 
+fun parens(p) {
+  inbr (s ("("), p, s (")"))
+}
+
+fun binop (l, bop, r) {
+  Binop (bop, l, r)
+}
+
 -- 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"));
+var primary = memo $ eta syntax (x=decimal {Const (stringInt (x))} |
+                                 x=lident  {Var (x)}               |
+                                 inbr[s("("), exp, s(")")]),
+    exp = memo $ eta expr ({
+      [Left, {[s ("!!"), binop]}],
+      [Left, {[s ("&&"), binop]}],
+      [Nona, {[s ("<"), binop], [s ("<="), binop], [s (">"), binop], [s (">="), binop], [s ("=="), binop], [s ("!="), binop]}],
+      [Left, {[s ("+"), binop], [s ("-"), binop]}],
+      [Left, {[s ("*"), binop], [s ("/"), binop], [s ("%"), binop]}]
+    }, primary),
+    ifHead = memo $ eta syntax (kIf condition=exp kThen body=stmts tail=ifTail {If (condition, body, tail)}),
+    ifTail = memo $ eta syntax (kElif condition=exp kThen body=stmts tail=ifTail {If (condition, body, tail)} |
+                                kElse body=stmts kFi {body}                                                   |
+                                kFi {Skip});
+
+var stmt = memo $ eta syntax (
+  kRead x=parens[lident] {Read (x)}                                                                                                 |
+  kWrite x=parens[exp]  {Write (x)}                                                                                                 |
+  kSkip {Skip}                                                                                                                      |
+  target=lident s[":="] value=exp {Assn (target, value)}                                                                            |
+  ifStmt=ifHead {ifStmt}                                                                                                            |
+  kWhile condition=exp kDo body=stmts kOd {While (condition, body)}                                                                 |
+  kDo body=stmts kWhile condition=exp kOd {DoWhile(body, condition)}                                                                |
+  kFor iterator=stmts s[","] condition=exp s[","] step=stmts kDo body=stmts kOd {Seq (iterator, While(condition, Seq(body, step)))}
+);
 
-var stmt = memo $ eta (failure ("statement parsing not implemented\n"));
+var stmts = memo $ eta syntax (
+  stmt |
+  head=stmt s[";"] tail=stmts {Seq (head, tail)}
+);
 
 
 -- Public top-level parser
-public parse = stmt;
+public parse = stmts;

src/SM.lama

@@ -8,6 +8,7 @@ import World;
 import State;
 import Expr;
 import Buffer;
+import Parser;
 
 -- Stack code printer. Takes a list of SM instructions, return its
 -- string representation.
@@ -52,10 +53,48 @@ fun fromLabel (env, lab) {
   env [0] (lab)
 }
 
+fun compileCJmp(znz, lab, env, [(x:t), state, world]) {
+  case znz of
+    ("z") -> if x then [None, [t, state, world]] else [Some (env.fromLabel (lab)), [t, state, world]] fi
+  | ("nz") -> if x then [Some (env.fromLabel (lab)), [t, state, world]] else [None, [t, state, world]] fi
+  esac
+}
+
+fun evalSingle (env, conf@[stack, state, world], instruction) {
+  case instruction of
+    READ -> 
+      case readWorld(world) of
+        [value, newWorld] -> [None, [value:stack, state, newWorld]]
+      esac
+  | WRITE -> 
+      [None, [tl(stack), state, writeWorld(hd(stack), world)]]
+  | BINOP (bop) ->
+      case stack of
+        snd:fst:tail -> [None, [evalBinop(fst, snd, bop):tail, state, world]]
+      esac
+  | LD (varName) ->
+      [None, [state(varName):stack, state, world]]
+  | ST (varName) ->
+      [None, [stack, state <- [varName, hd(stack)], world]]
+  | CONST (n) ->
+      [None, [n:stack, state, world]]
+  | LABEL (_) -> [None, conf]
+  | JMP (lab) -> [Some (env.fromLabel (lab)), conf]
+  | CJMP (znz, lab) -> compileCJmp (znz, lab, env, conf)
+  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")
+  case insns of 
+    {} -> c
+  | ins:insns -> 
+      case evalSingle(env, c, ins) of
+        [None, conf] -> eval(env, conf, insns)
+      | [Some (insns), conf] -> eval(env, conf, insns)
+      esac
+  esac
 }
 
 -- Runs a stack machine for a given input and a given program, returns an output
@@ -96,7 +135,11 @@ fun genLabels (env, n) {
 -- 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 (varName) -> singletonBuffer (LD (varName))
+  | Const (num) -> singletonBuffer (CONST (num))
+  | Binop (bop, left, right) -> compileExpr(left) <+> compileExpr(right) <+ BINOP (bop) 
+  esac
 }
 
 -- Compiles a statement into a stack machine code.
@@ -137,7 +180,24 @@ public fun compileSM (stmt) {
                   esac
              esac
         esac
-    | _              -> failure ("compileSM not implemented\n")
+    | If    (condition, ifBranch, elseBranch) ->
+        case env.genLabel of
+          [elseBranchLab, env] ->
+            case compile (lab, env, ifBranch) of
+              [_, env, ifBranchCode] ->
+                case compile (lab, env, elseBranch) of
+                  [_, env, elseBranchCode] -> [true, env, compileExpr (condition) <+ CJMP ("z", elseBranchLab) <+> ifBranchCode <+ JMP (lab) <+ LABEL (elseBranchLab) <+> elseBranchCode]
+                esac
+            esac
+        esac
+    | While (condition, body) ->
+        case env.genLabels (2) of
+          [conditionLab, bodyLab, env] ->
+            case compile (conditionLab, env, body) of
+              [_, env, bodyCode] -> [true, env, singletonBuffer (LABEL (conditionLab)) <+> compileExpr (condition) <+ CJMP ("z", lab) <+> bodyCode <+ JMP (conditionLab)]
+            esac
+        esac
+    | DoWhile (body, condition) -> compile (lab, env, Seq (body, While (condition, body)))
     esac
   }  
 

src/Stmt.lama

@@ -20,7 +20,30 @@ import World;
 --        DoWhile (stmt, expr)
 
 fun eval (c, stmt) {
-  failure ("Stmt eval not implemented\n")
+  var state = c.fst;
+  var world = c.snd;
+
+  case stmt of
+    Assn (varName, expr) -> [state <- [varName, evalExpr(state, expr)], world]
+  | Seq (stmt1, stmt2) -> eval(eval(c, stmt1), stmt2)
+  | Skip -> c
+  | Read (varName) -> 
+      case readWorld(world) of
+        [value, newWorld] -> [state <- [varName, value], newWorld]
+      esac
+  | Write (expr) -> [state, writeWorld(evalExpr(state, expr), world)]
+  | If (condition, body, elsePart) ->
+    case evalExpr(state, condition) of
+      0 -> eval([state, world], elsePart)
+    | _ -> eval([state, world], body)
+    esac
+  | node@While (condition, body) ->
+    case evalExpr(state, condition) of
+      0 -> [state, world]
+    | _ -> eval(eval([state, world], body), node)
+    esac
+  | DoWhile(body, condition) -> eval(eval(c, body), While(condition, body))
+  esac
 }
 
 -- Evaluates a program with a given input and returns an output

src/X86.lama

@@ -299,6 +299,81 @@ fun suffix (op) {
   esac
 }
 
+fun isComparison(bop) {
+  case bop of 
+    "<=" -> true
+  | "<" -> true
+  | ">=" -> true
+  | ">" -> true
+  | "==" -> true
+  | "!=" -> true
+  | _ -> false
+  esac
+}
+
+fun compileComparison(cmp, left, right, env, code) {
+  case env.allocate of 
+    [s, newEnv] -> [newEnv, code <+> move (left, eax) <+ Mov (L(0), edx) <+ Binop ("cmp", right, eax) <+ Set (suffix (cmp), "%dl") <+> move (edx, s)]
+  esac
+}
+
+fun isDivMod(bop) {
+  case bop of
+    "/" -> true
+  | "%" -> true
+  | _ -> false
+  esac
+}
+
+fun compileDivMod(bop, left, right, env, code) {
+  var commonPart = code <+> move (left, eax) <+ Cltd <+ IDiv (right);
+  case env.allocate of
+    [s, newEnv] -> 
+      case bop of 
+        "/" -> [newEnv, commonPart <+> move (eax, s)]
+      | "%" -> [newEnv, commonPart <+> move (edx, s)]
+      esac
+  esac
+}
+
+fun isLogical(bop) {
+  case bop of
+    "&&" -> true
+  | "!!" -> true
+  | _ -> false
+  esac
+}
+
+fun compileLogical(bop, left, right, env, code) {
+  case env.allocate of 
+    [s, newEnv] -> [newEnv, code <+ Mov (L(0), eax) <+ Binop ("cmp", eax, left) <+ Set (suffix ("!="), "%al")
+                                 <+ Mov (L(0), edx) <+ Binop ("cmp", edx, right) <+ Set (suffix ("!="), "%dl") <+ Binop (bop, edx, eax) <+> move (eax, s)]
+  esac
+}
+
+fun compileSimpleBinaryOperation(bop, left, right, env, code) {
+  case env.allocate of
+    [s, newEnv] -> [newEnv, code <+> move (left, eax) <+ Binop (bop, right, eax) <+> move (eax, s)]
+  esac
+}
+
+fun compileBinaryOperation(bop, env, code) {
+  fun compileImpl([right, left, newEnv]) {
+    if isComparison (bop)
+    then compileComparison (bop, left, right, newEnv, code)
+    elif isDivMod (bop)
+    then compileDivMod (bop, left, right, newEnv, code)
+    elif isLogical (bop)
+    then compileLogical (bop, left, right, newEnv, code)
+    else compileSimpleBinaryOperation (bop, left, right, newEnv, code)
+    fi
+  }
+
+  case env.pop2 of
+    result -> compileImpl(result)      
+  esac
+}
+
 -- 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) {
@@ -314,6 +389,25 @@ fun compile (env, code) {
           case env.pop of
             [s, env] -> [env, code <+> genCallF(env, "Lwrite", singletonBuffer(Push(s)), singletonBuffer(Pop (eax)))]
           esac
+      | LD (x) ->
+          case env.addGlobal (x).allocate of
+	    [s, env] -> [env, code <+> move (env.loc (x), s)]
+	  esac
+      | ST (x) ->
+          case env.addGlobal (x).pop of
+	    [s, env] -> [env, code <+> move (s, env.loc (x))]
+	  esac
+      | BINOP (bop) -> compileBinaryOperation(bop, env, code)
+      | CONST (n) -> 
+          case env.allocate of
+            [s, env] -> [env, code <+> move (L (n), s)]
+          esac
+      | LABEL (lab) -> [env, code <+ Label (lab)]
+      | JMP (lab) -> [env, code <+ Jmp (lab)]
+      | CJMP (znz, lab) -> 
+          case env.pop of
+            [s, env] -> [env, code <+ Binop ("cmp", L(0), s) <+ CJmp (znz, lab)]
+          esac
       | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string)
         esac
     }, [env, emptyBuffer ()], code)}