[typer] add CfConstructor and a_constructor

src/codegen/gencommon/abstractImplementationFix.ml

@@ -24,7 +24,7 @@ let add_abstract_params = function
 	| TClassDecl ({ cl_kind = KAbstractImpl a } as c) ->
 		List.iter (
 			function
-			| ({ cf_name = "_new" } as cf) ->
+			| cf when has_class_field_flag cf CfConstructor ->
 				cf.cf_params <- cf.cf_params @ a.a_params
 			| cf when has_class_field_flag cf CfImpl ->
 				(match cf.cf_expr with

src/core/ast.ml

@@ -256,6 +256,7 @@ and access =
 	| AExtern
 	| AAbstract
 	| AOverload
+	| AConstructor
 
 and placed_access = access * pos
 
@@ -437,6 +438,7 @@ let s_access = function
 	| AExtern -> "extern"
 	| AAbstract -> "abstract"
 	| AOverload -> "overload"
+	| AConstructor -> "constructor"
 
 let s_placed_access (a,_) = s_access a
 

src/core/display/completionItem.ml

@@ -176,14 +176,9 @@ module CompletionModuleType = struct
 			raise Exit
 
 	let of_module_type mt =
-		let actor a = match a.a_impl with
-			| None -> No
-			| Some c ->
-				try
-					let cf = PMap.find "_new" c.cl_statics in
-					if (has_class_flag c CExtern) || (has_class_field_flag cf CfPublic) then Yes else YesButPrivate
-				with Not_found ->
-					No
+		let actor a = match a.a_constructor,a.a_impl with
+			| Some cf,Some c -> if (has_class_flag c CExtern) || (has_class_field_flag cf CfPublic) then Yes else YesButPrivate
+			| _ -> No
 		in
 		let ctor c =
 			try

src/core/tFunctions.ml

@@ -204,6 +204,7 @@ let null_abstract = {
 	a_ops = [];
 	a_unops = [];
 	a_impl = None;
+	a_constructor = None;
 	a_this = t_dynamic;
 	a_from = [];
 	a_from_field = [];

src/core/tType.ml

@@ -303,6 +303,7 @@ and tabstract = {
 	mutable a_ops : (Ast.binop * tclass_field) list;
 	mutable a_unops : (Ast.unop * unop_flag * tclass_field) list;
 	mutable a_impl : tclass option;
+	mutable a_constructor : tclass_field option;
 	mutable a_this : t;
 	mutable a_from : t list;
 	mutable a_from_field : (t * tclass_field) list;
@@ -396,6 +397,7 @@ type flag_tclass_field =
 	| CfImpl
 	| CfEnum
 	| CfGeneric
+	| CfConstructor
 
 type flag_tvar =
 	| VCaptured

src/macro/macroApi.ml

@@ -316,6 +316,7 @@ and encode_access a =
 		| AExtern -> 8
 		| AAbstract -> 9
 		| AOverload -> 10
+		| AConstructor -> 11
 	in
 	encode_enum ~pos:(Some (pos a)) IAccess tag []
 
@@ -668,6 +669,7 @@ and decode_access v =
 	| 8 -> AExtern
 	| 9 -> AAbstract
 	| 10 -> AOverload
+	| 11 -> AConstructor
 	| _ -> raise Invalid_expr
 	in
 	a,p

src/optimization/inline.ml

@@ -251,7 +251,7 @@ let inline_default_config cf t =
 let inline_config cls_opt cf call_args return_type =
 	match cls_opt with
 	| Some ({cl_kind = KAbstractImpl _}) when has_class_field_flag cf CfImpl ->
-		let t = if cf.cf_name = "_new" then
+		let t = if has_class_field_flag cf CfConstructor then
 			return_type
 		else if call_args = [] then
 			error "Invalid abstract implementation function" cf.cf_pos
@@ -588,7 +588,7 @@ class inline_state ctx ethis params cf f p = object(self)
 			(match follow ethis.etype with
 			| TAnon a -> (match !(a.a_status) with
 				| Statics {cl_kind = KAbstractImpl a } when has_class_field_flag cf CfImpl ->
-					if cf.cf_name <> "_new" then begin
+					if not (has_class_field_flag cf CfConstructor) then begin
 						(* the first argument must unify with a_this for abstract implementation functions *)
 						let tb = (TFun(("",false,map_type a.a_this) :: (List.tl tl),tret)) in
 						unify_raise ctx mt tb p

src/syntax/reification.ml

@@ -184,6 +184,7 @@ let reify in_macro =
 			| AExtern -> "AExtern"
 			| AAbstract -> "AAbstract"
 			| AOverload -> "AOverload"
+			| AConstructor -> "AConstructor"
 			) in
 			mk_enum "Access" n [] p
 		in

src/typing/calls.ml

@@ -50,7 +50,7 @@ let make_call ctx e params t ?(force_inline=false) p =
 		(match cl, ctx.curclass.cl_kind, params with
 			| Some c, KAbstractImpl _, { eexpr = TLocal { v_meta = v_meta } } :: _ when c == ctx.curclass ->
 				if
-					f.cf_name <> "_new"
+					not (has_class_field_flag f CfConstructor)
 					&& has_meta Meta.This v_meta
 					&& has_class_field_flag f CfModifiesThis
 				then
@@ -221,7 +221,7 @@ let unify_field_call ctx fa el_typed el p inline =
 			cfl,Some c,false,TClass.get_map_function c tl,(fun t -> t)
 		| FHAbstract(a,tl,c) ->
 			let map = apply_params a.a_params tl in
-			let tmap = if fa.fa_field.cf_name = "_new" (* TODO: BAD BAD BAD BAD *) then (fun t -> t) else (fun t -> map a.a_this) in
+			let tmap = if has_class_field_flag fa.fa_field CfConstructor then (fun t -> t) else (fun t -> map a.a_this) in
 			expand_overloads fa.fa_field,Some c,true,map,tmap
 	in
 	let is_forced_inline = is_forced_inline co fa.fa_field in

src/typing/typeload.ml

@@ -544,7 +544,7 @@ and load_complex_type' ctx allow_display (t,p) =
 					pub := false;
 				| ADynamic when (match f.cff_kind with FFun _ -> true | _ -> false) -> dyn := true
 				| AFinal -> final := true
-				| AStatic | AOverride | AInline | ADynamic | AMacro | AExtern | AAbstract | AOverload as a -> error ("Invalid access " ^ Ast.s_access a) p
+				| AStatic | AOverride | AInline | ADynamic | AMacro | AExtern | AAbstract | AOverload | AConstructor as a -> error ("Invalid access " ^ Ast.s_access a) p
 			) f.cff_access;
 			let t , access = (match f.cff_kind with
 				| FVar(t,e) when !final ->

src/typing/typeloadFields.ml

@@ -59,6 +59,7 @@ type class_init_ctx = {
 type field_kind =
 	| FKNormal
 	| FKConstructor
+	| FKAbstractConstructor
 	| FKInit
 
 type field_init_ctx = {
@@ -100,6 +101,7 @@ let dump_class_context cctx =
 let s_field_kind = function
 	| FKNormal -> "FKNormal"
 	| FKConstructor -> "FKConstructor"
+	| FKAbstractConstructor -> "FKAbstractConstructor"
 	| FKInit -> "FKInit"
 
 let dump_field_context fctx =
@@ -253,7 +255,7 @@ let transform_abstract_field com this_t a_t a f =
 			);
 			f_type = Some a_t;
 		} in
-		{ f with cff_name = "_new",pos f.cff_name; cff_kind = FFun fu; cff_meta = meta }
+		{ f with cff_name = "_new",pos f.cff_name; cff_kind = FFun fu; cff_meta = meta; cff_access = (AConstructor,null_pos) :: f.cff_access }
 	| FFun fu when not stat ->
 		if Meta.has Meta.From f.cff_meta then error "@:from cast functions must be static" f.cff_pos;
 		{ f with cff_kind = FFun fu }
@@ -595,7 +597,11 @@ let create_field_context (ctx,cctx) c cff =
 	let field_kind = match fst cff.cff_name with
 		| "new" -> FKConstructor
 		| "__init__" when is_static -> FKInit
-		| _ -> FKNormal
+		| _ ->
+			if List.mem_assoc AConstructor cff.cff_access && cctx.abstract <> None then
+				FKAbstractConstructor
+			else
+				FKNormal
 	in
 	let fctx = {
 		is_inline = is_inline;
@@ -731,7 +737,7 @@ let check_field_display ctx fctx c cf =
 		let scope, cf = match c.cl_kind with
 			| KAbstractImpl _ ->
 				if has_class_field_flag cf CfImpl then
-					(if cf.cf_name = "_new" then
+					(if has_class_field_flag cf CfConstructor then
 						CFSConstructor, {cf with cf_name = "new"}
 					else
 						CFSMember, cf)
@@ -957,10 +963,11 @@ let check_abstract (ctx,cctx,fctx) c cf fd t ret p =
 					let r = exc_protect ctx (fun r ->
 						r := lazy_processing (fun () -> t);
 						let args = if Meta.has Meta.MultiType a.a_meta then begin
-							let ctor = try
-								PMap.find "_new" c.cl_statics
-							with Not_found ->
-								error "Constructor of multi-type abstract must be defined before the individual @:to-functions are" cf.cf_pos
+							let ctor = match a.a_constructor with
+								| Some cf ->
+									cf
+								| None ->
+									error "Constructor of multi-type abstract must be defined before the individual @:to-functions are" cf.cf_pos
 							in
 							(* delay ctx PFinal (fun () -> unify ctx m tthis f.cff_pos); *)
 							let args = match follow (monomorphs a.a_params ctor.cf_type) with
@@ -1045,7 +1052,7 @@ let check_abstract (ctx,cctx,fctx) c cf fd t ret p =
 					if not (Meta.has Meta.CoreType a.a_meta) then fctx.do_add <- false;
 				end
 			in
-			if cf.cf_name = "_new" && Meta.has Meta.MultiType a.a_meta then fctx.do_bind <- false;
+			if has_class_field_flag cf CfConstructor && Meta.has Meta.MultiType a.a_meta then fctx.do_bind <- false;
 			if !allows_no_expr then check_bind()
 		| _ ->
 			()
@@ -1143,7 +1150,7 @@ let create_method (ctx,cctx,fctx) c f fd p =
 	let args = loop fd.f_args in
 	let fargs = TypeloadFunction.convert_fargs fd in
 	let args,fargs = match cctx.abstract with
-		| Some a when fctx.is_abstract_member && fst f.cff_name <> "_new" (* TODO: this sucks *) && not fctx.is_macro ->
+		| Some a when fctx.is_abstract_member && not (List.mem_assoc AConstructor f.cff_access) && not fctx.is_macro ->
 			("this",None,a.a_this) :: args,(null_pos,[]) :: fargs
 		| _ ->
 			args,fargs
@@ -1196,7 +1203,7 @@ let create_method (ctx,cctx,fctx) c f fd p =
 				| Some _ ->
 					(match args with
 					| ("this",_,_) :: _ -> FunMemberAbstract
-					| _ when fst f.cff_name = "_new" -> FunMemberAbstract
+					| _ when List.mem_assoc AConstructor f.cff_access -> FunMemberAbstract
 					| _ -> FunStatic)
 				| None ->
 					if fctx.field_kind = FKConstructor then FunConstructor else if fctx.is_static then FunStatic else FunMember
@@ -1434,7 +1441,7 @@ let init_field (ctx,cctx,fctx) f =
 	if not (has_class_flag c CExtern) && not (Meta.has Meta.Native f.cff_meta) then Typecore.check_field_name ctx name p;
 	List.iter (fun acc ->
 		match (fst acc, f.cff_kind) with
-		| APublic, _ | APrivate, _ | AStatic, _ | AFinal, _ | AExtern, _ -> ()
+		| APublic, _ | APrivate, _ | AStatic, _ | AFinal, _ | AExtern, _ | AConstructor, _ -> ()
 		| ADynamic, FFun _ | AOverride, FFun _ | AMacro, FFun _ | AInline, FFun _ | AInline, FVar _ | AAbstract, FFun _ | AOverload, FFun _ -> ()
 		| _, FVar _ -> display_error ctx ("Invalid accessor '" ^ Ast.s_placed_access acc ^ "' for variable " ^ name) (snd acc)
 		| _, FProp _ -> display_error ctx ("Invalid accessor '" ^ Ast.s_placed_access acc ^ "' for property " ^ name) (snd acc)
@@ -1604,6 +1611,15 @@ let init_class ctx c p context_init herits fields =
 				| Some ctor ->
 							display_error ctx "Duplicate constructor" p
 				end
+			| FKAbstractConstructor ->
+				begin match cctx.abstract with
+					| Some a ->
+						add_class_field_flag cf CfConstructor;
+						a.a_constructor <- Some cf;
+						if fctx.do_add then TClass.add_field c cf
+					| None ->
+						die "" __LOC__
+				end
 			| FKInit ->
 				()
 			| FKNormal ->

src/typing/typeloadModule.ml

@@ -326,6 +326,7 @@ let module_pass_1 ctx m tdecls loadp =
 				a_ops = [];
 				a_unops = [];
 				a_impl = None;
+				a_constructor = None;
 				a_array = [];
 				a_this = mk_mono();
 				a_read = None;

src/typing/typer.ml

@@ -1369,7 +1369,7 @@ and type_array_comprehension ctx e with_type p =
 	]) v.v_type p
 
 and type_return ?(implicit=false) ctx e with_type p =
-	let is_abstract_ctor = ctx.curfun = FunMemberAbstract && ctx.curfield.cf_name = "_new" in
+	let is_abstract_ctor = ctx.curfun = FunMemberAbstract && has_class_field_flag ctx.curfield CfConstructor in
 	match e with
 	| None when is_abstract_ctor ->
 		let e_cast = mk (TCast(get_this ctx p,None)) ctx.ret p in

src/typing/typerBase.ml

@@ -134,7 +134,7 @@ let assign_to_this_is_allowed ctx =
 		| KAbstractImpl _ ->
 			(match ctx.curfield.cf_kind with
 				| Method MethInline -> true
-				| Method _ when ctx.curfield.cf_name = "_new" -> true
+				| Method _ when has_class_field_flag ctx.curfield CfConstructor -> true
 				| _ -> false
 			)
 		| _ -> false
@@ -399,7 +399,10 @@ module FieldAccess = struct
 	let get_constructor_access c params p =
 		match c.cl_kind with
 		| KAbstractImpl a ->
-			let cf = (try PMap.find "_new" c.cl_statics with Not_found -> raise_error (No_constructor (TAbstractDecl a)) p) in
+			let cf = match a.a_constructor with
+				| Some cf -> cf
+				| None -> raise_error (No_constructor (TAbstractDecl a)) p
+			in
 			create (Builder.make_static_this c p) cf (FHAbstract(a,params,c)) false p
 		| _ ->
 			let cf = (try Type.get_constructor c with Not_found -> raise_error (No_constructor (TClassDecl c)) p) in

src/typing/typerDisplay.ml

@@ -596,9 +596,9 @@ let handle_display ctx e_ast dk mode with_type =
 						let mt = ctx.g.do_load_type_def ctx null_pos {tpackage=mt.pack;tname=mt.module_name;tsub=Some mt.name;tparams=[]} in
 						begin match resolve_typedef mt with
 						| TClassDecl c when has_constructor c -> true
-						| TAbstractDecl {a_impl = Some c} ->
+						| TAbstractDecl ({a_impl = Some c} as a) ->
 							ignore(c.cl_build());
-							PMap.mem "_new" c.cl_statics
+							a.a_constructor <> None
 						| _ -> false
 						end
 					with _ ->