add location info in Ptype_variant and Ptype_record

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

10 files changed, 39 insertions, 31 deletions

diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml
index 44ad62f4c2..4e16961d41 100644
--- a/camlp4/camlp4/ast2pt.ml
+++ b/camlp4/camlp4/ast2pt.ml
@@ -243,8 +243,9 @@ value mktype loc tl cl tk tm =
 ;
 value mkmutable m = if m then Mutable else Immutable;
 value mkprivate m = if m then Private else Public;
-value mktrecord (_, n, m, t) = (n, mkmutable m, ctyp (mkpolytype t));
-value mkvariant (_, c, tl) = (c, List.map ctyp tl);
+value mktrecord (loc, n, m, t) =
+  (n, mkmutable m, ctyp (mkpolytype t), mkloc loc);
+value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc);
 value type_decl tl cl =
   fun
   [ TyMan loc t (TyRec _ pflag ltl) ->
diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml
index 786075527c..b3c9f6477c 100644
--- a/camlp4/ocaml_src/camlp4/ast2pt.ml
+++ b/camlp4/ocaml_src/camlp4/ast2pt.ml
@@ -226,8 +226,8 @@ let mktype loc tl cl tk tm =
 ;;
 let mkmutable m = if m then Mutable else Immutable;;
 let mkprivate m = if m then Private else Public;;
-let mktrecord (_, n, m, t) = n, mkmutable m, ctyp (mkpolytype t);;
-let mkvariant (_, c, tl) = c, List.map ctyp tl;;
+let mktrecord (loc, n, m, t) = n, mkmutable m, ctyp (mkpolytype t), mkloc loc;;
+let mkvariant (loc, c, tl) = c, List.map ctyp tl, mkloc loc;;
 let type_decl tl cl =
   function
     TyMan (loc, t, TyRec (_, pflag, ltl)) ->
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 278afad84c..23be6e8dd3 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -180,13 +180,14 @@ module Analyser =
             match cons_core_type_list_list with
               [] ->
                 (0, acc)
-            | (name, core_type_list) :: [] ->
+            | (name, core_type_list, xxloc) :: [] ->
                 let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
                 let s = get_string_of_file pos_end pos_limit in
                 let (len, comment_opt) =  My_ir.just_after_special !file_name s in
                 (len, acc @ [ (name, comment_opt) ])
 
-            | (name, core_type_list) :: (name2, core_type_list2) :: q ->
+            | (name, core_type_list, xxloc) :: (name2, core_type_list2, loc2)
+              :: q ->
                 match (List.rev core_type_list, core_type_list2) with
                   ([], []) ->
                     let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
@@ -194,7 +195,8 @@ module Analyser =
                     let pos2 = Str.search_forward (Str.regexp_string name2) !file pos' in
                     let s = get_string_of_file pos' pos2 in
                     let (_,comment_opt) =  My_ir.just_after_special !file_name  s in
-                    f (acc @ [name, comment_opt]) pos2 ((name2, core_type_list2) :: q)
+                    f (acc @ [name, comment_opt]) pos2
+                      ((name2, core_type_list2, loc2) :: q)
                       
                 | ([], (ct2 :: _)) ->
                     let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
@@ -203,7 +205,8 @@ module Analyser =
                     let pos2' = Str.search_backward (Str.regexp_string name2) !file pos2 in
                     let s = get_string_of_file pos' pos2' in
                     let (_,comment_opt) =  My_ir.just_after_special !file_name  s in
-                    f (acc @ [name, comment_opt]) pos2' ((name2, core_type_list2) :: q)
+                    f (acc @ [name, comment_opt]) pos2'
+                      ((name2, core_type_list2, loc2) :: q)
                       
                 | ((ct :: _), _) ->
                     let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
@@ -215,7 +218,8 @@ module Analyser =
                         None -> ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum
                        | Some _ -> Str.search_forward (Str.regexp "*)") !file pos
                     in
-                    f (acc @ [name, comment_opt]) new_pos_end ((name2, core_type_list2) :: q)
+                    f (acc @ [name, comment_opt]) new_pos_end
+                      ((name2, core_type_list2, loc2) :: q)
           in
           f [] pos_start cons_core_type_list_list
             
@@ -223,12 +227,12 @@ module Analyser =
           let rec f = function
               [] ->
                 []
-            | (name, _, ct) :: [] ->
+            | (name, _, ct, xxloc) :: [] ->
                 let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
                 let s = get_string_of_file pos pos_end in
                 let (_,comment_opt) =  My_ir.just_after_special !file_name s in
                 [name, comment_opt]
-            | (name,_,ct) :: ((name2,_,ct2) as ele2) :: q ->
+            | (name,_,ct,xxloc) :: ((name2,_,ct2,xxloc2) as ele2) :: q ->
                 let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
                 let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
                 let s = get_string_of_file pos pos2 in
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 7567d7362b..a86fd90f48 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -169,9 +169,9 @@ let search_pos_type_decl td ~pos ~env =
       Ptype_abstract -> ()
     | Ptype_variant (dl, _) ->
         List.iter dl
-          ~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env))
+          ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
     | Ptype_record (dl, _) ->
-        List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env) in
+        List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
     search_tkind td.ptype_kind;
     List.iter td.ptype_cstrs ~f:
       begin fun (t1, t2, _) ->
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 651366b447..5907561b7a 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1181,7 +1181,7 @@ constructor_declarations:
   | constructor_declarations BAR constructor_declaration { $3 :: $1 }
 ;
 constructor_declaration:
