From 3d02b85bd68e4a08a9c3c69eb492fd0fa28b2c37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Mon, 13 Sep 2010 13:32:35 +0200 Subject: [PATCH] Fixed some non exhaustive pattern matchings Added assert_n functions to decompose to get a tuple from a list of known size, and assert_nmin when the list has at least n elements. --- compiler/heptagon/analysis/typing.ml | 4 ++- compiler/heptagon/hept_printer.ml | 1 + compiler/main/hept2mls.ml | 1 + compiler/main/mls2obc.ml | 3 +- compiler/minils/mls_printer.ml | 49 +++++++++++++++++++--------- compiler/obc/c/cgen.ml | 20 ++++++++++-- compiler/obc/c/cmain.ml | 4 +-- compiler/utilities/misc.ml | 33 ++++++++++++++++++- compiler/utilities/misc.mli | 7 ++++ 9 files changed, 99 insertions(+), 23 deletions(-) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index c3394f0..4d97782 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -246,7 +246,7 @@ let desc_of_ty = function | Tid ty_name -> find_type ty_name | _ -> Tabstract let set_of_constr = function - | Tabstract | Tstruct _ -> assert false + | Tabstract | Tstruct _ | Talias _ -> assert false | Tenum tag_list -> List.fold_right QualSet.add tag_list QualSet.empty let name_mem n env = @@ -573,6 +573,8 @@ let rec typing const_env h e = (* return the type *) Eiterator(it, { app with a_op = op; a_params = typed_params } , typed_n, typed_e_list, reset), ty + + | Eiterator _ -> assert false in { e with e_desc = typed_desc; e_ty = ty; }, ty with diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index c037e46..e5e8096 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -94,6 +94,7 @@ and print_exp ff e = | None -> () | Some r -> fprintf ff " every %a" print_exp r ) + | Eiterator _ -> assert false end; if !Misc.full_type_info then fprintf ff " : %a)" print_type e.e_ty diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index 7d30be9..3814e92 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -244,6 +244,7 @@ let rec translate env translate_app env app, n, List.map (translate env) e_list, translate_reset reset)) + | Heptagon.Efby _ | Heptagon.Elast _ -> Error.message loc Error.Eunsupported_language_construct diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 5eee237..9c1d0aa 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -357,7 +357,8 @@ and mk_node_call map call_context app loc name_list args = let si = (match app.Minils.a_op with | Minils.Efun _ -> [] - | Minils.Enode _ -> [reinit o]) in + | Minils.Enode _ -> [reinit o] + | _ -> assert false) in [], si, [obj], [Acall (name_list, o, Mstep, args)] | _ -> assert false diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index c6ff0e4..0e732b2 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -1,4 +1,4 @@ - +open Misc open Names open Idents open Types @@ -110,33 +110,50 @@ and print_exp_desc ff = function print_exp_tuple args print_every reset -and print_app ff (app, args) = match app.a_op, app.a_params, args with - | Eequal, _, [e1; e2] -> +and print_app ff (app, args) = match app.a_op with + | Eequal -> + let e1, e2 = assert_2 args in fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2 - | Etuple, _, a -> print_exp_tuple ff a - | (Efun(f)|Enode(f)), p, a -> + | Etuple -> print_exp_tuple ff args + | Efun f | Enode f -> fprintf ff "@[%a@,%a@,%a@]" - print_qualname f print_params p print_exp_tuple a - | Eifthenelse, _, [e1; e2; e3] -> + print_qualname f print_params app.a_params print_exp_tuple args + | Eifthenelse -> + let e1, e2, e3 = assert_3 args in fprintf ff "@[if %a@ then %a@ else %a@]" print_exp e1 print_exp e2 print_exp e3 - | Efield, [f], [r] -> fprintf ff "%a.%a" print_exp r print_static_exp f - | Efield_update, [f], [r; e] -> + | Efield -> + let r = assert_1 args in + let f = assert_1 app.a_params in + fprintf ff "%a.%a" print_exp r print_static_exp f + | Efield_update -> + let r,e = assert_2 args in + let f = assert_1 app.a_params in fprintf ff "@[<2>{%a with .%a =@ %a}@]" print_exp r print_static_exp f print_exp e - | Earray, _, a -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") a - | Earray_fill, [n], [e] -> fprintf ff "%a^%a" print_exp e print_static_exp n - | Eselect, idx, [e] -> fprintf ff "%a%a" print_exp e print_index idx - | Eselect_slice, [idx1; idx2], [e] -> + | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args + | Earray_fill -> + let e = assert_1 args in + let n = assert_1 app.a_params in + fprintf ff "%a^%a" print_exp e print_static_exp n + | Eselect -> + let e = assert_1 args in + fprintf ff "%a%a" print_exp e print_index app.a_params + | Eselect_slice -> + let e = assert_1 args in + let idx1, idx2 = assert_2 app.a_params in fprintf ff "%a[%a..%a]" print_exp e print_static_exp idx1 print_static_exp idx2 - | Eselect_dyn, _, r::d::e -> + | Eselect_dyn -> + let r, d, e = assert_2min args in fprintf ff "%a%a default %a" print_exp r print_dyn_index e print_exp d - | Eupdate, _, e1::e2::idx -> + | Eupdate -> + let e1, e2, idx = assert_2min args in fprintf ff "@[<2>(%a with %a =@ %a)@]" print_exp e1 print_dyn_index idx print_exp e2 - | Econcat, _,[e1; e2] -> + | Econcat -> + let e1, e2 = assert_2 args in fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 and print_handler ff c = diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 17b75a3..1c950f9 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -29,6 +29,7 @@ struct | Eno_unnamed_output | Ederef_not_pointer | Estatic_exp_compute_failed + | Eunknown_method of string let message loc kind = (match kind with | Evar name -> @@ -46,7 +47,12 @@ struct | Estatic_exp_compute_failed -> eprintf "%aCode generation : Computation of the value of the static \ expression failed.@." - print_location loc); + print_location loc + | Eunknown_method s -> + eprintf "%aCode generation : Methods other than step and \ + reset are not supported (found '%s').@." + print_location loc + s); raise Misc.Error end @@ -207,6 +213,7 @@ and create_affect_stm dest src ty = [Cfor(x, 0, n, create_affect_stm (Carray (dest, Clhs (Cvar x))) (Clhs (Carray (src, Clhs (Cvar x)))) bty)] + | _ -> assert false (** TODO: add missing cases eg for records *) ) | _ -> [Caffect (dest, src)] @@ -243,6 +250,8 @@ let rec cexpr_of_static_exp se = Error.message se.se_loc Error.Estatic_exp_compute_failed else cexpr_of_static_exp se' + | Stuple _ -> assert false (** TODO *) + | Srecord _ -> assert false (** TODO *) (** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *) let rec cexpr_of_exp var_env exp = @@ -435,7 +444,9 @@ let rec cstm_of_act var_env obj_env act = (** Reinitialization of an object variable, extracting the reset function's name from our environment [obj_env]. *) - | Acall ([], o, Mreset, []) -> + | Acall (name_list, o, Mreset, args) -> + assert_empty name_list; + assert_empty args; let on = obj_call_name o in let obj = assoc_obj on obj_env in let classn = cname_of_qn obj.o_class in @@ -471,6 +482,11 @@ let rec cstm_of_act var_env obj_env act = let outvl = clhss_of_lhss var_env outvl in generate_function_call var_env obj_env outvl objn args + | Acall(_, o, Mmethod s, _) -> + let on = obj_call_name o in + let obj = assoc_obj on obj_env in + Error.message obj.o_loc (Error.Eunknown_method s) + and cstm_of_act_list var_env obj_env b = let l = List.map cvar_of_vd b.b_locals in let var_env = l @ var_env in diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index c6bd383..35975ad 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -84,7 +84,7 @@ let assert_node_res cd = (* TODO: refactor into something more readable. *) let main_def_of_class_def cd = let format_for_type ty = match ty with - | Tarray _ -> assert false + | Tarray _ | Tprod _ -> assert false | Types.Tid id when id = Initial.pfloat -> "%f" | Types.Tid id when id = Initial.pint -> "%d" | Types.Tid id when id = Initial.pbool -> "%d" @@ -93,7 +93,7 @@ let main_def_of_class_def cd = (** Does reading type [ty] need a buffer? When it is the case, [need_buf_for_ty] also returns the type's name. *) let need_buf_for_ty ty = match ty with - | Tarray _ -> assert false + | Tarray _ | Tprod _ -> assert false | Types.Tid id when id = Initial.pfloat -> None | Types.Tid id when id = Initial.pint -> None | Types.Tid id when id = Initial.pbool -> None diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index 1434800..c2e00e1 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -259,6 +259,37 @@ let mapi3 f l1 l2 l3 = in aux 0 l1 l2 l3 +(* Functions to decompose a list into a tuple *) +let _arity_error i l = + Format.eprintf "Internal compiler error: \ + wrong list size (found %d, expected %d).@." (List.length l) i; + assert false + +let _arity_min_error i l = + Format.eprintf "Internal compiler error: \ + wrong list size (found %d, expected %d at least).@." (List.length l) i; + assert false + +let assert_empty = function + | [] -> () + | l -> _arity_error 1 l + +let assert_1 = function + | [v] -> v + | l -> _arity_error 1 l + +let assert_2 = function + | [v1; v2] -> v1, v2 + | l -> _arity_error 1 l + +let assert_2min = function + | v1::v2::l -> v1, v2, l + | l -> _arity_min_error 1 l + +let assert_3 = function + | [v1; v2; v3] -> v1, v2, v3 + | l -> _arity_error 1 l + exception Cannot_find_file of string let findfile filename = @@ -272,4 +303,4 @@ let findfile filename = | a::rest -> let b = Filename.concat a filename in if Sys.file_exists b then b else find rest in - find !load_path \ No newline at end of file + find !load_path diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli index 6c3da07..ab2c71c 100644 --- a/compiler/utilities/misc.mli +++ b/compiler/utilities/misc.mli @@ -188,5 +188,12 @@ val mapi2: (int -> 'a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val mapi3: (int -> 'a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list +(** Functions to decompose a list into a tuple *) +val assert_empty : 'a list -> unit +val assert_1 : 'a list -> 'a +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