Переглянути джерело

fixed constraint comparison between two fields (fixed issue #1228)

Nicolas Cannasse 13 роки тому
батько
коміт
a127252e03
1 змінених файлів з 19 додано та 16 видалено
  1. 19 16
      typeload.ml

+ 19 - 16
typeload.ml

@@ -514,29 +514,32 @@ let valid_redefinition ctx f1 t1 f2 t2 =
 	let t1, t2 = (match f1.cf_params, f2.cf_params with
 		| [], [] -> t1, t2
 		| l1, l2 when List.length l1 = List.length l2 ->
-			let monos = List.map2 (fun (_,p1) (_,p2) ->
-				match follow p1, follow p2 with
+			let to_check = ref [] in
+			let monos = List.map2 (fun (name,p1) (_,p2) ->
+				(match follow p1, follow p2 with
 				| TInst ({ cl_kind = KTypeParameter ct1 } as c1,pl1), TInst ({ cl_kind = KTypeParameter ct2 } as c2,pl2) ->
 					(match ct1, ct2 with
-					| [], [] ->
-						let m = mk_mono() in
-						m,m
+					| [], [] -> ()
 					| _, _ when List.length ct1 = List.length ct2 ->
 						(* if same constraints, they are the same type *)
-						List.iter2 (fun t1 t2  ->
-							try
-								type_eq EqStrict (apply_params c1.cl_types pl1 t1) (apply_params c2.cl_types pl2 t2)
-							with Unify_error l ->
-								raise (Unify_error (Unify_custom "Constraints differ" :: l))
-						) ct1 ct2;
-						let m = mk_mono() in
-						m,m
+						let check monos =
+							List.iter2 (fun t1 t2  ->
+								try
+									let t1 = apply_params l1 monos (apply_params c1.cl_types pl1 t1) in
+									let t2 = apply_params l2 monos (apply_params c2.cl_types pl2 t2) in
+									type_eq EqStrict t1 t2
+								with Unify_error l ->
+									raise (Unify_error (Unify_custom "Constraints differ" :: l))
+							) ct1 ct2
+						in
+						to_check := check :: !to_check;
 					| _ ->
 						raise (Unify_error [Unify_custom "Different number of constraints"]))
-				| _ ->
-					p1, p2
+				| _ -> ());
+				TInst (mk_class null_module ([],name) Ast.null_pos,[])
 			) l1 l2 in
-			apply_params l1 (List.map fst monos) t1, apply_params l2 (List.map snd monos) t2
+			List.iter (fun f -> f monos) !to_check;
+			apply_params l1 monos t1, apply_params l2 monos t2
 		| _  ->
 			(* ignore type params, will create other errors later *)
 			t1, t2