added hashlink @:struct support (hl 1.10)

src/generators/genhl.ml

@@ -570,7 +570,7 @@ and class_type ?(tref=None) ctx c pl statics =
 			pinterfaces = PMap.empty;
 			pbindings = [];
 		} in
-		let t = HObj p in
+		let t = (if Meta.has Meta.Struct c.cl_meta && not statics then HStruct p else HObj p) in
 		(match tref with
 		| None -> ()
 		| Some r -> r := Some t);
@@ -587,7 +587,8 @@ and class_type ?(tref=None) ctx c pl statics =
 		) in
 		let start_field, virtuals = (match tsup with
 			| None -> 0, [||]
-			| Some (HObj psup) ->
+			| Some ((HObj psup | HStruct psup) as pt) ->
+				if is_struct t <> is_struct pt then abort (if is_struct t then "Struct cannot extend a not struct class" else "Class cannot extend a struct") c.cl_pos;
 				if psup.pnfields < 0 then assert false;
 				p.psuper <- Some psup;
 				psup.pnfields, psup.pvirtuals
@@ -1266,7 +1267,7 @@ and unsafe_cast_to ?(debugchk=true) ctx (r:reg) (t:ttype) p =
 
 and object_access ctx eobj t f =
 	match t with
-	| HObj p ->
+	| HObj p | HStruct p ->
 		(try
 			let fid = fst (get_index f.cf_name p) in
 			if f.cf_kind = Method MethNormal then
@@ -3292,7 +3293,7 @@ let rec generate_member ctx c f =
 		let gen_content = if f.cf_name <> "new" then None else Some (fun() ->
 
 			let o = (match class_type ctx c (List.map snd c.cl_params) false with
-				| HObj o -> o
+				| HObj o | HStruct o -> o
 				| _ -> assert false
 			) in
 
@@ -3751,8 +3752,8 @@ let write_code ch code debug =
 			byte n;
 			List.iter write_type args;
 			write_type ret
-		| HObj p ->
-			byte 11;
+		| HObj p | HStruct p ->
+			byte (if is_struct t then 21 else 11);
 			write_index p.pid;
 			(match p.psuper with
 			| None -> write_index (-1)

src/generators/hl2c.ml

@@ -115,7 +115,7 @@ let s_comp = function
 let core_types =
 	let vp = { vfields = [||]; vindex = PMap.empty } in
 	let ep = { ename = ""; eid = 0; eglobal = None; efields = [||] } in
-	[HVoid;HUI8;HUI16;HI32;HI64;HF32;HF64;HBool;HBytes;HDyn;HFun ([],HVoid);HObj null_proto;HArray;HType;HRef HVoid;HVirtual vp;HDynObj;HAbstract ("",0);HEnum ep;HNull HVoid]
+	[HVoid;HUI8;HUI16;HI32;HI64;HF32;HF64;HBool;HBytes;HDyn;HFun ([],HVoid);HObj null_proto;HArray;HType;HRef HVoid;HVirtual vp;HDynObj;HAbstract ("",0);HEnum ep;HNull HVoid;HMethod ([],HVoid);HStruct null_proto]
 
 let tname str =
 	let n = String.concat "__" (ExtString.String.nsplit str ".") in
@@ -123,7 +123,7 @@ let tname str =
 
 let is_gc_ptr = function
 	| HVoid | HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 | HBool | HType | HRef _ | HMethod _ -> false
-	| HBytes | HDyn | HFun _ | HObj _ | HArray | HVirtual _ | HDynObj | HAbstract _ | HEnum _ | HNull _ -> true
+	| HBytes | HDyn | HFun _ | HObj _ | HArray | HVirtual _ | HDynObj | HAbstract _ | HEnum _ | HNull _ | HStruct _ -> true
 
 let is_ptr = function
 	| HVoid | HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 | HBool -> false
@@ -141,7 +141,7 @@ let rec ctype_no_ptr = function
 	| HBytes -> "vbyte",1
 	| HDyn -> "vdynamic",1
 	| HFun _ -> "vclosure",1
-	| HObj p -> tname p.pname,0
+	| HObj p | HStruct p -> tname p.pname,0
 	| HArray -> "varray",1
 	| HType -> "hl_type",1
 	| HRef t -> let s,i = ctype_no_ptr t in s,i + 1
@@ -196,6 +196,7 @@ let type_id t =
 	| HEnum _ -> "HENUM"
 	| HNull _ -> "HNULL"
 	| HMethod _ -> "HMETHOD"
+	| HStruct _  -> "HSTRUCT"
 
 let var_type n t =
 	ctype t ^ " " ^ ident n
@@ -236,13 +237,13 @@ let rec define_type ctx t =
 	| HFun (args,ret) | HMethod (args,ret) ->
 		List.iter (define_type ctx) args;
 		define_type ctx ret
-	| HEnum _ | HObj _ when not (PMap.exists t ctx.defined_types) ->
+	| HEnum _ | HObj _ | HStruct _ when not (PMap.exists t ctx.defined_types) ->
 		ctx.defined_types <- PMap.add t () ctx.defined_types;
 		define ctx (sprintf "#include <%s.h>" (try PMap.find t ctx.type_module with Not_found -> assert false).m_name)
 	| HVirtual vp when not (PMap.exists t ctx.defined_types) ->
 		ctx.defined_types <- PMap.add t () ctx.defined_types;
 		Array.iter (fun (_,_,t) -> define_type ctx t) vp.vfields
-	| HEnum _ | HObj _ | HVirtual _ ->
+	| HEnum _ | HObj _ | HStruct _ | HVirtual _ ->
 		()
 
 let type_value ctx t =
@@ -363,8 +364,7 @@ let generate_reflection ctx =
 		match t with
 		| HVoid | HF32 | HF64 | HI64 -> t
 		| HBool | HUI8 | HUI16 | HI32 -> HI32
-		| HBytes | HDyn | HFun _ | HObj _ | HArray | HType | HRef _ | HVirtual _ | HDynObj | HAbstract _ | HEnum _ | HNull _ -> HDyn
-		| HMethod _ -> assert false
+		| _ -> HDyn
 	in
 	let type_kind_id t =
 		match t with
@@ -594,7 +594,7 @@ let generate_function ctx f =
 		| [] -> assert false
 		| o :: args ->
 			match rtype o with
-			| HObj _ ->
+			| HObj _ | HStruct _ ->
 				let vfun = cast_fun (sprintf "%s->$type->vobj_proto[%d]" (reg o) fid) (rtype o :: List.map rtype args) (rtype r) in
 				sexpr "%s%s(%s)" (rassign r (rtype r)) vfun (String.concat "," (List.map reg (o::args)))
 			| HVirtual vp ->
@@ -623,7 +623,7 @@ let generate_function ctx f =
 
 	let set_field obj fid v =
 		match rtype obj with
-		| HObj o ->
+		| HObj o | HStruct o ->
 			let name, t = resolve_field o fid in
 			sexpr "%s->%s = %s" (reg obj) (obj_field fid name) (rcast v t)
 		| HVirtual vp ->
@@ -636,7 +636,7 @@ let generate_function ctx f =
 
 	let get_field r obj fid =
 		match rtype obj with
-		| HObj o ->
+		| HObj o | HStruct o ->
 			let name, t = resolve_field o fid in
 			sexpr "%s%s->%s" (rassign r t) (reg obj) (obj_field fid name)
 		| HVirtual v ->
@@ -760,6 +760,8 @@ let generate_function ctx f =
 						sexpr "if( %s && %s && %s(%s,(vdynamic*)%s) %s 0 ) goto %s" (reg a) (reg b) (funname fid) (reg a) (reg b) (s_comp op) (label d)
 				with Not_found ->
 					phys_compare())
+			| HStruct _, HStruct _ ->
+				phys_compare()
 			| HVirtual _, HVirtual _ ->
 				if op = CEq then
 					sexpr "if( %s == %s || (%s && %s && %s->value && %s->value && %s->value == %s->value) ) goto %s" (reg a) (reg b) (reg a) (reg b) (reg a) (reg b) (reg a) (reg b) (label d)
@@ -953,7 +955,7 @@ let generate_function ctx f =
 			sexpr "%s = (int)%s" (reg r) (reg v)
 		| ONew r ->
 			(match rtype r with
-			| HObj o -> sexpr "%s = (%s)hl_alloc_obj(%s)" (reg r) (tname o.pname) (type_value (HObj o))
+			| HObj o | HStruct o -> sexpr "%s = (%s)hl_alloc_obj(%s)" (reg r) (tname o.pname) (type_value (rtype r))
 			| HDynObj -> sexpr "%s = hl_alloc_dynobj()" (reg r)
 			| HVirtual _ as t -> sexpr "%s = hl_alloc_virtual(%s)" (reg r) (type_value t)
 			| _ -> assert false)
@@ -1102,7 +1104,7 @@ let make_types_idents htypes =
 			DFun (List.map make_desc tl, make_desc t, true)
 		| HMethod (tl, t) ->
 			DFun (List.map make_desc tl, make_desc t, false)
-		| HObj p ->
+		| HObj p | HStruct p ->
 			DNamed p.pname
 		| HAbstract (n,_) ->
 			DNamed n
@@ -1260,7 +1262,7 @@ let make_modules ctx all_types =
 	in
 	Array.iter (fun t ->
 		match t with
-		| HObj o ->
+		| HObj o | HStruct o ->
 			let m = get_module (mk_name o.pname) in
 			Array.iter (fun p -> add m p.fmethod) o.pproto;
 			List.iter (fun (_,mid) -> add m mid) o.pbindings;
@@ -1310,7 +1312,7 @@ let generate_module_types ctx m =
 	define ctx (sprintf "#define %s" def_name);
 	List.iter (fun t ->
 		match t with
-		| HObj o ->
+		| HObj o | HStruct o ->
 			let name = tname o.pname in
 			ctx.defined_types <- PMap.add t () ctx.defined_types;
 			define ctx (sprintf "typedef struct _%s *%s;" name name);
@@ -1319,15 +1321,16 @@ let generate_module_types ctx m =
 	line "";
 	List.iter (fun t ->
 		match t with
-		| HObj op ->
+		| HObj op | HStruct op ->
 			let name = tname op.pname in
 			line ("struct _" ^ name ^ " {");
 			block ctx;
 			let rec loop o =
 				(match o.psuper with
-				| None -> expr ("hl_type *$type");
+				| None ->
+					if not (is_struct t) then expr ("hl_type *$type");
 				| Some c ->
-					define_type ctx (HObj c);
+					define_type ctx (if is_struct t then HStruct c else HObj c);
 					loop c);
 				Array.iteri (fun i (n,_,t) ->
 					let rec abs_index p v =
@@ -1444,8 +1447,9 @@ let write_c com file (code:code) gnames =
 				assert false
 		in
 		let fields = match t with
-			| HObj o ->
-				type_value ctx t :: List.map2 field_value (List.map (fun (_,_,t) -> t) (Array.to_list o.pfields)) (Array.to_list fields)
+			| HObj o | HStruct o ->
+				let fields = List.map2 field_value (List.map (fun (_,_,t) -> t) (Array.to_list o.pfields)) (Array.to_list fields) in
+				if is_struct t then fields else type_value ctx t :: fields
 			| _ ->
 				assert false
 		in
@@ -1520,7 +1524,7 @@ let write_c com file (code:code) gnames =
 			sprintf "{(const uchar*)%s, %s, %ld}" (string ctx name_id) (type_value ctx t) (hash ctx name_id)
 		in
 		match t with
-		| HObj o ->
+		| HObj o | HStruct o ->
 			let name = type_name ctx t in
 			let proto_value p =
 				sprintf "{(const uchar*)%s, %d, %d, %ld}" (string ctx p.fid) p.fmethod (match p.fvirtual with None -> -1 | Some i -> i) (hash ctx p.fid)
@@ -1612,7 +1616,7 @@ let write_c com file (code:code) gnames =
 	block ctx;
 	Array.iter (fun t ->
 		match t with
-		| HObj o ->
+		| HObj o | HStruct o ->
 			let name = type_name ctx t in
 			sexpr "obj%s.m = ctx" name;
 			(match o.pclassglobal with

src/generators/hlcode.ml

@@ -47,6 +47,7 @@ type ttype =
 	| HEnum of enum_proto
 	| HNull of ttype
 	| HMethod of ttype list * ttype
+	| HStruct of class_proto
 
 and class_proto = {
 	pname : string;
@@ -254,9 +255,12 @@ let list_mapi f l =
 *)
 let is_nullable t =
 	match t with
-	| HBytes | HDyn | HFun _ | HObj _ | HArray | HVirtual _ | HDynObj | HAbstract _ | HEnum _ | HNull _ | HRef _ | HType | HMethod _ -> true
+	| HBytes | HDyn | HFun _ | HObj _ | HArray | HVirtual _ | HDynObj | HAbstract _ | HEnum _ | HNull _ | HRef _ | HType | HMethod _ | HStruct _ -> true
 	| HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 | HBool | HVoid -> false
 
+let is_struct = function
+	| HStruct _ -> true
+	| _ -> false
 
 let is_int = function
 	| HUI8 | HUI16 | HI32 | HI64 -> true
@@ -285,6 +289,7 @@ let rec tsame t1 t2 =
 	| HMethod (args1,ret1), HMethod (args2,ret2) when List.length args1 = List.length args2 -> List.for_all2 tsame args1 args2 && tsame ret2 ret1
 	| HObj p1, HObj p2 -> p1 == p2
 	| HEnum e1, HEnum e2 -> e1 == e2
+	| HStruct p1, HStruct p2 -> p1 == p2
 	| HAbstract (_,a1), HAbstract (_,a2) -> a1 == a2
 	| HVirtual v1, HVirtual v2 ->
 		if v1 == v2 then true else
@@ -321,6 +326,12 @@ let rec safe_cast t1 t2 =
 			p.pname = p2.pname || (match p.psuper with None -> false | Some p -> loop p)
 		in
 		loop p1
+	| HStruct p1, HStruct p2 ->
+		(* allow subtyping *)
+		let rec loop p =
+			p.pname = p2.pname || (match p.psuper with None -> false | Some p -> loop p)
+		in
+		loop p1
 	| HFun (args1,t1), HFun (args2,t2) when List.length args1 = List.length args2 ->
 		List.for_all2 (fun t1 t2 -> safe_cast t2 t1 || (t1 = HDyn && is_dynamic t2)) args1 args2 && safe_cast t1 t2
 	| _ ->
@@ -380,7 +391,7 @@ let gather_types (code:code) =
 		| HFun (args, ret) | HMethod (args, ret) ->
 			List.iter get_type args;
 			get_type ret
-		| HObj p ->
+		| HObj p | HStruct p ->
 			Array.iter (fun (_,n,t) -> get_type t) p.pfields
 		| HNull t | HRef t ->
 			get_type t
@@ -424,11 +435,13 @@ let rec tstr ?(stack=[]) ?(detailed=false) t =
 	| HDyn  -> "dyn"
 	| HFun (args,ret) -> "(" ^ String.concat "," (List.map (tstr ~stack ~detailed) args) ^ "):" ^ tstr ~stack ~detailed ret
 	| HMethod (args,ret) -> "method:(" ^ String.concat "," (List.map (tstr ~stack ~detailed) args) ^ "):" ^ tstr ~stack ~detailed ret
-	| HObj o when not detailed -> "#" ^ o.pname
-	| HObj o ->
+	| HObj o when not detailed -> o.pname
+	| HStruct s when not detailed -> "@" ^ s.pname
+	| HObj o | HStruct o ->
 		let fields = "{" ^ String.concat "," (List.map (fun(s,_,t) -> s ^ " : " ^ tstr ~detailed:false t) (Array.to_list o.pfields)) ^ "}" in
 		let proto = "{"  ^ String.concat "," (List.map (fun p -> (match p.fvirtual with None -> "" | Some _ -> "virtual ") ^ p.fname ^ "@" ^  string_of_int p.fmethod) (Array.to_list o.pproto)) ^ "}" in
-		"#" ^ o.pname ^ "[" ^ (match o.psuper with None -> "" | Some p -> ">" ^ p.pname ^ " ") ^ "fields=" ^ fields ^ " proto=" ^ proto ^ "]"
+		let str = o.pname ^ "[" ^ (match o.psuper with None -> "" | Some p -> ">" ^ p.pname ^ " ") ^ "fields=" ^ fields ^ " proto=" ^ proto ^ "]" in
+		(match t with HObj o -> str | _ -> "@" ^ str)
 	| HArray ->
 		"array"
 	| HType ->

src/generators/hlinterp.ml

@@ -41,6 +41,7 @@ type value =
 	| VEnum of enum_proto * int * value array
 	| VAbstract of vabstract
 	| VVarArgs of vfunction * value option
+	| VStruct of vobject
 
 and ref_value =
 	| RStack of int
@@ -163,6 +164,7 @@ let rec is_compatible v t =
 	| VRef (_,t1), HRef t2 -> tsame t1 t2
 	| VAbstract _, HAbstract _ -> true
 	| VEnum _, HEnum _ -> true
+	| VStruct v, HStruct _ -> safe_cast (HStruct v.oproto.pclass) t
 	| _ -> false
 
 type cast =
@@ -204,6 +206,10 @@ let alloc_obj ctx t =
 		let obj = VObj { oproto = p; ofields = ftable } in
 		List.iter (fun (fid,mk) -> ftable.(fid) <- mk obj) bindings;
 		obj
+	| HStruct p ->
+		let p, fields, bindings = get_proto ctx p in
+		let ftable = Array.map default fields in
+		VStruct { oproto = p; ofields = ftable }
 	| HVirtual v ->
 		let o = {
 			dfields = Hashtbl.create 0;
@@ -346,7 +352,7 @@ let rec vstr_d ctx v =
 	| VBool b -> if b then "true" else "false"
 	| VDyn (v,t) -> "dyn(" ^ vstr_d v ^ ":" ^ tstr t ^ ")"
 	| VObj o ->
-		let p = "#" ^ o.oproto.pclass.pname in
+		let p = o.oproto.pclass.pname in
 		(match get_to_string ctx o.oproto.pclass with
 		| Some f -> p ^ ":" ^ vstr_d (ctx.fcall f [v])
 		| None -> p)
@@ -364,6 +370,7 @@ let rec vstr_d ctx v =
 	| VEnum (e,i,vals) -> let n, _, _ = e.efields.(i) in if Array.length vals = 0 then n else n ^ "(" ^ String.concat "," (Array.to_list (Array.map vstr_d vals)) ^ ")"
 	| VAbstract _ -> "abstract"
 	| VVarArgs _ -> "varargs"
+	| VStruct v -> "@" ^ v.oproto.pclass.pname
 
 let rec to_virtual ctx v vp =
 	match v with
@@ -563,7 +570,7 @@ let rec dyn_get_field ctx obj field rt =
 			get_with d.dvalues.(idx) d.dtypes.(idx)
 		with Not_found ->
 			default rt)
-	| VObj o ->
+	| VObj o | VDyn (VStruct o, HStruct _) ->
 		let default rt =
 			match get_method o.oproto.pclass "__get_field" with
 			| None -> default rt
@@ -705,7 +712,7 @@ let rec vstr ctx v t =
 		vstr v t
 	| VObj o ->
 		(match get_to_string ctx o.oproto.pclass with
-		| None -> "#" ^ o.oproto.pclass.pname
+		| None -> o.oproto.pclass.pname
 		| Some f -> vstr (ctx.fcall f [v]) HBytes)
 	| VBytes b -> (try hl_to_caml b with _ -> "?" ^ String.escaped b)
 	| VClosure (f,_) -> fstr f
@@ -738,6 +745,7 @@ let rec vstr ctx v t =
 			in
 			n ^ "(" ^ String.concat "," (loop 0) ^ ")"
 	| VVarArgs _ -> "varargs"
+	| VStruct s -> "@" ^ s.oproto.pclass.pname
 
 let interp ctx f args =
 	let func = get_function ctx in
@@ -897,7 +905,7 @@ let interp ctx f args =
 			set r (alloc_obj ctx (rtype r))
 		| OField (r,o,fid) ->
 			set r (match get o with
-				| VObj v -> v.ofields.(fid)
+				| VObj v | VStruct v -> v.ofields.(fid)
 				| VVirtual v as obj ->
 					(match v.vindexes.(fid) with
 					| VFNone -> dyn_get_field ctx obj (let n,_,_ = v.vtype.vfields.(fid) in n) (rtype r)
@@ -908,7 +916,7 @@ let interp ctx f args =
 			let rv = get r in
 			let o = get o in
 			(match o with
-			| VObj v ->
+			| VObj v | VStruct v ->
 				check_obj rv o fid;
 				v.ofields.(fid) <- rv
 			| VVirtual v ->
@@ -921,10 +929,10 @@ let interp ctx f args =
 			| VNull -> null_access()
 			| _ -> assert false)
 		| OGetThis (r, fid) ->
-			set r (match get 0 with VObj v -> v.ofields.(fid) | _ -> assert false)
+			set r (match get 0 with VObj v | VStruct v -> v.ofields.(fid) | _ -> assert false)
 		| OSetThis (fid, r) ->
 			(match get 0 with
-			| VObj v as o ->
+			| (VObj v | VStruct v) as o ->
 				let rv = get r in
 				check_obj rv o fid;
 				v.ofields.(fid) <- rv
@@ -1073,7 +1081,8 @@ let interp ctx f args =
 					| HAbstract _ -> 17
 					| HEnum _ -> 18
 					| HNull _ -> 19
-					| HMethod _ -> 20)))
+					| HMethod _ -> 20
+					| HStruct _ -> 21)))
 				| _ -> assert false);
 		| ORef (r,v) ->
 			set r (VRef (RStack (v + spos),rtype v))
@@ -2251,11 +2260,16 @@ let check code macros =
 		let is_dyn r =
 			if not (is_dynamic (rtype r)) then error (reg_inf r ^ " should be castable to dynamic")
 		in
+		let get_field r p fid =
+			try snd (resolve_field p fid) with Not_found -> error (reg_inf r ^ " does not have field " ^ string_of_int fid)
+		in
 		let tfield o fid proto =
 			if fid < 0 then error (reg_inf o ^ " does not have " ^ (if proto then "proto " else "") ^ "field " ^ string_of_int fid);
 			match rtype o with
 			| HObj p ->
-				if proto then ftypes.(p.pvirtuals.(fid)) else (try snd (resolve_field p fid) with Not_found -> error (reg_inf o ^ " does not have field " ^ string_of_int fid))
+				if proto then ftypes.(p.pvirtuals.(fid)) else get_field o p fid
+			| HStruct p when not proto ->
+				get_field o p fid
 			| HVirtual v when not proto ->
 				let _,_, t = v.vfields.(fid) in
 				t
@@ -2384,7 +2398,7 @@ let check code macros =
 				()
 			| ONew r ->
 				(match rtype r with
-				| HDynObj | HVirtual _ -> ()
+				| HDynObj | HVirtual _ | HStruct _ -> ()
 				| _ -> is_obj r)
 			| OField (r,o,fid) ->
 				check (tfield o fid false) (rtype r)