merge changes from 4.00 branching to 4.00.0 (part 1)

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

1 files changed, 181 insertions, 135 deletions

diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index 26f813cad..74fbb50f1 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -358,6 +358,13 @@ module Analyser =
            let name_pre = Name.from_ident ident in
            let name = Name.parens_if_infix name_pre in
            let complete_name = Name.concat current_module_name name in
+           let code =
+              if !Odoc_global.keep_code then
+                Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+                      loc.Location.loc_end.Lexing.pos_cnum)
+              else
+                None
+            in
            (* create the value *)
            let new_value = {
              val_name = complete_name ;
@@ -365,8 +372,8 @@ module Analyser =
              val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
              val_recursive = rec_flag = Asttypes.Recursive ;
              val_parameters = tt_analyse_function_parameters env comment_opt pat_exp_list2 ;
-             val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-             val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+             val_code = code ;
+             val_loc = { loc_impl = Some loc ; loc_inter = None } ;
            }
            in
            [ new_value ]
@@ -376,14 +383,21 @@ module Analyser =
            let name_pre = Name.from_ident ident in
            let name = Name.parens_if_infix name_pre in
            let complete_name = Name.concat current_module_name name in
+           let code =
+             if !Odoc_global.keep_code then
+                Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+                      loc.Location.loc_end.Lexing.pos_cnum)
+             else
+               None
+            in
            let new_value = {
              val_name = complete_name ;
              val_info = comment_opt ;
              val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
              val_recursive = rec_flag = Asttypes.Recursive ;
              val_parameters = [] ;
-             val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-             val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+             val_code = code ;
+             val_loc = { loc_impl = Some loc ; loc_inter = None } ;
            }
            in
            [ new_value ]
@@ -438,7 +452,7 @@ module Analyser =
            | l ->
                match l with
                  [] ->
-                   (* cas impossible, on l'a filtré avant *)
+                   (* cas impossible, on l'a filtré avant *)
                    assert false
                | (pattern_param, exp) :: second_ele :: q ->
                    (* implicit pattern matching -> anonymous parameter *)
@@ -553,27 +567,34 @@ module Analyser =
             try
               if virt then
                 Typedtree_search.search_virtual_attribute_type table
-                  (Name.simple current_class_name) label
+                (Name.simple current_class_name) label
               else
                 Typedtree_search.search_attribute_type tt_cls label
             with Not_found ->
                 raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name))
-            in
-            let att =
-              {
-                att_value = { val_name = complete_name ;
-                              val_info = info_opt ;
-                              val_type = Odoc_env.subst_type env type_exp ;
-                              val_recursive = false ;
-                              val_parameters = [] ;
-                              val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-                              val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
-                            } ;
-                att_mutable = mutable_flag = Asttypes.Mutable ;
-                att_virtual = virt ;
-              }
-            in
-            iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q
+          in
+          let code =
+            if !Odoc_global.keep_code then
+              Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+                    loc.Location.loc_end.Lexing.pos_cnum)
+            else
+              None
+          in
+          let att =
+            {
+              att_value = { val_name = complete_name ;
+                val_info = info_opt ;
+                val_type = Odoc_env.subst_type env type_exp ;
+                val_recursive = false ;
+                val_parameters = [] ;
+                val_code = code ;
+                val_loc = { loc_impl = Some loc ; loc_inter = None } ;
+              } ;
+              att_mutable = mutable_flag = Asttypes.Mutable ;
+              att_virtual = virt ;
+            }
+          in
+          iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q
 
         | (Parsetree.Pcf_virt  ({ txt = label }, private_flag, _)) ->
             let complete_name = Name.concat current_class_name label in
@@ -584,64 +605,79 @@ module Analyser =
             in
             let real_type =
               match met_type.Types.desc with
-                Tarrow (_, _, t, _) ->
-                  t
-              |  _ ->
+              Tarrow (_, _, t, _) ->
+                t
+            |  _ ->
                 (* ?!? : not an arrow type ! return the original type *)
