Browse Source

allow custom [] access on abstracts

Simon Krajewski 12 years ago
parent
commit
fd71514da4
7 changed files with 144 additions and 6 deletions
  1. 7 0
      std/Map.hx
  2. 11 0
      tests/unit/MyAbstract.hx
  3. 33 0
      tests/unit/TestType.hx
  4. 15 1
      tests/unit/unitstd/Map.unit.hx
  5. 1 0
      type.ml
  6. 3 0
      typeload.ml
  7. 74 5
      typer.ml

+ 7 - 0
std/Map.hx

@@ -114,6 +114,13 @@ abstract Map< K, V > (IMap< K, V > ) {
 		return this.iterator();
 		return this.iterator();
 	}
 	}
 	
 	
+	@:arrayAccess public inline function arrayRead(k:K):V {
+		return this.get(k);
+	}
+	
+	@:arrayAccess public inline function arrayWrite(k:K, v:V):Void {
+		this.set(k,v);
+	}
 	
 	
 	@:to static inline function toStringMap(t:IMap < String, V > ):StringMap<V> {
 	@:to static inline function toStringMap(t:IMap < String, V > ):StringMap<V> {
 		return new StringMap<V>();
 		return new StringMap<V>();

+ 11 - 0
tests/unit/MyAbstract.hx

@@ -170,4 +170,15 @@ class ClassWithHashCode {
 class ClassWithoutHashCode {
 class ClassWithoutHashCode {
 	public var i:Int;
 	public var i:Int;
 	public function new(i) { this.i = i; }
 	public function new(i) { this.i = i; }
+}
+
+abstract MyReflect({}) from {} {
+	@:arrayAccess public inline function arrayAccess(key:String):Dynamic {
+		return Reflect.field(this, key);
+	}
+	
+	@:arrayAccess public inline function arrayWrite<T>(key:String, value:T):T {
+		Reflect.setField(this, key, value);
+		return value;
+	}
 }
 }

+ 33 - 0
tests/unit/TestType.hx

@@ -791,4 +791,37 @@ class TestType extends Test {
 		eq(map.get("a"), "A");
 		eq(map.get("a"), "A");
 		eq(map.get("b"), "B");
 		eq(map.get("b"), "B");
 	}
 	}
+	
+	function testCustomArrayAccess() {
+		var obj = {
+			foo: 12,
+			bar: "test"
+		};
+		var mr:unit.MyAbstract.MyReflect = obj;
+		eq(mr["foo"], 12);
+		eq(mr["bar"], "test");
+		mr["foo"] = 11;
+		eq(mr["foo"], 11);
+		mr["foo"] += 99;
+		eq(mr["foo"], 110);
+		mr["baz"] = mr["bar"] += mr["foo"];
+		eq(mr["baz"], "test110");
+		eq(mr["bar"], "test110");
+		
+		var v = "hh";
+		mr[v] = 1;
+		mr[v += "h"] = 2;
+		eq(mr["hhh"], 2);
+		eq(v, "hhh");
+		
+		mr["hhhh"] = 0;
+		mr[v += "h"] += 4;
+		eq(mr["hhhh"], 4);
+		eq(mr["hhh"], 2);
+		eq(v, "hhhh");
+		
+		// note for later: As3 compilation fails if the function name is removed
+		mr["101"] = function n(x) return 9 + x;
+		eq(mr["101"](1), 10);
+	}
 }
 }

+ 15 - 1
tests/unit/unitstd/Map.unit.hx

@@ -136,4 +136,18 @@ map.remove(b) == false;
 map.exists(a) == true;
 map.exists(a) == true;
 map.exists(b) == false;
 map.exists(b) == false;
 map.exists(c) == true;
 map.exists(c) == true;
-map.get(b) == null;
+map.get(b) == null;
+
+// [] access
+var map = new Map();
+map["foo"] == null;
+map["foo"] = 12;
+map.get("foo") == 12;
+map["foo"] == 12;
+map["foo"] += 2;
+map.get("foo") == 14;
+map["foo"] == 14;
+map["foo"] *= map["foo"] + 2;
+map["foo"] == 224;
+map["f" + "o" + "o"] -= 223;
+map[(function(s) return s + "o")("fo")] == 1;

+ 1 - 0
type.ml

@@ -252,6 +252,7 @@ and tabstract = {
 	mutable a_impl : tclass option;
 	mutable a_impl : tclass option;
 	mutable a_this : t;
 	mutable a_this : t;
 	mutable a_from : (t * tclass_field option) list;
 	mutable a_from : (t * tclass_field option) list;
+	mutable a_array : tclass_field list;
 	mutable a_to : (t * tclass_field option) list;
 	mutable a_to : (t * tclass_field option) list;
 }
 }
 
 

