rewrote dt -> AST conversion

ast.ml

@@ -54,6 +54,7 @@ module Meta = struct
 		| DynamicObject
 		| Enum
 		| EnumConstructorParam
+		| Exhaustive
 		| Expose
 		| Extern
 		| FakeEnum
@@ -138,7 +139,7 @@ module Meta = struct
 	let get m ml = List.find (fun (m2,_,_) -> m = m2) ml
 
 	let to_string_ref = ref (fun _ -> assert false)
-	let to_string (m : strict_meta) : string = !to_string_ref m 
+	let to_string (m : strict_meta) : string = !to_string_ref m
 end
 
 type keyword =

codegen.ml

@@ -1289,6 +1289,12 @@ let check_local_vars_init e =
 				v
 			) cases in
 			(match def with
+			| None when (match e.eexpr with TMeta((Meta.Exhaustive,_,_),_) | TParenthesis({eexpr = TMeta((Meta.Exhaustive,_,_),_)}) -> true | _ -> false) ->
+				(match cvars with
+				| cv :: cvars ->
+					PMap.iter (fun i b -> if b then vars := PMap.add i b !vars) cv;
+					join vars cvars
+				| [] -> ())
 			| None -> ()
 			| Some e ->
 				loop vars e;
@@ -1533,18 +1539,12 @@ module Abstract = struct
 end
 
 module PatternMatchConversion = struct
-	type cctx = {
+
+ 	type cctx = {
 		ctx : typer;
-		v_lookup : (string,tvar) Hashtbl.t;
-		out_type : t;
 		mutable eval_stack : ((tvar * pos) * st) list list;
 		dt_lookup : dt array;
-	}
-
-	let mk_st def t p = {
-		st_def = def;
-		st_type = t;
-		st_pos = p;
+		ttype : tclass;
 	}
 
 	let mk_const ctx p = function
@@ -1555,252 +1555,92 @@ module PatternMatchConversion = struct
 		| TNull -> mk (TConst TNull) (ctx.com.basic.tnull (mk_mono())) p
 		| _ -> error "Unsupported constant" p
 
-	let rec st_to_unique_name ctx st = match st.st_def with
-		| SField(st,f) -> st_to_unique_name ctx st ^ "_f" ^ f
-		| SArray(st,i) -> st_to_unique_name ctx st ^ "_a" ^ (string_of_int i)
-		| SEnum(st,n,i) -> st_to_unique_name ctx st ^ "_e" ^ n ^ "_" ^ (string_of_int i)
-		| SVar v -> v.v_name
-		| STuple (st,_,_) -> st_to_unique_name ctx st
-
-	let rec st_to_texpr cctx st = match st.st_def with
+	let rec convert_st cctx st = match st.st_def with
 		| SVar v -> mk (TLocal v) v.v_type st.st_pos
 		| SField (sts,f) ->
-			let e = st_to_texpr cctx sts in
+			let e = convert_st cctx sts in
 			let fa = try quick_field e.etype f with Not_found -> FDynamic f in
 			mk (TField(e,fa)) st.st_type st.st_pos
-		| SArray (sts,i) -> mk (TArray(st_to_texpr cctx sts,mk_const cctx.ctx st.st_pos (TInt (Int32.of_int i)))) st.st_type st.st_pos
-		| STuple (st,_,_) -> st_to_texpr cctx st
-		| SEnum _ ->
-			let n = st_to_unique_name cctx st in
-			let v = try	Hashtbl.find cctx.v_lookup n with Not_found ->
-				let v = alloc_var n st.st_type in
-				Hashtbl.add cctx.v_lookup n v;
-				v
-			in
-			cctx.ctx.locals <- PMap.add n v cctx.ctx.locals;
-			mk (TLocal v) v.v_type st.st_pos
-
-	let rec st_eq st1 st2 = match st1.st_def,st2.st_def with
-		| STuple (st1,i1,_), STuple(st2,i2,_) -> i1 = i2 && st_eq st1 st2
-		| SEnum(st1,_,i1), SEnum(st2,_,i2) -> i1 = i2 && st_eq st1 st2
-		| SField(st1,f1),SField(st2,f2) -> f1 = f2 && st_eq st1 st2
-		| SArray(st1,i1),SArray(st2,i2) -> i1 = i1 && st_eq st1 st2
-		| SVar _, SVar _ -> true
-		| _ -> false
-
-	let replace_locals cctx e =
+		| SArray (sts,i) -> mk (TArray(convert_st cctx sts,mk_const cctx.ctx st.st_pos (TInt (Int32.of_int i)))) st.st_type st.st_pos
+		| STuple (st,_,_) -> convert_st cctx st
+		| SEnum(st,_,i) ->
+			let cf = PMap.find "enumParameters" cctx.ttype.cl_statics in
+			let ec = mk (TTypeExpr (TClassDecl cctx.ttype)) t_dynamic st.st_pos in
+			let ef = mk (TField(ec, FStatic(cctx.ttype,cf))) (tfun [st.st_type] (cctx.ctx.t.tarray t_dynamic)) st.st_pos in
+			let ec = mk (TCall (ef,[convert_st cctx st])) t_dynamic st.st_pos in
+			mk (TArray (ec,mk (TConst(TInt (Int32.of_int i))) cctx.ctx.t.tint st.st_pos)) t_dynamic st.st_pos
+
+	let convert_con cctx con = match con.c_def with
+		| CConst c -> mk_const cctx.ctx con.c_pos c
+		| CType mt -> mk (TTypeExpr mt) t_dynamic con.c_pos
+		| CExpr e -> e
+		| CEnum(e,ef) -> mk_const cctx.ctx con.c_pos (TInt (Int32.of_int ef.ef_index))
+		| CArray i -> mk_const cctx.ctx con.c_pos (TInt (Int32.of_int i))
+		| CAny -> assert false
+		| CFields _ -> assert false
+
+	let replace_locals stack f e =
 		let replace v =
 			let rec loop vl = match vl with
 				| vl :: vll -> (try snd (List.find (fun ((v2,_),st) -> v2 == v) vl) with Not_found -> loop vll)
 				| [] -> raise Not_found
 			in
-			loop cctx.eval_stack
+			loop stack
 		in
 		let rec loop e = match e.eexpr with
-			| TLocal v ->
-				(try
-					let st = replace v in
-					unify cctx.ctx e.etype st.st_type e.epos;
-					st_to_texpr cctx st
-				with Not_found ->
-					e)
-			| _ ->
-				Type.map_expr loop e
+			| TLocal v -> (try f (replace v) with Not_found -> e)
+			| _ -> Type.map_expr loop e
 		in
 		loop e
 
-	let rec to_typed_ast cctx dt =
+	let rec convert_dt cctx dt =
 		match dt with
-		| Goto i ->
-			to_typed_ast cctx (cctx.dt_lookup.(i))
-		| Expr e -> replace_locals cctx e
-		| Guard (e,dt1,dt2) ->
-			let e = replace_locals cctx e in
-			begin match dt2 with
-			| None -> mk (TIf(e,to_typed_ast cctx dt1,None)) t_dynamic e.epos
-			| Some dt ->
-				let eelse = to_typed_ast cctx dt in
-				mk (TIf(e,to_typed_ast cctx dt1,Some eelse)) eelse.etype (punion e.epos eelse.epos)
-			end
-		| Bind (bl, dt) ->
-			List.iter (fun ((v,_),st) ->
-				let e = st_to_texpr cctx st in
-				begin match e.eexpr with
-					| TLocal v2 -> v2.v_name <- v.v_name
-					| _ -> ()
-				end;
-			) bl;
+		| Bind (bl,dt) ->
 			cctx.eval_stack <- bl :: cctx.eval_stack;
-			let e = to_typed_ast cctx dt in
+			let e = convert_dt cctx dt in
 			cctx.eval_stack <- List.tl cctx.eval_stack;
 			e
-		| Switch(st,cases) ->
-			(* separate null-patterns: these are placed in an initial if (st == null) check to avoid null access issues *)
-			let null,cases = List.partition (fun (c,_) -> match c.c_def with CConst(TNull) -> true | _ -> false) cases in
-			let e = match follow st.st_type with
-			| TEnum(en,pl) | TAbstract({a_this = TEnum(en,_)},pl) -> to_enum_switch cctx en pl st cases
-			| TInst({cl_path = [],"Array"},[t]) -> to_array_switch cctx t st cases
-			| TAnon a -> to_structure_switch cctx a st cases
-			| t -> to_value_switch cctx t st cases
-			in
-			match null with
-			| [] -> e
-			| [_,dt] ->
-				let eval = st_to_texpr cctx st in
-				let ethen = to_typed_ast cctx dt in
-				let eif = mk (TBinop(OpEq,(mk (TConst TNull) st.st_type st.st_pos),eval)) cctx.ctx.t.tbool ethen.epos in
-				mk (TIf(eif,ethen,Some e)) ethen.etype ethen.epos
-			| _ ->
-				assert false
-
-	and group_cases cctx cases to_case =
-		let def = ref None in
-		let group,cases,dto = List.fold_left (fun (group,cases,dto) (con,dt) -> match con.c_def with
-			| CAny ->
-				let e = to_typed_ast cctx dt in
-				def := Some e;
-				(group,cases,dto)
-			| _ -> match dto with
-				| None -> ([to_case con],cases,Some dt)
-				| Some dt2 -> match dt,dt2 with
-					| Expr e1, Expr e2 when e1 == e2 ->
-						((to_case con) :: group,cases,dto)
-					| _ ->
-						let e = to_typed_ast cctx dt2 in
-						([to_case con],(List.rev group,e) :: cases, Some dt)
-		) ([],[],None) cases in
-		let cases = List.rev (match group,dto with
-			| [],None ->
-				cases
-			| group,Some dt ->
-				let e = to_typed_ast cctx dt in
-				(List.rev group,e) :: cases
-			| _ ->
-				assert false
-		) in
-		cases,def
-
-	and to_enum_switch cctx en pl st cases =
-		let eval = st_to_texpr cctx st in
-		let to_case con = match con.c_def with
-			| CEnum(en,ef) -> en,ef
-			| _ ->
-				error ("Unexpected") con.c_pos
-		in
-		let type_case group dt p =
-			let group = List.rev group in
-			let en,ef = List.hd group in
-			let save = save_locals cctx.ctx in
-			let etf = follow (monomorphs en.e_types (monomorphs ef.ef_params ef.ef_type)) in
-			(* TODO: this is horrible !!! *)
-			let capture_vars = match dt with
-				| Expr _ ->
-					let vl = PMap.foldi (fun k v acc -> (k,v) :: acc) (List.fold_left (fun acc vl -> List.fold_left (fun acc (v,st) -> if PMap.mem v acc then acc else PMap.add v st acc) acc vl) PMap.empty cctx.eval_stack) [] in
-					Some vl
+		| Goto i ->
+			convert_dt cctx (cctx.dt_lookup.(i))
+		| Expr e ->
+			replace_locals cctx.eval_stack (convert_st cctx) e
+		| Guard(e,dt1,dt2) ->
+			let ethen = convert_dt cctx dt1 in
+			mk (TIf(replace_locals cctx.eval_stack (convert_st cctx) e,ethen,match dt2 with None -> None | Some dt -> Some (convert_dt cctx dt))) ethen.etype (punion e.epos ethen.epos)
+		| Switch(st,cl) ->
+			let e_subject = convert_st cctx st in
+			let e_subject,exh = match follow st.st_type with
+				| TEnum(_) ->
+					let cf = PMap.find "enumIndex" cctx.ttype.cl_statics in
+					let ec = mk (TTypeExpr (TClassDecl cctx.ttype)) t_dynamic st.st_pos in
+					let ef = mk (TField(ec, FStatic(cctx.ttype,cf))) (tfun [t_dynamic] cctx.ctx.t.tint) st.st_pos in
+					mk (TCall (ef,[e_subject])) cctx.ctx.t.tint st.st_pos,true
+				| TInst({cl_path = [],"Array"},_) ->
+					mk (TField (e_subject,FDynamic "length")) cctx.ctx.t.tint st.st_pos,false
 				| _ ->
-					None
+					e_subject,false
 			in
-			let vl = match etf with
-				| TFun(args,r) ->
-					let vl = ExtList.List.mapi (fun i (_,_,t) ->
-						let st = mk_st (SEnum(st,ef.ef_name,i)) t st.st_pos in
-						let mk_e () = Some (match (st_to_texpr cctx st).eexpr with TLocal v -> v | _ -> assert false) in
-						begin match capture_vars with
-							| Some cvl ->
-								let rec check st2 = st_eq st st2 || match st2.st_def with
-									| SEnum(st,_,_) | SArray(st,_) | STuple(st,_,_) | SField(st,_) -> check st
-									| SVar _ -> false
-								in
-								let rec loop cvl = match cvl with
-									| [] -> None
-									| (_,st2) :: cvl ->
-										if check st2 then mk_e() else loop cvl
-								in
-								loop cvl
-							| _ ->
-								mk_e()
-						end
-					) args in
-					if List.exists (fun e -> e <> None) vl then (Some vl) else None
-				| _ -> None
-			in
-			let e = to_typed_ast cctx dt in
-			save();
-			(List.map (fun (_,ef) -> ef.ef_index) group),vl,e
-		in
-		let def = ref None in
-		let group,cases,dto = List.fold_left (fun (group,cases,dto) (con,dt) -> match con.c_def with
-			| CAny ->
-				let e = to_typed_ast cctx dt in
-				def := Some e;
-				(group,cases,dto)
-			| _ -> match dto with
-				| None -> ([to_case con],cases,Some dt)
-				| Some dt2 -> match dt,dt2 with
-					| Expr e1,Expr e2 when e1 == e2 ->
-						((to_case con) :: group,cases,dto)
-					| _ ->
-						let g = type_case group dt2 con.c_pos in
-						([to_case con],g :: cases, Some dt)
-		) ([],[],None) cases in
-		let cases = List.rev (match group,dto with
-			| [],None ->
-				cases
-			| group,Some dt ->
-				let g = type_case group dt eval.epos in
-				g :: cases
-			| _ ->
-				assert false
-		) in
-		mk (TMatch(eval,(en,pl),cases,!def)) cctx.out_type eval.epos
-
-	and to_value_switch cctx t st cases =
-		let eval = st_to_texpr cctx st in
-		let to_case con = match con.c_def with
-			| CConst c ->
-				mk_const cctx.ctx con.c_pos c
-			| CType mt ->
-				(!type_module_type_ref) cctx.ctx mt None con.c_pos
-			| CExpr e ->
-				e
-			| _ ->
-				error ("Unexpected "  ^ (s_con con)) con.c_pos
-		in
-		let cases,def = group_cases cctx cases to_case in
-		mk (TSwitch(eval,cases,!def)) cctx.out_type eval.epos
-
-	and to_structure_switch cctx t st cases =
-		match cases with
-		| ({c_def = CFields _},dt) :: cl ->
-			to_typed_ast cctx dt
-		| ({c_def = CAny},dt) :: [] ->
-			to_typed_ast cctx dt;
-		| _ ->
-			assert false
-
-	and to_array_switch cctx t st cases =
-		let to_case con = match con.c_def with
-			| CArray i ->
-				mk_const cctx.ctx con.c_pos (TInt (Int32.of_int i))
-			| _ ->
-				error ("Unexpected "  ^ (s_con con)) con.c_pos
-		in
-		let cases,def = group_cases cctx cases to_case in
-		let eval = st_to_texpr cctx st in
-		let eval = mk (TField(eval,quick_field eval.etype "length")) cctx.ctx.com.basic.tint st.st_pos in
-		mk (TSwitch(eval,cases,!def)) cctx.out_type eval.epos
+			let def = ref None in
+			let cases = ExtList.List.filter_map (fun (con,dt) ->
+				match con.c_def with
+				| CAny ->
+					def := Some (convert_dt cctx dt);
+					None
+				| _ ->
+					Some ([convert_con cctx con],convert_dt cctx dt)
+			) cl in
+			let e_subject = if exh then mk (TMeta((Meta.Exhaustive,[],st.st_pos), e_subject)) e_subject.etype e_subject.epos else e_subject in
+			mk (TSwitch(e_subject,cases,!def)) (mk_mono()) (st.st_pos)
 
 	let to_typed_ast ctx dt p =
 		let first = dt.dt_dt_lookup.(dt.dt_first) in
 		let cctx = {
 			ctx = ctx;
-			out_type = mk_mono();
-			v_lookup = Hashtbl.create 0;
-			eval_stack = [];
 			dt_lookup = dt.dt_dt_lookup;
+			eval_stack = [];
+			ttype = match follow (Typeload.load_instance ctx { tpackage = ["std"]; tname="Type"; tparams=[]; tsub = None} p true) with TInst(c,_) -> c | t -> assert false;
 		} in
-		(* generate typed AST from decision tree *)
-		let e = to_typed_ast cctx first in
+		let e = convert_dt cctx first in
 		let e = { e with epos = p; etype = dt.dt_type} in
 		if dt.dt_var_init = [] then
 			e

common.ml

@@ -313,6 +313,7 @@ module MetaInfo = struct
 		| DynamicObject -> ":dynamicObject",("Used internally to identify the Dynamic Object implementation",[Platforms [Java;Cs]; UsedOn TClass; Internal])
 		| Enum -> ":enum",("Used internally to annotate a class that was generated from an enum",[Platforms [Java;Cs]; UsedOn TClass; Internal])
 		| EnumConstructorParam -> ":enumConstructorParam",("Used internally to annotate GADT type parameters",[UsedOn TClass; Internal])
+		| Exhaustive -> ":exhaustive",("",[Internal])
 		| Expose -> ":expose",("Makes the class available on the window object",[HasParam "?Name=Class path";UsedOn TClass;Platform Js])
 		| Extern -> ":extern",("Marks the field as extern so it is not generated",[UsedOn TClassField])
 		| FakeEnum -> ":fakeEnum",("Treat enum as collection of values of the specified type",[HasParam "Type name";UsedOn TEnum])