diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 2488e8da9..4e3be11c4 100644 --- a/bytecomp/translmod.ml +++ b/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) -> diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index eb321e29d..3ab8d9a98 100644 --- a/ocamldoc/odoc_ast.ml +++ b/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 = diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml index 3972bd15e..084821bdb 100644 --- a/tools/tast_iter.ml +++ b/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 diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 45c3ed4af..fbb0e9df2 100644 --- a/tools/untypeast.ml +++ b/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 diff --git a/typing/printtyped.ml b/typing/printtyped.ml index d86bbb359..6082dc9ed 100644 --- a/typing/printtyped.ml +++ b/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"; diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 18a8df9ac..cb3267792 100644 --- a/typing/typedecl.ml +++ b/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. *) diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 696989ebb..a1f0cfb2c 100644 --- a/typing/typedecl.mli +++ b/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 -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index dad330166..c61de7d7b 100644 --- a/typing/typedtree.ml +++ b/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; } diff --git a/typing/typedtree.mli b/typing/typedtree.mli index f37480ca6..436c654fa 100644 --- a/typing/typedtree.mli +++ b/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; } diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 0302b40f6..2f865a31d 100644 --- a/typing/typedtreeIter.ml +++ b/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 diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index c964717d1..6452d15e4 100644 --- a/typing/typedtreeMap.ml +++ b/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) diff --git a/typing/typemod.ml b/typing/typemod.ml index d0726316c..8e8bdae3e 100644 --- a/typing/typemod.ml +++ b/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)