Ajout des motifs de tableaux

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@1899 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

typing/parmatch.ml

@@ -19,7 +19,8 @@ open Types
 open Typedtree
 
 let make_pat desc ty =
-  {pat_desc = desc; pat_loc = Location.none; pat_type = ty}
+  {pat_desc = desc; pat_loc = Location.none;
+   pat_type = ty; pat_env = Env.empty}
 
 let omega = make_pat Tpat_any Ctype.none
 
@@ -41,6 +42,7 @@ let simple_match p1 p2 =
       c1 = c2
   | Tpat_tuple(_), Tpat_tuple(_) -> true
   | Tpat_record(_), Tpat_record(_) -> true
+  | Tpat_array(p1s), Tpat_array(p2s) -> List.length p1s = List.length p2s
   | _, (Tpat_any | Tpat_var(_)) -> true
   | _, _ -> false
 
@@ -69,11 +71,13 @@ let simple_match_args p1 p2 =
     Tpat_construct(cstr, args) -> args
   | Tpat_tuple(args)  -> args
   | Tpat_record(args) ->  set_fields (record_num_fields p1) args
+  | Tpat_array(args) -> args
   | (Tpat_any | Tpat_var(_)) ->
       begin match p1.pat_desc with
         Tpat_construct(_, args) -> omega_list args
       | Tpat_tuple(args) -> omega_list args
       | Tpat_record(args) ->  omega_list args
+      | Tpat_array(args) ->  omega_list args
       | _ -> []
       end
   | _ -> []
@@ -174,6 +178,7 @@ let full_match env =
   | ({pat_desc = Tpat_constant(_)},_) :: _ -> false
   | ({pat_desc = Tpat_tuple(_)},_) :: _ -> true
   | ({pat_desc = Tpat_record(_)},_) :: _ -> true
+  | ({pat_desc = Tpat_array(_)},_) :: _ -> false
   | _ -> fatal_error "Parmatch.full_match"
 
 (*
@@ -204,7 +209,7 @@ let rec satisfiable pss qs =
               satisfiable pss (simple_match_args p omega @ qs)  in
             if full_match constrs
             then List.exists try_non_omega constrs
-            else satisfiable (filter_extra pss) qs or
+            else satisfiable (filter_extra pss) qs ||
                  List.exists try_non_omega constrs
         end
     | q::qs ->
@@ -227,16 +232,18 @@ let rec le_pat p q =
   | _, Tpat_or(q1,q2) -> le_pat p q1 & le_pat p q2
   | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
   | Tpat_construct(c1,ps), Tpat_construct(c2,qs) ->
-      c1.cstr_tag = c2.cstr_tag & le_pats ps qs
+      c1.cstr_tag = c2.cstr_tag && le_pats ps qs
   | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
   | Tpat_record(l1), Tpat_record(l2) ->
      let size = record_num_fields p in
      le_pats (set_fields size l1) (set_fields size l2)
+  | Tpat_array(ps), Tpat_array(qs) ->
+     List.length ps = List.length qs && le_pats ps qs
   | _, _ -> false  
 
 and le_pats ps qs =
   match ps,qs with
-    p::ps, q::qs -> le_pat p q & le_pats ps qs
+    p::ps, q::qs -> le_pat p q && le_pats ps qs
   | _, _         -> true
 
 let get_mins ps =

typing/typecore.ml

@@ -87,28 +87,33 @@ let rec type_pat env sp =
     Ppat_any ->
       { pat_desc = Tpat_any;
         pat_loc = sp.ppat_loc;
-        pat_type = newvar() }
+        pat_type = newvar();
+        pat_env = env }
   | Ppat_var name ->
       let ty = newvar() in
       let id = enter_variable sp.ppat_loc name ty in
       { pat_desc = Tpat_var id;
         pat_loc = sp.ppat_loc;
-        pat_type = ty }
+        pat_type = ty;
+        pat_env = env }
   | Ppat_alias(sp, name) ->
       let p = type_pat env sp in
       let id = enter_variable sp.ppat_loc name p.pat_type in
       { pat_desc = Tpat_alias(p, id);
         pat_loc = sp.ppat_loc;
-        pat_type = p.pat_type }
+        pat_type = p.pat_type;
+        pat_env = env }
   | Ppat_constant cst ->
       { pat_desc = Tpat_constant cst;
         pat_loc = sp.ppat_loc;
-        pat_type = type_constant cst }
+        pat_type = type_constant cst;
+        pat_env = env }
   | Ppat_tuple spl ->
       let pl = List.map (type_pat env) spl in
       { pat_desc = Tpat_tuple pl;
         pat_loc = sp.ppat_loc;
-        pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl)) }
+        pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
+        pat_env = env }
   | Ppat_construct(lid, sarg, explicit_arity) ->
       let constr =
         try