-                  met_type
-            in
-            let met =
-              {
-                met_value = { val_name = complete_name ;
-                              val_info = info_opt ;
-                              val_type = Odoc_env.subst_type env real_type ;
-                              val_recursive = false ;
-                              val_parameters = [] ;
-                              val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-                              val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
-                            } ;
-                met_private = private_flag = Asttypes.Private ;
-                met_virtual = true ;
-              }
-            in
-            (* update the parameter description *)
-            Odoc_value.update_value_parameters_text met.met_value;
+                met_type
+          in
+          let code =
+            if !Odoc_global.keep_code then
+              Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+               loc.Location.loc_end.Lexing.pos_cnum)
+            else
+              None
+          in
+          let met =
+            {
+              met_value = {
+                val_name = complete_name ;
+                val_info = info_opt ;
+                val_type = Odoc_env.subst_type env real_type ;
+                val_recursive = false ;
+                val_parameters = [] ;
+                val_code = code ;
+                val_loc = { loc_impl = Some loc ; loc_inter = None } ;
+              } ;
+              met_private = private_flag = Asttypes.Private ;
+              met_virtual = true ;
+            }
+          in
+          (* update the parameter description *)
+          Odoc_value.update_value_parameters_text met.met_value;
 
-            iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
+          iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
 
         | (Parsetree.Pcf_meth ({ txt = label }, private_flag, _, _)) ->
             let complete_name = Name.concat current_class_name label in
             let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
             let exp =
               try Typedtree_search.search_method_expression tt_cls label
-              with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
-            in
-            let real_type =
-              match exp.exp_type.desc with
-                Tarrow (_, _, t,_) ->
-                  t
-              |  _ ->
+            with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
+          in
+          let real_type =
+            match exp.exp_type.desc with
+              Tarrow (_, _, t,_) ->
+                t
+            |  _ ->
                 (* ?!? : not an arrow type ! return the original type *)
-                  exp.Typedtree.exp_type
-            in
-            let met =
-              {
-                met_value = { val_name = complete_name ;
-                              val_info = info_opt ;
-                              val_type = Odoc_env.subst_type env real_type ;
-                              val_recursive = false ;
-                              val_parameters = tt_analyse_method_expression env complete_name info_opt exp ;
-                              val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-                              val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
-                            } ;
-                met_private = private_flag = Asttypes.Private ;
-                met_virtual = false ;
+                exp.Typedtree.exp_type
+          in
+          let code =
+            if !Odoc_global.keep_code then
+                Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+               loc.Location.loc_end.Lexing.pos_cnum)
+            else
+              None
+          in
+          let met =
+            {
+              met_value = { val_name = complete_name ;
+                val_info = info_opt ;
+                val_type = Odoc_env.subst_type env real_type ;
+                val_recursive = false ;
+                val_parameters = tt_analyse_method_expression env complete_name info_opt exp ;
+                val_code = code ;
+                val_loc = { loc_impl = Some loc ; loc_inter = None } ;
+              } ;
+              met_private = private_flag = Asttypes.Private ;
+              met_virtual = false ;
               }
-            in
-            (* update the parameter description *)
-            Odoc_value.update_value_parameters_text met.met_value;
+          in
+          (* update the parameter description *)
+          Odoc_value.update_value_parameters_text met.met_value;
 
