Browse Source

store cast fields in a_to and a_from

Simon Krajewski 12 years ago
parent
commit
a406f8d9c5
8 changed files with 87 additions and 64 deletions
  1. 10 34
      codegen.ml
  2. 6 6
      gencommon.ml
  3. 2 2
      genxml.ml
  4. 34 0
      tests/unit/MyAbstract.hx
  5. 9 0
      tests/unit/TestBasetypes.hx
  6. 10 6
      type.ml
  7. 15 15
      typeload.ml
  8. 1 1
      typer.ml

+ 10 - 34
codegen.ml

@@ -1317,37 +1317,13 @@ let handle_abstract_casts ctx e =
 		| _ ->
 			def())
 	in
-	let find_from_cast c a pl t p =
-		let rec loop cfl = match cfl with
-			| [] ->
-				raise Not_found
-			| cf :: cfl when has_meta ":from" cf.cf_meta ->
-				begin match follow cf.cf_type with
-				| TFun([_,_,ta],_) when type_iseq (apply_params a.a_types pl ta) t ->
-					cf
-				| _ ->
-					loop cfl
-				end
-			| _ :: cfl ->
-				loop cfl
-		in
-		loop c.cl_ordered_statics
-	in
-	let find_to_cast c a t p =
-		let rec loop cfl = match cfl with
-			| [] ->
-				raise Not_found
-			| cf :: cfl when has_meta ":to" cf.cf_meta ->
-				begin match follow cf.cf_type with
-				| TFun([ta],r) when type_iseq r t ->
-					cf
-				| _ ->
-					loop cfl
-				end
-			| _ :: cfl ->
-				loop cfl
+	let find_cast a pl t from =
+		let rec loop fl = match fl with
+			| [] -> raise Not_found
+			| (t2,Some cf) :: _ when type_iseq t (apply_params a.a_types pl (monomorphs cf.cf_params t2)) -> cf
+			| (t2,_) :: fl -> loop fl
 		in
-		loop c.cl_ordered_statics
+		loop (List.rev (if from then a.a_from else a.a_to))
 	in
 	let rec check_cast tleft eright p =
 		let eright = loop eright in
@@ -1357,19 +1333,19 @@ let handle_abstract_casts ctx e =
 					eright
 				else begin
 					let c,cf,a,pl = try
-						c1,find_from_cast c1 a1 pl1 t2 p,a1,pl1
+						c1,find_cast a1 pl1 t2 true,a1,pl1
 					with Not_found ->
-						c2,find_to_cast c2 a2 t1 p,a2,pl2
+						c2,find_cast a2 pl2 t1 false,a2,pl2
 					in
 					make_cast_call c cf a pl [eright] tleft p
 				end
 			| TDynamic _,_ | _,TDynamic _ ->
 				eright
 			| TAbstract({a_impl = Some c} as a,pl),t ->
-				let cf = find_from_cast c a pl eright.etype p in
+				let cf = find_cast a pl t true in
 				make_cast_call c cf a pl [eright] tleft p
 			| t,TAbstract({a_impl = Some c} as a,pl) ->
-				let cf = find_to_cast c a t p in
+				let cf = find_cast a pl t false in
 				make_cast_call c cf a pl [eright] tleft p
 			| _ ->
 				eright)

+ 6 - 6
gencommon.ml

@@ -67,13 +67,13 @@ let rec like_float t =
   match follow t with
     | TAbstract({ a_path = ([], "Float") },[])
     | TAbstract({ a_path = ([], "Int") },[]) -> true
-    | TAbstract(a, _) -> List.exists like_float a.a_from || List.exists like_float a.a_to
+    | TAbstract(a, _) -> List.exists (fun (t,_) -> like_float t) a.a_from || List.exists (fun (t,_) -> like_float t) a.a_to
     | _ -> false
 
 let rec like_int t =
   match follow t with
     | TAbstract({ a_path = ([], "Int") },[]) -> true
-    | TAbstract(a, _) -> List.exists like_int a.a_from || List.exists like_float a.a_to
+    | TAbstract(a, _) -> List.exists (fun (t,_) -> like_int t) a.a_from || List.exists (fun (t,_) -> like_float t) a.a_to
     | _ -> false
 
 
@@ -3641,11 +3641,11 @@ struct
           if a == a2 then
             List.iter2 (get_arg) params params2
           else begin
