فهرست منبع

inversed local function typing order (parameters are infered based on its usage as an argument).

Nicolas Cannasse 18 سال پیش
والد
کامیت
86298fdc48
1فایلهای تغییر یافته به همراه38 افزوده شده و 11 حذف شده
  1. 38 11
      typer.ml

+ 38 - 11
typer.ml

@@ -57,6 +57,7 @@ type context = {
 	mutable locals_map : (string, string) PMap.t;
 	mutable locals_map_inv : (string, string) PMap.t;
 	mutable opened : anon_status ref list;
+	mutable param_type : t option;
 }
 
 (* ---------------------------------------------------------------------- *)
@@ -145,6 +146,7 @@ let context err warn =
 		current = empty;
 		std = empty;
 		opened = [];
+		param_type = None;
 	} in
 	ctx.std <- (try
 		load ctx ([],"StdTypes") null_pos
@@ -766,15 +768,29 @@ let unify_call_params ctx name el args p =
 			| _ -> error "Invalid");
 			[]
 		| e :: l, (name,opt,t) :: l2 ->
-			try
-				unify_raise ctx e.etype t e.epos;
-				loop ((e,false) :: acc) l l2 skip
+			let old = ctx.param_type in
+			let e = (try
+				ctx.param_type <- Some t;
+				let e = (!type_expr_ref) ctx e in
+				ctx.param_type <- old;
+				e
 			with
-				Error (Unify ul,_) ->
-					if opt then
-						loop (default_value t :: acc) (e :: l) l2 ((name,ul) :: skip)
-					else
-						arg_error ul name false
+				exc -> 
+					ctx.param_type <- old;
+					raise exc
+			) in
+			let rec inner_loop acc skip =
+				try
+					unify_raise ctx e.etype t e.epos;
+					loop ((e,false) :: acc) l l2 skip
+				with
+					Error (Unify ul,_) ->
+						if opt then
+							inner_loop (default_value t :: acc) ((name,ul) :: skip)
+						else
+							arg_error ul name false
+			in
+			inner_loop acc skip
 	in
 	loop [] el args []
 
@@ -1787,7 +1803,6 @@ and type_expr ctx ?(need_val=true) (e,p) =
 		else
 			e
 	| ECall ((EConst (Ident "super"),sp),el) ->
-		let el = List.map (type_expr ctx) el in
 		if ctx.in_static || not ctx.in_constructor then error "Cannot call superconstructor outside class constructor" p;
 		let el, t = (match ctx.curclass.cl_super with
 		| None -> error "Current class does not have a super" p
@@ -1805,16 +1820,17 @@ and type_expr ctx ?(need_val=true) (e,p) =
 	| ECall (e,el) ->
 		(match e with EField ((EConst (Ident "super"),_),_) , _ -> ctx.super_call <- true | _ -> ());
 		let e = type_expr ctx e in
-		let el = List.map (type_expr ctx) el in
 		let el , t = (match follow e.etype with
 		| TFun (args,r) ->
 			let el = unify_call_params ctx (match e.eexpr with TField (_,f) -> Some f | _ -> None) el args p in
 			el , r
 		| TMono _ ->
 			let t = mk_mono() in
+			let el = List.map (type_expr ctx) el in
 			unify ctx (TFun (List.map (fun e -> "",false,e.etype) el,t)) e.etype e.epos;
 			el, t
 		| t ->
+			let el = List.map (type_expr ctx) el in
 			el, if t == t_dynamic then
 				t_dynamic
 			else if ctx.untyped then
@@ -1827,7 +1843,6 @@ and type_expr ctx ?(need_val=true) (e,p) =
 		let name = (match t.tpackage with [] -> t.tname | x :: _ -> x) in
 		if PMap.mem name ctx.locals then error ("Local variable " ^ name ^ " is preventing usage of this class here") p;
 		let t = load_normal_type ctx t p true in
-		let el = List.map (type_expr ctx) el in
 		let el, c , params , t = (match follow t with
 		| TInst (c,params) ->
 			let f = (match c.cl_constructor with Some f -> f | None -> error (s_type_path c.cl_path ^ " does not have a constructor") p) in
@@ -1848,6 +1863,17 @@ and type_expr ctx ?(need_val=true) (e,p) =
 	| EFunction f ->
 		let rt = load_type_opt ctx p f.f_type in
 		let args = List.map (fun (s,opt,t) -> s , opt, load_type_opt ctx p t) f.f_args in
+		(match ctx.param_type with
+		| None -> ()
+		| Some t -> 
+			match follow t with
+			| TFun (args2,_) when List.length args2 = List.length args ->
+				List.iter2 (fun (_,_,t1) (_,_,t2) ->
+					match follow t1 with
+					| TMono _ -> unify ctx t2 t1 p
+					| _ -> ()
+				) args args2;				
+			| _ -> ());
 		let ft = TFun (args,rt) in
 		let e , fargs = type_function ctx ft true false f p in
 		let f = {
@@ -2318,6 +2344,7 @@ let type_module ctx m tdecls loadp =
 		in_loop = false;
 		untyped = false;
 		opened = [];
+		param_type = None;
 	} in
 	let delays = ref [] in
 	let get_class name =