+ 3 - 0
typeload.ml

@@ -110,6 +110,7 @@ let make_module ctx mpath file tdecls loadp =
 				a_to = [];
 				a_to = [];
 				a_ops = [];
 				a_ops = [];
 				a_impl = None;
 				a_impl = None;
+				a_array = [];
 				a_this = mk_mono();
 				a_this = mk_mono();
 			} in
 			} in
 			decls := (TAbstractDecl a, decl) :: !decls;
 			decls := (TAbstractDecl a, decl) :: !decls;
@@ -1379,6 +1380,8 @@ let init_class ctx c p context_init herits fields =
 						unify ctx t (tfun [ta] m) f.cff_pos;
 						unify ctx t (tfun [ta] m) f.cff_pos;
 						if not (Meta.has Meta.Impl cf.cf_meta) then cf.cf_meta <- (Meta.Impl,[],cf.cf_pos) :: cf.cf_meta;
 						if not (Meta.has Meta.Impl cf.cf_meta) then cf.cf_meta <- (Meta.Impl,[],cf.cf_pos) :: cf.cf_meta;
 						a.a_to <- (follow m, Some cf) :: a.a_to
 						a.a_to <- (follow m, Some cf) :: a.a_to
+					end else if Meta.has Meta.ArrayAccess f.cff_meta then begin
+						a.a_array <- cf :: a.a_array;
 					end else if f.cff_name = "_new" && Meta.has Meta.MultiType a.a_meta then
 					end else if f.cff_name = "_new" && Meta.has Meta.MultiType a.a_meta then
 						do_bind := false
 						do_bind := false
 					else (try match Meta.get Meta.Op cf.cf_meta with
 					else (try match Meta.get Meta.Op cf.cf_meta with

+ 74 - 5
typer.ml

@@ -50,6 +50,7 @@ type access_kind =
 	| AKInline of texpr * tclass_field * tfield_access * t
 	| AKInline of texpr * tclass_field * tfield_access * t
 	| AKMacro of texpr * tclass_field
 	| AKMacro of texpr * tclass_field
 	| AKUsing of texpr * tclass * tclass_field * texpr
 	| AKUsing of texpr * tclass * tclass_field * texpr
+	| AKAccess of texpr * texpr
 
 
 let mk_infos ctx p params =
 let mk_infos ctx p params =
 	let file = if ctx.in_macro then p.pfile else if Common.defined ctx.com Define.AbsolutePath then Common.get_full_path p.pfile else Filename.basename p.pfile in
 	let file = if ctx.in_macro then p.pfile else if Common.defined ctx.com Define.AbsolutePath then Common.get_full_path p.pfile else Filename.basename p.pfile in
@@ -219,6 +220,21 @@ let prepare_using_field cf = match cf.cf_type with
 		{cf with cf_overloads = loop [] cf.cf_overloads; cf_type = TFun(args,ret)}
 		{cf with cf_overloads = loop [] cf.cf_overloads; cf_type = TFun(args,ret)}
 	| _ -> cf
 	| _ -> cf
 
 
+let find_array_access a pl c t1 t2 is_set =
+	let ta = apply_params a.a_types pl a.a_this in
+	let rec loop cfl = match cfl with
+		| [] -> raise Not_found
+		| cf :: cfl when not (Meta.has Meta.ArrayAccess cf.cf_meta) ->
+			loop cfl
+		| cf :: cfl ->
+			match follow (apply_params a.a_types pl (monomorphs cf.cf_params cf.cf_type)) with
+			| TFun([(_,_,tab);(_,_,ta1);(_,_,ta2)],r) as tf when is_set && type_iseq tab ta && type_iseq ta1 t1 && type_iseq ta2 t2 ->
+				cf,tf,r
+			| TFun([(_,_,tab);(_,_,ta1)],r) as tf when not is_set && type_iseq tab ta && type_iseq ta1 t1 ->
+				cf,tf,r
+			| _ -> loop cfl
+	in
+	loop a.a_array
 
 
 let parse_string ctx s p inlined =
 let parse_string ctx s p inlined =
 	let old = Lexer.save() in
 	let old = Lexer.save() in
@@ -601,7 +617,7 @@ let rec acc_get ctx g p =
 	match g with
 	match g with
 	| AKNo f -> error ("Field " ^ f ^ " cannot be accessed for reading") p
 	| AKNo f -> error ("Field " ^ f ^ " cannot be accessed for reading") p
 	| AKExpr e | AKField (e,_,_) -> e
 	| AKExpr e | AKField (e,_,_) -> e
-	| AKSet _ -> assert false
+	| AKSet _ | AKAccess _ -> assert false
 	| AKUsing (et,_,_,e) ->
 	| AKUsing (et,_,_,e) ->
 		(* build a closure with first parameter applied *)
 		(* build a closure with first parameter applied *)
 		(match follow et.etype with
 		(match follow et.etype with
@@ -1229,7 +1245,7 @@ let rec type_binop ctx op e1 e2 is_assign_op p =
 	match op with
 	match op with
 	| OpAssign ->
 	| OpAssign ->
 		let e1 = type_access ctx (fst e1) (snd e1) MSet in
 		let e1 = type_access ctx (fst e1) (snd e1) MSet in
-		let tt = (match e1 with AKNo _ | AKInline _ | AKUsing _ | AKMacro _ -> Value | AKSet(_,_,t,_) -> WithType t | AKExpr e | AKField (e,_,_) -> WithType e.etype) in
+		let tt = (match e1 with AKNo _ | AKInline _ | AKUsing _ | AKMacro _ | AKAccess _ -> Value | AKSet(_,_,t,_) -> WithType t | AKExpr e | AKField (e,_,_) -> WithType e.etype) in
 		let e2 = type_expr ctx e2 tt in
 		let e2 = type_expr ctx e2 tt in
 		(match e1 with
 		(match e1 with
 		| AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p
 		| AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p
@@ -1245,6 +1261,15 @@ let rec type_binop ctx op e1 e2 is_assign_op p =
 		| AKSet (e,m,t,_) ->
 		| AKSet (e,m,t,_) ->
 			unify ctx e2.etype t p;
 			unify ctx e2.etype t p;
 			make_call ctx (mk (TField (e,FDynamic m)) (tfun [t] t) p) [e2] t p
 			make_call ctx (mk (TField (e,FDynamic m)) (tfun [t] t) p) [e2] t p
+		| AKAccess(ebase,ekey) ->
+			let a,pl,c = match follow ebase.etype with TAbstract({a_impl = Some c} as a,pl) -> a,pl,c | _ -> error "Invalid operation" p in
+			let cf,tf,r =
+				try find_array_access a pl c ekey.etype e2.etype true
+				with Not_found -> error ("No @:arrayAccess function accepts arguments of " ^ (s_type (print_context()) ekey.etype) ^ " and " ^ (s_type (print_context()) e2.etype)) p
+			in
+			let et = type_module_type ctx (TClassDecl c) None p in
+			let ef = mk (TField(et,(FStatic(c,cf)))) tf p in
+			make_call ctx ef [ebase;ekey;e2] r p
 		| AKInline _ | AKUsing _ | AKMacro _ ->
 		| AKInline _ | AKUsing _ | AKMacro _ ->
 			assert false)
 			assert false)
 	| OpAssignOp op ->
 	| OpAssignOp op ->
@@ -1275,6 +1300,37 @@ let rec type_binop ctx op e1 e2 is_assign_op p =
 				mk (TVars [v,Some e]) ctx.t.tvoid p;
 				mk (TVars [v,Some e]) ctx.t.tvoid p;
 				make_call ctx (mk (TField (ev,FDynamic m)) (tfun [t] t) p) [get] t p
 				make_call ctx (mk (TField (ev,FDynamic m)) (tfun [t] t) p) [get] t p
 			]) t p
 			]) t p
