Browse Source

[typeload] turn context_init into a class

Simon Krajewski 5 years ago
parent
commit
115d522dab
3 changed files with 31 additions and 24 deletions
  1. 2 1
      src/context/display/displayTexpr.ml
  2. 17 5
      src/typing/typeloadFields.ml
  3. 12 18
      src/typing/typeloadModule.ml

+ 2 - 1
src/context/display/displayTexpr.ml

@@ -52,7 +52,8 @@ let find_abstract_by_position cfile p =
 
 
 let check_display_field ctx sc c cf =
 let check_display_field ctx sc c cf =
 	let cff = find_field_by_position sc cf.cf_name_pos in
 	let cff = find_field_by_position sc cf.cf_name_pos in
-	let ctx,cctx = TypeloadFields.create_class_context ctx c (fun () -> ()) cf.cf_pos in
+	let context_init = new TypeloadFields.context_init in
+	let ctx,cctx = TypeloadFields.create_class_context ctx c context_init cf.cf_pos in
 	let ctx,fctx = TypeloadFields.create_field_context (ctx,cctx) c cff in
 	let ctx,fctx = TypeloadFields.create_field_context (ctx,cctx) c cff in
 	let cf = TypeloadFields.init_field (ctx,cctx,fctx) cff in
 	let cf = TypeloadFields.init_field (ctx,cctx,fctx) cff in
 	ignore(follow cf.cf_type)
 	ignore(follow cf.cf_type)

+ 17 - 5
src/typing/typeloadFields.ml

@@ -29,6 +29,18 @@ open CompletionItem.ClassFieldOrigin
 open Common
 open Common
 open Error
 open Error
 
 
