add TPatMatch node, factor out AST conversion

codegen.ml

@@ -1531,6 +1531,290 @@ module Abstract = struct
 	let handle_abstract_casts ctx e =
 		loop ctx e
 end
+
+module PatternMatchConversion = struct
+	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;
+	}
+
+	let mk_const ctx p = function
+		| TString s -> mk (TConst (TString s)) ctx.com.basic.tstring p
+		| TInt i -> mk (TConst (TInt i)) ctx.com.basic.tint p
+		| TFloat f -> mk (TConst (TFloat f)) ctx.com.basic.tfloat p
+		| TBool b -> mk (TConst (TBool b)) ctx.com.basic.tbool p
+		| 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
+		| SVar v -> mk (TLocal v) v.v_type st.st_pos
+		| SField (sts,f) ->
+			let e = st_to_texpr 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 =
+		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
+		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
+		in
+		loop e
+
+	let rec to_typed_ast cctx dt =
+		match dt with
+		| Goto i ->
+			to_typed_ast cctx (cctx.dt_lookup.(i))
+		| Out(e,eo,dt) ->
+			replace_locals cctx begin match eo,dt with
+				| Some eg,None ->
+					mk (TIf(eg,e,None)) t_dynamic e.epos
+				| Some eg,Some dt ->
+					let eelse = to_typed_ast cctx dt in
+					mk (TIf(eg,e,Some eelse)) eelse.etype (punion e.epos eelse.epos)
+				| _,None ->
+					e
+				| _ -> assert false
+			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;
+			cctx.eval_stack <- bl :: cctx.eval_stack;
+			let e = to_typed_ast 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
+					| Out(e1,eg,_),Out(e2,_,_) when e1 == e2 && eg = None ->
+						((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
+				| Out(_,_,None) ->
+					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
+				| _ ->
+					None
+			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
+					| Out(e1,eg,_),Out(e2,_,_) when e1 == e2 && eg = None ->
+						((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 ->
+				(* Typer.type_module_type cctx.ctx mt None con.c_pos *)
+				assert false
+			| 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 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;
+		} in
+		(* generate typed AST from decision tree *)
+		let e = to_typed_ast cctx first in
+		let e = { e with epos = p; etype = dt.dt_type} in
+		if dt.dt_var_init = [] then
+			e
+		else begin
+			mk (TBlock [
+				mk (TVars dt.dt_var_init) t_dynamic e.epos;
+				e;
+			]) dt.dt_type e.epos
+		end			
+end
+
 (* -------------------------------------------------------------------------- *)
 (* USAGE *)
 
@@ -1854,7 +2138,7 @@ let rec constructor_side_effects e =
 		true
 	| TField (_,FEnum _) ->
 		false
-	| TUnop _ | TArray _ | TField _ | TCall _ | TNew _ | TFor _ | TWhile _ | TSwitch _ | TMatch _ | TReturn _ | TThrow _ ->
+	| TUnop _ | TArray _ | TField _ | TCall _ | TNew _ | TFor _ | TWhile _ | TSwitch _ | TMatch _ | TPatMatch _ | TReturn _ | TThrow _ ->
 		true
 	| TBinop _ | TTry _ | TIf _ | TBlock _ | TVars _
 	| TFunction _ | TArrayDecl _ | TObjectDecl _

genas3.ml

@@ -766,6 +766,7 @@ and gen_expr ctx e =
 		bend();
 		newline ctx;
 		spr ctx "}";
+	| TPatMatch dt -> assert false
 	| TSwitch (e,cases,def) ->
 		spr ctx "switch";
 		gen_value ctx (parent e);
@@ -934,6 +935,7 @@ and gen_value ctx e =
 			match def with None -> None | Some e -> Some (assign e)
 		)) e.etype e.epos);
 		v()
