[typer] split up abstract array read/write handling

src/context/abstractCast.ml

@@ -112,43 +112,57 @@ and cast_or_unify ctx tleft eright p =
 		raise_or_display ctx l p;
 		eright
 
-let find_array_access_raise ctx a pl e1 e2o p =
-	let is_set = e2o <> None in
-	let ta = apply_params a.a_params pl a.a_this in
+let prepare_array_access_field ctx a pl cf p =
+	let monos = List.map (fun _ -> spawn_monomorph ctx p) cf.cf_params in
+	let map t = apply_params a.a_params pl (apply_params cf.cf_params monos t) in
+	let check_constraints () =
+		List.iter2 (fun m tp -> match follow tp.ttp_type with
+			| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
+				List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> Type.unify m (map tc) ) constr
+			| _ -> ()
+		) monos cf.cf_params;
+	in
+	let get_ta() =
+		let ta = apply_params a.a_params pl a.a_this in
+		if has_class_field_flag cf CfImpl then ta
+		else TAbstract(a,pl)
+	in
+	map,check_constraints,get_ta
+
+let find_array_read_access_raise ctx a pl e1 p =
 	let rec loop cfl =
 		match cfl with
 		| [] -> raise Not_found
 		| cf :: cfl ->
-			let monos = List.map (fun _ -> spawn_monomorph ctx p) cf.cf_params in
-			let map t = apply_params a.a_params pl (apply_params cf.cf_params monos t) in
-			let check_constraints () =
-				List.iter2 (fun m tp -> match follow tp.ttp_type with
-					| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
-						List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> Type.unify m (map tc) ) constr
-					| _ -> ()
-				) monos cf.cf_params;
-			in
-			let get_ta() =
-				if has_class_field_flag cf CfImpl then ta
-				else TAbstract(a,pl)
-			in
+			let map,check_constraints,get_ta = prepare_array_access_field ctx a pl cf p in
 			match follow (map cf.cf_type) with
-			| TFun((_,_,tab) :: (_,_,ta1) :: (_,_,ta2) :: args,r) as tf when is_set && is_empty_or_pos_infos args ->
+			| TFun((_,_,tab) :: (_,_,ta1) :: args,r) as tf when is_empty_or_pos_infos args ->
 				begin try
 					Type.unify tab (get_ta());
 					let e1 = cast_or_unify_raise ctx ta1 e1 p in
-					let e2o = match e2o with None -> None | Some e2 -> Some (cast_or_unify_raise ctx ta2 e2 p) in
 					check_constraints();
-					cf,tf,r,e1,e2o
+					cf,tf,r,e1
 				with Unify_error _ | Error (Unify _,_) ->
 					loop cfl
 				end
-			| TFun((_,_,tab) :: (_,_,ta1) :: args,r) as tf when not is_set && is_empty_or_pos_infos args ->
+			| _ -> loop cfl
+	in
+	loop a.a_array
+
+let find_array_write_access_raise ctx a pl e1 e2  p =
+	let rec loop cfl =
+		match cfl with
+		| [] -> raise Not_found
+		| cf :: cfl ->
+			let map,check_constraints,get_ta = prepare_array_access_field ctx a pl cf p in
+			match follow (map cf.cf_type) with
+			| TFun((_,_,tab) :: (_,_,ta1) :: (_,_,ta2) :: args,r) as tf when is_empty_or_pos_infos args ->
 				begin try
 					Type.unify tab (get_ta());
 					let e1 = cast_or_unify_raise ctx ta1 e1 p in
+					let e2 = cast_or_unify_raise ctx ta2 e2 p in
 					check_constraints();
-					cf,tf,r,e1,None
+					cf,tf,r,e1,e2
 				with Unify_error _ | Error (Unify _,_) ->
 					loop cfl
 				end
@@ -156,15 +170,19 @@ let find_array_access_raise ctx a pl e1 e2o p =
 	in
 	loop a.a_array
 
