a bit more hl macro work

src/generators/genhl.ml

@@ -95,6 +95,7 @@ type context = {
 	mutable method_wrappers : ((ttype * ttype), int) PMap.t;
 	mutable rec_cache : (Type.t * ttype option ref) list;
 	mutable cached_tuples : (ttype list, ttype) PMap.t;
+	macro_typedefs : (string, ttype) Hashtbl.t;
 	array_impl : array_impl;
 	base_class : tclass;
 	base_type : tclass;
@@ -345,6 +346,7 @@ let rec to_type ?tref ctx t =
 		) in
 		(match td.t_path with
 		| [], "Null" when not (is_nullable t) -> HNull t
+		| ["haxe";"macro"], name -> Hashtbl.replace ctx.macro_typedefs name t; t
 		| _ -> t)
 	| TLazy f ->
 		to_type ?tref ctx (!f())
@@ -3495,6 +3497,7 @@ let create_context com is_macro dump =
 		rec_cache = [];
 		method_wrappers = PMap.empty;
 		cdebug_files = new_lookup();
+		macro_typedefs = Hashtbl.create 0;
 	} in
 	ignore(alloc_string ctx "");
 	ignore(class_type ctx ctx.base_class [] false);

src/generators/hlinterp.ml

@@ -379,8 +379,13 @@ let rec to_virtual ctx v vp =
 			d.dvirtuals <- v :: d.dvirtuals;
 			VVirtual v
 		)
-	| VVirtual v ->
-		to_virtual ctx v.vvalue vp
+	| VVirtual vd ->
+		if vd.vtype == vp then
+			v
+		else if vd.vvalue = VNull then
+			assert false
+		else
+			to_virtual ctx vd.vvalue vp
 	| _ ->
 		throw_msg ctx ("Invalid ToVirtual " ^ vstr_d ctx v ^ " : " ^ tstr (HVirtual vp))
 
@@ -556,7 +561,16 @@ let rec dyn_get_field ctx obj field rt =
 		with Not_found ->
 			loop o.oproto.pclass)
 	| VVirtual vp ->
-		dyn_get_field ctx vp.vvalue field rt
+		(match vp.vvalue with
+		| VNull ->
+			(try
+				let idx = PMap.find field vp.vtype.vindex in
+				match vp.vindexes.(idx) with
+				| VFNone -> VNull
+				| VFIndex i -> vp.vtable.(i)
+			with Not_found ->
+				VNull)
+		| v -> dyn_get_field ctx v field rt)
 	| VNull ->
 		null_access()
 	| _ ->
@@ -624,6 +638,26 @@ let stack_frame ctx (f,pos) =
 	let file, line = make_stack ctx (f,pos) in
 	Printf.sprintf "%s:%d: Called from fun@%d @x%X" file line f.findex (!pos - 1)
 
+let virt_make_val v =
+	let hfields = Hashtbl.create 0 in
+	let ftypes = DynArray.create() in
+	let values = DynArray.create() in
+	Array.iteri (fun i idx ->
+		match idx with
+		| VFNone -> ()
+		| VFIndex k ->
+			let n, _, t = v.vtype.vfields.(i) in
+			Hashtbl.add hfields n (DynArray.length values);
+			DynArray.add values v.vtable.(k);
+			DynArray.add ftypes t;
+	) v.vindexes;
+	VDynObj {
+		dfields = hfields;
+		dtypes = DynArray.to_array ftypes;
+		dvalues = DynArray.to_array values;
+		dvirtuals = [v];
+	}
+
 let rec vstr ctx v t =
 	let vstr = vstr ctx in
 	match v with
