Control statement (interpreter, SM, x86)

src/SM.ml

@@ -8,8 +8,11 @@ open Language
 (* read to stack                   *) | READ
 (* write from stack                *) | WRITE
 (* load a variable to the stack    *) | LD    of string
-(* store a variable from the stack *) | ST    of string with show
-
+(* store a variable from the stack *) | ST    of string
+(* a label                         *) | LABEL of string
+(* unconditional jump              *) | JMP   of string                                                                                                                
+(* conditional jump                *) | CJMP  of string * string with show
+                                                   
 (* The type for the stack machine program *)                                                               
 type prg = insn list
 
@@ -20,22 +23,25 @@ type config = int list * Stmt.config
 
 (* Stack machine interpreter
 
-     val eval : config -> prg -> config
+     val eval : env -> config -> prg -> config
 
-   Takes a configuration and a program, and returns a configuration as a result
- *)                         
-let rec eval ((stack, ((st, i, o) as c)) as conf) = function
+   Takes an environment, a configuration and a program, and returns a configuration as a result. The
+   environment is used to locate a label to jump to (via method env#labeled <label_name>)
+*)                         
+let rec eval env ((stack, ((st, i, o) as c)) as conf) = function
 | [] -> conf
 | insn :: prg' ->
-   eval 
-     (match insn with
-      | BINOP op -> let y::x::stack' = stack in (Expr.to_func op x y :: stack', c)
-      | READ     -> let z::i'        = i     in (z::stack, (st, i', o))
-      | WRITE    -> let z::stack'    = stack in (stack', (st, i, o @ [z]))
-      | CONST i  -> (i::stack, c)
-      | LD x     -> (st x :: stack, c)
-      | ST x     -> let z::stack'    = stack in (stack', (Expr.update x z st, i, o))
-     ) prg'
+   (match insn with
+    | BINOP op    -> let y::x::stack' = stack in eval env (Expr.to_func op x y :: stack', c) prg'
+    | READ        -> let z::i' = i     in eval env (z::stack, (st, i', o)) prg'
+    | WRITE       -> let z::stack' = stack in eval env (stack', (st, i, o @ [z])) prg'
+    | CONST i     -> eval env (i::stack, c) prg'
+    | LD x        -> eval env (st x :: stack, c) prg'
+    | ST x        -> let z::stack' = stack in eval env (stack', (Expr.update x z st, i, o)) prg'
+    | LABEL _     -> eval env conf prg'
+    | JMP   l     -> eval env conf (env#labeled l)
+    | CJMP (c, l) -> let x::stack' = stack in eval env conf (if (c = "z" && x = 0) || (c = "nz" && x <> 0) then env#labeled l else prg')
+   ) 
 
 (* Top-level evaluation
 
@@ -43,7 +49,15 @@ let rec eval ((stack, ((st, i, o) as c)) as conf) = function
 
    Takes a program, an input stream, and returns an output stream this program calculates
 *)
-let run p i = let (_, (_, _, o)) = eval ([], (Expr.empty, i, [])) p in o
+let run p i =
+  let module M = Map.Make (String) in
+  let rec make_map m = function
+  | []              -> m
+  | (LABEL l) :: tl -> make_map (M.add l tl m) tl
+  | _ :: tl         -> make_map m tl
+  in
+  let m = make_map M.empty p in
+  let (_, (_, _, o)) = eval (object method labeled l = M.find l m end) ([], (Expr.empty, i, [])) p in o
 
 (* Stack machine compiler
 
@@ -52,14 +66,39 @@ let run p i = let (_, (_, _, o)) = eval ([], (Expr.empty, i, [])) p in o
    Takes a program in the source language and returns an equivalent program for the
    stack machine
 *)
-let rec compile =
+let compile p =
   let rec expr = function
   | Expr.Var   x          -> [LD x]
   | Expr.Const n          -> [CONST n]
   | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op]
   in
-  function
-  | Stmt.Seq (s1, s2)  -> compile s1 @ compile s2
-  | Stmt.Read x        -> [READ; ST x]
-  | Stmt.Write e       -> expr e @ [WRITE]
-  | Stmt.Assign (x, e) -> expr e @ [ST x]
+  let rec compile' l env = function  
+  | Stmt.Read    x          -> env, false, [READ; ST x]
+  | Stmt.Write   e          -> env, false, expr e @ [WRITE]
+  | Stmt.Assign (x, e)      -> env, false, expr e @ [ST x]
+  | Stmt.Skip               -> env, false, []
+
+  | Stmt.Seq    (s1, s2)    -> let l2, env = env#get_label in
+                               let env, flag1, s1 = compile' l2 env s1 in
+                               let env, flag2, s2 = compile' l  env s2 in
+                               env, flag2, s1 @ (if flag1 then [LABEL l2] else []) @ s2                                      
+
+  | Stmt.If     (c, s1, s2) -> let l2, env = env#get_label in
+                               let env, flag1, s1 = compile' l env s1 in
+                               let env, flag2, s2 = compile' l env s2 in
+                               env, true, expr c @ [CJMP ("z", l2)] @ s1 @ (if flag1 then [] else [JMP l]) @ [LABEL l2] @ s2 @ (if flag2 then [] else [JMP l])
+                               
+  | Stmt.While  (c, s)      -> let loop, env = env#get_label in
+                               let cond, env = env#get_label in
+                               let env, _, s = compile' cond env s in
+                               env, false, [JMP cond; LABEL loop] @ s @ [LABEL cond] @ expr c @ [CJMP ("nz", loop)]
+  in
+  let env =
+    object
+      val label = 0
+      method get_label = "L_" ^ string_of_int label, {< label = label + 1 >}
+    end
+  in
+  let lend, env = env#get_label in
+  let _, flag, code = compile' lend env p in
+  if flag then code @ [LABEL lend] else code