-let find_array_access ctx a tl e1 e2o p =
-	try find_array_access_raise ctx a tl e1 e2o p
+let find_array_read_access ctx a tl e1 p =
+	try
+		find_array_read_access_raise ctx a tl e1 p
+	with Not_found ->
+		let s_type = s_type (print_context()) in
+		typing_error (Printf.sprintf "No @:arrayAccess function for %s accepts argument of %s" (s_type (TAbstract(a,tl))) (s_type e1.etype)) p
+
+let find_array_write_access ctx a tl e1 e2 p =
+	try
+		find_array_write_access_raise ctx a tl e1 e2 p
 	with Not_found ->
 		let s_type = s_type (print_context()) in
-		match e2o with
-		| None ->
-			typing_error (Printf.sprintf "No @:arrayAccess function for %s accepts argument of %s" (s_type (TAbstract(a,tl))) (s_type e1.etype)) p
-		| Some e2 ->
-			typing_error (Printf.sprintf "No @:arrayAccess function for %s accepts arguments of %s and %s" (s_type (TAbstract(a,tl))) (s_type e1.etype) (s_type e2.etype)) p
+		typing_error (Printf.sprintf "No @:arrayAccess function for %s accepts arguments of %s and %s" (s_type (TAbstract(a,tl))) (s_type e1.etype) (s_type e2.etype)) p
 
 let find_multitype_specialization com a pl p =
 	let uctx = default_unification_context in

src/typing/calls.ml

@@ -86,7 +86,7 @@ let make_call ctx e params t ?(force_inline=false) p =
 	with Exit ->
 		mk (TCall (e,params)) t p
 
-let mk_array_get_call ctx (cf,tf,r,e1,e2o) c ebase p = match cf.cf_expr with
+let mk_array_get_call ctx (cf,tf,r,e1) c ebase p = match cf.cf_expr with
 	| None when not (has_class_field_flag cf CfExtern) ->
 		if not (Meta.has Meta.NoExpr cf.cf_meta) then display_error ctx.com "Recursive array get method" p;
 		mk (TArray(ebase,e1)) r p
@@ -95,8 +95,7 @@ let mk_array_get_call ctx (cf,tf,r,e1,e2o) c ebase p = match cf.cf_expr with
 		let ef = mk (TField(et,(FStatic(c,cf)))) tf p in
 		make_call ctx ef [ebase;e1] r p
 
-let mk_array_set_call ctx (cf,tf,r,e1,e2o) c ebase p =
-	let evalue = match e2o with None -> die "" __LOC__ | Some e -> e in
+let mk_array_set_call ctx (cf,tf,r,e1,evalue) c ebase p =
 	match cf.cf_expr with
 		| None when not (has_class_field_flag cf CfExtern) ->
 			if not (Meta.has Meta.NoExpr cf.cf_meta) then display_error ctx.com "Recursive array set method" p;
@@ -442,9 +441,9 @@ let array_access ctx e1 e2 mode p =
 				AKAccess (a,pl,c,e1,e2)
 			| _ ->
 				has_abstract_array_access := true;
-				let f = AbstractCast.find_array_access ctx a pl e2 None p in
+				let f = AbstractCast.find_array_read_access ctx a pl e2 p in
 				if not ctx.allow_transform then
-					let _,_,r,_,_ = f in
+					let _,_,r,_ = f in
 					AKExpr { eexpr = TArray(e1,e2); epos = p; etype = r }
 				else begin
 					let e = mk_array_get_call ctx f c e1 p in

src/typing/forLoop.ml