@@ -645,8 +679,10 @@ let rec vstr ctx v t =
 	| VRef (r,t) -> "*" ^ (vstr (get_ref ctx r) t)
 	| VVirtual v ->
 		(match v.vvalue with
-		| VNull -> assert false
-		| _ -> vstr v.vvalue HDyn)
+		| VNull ->
+			vstr (virt_make_val v) HDyn
+		| _ ->
+			vstr v.vvalue HDyn)
 	| VDynObj d ->
 		(try
 			let fid = Hashtbl.find d.dfields "__string" in
@@ -662,7 +698,11 @@ let rec vstr ctx v t =
 			if Array.length pl = 0 then
 				n
 			else
-				n ^ "(" ^ String.concat "," (List.map2 vstr (Array.to_list vals) (Array.to_list pl)) ^ ")"
+				let rec loop i =
+					if i = Array.length pl then []
+					else let v = vals.(i) in vstr v pl.(i) :: loop (i + 1)
+				in
+				n ^ "(" ^ String.concat "," (loop 0) ^ ")"
 		| _ ->
 			assert false)
 	| VVarArgs _ -> "varargs"

src/macro/hlmacro.ml

@@ -31,6 +31,7 @@ type context = {
 	interp : Hlinterp.context;
 	types : (Type.path,int) Hashtbl.t;
 	cached_protos : (obj_type, (virtual_proto * vfield array)) Hashtbl.t;
+	cached_enums : (enum_type, ttype) Hashtbl.t;
 	mutable curapi : value MacroApi.compiler_api;
 	mutable has_error : bool;
 }
@@ -85,6 +86,7 @@ let create com api =
 		types = Hashtbl.create 0;
 		has_error = false;
 		cached_protos = Hashtbl.create 0;
+		cached_enums = Hashtbl.create 0;
 	} in
 	select ctx;
 	Hlinterp.set_error_handler ctx.interp (error_handler ctx);
@@ -225,7 +227,10 @@ let decode_pos = function
 	| VAbstract (APos p) -> p
 	| _ -> raise Invalid_expr
 
-let encode_enum _ pos tag pl =
+let last_enum_type = ref IExpr
+
+let encode_enum t pos tag pl =
+	last_enum_type := t;
 	match pos with
 	| None -> VEnum (tag,Array.of_list pl)
 	| Some p -> VEnum (tag,Array.of_list (List.rev (encode_pos p :: List.rev pl)))
@@ -293,14 +298,101 @@ let decode_lazytype = function
 	| _ -> raise Invalid_expr
 
 let enc_obj t fields =
-	let t, idx = try
-		Hashtbl.find (get_ctx()).cached_protos t
+	match t with
+	| OMetaAccess ->
+		let h = Hashtbl.create 0 in
+		let rec loop i = function
+			| [] -> ()
+			| (n,_) :: l ->
+				Hashtbl.add h n i;
+				loop (i + 1) l
+		in
+		loop 0 fields;
+		let values = Array.of_list (List.map snd fields) in
+		VDynObj {
+			dfields = h;
+			dvalues = values;
+			dtypes = Array.make (Array.length values) HDyn;
+			dvirtuals = [];
+		}
+	| _ ->
+	let ctx = get_ctx() in
+	let to_str (name,f) =
+		match f with
+		| None -> name
+		| Some f -> name ^ "." ^ f
+	in
+	let vp, idx = try
+		Hashtbl.find ctx.cached_protos t
 	with Not_found ->
 		let name, field = proto_name t in
