Align typed value_declaration with parsetree.

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

bytecomp/translmod.ml

@@ -290,7 +290,7 @@ and transl_structure fields cc rootpath = function
       let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
       transl_let rec_flag pat_expr_list
                  (transl_structure ext_fields cc rootpath rem)
-  | Tstr_primitive(id, _, descr) ->
+  | Tstr_primitive descr ->
       record_primitive descr.val_val;
       transl_structure fields cc rootpath rem
   | Tstr_type(decls) ->
@@ -363,7 +363,7 @@ let rec defined_idents = function
     | Tstr_eval expr -> defined_idents rem
     | Tstr_value(rec_flag, pat_expr_list) ->
       let_bound_idents pat_expr_list @ defined_idents rem
-    | Tstr_primitive(id, _, descr) -> defined_idents rem
+    | Tstr_primitive desc -> defined_idents rem
     | Tstr_type decls -> defined_idents rem
     | Tstr_exception(id, _, decl) -> id :: defined_idents rem
     | Tstr_exn_rebind(id, _, path, _, _) -> id :: defined_idents rem
@@ -385,7 +385,7 @@ let rec more_idents = function
     match item.str_desc with
     | Tstr_eval expr -> more_idents rem
     | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem
-    | Tstr_primitive(id, _, descr) -> more_idents rem
+    | Tstr_primitive _ -> more_idents rem
     | Tstr_type decls -> more_idents rem
     | Tstr_exception(id, _, decl) -> more_idents rem
     | Tstr_exn_rebind(id, _, path, _, _) -> more_idents rem
@@ -407,7 +407,7 @@ and all_idents = function
     | Tstr_eval expr -> all_idents rem
     | Tstr_value(rec_flag, pat_expr_list) ->
       let_bound_idents pat_expr_list @ all_idents rem
-    | Tstr_primitive(id, _, descr) -> all_idents rem
+    | Tstr_primitive _ -> all_idents rem
     | Tstr_type decls -> all_idents rem
     | Tstr_exception(id, _, decl) -> id :: all_idents rem
     | Tstr_exn_rebind(id, _, path, _, _) -> id :: all_idents rem
@@ -460,7 +460,7 @@ let transl_store_structure glob map prims str =
       let lam = transl_let rec_flag pat_expr_list (store_idents ids) in
       Lsequence(subst_lambda subst lam,
                 transl_store rootpath (add_idents false ids subst) rem)
-  | Tstr_primitive(id, _, descr) ->
+  | Tstr_primitive descr ->
       record_primitive descr.val_val;
       transl_store rootpath subst rem
   | Tstr_type(decls) ->

ocamldoc/odoc_ast.ml

@@ -106,8 +106,8 @@ module Typedtree_search =
               | Some n -> Hashtbl.add table_values n (pat,exp)
             )
             pat_exp_list
-      | Typedtree.Tstr_primitive (ident, _, _) ->
-          Hashtbl.add table (P (Name.from_ident ident)) tt
+      | Typedtree.Tstr_primitive vd ->
+          Hashtbl.add table (P (Name.from_ident vd.val_id)) tt
       | Typedtree.Tstr_open _ -> ()
       | Typedtree.Tstr_include _ -> ()
       | Typedtree.Tstr_eval _ -> ()
@@ -167,7 +167,7 @@ module Typedtree_search =
 
     let search_primitive table name =
       match Hashtbl.find table (P name) with
-        Tstr_primitive (ident, _, val_desc) -> val_desc.val_val.Types.val_type
+        Tstr_primitive vd -> vd.val_val.Types.val_type
       | _ -> assert false
 
     let get_nth_inherit_class_expr cls n =

tools/tast_iter.ml

@@ -22,7 +22,7 @@ let structure_item sub x =
   match x.str_desc with
   | Tstr_eval exp -> sub # expression exp
   | Tstr_value (rec_flag, list) -> sub # bindings (rec_flag, list)
-  | Tstr_primitive (_id, _, v) -> sub # value_description v
+  | Tstr_primitive v -> sub # value_description v
   | Tstr_type list ->
       List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list
   | Tstr_exception (_id, _, decl) -> sub # exception_declaration decl
@@ -171,7 +171,7 @@ let signature sub sg =
 
 let signature_item sub item =
   match item.sig_desc with
-  | Tsig_value (_id, _, v) ->
+  | Tsig_value v ->
       sub # value_description v
   | Tsig_type list ->
       List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list

tools/untypeast.ml

@@ -50,8 +50,8 @@ and untype_structure_item item =
     | Tstr_value (rec_flag, list) ->
         Pstr_value (rec_flag, List.map (fun (pat, exp) ->
               untype_pattern pat, untype_expression exp) list)
-    | Tstr_primitive (_id, name, v) ->
-        Pstr_primitive (untype_value_description name v)
+    | Tstr_primitive vd ->
+        Pstr_primitive (untype_value_description vd)
     | Tstr_type list ->
         Pstr_type (List.map (fun (_id, name, decl) ->
               untype_type_declaration name decl) list)
