fmt

flap/src/fopix/hobixToFopix.ml

@@ -8,9 +8,7 @@ module S = Source.AST
 module Target = Fopix
 module T = Target.AST
 
-(**
+(** The translation from Hobix to Fopix turns anonymous
-
-   The translation from Hobix to Fopix turns anonymous
     lambda-abstractions into toplevel functions and applications into
     function calls. In other words, it translates a high-level language
     (like OCaml) into a first order language (like C).
@@ -63,63 +61,59 @@ module T = Target.AST
 
     (Remark: Did you notice that this form of "auto-application" is
     very similar to the way "this" is defined in object-oriented
-   programming languages?)
+    programming languages?) *)
 
-*)
+(** Helpers functions. *)
 
-(**
+let error pos msg = Error.error "compilation" pos msg
-   Helpers functions.
-*)
-
-let error pos msg =
-  Error.error "compilation" pos msg
 
 let make_fresh_variable =
   let r = ref 0 in
-  fun () -> incr r; T.Id (Printf.sprintf "_%d" !r)
+  fun () ->
-
+    incr r;
+    T.Id (Printf.sprintf "_%d" !r)
+;;
 
 let make_fresh_function_identifier =
   let r = ref 0 in
-  fun () -> incr r; T.FunId (Printf.sprintf "_%d" !r)
+  fun () ->
+    incr r;
+    T.FunId (Printf.sprintf "_%d" !r)
+;;
 
 let define e f =
   let x = make_fresh_variable () in
   T.Define (x, e, f x)
+;;
 
 let rec defines ds e =
   match ds with
-    | [] ->
+  | [] -> e
-      e
+  | (x, d) :: ds -> T.Define (x, d, defines ds e)
-    | (x, d) :: ds ->
+;;
-      T.Define (x, d, defines ds e)
 
-let seq a b =
+let seq a b = define a (fun _ -> b)
-  define a (fun _ -> b)
 
 let rec seqs = function
   | [] -> assert false
   | [ x ] -> x
   | x :: xs -> seq x (seqs xs)
+;;
 
-let allocate_block e =
+let allocate_block e = T.(FunCall (FunId "allocate_block", [ e ]))
-  T.(FunCall (FunId "allocate_block", [e]))
+let write_block e i v = T.(FunCall (FunId "write_block", [ e; i; v ]))
-
+let read_block e i = T.(FunCall (FunId "read_block", [ e; i ]))
-let write_block e i v =
+let lint i = T.(Literal (LInt (Int64.of_int i)))
-  T.(FunCall (FunId "write_block", [e; i; v]))
-
-let read_block e i =
-  T.(FunCall (FunId "read_block", [e; i]))
-
-let lint i =
-  T.(Literal (LInt (Int64.of_int i)))
-
 
 (** [free_variables e] returns the list of free variables that
     occur in [e].*)
 let free_variables =
   let module M =
-    Set.Make (struct type t = S.identifier let compare = compare end)
+    Set.Make (struct
+      type t = S.identifier
+
+      let compare = compare
+    end)
   in
   let rec unions f = function
     | [] -> M.empty
@@ -127,33 +121,27 @@ let free_variables =
     | s :: xs -> M.union (f s) (unions f xs)
   in
   let rec fvs = function
-    | S.Literal _ ->
+    | S.Literal _ -> M.empty
-       M.empty
+    | S.Variable x -> M.singleton x
-    | S.Variable x ->
+    | S.While (cond, e) -> failwith "Students! This is your job!"
-       M.singleton x
+    | S.Define (vd, a) -> failwith "Students! This is your job!"
-    | S.While (cond, e) ->
+    | S.ReadBlock (a, b) -> unions fvs [ a; b ]
-       failwith "Students! This is your job!"
+    | S.Apply (a, b) -> unions fvs (a :: b)
-    | S.Define (vd, a) ->
+    | S.WriteBlock (a, b, c) | S.IfThenElse (a, b, c) -> unions fvs [ a; b; c ]
-       failwith "Students! This is your job!"
+    | S.AllocateBlock a -> fvs a
-    | S.ReadBlock (a, b) ->
+    | S.Fun (xs, e) -> failwith "Students! This is your job!"
-       unions fvs [a; b]
-    | S.Apply (a, b) ->
-       unions fvs (a :: b)
-    | S.WriteBlock (a, b, c) | S.IfThenElse (a, b, c) ->
-       unions fvs [a; b; c]
-    | S.AllocateBlock a ->
-       fvs a
-    | S.Fun (xs, e) ->
-       failwith "Students! This is your job!"
     | S.Switch (a, b, c) ->
-       let c = match c with None -> [] | Some c -> [c] in
+      let c =
-       unions fvs (a :: ExtStd.Array.present_to_list b @ c)
+        match c with
+        | None -> []
+        | Some c -> [ c ]
+      in
+      unions fvs ((a :: ExtStd.Array.present_to_list b) @ c)
   in
   fun e -> M.elements (fvs e)
+;;
 