-            iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
+          iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
 
         | Parsetree.Pcf_constr (_, _) ->
             (* don't give a $*%@ ! *)
@@ -664,7 +700,7 @@ module Analyser =
                 (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
                 Name.from_longident lid.txt
           in
-          (* On n'a pas ici les paramètres de type sous forme de Types.type_expr,
+          (* On n'a pas ici les paramètres de type sous forme de Types.type_expr,
              par contre on peut les trouver dans le class_type *)
           let params =
             match tt_class_exp.Typedtree.cl_type with
@@ -749,7 +785,7 @@ module Analyser =
             match tt_class_expr2.Typedtree.cl_desc with
               Typedtree.Tcl_ident (p,_,_) -> Name.from_path p (* A VOIR : obtenir le nom complet *)
             | _ ->
-                (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
+                (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
                 match p_class_expr2.Parsetree.pcl_desc with
                   Parsetree.Pcl_constr (lid, _) ->
                     (* we try to get the name from the environment. *)
@@ -814,7 +850,8 @@ module Analyser =
     let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp table =
       let name = p_class_decl.Parsetree.pci_name in
       let complete_name = Name.concat current_module_name name.txt in
-      let pos_start = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in
+      let loc = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc in
+      let pos_start = loc.Location.loc_start.Lexing.pos_cnum in
       let type_parameters = tt_type_params in
       let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in
       let cltype = Odoc_env.subst_class_type env tt_class_exp.Typedtree.cl_type in
@@ -836,7 +873,7 @@ module Analyser =
           cl_type_parameters = type_parameters ;
           cl_kind = kind ;
           cl_parameters = parameters ;
-          cl_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ;
+          cl_loc = { loc_impl = Some loc ; loc_inter = None } ;
         }
       in
       cl
@@ -1089,23 +1126,30 @@ module Analyser =
           (0, new_env, l_ele)
 
       | Parsetree.Pstr_primitive ({ txt = name_pre }, val_desc) ->
-          (* of string * value_description *)
-          print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]");
-          let typ = Typedtree_search.search_primitive table name_pre in
-          let name = Name.parens_if_infix name_pre in
-          let complete_name = Name.concat current_module_name name in
-          let new_value = {
-             val_name = complete_name ;
-             val_info = comment_opt ;
-             val_type = Odoc_env.subst_type env typ ;
-             val_recursive = false ;
-             val_parameters = [] ;
-             val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-             val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
-           }
-           in
-          let new_env = Odoc_env.add_value env new_value.val_name in
-          (0, new_env, [Element_value new_value])
+            (* of string * value_description *)
+            print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]");
+            let typ = Typedtree_search.search_primitive table name_pre in
+            let name = Name.parens_if_infix name_pre in
+            let complete_name = Name.concat current_module_name name in
+            let code =
+              if !Odoc_global.keep_code then
+                Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+                      loc.Location.loc_end.Lexing.pos_cnum)
+              else
+                None
+            in
+            let new_value = {
+                val_name = complete_name ;
+                val_info = comment_opt ;
+                val_type = Odoc_env.subst_type env typ ;
+                val_recursive = false ;
+                val_parameters = [] ;
+                val_code = code ;
+                val_loc = { loc_impl = Some loc ; loc_inter = None } ;
+              }
+            in
+            let new_env = Odoc_env.add_value env new_value.val_name in
+            (0, new_env, [Element_value new_value])
 
       | Parsetree.Pstr_type name_typedecl_list ->
           (* of (string * type_declaration) list *)
@@ -1124,14 +1168,15 @@ module Analyser =
               [] -> (maybe_more_acc, [])
             | ({ txt = name }, type_decl) :: q ->
                 let complete_name = Name.concat current_module_name name in
-                let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
-                let loc_end =  type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum in
+                let loc = type_decl.Parsetree.ptype_loc in
+                let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
+                let loc_end =  loc.Location.loc_end.Lexing.pos_cnum in
                 let pos_limit2 =
                   match q with
-                    [] -> pos_limit
-                  | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
-                in
-                let (maybe_more, name_comment_list) =
+                      [] -> pos_limit
+                    | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
+                  in
+                  let (maybe_more, name_comment_list) =
                     Sig.name_comment_from_type_kind
                     loc_end
                     pos_limit2
@@ -1151,47 +1196,47 @@ module Analyser =
                   let kind = Sig.get_type_kind
                     new_env name_comment_list
                     tt_type_decl.Types.type_kind
-                in
-                let new_end = loc_end + maybe_more in
-                let t =
-                  {
-                    ty_name = complete_name ;
-                    ty_info = com_opt ;
-                    ty_parameters =
+                  in
+                  let new_end = loc_end + maybe_more in
+                  let t =
+                    {
+                      ty_name = complete_name ;
+                      ty_info = com_opt ;
+                      ty_parameters =
                       List.map2
-                        (fun p (co,cn,_) ->
-                          (Odoc_env.subst_type new_env p,
-                           co, cn)
-                        )
+                      (fun p (co,cn,_) ->
+                         (Odoc_env.subst_type new_env p,
+                          co, cn)
+                      )
                       tt_type_decl.Types.type_params
                       tt_type_decl.Types.type_variance ;
-                    ty_kind = kind ;
-                    ty_private = tt_type_decl.Types.type_private;
-                    ty_manifest =
-                    (match tt_type_decl.Types.type_manifest with
-                      None -> None
-                    | Some t -> Some (Odoc_env.subst_type new_env t));
-                    ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ;
-                    ty_code =
+                      ty_kind = kind ;
+                      ty_private = tt_type_decl.Types.type_private;
+                      ty_manifest =
+                        (match tt_type_decl.Types.type_manifest with
+                           None -> None
+                         | Some t -> Some (Odoc_env.subst_type new_env t));
+                      ty_loc = { loc_impl = Some loc ; loc_inter = None } ;
+                      ty_code =
                       (
                        if !Odoc_global.keep_code then
                          Some (get_string_of_file loc_start new_end)
                        else
                          None
                       ) ;
-                  }
-                in
-                let (maybe_more2, info_after_opt) =
-                  My_ir.just_after_special
+                    }
+                  in
+                  let (maybe_more2, info_after_opt) =
+                    My_ir.just_after_special
                     !file_name
                     (get_string_of_file new_end pos_limit2)
-                in
-                t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ;
-                let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in
-                (maybe_more3, ele_comments @ ((Element_type t) :: eles))
-          in
-          let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in
-          (maybe_more, new_env, eles)
+                  in
+                  t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ;
+                  let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in
+                  (maybe_more3, ele_comments @ ((Element_type t) :: eles))
+            in
+            let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in
+            (maybe_more, new_env, eles)
 
       | Parsetree.Pstr_exception (name, excep_decl) ->
           (* a new exception is defined *)
@@ -1213,7 +1258,7 @@ module Analyser =
                 Odoc_env.subst_type new_env ctyp.ctyp_type)
                 tt_excep_decl.exn_params ;
               ex_alias = None ;