+class context_init = object(self)
+	val mutable l = []
+
+	method add (f : unit -> unit) =
+		l <- f :: l
+
+	method run =
+		let l' = l in
+		l <- [];
+		List.iter (fun f -> f()) (List.rev l')
+end
+
 type class_init_ctx = {
 type class_init_ctx = {
 	tclass : tclass; (* I don't trust ctx.curclass because it's mutable. *)
 	tclass : tclass; (* I don't trust ctx.curclass because it's mutable. *)
 	is_lib : bool;
 	is_lib : bool;
@@ -37,7 +49,7 @@ type class_init_ctx = {
 	is_class_debug : bool;
 	is_class_debug : bool;
 	extends_public : bool;
 	extends_public : bool;
 	abstract : tabstract option;
 	abstract : tabstract option;
-	context_init : unit -> unit;
+	context_init : context_init;
 	mutable has_display_field : bool;
 	mutable has_display_field : bool;
 	mutable delayed_expr : (typer * tlazy ref option) list;
 	mutable delayed_expr : (typer * tlazy ref option) list;
 	mutable force_constructor : bool;
 	mutable force_constructor : bool;
@@ -420,7 +432,7 @@ let build_module_def ctx mt meta fvars context_init fbuild =
 				if ctx.in_macro then error "You cannot use @:build inside a macro : make sure that your type is not used in macro" p;
 				if ctx.in_macro then error "You cannot use @:build inside a macro : make sure that your type is not used in macro" p;
 				let old = ctx.get_build_infos in
 				let old = ctx.get_build_infos in
 				ctx.get_build_infos <- (fun() -> Some (mt, List.map snd (t_infos mt).mt_params, fvars()));
 				ctx.get_build_infos <- (fun() -> Some (mt, List.map snd (t_infos mt).mt_params, fvars()));
-				context_init();
+				context_init#run;
 				let r = try apply_macro ctx MBuild s el p with e -> ctx.get_build_infos <- old; raise e in
 				let r = try apply_macro ctx MBuild s el p with e -> ctx.get_build_infos <- old; raise e in
 				ctx.get_build_infos <- old;
 				ctx.get_build_infos <- old;
 				(match r with
 				(match r with
@@ -432,7 +444,7 @@ let build_module_def ctx mt meta fvars context_init fbuild =
 					| TClassDecl ({cl_kind = KAbstractImpl a} as c) ->
 					| TClassDecl ({cl_kind = KAbstractImpl a} as c) ->
 						(* if p <> null_pos && not (Define.is_haxe3_compat ctx.com.defines) then
 						(* if p <> null_pos && not (Define.is_haxe3_compat ctx.com.defines) then
 							ctx.com.warning "`@:enum abstract` is deprecated in favor of `enum abstract`" p; *)
 							ctx.com.warning "`@:enum abstract` is deprecated in favor of `enum abstract`" p; *)
-						context_init();
+						context_init#run;
 						let e = build_enum_abstract ctx c a (fvars()) p in
 						let e = build_enum_abstract ctx c a (fvars()) p in
 						fbuild e;
 						fbuild e;
 					| _ ->
 					| _ ->
@@ -771,7 +783,7 @@ let bind_var (ctx,cctx,fctx) cf e =
 			(* type constant init fields (issue #1956) *)
 			(* type constant init fields (issue #1956) *)
 			if not !return_partial_type || (match fst e with EConst _ -> true | _ -> false) then begin
 			if not !return_partial_type || (match fst e with EConst _ -> true | _ -> false) then begin
 				r := lazy_processing (fun() -> t);
 				r := lazy_processing (fun() -> t);
-				cctx.context_init();
+				cctx.context_init#run;
 				if ctx.com.verbose then Common.log ctx.com ("Typing " ^ (if ctx.in_macro then "macro " else "") ^ s_type_path c.cl_path ^ "." ^ cf.cf_name);
 				if ctx.com.verbose then Common.log ctx.com ("Typing " ^ (if ctx.in_macro then "macro " else "") ^ s_type_path c.cl_path ^ "." ^ cf.cf_name);
 				let e = TypeloadFunction.type_var_field ctx t e fctx.is_static fctx.is_display_field p in
 				let e = TypeloadFunction.type_var_field ctx t e fctx.is_static fctx.is_display_field p in
 				let maybe_run_analyzer e = match e.eexpr with
 				let maybe_run_analyzer e = match e.eexpr with
@@ -1136,7 +1148,7 @@ let create_method (ctx,cctx,fctx) c f fd p =
 	let r = exc_protect ~force:false ctx (fun r ->
 	let r = exc_protect ~force:false ctx (fun r ->
 		if not !return_partial_type then begin
 		if not !return_partial_type then begin
 			r := lazy_processing (fun() -> t);
 			r := lazy_processing (fun() -> t);
-			cctx.context_init();
+			cctx.context_init#run;
 			incr stats.s_methods_typed;
 			incr stats.s_methods_typed;
 			if ctx.com.verbose then Common.log ctx.com ("Typing " ^ (if ctx.in_macro then "macro " else "") ^ s_type_path c.cl_path ^ "." ^ fst f.cff_name);
 			if ctx.com.verbose then Common.log ctx.com ("Typing " ^ (if ctx.in_macro then "macro " else "") ^ s_type_path c.cl_path ^ "." ^ fst f.cff_name);
 			let fmode = (match cctx.abstract with
 			let fmode = (match cctx.abstract with

+ 12 - 18
src/typing/typeloadModule.ml

@@ -401,7 +401,7 @@ let load_enum_field ctx e et is_flat index c =
 	since they have not been setup. We also build a context_init list that will be evaluated the first time we evaluate
 	since they have not been setup. We also build a context_init list that will be evaluated the first time we evaluate
 	an expression into the context
 	an expression into the context
 *)
 *)
-let init_module_type ctx context_init do_init (decl,p) =
+let init_module_type ctx context_init (decl,p) =
 	let get_type name =
 	let get_type name =
 		try List.find (fun t -> snd (t_infos t).mt_path = name) ctx.m.curmod.m_types with Not_found -> assert false
 		try List.find (fun t -> snd (t_infos t).mt_path = name) ctx.m.curmod.m_types with Not_found -> assert false
 	in
 	in
@@ -502,23 +502,23 @@ let init_module_type ctx context_init do_init (decl,p) =
 					with Not_found ->
 					with Not_found ->
 						(* this might be a static property, wait later to check *)
 						(* this might be a static property, wait later to check *)
 						let tmain = get_type tname in
 						let tmain = get_type tname in
-						context_init := (fun() ->
+						context_init#add (fun() ->
 							try
 							try
 								add_static_init tmain name tsub
 								add_static_init tmain name tsub
 							with Not_found ->
 							with Not_found ->
 								error (s_type_path (t_infos tmain).mt_path ^ " has no field or subtype " ^ tsub) p
 								error (s_type_path (t_infos tmain).mt_path ^ " has no field or subtype " ^ tsub) p
-						) :: !context_init)
+						))
 				| (tsub,p2) :: (fname,p3) :: rest ->
 				| (tsub,p2) :: (fname,p3) :: rest ->
 					(match rest with
 					(match rest with
 					| [] -> ()
 					| [] -> ()
 					| (n,p) :: _ -> error ("Unexpected " ^ n) p);
 					| (n,p) :: _ -> error ("Unexpected " ^ n) p);
 					let tsub = get_type tsub in
 					let tsub = get_type tsub in
-					context_init := (fun() ->
+					context_init#add (fun() ->
 						try
 						try
 							add_static_init tsub name fname
 							add_static_init tsub name fname
 						with Not_found ->
 						with Not_found ->
 							error (s_type_path (t_infos tsub).mt_path ^ " has no field " ^ fname) (punion p p3)
 							error (s_type_path (t_infos tsub).mt_path ^ " has no field " ^ fname) (punion p p3)
-					) :: !context_init;
+					);
 				)
 				)
 			| IAll ->
 			| IAll ->
 				let t = (match rest with
 				let t = (match rest with
@@ -526,7 +526,7 @@ let init_module_type ctx context_init do_init (decl,p) =
 					| [tsub,_] -> get_type tsub
 					| [tsub,_] -> get_type tsub
 					| _ :: (n,p) :: _ -> error ("Unexpected " ^ n) p
 					| _ :: (n,p) :: _ -> error ("Unexpected " ^ n) p
 				) in
 				) in
-				context_init := (fun() ->
+				context_init#add (fun() ->
 					match resolve_typedef t with
 					match resolve_typedef t with
 					| TClassDecl c
 					| TClassDecl c
 					| TAbstractDecl {a_impl = Some c} ->
 					| TAbstractDecl {a_impl = Some c} ->
@@ -536,14 +536,14 @@ let init_module_type ctx context_init do_init (decl,p) =
 						PMap.iter (fun _ c -> if not (has_meta Meta.NoImportGlobal c.ef_meta) then ctx.m.module_globals <- PMap.add c.ef_name (TEnumDecl e,c.ef_name,p) ctx.m.module_globals) e.e_constrs
 						PMap.iter (fun _ c -> if not (has_meta Meta.NoImportGlobal c.ef_meta) then ctx.m.module_globals <- PMap.add c.ef_name (TEnumDecl e,c.ef_name,p) ctx.m.module_globals) e.e_constrs
 					| _ ->
 					| _ ->
 						error "No statics to import from this type" p
 						error "No statics to import from this type" p
-				) :: !context_init
+				)
 			))
 			))
 	| EUsing path ->
 	| EUsing path ->
 		check_path_display path p;
 		check_path_display path p;
 		let types,filter_classes = handle_using ctx path p in
 		let types,filter_classes = handle_using ctx path p in
 		(* do the import first *)
 		(* do the import first *)
 		ctx.m.module_types <- (List.map (fun t -> t,p) types) @ ctx.m.module_types;
 		ctx.m.module_types <- (List.map (fun t -> t,p) types) @ ctx.m.module_types;
-		context_init := (fun() -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using) :: !context_init
+		context_init#add (fun() -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using)
 	| EClass d ->
 	| EClass d ->
 		let c = (match get_type (fst d.d_name) with TClassDecl c -> c | _ -> assert false) in
 		let c = (match get_type (fst d.d_name) with TClassDecl c -> c | _ -> assert false) in
 		if ctx.is_display_file && DisplayPosition.display_position#enclosed_in (pos d.d_name) then
 		if ctx.is_display_file && DisplayPosition.display_position#enclosed_in (pos d.d_name) then
@@ -564,7 +564,7 @@ let init_module_type ctx context_init do_init (decl,p) =
 				c.cl_build <- (fun()-> Building [c]);
 				c.cl_build <- (fun()-> Building [c]);
 				try
 				try
 					List.iter (fun f -> f()) fl;
 					List.iter (fun f -> f()) fl;
-					TypeloadFields.init_class ctx c p do_init d.d_flags d.d_data;
+					TypeloadFields.init_class ctx c p context_init d.d_flags d.d_data;
 					c.cl_build <- (fun()-> Built);
 					c.cl_build <- (fun()-> Built);
 					incr build_count;
 					incr build_count;
 					List.iter (fun (_,t) -> ignore(follow t)) c.cl_params;
 					List.iter (fun (_,t) -> ignore(follow t)) c.cl_params;
@@ -638,8 +638,7 @@ let init_module_type ctx context_init do_init (decl,p) =
 				}
 				}
 			) (!constructs)
 			) (!constructs)
 		in
 		in