+		| AKAccess(ebase,ekey) ->
+			let a,pl,c = match follow ebase.etype with TAbstract({a_impl = Some c} as a,pl) -> a,pl,c | _ -> error "Invalid operation" p in
+			let et = type_module_type ctx (TClassDecl c) None p in
+			let cf_get,tf_get,r_get =
+				try find_array_access a pl c ekey.etype t_dynamic false
+				with Not_found -> error ("No @:arrayAccess function accepts an argument of " ^ (s_type (print_context()) ekey.etype)) p
+			in
+			(* bind complex keys to a variable so they do not make it into the output twice *)
+			let ekey,l = match Optimizer.make_constant_expression ctx ekey with
+				| Some e -> e, fun () -> None
+				| None ->
+					let save = save_locals ctx in
+					let v = gen_local ctx ekey.etype in
+					let e = mk (TLocal v) ekey.etype p in
+					e, fun () -> (save(); Some (mk (TVars [v,Some ekey]) ctx.t.tvoid p))
+			in
+			let ast_call = ECall((EField(Interp.make_ast ebase,cf_get.cf_name),p),[Interp.make_ast ekey]),p in
+			let eget = type_binop ctx op ast_call e2 true p in
+			unify ctx eget.etype r_get p;
+			let cf_set,tf_set,r_set =
+				try find_array_access a pl c ekey.etype eget.etype true
+				with Not_found -> error ("No @:arrayAccess function accepts arguments of " ^ (s_type (print_context()) ekey.etype) ^ " and " ^ (s_type (print_context()) eget.etype)) p
+			in
+			let ef_set = mk (TField(et,(FStatic(c,cf_set)))) tf_set p in
+			(match l() with
+			| None -> make_call ctx ef_set [ebase;ekey;eget] r_set p
+			| Some e ->
+				mk (TBlock [
+					e;
+					make_call ctx ef_set [ebase;ekey;eget] r_set p
+				]) r_set p)
 		| AKInline _ | AKUsing _ | AKMacro _ ->
 		| AKInline _ | AKUsing _ | AKMacro _ ->
 			assert false)
 			assert false)
 	| _ ->
 	| _ ->
