merge head changes

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

8 files changed, 83 insertions, 63 deletions

diff --git a/typing/ctype.ml b/typing/ctype.ml
index 86df6b8cf9..9d2ccd77c2 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1498,8 +1498,8 @@ and unify_row env row1 row2 =
   in
   let empty fields =
     List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
-  if (row1.row_closed || row2.row_closed)
-  && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed)
+  (* Check whether we are going to build an empty type *)
+  if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed)
   && List.for_all
       (fun (_,f1,f2) ->
         row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent)
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index aaf5f16082..d7e1dd4659 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -597,9 +597,9 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) =
   let type_defined ppf =
     match args with
     | [] -> fprintf ppf "%s" name
-    | [arg] -> fprintf ppf "%a@ %s" type_parameter arg name
+    | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name
     | _ ->
-        fprintf ppf "(@[%a)@]@ %s"
+        fprintf ppf "@[(@[%a)@]@ %s@]"
           (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
           args name
   in
@@ -631,7 +631,7 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) =
         (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
         print_constraints constraints
   | ty ->
-      fprintf ppf "@[<2>@[<hv 2>%t = %a@]%a@]"
+      fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]"
         print_name_args !outcome_type ty
         print_constraints constraints
 and print_out_constr ppf (name, tyl) =
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 5d1958923e..3ede8f6fc0 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -428,9 +428,11 @@ let rec class_field cl_num self_type meths vars
         raise(Typecore.Error(expr.pexp_loc, Expr_type_clash(trace)))
       end;
       Ctype.end_def ();
+      let vars_local = !vars in
       let field =
         lazy begin
           Ctype.raise_nongen_level ();
+          vars := vars_local;
           let texp = type_expect met_env meth_expr meth_type in
           Ctype.end_def ();
           Cf_meth (lab, texp)
@@ -474,6 +476,7 @@ let rec class_field cl_num self_type meths vars
 
   | Pcf_init expr ->
       let expr = make_method cl_num expr in
+      let vars_local = !vars in
       let field =
         lazy begin
           Ctype.raise_nongen_level ();
@@ -481,6 +484,7 @@ let rec class_field cl_num self_type meths vars
           let (obj_ty, res_ty) = Ctype.filter_arrow val_env meth_type "" in
           Ctype.unify val_env obj_ty self_type;
           Ctype.unify val_env res_ty (Ctype.instance Predef.type_unit);
+          vars := vars_local;
           let texp = type_expect met_env expr meth_type in
           Ctype.end_def ();
           Cf_init texp
@@ -514,7 +518,9 @@ and class_structure cl_num val_env met_env (spat, str) =
       (val_env, meth_env, par_env, [], Concr.empty, StringSet.empty)
       str
   in
+  let vars_final = !vars in
   let fields = List.map Lazy.force (List.rev fields) in
+  vars := vars_final;
 
   {cl_field = fields;
    cl_meths = Meths.map (function (id, ty) -> id) !meths},
@@ -1175,11 +1181,10 @@ let report_error ppf = function
   | Repeated_parameter ->
       fprintf ppf "A type parameter occurs several times"
   | Unconsistent_constraint trace ->
+      fprintf ppf "The class constraints are not consistent.@.";
       Printtyp.report_unification_error ppf trace
-        (function ppf ->
-           fprintf ppf "The class constraints are not consistent : type")
-        (function ppf ->
-           fprintf ppf "is not compatible with type")
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
   | Method_type_mismatch (m, trace) ->
       Printtyp.report_unification_error ppf trace
         (function ppf ->
diff --git a/typing/typecore.ml b/typing/typecore.ml
index f86297b1f1..0308c7da82 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -658,6 +658,20 @@ let rec type_approx env sexp =
       end
   | _ -> newvar ()
 
+(* List labels in a function type, and whether return type is a variable *)
+let rec list_labels_aux env visited ls ty_fun =
+  let ty = expand_head env ty_fun in
+  if !Clflags.recursive_types && List.memq ty visited then
+    List.rev ls, false
+  else match ty.desc with
+    Tarrow (l, _, ty_res, _) ->
+      list_labels_aux env (ty::visited) (l::ls) ty_res
+  | _ ->
+      List.rev ls, ty.desc = Tvar
+
+let list_labels env ty = list_labels_aux env [] [] ty
+
+(* Hack to allow coercion of self. Will clean-up later. *)
 let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
 
 (* Typing of expressions *)
@@ -1109,15 +1123,13 @@ let rec type_exp env sexp =
          exp_type = newvar ();
          exp_env = env;
        }
+  | Pexp_poly _ ->
+      assert false
 
 and type_argument env sarg ty_expected =