+	| TPatMatch dt -> assert false
 	| TTry (b,catchs) ->
 		let v = value true in
 		gen_expr ctx (mk (TTry (block (assign b),

gencommon.ml

@@ -110,7 +110,7 @@ struct
   let mk_heexpr = function
     | TConst _ -> 0 | TLocal _ -> 1 | TArray _ -> 3 | TBinop _ -> 4 | TField _ -> 5 | TTypeExpr _ -> 7 | TParenthesis _ -> 8 | TObjectDecl _ -> 9
     | TArrayDecl _ -> 10 | TCall _ -> 11 | TNew _ -> 12 | TUnop _ -> 13 | TFunction _ -> 14 | TVars _ -> 15 | TBlock _ -> 16 | TFor _ -> 17 | TIf _ -> 18 | TWhile _ -> 19
-    | TSwitch _ -> 20 | TMatch _ -> 21 | TTry _ -> 22 | TReturn _ -> 23 | TBreak -> 24 | TContinue -> 25 | TThrow _ -> 26 | TCast _ -> 27 | TMeta _ -> 28
+    | TSwitch _ -> 20 | TMatch _ -> 21 | TTry _ -> 22 | TReturn _ -> 23 | TBreak -> 24 | TContinue -> 25 | TThrow _ -> 26 | TCast _ -> 27 | TMeta _ -> 28 | TPatMatch _ -> 29
 
   let mk_heetype = function
     | TMono _ -> 0 | TEnum _ -> 1 | TInst _ -> 2 | TType _ -> 3 | TFun _ -> 4
@@ -4670,6 +4670,7 @@ struct
       | TWhile _
       | TSwitch _
       | TMatch _
+      | TPatMatch _
       | TTry _
       | TReturn _
       | TBreak

gencpp.ml

@@ -794,6 +794,7 @@ let rec iter_retval f retval e =
 		f true e;
 		List.iter (fun (_,_,e) -> f false e) cases;
 		(match def with None -> () | Some e -> f false e)
+	| TPatMatch dt -> assert false
 	| TTry (e,catches) ->
 		f retval e;
 		List.iter (fun (_,e) -> f false e) catches
@@ -1881,6 +1882,7 @@ and gen_expression ctx retval expression =
 	| TSwitch (_,_,_)
 	| TMatch (_, _, _, _) when (retval && (not return_from_internal_node) )->
       gen_local_block_call()
+    | TPatMatch dt -> assert false
 	| TSwitch (condition,cases,optional_default)  ->
 		let switch_on_int_constants = (only_int_cases cases) && (not (contains_break expression)) in
 		if (switch_on_int_constants) then begin

gencs.ml

@@ -1264,6 +1264,7 @@ let configure gen =
         | TObjectDecl _ -> write w "[ obj decl not supported ]"; if !strict_mode then assert false
         | TFunction _ -> write w "[ func decl not supported ]"; if !strict_mode then assert false
         | TMatch _ -> write w "[ match not supported ]"; if !strict_mode then assert false
+        | TPatMatch dt -> assert false
     )
     and do_call w e el =
       let params, el = extract_tparams [] el in

genjava.ml

@@ -1391,6 +1391,7 @@ let configure gen =
         | TObjectDecl _ -> write w "[ obj decl not supported ]"; if !strict_mode then assert false
         | TFunction _ -> write w "[ func decl not supported ]"; if !strict_mode then assert false
         | TMatch _ -> write w "[ match not supported ]"; if !strict_mode then assert false
+        | TPatMatch dt -> assert false
     in
     expr_s w e
   in

genjs.ml

@@ -690,6 +690,7 @@ and gen_expr ctx e =
 		);
 		newline ctx;
 		spr ctx "}"
+	| TPatMatch dt -> assert false
 	| TSwitch (e,cases,def) ->
 		spr ctx "switch";
 		gen_value ctx e;
@@ -861,6 +862,7 @@ and gen_value ctx e =
 			match def with None -> None | Some e -> Some (assign e)
 		)) e.etype e.epos);
 		v()
+	| TPatMatch dt -> assert false
 	| TTry (b,catchs) ->
 		let v = value() in
 		let block e = mk (TBlock [e]) e.etype e.epos in

genneko.ml

@@ -419,6 +419,7 @@ and gen_expr ctx e =
 					) (match eo with None -> null p | Some e -> (gen_expr ctx e)) (List.rev cases)
 				],p)
 		)
