Browse Source

[typer] add cl_type

Simon Krajewski 1 year ago
parent
commit
c39a83b7bb
6 changed files with 57 additions and 45 deletions
  1. 26 23
      src/core/tFunctions.ml
  2. 1 0
      src/core/tType.ml
  3. 2 2
      src/core/texpr.ml
  4. 21 18
      src/typing/fields.ml
  5. 6 0
      src/typing/typeloadFields.ml
  6. 1 2
      src/typing/typerBase.ml

+ 26 - 23
src/core/tFunctions.ml

@@ -107,8 +107,28 @@ let tfun pl r = TFun (List.map (fun t -> "",false,t) pl,r)
 
 let fun_args l = List.map (fun (a,c,t) -> a, c <> None, t) l
 
-let mk_class m path pos name_pos =
+let mk_typedef m path pos name_pos t =
 	{
+		t_path = path;
+		t_module = m;
+		t_pos = pos;
+		t_name_pos = name_pos;
+		t_private = false;
+		t_doc = None;
+		t_meta = [];
+		t_params = [];
+		t_using = [];
+		t_type = t;
+		t_restore = (fun () -> ());
+	}
+
+let class_module_type c =
+	let path = ([],"Class<" ^ (s_type_path c.cl_path) ^ ">") in
+	let t = mk_anon ~fields:c.cl_statics (ref (ClassStatics c)) in
+	{ (mk_typedef c.cl_module path c.cl_pos null_pos t) with t_private = true}
+
+let mk_class m path pos name_pos =
+	let c = {
 		cl_path = path;
 		cl_module = m;
 		cl_pos = pos;
@@ -118,6 +138,7 @@ let mk_class m path pos name_pos =
 		cl_private = false;
 		cl_kind = KNormal;
 		cl_flags = 0;
+		cl_type = t_dynamic;
 		cl_params = [];
 		cl_using = [];
 		cl_super = None;
@@ -133,22 +154,9 @@ let mk_class m path pos name_pos =
 		cl_build = (fun() -> Built);
 		cl_restore = (fun() -> ());
 		cl_descendants = [];
-	}
-
-let mk_typedef m path pos name_pos t =
-	{
-		t_path = path;
-		t_module = m;
-		t_pos = pos;
-		t_name_pos = name_pos;
-		t_private = false;
-		t_doc = None;
-		t_meta = [];
-		t_params = [];
-		t_using = [];
-		t_type = t;
-		t_restore = (fun () -> ());
-	}
+	} in
+	c.cl_type <- TType(class_module_type c,[]);
+	c
 
 let module_extra file sign time kind added policy =
 	{
@@ -940,11 +948,6 @@ let var_extra params e = {
 	v_expr = e;
 }
 
-let class_module_type c =
-	let path = ([],"Class<" ^ (s_type_path c.cl_path) ^ ">") in
-	let t = mk_anon ~fields:c.cl_statics (ref (ClassStatics c)) in
-	{ (mk_typedef c.cl_module path c.cl_pos null_pos t) with t_private = true}
-
 let enum_module_type en =
 	let path = ([], "Enum<" ^ (s_type_path en.e_path) ^ ">") in
 	let t = mk_anon (ref (EnumStatics en)) in
@@ -963,4 +966,4 @@ let class_field_of_enum_field ef = {
 	);
 	cf_doc = ef.ef_doc;
 	cf_params = ef.ef_params;
-}
+}

+ 1 - 0
src/core/tType.ml