@@ -1542,7 +1598,7 @@ and type_unop ctx op flag e p =
 	| AKInline _ | AKUsing _ when not set -> access (acc_get ctx acc p)
 	| AKInline _ | AKUsing _ when not set -> access (acc_get ctx acc p)
 	| AKNo s ->
 	| AKNo s ->
 		error ("The field or identifier " ^ s ^ " is not accessible for " ^ (if set then "writing" else "reading")) p
 		error ("The field or identifier " ^ s ^ " is not accessible for " ^ (if set then "writing" else "reading")) p
-	| AKInline _ | AKUsing _ | AKMacro _ ->
+	| AKInline _ | AKUsing _ | AKMacro _ | AKAccess _ ->
 		error "This kind of operation is not supported" p
 		error "This kind of operation is not supported" p
 	| AKSet (e,m,t,f) ->
 	| AKSet (e,m,t,f) ->
 		let l = save_locals ctx in
 		let l = save_locals ctx in
@@ -1926,6 +1982,19 @@ and type_access ctx e p mode =
 	| EArray (e1,e2) ->
 	| EArray (e1,e2) ->
 		let e1 = type_expr ctx e1 Value in
 		let e1 = type_expr ctx e1 Value in
 		let e2 = type_expr ctx e2 Value in
 		let e2 = type_expr ctx e2 Value in
+		(try (match follow e1.etype with
+		| TAbstract ({a_impl = Some c} as a,pl) when a.a_array <> [] ->
+			(match mode with
+			| MSet ->
+				(* resolve later *)
+				AKAccess (e1, e2)
+			| _ ->
+				let cf,tf,r = find_array_access a pl c e2.etype t_dynamic false in
+				let et = type_module_type ctx (TClassDecl c) None p in
+				let ef = mk (TField(et,(FStatic(c,cf)))) tf p in
+				AKExpr (make_call ctx ef [e1;e2] r p))
+		| _ -> raise Not_found)
+		with Not_found ->
 		unify ctx e2.etype ctx.t.tint e2.epos;
 		unify ctx e2.etype ctx.t.tint e2.epos;
 		let rec loop et =
 		let rec loop et =
 			match follow et with
 			match follow et with
@@ -1945,7 +2014,7 @@ and type_access ctx e p mode =
 				pt
 				pt
 		in
 		in
 		let pt = loop e1.etype in
 		let pt = loop e1.etype in
-		AKExpr (mk (TArray (e1,e2)) pt p)
+		AKExpr (mk (TArray (e1,e2)) pt p))
 	| _ ->
 	| _ ->
 		AKExpr (type_expr ctx (e,p) Value)
 		AKExpr (type_expr ctx (e,p) Value)
 
 
@@ -2924,7 +2993,7 @@ and build_call ctx acc el (with_type:with_type) p =
 		let e = try f() with Error (m,p) -> display_error ctx (error_msg m) p; ctx.on_error <- old; raise Fatal_error in
 		let e = try f() with Error (m,p) -> display_error ctx (error_msg m) p; ctx.on_error <- old; raise Fatal_error in
 		ctx.on_error <- old;
 		ctx.on_error <- old;
 		e
 		e
-	| AKNo _ | AKSet _ ->
+	| AKNo _ | AKSet _ | AKAccess _ ->
 		ignore(acc_get ctx acc p);
 		ignore(acc_get ctx acc p);
 		assert false
 		assert false
 	| AKExpr e | AKField (e,_,_) ->
 	| AKExpr e | AKField (e,_,_) ->