+	| TPatMatch dt -> assert false
 	| TSwitch (e,cases,eo) ->
 		let e = gen_expr ctx e in
 		let eo = (match eo with None -> None | Some e -> Some (gen_expr ctx e)) in

genphp.ml

@@ -1631,6 +1631,7 @@ and gen_expr ctx e =
 		ctx.in_loop <- old_loop;
 		spr ctx "}";
 		b()
+	| TPatMatch dt -> assert false
 	| TSwitch (e,cases,def) ->
 		let old_loop = ctx.in_loop in
 		ctx.in_loop <- false;
@@ -1820,6 +1821,7 @@ and gen_value ctx e =
 	| TSwitch _
 	| TFor _
 	| TMatch _
+	| TPatMatch _
 	| TIf _
 	| TTry _ ->
 		inline_block ctx e

genswf8.ml

@@ -1166,6 +1166,7 @@ and gen_expr_2 ctx retval e =
 		gen_expr ctx retval (Codegen.default_cast ctx.com e1 t e.etype e.epos)
 	| TMatch (e,_,cases,def) ->
 		gen_match ctx retval e cases def
+	| TPatMatch dt -> assert false
 	| TFor (v,it,e) ->
 		gen_expr ctx true it;
 		let r = alloc_tmp ctx in

genswf9.ml

@@ -1325,6 +1325,7 @@ let rec gen_expr_content ctx retval e =
 		switch();
 		List.iter (fun j -> j()) jends;
 		free_reg ctx rparams
+	| TPatMatch dt -> assert false
 	| TCast (e1,t) ->
 		gen_expr ctx retval e1;
 		if retval then begin

interp.ml

@@ -4518,6 +4518,7 @@ let rec make_ast e =
 		in
 		let def = match eopt def with None -> None | Some (EBlock [],_) -> Some None | e -> Some e in
 		ESwitch (make_ast e,List.map scases cases,def)
+	| TPatMatch dt -> assert false
 	| TTry (e,catches) -> ETry (make_ast e,List.map (fun (v,e) -> v.v_name, (try make_type v.v_type with Exit -> assert false), make_ast e) catches)
 	| TReturn e -> EReturn (eopt e)
 	| TBreak -> EBreak

matcher.ml

@@ -166,21 +166,6 @@ let get_tuple_types t = match t with
 
 let s_type = s_type (print_context())
 
-let rec s_expr_small e = match e.eexpr with
-	| TLocal v -> v.v_name
-	| TField (e,s) -> s_expr_small e ^ "." ^ field_name s
-	| TBlock [] -> "{}"
-	| _ -> s_expr (s_type) e
-
-let s_con con = match con.c_def with
-	| CEnum(_,ef) -> ef.ef_name
-	| CAny -> "_"
-	| CConst c -> s_const c
-	| CType mt -> s_type_path (t_path mt)
-	| CArray i -> "[" ^(string_of_int i) ^ "]"
-	| CFields (_,fl) -> String.concat "," (List.map (fun (s,_) -> s) fl)
-	| CExpr e -> s_expr s_type e
-
 let rec s_pat pat = match pat.p_def with
 	| PVar (v,_) -> v.v_name
 	| PCon (c,[]) -> s_con c
@@ -190,42 +175,11 @@ let rec s_pat pat = match pat.p_def with
 	| PBind((v,_),pat) -> v.v_name ^ "=" ^ s_pat pat
 	| PTuple pl -> "(" ^ (String.concat " " (Array.to_list (Array.map s_pat pl))) ^ ")"
 
-let st_args l r v =
-	(if l > 0 then (String.concat "," (ExtList.List.make l "_")) ^ "," else "")
-	^ v ^
-	(if r > 0 then "," ^ (String.concat "," (ExtList.List.make r "_")) else "")
-
-let rec s_st st = (match st.st_def with
-	| SVar v -> v.v_name
-	| SEnum (st,n,i) -> s_st st ^ "." ^ n ^ "." ^ (string_of_int i)
-	| SArray (st,i) -> s_st st ^ "[" ^ (string_of_int i) ^ "]"
-	| STuple (st,i,a) -> "(" ^ (st_args i (a - i - 1) (s_st st)) ^ ")"
-	| SField (st,n) -> s_st st ^ "." ^ n)
-	(* ^ ":" ^ (s_type st.st_type) *)
-
 let rec s_pat_vec pl =
 	String.concat " " (Array.to_list (Array.map s_pat pl))
 