-            List.iter (fun t ->
+            List.iter (fun (t,_) ->
               let t = apply_params a2.a_types params2 t in
               get_arg original t
             ) a2.a_to;
-            List.iter (fun t ->
+            List.iter (fun (t,_) ->
               let t = apply_params a.a_types params t in
               get_arg t applied
             ) a.a_from
@@ -3671,12 +3671,12 @@ struct
           ignore (loop cl2 params2)
 
         | TAbstract(a, params), _ ->
-          List.iter (fun t ->
+          List.iter (fun (t,_) ->
             let t = apply_params a.a_types params t in
             get_arg t applied
           ) a.a_from
         | _, TAbstract(a2, params2) ->
-          List.iter (fun t ->
+          List.iter (fun (t,_) ->
             let t = apply_params a2.a_types params2 t in
             get_arg original t
           ) a2.a_to

+ 2 - 2
genxml.ml

@@ -194,8 +194,8 @@ let gen_type_decl com pos t =
 	| TAbstractDecl a ->
 		let doc = gen_doc_opt a.a_doc in
 		let meta = gen_meta a.a_meta in
-		let sub = (match a.a_from with [] -> [] | l -> [node "from" [] (List.map gen_type l)]) in
-		let super = (match a.a_to with [] -> [] | l -> [node "to" [] (List.map gen_type l)]) in
+		let sub = (match a.a_from with [] -> [] | l -> [node "from" [] (List.map (fun (t,_) -> gen_type t) l)]) in
+		let super = (match a.a_to with [] -> [] | l -> [node "to" [] (List.map (fun (t,_) -> gen_type t) l)]) in
 		node "abstract" (gen_type_params pos a.a_private (tpath t) a.a_types a.a_pos m) (sub @ super @ doc @ meta)
 
 let att_str att =

+ 34 - 0
tests/unit/MyAbstract.hx

@@ -53,4 +53,38 @@ abstract Kilometer(Float) {
 		
 	@:to public inline function toFloat()
 		return this
+}
+
+abstract MyHash(Hash<V>)<V> {
+	private inline function new() {
+		this = new Hash<V>();
+	}
+	public inline function set(k:String, v:V)
+		this.set(k, v)
+	public inline function get(k:String)
+		return this.get(k)
+	public inline function toString()
+		return this.toString()
+		
+	@:from static public function fromStringArray(arr:Array<String>) {
+		var hash = new MyHash();
+		var i = 0;
+		while (i < arr.length) {
+			var k = arr[i++];
+			var v = arr[i++];
+			hash.set(k, v);
+		}
+		return hash;
+	}
+	
+	@:from static public function fromArray<K>(arr:Array<K>) {
+		var hash = new MyHash();
+		var i = 0;
+		while (i < arr.length) {
+			var k = arr[i++];
+			var v = arr[i++];
+			hash.set(Std.string('_s$k'), v);
+		}
+		return hash;
+	}
 }

+ 9 - 0
tests/unit/TestBasetypes.hx

@@ -354,4 +354,13 @@ class TestBasetypes extends Test {
 		var km:unit.MyAbstract.Kilometer = m;
 		feq(km, 0.1222);
 	}
+	
+	function testAbstractTypeParameters() {
+		var hash1:unit.MyAbstract.MyHash<String> = ["k1", "v1", "k2", "v2"];
+		eq("v1", hash1.get("k1"));
+		eq("v2", hash1.get("k2"));
+		var hash1:unit.MyAbstract.MyHash<Int> = [1, 2, 3, 4];
+		eq(2, hash1.get("_s1"));
+		eq(4, hash1.get("_s3"));
+	}
 }

+ 10 - 6
type.ml

@@ -247,8 +247,8 @@ and tabstract = {
 
 	mutable a_impl : tclass option;
 	mutable a_this : t;
-	mutable a_from : t list;
-	mutable a_to : t list;
+	mutable a_from : (t * tclass_field option) list;
+	mutable a_to : (t * tclass_field option) list;
 }
 
 and module_type =
@@ -993,11 +993,13 @@ let rec unify a b =
 	| _ , TAbstract ({a_path=[],"Void"},_) ->
 		error [cannot_unify a b]
 	| TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
-		if not (List.exists (fun t ->
+		if not (List.exists (fun (t,cfo) ->
 			let t = apply_params a1.a_types tl1 t in
+			let t = match cfo with None -> t | Some cf -> monomorphs cf.cf_params t in
 			try unify t b; true with Unify_error _ -> false
-		) a1.a_to) && not (List.exists (fun t ->
+		) a1.a_to) && not (List.exists (fun (t,cfo) ->
 			let t = apply_params a2.a_types tl2 t in
+			let t = match cfo with None -> t | Some cf -> monomorphs cf.cf_params t in
 			try unify a t; true with Unify_error _ -> false
 		) a2.a_from) then error [cannot_unify a b]
 	| TInst (c1,tl1) , TInst (c2,tl2) ->
@@ -1143,8 +1145,9 @@ let rec unify a b =
 		| _ ->
 			error [cannot_unify a b])
 	| TAbstract (aa,tl), _  ->
-		if not (List.exists (fun t ->
+		if not (List.exists (fun (t,cfo) ->
 			let t = apply_params aa.a_types tl t in
+			let t = match cfo with None -> t | Some cf -> monomorphs cf.cf_params t in
 			try unify t b; true with Unify_error _ -> false
 		) aa.a_to) then error [cannot_unify a b];
 	| TInst ({ cl_kind = KTypeParameter ctl } as c,pl), TAbstract _ ->
@@ -1154,8 +1157,9 @@ let rec unify a b =
 			try unify t b; true with Unify_error _ -> false
 		) ctl) then error [cannot_unify a b];
 	| _, TAbstract (bb,tl) ->
-		if not (List.exists (fun t ->
+		if not (List.exists (fun (t,cfo) ->
 			let t = apply_params bb.a_types tl t in
+			let t = match cfo with None -> t | Some cf -> monomorphs cf.cf_params t in
 			try unify a t; true with Unify_error _ -> false
 		) bb.a_from) then error [cannot_unify a b];
 	| _ , _ ->

+ 15 - 15
typeload.ml

@@ -1314,19 +1314,6 @@ let init_class ctx c p context_init herits fields =
 				name, c, t
 			) fd.f_args in
 			let t = TFun (fun_args args,ret) in
-			(match c.cl_kind with
-				| KAbstractImpl a ->
-					let m = mk_mono() in
-					if has_meta ":from" f.cff_meta then begin
-						let t_abstract = TAbstract(a,(List.map (fun _ -> mk_mono()) a.a_types)) in
-						unify ctx t (tfun [m] t_abstract) f.cff_pos;
-						a.a_from <- (follow m) :: a.a_from
-					end else if has_meta ":to" f.cff_meta then begin
-						unify ctx t (tfun [a.a_this] m) f.cff_pos;
-						a.a_to <- (follow m) :: a.a_to
-					end
-				| _ ->
-					());
 			if constr && c.cl_interface then error "An interface cannot have a constructor" p;
 			if c.cl_interface && not stat && fd.f_expr <> None then error "An interface method cannot have a body" p;
 			if constr then (match fd.f_type with
@@ -1345,6 +1332,19 @@ let init_class ctx c p context_init herits fields =
 				cf_params = params;
 				cf_overloads = [];
 			} in
+			(match c.cl_kind with
+				| KAbstractImpl a ->
+					let m = mk_mono() in
+					if has_meta ":from" f.cff_meta then begin
+						let t_abstract = TAbstract(a,(List.map (fun _ -> mk_mono()) a.a_types)) in
+						unify ctx t (tfun [m] t_abstract) f.cff_pos;
+						a.a_from <- (follow m, Some cf) :: a.a_from
+					end else if has_meta ":to" f.cff_meta then begin
+						unify ctx t (tfun [a.a_this] m) f.cff_pos;
+						a.a_to <- (follow m, Some cf) :: a.a_to
+					end
+				| _ ->
+					());
 			init_meta_overloads ctx cf;
 			ctx.curfield <- cf;
 			let r = exc_protect ctx (fun r ->
@@ -1883,8 +1883,8 @@ let rec init_module_type ctx context_init do_init (decl,p) =
 			t
 		in
 		List.iter (function
-			| AFromType t -> a.a_from <- load_type t :: a.a_from
-			| AToType t -> a.a_to <- load_type t :: a.a_to
+			| AFromType t -> a.a_from <- (load_type t, None) :: a.a_from
+			| AToType t -> a.a_to <- (load_type t, None) :: a.a_to
 			| AIsType t ->
 				a.a_this <- load_complex_type ctx p t;
 				is_type := true;

+ 1 - 1
typer.ml

@@ -83,7 +83,7 @@ let rec classify t =
 	| TInst ({ cl_path = ([],"String") },[]) -> KString
 	| TAbstract ({ a_path = [],"Int" },[]) -> KInt
 	| TAbstract ({ a_path = [],"Float" },[]) -> KFloat
-	| TAbstract (a,[]) when List.exists (fun t -> match classify t with KInt | KFloat -> true | _ -> false) a.a_to -> KParam t
+	| TAbstract (a,[]) when List.exists (fun (t,_) -> match classify t with KInt | KFloat -> true | _ -> false) a.a_to -> KParam t
 	| TInst ({ cl_kind = KTypeParameter ctl },_) when List.exists (fun t -> match classify t with KInt | KFloat -> true | _ -> false) ctl -> KParam t
 	| TMono r when !r = None -> KUnk
 	| TDynamic _ -> KDyn