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

@@ -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

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
 

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
 

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
 

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 "@[<hv>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 =

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

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

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
+    find !load_path

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