From 02db2ad6b42c9672dc3f095ca841bc4e254774cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Tue, 14 Sep 2010 09:39:02 +0200 Subject: [PATCH] Changed compile flags, and cleaned a bit. Warn as error for partial match. Warn for unused variables : added some TODO to check. PS : I'll deal with callgraph which is doing things that Modules does. --- compiler/global/clocks.ml | 2 +- compiler/global/global_mapfold.ml | 2 +- compiler/global/global_printer.ml | 2 +- compiler/heptagon/analysis/causality.ml | 7 ++-- compiler/heptagon/analysis/typing.ml | 34 ++++++------------- compiler/heptagon/hept_printer.ml | 3 +- compiler/heptagon/main/hept_compiler.ml | 6 ++-- compiler/heptagon/parsing/hept_lexer.mll | 8 +---- .../heptagon/transformations/completion.ml | 2 +- compiler/heptagon/transformations/last.ml | 4 +-- compiler/heptagon/transformations/reset.ml | 4 +-- compiler/main/hept2mls.ml | 20 +++++------ compiler/main/mls2obc.ml | 5 ++- compiler/minils/analysis/clocking.ml | 7 ++-- compiler/minils/mls_printer.ml | 2 +- compiler/minils/mls_utils.ml | 11 +++--- compiler/minils/parsing/mls_lexer.mll | 7 +--- compiler/minils/transformations/callgraph.ml | 10 +++--- compiler/minils/transformations/normalize.ml | 2 +- compiler/minils/transformations/schedule.ml | 2 +- compiler/myocamlbuild.ml | 2 ++ compiler/obc/c/c.ml | 8 ++--- compiler/obc/c/cgen.ml | 11 +++--- compiler/obc/c/cmain.ml | 4 +-- compiler/obc/control.ml | 2 +- compiler/utilities/global/compiler_utils.ml | 15 ++++++-- compiler/utilities/misc.ml | 8 ++--- 27 files changed, 87 insertions(+), 103 deletions(-) diff --git a/compiler/global/clocks.ml b/compiler/global/clocks.ml index 7c1edcd..cde5c5b 100644 --- a/compiler/global/clocks.ml +++ b/compiler/global/clocks.ml @@ -98,7 +98,7 @@ let rec skeleton ck = function | _ -> Cprod (List.map (skeleton ck) ty_list)) | Tarray _ | Tid _ -> Ck ck -let ckofct = function | Ck ck -> ck_repr ck | Cprod ct_list -> Cbase +let ckofct = function | Ck ck -> ck_repr ck | Cprod _ -> Cbase (*TODO bug ?*) diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index fe9468b..db022ce 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -127,7 +127,7 @@ let defaults = { (** Is used to stop the pass at this level *) -let stop funs acc x = x, acc +let stop _ acc x = x, acc let defaults_stop = { static_exp = stop; diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index 0886e68..759d470 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -97,7 +97,7 @@ let print_interface_value ff name node = node.node_params_constraints -let print_interface ff i = +let print_interface ff = let m = Modules.current_module () in NamesEnv.iter (fun key typdesc -> print_interface_type ff key typdesc) m.m_types; diff --git a/compiler/heptagon/analysis/causality.ml b/compiler/heptagon/analysis/causality.ml index f4f14dc..eec9a92 100644 --- a/compiler/heptagon/analysis/causality.ml +++ b/compiler/heptagon/analysis/causality.ml @@ -62,7 +62,7 @@ let rec pre = function | Cand(c1, c2) -> Cand(pre c1, pre c2) | Ctuple l -> Ctuple (List.map pre l) | Cseq(c1, c2) -> Cseq(pre c1, pre c2) - | Cread(x) -> Cempty + | Cread _ -> Cempty | (Cwrite _ | Clastread _ | Cempty) as c -> c (* projection and restriction *) @@ -94,7 +94,7 @@ let build dec = (** Main typing function *) let rec typing e = match e.e_desc with - | Econst(c) -> cempty + | Econst _ -> cempty | Evar(x) -> read x | Elast(x) -> lastread x | Epre (_, e) -> pre (typing e) @@ -201,8 +201,7 @@ let typing_contract loc contract = let t_contract = clear (build b.b_local) t_contract in t_contract -let typing_node { n_name = f; n_input = i_list; n_output = o_list; - n_contract = contract; +let typing_node { n_contract = contract; n_block = b; n_loc = loc } = let _ = typing_contract loc contract in ignore (typing_block b) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 2d39fa6..3d87558 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -255,18 +255,6 @@ let name_mem n env = in Env.fold check_one env false -(*let rec simplify_type = function - | Tid _ as t -> t - | Tarray(ty, e) -> - Tarray(simplify_type ty, simplify NamesEnv.empty e) - | Tprod l -> - Tprod (List.map simplify_type l) - -let simplify_type loc ty = - try - simplify_type ty - with - Instanciation_failed -> message loc (Etype_should_be_static ty) *) let build_subst names values = if List.length names <> List.length values @@ -386,7 +374,7 @@ let check_static_field_unicity l = [loc] is the location used for error reporting.*) let struct_info_from_name n = try - n, find_struct n + find_struct n with Not_found -> error (Erecord_type_expected (Tid n)) @@ -403,7 +391,8 @@ let struct_info ty = match ty with [loc] is the location used for error reporting.*) let struct_info_from_field f = try - struct_info_from_name (find_field f) + let t = find_field f in + t, struct_info_from_name t with Not_found -> error (Eundefined (fullname f)) @@ -456,7 +445,7 @@ and typing_static_exp const_env se = let q, fields = (match f_se_list with | [] -> error (Eempty_record) - | (f,_)::l -> struct_info_from_field f + | (f,_)::_ -> struct_info_from_field f ) in if List.length f_se_list <> List.length fields then @@ -523,7 +512,7 @@ let rec typing const_env h e = let q, fields = (match l with | [] -> message e.e_loc (Eempty_record) - | (f,_)::l -> struct_info_from_field f + | (f,_)::_ -> struct_info_from_field f ) in if List.length l <> List.length fields then @@ -553,7 +542,6 @@ let rec typing const_env h e = n, e_list, reset) -> let ty_desc = find_value f in let op, expected_ty_list, result_ty_list = kind f ty_desc in -(*TODO verifier....*) let node_params = List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in let m = build_subst node_params params in @@ -620,7 +608,6 @@ and typing_app const_env h op e_list = | { a_op = (Efun f | Enode f); a_params = params } as app -> let ty_desc = find_value f in let op, expected_ty_list, result_ty_list = kind f ty_desc in -(*TODO verifier....*) let node_params = List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in let m = build_subst node_params params in @@ -658,7 +645,7 @@ and typing_app const_env h op e_list = | Sfield fn -> fn | _ -> assert false) in let typed_e, t1 = typing const_env h e in - let q, fields = struct_info t1 in + let fields = struct_info t1 in let t2 = field_type const_env fn fields t1 e.e_loc in t2, op, [typed_e] @@ -666,7 +653,7 @@ and typing_app const_env h op e_list = let e1, e2 = assert_2 e_list in let f = assert_1 params in let typed_e1, t1 = typing const_env h e1 in - let q, fields = struct_info t1 in + let fields = struct_info t1 in let fn = (match f.se_desc with | Sfield fn -> fn @@ -803,7 +790,7 @@ and typing_array_subscript const_env h idx_list ty = and typing_array_subscript_dyn const_env h idx_list ty = match unalias_type ty, idx_list with | ty, [] -> ty, [] - | Tarray(ty, exp), idx::idx_list -> + | Tarray(ty, _), idx::idx_list -> let typed_idx = expect const_env h (Tid Initial.pint) idx in let ty, typed_idx_list = typing_array_subscript_dyn const_env h idx_list ty in @@ -890,7 +877,7 @@ and typing_automaton_handlers const_env h acc state_handlers = let typed_e = expect const_env h (Tid Initial.pbool) e in { esc with e_cond = typed_e } in - let handler ({ s_state = n; s_block = b; s_until = e_list1; + let handler ({ s_block = b; s_until = e_list1; s_unless = e_list2 } as s) = let typed_b, defined_names, h0 = typing_block const_env h b in let typed_e_list1 = List.map (escape h0) e_list1 in @@ -1018,8 +1005,7 @@ let build_node_params const_env l = in mapfold check_param const_env l -let node ({ n_name = f; n_statefull = statefull; - n_input = i_list; n_output = o_list; +let node ({ n_name = f; n_input = i_list; n_output = o_list; n_contract = contract; n_block = b; n_loc = loc; n_params = node_params; } as n) = diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index f552f34..c97a15d 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -111,7 +111,6 @@ and print_exp_desc ff = function print_static_exp param print_exp_tuple args print_every reset - | Eiterator _ -> assert false and print_every ff reset = print_opt (fun ff id -> fprintf ff " every %a" print_exp id) ff reset @@ -230,7 +229,7 @@ and print_eq_list ff = function | [] -> () | l -> print_list_r print_eq """;""" ff l -and print_block ff { b_local = v_list; b_equs = eqs; b_defnames = defnames } = +and print_block ff { b_local = v_list; b_equs = eqs } = fprintf ff "%a@[do@ %a@]" print_local_vars v_list print_eq_list eqs let rec print_type_def ff { t_name = name; t_desc = tdesc } = diff --git a/compiler/heptagon/main/hept_compiler.ml b/compiler/heptagon/main/hept_compiler.ml index 6103242..7181cd9 100644 --- a/compiler/heptagon/main/hept_compiler.ml +++ b/compiler/heptagon/main/hept_compiler.ml @@ -40,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 p; + if !print_types then print_interface Format.std_formatter; (* Causality check *) let p = silent_pass "Causality check" true Causality.program p in @@ -92,8 +92,8 @@ let compile_interface modname filename = let l = do_silent_pass "Parsing" parse_interface lexbuf in (* Convert the parse tree to Heptagon AST *) - let l = do_silent_pass "Scoping" Hept_scoping.translate_interface l in - if !print_types then print_interface Format.std_formatter l; + let _ = do_silent_pass "Scoping" Hept_scoping.translate_interface l in + if !print_types then print_interface Format.std_formatter; output_value itc (Modules.current_module ()); diff --git a/compiler/heptagon/parsing/hept_lexer.mll b/compiler/heptagon/parsing/hept_lexer.mll index d5bd561..b2a3b43 100644 --- a/compiler/heptagon/parsing/hept_lexer.mll +++ b/compiler/heptagon/parsing/hept_lexer.mll @@ -5,13 +5,7 @@ open Lexing open Location open Hept_parser - - -type lexical_error = - Illegal_character - | Unterminated_comment - | Bad_char_constant - | Unterminated_string;; +open Compiler_utils exception Lexical_error of lexical_error * location;; diff --git a/compiler/heptagon/transformations/completion.ml b/compiler/heptagon/transformations/completion.ml index 0149181..fe27c31 100644 --- a/compiler/heptagon/transformations/completion.ml +++ b/compiler/heptagon/transformations/completion.ml @@ -21,7 +21,7 @@ open Idents *) (* We stop at the first level, it'll correspond to an handler *) -let block_collect funs env b = +let block_collect _ _ b = b, b.b_defnames let gather f funs env x = diff --git a/compiler/heptagon/transformations/last.ml b/compiler/heptagon/transformations/last.ml index f330a44..b42dbdb 100644 --- a/compiler/heptagon/transformations/last.ml +++ b/compiler/heptagon/transformations/last.ml @@ -27,7 +27,7 @@ let last (eq_list, env, v) { v_ident = n; v_type = t; v_last = last } = let extend_env env v = List.fold_left last ([], env, []) v -let edesc funs env ed = match ed with +let edesc _ env ed = match ed with | Elast x -> let lx = Env.find x env in Evar lx, env | _ -> raise Misc.Fallback @@ -38,7 +38,7 @@ let block funs env b = { b with b_local = b.b_local @ last_v; b_equs = eq_lastn_n_list @ b.b_equs }, env -let node_dec funs env n = +let node_dec funs _ n = let _, env, _ = extend_env Env.empty n.n_input in let eq_lasto_list, env, last_o = extend_env env n.n_output in let n, _ = Hept_mapfold.node_dec funs env n in diff --git a/compiler/heptagon/transformations/reset.ml b/compiler/heptagon/transformations/reset.ml index a463970..8b5507e 100644 --- a/compiler/heptagon/transformations/reset.ml +++ b/compiler/heptagon/transformations/reset.ml @@ -82,7 +82,7 @@ let equation v acc_eq_list e = let orthen v acc_eq_list res e = match e.e_desc with - | Evar n -> add_resets res (Some e), v, acc_eq_list + | Evar _ -> add_resets res (Some e), v, acc_eq_list | _ -> let n, v, acc_eq_list = equation v acc_eq_list e in add_resets res (Some { e with e_desc = Evar n }), v, acc_eq_list @@ -180,7 +180,7 @@ let eq funs (res, v, acc_eq_list) equ = equ, (res, v, equ::acc_eq_list) let block funs _ b = - let n, (_, v, eq_list) = Hept_mapfold.block funs (None, [], []) b in + let _, (_, v, eq_list) = Hept_mapfold.block funs (None, [], []) b in { b with b_local = v @ b.b_local; b_equs = eq_list; }, (None, [], []) let program p = diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index 3814e92..727c723 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -84,7 +84,7 @@ struct let ck_tag_name = Con(ck, tag, name) in { e with e_desc = Ewhen(e, tag, name); e_ck = ck_tag_name }, ck_tag_name - | Ecomp(env, l) -> constrec env in + | Ecomp(env, _) -> constrec env in let e, _ = constrec env in e end @@ -149,12 +149,12 @@ let switch x ci_eqs_list = | _ -> let firsts,nexts = extract eqs_lists in (* check all firsts defining same name *) - if (List.for_all (fun (x,e) -> x = (fst (List.hd firsts))) firsts) + if (List.for_all (fun (x,_) -> x = (fst (List.hd firsts))) firsts) then () else begin List.iter - (fun (x,e) -> Format.eprintf "|%s|, " (name x)) + (fun (x,_) -> Format.eprintf "|%s|, " (name x)) firsts; assert false end; @@ -168,14 +168,14 @@ let switch x ci_eqs_list = let rec split ci_eqs_list = match ci_eqs_list with | [] | (_, []) :: _ -> [], [] - | (ci, (y, e) :: shared_eq_list) :: ci_eqs_list -> + | (ci, (_, e) :: shared_eq_list) :: ci_eqs_list -> let ci_e_list, ci_eqs_list = split ci_eqs_list in (ci, e) :: ci_e_list, (ci, shared_eq_list) :: ci_eqs_list in let rec distribute ci_eqs_list = match ci_eqs_list with | [] | (_, []) :: _ -> [] - | (ci, (y, { e_ty = ty; e_loc = loc }) :: _) :: _ -> + | (_, (y, { e_ty = ty; e_loc = loc }) :: _) :: _ -> let ci_e_list, ci_eqs_list = split ci_eqs_list in (y, mk_exp ~exp_ty:ty ~loc:loc (Emerge(x, ci_e_list))) :: distribute ci_eqs_list in @@ -194,7 +194,7 @@ let translate_iterator_type = function | Heptagon.Ifoldi -> Ifoldi | Heptagon.Imapfold -> Imapfold -let rec translate_op env = function +let rec translate_op = function | Heptagon.Eequal -> Eequal | Heptagon.Eifthenelse -> Eifthenelse | Heptagon.Efun f -> Efun f @@ -212,9 +212,9 @@ let rec translate_op env = function | Heptagon.Earrow -> Error.message no_location Error.Eunsupported_language_construct -let translate_app env app = +let translate_app app = mk_app ~params:app.Heptagon.a_params - ~unsafe:app.Heptagon.a_unsafe (translate_op env app.Heptagon.a_op) + ~unsafe:app.Heptagon.a_unsafe (translate_op app.Heptagon.a_op) let rec translate env { Heptagon.e_desc = desc; Heptagon.e_ty = ty; @@ -235,13 +235,13 @@ let rec translate env (fun (f, e) -> (f, translate env e)) f_e_list in mk_exp ~loc:loc ~exp_ty:ty (Estruct f_e_list) | Heptagon.Eapp(app, e_list, reset) -> - mk_exp ~loc:loc ~exp_ty:ty (Eapp (translate_app env app, + mk_exp ~loc:loc ~exp_ty:ty (Eapp (translate_app app, List.map (translate env) e_list, translate_reset reset)) | Heptagon.Eiterator(it, app, n, e_list, reset) -> mk_exp ~loc:loc ~exp_ty:ty (Eiterator (translate_iterator_type it, - translate_app env app, n, + translate_app app, n, List.map (translate env) e_list, translate_reset reset)) | Heptagon.Efby _ diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index cf5284d..0055595 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -63,7 +63,7 @@ let rec translate_pat map = function List.fold_right (fun pat acc -> (translate_pat map pat) @ acc) pat_list [] -let translate_var_dec map l = +let translate_var_dec map l = (*TODO bug map unused ?*) let one_var { Minils.v_ident = x; Minils.v_type = t; v_loc = loc } = mk_var_dec ~loc:loc x t in @@ -238,8 +238,7 @@ let empty_call_context = Oobj "n", None let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } (v, si, j, s) = - let { Minils.e_desc = desc; Minils.e_ty = ty; - Minils.e_ck = ck; Minils.e_loc = loc } = e in + let { Minils.e_desc = desc; Minils.e_ck = ck; Minils.e_loc = loc } = e in match (pat, desc) with | Minils.Evarpat n, Minils.Efby (opt_c, e) -> let x = var_from_name map n in diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index a6ecfc5..6edd304 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -37,7 +37,7 @@ let rec typing h e = let ct = match e.e_desc with | Econst se -> skeleton (new_var ()) se.se_ty | Evar x -> Ck (typ_of_name h x) - | Efby (c, e) -> typing h e + | Efby (_, e) -> typing h e | Eapp({a_op = op}, args, r) -> let ck = match r with | None -> new_var () @@ -57,7 +57,7 @@ let rec typing h e = | Estruct l -> let ck = new_var () in (List.iter - (fun (n, e) -> let ct = skeleton ck e.e_ty in expect h ct e) l; + (fun (_, e) -> let ct = skeleton ck e.e_ty in expect h ct e) l; Ck ck) in (e.e_ck <- ckofct ct; ct) @@ -147,8 +147,7 @@ let typing_contract h contract base = expect h' (Ck base) e_g; h) -let typing_node ({ n_name = f; - n_input = i_list; +let typing_node ({ n_input = i_list; n_output = o_list; n_contract = contract; n_local = l_list; diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 0e732b2..f7479f3 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -31,7 +31,7 @@ let rec print_ck ff = function | Cbase -> fprintf ff "base" | Con (ck, c, n) -> fprintf ff "%a on %a(%a)" print_ck ck print_qualname c print_ident n - | Cvar { contents = Cindex n } -> fprintf ff "base" + | Cvar { contents = Cindex _ } -> fprintf ff "base" | Cvar { contents = Clink ck } -> print_ck ff ck let rec print_clock ff = function diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index e812e08..c9c6859 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -15,7 +15,8 @@ type err_kind = | Enot_static_exp let err_message ?(exp=void) ?(loc=exp.e_loc) = function | Enot_static_exp -> - Format.eprintf "The expression %a should be a static_exp.@." + Format.eprintf "%aThe expression %a should be a static_exp.@." + print_location loc print_exp exp; raise Error @@ -70,7 +71,7 @@ struct | Etuplepat pat_list -> List.fold_left vars_pat acc pat_list let rec vars_ck acc = function - | Con(ck, c, n) -> add n acc + | Con(_, _, n) -> add n acc | Cbase | Cvar { contents = Cindex _ } -> acc | Cvar { contents = Clink ck } -> vars_ck acc ck @@ -123,7 +124,7 @@ struct let rec headrec ck l = match ck with | Cbase | Cvar { contents = Cindex _ } -> l - | Con(ck, c, n) -> headrec ck (n :: l) + | Con(ck, _, n) -> headrec ck (n :: l) | Cvar { contents = Clink ck } -> headrec ck l in headrec ck [] @@ -136,7 +137,7 @@ struct end let node_memory_vars n = - let eq funs acc ({ eq_lhs = pat; eq_rhs = e } as eq) = + let eq _ acc ({ eq_lhs = pat; eq_rhs = e } as eq) = match e.e_desc with | Efby(_, _) -> eq, Vars.vars_pat acc pat | _ -> eq, acc @@ -160,5 +161,5 @@ module AllDep = Dep.Make type equation = eq let read eq = Vars.read false eq let def = Vars.def - let antidep eq = false + let antidep _ = false end) diff --git a/compiler/minils/parsing/mls_lexer.mll b/compiler/minils/parsing/mls_lexer.mll index ce772e5..ab43dea 100644 --- a/compiler/minils/parsing/mls_lexer.mll +++ b/compiler/minils/parsing/mls_lexer.mll @@ -5,12 +5,7 @@ open Location open Lexing open Mls_parser - -type lexical_error = - Illegal_character - | Unterminated_comment - | Bad_char_constant - | Unterminated_string;; +open Compiler_utils exception Lexical_error of lexical_error * location;; diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index e65b5e8..dcd0672 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -239,11 +239,11 @@ let load_object_file modname = (** @return the node with name [ln], loading the corresponding object file if necessary. *) -let node_by_longname ({ qual = q; name = n } as node) = - if not (NamesEnv.mem q info.opened) - then load_object_file q; +let node_by_longname node = + if not (NamesEnv.mem node.qual info.opened) + then load_object_file node.qual; try - let p = NamesEnv.find q info.opened in + let p = NamesEnv.find node.qual info.opened in List.find (fun n -> n.n_name = node) p.p_nodes with Not_found -> Error.message no_location (Error.Enode_unbound node) @@ -259,7 +259,7 @@ let collect_node_calls ln = | { qual = "Pervasives" } -> acc | _ -> (ln, params)::acc) in - let edesc funs acc ed = match ed with + let edesc _ acc ed = match ed with | Eapp ({ a_op = (Enode ln | Efun ln); a_params = params }, _, _) -> ed, add_called_node ln params acc | Eiterator(_, { a_op = (Enode ln | Efun ln); a_params = params }, diff --git a/compiler/minils/transformations/normalize.ml b/compiler/minils/transformations/normalize.ml index f2ad8d1..3c28ec8 100644 --- a/compiler/minils/transformations/normalize.ml +++ b/compiler/minils/transformations/normalize.ml @@ -89,7 +89,7 @@ let rec merge e x ci_a_list = let rec distribute ci_tas_list = match ci_tas_list with | [] | (_, _, []) :: _ -> [] - | (ci, b, (eo :: _)) :: _ -> + | (_, b, (eo :: _)) :: _ -> let ci_ta_list, ci_tas_list = split ci_tas_list in let ci_tas_list = distribute ci_tas_list in (if b then diff --git a/compiler/minils/transformations/schedule.ml b/compiler/minils/transformations/schedule.ml index 4d29093..c6a889f 100644 --- a/compiler/minils/transformations/schedule.ml +++ b/compiler/minils/transformations/schedule.ml @@ -77,7 +77,7 @@ let eqs funs () eq_list = let eqs, () = Mls_mapfold.eqs funs () eq_list in schedule eqs, () -let edesc funs () = function +let edesc _ () = 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 diff --git a/compiler/myocamlbuild.ml b/compiler/myocamlbuild.ml index 5f5ac99..2fa1896 100644 --- a/compiler/myocamlbuild.ml +++ b/compiler/myocamlbuild.ml @@ -33,6 +33,8 @@ let df = function flag ["ocaml"; "parser" ; "menhir" ; "use_menhir"] (S[A"--explain"; A"--table"]); + flag ["ocaml"; "compile" ] (S[A"-w"; A"Ae"; A"-warn-error"; A"PU"]); + | _ -> () let _ = dispatch df diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index a55fdeb..75f5bd9 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -190,14 +190,14 @@ let rec pp_array_decl cty = | _ -> cty, "" let rec pp_param_cty fmt = function - | Cty_arr(n, cty') -> + | Cty_arr(_, cty') -> fprintf fmt "%a*" pp_param_cty cty' | cty -> pp_cty fmt cty (* pp_vardecl, featuring an ugly hack coping with C's inconsistent concrete syntax! *) let rec pp_vardecl fmt (s, cty) = match cty with - | Cty_arr (n, cty') -> + | Cty_arr _ -> let ty, indices = pp_array_decl cty in fprintf fmt "%a %a%s" pp_cty ty pp_string s indices | _ -> fprintf fmt "%a %a" pp_cty cty pp_string s @@ -349,6 +349,6 @@ let is_pointer_type = function then it returns a[i1]..[ip]. *) let rec array_base_ctype ty idx_list = match ty, idx_list with - | Cty_arr (n, ty), [i] -> ty - | Cty_arr (n, ty), i::idx_list -> array_base_ctype ty idx_list + | Cty_arr (_, ty), [_] -> ty + | Cty_arr (_, ty), _::idx_list -> array_base_ctype ty idx_list | _ -> assert false diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 4dff40e..d34dd58 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -231,7 +231,7 @@ let rec cexpr_of_static_exp se = | Sint i -> Cconst (Ccint i) | Sfloat f -> Cconst (Ccfloat f) | Sbool b -> Cconst (Ctag (if b then "TRUE" else "FALSE")) - | Sfield f -> assert false + | Sfield _ -> assert false | Sconstructor c -> Cconst (Ctag (cname_of_qn c)) | Sarray sl -> Carraylit (List.map cexpr_of_static_exp sl) | Sarray_power(n,c) -> @@ -274,7 +274,7 @@ let rec cexpr_of_exp var_env exp = and cexprs_of_exps var_env exps = List.map (cexpr_of_exp var_env) exps -and cop_of_op_aux var_env op_name cexps = match op_name with +and cop_of_op_aux op_name cexps = match op_name with | { qual = "Pervasives"; name = op } -> begin match op,cexps with | "~-", [e] -> Cuop ("-", e) @@ -288,12 +288,11 @@ and cop_of_op_aux var_env op_name cexps = match op_name with Cbop (copname op, el, er) | _ -> Cfun_call(op, cexps) end - | {qual = m; name = op} -> - Cfun_call(op,cexps) + | {qual = m; name = op} -> Cfun_call(op,cexps) (*TODO m should be used?*) and cop_of_op var_env op_name exps = let cexps = cexprs_of_exps var_env exps in - cop_of_op_aux var_env op_name cexps + cop_of_op_aux op_name cexps and clhs_of_lhs var_env l = match l.l_desc with (** Each Obc variable corresponds to a real local C variable. *) @@ -369,7 +368,7 @@ let generate_function_call var_env obj_env outvl objn args = let fun_call = if is_op classln then - cop_of_op_aux var_env classln args + cop_of_op_aux classln args else (** The step function takes scalar arguments and its own internal memory holding structure. *) diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index 033f72f..d4900c4 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -160,7 +160,7 @@ let main_def_of_class_def cd = :: ep))], match nbuf_opt with | None -> [] - | Some id -> [(varn, Cty_arr (20, Cty_char))]) in + | Some _ -> [(varn, Cty_arr (20, Cty_char))]) in let stepm = find_step_method cd in let (scanf_calls, scanf_decls) = @@ -270,7 +270,7 @@ let mk_main name p = match (!Misc.simulation_node, !Misc.assert_nodes) with (var @ var_l, res :: res_l, step :: step_l) in List.fold_right add a_classes ([], [], []) in - let (deps, var_l, res_l, step_l) = + let (_, var_l, res_l, step_l) = (match !Misc.simulation_node with | None -> (n_names, var_l, res_l, step_l) | Some n -> diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index 5645a02..c0a86df 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -46,7 +46,7 @@ let is_deadcode = function | Elhs l -> l = lhs | _ -> false ) - | Acase (e, []) -> true + | Acase (_, []) -> true | Afor(_, _, _, { b_body = [] }) -> true | _ -> false diff --git a/compiler/utilities/global/compiler_utils.ml b/compiler/utilities/global/compiler_utils.ml index 944d5ae..1cdc798 100644 --- a/compiler/utilities/global/compiler_utils.ml +++ b/compiler/utilities/global/compiler_utils.ml @@ -10,8 +10,19 @@ open Misc open Location open Minils +type lexical_error = + | Illegal_character + | Unterminated_comment + | Bad_char_constant + | Unterminated_string + let lexical_error err loc = - Format.eprintf "%aIllegal character.@." print_location loc; + Format.eprintf (match err with + | Illegal_character -> Pervasives.format_of_string "%aIllegal character.@." + | Unterminated_comment -> "%aUnterminated comment.@." + | Bad_char_constant -> "%aBad char constant.@." + | Unterminated_string -> "%aUnterminated string.@." + ) print_location loc; raise Error let syntax_error loc = @@ -34,7 +45,7 @@ let do_pass d f p pp = comment ~sep:"*** " (d^" done."); r -let do_silent_pass d f p = do_pass d f p (fun x -> ()) +let do_silent_pass d f p = do_pass d f p (fun _ -> ()) let pass d enabled f p pp = if enabled diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index 6460bd4..202e098 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -151,9 +151,9 @@ let print_header_info ff cbeg cend = cend let unique l = - let tbl = Hashtbl.create 10 in (* You could replace 10 with List.length l *) + let tbl = Hashtbl.create (List.length l) in List.iter (fun i -> Hashtbl.replace tbl i ()) l; - Hashtbl.fold (fun key data accu -> key :: accu) tbl [] + Hashtbl.fold (fun key _ accu -> key :: accu) tbl [] let rec incomplete_map f l = match l with @@ -165,7 +165,7 @@ let rec last_element l = match l with | [] -> assert false | [v] -> v - | v::l -> last_element l + | _::l -> last_element l (** [split_last l] returns l without its last element and the last element of l. *) @@ -204,7 +204,7 @@ let repeat_list v n = (** Same as List.mem_assoc but using the value instead of the key. *) let rec memd_assoc value = function | [] -> false - | (k,d)::l -> (d = value) or (memd_assoc value l) + | (_,d)::l -> (d = value) or (memd_assoc value l) (** Same as List.assoc but searching for a data and returning the key. *) let rec assocd value = function