-		assert false
+		let gen = (match ctx.gen with None -> assert false | Some gen -> gen) in
+		let vt = (try
+			let t = Hashtbl.find gen.Genhl.macro_typedefs name in
+			(match t, field with
+			| _, None -> t
+			| HVirtual v, Some f ->
+				let idx = (try PMap.find f v.vindex with Not_found -> failwith (name ^ " has no field definition " ^ f)) in
+				let _,_, t = v.vfields.(idx) in
+				(match t with
+				| HVirtual _ -> t
+				| _ -> failwith ("Unexpected type " ^ tstr t ^ " for definition " ^ to_str (name,field)))
+			| _ ->
+				assert false
+			)
+		with Not_found -> try
+			let t = PMap.find (["haxe";"macro"],name) gen.Genhl.cached_types in
+			(match t, field with
+			| HEnum e, Some f ->
+				let rec loop i =
+					if i = Array.length e.efields then raise Not_found;
+					let n, _, tl = e.efields.(i) in
+					if n = f then
+						tl.(0)
+					else
+						loop (i + 1)
+				in
+				loop 0
+			| _ ->
+				failwith ("Unexpected type " ^ tstr t ^ " for definition " ^ to_str (name,field)))
+		with Not_found ->
+			failwith ("Macro definition missing " ^ to_str (name,field))
+		) in
+		match vt with
+		| HVirtual vp ->
+			let vindexes = Array.map (fun (n,_,_) ->
+				let rec loop i = function
+					| [] -> VFNone
+					| (n2,_) :: _ when n = n2 -> VFIndex i
+					| _ :: l -> loop (i + 1) l
+				in
+				loop 0 fields
+			) vp.vfields in
+			Hashtbl.replace ctx.cached_protos t (vp, vindexes);
+			vp, vindexes
+		| _ ->
+			failwith (to_str (name,field) ^ " returned invalid type " ^ tstr vt)
 	in
+	if debug then begin
+		let farr = Array.of_list fields in
+		Array.iteri (fun i idx ->
+			let name, _ ,_ = vp.vfields.(i) in
+			match idx with
+			| VFNone ->
+				if List.mem_assoc name fields then failwith ("Field " ^ name ^ " is present in "  ^ to_str (proto_name t))
+			| VFIndex i when i >= Array.length farr ->
+				failwith ("Missing field " ^ name ^ " of "  ^ to_str (proto_name t))
+			| VFIndex i when fst farr.(i) <> name ->
+				failwith ("Field " ^ name ^ " of "  ^ to_str (proto_name t) ^ " is wrongly mapped on " ^ fst farr.(i))
+			| _ ->
+				()
+		) idx;
+		List.iter (fun (n,_) ->
+			if n <> "name_pos" && not (PMap.mem n vp.vindex) then failwith ("Field " ^ n ^ " has data but is not part of type " ^ to_str (proto_name t));
+		) fields;
+	end;
 	VVirtual {
-		vtype = t;
+		vtype = vp;
 		vindexes = idx;
 		vtable = Array.map snd (Array.of_list fields);
 		vvalue = VNull;
@@ -320,7 +412,26 @@ let enc_string s =
 	enc_inst ([],"String") [|VBytes (caml_to_hl s);VInt (Int32.of_int (String.length s))|]
 
 let enc_array vl =
-	let arr = Array.of_list vl in
+	let arr = Array.of_list (List.map (fun v ->
+		match v with
+		| VNull | VObj _ | VVirtual _ -> v
+		| VEnum _ ->
+			let ctx = get_ctx() in
+			let et = !last_enum_type in
+			let t = try
+				Hashtbl.find ctx.cached_enums et
+			with Not_found ->
+				let name = enum_name et in
+				let t = (match ctx.gen with
+				| None -> assert false
+				| Some gen -> try PMap.find (["haxe";"macro"],name) gen.Genhl.cached_types with Not_found -> failwith ("Missing enum type " ^ name)
+				) in
+				Hashtbl.replace ctx.cached_enums et t;
+				t
+			in
+			VDyn (v,t)
+		| _ -> failwith "Invalid array value"
+	) vl) in
 	enc_inst (["hl";"types"],"ArrayObj") [|VInt (Int32.of_int (Array.length arr));VArray (arr,HDyn)|]
 
 let encode_bytes s =
@@ -336,12 +447,27 @@ let decode_bytes = function
 	| _ -> raise Invalid_expr
 
 let encode_ref v convert tostr =
-	enc_obj ORef [
-		"get", vfun0 (fun() -> convert v);
-		"__string", vfun0 (fun() -> VBytes (caml_to_hl (tostr())));
-		"toString", vfun0 (fun() -> enc_string (tostr()));
-		"$", VAbstract (AUnsafe (Obj.repr v));
-	]
+	let h = Hashtbl.create 0 in
+	Hashtbl.add h "get" 0;
+	Hashtbl.add h "__string" 1;
+	Hashtbl.add h "toString" 2;
+	Hashtbl.add h "$" 3;
+	VDynObj {
+		dfields = h;
+		dvalues = [|
+			vfun0 (fun() -> convert v);
+			vfun0 (fun() -> VBytes (caml_to_hl (tostr())));
+			vfun0 (fun() -> enc_string (tostr()));
+			VAbstract (AUnsafe (Obj.repr v))
+		|];
+		dtypes = [|
+			HFun ([],HDyn);
+			HFun ([],HBytes);
+			HFun ([],HDyn);
+			HDyn;
+		|];
+		dvirtuals = [];
+	}
 
 let decode_ref v : 'a =
 	match field v "$" with

src/macro/interp.ml

@@ -3194,7 +3194,7 @@ let enc_hash h =
 
 let enc_obj _ l = VObject (obj hash l)
 
-let encode_enum (i:enum_index) pos index pl =
+let encode_enum (i:enum_type) pos index pl =
 	let eindex : int = Obj.magic i in
 	let edef = (get_ctx()).enums.(eindex) in
 	if pl = [] then

src/macro/macroApi.ml

@@ -51,7 +51,7 @@ type 'value compiler_api = {
 }
 
 
