Make heptc compile

compiler/heptagon/analysis/typing.ml

@@ -561,8 +561,8 @@ let rec typing const_env h e =
             List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in
           let m = build_subst node_params params in
           let expected_ty_list =
-            List.map (subst_type_vars m) expected_ty_list in
-          let result_ty_list = List.map (subst_type_vars m) result_ty_list in
+            List.map (simplify m) expected_ty_list in
+          let result_ty_list = List.map (simplify m) result_ty_list in
           let typed_n = expect_static_exp const_env (Tid Initial.pint) n in
           let ty, typed_e_list = typing_iterator const_env h it n
             expected_ty_list result_ty_list e_list in

compiler/heptagon/main/hept_compiler.ml

@@ -11,6 +11,7 @@
 open Misc
 open Compiler_utils
 open Location
+open Global_printer
 
 let pp p = if !verbose then Hept_printer.print stdout p
 
@@ -39,7 +40,7 @@ let compile_impl pp p =
   (*let p = pass "Typing" true Typing.program p pp in*)
   let p = silent_pass "Statefullness check" true Statefull.program p in
 
-  if !print_types then print_interface Format.std_formatter l;
+  if !print_types then print_interface Format.std_formatter p;
 
   (* Causality check *)
   let p = silent_pass "Causality check" true Causality.program p in
@@ -95,7 +96,7 @@ let compile_interface modname filename =
     if !print_types then print_interface Format.std_formatter l;
 
 
-    Modules.write itc;
+      output_value itc (Modules.current_module ());
 
     close_all_files ()
   with

compiler/heptagon/parsing/hept_scoping.ml

@@ -379,7 +379,7 @@ let params_of_var_decs local_const =
 
 let args_of_var_decs local_const =
   List.map (fun vd -> Signature.mk_arg
-                        (Some (name vd.v_name))
+                        (Some vd.v_name)
                         (translate_type vd.v_loc local_const vd.v_type))
 
 let translate_node node =

compiler/main/hept2mls.ml

@@ -48,7 +48,7 @@ struct
   type env =
     | Eempty
     | Ecomp of env * IdentSet.t
-    | Eon of env * longname * ident
+    | Eon of env * constructor_name * ident
 
   let empty = Eempty
 

compiler/main/heptc.ml

@@ -44,7 +44,7 @@ let compile_impl modname filename =
 
     (* Process the Heptagon AST *)
     let p = compile_impl pp p in
-    Modules.write_current_module itc;
+    output_value itc (Modules.current_module ());
 
     (* Set pretty printer to the Minils one *)
     let pp = Mls_compiler.pp in

compiler/minils/transformations/callgraph.ml

@@ -8,6 +8,7 @@ open Static
 open Global_mapfold
 open Mls_mapfold
 open Minils
+open Global_printer
 
 module Error =
 struct
@@ -32,7 +33,7 @@ end
 module Param_instances :
 sig
   type key = private static_exp (** Fully instantiated param *)
-  type env = key NamesEnv.t
+  type env = key QualEnv.t
   val instantiate: env -> static_exp list -> key list
   val get_node_instances : QualEnv.key -> key list list
   val add_node_instance : QualEnv.key -> key list -> unit
@@ -44,7 +45,7 @@ sig
 end =
 struct
   type key = static_exp
-  type env = key NamesEnv.t
+  type env = key QualEnv.t
 
   (** An instance is a list of instantiated params *)
   type instance = key list
@@ -121,7 +122,7 @@ struct
 
   (** Build an environment by instantiating the passed params *)
   let build env params_names params_values =
-    List.fold_left2 (fun m { p_name = n } v -> NamesEnv.add n v m)
+    List.fold_left2 (fun m { p_name = n } v -> QualEnv.add (local_qn n) v m)
       env params_names (instantiate env params_values)
 
 
@@ -133,10 +134,10 @@ struct
     let static_exp funs m se =
       let se, _ = Global_mapfold.static_exp funs m se in
       let se = match se.se_desc with
-        | Svar { qual = q; name = n } ->
-            if q = local_qualname
+        | Svar q ->
+            if q.qual = local_qualname
             then (* This var is a static parameter, it has to be instanciated *)