@@ -288,6 +288,7 @@ and tclass = {
 	mutable cl_using : (tclass * pos) list;
 	mutable cl_restore : unit -> unit;
 	(* do not insert any fields above *)
+	mutable cl_type : t;
 	mutable cl_kind : tclass_kind;
 	mutable cl_flags : int;
 	mutable cl_super : (tclass * tparams) option;

+ 2 - 2
src/core/texpr.ml

@@ -486,12 +486,12 @@ let foldmap f acc e =
 (* Collection of functions that return expressions *)
 module Builder = struct
 	let make_static_this c p =
-		mk (TTypeExpr (TClassDecl c)) (TType(TFunctions.class_module_type c,[])) p
+		mk (TTypeExpr (TClassDecl c)) c.cl_type p
 
 	let make_typeexpr mt pos =
 		let t =
 			match resolve_typedef mt with
-			| TClassDecl c -> TType(class_module_type c,[])
+			| TClassDecl c -> c.cl_type
 			| TEnumDecl e -> e.e_type
 			| TAbstractDecl a -> TType(abstract_module_type a [],[])
 			| _ -> die "" __LOC__

+ 21 - 18
src/typing/fields.ml

@@ -329,30 +329,33 @@ let type_field cfg ctx e i p mode (with_type : WithType.t) =
 				type_field_by_interfaces e c
 			)
 		| TAnon a ->
-			(try
-				let f = PMap.find i a.a_fields in
-				if has_class_field_flag f CfImpl && not (has_class_field_flag f CfEnum) then display_error ctx.com "Cannot access non-static abstract field statically" pfield;
-				match !(a.a_status) with
+			begin match !(a.a_status) with
 				| ClassStatics c ->
-					field_access f (FHStatic c)
-				| _ ->
-					field_access f FHAnon
-			with Not_found ->
-				match !(a.a_status) with
-				| ClassStatics { cl_kind = KAbstractImpl a } ->
-					type_field_by_forward_static (fun() ->
-						let mt = try module_type_of_type a.a_this with Exit -> raise Not_found in
-						let et = type_module_type ctx mt p in
-						type_field_by_e type_field_by_type et
-					) a
+					begin try
+						let cf = PMap.find i c.cl_statics in
+						if has_class_field_flag cf CfImpl && not (has_class_field_flag cf CfEnum) then display_error ctx.com "Cannot access non-static abstract field statically" pfield;
+						field_access cf (FHStatic c)
+					with Not_found ->
+						begin match c.cl_kind with
+						| KAbstractImpl a ->
+							type_field_by_forward_static (fun() ->
+								let mt = try module_type_of_type a.a_this with Exit -> raise Not_found in
+								let et = type_module_type ctx mt p in
+								type_field_by_e type_field_by_type et
+							) a
+						| _ ->
+							raise Not_found
+						end
+					end
 				| EnumStatics en ->
 					let c = PMap.find i en.e_constrs in
 					let fmode = FEnum (en,c) in
 					let t = enum_field_type ctx en c p in
-					AKExpr (mk (TField (e,fmode)) t p)					
+					AKExpr (mk (TField (e,fmode)) t p)
 				| _ ->
-					raise Not_found
-			)
+					let cf = PMap.find i a.a_fields in
+					field_access cf FHAnon
+			end;
 		| TMono r ->
 			let mk_field () = {
 				(mk_field i (mk_mono()) p null_pos) with

+ 6 - 0
src/typing/typeloadFields.ml

@@ -1878,6 +1878,12 @@ let init_class ctx c p herits fields =
 	end;
 	c.cl_ordered_statics <- List.rev c.cl_ordered_statics;
 	c.cl_ordered_fields <- List.rev c.cl_ordered_fields;
+	delay ctx PConnectField (fun () -> match follow c.cl_type with
+		| TAnon an ->
+			an.a_fields <- c.cl_statics
+		| _ ->
+			die "" __LOC__
+	);
 	(*
 		make sure a default contructor with same access as super one will be added to the class structure at some point.
 	*)

+ 1 - 2
src/typing/typerBase.ml

@@ -207,8 +207,7 @@ let type_module_type ctx t p =
 			in
 			loop mt None
 		| TClassDecl c ->
-			let t_tmp = class_module_type c in
-			mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p
+			mk (TTypeExpr (TClassDecl c)) c.cl_type p
 		| TEnumDecl e ->
 			mk (TTypeExpr (TEnumDecl e)) e.e_type p
 		| TTypeDecl s ->