Nicolas Cannasse 17 years ago
parent
commit
69259bd9cc
4 changed files with 97 additions and 108 deletions
  1. 4 0
      type.ml
  2. 0 5
      typecore.ml
  3. 1 16
      typeload.ml
  4. 92 87
      typer.ml

+ 4 - 0
type.ml

@@ -188,10 +188,14 @@ let mk_block e =
 	| TBlock (_ :: _) -> e
 	| _ -> mk (TBlock [e]) e.etype e.epos
 
+let null t p = mk (TConst TNull) t p
+
 let mk_mono() = TMono (ref None)
 
 let rec t_dynamic = TDynamic t_dynamic
 
+let tfun pl r = TFun (List.map (fun t -> "",false,t) pl,r)
+
 let mk_class path pos doc priv =
 	{
 		cl_path = path;

+ 0 - 5
typecore.ml

@@ -30,7 +30,6 @@ type typer = {
 	doinline : bool;
 	mutable std : module_def;
 	mutable untyped : bool;
-	mutable isproxy : bool;
 	mutable super_call : bool;
 	(* per-module *)
 	current : module_def;
@@ -178,10 +177,6 @@ let rec is_null = function
 	| _ ->
 		false
 
-let null t p = mk (TConst TNull) t p
-
-let tfun pl r = TFun (List.map (fun t -> "",false,t) pl,r)
-
 let not_opened = ref Closed
 let mk_anon fl = TAnon { a_fields = fl; a_status = not_opened; }
 

+ 1 - 16
typeload.ml

@@ -199,20 +199,6 @@ let load_core_type ctx name =
 	show();
 	t
 
-let is_int t =
-	match follow t with
-	| TInst (c,[]) ->
-		c.cl_path = ([],"Int")
-	| _ ->
-		false
-
-let is_float t =
-	match follow t with
-	| TInst (c,[]) ->
-		c.cl_path = ([],"Float")
-	| _ ->
-		false
-
 let t_array_access ctx =
 	let show = hide_types ctx in
 	match load_type_def ctx null_pos ([],"ArrayAccess") with
@@ -589,7 +575,7 @@ let init_class ctx c p herits fields =
 				t
 			) in
 			let delay = (
-				if (c.cl_extern || c.cl_interface || ctx.isproxy) && cf.cf_name <> "__init__" then
+				if (c.cl_extern || c.cl_interface) && cf.cf_name <> "__init__" then
 					(fun() -> ())
 				else begin
 					cf.cf_type <- TLazy r;
@@ -776,7 +762,6 @@ let type_module ctx m tdecls loadp =
 		tthis = ctx.tthis;
 		std = ctx.std;
 		ret = ctx.ret;
-		isproxy = ctx.isproxy;
 		doinline = ctx.doinline;
 		current = m;
 		locals = PMap.empty;

+ 92 - 87
typer.ml

@@ -47,50 +47,47 @@ let mk_infos ctx p params =
 			("methodName", (EConst (String ctx.curmethod),p)) :: params
 	) ,p)
 
-let field_access ctx get f t e p =
-	match if get then f.cf_get else f.cf_set with
-	| NoAccess ->
-		let normal = AccExpr (mk (TField (e,f.cf_name)) t p) in
-		(match follow e.etype with
-		| TInst (c,_) when is_parent c ctx.curclass -> normal
-		| TAnon a ->
-			(match !(a.a_status) with
-			| Statics c2 when ctx.curclass == c2 -> normal
-			| _ -> if ctx.untyped then normal else AccNo f.cf_name)
-		| _ ->
-			if ctx.untyped then normal else AccNo f.cf_name)
-	| MethodCantAccess when not ctx.untyped ->
-		error "Cannot rebind this method : please use 'dynamic' before method declaration" p
-	| NormalAccess | MethodCantAccess ->
-		AccExpr (mk (TField (e,f.cf_name)) t p)
-	| MethodAccess m ->
-		if m = ctx.curmethod && (match e.eexpr with TConst TThis -> true | TTypeExpr (TClassDecl c) when c == ctx.curclass -> true | _ -> false) then
-			let prefix = if Common.defined ctx.com "as3gen" then "$" else "" in
-			AccExpr (mk (TField (e,prefix ^ f.cf_name)) t p)
-		else if get then
-			AccExpr (mk (TCall (mk (TField (e,m)) (tfun [] t) p,[])) t p)
-		else
-			AccSet (e,m,t,f.cf_name)
-	| ResolveAccess ->
-		let fstring = mk (TConst (TString f.cf_name)) ctx.api.tstring p in
-		let tresolve = tfun [ctx.api.tstring] t in
-		AccExpr (mk (TCall (mk (TField (e,"resolve")) tresolve p,[fstring])) t p)
-	| NeverAccess ->
-		AccNo f.cf_name
-	| InlineAccess ->
-		AccInline (e,f,t)
+let check_locals_masking ctx e =
+	let path = (match e.eexpr with
+		| TEnumField (e,_)
+		| TTypeExpr (TEnumDecl e) ->
+			Some e.e_path
+		| TTypeExpr (TClassDecl c) ->
+			Some c.cl_path
+		| _ -> None
+	) in
+	match path with
+	| Some ([],name) | Some (name::_,_) when PMap.mem name ctx.locals ->
+		error ("Local variable " ^ name ^ " is preventing usage of this type here") e.epos;
+	| _ -> ()
 
