Keep location on value declarations.located_errors

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

11 files changed, 72 insertions, 37 deletions

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 5fcd8eeb97..2651c8d160 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -481,7 +481,9 @@ let rec push_defaults loc bindings pat_expr_list partial =
           Texp_match
             ({exp with exp_type = pat.pat_type; exp_desc =
               Texp_ident (Path.Pident param,
-                          {val_type = pat.pat_type; val_kind = Val_reg})},
+                          {val_type = pat.pat_type; val_kind = Val_reg;
+                           val_loc = Location.none;
+                          })},
              pat_expr_list, partial) }
       in
       push_defaults loc bindings
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 87a5659611..d3eb5f5b73 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -40,6 +40,8 @@ let mkclass d =
   { pcl_desc = d; pcl_loc = symbol_rloc() }
 let mkcty d =
   { pcty_desc = d; pcty_loc = symbol_rloc() }
+let mkval ty p =
+  {pval_type = ty; pval_prim = p; pval_loc = symbol_rloc()}
 
 let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
 let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
@@ -470,7 +472,7 @@ structure_item:
           [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp)
         | _ -> mkstr(Pstr_value($2, List.rev $3)) }
   | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
-      { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) }
+      { mkstr(Pstr_primitive($2, mkval $4 $6)) }
   | TYPE type_declarations
       { mkstr(Pstr_type(List.rev $2)) }
   | EXCEPTION UIDENT constructor_arguments
@@ -536,9 +538,9 @@ signature:
 ;
 signature_item:
     VAL val_ident COLON core_type
-      { mksig(Psig_value($2, {pval_type = $4; pval_prim = []})) }
+      { mksig(Psig_value($2, mkval $4 [])) }
   | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
-      { mksig(Psig_value($2, {pval_type = $4; pval_prim = $6})) }
+      { mksig(Psig_value($2, mkval $4 $6)) }
   | TYPE type_declarations
       { mksig(Psig_type(List.rev $2)) }
   | EXCEPTION UIDENT constructor_arguments
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 05f92bd037..a458b66a65 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -123,7 +123,9 @@ and expression_desc =
 
 and value_description =
   { pval_type: core_type;
-    pval_prim: string list }
+    pval_prim: string list;
+    pval_loc: Location.t;
+   }
 
 (* Type declarations *)
 
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 75c2c299f4..395fa8ae22 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -328,6 +328,18 @@ let type_declarations env id decl1 decl2 =
 open Format
 open Printtyp
 
+let show_locs ppf loc1 loc2 =
+  if loc2.Location.loc_start <> Lexing.dummy_pos then begin
+    fprintf ppf "@.";
+    Location.print ppf loc2;
+    fprintf ppf "Expected declaration"
+  end;
+  if loc1.Location.loc_start <> Lexing.dummy_pos then begin
+    fprintf ppf "@.";
+    Location.print ppf loc1;
+    fprintf ppf "Actual declaration"
+  end
+
 let include_err ppf = function
   | Missing_field id ->
       fprintf ppf "The field `%a' is required but not provided" ident id
@@ -335,22 +347,14 @@ let include_err ppf = function
       fprintf ppf
        "@[<hv 2>Values do not match:@ \
         %a@;<1 -2>is not included in@ %a@]"
-       (value_description id) d1 (value_description id) d2
+       (value_description id) d1 (value_description id) d2;
+      show_locs ppf d1.val_loc d2.val_loc;
   | Type_declarations(id, d1, d2, errs) ->
       fprintf ppf
         "@[<hv 2>Type declarations do not match:@ %a@;<1 -2>is not included in@ %a@]"
         (type_declaration id) d1
         (type_declaration id) d2;