@@ -106,9 +106,9 @@ and untype_structure_item item =
   in
   { pstr_desc = desc; pstr_loc = item.str_loc; }
 
-and untype_value_description name v =
+and untype_value_description v =
   {
-   pval_name = name;
+   pval_name = v.val_name;
    pval_prim = v.val_prim;
    pval_type = untype_core_type v.val_desc;
    pval_loc = v.val_loc;
@@ -316,8 +316,8 @@ and untype_signature sg =
 and untype_signature_item item =
   let desc =
     match item.sig_desc with
-      Tsig_value (_id, name, v) ->
-        Psig_value (untype_value_description name v)
+      Tsig_value v ->
+        Psig_value (untype_value_description v)
     | Tsig_type list ->
         Psig_type (List.map (fun (_id, name, decl) ->
               untype_type_declaration name decl

typing/printtyped.ml

@@ -374,7 +374,7 @@ and expression i ppf x =
       module_expr i ppf me
 
 and value_description i ppf x =
-  line i ppf "value_description\n";
+  line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location x.val_loc;
   attributes i ppf x.val_attributes;
   core_type (i+1) ppf x.val_desc;
   list (i+1) string ppf x.val_prim;
@@ -587,8 +587,8 @@ and signature_item i ppf x =
   line i ppf "signature_item %a\n" fmt_location x.sig_loc;
   let i = i+1 in
   match x.sig_desc with
-  | Tsig_value (s, _, vd) ->
-      line i ppf "Psig_value \"%a\"\n" fmt_ident s;
+  | Tsig_value vd ->
+      line i ppf "Psig_value\n";
       value_description i ppf vd;
   | Tsig_type (l) ->
       line i ppf "Psig_type\n";
@@ -685,8 +685,8 @@ and structure_item i ppf x =
   | Tstr_value (rf, l) ->
       line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
       list i pattern_x_expression_def ppf l;
-  | Tstr_primitive (s, _, vd) ->
-      line i ppf "Pstr_primitive \"%a\"\n" fmt_ident s;
+  | Tstr_primitive vd ->
+      line i ppf "Pstr_primitive\n";
       value_description i ppf vd;
   | Tstr_type l ->
       line i ppf "Pstr_type\n";

typing/typedecl.ml

@@ -923,11 +923,21 @@ let transl_value_decl env loc valdecl =
       then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
       { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc }
   in
-  { val_desc = cty; val_val = v;
-    val_prim = valdecl.pval_prim;
-    val_loc = valdecl.pval_loc;
-    val_attributes = valdecl.pval_attributes;
-   }
+  let (id, newenv) =
+    Env.enter_value valdecl.pval_name.txt v env
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+  in
+  let desc =
+    {
+     val_id = id;
+     val_name = valdecl.pval_name;
+     val_desc = cty; val_val = v;
+     val_prim = valdecl.pval_prim;
+     val_loc = valdecl.pval_loc;
+     val_attributes = valdecl.pval_attributes;
+    }
+  in
+  desc, newenv
 
 (* Translate a "with" constraint -- much simplified version of
     transl_type_decl. *)

typing/typedecl.mli

@@ -28,7 +28,7 @@ val transl_exn_rebind:
 
 val transl_value_decl:
     Env.t -> Location.t ->
-    Parsetree.value_description -> Typedtree.value_description
+    Parsetree.value_description -> Typedtree.value_description * Env.t
 
 val transl_with_constraint:
     Env.t -> Ident.t -> Path.t option -> Types.type_declaration ->

typing/typedtree.ml

@@ -200,7 +200,7 @@ and structure_item =
 and structure_item_desc =
     Tstr_eval of expression
   | Tstr_value of rec_flag * (pattern * expression) list
-  | Tstr_primitive of Ident.t * string loc * value_description
+  | Tstr_primitive of value_description
   | Tstr_type of (Ident.t * string loc * type_declaration) list
   | Tstr_exception of Ident.t * string loc * exception_declaration
   | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attribute list
@@ -246,7 +246,7 @@ and signature_item =
     sig_loc: Location.t }
 
 and signature_item_desc =
-    Tsig_value of Ident.t * string loc * value_description
+    Tsig_value of value_description
   | Tsig_type of (Ident.t * string loc * type_declaration) list
   | Tsig_exception of Ident.t * string loc * exception_declaration
   | Tsig_module of module_declaration
@@ -322,10 +322,12 @@ and row_field =
   | Tinherit of core_type
 
 and value_description =
-  { val_desc : core_type;
-    val_val : Types.value_description;
-    val_prim : string list;
-    val_loc : Location.t;
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
     val_attributes: attribute list;
     }
 

typing/typedtree.mli

@@ -199,7 +199,7 @@ and structure_item =
 and structure_item_desc =
     Tstr_eval of expression
   | Tstr_value of rec_flag * (pattern * expression) list
-  | Tstr_primitive of Ident.t * string loc * value_description
+  | Tstr_primitive of value_description
   | Tstr_type of (Ident.t * string loc * type_declaration) list
   | Tstr_exception of Ident.t * string loc * exception_declaration
   | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attribute list
@@ -245,7 +245,7 @@ and signature_item =
     sig_loc: Location.t }
 
 and signature_item_desc =
-    Tsig_value of Ident.t * string loc * value_description
+    Tsig_value of value_description
   | Tsig_type of (Ident.t * string loc * type_declaration) list
   | Tsig_exception of Ident.t * string loc * exception_declaration
   | Tsig_module of module_declaration
@@ -321,10 +321,12 @@ and row_field =
   | Tinherit of core_type
 
 and value_description =
-  { val_desc : core_type;
-    val_val : Types.value_description;
-    val_prim : string list;
-    val_loc : Location.t;
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
     val_attributes: attribute list;
     }
 

typing/typedtreeIter.ml

@@ -128,7 +128,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
           Tstr_eval exp -> iter_expression exp
         | Tstr_value (rec_flag, list) ->
             iter_bindings rec_flag list
-        | Tstr_primitive (id, _, v) -> iter_value_description v
+        | Tstr_primitive vd -> iter_value_description vd
         | Tstr_type list ->
             List.iter (fun (id, _, decl) -> iter_type_declaration decl) list
         | Tstr_exception (id, _, decl) -> iter_exception_declaration decl
@@ -344,8 +344,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
       Iter.enter_signature_item item;
       begin
         match item.sig_desc with
-          Tsig_value (id, _, v) ->
-            iter_value_description v
+          Tsig_value vd ->
+            iter_value_description vd
         | Tsig_type list ->
             List.iter (fun (id, _, decl) ->
                 iter_type_declaration decl

typing/typedtreeMap.ml

@@ -100,8 +100,8 @@ module MakeMap(Map : MapArgument) = struct
           Tstr_eval exp -> Tstr_eval (map_expression exp)
         | Tstr_value (rec_flag, list) ->
           Tstr_value (rec_flag, map_bindings rec_flag list)
-        | Tstr_primitive (id, name, v) ->
-          Tstr_primitive (id, name, map_value_description v)
+        | Tstr_primitive vd ->
+          Tstr_primitive (map_value_description vd)
         | Tstr_type list ->
           Tstr_type (List.map (
             fun (id, name, decl) ->
@@ -393,8 +393,8 @@ module MakeMap(Map : MapArgument) = struct
     let item = Map.enter_signature_item item in
     let sig_desc =
       match item.sig_desc with
-          Tsig_value (id, name, v) ->
-            Tsig_value (id, name, map_value_description v)
+          Tsig_value vd ->
+            Tsig_value (map_value_description vd)
         | Tsig_type list -> Tsig_type (
           List.map (fun (id, name, decl) ->
             (id, name, map_type_declaration decl)

typing/typemod.ml

@@ -460,15 +460,11 @@ and transl_signature env sg =
         let loc = item.psig_loc in
         match item.psig_desc with
         | Psig_value sdesc ->
-            let tdesc = Typedecl.transl_value_decl env item.psig_loc sdesc in
-            let desc = tdesc.val_val in
-            let (id, newenv) =
-              Env.enter_value sdesc.pval_name.txt desc env
-                ~check:(fun s -> Warnings.Unused_value_declaration s)  in
+            let (tdesc, newenv) = Typedecl.transl_value_decl env item.psig_loc sdesc in
             let (trem,rem, final_env) = transl_sig newenv srem in
-            mksig (Tsig_value (id, sdesc.pval_name, tdesc)) env loc :: trem,
-            (if List.exists (Ident.equal id) (get_values rem) then rem
-            else Sig_value(id, desc) :: rem),
+            mksig (Tsig_value tdesc) env loc :: trem,
+            (if List.exists (Ident.equal tdesc.val_id) (get_values rem) then rem
+            else Sig_value(tdesc.val_id, tdesc.val_val) :: rem),
               final_env
         | Psig_type sdecls ->
             List.iter
@@ -992,12 +988,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
          map_end make_sig_value bound_idents sig_rem,
          final_env)
     | Pstr_primitive sdesc ->
-        let desc = Typedecl.transl_value_decl env loc sdesc in
-        let (id, newenv) = Env.enter_value sdesc.pval_name.txt desc.val_val env
-            ~check:(fun s -> Warnings.Unused_value_declaration s) in
-        let item = mk (Tstr_primitive(id, sdesc.pval_name, desc)) in
+        let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
+        let item = mk (Tstr_primitive desc) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
-        (item :: str_rem, Sig_value(id, desc.val_val) :: sig_rem, final_env)
+        (item :: str_rem, Sig_value(desc.val_id, desc.val_val) :: sig_rem, final_env)
     | Pstr_type sdecls ->
         List.iter
           (fun decl -> check "type" loc type_names decl.ptype_name.txt)