@@ -131,7 +136,8 @@ let rec type_pat env sp =
       List.iter2 (unify_pat env) args ty_args;
       { pat_desc = Tpat_construct(constr, args);
         pat_loc = sp.ppat_loc;
-        pat_type = ty_res }
+        pat_type = ty_res;
+        pat_env = env }
   | Ppat_record lid_sp_list ->
       let ty = newvar() in
       let type_label_pat (lid, sarg) =
@@ -152,7 +158,16 @@ let rec type_pat env sp =
       in
       { pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
         pat_loc = sp.ppat_loc;
-        pat_type = ty }
+        pat_type = ty;
+        pat_env = env }
+  | Ppat_array spl ->
+      let pl = List.map (type_pat env) spl in
+      let ty_elt = newvar() in
+      List.iter (fun p -> unify_pat env p ty_elt) pl;
+      { pat_desc = Tpat_array pl;
+        pat_loc = sp.ppat_loc;
+        pat_type = instance (Predef.type_array ty_elt);
+        pat_env = env }
   | Ppat_or(sp1, sp2) ->
       let initial_pattern_variables = !pattern_variables in
       let p1 = type_pat env sp1 in
@@ -162,7 +177,8 @@ let rec type_pat env sp =
       unify_pat env p2 p1.pat_type;
       { pat_desc = Tpat_or(p1, p2);
         pat_loc = sp.ppat_loc;
-        pat_type = p1.pat_type }
+        pat_type = p1.pat_type;
+        pat_env = env }
   | Ppat_constraint(sp, sty) ->
       let p = type_pat env sp in
       let ty = Typetexp.transl_simple_type env false sty in
@@ -823,7 +839,8 @@ let type_method env self self_name meths sexp ty_expected =
   let pattern =
     { pat_desc = Tpat_var obj;
       pat_loc = Location.none;
-      pat_type = self }
+      pat_type = self;
+      pat_env = env }
   in
   let (pattern, env) =
     match self_name with
@@ -835,7 +852,8 @@ let type_method env self self_name meths sexp ty_expected =
         in
         ({ pat_desc = Tpat_alias (pattern, self_name);
            pat_loc = Location.none;
-           pat_type = self },
+           pat_type = self;
+           pat_env = env },
          env)
   in
   let exp = type_expect_fun env sexp ty_expected in

typing/typedtree.ml

@@ -22,7 +22,8 @@ open Types
 type pattern =
   { pat_desc: pattern_desc;
     pat_loc: Location.t;
-    pat_type: type_expr }
+    pat_type: type_expr;
+    pat_env: Env.t }
 
 and pattern_desc =
     Tpat_any
@@ -32,6 +33,7 @@ and pattern_desc =
   | Tpat_tuple of pattern list
   | Tpat_construct of constructor_description * pattern list
   | Tpat_record of (label_description * pattern) list
+  | Tpat_array of pattern list
   | Tpat_or of pattern * pattern
 
 type expression =

typing/typedtree.mli

@@ -21,7 +21,8 @@ open Types
 type pattern =
   { pat_desc: pattern_desc;
     pat_loc: Location.t;
-    pat_type: type_expr }
+    pat_type: type_expr;
+    pat_env: Env.t }
 
 and pattern_desc =
     Tpat_any
@@ -31,6 +32,7 @@ and pattern_desc =
   | Tpat_tuple of pattern list
   | Tpat_construct of constructor_description * pattern list
   | Tpat_record of (label_description * pattern) list
+  | Tpat_array of pattern list
   | Tpat_or of pattern * pattern
 
 type expression =