-      if d1.type_loc.Location.loc_start <> Lexing.dummy_pos then begin
-        fprintf ppf "@.";
-        Location.print ppf d1.type_loc;
-        fprintf ppf "First declaration"
-      end;
-      if d2.type_loc.Location.loc_start <> Lexing.dummy_pos then begin
-        fprintf ppf "@.";
-        Location.print ppf d2.type_loc;
-        fprintf ppf "Second declaration"
-      end;
+      show_locs ppf d1.type_loc d2.type_loc;
       List.iter
         (fun err -> fprintf ppf "@.%s."
             (Includecore.report_type_mismatch "the first" "the second" err))
diff --git a/typing/mtype.ml b/typing/mtype.ml
index dddc65a0e9..1d8384c1be 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -110,7 +110,9 @@ let nondep_supertype env mid mty =
       match item with
         Tsig_value(id, d) ->
           Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
-                          val_kind = d.val_kind}) :: rem'
+                          val_kind = d.val_kind;
+                          val_loc = d.val_loc;
+                         }) :: rem'
       | Tsig_type(id, d, rs) ->
           Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
           :: rem'
diff --git a/typing/subst.ml b/typing/subst.ml
index 40cafb7bc3..62ab52808b 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -242,7 +242,9 @@ let class_type s cty =
 
 let value_description s descr =
   { val_type = type_expr s descr.val_type;
-    val_kind = descr.val_kind }
+    val_kind = descr.val_kind;
+    val_loc = if s.for_saving then Location.none else descr.val_loc;
+   }
 
 let exception_declaration s tyl =
   List.map (type_expr s) tyl
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index cea3a5c361..d4f7bd1725 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -194,11 +194,11 @@ let rc node =
 (* Enter a value in the method environment only *)
 let enter_met_env lab kind ty val_env met_env par_env =
   let (id, val_env) =
-    Env.enter_value lab {val_type = ty; val_kind = Val_unbound} val_env
+    Env.enter_value lab {val_type = ty; val_kind = Val_unbound; val_loc = Location.none} val_env
   in
   (id, val_env,
-   Env.add_value id {val_type = ty; val_kind = kind} met_env,
-   Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
+   Env.add_value id {val_type = ty; val_kind = kind; val_loc = Location.none} met_env,
+   Env.add_value id {val_type = ty; val_kind = Val_unbound; val_loc = Location.none} par_env)
 
 (* Enter an instance variable in the environment *)
 let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
