diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index db022ce..6d69ba2 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -1,4 +1,5 @@ open Misc +open Errors open Types (*open Clocks*) open Signature diff --git a/compiler/global/initial.ml b/compiler/global/initial.ml index 4f8a0eb..000fec4 100644 --- a/compiler/global/initial.ml +++ b/compiler/global/initial.ml @@ -35,6 +35,7 @@ let mk_static_bool b = (* build the initial environment *) -let initialize () = +let initialize modname = + Modules.initialize modname; List.iter (fun (f, ty) -> Modules.add_type f ty) tglobal; List.iter (fun (f, ty) -> Modules.add_constrs f ty) cglobal diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index 509dce0..4384a89 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -11,6 +11,7 @@ open Misc +open Compiler_options open Signature open Types open Names @@ -91,7 +92,7 @@ let _load_module modname = else let name = String.uncapitalize modname in try - let filename = Misc.findfile (name ^ ".epci") in + let filename = Compiler_utils.findfile (name ^ ".epci") in let ic = open_in_bin filename in let mo:module_object = try @@ -101,18 +102,18 @@ let _load_module modname = close_in ic; Format.eprintf "Corrupted compiled interface file %s.@\n\ Please recompile %s.ept first.@." filename name; - raise Error in + raise Errors.Error in if mo.m_format_version <> interface_format_version then ( Format.eprintf "The file %s was compiled with an older version \ of the compiler.@\nPlease recompile %s.ept first.@." filename name; - raise Error ); + raise Errors.Error ); _append_module mo with - | Misc.Cannot_find_file(f) -> + | Compiler_utils.Cannot_find_file(f) -> Format.eprintf "Cannot find the compiled interface file %s.@." f; - raise Error + raise Errors.Error @@ -286,5 +287,3 @@ let current_module () = m_fields = unqualify_all g_env.fields; m_format_version = g_env.format_version } - - diff --git a/compiler/heptagon/analysis/causal.ml b/compiler/heptagon/analysis/causal.ml index bb0f08d..9dd729b 100644 --- a/compiler/heptagon/analysis/causal.ml +++ b/compiler/heptagon/analysis/causal.ml @@ -90,7 +90,7 @@ let message loc kind = print_location loc output_ac ac end; - raise Misc.Error + raise Errors.Error let cor nc1 nc2 = match nc1, nc2 with diff --git a/compiler/heptagon/analysis/initialization.ml b/compiler/heptagon/analysis/initialization.ml index 685446f..045dc96 100644 --- a/compiler/heptagon/analysis/initialization.ml +++ b/compiler/heptagon/analysis/initialization.ml @@ -175,7 +175,7 @@ module Error = struct Printer.print_type left_ty Printer.print_type right_ty end; - raise Misc.Error + raise Errors.Error end let less_exp e actual_ty expected_ty = diff --git a/compiler/heptagon/analysis/statefull.ml b/compiler/heptagon/analysis/statefull.ml index d719d7c..f15e84b 100644 --- a/compiler/heptagon/analysis/statefull.ml +++ b/compiler/heptagon/analysis/statefull.ml @@ -9,7 +9,6 @@ (* Checks that a node declared stateless is stateless *) open Names open Location -open Misc open Signature open Modules open Heptagon @@ -29,7 +28,7 @@ let message loc kind = Format.eprintf "%aThis expression should be stateless.@." print_location loc end; - raise Error + raise Errors.Error (** @returns whether the exp is statefull. Replaces node calls with the correct Efun or Enode depending on the node signature. *) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 9493655..8db61ac 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -158,7 +158,7 @@ let message loc kind = print_location loc print_type ty end; - raise Error + raise Errors.Error (** Add wrappers around Modules function to raise errors and display the correct location. *) diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml index 7376274..1ca14d7 100644 --- a/compiler/heptagon/hept_mapfold.ml +++ b/compiler/heptagon/hept_mapfold.ml @@ -49,6 +49,7 @@ provided in this file. Trespassers will loop infinitely! /!\ *) open Misc +open Errors open Global_mapfold open Heptagon diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index c97a15d..c7e1cdf 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -54,7 +54,7 @@ let print_local_vars ff = function | l -> fprintf ff "@[<4>%a@]@\n" (print_list_r print_vd "var "";"";") l let print_const_dec ff c = - if !Misc.full_type_info then + if !Compiler_options.full_type_info then fprintf ff "const %a : %a = %a" print_qualname c.c_name print_type c.c_type print_static_exp c.c_value else @@ -85,7 +85,7 @@ and print_exps ff e_list = print_list_r print_exp "(" "," ")" ff e_list and print_exp ff e = - if !Misc.full_type_info then + if !Compiler_options.full_type_info then fprintf ff "(%a : %a)" print_exp_desc e.e_desc print_type e.e_ty else fprintf ff "%a" print_exp_desc e.e_desc diff --git a/compiler/heptagon/main/hept_compiler.ml b/compiler/heptagon/main/hept_compiler.ml index 7181cd9..29bde2e 100644 --- a/compiler/heptagon/main/hept_compiler.ml +++ b/compiler/heptagon/main/hept_compiler.ml @@ -7,8 +7,7 @@ (* *) (**************************************************************************) - -open Misc +open Compiler_options open Compiler_utils open Location open Global_printer @@ -86,7 +85,7 @@ let compile_interface modname filename = close_out itc in try - init_compiler modname; + Initial.initialize modname; (* Parsing of the file *) let l = do_silent_pass "Parsing" parse_interface lexbuf in diff --git a/compiler/heptagon/main/heptcheck.ml b/compiler/heptagon/main/heptcheck.ml index a3059d9..b3e2d5a 100644 --- a/compiler/heptagon/main/heptcheck.ml +++ b/compiler/heptagon/main/heptcheck.ml @@ -25,7 +25,7 @@ let check_implementation modname filename = in try - init_compiler modname; + Initial.initialize modname; add_include (Filename.dirname filename); (* Parsing of the file *) @@ -59,7 +59,7 @@ let main () = (compile check_implementation) errmsg; with - | Misc.Error -> exit 2;; + | Errors.Error -> exit 2;; main () diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index b7458de..ac9dcea 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -74,7 +74,7 @@ struct eprintf "%aA static expression was expected.@." print_location loc end; - raise Misc.Error + raise Errors.Error exception ScopingError of error diff --git a/compiler/heptagon/transformations/completion.ml b/compiler/heptagon/transformations/completion.ml index fe27c31..d1f495b 100644 --- a/compiler/heptagon/transformations/completion.ml +++ b/compiler/heptagon/transformations/completion.ml @@ -66,7 +66,7 @@ let eqdesc funs _ ed = match ed with Hept_mapfold.eqdesc funs_collect Env.empty ed in (* add missing defnames *) Hept_mapfold.eqdesc funs defnames ed - | _ -> raise Misc.Fallback + | _ -> raise Errors.Fallback let funs = { Hept_mapfold.defaults with eqdesc = eqdesc; block = block; } diff --git a/compiler/heptagon/transformations/last.ml b/compiler/heptagon/transformations/last.ml index b42dbdb..f0aa6bd 100644 --- a/compiler/heptagon/transformations/last.ml +++ b/compiler/heptagon/transformations/last.ml @@ -30,7 +30,7 @@ let extend_env env v = List.fold_left last ([], env, []) v let edesc _ env ed = match ed with | Elast x -> let lx = Env.find x env in Evar lx, env - | _ -> raise Misc.Fallback + | _ -> raise Errors.Fallback let block funs env b = let eq_lastn_n_list, env, last_v = extend_env env b.b_local in diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index 52c48a7..a44d186 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -37,7 +37,7 @@ struct eprintf "%aThis construct is not supported by MiniLS.@." print_location loc end; - raise Misc.Error + raise Errors.Error end module Env = diff --git a/compiler/main/heptc.ml b/compiler/main/heptc.ml index a8d1aba..e821550 100644 --- a/compiler/main/heptc.ml +++ b/compiler/main/heptc.ml @@ -12,6 +12,7 @@ open Misc open Modules open Location open Compiler_utils +open Compiler_options open Hept_compiler @@ -33,7 +34,7 @@ let compile_impl modname filename = close_out mlsc in try - init_compiler modname; + Initial.initialize modname; add_include (Filename.dirname filename); (* Parsing of the file *) @@ -88,6 +89,6 @@ let main () = (compile compile_impl) errmsg; with - | Misc.Error -> exit 2;; + | Errors.Error -> exit 2;; main () diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index 6edd304..2bc9cd5 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -28,7 +28,7 @@ let error_message loc = function print_location loc print_clock actual_ct print_clock expected_ct; - raise Error + raise Errors.Error let typ_of_name h x = Env.find x h @@ -119,11 +119,11 @@ let typing_eqs h eq_list = (*TODO FIXME*) let typing_eq { eq_lhs = pat; eq_rhs = e } = let ty_pat = typing_pat h pat in (try expect h ty_pat e with - | Error -> (* DEBUG *) + | Errors.Error -> (* DEBUG *) Format.eprintf "Complete expression: %a@\nClock pattern: %a@." Mls_printer.print_exp e Mls_printer.print_clock ty_pat; - raise Error) + raise Errors.Error) in List.iter typing_eq eq_list let build h dec = diff --git a/compiler/minils/analysis/init.ml b/compiler/minils/analysis/init.ml index a22d637..65e50f8 100644 --- a/compiler/minils/analysis/init.ml +++ b/compiler/minils/analysis/init.ml @@ -192,7 +192,7 @@ struct but is expected to have type %a@." print_location loc Printer.output_typ left_ty Printer. output_typ right_ty); - raise Misc.Error) + raise Errors.Error) end diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index b6e51b8..bfbd199 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -8,6 +8,7 @@ (**************************************************************************) open Compiler_utils +open Compiler_options open Obc open Minils open Misc @@ -45,11 +46,12 @@ let targets = [ "c", Obc_no_params Cmain.program; let generate_target p s = let print_unfolded p_list = comment "Unfolding"; - if !Misc.verbose then List.iter (Mls_printer.print stderr) p_list in + if !Compiler_options.verbose then + List.iter (Mls_printer.print stderr) p_list in let target = (try List.assoc s targets - with Not_found -> language_error s; raise Error) in + with Not_found -> language_error s; raise Errors.Error) in match target with | Minils convert_fun -> convert_fun p @@ -64,7 +66,7 @@ let generate_target p s = let o_list = List.map Mls2obc.program p_list in print_unfolded p_list; comment "Translation to Obc"; - if !Misc.verbose then + if !verbose then List.iter (Obc_printer.print stdout) o_list; List.iter convert_fun o_list diff --git a/compiler/minils/main/mls_compiler.ml b/compiler/minils/main/mls_compiler.ml index 14df782..fe191d4 100644 --- a/compiler/minils/main/mls_compiler.ml +++ b/compiler/minils/main/mls_compiler.ml @@ -9,6 +9,7 @@ open Misc open Location open Compiler_utils +open Compiler_options let pp p = if !verbose then Mls_printer.print stdout p (* diff --git a/compiler/minils/main/mlsc.ml b/compiler/minils/main/mlsc.ml index 98700a7..f7793c9 100644 --- a/compiler/minils/main/mlsc.ml +++ b/compiler/minils/main/mlsc.ml @@ -30,7 +30,7 @@ let compile_impl modname filename = in try - init_compiler modname; + Initial.initialize modname; (* Set pretty printer to the Minils one *) let pp = Mls_compiler.pp in @@ -83,6 +83,6 @@ let main () = compile errmsg; with - | Misc.Error -> exit 2;; + | Errors.Error -> exit 2;; main () diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index 9358d53..e9ef4d3 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -8,6 +8,7 @@ (**************************************************************************) (* Generic mapred over Minils Ast *) open Misc +open Errors open Global_mapfold open Minils diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index f7479f3..17eb4cd 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -40,7 +40,7 @@ let rec print_clock ff = function fprintf ff "@[<2>(%a)@]" (print_list_r print_clock """ *""") ct_list let print_vd ff { v_ident = n; v_type = ty; v_clock = ck } = - if !Misc.full_type_info then + if !Compiler_options.full_type_info then fprintf ff "%a : %a :: %a" print_ident n print_type ty print_ck ck else fprintf ff "%a : %a" print_ident n print_type ty @@ -49,7 +49,7 @@ let print_local_vars ff = function | l -> fprintf ff "@[<4>%a@]@\n" (print_list_r print_vd "var "";"";") l let print_const_dec ff c = - if !Misc.full_type_info then + if !Compiler_options.full_type_info then fprintf ff "const %a : %a = %a" print_qualname c.c_name print_type c.c_type print_static_exp c.c_value else @@ -77,7 +77,7 @@ and print_dyn_index ff idx = fprintf ff "@[<2>%a@]" (print_list print_exp "[""][""]") idx and print_exp ff e = - if !Misc.full_type_info then + if !Compiler_options.full_type_info then fprintf ff "(%a : %a :: %a)" print_exp_desc e.e_desc print_type e.e_ty print_ck e.e_ck else fprintf ff "%a" print_exp_desc e.e_desc @@ -164,7 +164,7 @@ and print_tag_e_list ff tag_e_list = and print_eq ff { eq_lhs = p; eq_rhs = e } = - if !Misc.full_type_info + if !Compiler_options.full_type_info then fprintf ff "@[<2>%a :: %a =@ %a@]" print_pat p print_ck e.e_ck print_exp e else fprintf ff "@[<2>%a =@ %a@]" print_pat p print_exp e diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 4375260..322ecec 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -18,7 +18,7 @@ let err_message ?(exp=void) ?(loc=exp.e_loc) = function Format.eprintf "%aThe expression %a should be a static_exp.@." print_location loc print_exp exp; - raise Error + raise Errors.Error let rec static_exp_of_exp e = match e.e_desc with diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index dcd0672..dbadb6f 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -27,7 +27,7 @@ struct print_location se.se_loc print_static_exp se end; - raise Misc.Error + raise Errors.Error end module Param_instances : @@ -213,7 +213,7 @@ let load_object_file modname = Modules.open_module modname; let name = String.uncapitalize modname in try - let filename = Misc.findfile (name ^ ".epo") in + let filename = Compiler_utils.findfile (name ^ ".epo") in let ic = open_in_bin filename in try let p:program = input_value ic in @@ -221,7 +221,7 @@ let load_object_file modname = Format.eprintf "The file %s was compiled with \ an older version of the compiler.@\n\ Please recompile %s.ept first.@." filename name; - raise Error + raise Errors.Error ); close_in ic; info.opened <- NamesEnv.add p.p_modname p info.opened @@ -230,12 +230,12 @@ let load_object_file modname = close_in ic; Format.eprintf "Corrupted object file %s.@\n\ Please recompile %s.ept first.@." filename name; - raise Error + raise Errors.Error with - | Misc.Cannot_find_file(filename) -> + | Compiler_utils.Cannot_find_file(filename) -> Format.eprintf "Cannot find the object file '%s'.@." filename; - raise Error + raise Errors.Error (** @return the node with name [ln], loading the corresponding object file if necessary. *) @@ -265,7 +265,7 @@ let collect_node_calls ln = | Eiterator(_, { a_op = (Enode ln | Efun ln); a_params = params }, _, _, _) -> ed, add_called_node ln params acc - | _ -> raise Misc.Fallback + | _ -> raise Errors.Fallback in let funs = { Mls_mapfold.defaults with edesc = edesc } in let n = node_by_longname ln in diff --git a/compiler/minils/transformations/itfusion.ml b/compiler/minils/transformations/itfusion.ml index 2646ea8..7c8b7b0 100644 --- a/compiler/minils/transformations/itfusion.ml +++ b/compiler/minils/transformations/itfusion.ml @@ -119,7 +119,7 @@ let edesc funs acc ed = ed, acc - | _ -> raise Misc.Fallback + | _ -> raise Errors.Fallback let program p = diff --git a/compiler/minils/transformations/schedule.ml b/compiler/minils/transformations/schedule.ml index c6a889f..10a4c94 100644 --- a/compiler/minils/transformations/schedule.ml +++ b/compiler/minils/transformations/schedule.ml @@ -84,7 +84,7 @@ let edesc _ () = function let nd = { nd with n_equs = schedule nd.n_equs } in Itfusion.replace_anon_node f nd; Eiterator(it, app, n, e_list, r), () - | _ -> raise Fallback + | _ -> raise Errors.Fallback let program p = let p, () = Mls_mapfold.program_it diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index 75f5bd9..bb5eea8 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -291,7 +291,7 @@ let pp_cfile_desc fmt filen cfile = match cfile with | Cheader (deps, cdecls) -> let headern_macro = String.uppercase filen_wo_ext in - Misc.print_header_info fmt "/*" "*/"; + Compiler_utils.print_header_info fmt "/*" "*/"; fprintf fmt "#ifndef %s_H@\n" headern_macro; fprintf fmt "#define %s_H@\n@\n" headern_macro; iter (fun d -> fprintf fmt "#include \"%s.h\"@\n" d) @@ -300,7 +300,7 @@ let pp_cfile_desc fmt filen cfile = fprintf fmt "#endif // %s_H@\n@?" headern_macro | Csource cdefs -> let headern = filen_wo_ext ^ ".h" in - Misc.print_header_info fmt "/*" "*/"; + Compiler_utils.print_header_info fmt "/*" "*/"; fprintf fmt "#include @\n"; fprintf fmt "#include @\n"; fprintf fmt "#include @\n"; @@ -313,7 +313,8 @@ let pp_cfile_desc fmt filen cfile = (** [output_cfile dir cfile] pretty-prints the content of [cfile] to the corresponding file in the [dir] directory. *) let output_cfile dir (filen, cfile_desc) = - if !Misc.verbose then Format.printf "C-NG generating %s/%s@." dir filen; + if !Compiler_options.verbose then + Format.printf "C-NG generating %s/%s@." dir filen; let buf = Buffer.create 20000 in let oc = open_out (Filename.concat dir filen) in let fmt = Format.formatter_of_buffer buf in diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index d34dd58..067e153 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -53,7 +53,7 @@ struct reset are not supported (found '%s').@." print_location loc s); - raise Misc.Error + raise Errors.Error end let rec struct_name ty = diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index d4900c4..0f9b6b1 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -253,9 +253,10 @@ let main_skel var_list prologue body = } } -let mk_main name p = match (!Misc.simulation_node, !Misc.assert_nodes) with - | (None, []) -> [] - | (_, n_names) -> +let mk_main name p = + match (!Compiler_options.simulation_node, !Compiler_options.assert_nodes) with + | (None, []) -> [] + | (_, n_names) -> let find_class n = try List.find (fun cd -> cd.cd_name.name = n) p.p_defs with Not_found -> @@ -271,7 +272,7 @@ let mk_main name p = match (!Misc.simulation_node, !Misc.assert_nodes) with List.fold_right add a_classes ([], [], []) in let (_, var_l, res_l, step_l) = - (match !Misc.simulation_node with + (match !Compiler_options.simulation_node with | None -> (n_names, var_l, res_l, step_l) | Some n -> let (nvar_l, res, nstep_l) = diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 85c0fee..8100fa3 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -8,6 +8,7 @@ (**************************************************************************) (* Generic mapred over Obc Ast *) open Misc +open Errors open Global_mapfold open Obc diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index 836f0da..d9c767f 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -28,13 +28,13 @@ struct let add deps (ln, _) = deps_longname deps ln in (sedesc, List.fold_left add deps fnel) | Sop (ln, _) -> (sedesc, deps_longname deps ln) - | _ -> raise Fallback + | _ -> raise Errors.Fallback let deps_lhsdesc funs deps ldesc = let (ldesc, deps) = Obc_mapfold.lhsdesc funs deps ldesc in match ldesc with | Lfield (_, ln) -> (ldesc, deps_longname deps ln) - | _ -> raise Fallback + | _ -> raise Errors.Fallback let deps_edesc funs deps edesc = let (edesc, deps) = Obc_mapfold.edesc funs deps edesc in @@ -43,7 +43,7 @@ struct | Estruct (ln, fnel) -> let add deps (ln, _) = deps_longname deps ln in (edesc, List.fold_left add (deps_longname deps ln) fnel) - | _ -> raise Fallback + | _ -> raise Errors.Fallback let deps_act funs deps act = let (act, deps) = Obc_mapfold.act funs deps act in @@ -51,7 +51,7 @@ struct | Acase (_, cbl) -> let add deps (ln, _) = deps_longname deps ln in (act, List.fold_left add deps cbl) - | _ -> raise Fallback + | _ -> raise Errors.Fallback let deps_obj_dec funs deps od = let (od, deps) = Obc_mapfold.obj_dec funs deps od in @@ -68,4 +68,4 @@ struct } in let (_, deps) = Obc_mapfold.program funs S.empty p in S.remove p.p_modname (S.remove "Pervasives" deps) -end \ No newline at end of file +end diff --git a/compiler/utilities/global/compiler_options.ml b/compiler/utilities/global/compiler_options.ml new file mode 100644 index 0000000..2f9b535 --- /dev/null +++ b/compiler/utilities/global/compiler_options.ml @@ -0,0 +1,83 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* Compiler options *) + +(* version of the compiler *) +let version = "0.4" +let date = "DATE" + +(* standard module *) +let pervasives_module = "Pervasives" +let standard_lib = "STDLIB" +let standard_lib = try Sys.getenv "HEPTLIB" with Not_found -> standard_lib + +(* list of modules initially opened *) +let default_used_modules = ref [pervasives_module] +let set_no_pervasives () = default_used_modules := [] + +(* load paths *) +let load_path = ref ([standard_lib]) + + +let set_stdlib p = + load_path := [p] +and add_include d = + load_path := d :: !load_path;; + +(* where is the standard library *) +let locate_stdlib () = + let stdlib = try + Sys.getenv "HEPTLIB" + with + Not_found -> standard_lib in + Format.printf "Standard library in %s@." stdlib + +let show_version () = + Format.printf "The Heptagon compiler, version %s (%s)@." + version date; + locate_stdlib () + + +(* other options of the compiler *) +let verbose = ref false +let print_types = ref false + +let assert_nodes:string list ref = ref [] +let add_assert nd = assert_nodes := nd :: !assert_nodes + +let simulation = ref false +let simulation_node : string option ref = ref None +let set_simulation_node s = + simulation := true; + simulation_node := Some s + +let create_object_file = ref false + +(* Target languages list for code generation *) +let target_languages : string list ref = ref [] + +let add_target_language s = + target_languages := s :: !target_languages + +(* Optional path for generated files (C or Java) *) +let target_path : string option ref = ref None + +let set_target_path path = + target_path := Some path + +let full_type_info = ref false + +let init = ref true + +let inline:string list ref = ref [] +let add_inlined_node s = inline := s :: !inline + +let flatten = ref false + +let nodes_to_inline : string list ref = ref [] diff --git a/compiler/utilities/global/compiler_utils.ml b/compiler/utilities/global/compiler_utils.ml index 1cdc798..352fd9b 100644 --- a/compiler/utilities/global/compiler_utils.ml +++ b/compiler/utilities/global/compiler_utils.ml @@ -6,9 +6,10 @@ (* Organization : Demons, LRI, University of Paris-Sud, Orsay *) (* *) (**************************************************************************) -open Misc open Location -open Minils +open Format +open Unix +open Compiler_options type lexical_error = | Illegal_character @@ -23,11 +24,11 @@ let lexical_error err loc = | Bad_char_constant -> "%aBad char constant.@." | Unterminated_string -> "%aUnterminated string.@." ) print_location loc; - raise Error + raise Errors.Error let syntax_error loc = Format.eprintf "%aSyntax error.@." print_location loc; - raise Error + raise Errors.Error let language_error lang = Format.eprintf "Unknown language: '%s'.@." lang @@ -73,9 +74,20 @@ let clean_dir dir = end else Unix.mkdir dir 0o740; dir -let init_compiler modname = - Modules.initialize modname; - Initial.initialize () +exception Cannot_find_file of string + +let findfile filename = + if Sys.file_exists filename then + filename + else if not(Filename.is_implicit filename) then + raise(Cannot_find_file filename) + else + let rec find = function + | [] -> raise(Cannot_find_file filename) + | a::rest -> + let b = Filename.concat a filename in + if Sys.file_exists b then b else find rest in + find !load_path let lexbuf_from_file file_name = let ic = open_in file_name in @@ -84,6 +96,18 @@ let lexbuf_from_file file_name = { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = file_name }; ic, lexbuf +let print_header_info ff cbeg cend = + let tm = Unix.localtime (Unix.time ()) in + fprintf ff "%s --- Generated the %d/%d/%d at %d:%d --- %s@\n" + cbeg tm.tm_mday (tm.tm_mon+1) (tm.tm_year + 1900) tm.tm_hour tm.tm_min cend; + fprintf ff "%s --- heptagon compiler, version %s (compiled %s) --- %s@\n" + cbeg version date cend; + fprintf ff "%s --- Command line: %a--- %s@\n@\n" + cbeg + (fun ff a -> + Array.iter (fun arg -> fprintf ff "%s " arg) a) + Sys.argv + cend let doc_verbose = "\t\t\tSet verbose mode" diff --git a/compiler/utilities/global/errors.ml b/compiler/utilities/global/errors.ml new file mode 100644 index 0000000..8f566fb --- /dev/null +++ b/compiler/utilities/global/errors.ml @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* error during the whole process *) +exception Error +(** Ast iterators *) +exception Fallback diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index 9e5228c..e157257 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -8,102 +8,6 @@ (**************************************************************************) (* useful stuff *) -(* version of the compiler *) -let version = "0.4" -let date = "DATE" - -(* standard module *) -let pervasives_module = "Pervasives" -let standard_lib = "STDLIB" -let standard_lib = try Sys.getenv "HEPTLIB" with Not_found -> standard_lib - -(* list of modules initially opened *) -let default_used_modules = ref [pervasives_module] -let set_no_pervasives () = default_used_modules := [] - -(* load paths *) -let load_path = ref ([standard_lib]) - -let set_stdlib p = - load_path := [p] -and add_include d = - load_path := d :: !load_path;; - -(* where is the standard library *) -let locate_stdlib () = - let stdlib = try - Sys.getenv "HEPTLIB" - with - Not_found -> standard_lib in - Format.printf "Standard library in %s@." stdlib - -let show_version () = - Format.printf "The Heptagon compiler, version %s (%s)@." - version date; - locate_stdlib () - -(* other options of the compiler *) -let verbose = ref false -let print_types = ref false - -let assert_nodes = ref [] -let add_assert nd = assert_nodes := nd :: !assert_nodes - -let simulation = ref false -let simulation_node : string option ref = ref None -let set_simulation_node s = - simulation := true; - simulation_node := Some s - -let create_object_file = ref false - -(* Target languages list for code generation *) -let target_languages : string list ref = ref [] - -let add_target_language s = - target_languages := s :: !target_languages - -(* Optional path for generated files (C or Java) *) -let target_path : string option ref = ref None - -let set_target_path path = - target_path := Some path - -let full_type_info = ref false - -let boolean = ref false - -let deadcode = ref false - -let init = ref true - -let cse = ref false - -let tomato = ref false - -let inline = ref [] - -let add_inlined_node s = inline := s :: !inline - -let flatten = ref false - -(* Backward compatibility *) -let set_sigali () = add_target_language "z3z";; - -let intermediate = ref false - -let nodes_to_inline : string list ref = ref [] - -let nodes_to_display : string list ref = ref [] - -let node_to_flatten : string option ref = ref None - -let no_mem_alloc = ref false - -let use_interf_scheduler = ref false - -let use_new_reset_encoding = ref false - let optional f = function | None -> None | Some x -> Some (f x) @@ -125,8 +29,6 @@ let rec split_string s c = String.sub s 0 id :: split_string rest c with Not_found -> [s] -(* error during the whole process *) -exception Error (* creation of names. Ensure unicity for the whole compilation chain *) let symbol = ref 0 @@ -134,22 +36,6 @@ let symbol = ref 0 let gen_symbol () = incr symbol; "_"^(string_of_int !symbol) let reset_symbol () = symbol := (*!min_symbol*) 0 -open Format -open Unix - -let print_header_info ff cbeg cend = - let tm = Unix.localtime (Unix.time ()) in - fprintf ff "%s --- Generated the %d/%d/%d at %d:%d --- %s@\n" - cbeg tm.tm_mday (tm.tm_mon+1) (tm.tm_year + 1900) tm.tm_hour tm.tm_min cend; - fprintf ff "%s --- heptagon compiler, version %s (compiled %s) --- %s@\n" - cbeg version date cend; - fprintf ff "%s --- Command line: %a--- %s@\n@\n" - cbeg - (fun ff a -> - Array.iter (fun arg -> fprintf ff "%s " arg) a) - Sys.argv - cend - let unique l = let tbl = Hashtbl.create (List.length l) in List.iter (fun i -> Hashtbl.replace tbl i ()) l; @@ -217,7 +103,6 @@ let rec assocd value = function (** { 3 Compiler iterators } *) -exception Fallback (** Mapfold *) let mapfold f acc l = @@ -293,18 +178,3 @@ let assert_2min = function let assert_3 = function | [v1; v2; v3] -> v1, v2, v3 | l -> _arity_error 3 l - -exception Cannot_find_file of string - -let findfile filename = - if Sys.file_exists filename then - filename - else if not(Filename.is_implicit filename) then - raise(Cannot_find_file filename) - else - let rec find = function - | [] -> raise(Cannot_find_file filename) - | a::rest -> - let b = Filename.concat a filename in - if Sys.file_exists b then b else find rest in - find !load_path diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli index b53fff1..711959b 100644 --- a/compiler/utilities/misc.mli +++ b/compiler/utilities/misc.mli @@ -7,113 +7,6 @@ (* *) (**************************************************************************) - -(* Version and date of compilation *) -val version : string -val date : string - -(* List of modules initially opened *) -val default_used_modules : string list ref - -(* Void the list of modules initially opened *) -val set_no_pervasives : unit -> unit - -(* Path list to libraries *) -val load_path : string list ref - -(* Set path to standard library *) -val set_stdlib : string -> unit - -(* Add path to libraries *) -val add_include : string -> unit - -(* Print the path to standard library *) -val locate_stdlib : unit -> unit - -(* Print the compiler version and its compilation date *) -val show_version : unit -> unit - -(* Verbose option *) -val verbose : bool ref - -(* Print types option *) -val print_types : bool ref - -(* Nodes to check at run-time *) -val assert_nodes : string list ref - -(* Add node (name) to the list of nodes to be checked. *) -val add_assert : string -> unit - -(* Simulation mode *) -val simulation : bool ref -(* Simulated node *) -val simulation_node : string option ref -(* Set the simulation mode on *) -val set_simulation_node : string -> unit - -(* If it is true, the compiler will only generate an object file (.epo). - Otherwise, it will generate obc code and possibily other targets.*) -val create_object_file : bool ref -(* List of target languages *) -val target_languages : string list ref -(* Add target language to the list *) -val add_target_language : string -> unit - -(* Optional path for generated files (C or Java) *) -val target_path : string option ref -(* Set the optional target path *) -val set_target_path : string -> unit - -(* Print full type information when pretty-printing MiniLS code. *) -val full_type_info : bool ref - -(* Boolean transformation of enumerated types *) -val boolean : bool ref - -(* Deadcode removal *) -val deadcode : bool ref - -(* Initialization analysis (enabled by default) *) -val init : bool ref - -(* Common sub-expression elimination *) -val cse : bool ref - -(* Automata minimization *) -val tomato : bool ref - -(* List of nodes to inline *) -val inline : string list ref -(* Add a new node name to the list of nodes to inline. *) -val add_inlined_node : string -> unit -(* Inline every node. *) -val flatten : bool ref - -(* Z/3Z back-end mode *) -val set_sigali : unit -> unit - -(* Intermediate-equations removal *) -val intermediate : bool ref - -(* Nodes to be inlined *) -val nodes_to_inline : string list ref - -(* Nodes which dependency graphics will be serialized to .dot file. *) -val nodes_to_display : string list ref - -(* Node to flatten *) -val node_to_flatten : string option ref - -(* Disable the memory allocation phase*) -val no_mem_alloc : bool ref - -(* Whether to use the interference aware scheduler*) -val use_interf_scheduler : bool ref - -(* Use the new encoding of resets using reset_mem. *) -val use_new_reset_encoding : bool ref - (* Misc. functions *) val optional : ('a -> 'b) -> 'a option -> 'b option (** Optional with accumulator *) @@ -121,15 +14,6 @@ val optional_wacc : ('a -> 'b -> 'c*'a) -> 'a -> 'b option -> ('c option * 'a) val optunit : ('a -> unit) -> 'a option -> unit val split_string : string -> char -> string list -(* Printing header informations (compiler version, generation date...) *) -(* [print_header_info ff cbeg cend] prints header info, where [ff] is - the formatter used, [cbeg] and [cend] the string of begin and end - of commentaries in the target language *) -val print_header_info : Format.formatter -> string -> string -> unit - -(* Error during the whole process *) -exception Error - (* Generation of unique names. Mandatory call of reset_symbol between set_min_symbol and gen_symbol *) (*val set_min_symbol : int -> unit*) @@ -169,12 +53,6 @@ val assocd : 'b -> ('a * 'b) list -> 'a induced by [c] *) val make_list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int - - -(** Ast iterators *) -exception Fallback - - (** Mapfold *) val mapfold: ('a -> 'b -> 'c * 'a) -> 'a -> 'b list -> 'c list * 'a @@ -196,5 +74,3 @@ val assert_2 : 'a list -> 'a * 'a val assert_2min : 'a list -> 'a * 'a * 'a list val assert_3 : 'a list -> 'a * 'a * 'a -exception Cannot_find_file of string -val findfile : string -> string