diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 49b2f35ad7e..110e897e1a5 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -183,8 +183,18 @@ and monomorphs = { mutable perfunction : (tmono * pos) list; } +let pass_name = function + | PBuildModule -> "build-module" + | PBuildClass -> "build-class" + | PConnectField -> "connect-field" + | PTypeField -> "type-field" + | PCheckConstraint -> "check-constraint" + | PForce -> "force" + | PFinal -> "final" + module TyperManager = struct let create ctx m c f e pass params = + if pass < ctx.pass then die (Printf.sprintf "Bad context clone from %s(%s) to %s(%s)" (s_type_path ctx.m.curmod.m_path) (pass_name ctx.pass) (s_type_path m.curmod.m_path) (pass_name pass)) __LOC__; let new_ctx = { com = ctx.com; g = ctx.g; @@ -260,19 +270,19 @@ module TyperManager = struct let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx ctx.m c f e PBuildModule en.e_params + create ctx ctx.m c f e PBuildClass en.e_params let clone_for_typedef ctx td = let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx ctx.m c f e PBuildModule td.t_params + create ctx ctx.m c f e PBuildClass td.t_params let clone_for_abstract ctx a = let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx ctx.m c f e PBuildModule a.a_params + create ctx ctx.m c f e PBuildClass a.a_params let clone_for_field ctx cf params = let f = create_ctx_f cf in @@ -287,6 +297,14 @@ module TyperManager = struct let clone_for_expr ctx = let e = create_ctx_e () in create ctx ctx.m ctx.c ctx.f e PTypeField ctx.type_params + + let clone_for_type_params ctx params = + create ctx ctx.m ctx.c ctx.f ctx.e ctx.pass params + + let clone_for_type_parameter_expression ctx = + let f = create_ctx_f ctx.f.curfield in + let e = create_ctx_e () in + create ctx ctx.m ctx.c f e PTypeField ctx.type_params end type field_host = @@ -351,15 +369,6 @@ let type_generic_function_ref : (typer -> field_access -> (unit -> texpr) field_ let create_context_ref : (Common.context -> ((unit -> unit) * typer) option -> typer) ref = ref (fun _ -> assert false) -let pass_name = function - | PBuildModule -> "build-module" - | PBuildClass -> "build-class" - | PConnectField -> "connect-field" - | PTypeField -> "type-field" - | PCheckConstraint -> "check-constraint" - | PForce -> "force" - | PFinal -> "final" - let warning ?(depth=0) ctx w msg p = let options = (Warning.from_meta ctx.c.curclass.cl_meta) @ (Warning.from_meta ctx.f.curfield.cf_meta) in match Warning.get_mode w options with diff --git a/src/typing/generic.ml b/src/typing/generic.ml index f3eb9eedc12..a0eebd9e8c3 100644 --- a/src/typing/generic.ml +++ b/src/typing/generic.ml @@ -26,7 +26,8 @@ let make_generic ctx ps pt debug p = begin match c.cl_kind with | KExpr e -> let name = ident_safe (Ast.Printer.s_expr e) in - let e = type_expr {ctx with f = {ctx.f with locals = PMap.empty}} e WithType.value in + let ctx = TyperManager.clone_for_type_parameter_expression ctx in + let e = type_expr ctx e WithType.value in name,(t,Some e) | _ -> ((ident_safe (s_type_path_underscore c.cl_path)) ^ (loop_tl top tl),(t,None)) @@ -298,8 +299,10 @@ let build_generic_class ctx c p tl = m_statics = None; m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake gctx.ctx.com.compilation_step m.m_extra.m_check_policy; } in + let ctx = TyperManager.clone_for_module ctx.g.root_typer (TypeloadModule.make_curmod ctx.com ctx.g mg) in gctx.mg <- Some mg; let cg = mk_class mg (pack,name) c.cl_pos c.cl_name_pos in + let ctx = TyperManager.clone_for_class ctx c in cg.cl_meta <- List.filter (fun (m,_,_) -> match m with | Meta.Access | Allow | Final diff --git a/src/typing/typeload.ml b/src/typing/typeload.ml index fc8201b5648..5a2c33f0a52 100644 --- a/src/typing/typeload.ml +++ b/src/typing/typeload.ml @@ -279,7 +279,8 @@ let check_param_constraints ctx t map ttp p = in match follow t with | TInst({cl_kind = KExpr e},_) -> - let e = type_expr {ctx with f = {ctx.f with locals = PMap.empty}} e (WithType.with_type ti) in + let ctx = TyperManager.clone_for_type_parameter_expression ctx in + let e = type_expr ctx e (WithType.with_type ti) in begin try unify_raise e.etype ti p with Error { err_message = Unify _ } -> fail() end | _ -> @@ -739,7 +740,7 @@ and type_type_params ctx host path p tpl = tp,type_type_param ctx host path p tp ) tpl in let params = List.map snd param_pairs in - let ctx = { ctx with type_params = params @ ctx.type_params } in + let ctx = TyperManager.clone_for_type_params ctx (params @ ctx.type_params) in List.iter (fun (tp,ttp) -> begin match tp.tp_default with | None ->