@@ -584,7 +584,9 @@ let rec class_field cl_num self_type meths vars
              in
              let desc =
                {val_type = expr.exp_type;
-                val_kind = Val_ivar (Immutable, cl_num)}
+                val_kind = Val_ivar (Immutable, cl_num);
+                val_loc = Location.none;
+               }
              in
              let id' = Ident.create (Ident.name id) in
              ((id', expr)
@@ -933,7 +935,9 @@ and class_expr cl_num val_env met_env scl =
              Ctype.generalize expr.exp_type;
              let desc =
                {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
-                                                               cl_num)}
+                                                               cl_num);
+                val_loc = Location.none;
+               }
              in
              let id' = Ident.create (Ident.name id) in
              ((id', expr)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 6121df0ce6..62aec5e5b2 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -571,7 +571,7 @@ let add_pattern_variables env =
   let pv = get_ref pattern_variables in
   List.fold_right
     (fun (id, ty, loc) env ->
-       let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in
+       let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg; val_loc = loc} env in
        Env.add_annot id (Annot.Iref_internal loc) e1;
     )
     pv env
@@ -599,11 +599,13 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   if is_optional l then unify_pat val_env pat (type_option (newvar ()));
   let (pv, met_env) =
     List.fold_right
-      (fun (id, ty, _loc) (pv, env) ->
+      (fun (id, ty, loc) (pv, env) ->
          let id' = Ident.create (Ident.name id) in
          ((id', id, ty)::pv,
           Env.add_value id' {val_type = ty;
-                             val_kind = Val_ivar (Immutable, cl_num)}
+                             val_kind = Val_ivar (Immutable, cl_num);
+                             val_loc = loc;
+                            }
             env))
       !pattern_variables ([], met_env)
   in
@@ -626,12 +628,19 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
   pattern_variables := [];
   let (val_env, met_env, par_env) =
     List.fold_right
-      (fun (id, ty, _loc) (val_env, met_env, par_env) ->
-         (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
+      (fun (id, ty, loc) (val_env, met_env, par_env) ->
+         (Env.add_value id {val_type = ty;
+                            val_kind = Val_unbound;
+                            val_loc = loc;
+                           } val_env,
           Env.add_value id {val_type = ty;
-                            val_kind = Val_self (meths, vars, cl_num, privty)}
+                            val_kind = Val_self (meths, vars, cl_num, privty);
+                            val_loc = loc;
+                           }
             met_env,
-          Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
+          Env.add_value id {val_type = ty; val_kind = Val_unbound;
+                            val_loc = loc;
+                           } par_env))
       pv (val_env, met_env, par_env)
   in
   (pat, meths, vars, val_env, met_env, par_env)
@@ -1275,7 +1284,9 @@ let rec type_exp env sexp =
       let high = type_expect env shigh (instance Predef.type_int) in
       let (id, new_env) =
         Env.enter_value param {val_type = instance Predef.type_int;
-                                val_kind = Val_reg} env in
+                               val_kind = Val_reg;
+                               val_loc = loc;
+                              } env in
       let body = type_statement new_env sbody in
       re {
         exp_desc = Texp_for(id, low, high, dir, body);
@@ -1410,7 +1421,9 @@ let rec type_exp env sexp =
                   unify env res_ty (instance typ);
                   (Texp_apply({ exp_desc = Texp_ident(Path.Pident method_id,
                                                      {val_type = method_type;
-                                                       val_kind = Val_reg});
+                                                      val_kind = Val_reg;
+                                                      val_loc = Location.none;
+                                                     });
                                 exp_loc = loc;
                                 exp_type = method_type;
                                 exp_env = env },
@@ -1684,7 +1697,7 @@ and type_argument env sarg ty_expected' =
         {pat_desc = Tpat_var id; pat_type = ty;
          pat_loc = Location.none; pat_env = env},
         {exp_type = ty; exp_loc = Location.none; exp_env = env; exp_desc =
-         Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg})}
+         Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg; val_loc = Location.none})}
       in
       let eta_pat, eta_var = var_pair "eta" ty_arg in
       let func texp =
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 484f6f3d64..d5202971b2 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -759,7 +759,7 @@ let transl_value_decl env valdecl =
   let ty = Typetexp.transl_type_scheme env valdecl.pval_type in
   match valdecl.pval_prim with
     [] ->
-      { val_type = ty; val_kind = Val_reg }
+      { val_type = ty; val_kind = Val_reg; val_loc = valdecl.pval_loc }
   | decl ->
       let arity = Ctype.arity ty in
       if arity = 0 then
@@ -769,7 +769,7 @@ let transl_value_decl env valdecl =
       && prim.prim_arity > 5
       && prim.prim_native_name = ""
       then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
-      { val_type = ty; val_kind = Val_prim prim }
+      { val_type = ty; val_kind = Val_prim prim; val_loc = valdecl.pval_loc }
 
 (* Translate a "with" constraint -- much simplified version of
     transl_type_decl. *)
diff --git a/typing/types.ml b/typing/types.ml
index e11755613e..5f4198a4af 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -87,7 +87,9 @@ module Vars = Meths
 
 type value_description =
   { val_type: type_expr;                (* Type of the value *)
-    val_kind: value_kind }
+    val_kind: value_kind;
+    val_loc: Location.t;
+ }
 
 and value_kind =
     Val_reg                             (* Regular value *)
diff --git a/typing/types.mli b/typing/types.mli
index fa130f8a4d..68d611ee8b 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -85,7 +85,9 @@ module Vars  : Map.S with type key = string
 
 type value_description =
   { val_type: type_expr;                (* Type of the value *)
-    val_kind: value_kind }
+    val_kind: value_kind;
+    val_loc: Location.t;
+   }
 
 and value_kind =
     Val_reg                             (* Regular value *)