2
0
Simon Krajewski 12 жил өмнө
parent
commit
fe31c73115
2 өөрчлөгдсөн 68 нэмэгдсэн , 63 устгасан
  1. 8 4
      codegen.ml
  2. 60 59
      typeload.ml

+ 8 - 4
codegen.ml

@@ -370,7 +370,9 @@ let rec build_generic ctx c p tl =
 					in
 					try
 						if pl <> [] then raise Not_found;
-						loop subst;
+						let t = loop subst in
+						(match c.cl_constructor with None -> () | Some cf -> error "Generics extending type parameters cannot have constructors" cf.cf_pos);
+						t
 					with Not_found ->
 						apply_params c.cl_types tl (TInst(cs,pl))
 				in
@@ -383,11 +385,13 @@ let rec build_generic ctx c p tl =
 					| _ -> assert false)
 				| _ -> Some(cs,pl)
 		);
+		Typeload.add_constructor ctx cg p;
 		cg.cl_kind <- KGenericInstance (c,tl);
 		cg.cl_interface <- c.cl_interface;
-		cg.cl_constructor <- (match c.cl_constructor, c.cl_super with
-			| None, None -> None
-			| Some c, _ -> Some (build_field c)
+		cg.cl_constructor <- (match cg.cl_constructor, c.cl_constructor, c.cl_super with
+			| Some ctor, _, _ -> Some ctor
+			| None, None, None -> None
+			| None, Some c, _ -> Some (build_field c)
 			| _ -> error "Please define a constructor for this class in order to use it as generic" c.cl_pos
 		);
 		cg.cl_implements <- List.map (fun (i,tl) ->

+ 60 - 59
typeload.ml

@@ -937,6 +937,64 @@ let check_extends ctx c t p = match follow t with
 		end
 	| _ -> error "Should extend by using a class" p
 
+let rec add_constructor ctx c p =
+	match c.cl_constructor, c.cl_super with
+	| None, Some ({ cl_constructor = Some cfsup } as csup,cparams) when not c.cl_extern ->
+		let cf = {
+			cfsup with
+			cf_pos = p;
+			cf_meta = [];
+			cf_doc = None;
+			cf_expr = None;
+		} in
+		let r = exc_protect ctx (fun r ->
+			let t = mk_mono() in
+			r := (fun() -> t);
+			let ctx = { ctx with
+				curfield = cf;
+				pass = PTypeField;
+			} in
+			ignore (follow cfsup.cf_type); (* make sure it's typed *)
+			(if ctx.com.config.pf_overload then List.iter (fun cf -> ignore (follow cf.cf_type)) cf.cf_overloads);
+			let args = (match cfsup.cf_expr with
+				| Some { eexpr = TFunction f } ->
+					List.map (fun (v,def) ->
+						(*
+							let's optimize a bit the output by not always copying the default value
+							into the inherited constructor when it's not necessary for the platform
+						*)
+						match ctx.com.platform, def with
+						| _, Some _ when not ctx.com.config.pf_static -> v, (Some TNull)
+						| Flash, Some (TString _) -> v, (Some TNull)
+						| Cpp, Some (TString _) -> v, def
+						| Cpp, Some _ -> { v with v_type = ctx.t.tnull v.v_type }, (Some TNull)
+						| _ -> v, def
+					) f.tf_args
+				| _ ->
+					match follow cfsup.cf_type with
+					| TFun (args,_) -> List.map (fun (n,o,t) -> alloc_var n (if o then ctx.t.tnull t else t), if o then Some TNull else None) args
+					| _ -> assert false
+			) in
+			let p = c.cl_pos in
+			let vars = List.map (fun (v,def) -> alloc_var v.v_name (apply_params csup.cl_types cparams v.v_type), def) args in
+			let super_call = mk (TCall (mk (TConst TSuper) (TInst (csup,cparams)) p,List.map (fun (v,_) -> mk (TLocal v) v.v_type p) vars)) ctx.t.tvoid p in
+			let constr = mk (TFunction {
+				tf_args = vars;
+				tf_type = ctx.t.tvoid;
+				tf_expr = super_call;
+			}) (TFun (List.map (fun (v,c) -> v.v_name, c <> None, v.v_type) vars,ctx.t.tvoid)) p in
+			cf.cf_expr <- Some constr;
+			cf.cf_type <- t;
+			unify ctx t constr.etype p;
+			t
+		) "add_constructor" in
+		cf.cf_type <- TLazy r;
+		c.cl_constructor <- Some cf;
+		delay ctx PForce (fun() -> ignore((!r)()));
+	| _ ->
+		(* nothing to do *)
+		()
+
 let set_heritance ctx c herits p =
 	let ctx = { ctx with curclass = c; type_params = c.cl_types; } in
 	let process_meta csup =
@@ -1814,67 +1872,10 @@ let init_class ctx c p context_init herits fields =
 	(*
 		make sure a default contructor with same access as super one will be added to the class structure at some point.
 	*)
-	let rec add_constructor c =
-		match c.cl_constructor, c.cl_super with
-		| None, Some ({ cl_constructor = Some cfsup } as csup,cparams) when not c.cl_extern ->
-			let cf = {
-				cfsup with
-				cf_pos = p;
-				cf_meta = [];
-				cf_doc = None;
-				cf_expr = None;
-			} in
-			let r = exc_protect ctx (fun r ->
-				let t = mk_mono() in
-				r := (fun() -> t);
-				let ctx = { ctx with
-					curfield = cf;
-					pass = PTypeField;
-				} in
-				ignore (follow cfsup.cf_type); (* make sure it's typed *)
-				(if ctx.com.config.pf_overload then List.iter (fun cf -> ignore (follow cf.cf_type)) cf.cf_overloads);
-				let args = (match cfsup.cf_expr with
-					| Some { eexpr = TFunction f } ->
-						List.map (fun (v,def) ->
-							(*
-								let's optimize a bit the output by not always copying the default value
-								into the inherited constructor when it's not necessary for the platform
-							*)
-							match ctx.com.platform, def with
-							| _, Some _ when not ctx.com.config.pf_static -> v, (Some TNull)
-							| Flash, Some (TString _) -> v, (Some TNull)
-							| Cpp, Some (TString _) -> v, def
-							| Cpp, Some _ -> { v with v_type = ctx.t.tnull v.v_type }, (Some TNull)
-							| _ -> v, def
-						) f.tf_args
-					| _ ->
-						match follow cfsup.cf_type with
-						| TFun (args,_) -> List.map (fun (n,o,t) -> alloc_var n (if o then ctx.t.tnull t else t), if o then Some TNull else None) args
-						| _ -> assert false
-				) in
-				let p = c.cl_pos in
-				let vars = List.map (fun (v,def) -> alloc_var v.v_name (apply_params csup.cl_types cparams v.v_type), def) args in
-				let super_call = mk (TCall (mk (TConst TSuper) (TInst (csup,cparams)) p,List.map (fun (v,_) -> mk (TLocal v) v.v_type p) vars)) ctx.t.tvoid p in
-				let constr = mk (TFunction {
-					tf_args = vars;
-					tf_type = ctx.t.tvoid;
-					tf_expr = super_call;
-				}) (TFun (List.map (fun (v,c) -> v.v_name, c <> None, v.v_type) vars,ctx.t.tvoid)) p in
-				cf.cf_expr <- Some constr;
-				cf.cf_type <- t;
-				unify ctx t constr.etype p;
-				t
-			) "add_constructor" in
-			cf.cf_type <- TLazy r;
-			c.cl_constructor <- Some cf;
-			delay ctx PForce (fun() -> ignore((!r)()));
-		| _ ->
-			(* nothing to do *)
-			()
-	in
+
   (* add_constructor does not deal with overloads correctly *)
   if not ctx.com.config.pf_overload then
-  	add_constructor c;
+  	add_constructor ctx c p;
 	(* check overloaded constructors *)
 	(if ctx.com.config.pf_overload then match c.cl_constructor with
 	| Some ctor ->