Merge pull request #3914 from HaxeFoundation/store_typed_expr

add Context.storeTypedExpr

analyzer.ml

@@ -188,7 +188,7 @@ module Simplifier = struct
 							let e_v',e1 = loop e_v e1 in
 							let e1 = assign e_v e1 in
 							begin match e1.eexpr with
-								| TBinop(OpAssign,{eexpr = TLocal v1},e2) when v == v1 ->
+								| TBinop(OpAssign,{eexpr = TLocal v1},e2) when v.v_id = v1.v_id ->
 									declare (Some e2)
 								| _ ->
 									declare None;
@@ -410,7 +410,7 @@ module Simplifier = struct
 	let unapply com e =
 		let var_map = ref IntMap.empty in
 		let rec get_assignment_to v e = match e.eexpr with
-			| TBinop(OpAssign,{eexpr = TLocal v2},e2) when v == v2 -> Some e2
+			| TBinop(OpAssign,{eexpr = TLocal v2},e2) when v.v_id = v2.v_id -> Some e2
 			| TBlock [e] -> get_assignment_to v e
 			| _ -> None
 		in
@@ -428,7 +428,7 @@ module Simplifier = struct
 								end
 							| TVar(v,None) when not (com.platform = Php) ->
 								begin match el with
-									| {eexpr = TBinop(OpAssign,{eexpr = TLocal v2},e2)} :: el when v == v2 ->
+									| {eexpr = TBinop(OpAssign,{eexpr = TLocal v2},e2)} :: el when v.v_id = v2.v_id ->
 										let e = {e with eexpr = TVar(v,Some e2)} in
 										loop2 (e :: el)
 									| ({eexpr = TIf(e1,e2,Some e3)} as e_if) :: el ->
@@ -695,7 +695,7 @@ module Ssa = struct
 			IntMap.find v.v_id ctx.cur_data.nd_var_map
 		with Not_found ->
 			if not (has_meta Meta.Unbound v.v_meta) then
-				ctx.com.warning (Printf.sprintf "Unbound variable %s" v.v_name) p;
+				error (Printf.sprintf "Unbound variable %s" v.v_name) p;
 			v
 
 	let close_join_node ctx node p =