-    constr_ident constructor_arguments          { ($1, $2) }
+    constr_ident constructor_arguments          { ($1, $2, symbol_rloc()) }
 ;
 constructor_arguments:
     /*empty*/                                   { [] }
@@ -1192,7 +1192,7 @@ label_declarations:
   | label_declarations SEMI label_declaration   { $3 :: $1 }
 ;
 label_declaration:
-    mutable_flag label COLON poly_type          { ($2, $1, $4) }
+    mutable_flag label COLON poly_type          { ($2, $1, $4, symbol_rloc()) }
 ;
 
 /* "with" constraints (additional type equations over signature components) */
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d0db6b8483..f53ad2cbe0 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -130,8 +130,9 @@ and type_declaration =
 
 and type_kind =
     Ptype_abstract
-  | Ptype_variant of (string * core_type list) list * private_flag
-  | Ptype_record of (string * mutable_flag * core_type) list * private_flag
+  | Ptype_variant of (string * core_type list * Location.t) list * private_flag
+  | Ptype_record of
+      (string * mutable_flag * core_type * Location.t) list * private_flag
 
 and exception_declaration = core_type list
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 340917155f..db5f79dfa8 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -319,10 +319,10 @@ and type_kind i ppf x =
       line i ppf "Ptype_abstract\n"
   | Ptype_variant (l, priv) ->
       line i ppf "Ptype_variant %a\n" fmt_private_flag priv;
-      list (i+1) string_x_core_type_list ppf l;
+      list (i+1) string_x_core_type_list_x_location ppf l;
   | Ptype_record (l, priv) ->
       line i ppf "Ptype_record %a\n" fmt_private_flag priv;
-      list (i+1) string_x_mutable_flag_x_core_type ppf l;
+      list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l;
 
 and exception_declaration i ppf x = list i core_type ppf x
 
@@ -611,11 +611,11 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
   core_type (i+1) ppf ct1;
   core_type (i+1) ppf ct2;
 
-and string_x_core_type_list i ppf (s, l) =
+and string_x_core_type_list_x_location i ppf (s, l, loc) =
   string i ppf s;
   list (i+1) core_type ppf l;
 
-and string_x_mutable_flag_x_core_type i ppf (s, mf, ct) =
+and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
   line i ppf "\"%s\" %a\n" s fmt_mutable_flag mf;
   core_type (i+1) ppf ct;
 
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index 6fc3961eee..aa28b9dcce 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -78,4 +78,4 @@ let catch_break on =
 
 (* OCaml version string, must be in the format described in sys.mli. *)
 
-let ocaml_version = "3.09+dev2 (2004-09-19)";;
+let ocaml_version = "3.09+dev3 (2004-10-06)";;
diff --git a/tools/depend.ml b/tools/depend.ml
index 8871d908df..e3b3e64f34 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -70,9 +70,9 @@ let add_type_declaration bv td =
   let rec add_tkind = function
     Ptype_abstract -> ()
   | Ptype_variant (cstrs, _) ->
-      List.iter (fun (c, args) -> List.iter (add_type bv) args) cstrs
+      List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs
   | Ptype_record (lbls, _) ->
-      List.iter (fun (l, mut, ty) -> add_type bv ty) lbls in
+      List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
   add_tkind td.ptype_kind
 
 let rec add_class_type bv cty =
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index c4bcc9def1..ff2e237125 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -109,29 +109,29 @@ let transl_declaration env (name, sdecl) id =
         | Ptype_variant (cstrs, priv) ->
             let all_constrs = ref StringSet.empty in
             List.iter
-              (fun (name, args) ->
+              (fun (name, args, loc) ->
                 if StringSet.mem name !all_constrs then
                   raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
                 all_constrs := StringSet.add name !all_constrs)
               cstrs;
-            if List.length (List.filter (fun (name, args) -> args <> []) cstrs)
+            if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs)
                > (Config.max_tag + 1) then
               raise(Error(sdecl.ptype_loc, Too_many_constructors));
             Type_variant(List.map
-              (fun (name, args) ->
+              (fun (name, args, loc) ->
                       (name, List.map (transl_simple_type env true) args))
               cstrs, priv)
         | Ptype_record (lbls, priv) ->
             let all_labels = ref StringSet.empty in
             List.iter
-              (fun (name, mut, arg) ->
+              (fun (name, mut, arg, loc) ->
                 if StringSet.mem name !all_labels then
                   raise(Error(sdecl.ptype_loc, Duplicate_label name));
                 all_labels := StringSet.add name !all_labels)
               lbls;
             let lbls' =
               List.map
-                (fun (name, mut, arg) ->
+                (fun (name, mut, arg, loc) ->
                   let ty = transl_simple_type env true arg in
                   name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
                 lbls in
@@ -223,7 +223,9 @@ let check_constraints env (_, sdecl) (_, decl) =
       let pl = find_pl sdecl.ptype_kind in
       List.iter
         (fun (name, tyl) ->
-          let styl = try List.assoc name pl with Not_found -> assert false in
+          let styl =
+            try let (_,sty,_) = List.find (fun (n,_,_) -> n = name) pl in sty
+            with Not_found -> assert false in
           List.iter2
             (fun sty ty ->
               check_constraints_rec env sty.ptyp_loc visited ty)
@@ -237,7 +239,7 @@ let check_constraints env (_, sdecl) (_, decl) =
       let pl = find_pl sdecl.ptype_kind in
       let rec get_loc name = function
           [] -> assert false
-        | (name', _, sty) :: tl ->
+        | (name', _, sty, _) :: tl ->
             if name = name' then sty.ptyp_loc else get_loc name tl
       in
       List.iter