-              (try NamesEnv.find n m
+              (try QualEnv.find q m
                with Not_found ->
                 Format.eprintf "local param not local";
                 assert false;)
@@ -171,17 +172,17 @@ struct
       let funs =
         { Mls_mapfold.defaults with edesc = edesc;
                                     global_funs = global_funs } in
-      let m = build NamesEnv.empty n.n_params params in
+      let m = build QualEnv.empty n.n_params params in
       let n, _ = Mls_mapfold.node_dec_it funs m n in
 
       (* Add to the global environment the signature of the new instance *)
-      let { info = node_sig } = find_value n.n_name in
+      let node_sig = find_value n.n_name in
       let node_sig, _ = Global_mapfold.node_it global_funs m node_sig in
       let node_sig = { node_sig with node_params = [];
                                      node_params_constraints = [] } in
       (* Find the name that was associated to this instance *)
       let ln = node_for_params_call n.n_name params in
-      Modules.add_value_by_longname ln node_sig;
+      Modules.add_value ln node_sig;
       { n with n_name = ln; n_params = []; n_params_constraints = []; }
 
     let node_dec modname n =
@@ -211,7 +212,7 @@ let load_object_file modname =
   Modules.open_module modname;
   let name = String.uncapitalize modname in
     try
-      let filename = Modules.findfile (name ^ ".epo") in
+      let filename = Misc.findfile (name ^ ".epo") in
       let ic = open_in_bin filename in
         try
           let p:program = input_value ic in
@@ -230,7 +231,7 @@ let load_object_file modname =
                         Please recompile %s.ept first.@." filename name;
               raise Error
     with
-      | Modules.Cannot_find_file(filename) ->
+      | Misc.Cannot_find_file(filename) ->
           Format.eprintf "Cannot find the object file '%s'.@."
             filename;
           raise Error
@@ -285,7 +286,7 @@ let called_nodes ln =
 let rec call_node (ln, params) =
   (* First, add the instance for this node *)
   let n = node_by_longname ln in
-  let m = build NamesEnv.empty n.n_params params in
+  let m = build QualEnv.empty n.n_params params in
 (*  List.iter check_no_static_var params; *)
   add_node_instance ln params;
 

compiler/minils/transformations/itfusion.ml

@@ -8,29 +8,29 @@ open Minils
 
 (* Functions to temporarily store anonymous nodes*)
 let mk_fresh_node_name () =
-  longname (Idents.name (Idents.fresh "_n_"))
+  current_qual (Idents.name (Idents.fresh "_n_"))
 
-let anon_nodes = ref LongNameEnv.empty
+let anon_nodes = ref QualEnv.empty
 
 let add_anon_node inputs outputs locals eqs =
   let n = mk_fresh_node_name () in
   let nd = mk_node ~input:inputs ~output:outputs ~local:locals
-    ~eq:eqs (shortname n) in
-  anon_nodes := LongNameEnv.add n nd !anon_nodes;
+    ~eq:eqs n in
+  anon_nodes := QualEnv.add n nd !anon_nodes;
   n
 
 let replace_anon_node n nd =
-  anon_nodes := LongNameEnv.add n nd !anon_nodes
+  anon_nodes := QualEnv.add n nd !anon_nodes
 
 let find_anon_node n =
-  LongNameEnv.find n !anon_nodes
+  QualEnv.find n !anon_nodes
 
 let is_anon_node n =
-  LongNameEnv.mem n !anon_nodes
+  QualEnv.mem n !anon_nodes
 
 let are_equal n m =
-  let n = simplify NamesEnv.empty n in
-  let m = simplify NamesEnv.empty m in
+  let n = simplify QualEnv.empty n in
+  let m = simplify QualEnv.empty m in
     n = m
 
 let pat_of_vd_list l =
@@ -56,7 +56,7 @@ let get_node_inp_outp app = match app.a_op with
       nd.n_input, nd.n_output
   | Enode f | Efun f ->
       (* it is a regular node*)
-    let { info = ty_desc } = find_value f in
+    let ty_desc = find_value f in
     let new_inp = List.map vd_of_arg ty_desc.node_outputs in
     let new_outp = List.map vd_of_arg ty_desc.node_outputs in
       new_inp, new_outp

compiler/minils/transformations/schedule.ml

@@ -77,6 +77,7 @@ let eqs funs () eq_list =
   let eqs, () = Mls_mapfold.eqs funs () eq_list in
     schedule eqs, ()
 
+let edesc funs () = function
   | Eiterator(it, ({ a_op = Enode f } as app),
               n, e_list, r) when Itfusion.is_anon_node f ->
     let nd = Itfusion.find_anon_node f in

compiler/obc/c/cgen.ml

@@ -154,10 +154,9 @@ let rec assoc_type n var_env =
 let rec unalias_ctype = function
   | Cty_id ty_name ->
       (try
-        let { qualname = q; info = ty_desc } = find_type (qualname ty_name) in
-          match ty_desc with
-            | Talias ty -> unalias_ctype (ctype_of_otype ty)
-            | _ -> Cty_id ty_name
+         match find_type (current_qual ty_name) with
+           | Talias ty -> unalias_ctype (ctype_of_otype ty)
+           | _ -> Cty_id ty_name
       with Not_found -> Cty_id ty_name)
   | Cty_arr (n, cty) -> Cty_arr (n, unalias_ctype cty)
   | Cty_ptr cty -> Cty_ptr (unalias_ctype cty)
@@ -180,8 +179,8 @@ let rec assoc_type_lhs lhs var_env =
     | Cfield(x, f) ->
         let ty = assoc_type_lhs x var_env in
         let n = struct_name ty in
-        let { info = fields } = find_struct (qualname n) in
-        ctype_of_otype (field_assoc (qualname f) fields)
+        let fields = find_struct (current_qual n) in
+        ctype_of_otype (field_assoc (current_qual f) fields)
 
 (** Creates the statement a = [e_1, e_2, ..], which gives a list
     a[i] = e_i.*)
@@ -232,11 +231,11 @@ let rec cexpr_of_static_exp se =
           Carraylit (repeat_list cc (int_of_static_exp n))
     | Svar ln ->
         (try
-          let { info = cd } = find_const ln in
-            cexpr_of_static_exp (Static.simplify NamesEnv.empty cd.c_value)
+          let cd = find_const ln in
+            cexpr_of_static_exp (Static.simplify QualEnv.empty cd.c_value)
         with Not_found -> assert false)
     | Sop _ ->
-        let se' = Static.simplify NamesEnv.empty se in
+        let se' = Static.simplify QualEnv.empty se in
           if se = se' then
             Error.message se.se_loc Error.Estatic_exp_compute_failed
           else
@@ -364,7 +363,7 @@ let generate_function_call var_env obj_env outvl objn args =
     else
       (** The step function takes scalar arguments and its own internal memory
           holding structure. *)
-      let args = step_fun_call var_env sig_info.info objn out args in
+      let args = step_fun_call var_env sig_info objn out args in
       (** Our C expression for the function call. *)
       Cfun_call (classn ^ "_step", args)
   in

compiler/obc/obc_printer.ml

@@ -4,6 +4,7 @@ open Pp_tools
 open Types
 open Idents
 open Names
+open Global_printer
 
 let print_vd ff vd =
   fprintf ff "@[<v>";