-		let init () = List.iter (fun f -> f()) !context_init in
-		TypeloadFields.build_module_def ctx (TEnumDecl e) e.e_meta get_constructs init (fun (e,p) ->
+		TypeloadFields.build_module_def ctx (TEnumDecl e) e.e_meta get_constructs context_init (fun (e,p) ->
 			match e with
 			match e with
 			| EVars [_,_,Some (CTAnonymous fields,p),None] ->
 			| EVars [_,_,Some (CTAnonymous fields,p),None] ->
 				constructs := List.map (fun f ->
 				constructs := List.map (fun f ->
@@ -827,13 +826,8 @@ let module_pass_2 ctx m decls tdecls p =
 			assert false
 			assert false
 	) decls;
 	) decls;
 	(* setup module types *)
 	(* setup module types *)
-	let context_init = ref [] in
-	let do_init() =
-		match !context_init with
-		| [] -> ()
-		| l -> context_init := []; List.iter (fun f -> f()) (List.rev l)
-	in
-	List.iter (init_module_type ctx context_init do_init) tdecls
+	let context_init = new TypeloadFields.context_init in
+	List.iter (init_module_type ctx context_init) tdecls
 
 
 (*
 (*
 	Creates a module context for [m] and types [tdecls] using it.
 	Creates a module context for [m] and types [tdecls] using it.