-let s_out out = ""
-	(* ^ s_expr_small out.o_expr *)
-
 let rec s_pat_matrix pmat =
-	String.concat "\n" (List.map (fun (pl,out) -> (s_pat_vec pl) ^ "->" ^ (s_out out)) pmat)
-
-let rec s_dt tabs tree = tabs ^ match tree with
-	| Out(e,eo,None)->
-		s_expr_small e
-	| Out(e,eo,Some dt) ->
-		"if (" ^ (s_expr_small (match eo with Some e -> e | None -> assert false)) ^ ") " ^ (s_expr_small e) ^ " else " ^ s_dt tabs dt
-	| Switch (st, cl) ->
-		"switch(" ^ (s_st st) ^ ") { \n" ^ tabs
-		^ (String.concat ("\n" ^ tabs) (List.map (fun (c,dt) ->
-			"case " ^ (s_con c) ^ ":\n" ^ (s_dt (tabs ^ "\t") dt)
-		) cl))
-		^ "\n" ^ (if String.length tabs = 0 then "" else (String.sub tabs 0 (String.length tabs - 1))) ^ "}"
-	| Bind (bl, dt) -> "bind " ^ (String.concat "," (List.map (fun ((v,_),st) -> v.v_name ^ "(" ^ (string_of_int v.v_id) ^ ") =" ^ (s_st st)) bl)) ^ "\n" ^ (s_dt tabs dt)
-	| Goto i ->
-		"goto " ^ (string_of_int i)
+	String.concat "\n" (List.map (fun (pl,out) -> (s_pat_vec pl) ^ "->" ^ "") pmat)
 
 (* Pattern parsing *)
 
@@ -861,7 +815,7 @@ let rec collapse_case el = match el with
 
 (* Decision tree compilation *)
 
-let make_dt ctx e cases def with_type p =
+let match_expr ctx e cases def with_type p =
 	let need_val,with_type,tmono = match with_type with
 		| NoValue -> false,NoValue,None
 		| WithType t | WithTypeResume t when (match follow t with TMono _ -> true | _ -> false) ->
@@ -1074,291 +1028,13 @@ let make_dt ctx e cases def with_type p =
 		| Some (WithTypeResume t2) -> (try unify_raise ctx t2 t p with Error (Unify l,p) -> raise (Typer.WithTypeError (l,p)))
 		| _ -> assert false
 	end;
