Begin translation module

[tiger.ml.git] / compiler / src / lib / tiger / tiger_translate.ml

diff --git a/compiler/src/lib/tiger/tiger_translate.ml b/compiler/src/lib/tiger/tiger_translate.ml
index 7f71711..483335a 100644 (file)
--- a/compiler/src/lib/tiger/tiger_translate.ml
+++ b/compiler/src/lib/tiger/tiger_translate.ml
@@ -1 +1,102 @@
-type exp = unit
+module List = ListLabels
+
+module Frame = Tiger_frame
+module Temp  = Tiger_temp
+module T     = Tiger_tree
+
+module Level = struct
+  type t =
+    { parent  : t option
+    ; name    : Temp.Label.t
+    ; formals : bool list
+    ; frame   : Frame.t
+    }
+
+  let init =
+    let name    = Temp.Label.gen () in
+    let formals = [] in
+    { parent  = None
+    ; name
+    ; formals
+    ; frame   = Frame.make ~name ~formals
+    }
+
+  let next t ~name  ~formals =
+    (* Adding the extra parameter for the static link. See p. 142 *)
+    let formals = true :: formals in
+    { parent = Some t
+    ; name
+    ; formals
+    ; frame = Frame.make ~name ~formals
+    }
+
+  let formals = function {formals; _} ->
+    formals
+
+  let frame = function {frame; _} ->
+    frame
+end
+
+type gen_stm =
+  (Tiger_temp.Label.t * Tiger_temp.Label.t) -> Tiger_tree.stm
+
+type exp =
+  | Ex of Tiger_tree.exp
+  | Nx of Tiger_tree.stm
+  | Cx of gen_stm
+
+type access =
+  (* must know about static links *)
+  { level        : Level.t
+  ; frame_access : Frame.access
+  }
+
+let alloc_local ~level ~escapes =
+  { level
+  ; frame_access = Frame.alloc_local (Level.frame level) ~escapes
+  }
+
+let formals ~level =
+  (* FIXME: This seems wrong. Should we call Frame.formals? *)
+  List.map (Level.formals level) ~f:(fun escapes ->
+    alloc_local ~level ~escapes
+  )
+
+let rec seq = function
+  (* TODO: Is appending 0 OK? How else can the empty case be handled? *)
+  | []      -> T.EXP (T.CONST 0)
+  | s :: ss -> T.SEQ (s, seq ss)
+
+let cond_stm gen_stm =
+  let t = Temp.Label.gen () in
+  let f = Temp.Label.gen () in
+  let r = Temp.Temp.gen () in
+  let stms =
+    [ T.MOVE (T.TEMP r, T.CONST 1)
+    ; gen_stm (t, f)
+    ; T.LABEL f
+    ; T.MOVE (T.TEMP r, T.CONST 0)
+    ; T.LABEL t
+    ]
+  in
+  (seq stms, T.TEMP r)
+
+let unEx = function
+  | Ex exp -> exp
+  | Nx stm -> T.ESEQ (stm, T.CONST 0)
+  | Cx gen ->
+      let stm, exp = cond_stm gen in
+      T.ESEQ (stm, exp)
+
+let unNx = function
+  | Ex exp -> T.EXP exp
+  | Nx stm -> stm
+  | Cx gen -> fst (cond_stm gen)
+
+let unCx = function
+  (* "should never occur in compiling a well typed Tiger program" p.154 *)
+  | Nx _ -> assert false
+  | Ex e -> fun (_, _) -> T.EXP e  (* TODO: Is this right? *)
+  | Cx g -> g
+
+let dummy__FIXME = Ex (T.CONST 0)