-(**
+(** A closure compilation environment relates an identifier to the way
-
-    A closure compilation environment relates an identifier to the way
     it is accessed in the compiled version of the function's
     body.
 
@@ -170,45 +158,35 @@ let free_variables =
     Indeed, "x" is a local variable that can be accessed directly in
     the compiled version of this function's body whereas "y" is a free
     variable whose value must be retrieved from the closure's
-    environment.
+    environment. *)
-
+type environment =
-*)
+  { vars : (HobixAST.identifier, FopixAST.expression) Dict.t
-type environment = {
+  ; externals : (HobixAST.identifier, int) Dict.t
-    vars : (HobixAST.identifier, FopixAST.expression) Dict.t;
-    externals : (HobixAST.identifier, int) Dict.t;
   }
 
-let initial_environment () =
+let initial_environment () = { vars = Dict.empty; externals = Dict.empty }
-  { vars = Dict.empty; externals = Dict.empty }
+let bind_external id n env = { env with externals = Dict.insert id n env.externals }
-
+let is_external id env = Dict.lookup id env.externals <> None
-let bind_external id n env =
+let reset_vars env = { env with vars = Dict.empty }
-  { env with externals = Dict.insert id n env.externals }
-
-let is_external id env =
-  Dict.lookup id env.externals <> None
-
-let reset_vars env =
-   { env with vars = Dict.empty }
 
 (** Precondition: [is_external id env = true]. *)
 let arity_of_external id env =
   match Dict.lookup id env.externals with
   | Some n -> n
   | None -> assert false (* By is_external. *)
-
+;;
 
 (** [translate p env] turns an Hobix program [p] into a Fopix program
     using [env] to retrieve contextual information. *)
 let translate (p : S.t) env =
   let rec program env defs =
     let env, defs = ExtStd.List.foldmap definition env defs in
-    (List.flatten defs, env)
+    List.flatten defs, env
   and definition env = function
     | S.DeclareExtern (id, n) ->
       let env = bind_external id n env in
-       (env, [T.ExternalFunction (function_identifier id, n)])
+      env, [ T.ExternalFunction (function_identifier id, n) ]
-    | S.DefineValue vd ->
+    | S.DefineValue vd -> env, value_definition env vd
-       (env, value_definition env vd)
   and value_definition env = function
     | S.SimpleValue (x, e) ->
       let fs, e = expression (reset_vars env) e in
@@ -216,12 +194,9 @@ let translate (p : S.t) env =
     | S.RecFunctions fdefs ->
       let fs, defs = define_recursive_functions fdefs in
       fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs
-
+  and define_recursive_functions rdefs = failwith "Students! This is your job!"
-  and define_recursive_functions rdefs =
-       failwith "Students! This is your job!"
   and expression env = function
-    | S.Literal l ->
+    | S.Literal l -> [], T.Literal (literal l)
-      [], T.Literal (literal l)
     | S.While (cond, e) ->
       let cfs, cond = expression env cond in
       let efs, e = expression env e in
@@ -232,66 +207,57 @@ let translate (p : S.t) env =
         | None -> T.Variable (identifier x)
         | Some e -> e
       in
-      ([], xc)
+      [], xc
-    | S.Define (vdef, a) ->
+    | S.Define (vdef, a) -> failwith "Students! This is your job!"
-         failwith "Students! This is your job!"
+    | S.Apply (a, bs) -> failwith "Students! This is your job!"
-    | S.Apply (a, bs) ->
-         failwith "Students! This is your job!"
     | S.IfThenElse (a, b, c) ->
       let afs, a = expression env a in
       let bfs, b = expression env b in
       let cfs, c = expression env c in
       afs @ bfs @ cfs, T.IfThenElse (a, b, c)
-
+    | S.Fun (x, e) -> failwith "Students! This is your job!"
-    | S.Fun (x, e) ->
-         failwith "Students! This is your job!"
     | S.AllocateBlock a ->
       let afs, a = expression env a in
-      (afs, allocate_block a)
+      afs, allocate_block a
     | S.WriteBlock (a, b, c) ->
       let afs, a = expression env a in
       let bfs, b = expression env b in
       let cfs, c = expression env c in
-      afs @ bfs @ cfs,
+      afs @ bfs @ cfs, T.FunCall (T.FunId "write_block", [ a; b; c ])
-      T.FunCall (T.FunId "write_block", [a; b; c])
     | S.ReadBlock (a, b) ->
       let afs, a = expression env a in
       let bfs, b = expression env b in
-      afs @ bfs,
+      afs @ bfs, T.FunCall (T.FunId "read_block", [ a; b ])
-      T.FunCall (T.FunId "read_block", [a; b])
     | S.Switch (a, bs, default) ->
       let afs, a = expression env a in
       let bsfs, bs =
-        ExtStd.List.foldmap (fun bs t ->
+        ExtStd.List.foldmap
+          (fun bs t ->
             match ExtStd.Option.map (expression env) t with
-                    | None -> (bs, None)
+            | None -> bs, None
-                    | Some (bs', t') -> (bs @ bs', Some t')
+            | Some (bs', t') -> bs @ bs', Some t')
-                  ) [] (Array.to_list bs)
+          []
+          (Array.to_list bs)
       in
-      let dfs, default = match default with
+      let dfs, default =
+        match default with
         | None -> [], None
-        | Some e -> let bs, e = expression env e in bs, Some e
+        | Some e ->
+          let bs, e = expression env e in
+          bs, Some e
       in
-      afs @ bsfs @ dfs,
+      afs @ bsfs @ dfs, T.Switch (a, Array.of_list bs, default)
-      T.Switch (a, Array.of_list bs, default)
-
-
   and expressions env = function
-    | [] ->
+    | [] -> [], []
-       [], []
     | e :: es ->
       let efs, es = expressions env es in
       let fs, e = expression env e in
       fs @ efs, e :: es
-
   and literal = function
     | S.LInt x -> T.LInt x
     | S.LString s -> T.LString s
     | S.LChar c -> T.LChar c
-
   and identifier (S.Id x) = T.Id x
-
+  and function_identifier (S.Id x) = T.FunId x in
-  and function_identifier (S.Id x) = T.FunId x
-
-  in
   program env p
+;;