@@ -716,7 +716,7 @@ module Ssa = struct
 					IntMap.iter (fun i v ->
 						try
 							let vl = IntMap.find i !vars in
-							if not (List.exists (fun (v',_) -> v == v') vl) then
+							if not (List.exists (fun (v',_) -> v.v_id = v'.v_id) vl) then
 								vars := IntMap.add i ((v,p) :: vl) !vars
 						with Not_found ->
 							()
@@ -1270,7 +1270,7 @@ module Checker = struct
 		let resolve_value v =
 			let e' = Ssa.get_var_value v in
 			begin match e'.eexpr with
-				| TLocal v' when v == v' -> e'
+				| TLocal v' when v.v_id = v'.v_id -> e'
 				| _ -> e'
 			end
 		in
@@ -1285,7 +1285,7 @@ module Checker = struct
 		let can_be_null v =
 			not (has_meta Meta.NotNull v.v_meta)
 			&& try not (List.exists (fun cond -> match cond with
-				| NotEqual(v',e) when v == v' && is_null_expr e -> true
+				| NotEqual(v',e) when v.v_id = v'.v_id && is_null_expr e -> true
 				| _ -> false
 			) (IntMap.find v.v_id ssa.var_conds)) with Not_found -> true
 		in

ast.ml

@@ -144,6 +144,7 @@ module Meta = struct
 		| SkipCtor
 		| SkipReflection
 		| Sound
+		| StoredTypedExpr
 		| Struct
 		| StructAccess
 		| SuppressWarnings

codegen.ml

@@ -928,7 +928,7 @@ module PatternMatchConversion = struct
 	let is_declared cctx v =
 		let rec loop sl = match sl with
 			| stack :: sl ->
-				List.exists (fun ((v2,_),_) -> v == v2) stack || loop sl
+				List.exists (fun ((v2,_),_) -> v.v_id = v2.v_id) stack || loop sl
 			| [] ->
 				false
 		in
@@ -980,7 +980,7 @@ module PatternMatchConversion = struct
 				) catches in
 				{e with eexpr = TTry(e1,catches)}
 			| TLocal v ->
-				let v' = try List.assq v !v_known with Not_found -> v in
+				let v' = try snd (List.find (fun (v2,_) -> v2.v_id = v.v_id) !v_known) with Not_found -> v in
 				{e with eexpr = TLocal v'}
 			| _ ->
 				Type.map_expr loop e

common.ml

@@ -133,6 +133,7 @@ type context = {
 	mutable get_macros : unit -> context option;
 	mutable run_command : string -> int;
 	file_lookup_cache : (string,string option) Hashtbl.t;
+	mutable stored_typed_exprs : (int, texpr) PMap.t;
 	(* output *)
 	mutable file : string;
 	mutable flash_version : float;
@@ -463,6 +464,7 @@ module MetaInfo = struct
 		| RuntimeValue -> ":runtimeValue",("Marks an abstract as being a runtime value",[UsedOn TAbstract])
 		| SelfCall -> ":selfCall",("Translates method calls into calling object directly",[UsedOn TClassField; Platform Js])
 		| Setter -> ":setter",("Generates a native getter function on the given field",[HasParam "Class field name";UsedOn TClassField;Platform Flash])
+		| StoredTypedExpr -> ":storedTypedExpr",("Used internally to reference a typed expression returned from a macro",[Internal])
 		| SkipCtor -> ":skipCtor",("Used internally to generate a constructor as if it were a native type (no __hx_ctor)",[Platforms [Java;Cs]; Internal])
 		| SkipReflection -> ":skipReflection",("Used internally to annotate a field that shouldn't have its reflection data generated",[Platforms [Java;Cs]; UsedOn TClassField; Internal])
 		| Sound -> ":sound",( "Includes a given .wav or .mp3 file into the target Swf and associates it with the class (must extend flash.media.Sound)",[HasParam "File path";UsedOn TClass;Platform Flash])
@@ -735,6 +737,7 @@ let create v args =
 			tarray = (fun _ -> assert false);
 		};
 		file_lookup_cache = Hashtbl.create 0;
+		stored_typed_exprs = PMap.empty;
 		memory_marker = memory_marker;
 	}
 

extra/CHANGES.txt

@@ -72,6 +72,7 @@
 	macro : [breaking] extended TAnonymous structures now have AExtend status instead of AClosed
 	macro : added Context.getDefines
 	macro : fixed file_seek from end (position was inversed)
+	macro : added Context.storeTypedExpr
 
 	Deprecations:
 

filters.ml

@@ -583,7 +583,7 @@ let rename_local_vars ctx e =
 				the same variable twice. In that case do not perform a rename since
 				we are sure it's actually the same variable
 			*)
-			if v == v2 then raise Not_found;
+			if v.v_id = v2.v_id then raise Not_found;
 			rename look_vars v;
 		with Not_found ->
 			());
@@ -600,7 +600,7 @@ let rename_local_vars ctx e =
 			let vars = if cfg.pf_locals_scope then vars else all_vars in
 			(try
 				let v = PMap.find name !vars in
-				if v == vtemp then raise Not_found; (* ignore *)
+				if v.v_id = vtemp.v_id then raise Not_found; (* ignore *)
 				rename (!vars) v;
 				rebuild_vars := true;
 				vars := PMap.add v.v_name v !vars

interp.ml

@@ -106,6 +106,7 @@ type extern_api = {
 	on_type_not_found : (string -> value) -> unit;
 	parse_string : string -> Ast.pos -> bool -> Ast.expr;
 	type_expr : Ast.expr -> Type.texpr;
+	store_typed_expr : Type.texpr -> Ast.expr;
 	get_display : string -> string;
 	allow_package : string -> unit;
 	type_patch : string -> string -> bool -> string option -> unit;
@@ -2628,6 +2629,10 @@ let macro_lib =
 			let e = decode_texpr e in
 			encode_expr (make_ast e)
 		);
+		"store_typed_expr", Fun1 (fun e ->
+			let e = try decode_texpr e with Invalid_expr -> error() in
+			encode_expr ((get_ctx()).curapi.store_typed_expr e)
+		);
 		"get_output", Fun0 (fun() ->
 			VString (ccom()).file
 		);

matcher.ml

@@ -770,7 +770,7 @@ let column_sigma mctx st pmat =
 		if not g then Hashtbl.replace unguarded c.c_def true;
 	in
 	let bind_st out st v =
-		if not (List.exists (fun ((v2,p),_) -> v2.v_id == (fst v).v_id) !bindings) then bindings := (v,st) :: !bindings
+		if not (List.exists (fun ((v2,p),_) -> v2.v_id = (fst v).v_id) !bindings) then bindings := (v,st) :: !bindings
 	in
 	let rec loop pmat = match pmat with
 		| (pv,out) :: pr ->

optimizer.ml

@@ -1315,7 +1315,7 @@ let inline_constructors ctx e =
 								match e.eexpr with
 								| TBlock el ->
 									List.iter get_assigns el
-								| TBinop (OpAssign, { eexpr = TField ({ eexpr = TLocal vv },FInstance(_,_,cf)); etype = t }, e) when v == vv ->
+								| TBinop (OpAssign, { eexpr = TField ({ eexpr = TLocal vv },FInstance(_,_,cf)); etype = t }, e) when v.v_id = vv.v_id ->
 									assigns := (cf.cf_name,e,t) :: !assigns
 								| _ ->
 									raise Exit

std/haxe/macro/Context.hx

@@ -465,6 +465,24 @@ class Context {
 		return load("get_typed_expr",1)(t);
 	}
 
+
+	/**
+		Store typed expression `t` internally and give a syntax-level expression
+		that can be returned from a macro and will be replaced by the stored
+		typed expression.
+
+		If `t` is null or invalid, an exception is thrown.
+
+		NOTE: the returned value references an internally stored typed expression
+		that is reset between compilations, so care should be taken when storing
+		the expression returned by this method in a static variable and using the
+		compilation server.
+	**/
+	@:require(haxe_ver >= 3.2)
+	public static function storeTypedExpr( t : Type.TypedExpr ) : Expr {
+		return load("store_typed_expr",1)(t);
+	}
+
 	/**
 		Manually adds a dependency between module `modulePath` and an external
 		file `externFile`.

tests/unit/src/unit/issues/Issue3914.hx

@@ -0,0 +1,61 @@
+package unit.issues;
+
+class Issue3914 extends Test {
+    #if macro
+    static var storedExpr:haxe.macro.Expr;
+    #end
+
+    function test() {
+        storeExpr(function(a:Array<Int>) {
+            for (i in a) {
+                try throw i catch (v:Dynamic) {
+                    var v2 = v;
+                    return v2;
+                }
+            }
+            throw false;
+        });
+        eq(getStoredExpr()([3,2,1]), 3);
+    }
+
+    function test2() {
+        storeExpr(function(a:Array<Int>) {
+            for (i in a) {
+                try throw i catch (v:Dynamic) {
+                    var v2 = v;
+                    return v2;
+                }
+            }
+            throw false;
+        });
+        check2();
+    }
+
+    function check2() {
+        eq(getStoredExpr()([3,2,1]), 3);
+    }
+
+    function test3() {
+        store3();
+        eq(getStoredExpr()([3,2,1]), 3);
+    }
+
+    function store3() {
+        storeExpr(function(a:Array<Int>) {
+            for (i in a) {
+                try throw i catch (v:Dynamic) {
+                    var v2 = v;
+                    return v2;
+                }
+            }
+            throw false;
+        });
+    }
+
+    static macro function storeExpr(e) {
+        storedExpr = haxe.macro.Context.storeTypedExpr(haxe.macro.Context.typeExpr(e));
+        return macro {};
+    }
+
+    static macro function getStoredExpr() return storedExpr;
+}

typeload.ml

@@ -1868,7 +1868,7 @@ let init_class ctx c p context_init herits fields =
 								let rec has_this e = match e.eexpr with
 									| TConst TThis ->
 										display_error ctx "Cannot access this or other member field in variable initialization" e.epos;
-									| TLocal v when (match ctx.vthis with Some v2 -> v == v2 | None -> false) ->
+									| TLocal v when (match ctx.vthis with Some v2 -> v.v_id = v2.v_id | None -> false) ->
 										display_error ctx "Cannot access this or other member field in variable initialization" e.epos;
 									| _ ->
 									Type.iter has_this e

typer.ml

@@ -3524,11 +3524,61 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			| (Meta.Analyzer,_,_) ->
 				let e = e() in
 				{e with eexpr = TMeta(m,e)}
+			| (Meta.StoredTypedExpr,_,_) ->
+				let id = match e1 with (EConst (Int s),_) -> int_of_string s | _ -> assert false in
+				get_stored_typed_expr ctx.com id
 			| _ -> e()
 		in
 		ctx.meta <- old;
 		e
 
+and get_next_stored_typed_expr_id =
+	let uid = ref 0 in
+	(fun() -> incr uid; !uid)
+
+and get_stored_typed_expr com id =
+	let vars = Hashtbl.create 0 in
+	let copy_var v =
+		let v2 = alloc_var v.v_name v.v_type in
+		v2.v_meta <- v.v_meta;
+		Hashtbl.add vars v.v_id v2;
+		v2;
+	in
+	let rec build_expr e =
+		match e.eexpr with
+		| TVar (v,eo) ->
+			let v2 = copy_var v in
+			{e with eexpr = TVar(v2, Option.map build_expr eo)}
+		| TFor (v,e1,e2) ->
+			let v2 = copy_var v in
+			{e with eexpr = TFor(v2, build_expr e1, build_expr e2)}
+		| TTry (e1,cl) ->
+			let cl = List.map (fun (v,e) ->
+				let v2 = copy_var v in
+				v2, build_expr e
+			) cl in
+			{e with eexpr = TTry(build_expr e1, cl)}
+		| TFunction f ->
+			let args = List.map (fun (v,c) -> copy_var v, c) f.tf_args in
+			let f = {
+				tf_args = args;
+				tf_type = f.tf_type;
+				tf_expr = build_expr f.tf_expr;
+			} in
+			{e with eexpr = TFunction f}
+		| TLocal v ->
+			(try
+				let v2 = Hashtbl.find vars v.v_id in
+				{e with eexpr = TLocal v2}
+			with _ ->
+				e)
+		| _ ->
+			map_expr build_expr e
+	in
+	let e = PMap.find id com.stored_typed_exprs in
+	build_expr  e
+
+
 and handle_display ctx e_ast iscall p =
 	let old = ctx.in_display in
 	ctx.in_display <- true;
@@ -4244,6 +4294,13 @@ let make_macro_api ctx p =
 		Interp.type_expr = (fun e ->
 			typing_timer ctx (fun() -> (type_expr ctx e Value))
 		);
+		Interp.store_typed_expr = (fun te ->
+			let p = te.epos in
+			let id = get_next_stored_typed_expr_id() in
+			ctx.com.stored_typed_exprs <- PMap.add id te ctx.com.stored_typed_exprs;
+			let eid = (EConst (Int (string_of_int id))), p in
+			(EMeta ((Meta.StoredTypedExpr,[],p), eid)), p
+		);
 		Interp.get_display = (fun s ->
 			let is_displaying = ctx.com.display <> DMNone in
 			let old_resume = !Parser.resume_display in