@@ -154,7 +154,7 @@ module IterationKind = struct
 			(try
 				(* first try: do we have an @:arrayAccess getter field? *)
 				let todo = mk (TConst TNull) ctx.t.tint p in
-				let cf,_,r,_,_ = AbstractCast.find_array_access_raise ctx a tl todo None p in
+				let cf,_,r,_ = AbstractCast.find_array_read_access_raise ctx a tl todo p in
 				let get_next e_base e_index t p =
 					make_static_call ctx c cf (apply_params a.a_params tl) [e_base;e_index] r p
 				in

src/typing/operators.ml

@@ -571,7 +571,7 @@ let type_assign ctx e1 e2 with_type p =
 		dispatcher#accessor_call fa [] [e2]
 	| AKAccess(a,tl,c,ebase,ekey) ->
 		let e2 = type_rhs WithType.value in
-		mk_array_set_call ctx (AbstractCast.find_array_access ctx a tl ekey (Some e2) p) c ebase p
+		mk_array_set_call ctx (AbstractCast.find_array_write_access ctx a tl ekey e2 p) c ebase p
 	| AKResolve(sea,name) ->
 		let eparam = sea.se_this in
 		let e_name = Texpr.Builder.make_string ctx.t name null_pos in
@@ -677,7 +677,7 @@ let type_assign_op ctx op e1 e2 with_type p =
 		let t_lhs,e_rhs = field_rhs op fa.fa_field ef in
 		set vr sea.se_access t_lhs e_rhs [ef]
 	| AKAccess(a,tl,c,ebase,ekey) ->
-		let cf_get,tf_get,r_get,ekey,_ = AbstractCast.find_array_access ctx a tl ekey None p in
+		let cf_get,tf_get,r_get,ekey = AbstractCast.find_array_read_access ctx a tl ekey p in
 		(* bind complex keys to a variable so they do not make it into the output twice *)
 		let save = save_locals ctx in
 		let maybe_bind_to_temp e = match Optimizer.make_constant_expression ctx e with
@@ -689,13 +689,12 @@ let type_assign_op ctx op e1 e2 with_type p =
 		in
 		let ekey,ekey' = maybe_bind_to_temp ekey in
 		let ebase,ebase' = maybe_bind_to_temp ebase in
-		let eget = mk_array_get_call ctx (cf_get,tf_get,r_get,ekey,None) c ebase p in
+		let eget = mk_array_get_call ctx (cf_get,tf_get,r_get,ekey) c ebase p in
 		let eget = type_binop2 ctx op eget e2 true WithType.value p in
 		let vr = new value_reference ctx in
 		let eget = BinopResult.to_texpr vr eget (fun e -> e) in
 		unify ctx eget.etype r_get p;
-		let cf_set,tf_set,r_set,ekey,eget = AbstractCast.find_array_access ctx a tl ekey (Some eget) p in
-		let eget = match eget with None -> die "" __LOC__ | Some e -> e in
+		let cf_set,tf_set,r_set,ekey,eget = AbstractCast.find_array_write_access ctx a tl ekey eget p in
 		let et = type_module_type ctx (TClassDecl c) None p in
 		let e = match cf_set.cf_expr,cf_get.cf_expr with
 			| None,None ->
@@ -883,7 +882,7 @@ let type_unop ctx op flag e with_type p =
 				let evar_key = mk (TVar(v_key,Some ekey)) ctx.com.basic.tvoid ekey.epos in
 				let ekey = mk (TLocal v_key) ekey.etype ekey.epos in
 				(* get *)
-				let e_get = mk_array_get_call ctx (AbstractCast.find_array_access_raise ctx a tl ekey None p) c ebase p in
+				let e_get = mk_array_get_call ctx (AbstractCast.find_array_read_access_raise ctx a tl ekey p) c ebase p in
 				let v_get = alloc_var VGenerated "tmp" e_get.etype e_get.epos in
 				let ev_get = mk (TLocal v_get) v_get.v_type p in
 				let evar_get = mk (TVar(v_get,Some e_get)) ctx.com.basic.tvoid p in
@@ -891,11 +890,11 @@ let type_unop ctx op flag e with_type p =
 				let e_one = mk (TConst (TInt (Int32.of_int 1))) ctx.com.basic.tint p in
 				let e_op = mk (TBinop((if op = Increment then OpAdd else OpSub),ev_get,e_one)) ev_get.etype p in
 				(* set *)
-				let e_set = mk_array_set_call ctx (AbstractCast.find_array_access_raise ctx a tl ekey (Some e_op) p) c ebase p in
+				let e_set = mk_array_set_call ctx (AbstractCast.find_array_write_access_raise ctx a tl ekey e_op p) c ebase p in
 				let el = evar_key :: evar_get :: e_set :: (if flag = Postfix then [ev_get] else []) in
 				mk (TBlock el) e_set.etype p
 			with Not_found ->
-				let e = mk_array_get_call ctx (AbstractCast.find_array_access ctx a tl ekey None p) c ebase p in
+				let e = mk_array_get_call ctx (AbstractCast.find_array_read_access ctx a tl ekey p) c ebase p in
 				find_overload_or_make e
 			end
 		| AKUsingField _ | AKResolve _ | AKSafeNav _ ->