diff options
Diffstat (limited to 'typing')
| -rw-r--r-- | typing/includemod.ml | 26 | ||||
| -rw-r--r-- | typing/mtype.ml | 4 | ||||
| -rw-r--r-- | typing/subst.ml | 4 | ||||
| -rw-r--r-- | typing/typeclass.ml | 14 | ||||
| -rw-r--r-- | typing/typecore.ml | 33 | ||||
| -rw-r--r-- | typing/typedecl.ml | 4 | ||||
| -rw-r--r-- | typing/types.ml | 4 | ||||
| -rw-r--r-- | typing/types.mli | 4 |
8 files changed, 61 insertions, 32 deletions
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 *) |