-  let rec no_labels ty =
-    let ty = expand_head env ty in
-    match ty.desc with
-      Tvar -> false
-    | Tarrow ("",_, ty,_) when not !Clflags.classic -> no_labels ty
-    | Tarrow _ -> false
-    | _ -> true
+  let no_labels ty =
+    let ls, tvar = list_labels env ty in
+    not tvar && List.for_all ((=) "") ls
   in
   match expand_head env ty_expected, sarg with
   | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
@@ -1174,12 +1186,9 @@ and type_application env funct sargs =
       (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
       ty_fun omitted
   in
-  let rec has_label l ty_fun =
-    match (expand_head env ty_fun).desc with
-    | Tarrow (l', _, ty_res, _) ->
-        (l = l' || has_label l ty_res)
-    | Tvar -> true
-    | _ -> false
+  let has_label l ty_fun =
+    let ls, tvar = list_labels env ty_fun in
+    tvar || List.mem l ls
   in
   let ignored = ref [] in
   let rec type_unknown_args args omitted ty_fun = function
@@ -1221,26 +1230,18 @@ and type_application env funct sargs =
         in
         type_unknown_args ((Some arg1, optional) :: args) omitted ty2 sargl
   in
-  let rec nonopt_labels ls ty_fun =
-    match (expand_head env ty_fun).desc with
-    | Tarrow (l, _, ty_res, _) ->
-        if is_optional l then nonopt_labels ls ty_res
-        else nonopt_labels (l::ls) ty_res
-    | Tvar -> None
-    | _    -> Some ls
-  in
   let ignore_labels =
     !Clflags.classic ||
-    match nonopt_labels [] funct.exp_type with
-    | Some labels ->
-        List.length labels = List.length sargs &&
-        List.for_all (fun (l,_) -> l = "") sargs &&
-        List.exists (fun l -> l <> "") labels &&
-        begin
-          Location.prerr_warning funct.exp_loc Warnings.Labels_omitted;
-          true
-        end
-    | None -> false
+    begin
+      let ls, tvar = list_labels env funct.exp_type in
+      not tvar &&
+      let labels = List.filter (fun l -> not (is_optional l)) ls in
+      List.length labels = List.length sargs &&
+      List.for_all (fun (l,_) -> l = "") sargs &&
+      List.exists (fun l -> l <> "") labels &&
+      (Location.prerr_warning funct.exp_loc Warnings.Labels_omitted;
+       true)
+    end
   in
   let rec type_args args omitted ty_fun ty_old sargs more_sargs =
     match expand_head env ty_fun with
@@ -1419,11 +1420,9 @@ and type_expect ?in_function env sexp ty_expected =
       let cases, partial =
         type_cases ~in_function:(loc,ty_fun) env ty_arg ty_res
           (Some sexp.pexp_loc) caselist in
-      let rec all_labeled ty =
-        match (repr ty).desc with
-          Tarrow ("", _, _, _) | Tvar -> false
-        | Tarrow (l, _, ty, _) -> l.[0] <> '?' && all_labeled ty
-        | _ -> true
+      let all_labeled ty =
+        let ls, tvar = list_labels env ty in
+        not (tvar || List.exists (fun l -> l = "" || l.[0] = '?') ls)
       in
       if is_optional l && all_labeled ty_res then
         Location.prerr_warning (fst (List.hd cases)).pat_loc
@@ -1593,10 +1592,12 @@ let report_error ppf = function
   | Apply_wrong_label (l, ty) ->
       let print_label ppf = function
         | "" -> fprintf ppf "without label"
-        | l -> fprintf ppf "with label ~%s" l in
+        | l ->
+            fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l
+      in
       reset_and_mark_loops ty;
       fprintf ppf
-        "@[<v>@[<2>Expecting function has type@ %a@]@,\
+        "@[<v>@[<2>Expecting function has type@ %a@]@.\
           This argument cannot be applied %a@]"
         type_expr ty print_label l
   | Label_multiply_defined lid ->
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 4521d79a7a..202313294d 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -30,7 +30,7 @@ type error =
   | Recursive_abbrev of string
   | Definition_mismatch of type_expr
   | Constraint_failed of type_expr * type_expr
-  | Unconsistent_constraint
+  | Unconsistent_constraint of (type_expr * type_expr) list
   | Type_clash of (type_expr * type_expr) list
   | Parameters_differ of type_expr * type_expr
   | Null_arity_external
@@ -151,8 +151,8 @@ let transl_declaration env (name, sdecl) id =
        try
          Ctype.unify env (transl_simple_type env false sty)
                          (transl_simple_type env false sty')
-       with Ctype.Unify _ ->
-         raise(Error(loc, Unconsistent_constraint)))
+       with Ctype.Unify tr ->
+         raise(Error(loc, Unconsistent_constraint tr)))
     sdecl.ptype_cstrs;
 
   (id, decl)
@@ -376,7 +376,9 @@ let compute_variance env tvl nega posi ty =
                   List.iter (compute_variance_rec posi nega) tyl
               | _ -> ())
             (Btype.row_repr row).row_fields
-      | Tvar | Tnil | Tlink _ -> ()
+      | Tpoly (ty, _) ->
+          compute_variance_rec posi nega ty
+      | Tvar | Tnil | Tlink _ | Tunivar -> ()
     end
   in
   compute_variance_rec nega posi ty;
@@ -561,8 +563,8 @@ let transl_with_constraint env sdecl =
        try
          Ctype.unify env (transl_simple_type env false ty)
                          (transl_simple_type env false ty')
-       with Ctype.Unify _ ->
-         raise(Error(loc, Unconsistent_constraint)))
+       with Ctype.Unify tr ->
+         raise(Error(loc, Unconsistent_constraint tr)))
     sdecl.ptype_cstrs;
   let decl =
     { type_params = params;
@@ -617,8 +619,11 @@ let report_error ppf = function
       fprintf ppf
         "@[<hv>In this definition, type@ %a@ should be@ %a@]"
         Printtyp.type_expr ty Printtyp.type_expr ty'
-  | Unconsistent_constraint ->
-      fprintf ppf "The type constraints are not consistent"
+  | Unconsistent_constraint trace ->
+      fprintf ppf "The type constraints are not consistent.@.";
+      Printtyp.report_unification_error ppf trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
   | Type_clash trace ->
       Printtyp.report_unification_error ppf trace
         (function ppf ->
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index a34aab610b..9a07ebe5ee 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -46,7 +46,7 @@ type error =
   | Recursive_abbrev of string
   | Definition_mismatch of type_expr
   | Constraint_failed of type_expr * type_expr
-  | Unconsistent_constraint
+  | Unconsistent_constraint of (type_expr * type_expr) list
   | Type_clash of (type_expr * type_expr) list
   | Parameters_differ of type_expr * type_expr
   | Null_arity_external
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 4a8e8d6d8f..9ed5ab826e 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -24,6 +24,7 @@ exception Already_bound
 type error =
     Unbound_type_variable of string
   | Unbound_type_constructor of Longident.t
+  | Unbound_type_constructor_2 of Path.t
   | Type_arity_mismatch of Longident.t * int * int
   | Bound_type_variable of string
   | Recursive_type
@@ -299,16 +300,20 @@ let rec transl_type env policy rowvar styp =
             add_typed_field styp.ptyp_loc l f fields
         | Rinherit sty ->
             let ty = transl_type env policy None sty in
-            if fields <> [] then name := None else begin
+            let nm =
               match repr ty with
-                {desc=Tconstr(p, tl, _)} -> name := Some(p, tl)
-              | _                        -> ()
-            end;
-            let fl = match expand_head env ty with
-              {desc=Tvariant row} when Btype.static_row row ->
+                {desc=Tconstr(p, tl, _)} -> Some(p, tl)
+              | _                        -> None
+            in
+            name := if fields = [] then nm else None;
+            let fl = match expand_head env ty, nm with
+              {desc=Tvariant row}, _ when Btype.static_row row ->
                 let row = Btype.row_repr row in
                 row.row_fields
-            | _ -> raise(Error(sty.ptyp_loc, Not_a_variant ty))
+            | {desc=Tvar}, Some(p, _) ->
+                raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p)) 
+            | _ ->
+                raise(Error(sty.ptyp_loc, Not_a_variant ty))
             in
             List.fold_left
               (fun fields (l, f) ->
@@ -448,6 +453,9 @@ let report_error ppf = function
       fprintf ppf "Unbound type parameter %s" name
   | Unbound_type_constructor lid ->
       fprintf ppf "Unbound type constructor %a" longident lid
+  | Unbound_type_constructor_2 p ->
+      fprintf ppf "The type constructor@ %a@ is not yet completely defined"
+        path p
   | Type_arity_mismatch(lid, expected, provided) ->
       fprintf ppf
        "@[The type constructor %a@ expects %i argument(s),@ \
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index 366bcf5072..d662472277 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -37,6 +37,7 @@ exception Already_bound
 type error =
     Unbound_type_variable of string
   | Unbound_type_constructor of Longident.t
+  | Unbound_type_constructor_2 of Path.t
   | Type_arity_mismatch of Longident.t * int * int
   | Bound_type_variable of string
   | Recursive_type