-let acc_get g p =
-	match g with
-	| AccNo f -> error ("Field " ^ f ^ " cannot be accessed for reading") p
-	| AccExpr e -> e
-	| AccSet _ -> assert false
-	| AccInline (e,f,t) ->
-		ignore(follow f.cf_type); (* force computing *)
-		match f.cf_expr with
-		| None -> error "Recursive inline is not supported" p
-		| Some { eexpr = TFunction _ } ->  mk (TField (e,f.cf_name)) t p
-		| Some e -> e
+let check_assign ctx e =
+	match e.eexpr with
+	| TLocal _ | TArray _ | TField _ ->
+		()
+	| TTypeExpr _ when ctx.untyped ->
+		()
+	| _ ->
+		error "Invalid assign" e.epos
+
+type type_class =
+	| KInt
+	| KFloat
+	| KString
+	| KUnk
+	| KDyn
+	| KOther
+	| KParam of t
+
+let classify t =
+	match follow t with
+	| TInst ({ cl_path = ([],"Int") },[]) -> KInt
+	| TInst ({ cl_path = ([],"Float") },[]) -> KFloat
+	| TInst ({ cl_path = ([],"String") },[]) -> KString
+	| TInst ({ cl_kind = KTypeParameter; cl_implements = [{ cl_path = ([],"Float")},[]] },[]) -> KParam t
+	| TMono r when !r = None -> KUnk
+	| TDynamic _ -> KDyn
+	| _ -> KOther
 
 (* ---------------------------------------------------------------------- *)
 (* PASS 3 : type expression & check structure *)
@@ -185,20 +182,6 @@ let type_local ctx i p =
 	let i = (try PMap.find i ctx.locals_map with Not_found -> i) in
 	mk (TLocal i) t p
 
-let check_locals_masking ctx e =
-	let path = (match e.eexpr with
-		| TEnumField (e,_)
-		| TTypeExpr (TEnumDecl e) ->
-			Some e.e_path
-		| TTypeExpr (TClassDecl c) ->
-			Some c.cl_path
-		| _ -> None
-	) in
-	match path with
-	| Some ([],name) | Some (name::_,_) when PMap.mem name ctx.locals ->
-		error ("Local variable " ^ name ^ " is preventing usage of this type here") e.epos;
-	| _ -> ()
-
 let type_type ctx tpath p =
 	let rec loop t tparams =
 	match t with
@@ -255,6 +238,51 @@ let type_type ctx tpath p =
 	check_locals_masking ctx e;
 	e
 
