Skip to content

Commit

Permalink
store cast fields in a_to and a_from
Browse files Browse the repository at this point in the history
  • Loading branch information
Simn committed Jan 21, 2013
1 parent 7db3d5e commit a406f8d
Show file tree
Hide file tree
Showing 8 changed files with 87 additions and 64 deletions.
44 changes: 10 additions & 34 deletions codegen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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)
Expand Down
12 changes: 6 additions & 6 deletions gencommon.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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


Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
4 changes: 2 additions & 2 deletions genxml.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
34 changes: 34 additions & 0 deletions tests/unit/MyAbstract.hx
Original file line number Diff line number Diff line change
Expand Up @@ -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 changes: 9 additions & 0 deletions tests/unit/TestBasetypes.hx
Original file line number Diff line number Diff line change
Expand Up @@ -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"));
}
}
16 changes: 10 additions & 6 deletions type.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down Expand Up @@ -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) ->
Expand Down Expand Up @@ -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 _ ->
Expand All @@ -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];
| _ , _ ->
Expand Down
30 changes: 15 additions & 15 deletions typeload.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 ->
Expand Down Expand Up @@ -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;
Expand Down
2 changes: 1 addition & 1 deletion typer.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down

0 comments on commit a406f8d

Please sign in to comment.