-	{
+	let dt = {
 		dt_first = (match dt with Goto i -> i | _ -> Hashtbl.find mctx.dt_cache dt);
 		dt_dt_lookup = DynArray.to_array mctx.dt_lut;
 		dt_type = t;
 		dt_var_init = List.rev !var_inits;
-	}
-
-(* Conversion to Typed AST *)
-
-type cctx = {
-	ctx : typer;
-	v_lookup : (string,tvar) Hashtbl.t;
-	out_type : t;
-	mutable eval_stack : (pvar * st) list list;
-	dt_lookup : dt array;
-}
-
-let mk_const ctx p = function
-	| TString s -> mk (TConst (TString s)) ctx.com.basic.tstring p
-	| TInt i -> mk (TConst (TInt i)) ctx.com.basic.tint p
-	| TFloat f -> mk (TConst (TFloat f)) ctx.com.basic.tfloat p
-	| TBool b -> mk (TConst (TBool b)) ctx.com.basic.tbool p
-	| 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
-	| SVar v -> mk (TLocal v) v.v_type st.st_pos
-	| SField (sts,f) ->
-		let e = st_to_texpr 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 =
-	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
-	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
-	in
-	loop e
-
-let rec to_typed_ast cctx dt =
-	match dt with
-	| Goto i ->
-		to_typed_ast cctx (cctx.dt_lookup.(i))
-	| Out(e,eo,dt) ->
-		replace_locals cctx begin match eo,dt with
-			| Some eg,None ->
-				mk (TIf(eg,e,None)) t_dynamic e.epos
-			| Some eg,Some dt ->
-				let eelse = to_typed_ast cctx dt in
-				mk (TIf(eg,e,Some eelse)) eelse.etype (punion e.epos eelse.epos)
-			| _,None ->
-				e
-			| _ -> assert false
-		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;
-		cctx.eval_stack <- bl :: cctx.eval_stack;
-		let e = to_typed_ast 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
-				| Out(e1,eg,_),Out(e2,_,_) when e1 == e2 && eg = None ->
-					((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
-			| Out(_,_,None) ->
-				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
-			| _ ->
-				None
-		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
-				| Out(e1,eg,_),Out(e2,_,_) when e1 == e2 && eg = None ->
-					((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 ->
-			Typer.type_module_type 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
-
-(* Main *)
-
-let match_expr ctx e cases def with_type p =
-	let dt = make_dt ctx e cases def with_type p in
-	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;
 	} in
-	(* generate typed AST from decision tree *)
-	let e = to_typed_ast cctx first in
-	let e = { e with epos = p; etype = dt.dt_type} in
-	if dt.dt_var_init = [] then
-		e
-	else begin
-		mk (TBlock [
-			mk (TVars dt.dt_var_init) t_dynamic e.epos;
-			e;
-		]) dt.dt_type e.epos
-	end
+	mk (TPatMatch dt) t p
 ;;
 match_expr_ref := match_expr;
 get_pattern_locals_ref := get_pattern_locals

optimizer.ml

@@ -32,7 +32,7 @@ let has_side_effect e =
 	let rec loop e =
 		match e.eexpr with
 		| TConst _ | TLocal _ | TField (_,FEnum _) | TTypeExpr _ | TFunction _ -> ()
-		| TMatch _ | TNew _ | TCall _ | TField _ | TArray _ | TBinop ((OpAssignOp _ | OpAssign),_,_) | TUnop ((Increment|Decrement),_,_) -> raise Exit
+		| TMatch _ | TPatMatch _ | TNew _ | TCall _ | TField _ | TArray _ | TBinop ((OpAssignOp _ | OpAssign),_,_) | TUnop ((Increment|Decrement),_,_) -> raise Exit
 		| TReturn _ | TBreak | TContinue | TThrow _ | TCast (_,Some _) -> raise Exit
 		| TCast (_,None) | TBinop _ | TUnop _ | TParenthesis _ | TMeta _ | TWhile _ | TFor _ | TIf _ | TTry _ | TSwitch _ | TArrayDecl _ | TVars _ | TBlock _ | TObjectDecl _ -> Type.iter loop e
 	in
@@ -602,7 +602,7 @@ let rec need_parent e =
 	match e.eexpr with
 	| TConst _ | TLocal _ | TArray _ | TField _ | TParenthesis _ | TMeta _ | TCall _ | TNew _ | TTypeExpr _ | TObjectDecl _ | TArrayDecl _ -> false
 	| TCast (e,None) -> need_parent e
-	| TCast _ | TThrow _ | TReturn _ | TTry _ | TMatch _ | TSwitch _ | TFor _ | TIf _ | TWhile _ | TBinop _ | TContinue | TBreak
+	| TCast _ | TThrow _ | TReturn _ | TTry _ | TMatch _ | TPatMatch _ | TSwitch _ | TFor _ | TIf _ | TWhile _ | TBinop _ | TContinue | TBreak
 	| TBlock _ | TVars _ | TFunction _ | TUnop _ -> true
 
 let rec add_final_return e t =

type.ml

@@ -120,6 +120,7 @@ and texpr_expr =
 	| TWhile of texpr * texpr * Ast.while_flag
 	| TSwitch of texpr * (texpr list * texpr) list * texpr option
 	| TMatch of texpr * (tenum * tparams) * (int list * tvar option list option * texpr) list * texpr option
+	| TPatMatch of decision_tree
 	| TTry of texpr * (tvar * texpr) list
 	| TReturn of texpr option
 	| TBreak
@@ -1356,6 +1357,17 @@ let iter f e =
 		f e;
 		List.iter (fun (_,_,e) -> f e) cases;
 		(match def with None -> () | Some e -> f e)
+	| TPatMatch dt ->
+		let rec loop dt = match dt with
+			| Out(e,eo,dt) ->
+				f e;
+				(match eo with None -> () | Some e -> f e);
+				(match dt with None -> () | Some dt -> loop dt);
+			| Bind(_,dt) -> loop dt
+			| Goto _ -> ()
+			| Switch(_,cl) -> List.iter (fun (_,dt) -> loop dt) cl
+		in
+		Array.iter loop dt.dt_dt_lookup
 	| TTry (e,catches) ->
 		f e;
 		List.iter (fun (_,e) -> f e) catches
@@ -1406,6 +1418,15 @@ let map_expr f e =
 		{ e with eexpr = TSwitch (f e1, List.map (fun (el,e2) -> List.map f el, f e2) cases, match def with None -> None | Some e -> Some (f e)) }
 	| TMatch (e1,t,cases,def) ->
 		{ e with eexpr = TMatch (f e1, t, List.map (fun (cl,params,e) -> cl, params, f e) cases, match def with None -> None | Some e -> Some (f e)) }
+	| TPatMatch dt ->
+		let rec loop dt = match dt with
+			| Out(e,eo,dt) ->
+				Out(f e, (match eo with None -> None | Some e -> Some (f e)), (match dt with None -> None | Some dt -> Some (loop dt)));
+			| Bind(vl,dt) -> Bind(vl, loop dt)
+			| Goto _ -> dt
+			| Switch(st,cl) -> Switch(st, List.map (fun (c,dt) -> c,loop dt) cl)
+		in
+		{ e with eexpr = TPatMatch({dt with dt_dt_lookup = Array.map loop dt.dt_dt_lookup})}		
 	| TTry (e1,catches) ->
 		{ e with eexpr = TTry (f e1, List.map (fun (v,e) -> v, f e) catches) }
 	| TReturn eo ->
@@ -1475,6 +1496,15 @@ let map_expr_type f ft fv e =
 			cl, params, f e
 		in
 		{ e with eexpr = TMatch (f e1, (en,List.map ft pl), List.map map_case cases, match def with None -> None | Some e -> Some (f e)); etype = ft e.etype }
+	| TPatMatch dt ->
+		let rec loop dt = match dt with
+			| Out(e,eo,dt) ->
+				Out(f e, (match eo with None -> None | Some e -> Some (f e)), (match dt with None -> None | Some dt -> Some (loop dt)));
+			| Bind(vl,dt) -> Bind(vl, loop dt)
+			| Goto _ -> dt
+			| Switch(st,cl) -> Switch(st, List.map (fun (c,dt) -> c,loop dt) cl)
+		in
+		{ e with eexpr = TPatMatch({dt with dt_dt_lookup = Array.map loop dt.dt_dt_lookup}); etype = ft e.etype}		
 	| TTry (e1,catches) ->
 		{ e with eexpr = TTry (f e1, List.map (fun (v,e) -> fv v, f e) catches); etype = ft e.etype }
 	| TReturn eo ->
@@ -1506,6 +1536,7 @@ let s_expr_kind e =
 	| TWhile (_,_,_) -> "While"
 	| TSwitch (_,_,_) -> "Switch"
 	| TMatch (_,_,_,_) -> "Match"
+	| TPatMatch _ -> "PatMatch"
 	| TTry (_,_) -> "Try"
 	| TReturn _ -> "Return"
 	| TBreak -> "Break"
@@ -1523,7 +1554,46 @@ let s_const = function
 	| TThis -> "this"
 	| TSuper -> "super"
 
-let rec s_expr s_type e =
+let rec s_con con = match con.c_def with
+	| CEnum(_,ef) -> ef.ef_name
+	| CAny -> "_"
+	| CConst c -> s_const c
+	| CType mt -> s_type_path (t_path mt)
+	| CArray i -> "[" ^(string_of_int i) ^ "]"
+	| CFields (_,fl) -> String.concat "," (List.map (fun (s,_) -> s) fl)
+	| CExpr e -> s_expr (s_type (print_context())) e
+
+and st_args l r v =
+	(if l > 0 then (String.concat "," (ExtList.List.make l "_")) ^ "," else "")
+	^ v ^
+	(if r > 0 then "," ^ (String.concat "," (ExtList.List.make r "_")) else "")
+
+and s_dt tabs tree =
+	let s_type = s_type (print_context()) in
+	let rec s_st st =
+		(match st.st_def with
+		| SVar v -> v.v_name
+		| SEnum (st,n,i) -> s_st st ^ "." ^ n ^ "." ^ (string_of_int i)
+		| SArray (st,i) -> s_st st ^ "[" ^ (string_of_int i) ^ "]"
+		| STuple (st,i,a) -> "(" ^ (st_args i (a - i - 1) (s_st st)) ^ ")"
+		| SField (st,n) -> s_st st ^ "." ^ n)
+	in
+	tabs ^ match tree with
+	| Out(e,eo,None)->
+		s_expr s_type e
+	| Out(e,eo,Some dt) ->
+		"if (" ^ (s_expr s_type (match eo with Some e -> e | None -> assert false)) ^ ") " ^ (s_expr s_type e) ^ " else " ^ s_dt tabs dt
+	| Switch (st, cl) ->
+		"switch(" ^ (s_st st) ^ ") { \n" ^ tabs
+		^ (String.concat ("\n" ^ tabs) (List.map (fun (c,dt) ->
+			"case " ^ (s_con c) ^ ":\n" ^ (s_dt (tabs ^ "\t") dt)
+		) cl))
+		^ "\n" ^ (if String.length tabs = 0 then "" else (String.sub tabs 0 (String.length tabs - 1))) ^ "}"
+	| Bind (bl, dt) -> "bind " ^ (String.concat "," (List.map (fun ((v,_),st) -> v.v_name ^ "(" ^ (string_of_int v.v_id) ^ ") =" ^ (s_st st)) bl)) ^ "\n" ^ (s_dt tabs dt)
+	| Goto i ->
+		"goto " ^ (string_of_int i)
+
+and s_expr s_type e =
 	let sprintf = Printf.sprintf in
 	let slist f l = String.concat "," (List.map f l) in
 	let loop = s_expr s_type in
@@ -1584,6 +1654,7 @@ let rec s_expr s_type e =
 		let args vl = slist (function None -> "_" | Some v -> sprintf "%s : %s" (s_var v) (s_type v.v_type)) vl in
 		let cases = slist (fun (il,vl,e) -> sprintf "case %s%s : %s" (slist string_of_int il) (match vl with None -> "" | Some vl -> sprintf "(%s)" (args vl)) (loop e)) cases in
 		sprintf "Match %s (%s,(%s)%s)" (s_type (TEnum (en,tparams))) (loop e) cases (match def with None -> "" | Some e -> "," ^ loop e)
+	| TPatMatch dt -> s_dt "" (dt.dt_dt_lookup.(dt.dt_first))
 	| TTry (e,cl) ->
 		sprintf "Try %s(%s) " (loop e) (slist (fun (v,e) -> sprintf "catch( %s : %s ) %s" (s_var v) (s_type v.v_type) (loop e)) cl)
 	| TReturn None ->
@@ -1659,6 +1730,7 @@ let rec s_expr_pretty tabs s_type e =
 		) cases in
 		let s = sprintf "switch (%s) {\n%s%s" (loop e) cases (match def with None -> "" | Some e -> ntabs ^ "default: " ^ (s_expr_pretty ntabs s_type e) ^ "\n") in
 		s ^ tabs ^ "}"
+	| TPatMatch dt -> s_dt tabs (dt.dt_dt_lookup.(dt.dt_first))	
 	| TTry (e,cl) ->
 		sprintf "try %s%s" (loop e) (slist (fun (v,e) -> sprintf "catch( %s : %s ) %s" v.v_name (s_type v.v_type) (loop e)) cl)
 	| TReturn None ->