+let acc_get g p =
+	match g with
+	| AccNo f -> error ("Field " ^ f ^ " cannot be accessed for reading") p
+	| AccExpr e -> e
+	| AccSet _ -> assert false
+	| AccInline (e,f,t) ->
+		ignore(follow f.cf_type); (* force computing *)
+		match f.cf_expr with
+		| None -> error "Recursive inline is not supported" p
+		| Some { eexpr = TFunction _ } ->  mk (TField (e,f.cf_name)) t p
+		| Some e -> e
+
+let field_access ctx get f t e p =
+	match if get then f.cf_get else f.cf_set with
+	| NoAccess ->
+		let normal = AccExpr (mk (TField (e,f.cf_name)) t p) in
+		(match follow e.etype with
+		| TInst (c,_) when is_parent c ctx.curclass -> normal
+		| TAnon a ->
+			(match !(a.a_status) with
+			| Statics c2 when ctx.curclass == c2 -> normal
+			| _ -> if ctx.untyped then normal else AccNo f.cf_name)
+		| _ ->
+			if ctx.untyped then normal else AccNo f.cf_name)
+	| MethodCantAccess when not ctx.untyped ->
+		error "Cannot rebind this method : please use 'dynamic' before method declaration" p
+	| NormalAccess | MethodCantAccess ->
+		AccExpr (mk (TField (e,f.cf_name)) t p)
+	| MethodAccess m ->
+		if m = ctx.curmethod && (match e.eexpr with TConst TThis -> true | TTypeExpr (TClassDecl c) when c == ctx.curclass -> true | _ -> false) then
+			let prefix = if Common.defined ctx.com "as3gen" then "$" else "" in
+			AccExpr (mk (TField (e,prefix ^ f.cf_name)) t p)
+		else if get then
+			AccExpr (mk (TCall (mk (TField (e,m)) (tfun [] t) p,[])) t p)
+		else
+			AccSet (e,m,t,f.cf_name)
+	| ResolveAccess ->
+		let fstring = mk (TConst (TString f.cf_name)) ctx.api.tstring p in
+		let tresolve = tfun [ctx.api.tstring] t in
+		AccExpr (mk (TCall (mk (TField (e,"resolve")) tresolve p,[fstring])) t p)
+	| NeverAccess ->
+		AccNo f.cf_name
+	| InlineAccess ->
+		AccInline (e,f,t)
+
 let type_ident ctx i is_type p get =
 	match i with
 	| "true" ->
@@ -365,15 +393,6 @@ let type_constant ctx c p =
 	| Ident _
 	| Type _ -> assert false
 
-let check_assign ctx e =
-	match e.eexpr with
-	| TLocal _ | TArray _ | TField _ ->
-		()
-	| TTypeExpr _ when ctx.untyped ->
-		()
-	| _ ->
-		error "Invalid assign" e.epos
-
 let type_matching ctx (enum,params) (e,p) ecases first_case =
 	let invalid() = error "Invalid enum matching" p in
 	let needs n = error ("This constructor needs " ^ string_of_int n ^ " parameters") p in
@@ -496,25 +515,6 @@ let type_field ctx e i p get =
 	| t ->
 		no_field()
 
-type type_class =
-	| KInt
-	| KFloat
-	| KString
-	| KUnk
-	| KDyn
-	| KOther
-	| KParam of t
-
-let classify t =
-	match follow t with
-	| TInst ({ cl_path = ([],"Int") },[]) -> KInt
-	| TInst ({ cl_path = ([],"Float") },[]) -> KFloat
-	| TInst ({ cl_path = ([],"String") },[]) -> KString
-	| TInst ({ cl_kind = KTypeParameter; cl_implements = [{ cl_path = ([],"Float")},[]] },[]) -> KParam t
-	| TMono r when !r = None -> KUnk
-	| TDynamic _ -> KDyn
-	| _ -> KOther
-
 let rec type_binop ctx op e1 e2 p =
 	match op with
 	| OpAssign ->
@@ -710,7 +710,7 @@ and type_unop ctx op flag e p =
 		| Neg
 		| NegBits ->
 			if set then check_assign ctx e;
-			if Typeload.is_float e.etype then
+			if classify e.etype = KFloat then
 				ctx.api.tfloat
 			else begin
 				unify ctx e.etype ctx.api.tint e.epos;
@@ -1659,6 +1659,9 @@ and optimize_for_loop ctx i e1 e2 p =
 			let e2 = type_expr ~need_val:false ctx e2 in
 			mk (TFor (i,pt,e1,e2)) t_void p
 
+(* ---------------------------------------------------------------------- *)
+(* FINALIZATION *)
+
 let rec finalize ctx =
 	let delays = List.concat !(ctx.delays) in
 	ctx.delays := [];
@@ -1825,6 +1828,9 @@ let types ctx main excludes =
 	);
 	List.rev !types
 
+(* ---------------------------------------------------------------------- *)
+(* TYPER INITIALIZATION *)
+
 let create com =
 	let empty =	{
 		mpath = [] , "";
@@ -1843,7 +1849,6 @@ let create com =
 		in_static = false;
 		in_loop = false;
 		untyped = false;
-		isproxy = false;
 		super_call = false;
 		in_display = false;
 		ret = mk_mono();