-              ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+              ex_loc = { loc_impl = Some loc ; loc_inter = None } ;
               ex_code =
                 (
                  if !Odoc_global.keep_code then
@@ -1242,7 +1287,7 @@ module Analyser =
               ex_args = [] ;
               ex_alias = Some { ea_name = (Odoc_env.full_exception_name env (Name.from_path tt_path)) ;
                                 ea_ex = None ; } ;
-              ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+              ex_loc = { loc_impl = Some loc ; loc_inter = None } ;
               ex_code = None ;
             }
           in
@@ -1369,7 +1414,7 @@ module Analyser =
               mt_is_interface = false ;
               mt_file = !file_name ;
               mt_kind = Some kind ;
-              mt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+              mt_loc = { loc_impl = Some loc ; loc_inter = None } ;
             }
           in
           let new_env = Odoc_env.add_module_type env mt.mt_name in
@@ -1485,7 +1530,7 @@ module Analyser =
                       clt_type_parameters = List.map (Odoc_env.subst_type new_env) type_params ;
                       clt_virtual = virt ;
                       clt_kind = kind ;
-                      clt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ;
+                      clt_loc = { loc_impl = Some loc ;
                                   loc_inter = None } ;
                     }
                 in
@@ -1504,13 +1549,14 @@ module Analyser =
               im_info = comment_opt ;
             }
           in
-          (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
+          (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
 
      (** Analysis of a [Parsetree.module_expr] and a name to return a [t_module].*)
      and analyse_module env current_module_name module_name comment_opt p_module_expr tt_module_expr =
       let complete_name = Name.concat current_module_name module_name in
-      let pos_start = p_module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
-      let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
+      let loc = p_module_expr.Parsetree.pmod_loc in
+      let pos_start = loc.Location.loc_start.Lexing.pos_cnum in
+      let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
       let modtype =
         (* A VOIR : Odoc_env.subst_module_type env  ? *)
         tt_module_expr.Typedtree.mod_type
@@ -1532,7 +1578,7 @@ module Analyser =
           m_is_interface = false ;
           m_file = !file_name ;
           m_kind = Module_struct [] ;
-          m_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ;
+          m_loc = { loc_impl = Some loc ; loc_inter = None } ;
           m_top_deps = [] ;
           m_code = None ; (* code is set by the caller, after the module is created *)
           m_code_intf = m_code_intf ;
@@ -1732,7 +1778,7 @@ module Analyser =
          m_is_interface = false ;
          m_file = !file_name ;
          m_kind = kind ;
-         m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ;
+         m_loc = { loc_impl = Some (Location.in_file !file_name) ; loc_inter = None } ;
          m_top_deps = [] ;
          m_code = (if !Odoc_global.keep_code then Some !file else None) ;
          m_code_intf = None ;