merge

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

5 files changed, 58 insertions, 31 deletions

diff --git a/parsing/location.ml b/parsing/location.ml
index cc2d81f403..f0b2ca43ed 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -86,6 +86,7 @@ let rec highlight_locations loc1 loc2 =
             Terminfo.standout false;
             (* Position cursor back to original location *)
             Terminfo.resume !num_loc_lines;
+            flush stdout;
             true;
           with Exit -> false
 
@@ -120,7 +121,9 @@ let print_warning loc ppf w =
       let n = Warnings.print ppf w in
       num_loc_lines := !num_loc_lines + n
     in
-    fprintf ppf "%aWarning: %a@." print loc printw w;
+    fprintf ppf "%a" print loc;
+    fprintf ppf "Warning: %a@." printw w;
+    pp_print_flush ppf ();
     incr num_loc_lines;
   end
 ;;
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index e2f58709a4..f53b27e64e 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -378,7 +378,7 @@ let full_match tdefs force env =  match env with
             [] fields
         in
         let closed =
-          { row_fields = more_fields; row_more = Ctype.newvar();
+          { row_fields = more_fields; row_more = Btype.newgenvar();
             row_bound = row.row_bound; row_closed = true;
             row_name = if more_fields = [] then row.row_name else None }
          (* Cannot fail *)
@@ -854,9 +854,11 @@ and compats ps qs = match ps,qs with
 (******************************)
 
 let check_partial tdefs loc casel =
-  if not (Warnings.is_active (Warnings.Partial_match "")) then
-    Partial
-  else   
+  (* This must be checked: typing of variants depend of this
+   * if not (Warnings.is_active (Warnings.Partial_match "")) then
+   *   Partial
+   * else
+   *)
     let pss = get_mins (initial_matrix casel) in    
     match pss with
     | [] ->
@@ -894,7 +896,7 @@ let location_of_clause = function
   | _ -> fatal_error "Parmatch.location_of_clause"
 
 let check_unused tdefs casel =
-  if Warnings.is_active Warnings.Unused_match then begin
+  if Warnings.is_active Warnings.Unused_match then
     let prefs =   
       List.fold_right
         (fun (pat,act as clause) r ->
@@ -919,4 +921,3 @@ let check_unused tdefs casel =
             (Warnings.Other "Fatal Error") ;
           raise e)
       prefs
-  end
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 39113700a4..270395a90e 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -255,7 +255,8 @@ let rec typexp sch prio0 ppf ty =
             let close_mark =
               if row.row_closed then
                 if all_present then " " else "< "
-              else "> " in
+              else
+                if all_present then "> " else "? " in
             let print_present ppf = function
               | [] -> ()
               | l ->
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 3bd964edea..27fd25d5cc 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -432,11 +432,24 @@ let type_self_pattern cl_num val_env met_env par_env spat =
 
 let check_unused_variant pat =
   match pat.pat_desc with
-    Tpat_variant(tag, _, row) ->
+    Tpat_variant(tag, opat, row) ->
       let row = row_repr row in
-      if try row_field_repr (List.assoc tag row.row_fields) = Rabsent
-         with Not_found -> true
-      then Location.prerr_warning pat.pat_loc Warnings.Unused_match
+      begin match
+        try row_field_repr (List.assoc tag row.row_fields)
+        with Not_found -> Rabsent
+      with
+      | Rpresent _ -> ()
+      | Rabsent ->
+          Location.prerr_warning pat.pat_loc Warnings.Unused_match
+      | Reither (true, [], e) when not row.row_closed ->
+          e := Some (Rpresent None)
+      | Reither (false, ty::tl, e) when not row.row_closed ->
+          e := Some (Rpresent (Some ty));
+          begin match opat with None -> assert false
+          | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
+          end
+      | _ -> ()
+      end
   | _ -> ()
 
 let rec iter_pattern f p =
@@ -633,16 +646,17 @@ let rec type_exp env sexp =
   | Pexp_match(sarg, caselist) ->
       let arg = type_exp env sarg in
       let ty_res = newvar() in
-      let cases = type_cases env arg.exp_type ty_res caselist in
-      let partial = Parmatch.check_partial env sexp.pexp_loc cases in
+      let cases, partial =
+        type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist in
       { exp_desc = Texp_match(arg, cases, partial);
         exp_loc = sexp.pexp_loc;
         exp_type = ty_res;
         exp_env = env }
   | Pexp_try(sbody, caselist) ->
       let body = type_exp env sbody in
-      let cases =
-        type_cases env (instance Predef.type_exn) body.exp_type caselist in
+      let cases, _ =
+        type_cases env (instance Predef.type_exn) body.exp_type None
+          caselist in
       { exp_desc = Texp_try(body, cases);
         exp_loc = sexp.pexp_loc;
         exp_type = body.exp_type;
@@ -1251,8 +1265,8 @@ and type_expect env sexp ty_expected =
         try unify env ty_arg (type_option(newvar()))
         with Unify _ -> assert false
       end;
-      let cases = type_cases env ty_arg ty_res caselist in
-      let partial = Parmatch.check_partial env sexp.pexp_loc cases in
+      let cases, partial =
+        type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist in
       let rec all_labeled ty =
         match (repr ty).desc with
           Tarrow ("", _, _) | Tvar -> false
@@ -1287,7 +1301,7 @@ and type_statement env sexp =
 
 (* Typing of match cases *)
 
-and type_cases env ty_arg ty_res caselist =
+and type_cases env ty_arg ty_res partial_loc caselist =
   let ty_arg' = newvar () in
   let pat_env_list =
     List.map
@@ -1296,17 +1310,22 @@ and type_cases env ty_arg ty_res caselist =
         unify_pat env pat ty_arg';
         (pat, ext_env))
       caselist in
-  (* Check unused cases here (required for polymorphic variants) *)
-  let cases = List.map2
-      (fun (pat, _) (_, act) ->
-        let dummy = { exp_desc = Texp_tuple []; exp_type = newty (Ttuple[]);
-                      exp_env = env; exp_loc = act.pexp_loc } in
-        match act.pexp_desc with
-          Pexp_when _ -> pat, {dummy with exp_desc = Texp_when(dummy, dummy)}
-        | _           -> pat, dummy)
-      pat_env_list caselist in
-  Parmatch.check_unused env cases;
-  (* Delay other unifications until after the use of unify_pat *)
+  (* Check partial matches here (required for polymorphic variants) *)
+  let partial =
+    match partial_loc with None -> Partial
+    | Some loc ->
+        let cases = List.map2
+            (fun (pat, _) (_, act) ->
+              let dummy = { exp_desc = Texp_tuple [];
+                            exp_type = newty (Ttuple[]);
+                            exp_env = env; exp_loc = act.pexp_loc } in
+              match act.pexp_desc with
+                Pexp_when _ ->
+                  pat, {dummy with exp_desc = Texp_when(dummy, dummy)}
+              | _           -> pat, dummy)
+            pat_env_list caselist in
+        Parmatch.check_partial env loc cases in
+  (* `Contaminating' unifications start here *)
   begin match pat_env_list with [] -> ()
   | (pat, _) :: _ -> unify_pat' env pat ty_arg
   end;
@@ -1318,7 +1337,8 @@ and type_cases env ty_arg ty_res caselist =
       pat_env_list caselist in
   (* Check for impossible variant constructors *)
   List.iter (fun (pat, _) -> iter_pattern check_unused_variant pat) cases;
-  cases
+  Parmatch.check_unused env cases;
+  cases, partial
 
 (* Typing of let bindings *)
 
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 7c74a87305..42ae95f8ca 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -264,6 +264,7 @@ let rec transl_type env policy styp =
       if policy = Fixed && not (Btype.static_row row) then
         raise(Error(styp.ptyp_loc, Unbound_type_variable "[..]"));
       newty (Tvariant row)
+(*
   | Ptyp_poly(vars, st) ->
       let ty_list = List.map (fun _ -> newty Tunivar) vars in
       let old_univars = !univars in
@@ -283,6 +284,7 @@ let rec transl_type env policy styp =
       aliases := List.fold_right Tbl.remove vars !aliases;
       univars := old_univars;
       newty (Tpoly(ty,ty_list))
+*)
 
 and transl_fields env policy =
   function