-type enum_index =
+type enum_type =
 	| IExpr
 	| IBinop
 	| IUnop
@@ -88,7 +88,7 @@ type obj_type =
 	| OVar
 	| OCase
 	| OCatch
-	| OExprDef
+	| OExpr
 	(* Type *)
 	| OMetaAccess
 	| OTypeParameter
@@ -146,7 +146,7 @@ module type InterpApi = sig
 	val vfun5 : (value -> value -> value -> value -> value -> value) -> value
 
 	val encode_pos : Globals.pos -> value
-	val encode_enum : enum_index -> Globals.pos option -> int -> value list -> value
+	val encode_enum : enum_type -> Globals.pos option -> int -> value list -> value
 	val encode_string_map : ('a -> value) -> (string, 'a) PMap.t -> value
 
 	val encode_tdecl : Type.module_type -> value
@@ -211,7 +211,7 @@ let proto_name = function
 	| OImportExpr -> "ImportExpr", None
 	| OImportExpr_path -> "ImportExpr", Some "path"
 	| OTypePath -> "TypePath", None
-	| OMetadataEntry -> "MetadaEntry", None
+	| OMetadataEntry -> "MetadataEntry", None
 	| OField -> "Field", None
 	| OTypeParamDecl -> "TypeParamDecl", None
 	| OFunction -> "Function", None
@@ -220,7 +220,7 @@ let proto_name = function
 	| OVar -> "Var", None
 	| OCase -> "Case", None
 	| OCatch -> "Catch", None
-	| OExprDef -> "ExprDef", None
+	| OExpr -> "Expr", None
 	| OMetaAccess -> "MetaAccess", None
 	| OTypeParameter -> "TypeParameter", None
 	| OClassType -> "ClassType", None
@@ -254,7 +254,7 @@ let proto_name = function
 let all_enums =
 	let last = IImportMode in
 	let rec loop i =
-		let e : enum_index = Obj.magic i in
+		let e : enum_type = Obj.magic i in
 		if e = last then [e] else e :: loop (i + 1)
 	in
 	loop 0
@@ -540,7 +540,7 @@ and encode_expr e =
 			| EMeta (m,e) ->
 				29, [encode_meta_entry m;loop e]
 		in
-		enc_obj OExprDef [
+		enc_obj OExpr [
 			"pos", encode_pos p;
 			"expr", encode_enum IExpr tag pl;
 		]
@@ -550,7 +550,7 @@ and encode_expr e =
 and encode_null_expr e =
 	match e with
 	| None ->
-		enc_obj OExprDef ["pos", vnull;"expr",vnull]
+		enc_obj OExpr ["pos", vnull;"expr",vnull]
 	| Some e ->
 		encode_expr e