hlc hello world ok

genhl.ml

@@ -308,6 +308,27 @@ let list_iteri f l =
 let is_extern_field f =
 	Type.is_extern_field f || (match f.cf_kind with Method MethNormal -> List.exists (fun (m,_,_) -> m = Meta.Custom ":hlNative") f.cf_meta | _ -> false)
 
+let resolve_field p fid =
+	let rec loop pl p =
+		let pl = p :: pl in
+		match p.psuper with
+		| None ->
+			let rec fetch id = function
+				| [] -> raise Not_found
+				| p :: pl ->
+					let d = id - Array.length p.pfields in
+					if d < 0 then
+						let name, _, t = p.pfields.(id) in
+						name, t
+					else
+						fetch d pl
+			in
+			fetch fid pl
+		| Some p ->
+			loop pl p
+	in
+	loop [] p
+
 let rec tstr ?(stack=[]) ?(detailed=false) t =
 	match t with
 	| HVoid -> "void"
@@ -3039,25 +3060,7 @@ let check code =
 			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 ->
-				let rec loop pl p =
-					let pl = p :: pl in
-					match p.psuper with
-					| None ->
-						let rec fetch id = function
-							| [] -> error (reg_inf o ^ " does not have " ^ (if proto then "proto " else "") ^ "field " ^ string_of_int fid)
-							| p :: pl ->
-								let d = id - Array.length p.pfields in
-								if d < 0 then
-									let _, _, t = p.pfields.(id) in
-									t
-								else
-									fetch d pl
-						in
-						fetch fid pl
-					| Some p ->
-						loop pl p
-				in
-				if proto then ftypes.(p.pvirtuals.(fid)) else loop [] 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))
 			| HVirtual v when not proto ->
 				let _,_, t = v.vfields.(fid) in
 				t
@@ -4741,7 +4744,7 @@ let interp code =
 					in
 					VBool (if e1 != e2 then false else loop v1 v2 e1)
 				| _ -> assert false)
-			| "get_field" ->
+			| "obj_get_field" ->
 				(function
 				| [o;VInt hash] ->
 					let f = (try Hashtbl.find hash_cache hash with Not_found -> assert false) in
@@ -4749,14 +4752,14 @@ let interp code =
 					| VObj _ | VDynObj _ | VVirtual _ -> dyn_get_field o f HDyn
 					| _ -> VNull)
 				| _ -> assert false)
-			| "set_field" ->
+			| "obj_set_field" ->
 				(function
 				| [o;VInt hash;v] ->
 					let f = (try Hashtbl.find hash_cache hash with Not_found -> assert false) in
 					dyn_set_field o f v HDyn;
 					VUndef
 				| _ -> assert false)
-			| "has_field" ->
+			| "obj_has_field" ->
 				(function
 				| [o;VInt hash] ->
 					let f = (try Hashtbl.find hash_cache hash with Not_found -> assert false) in
@@ -4773,7 +4776,7 @@ let interp code =
 					in
 					VBool (loop o)
 				| _ -> assert false)
-			| "delete_field" ->
+			| "obj_delete_field" ->
 				(function
 				| [o;VInt hash] ->
 					let f = (try Hashtbl.find hash_cache hash with Not_found -> assert false) in
@@ -5546,6 +5549,7 @@ let write_c version ch (code:code) =
 	let line str = IO.write_line ch (!tabs ^ str) in
 	let expr str = line (str ^ ";") in
 	let sexpr fmt = Printf.ksprintf expr fmt in
+	let sprintf = Printf.sprintf in
 
 	let keywords =
 		let h = Hashtbl.create 0 in
@@ -5579,6 +5583,30 @@ let write_c version ch (code:code) =
 		| HEnum e -> tname e.ename
 		| HNull _ -> "vdynamic*"
 	in
+
+	let type_id t =
+		match t with
+		| HVoid -> "HVOID"
+		| HI8 -> "HI8"
+		| HI16 -> "HI16"
+		| HI32 -> "HI32"
+		| HF32 -> "HF32"
+		| HF64 -> "HF64"
+		| HBool -> "HBOOL"
+		| HBytes -> "HBYTES"
+		| HDyn -> "HDYN"
+		| HFun _ -> "HFUN"
+		| HObj _ -> "HOBJ"
+		| HArray -> "HARRAY"
+		| HType -> "HTYPE"
+		| HRef _ -> "HREF"
+		| HVirtual _ -> "HVIRTUAL"
+		| HDynObj -> "HDYNOBJ"
+		| HAbstract _ -> "HABSTRACT"
+		| HEnum _ -> "HENUM"
+		| HNull _ -> "HNULL"
+	in
+
 	let var_type n t =
 		ctype t ^ " " ^ ident n
 	in
@@ -5589,11 +5617,11 @@ let write_c version ch (code:code) =
 	let ver_str = Printf.sprintf "%d.%d.%d" version_major version_minor version_revision in
 	line ("// Generated by HLC " ^ ver_str ^ " (HL v" ^ string_of_int code.version ^")");
 	line "#include <hl.h>";
-	line "";
-	line "// Types definitions";
 	let types = gather_types code in
 	let tfuns = Array.create (Array.length code.functions + Array.length code.natives) ([],HVoid) in
-	(* predecl types *)
+
+	line "";
+	line "// Types definitions";
 	DynArray.iter (fun t ->
 		match t with
 		| HObj o ->
@@ -5607,6 +5635,7 @@ let write_c version ch (code:code) =
 		| _ ->
 			()
 	) types.arr;
+
 	line "";
 	line "// Types implementation";
 	DynArray.iter (fun t ->
@@ -5629,13 +5658,27 @@ let write_c version ch (code:code) =
 			()
 	) types.arr;
 
+	line "";
+	line "// Types values declaration";
+	DynArray.iteri (fun i t ->
+		sexpr "static hl_type type$%d = { %s } /* %s */" i (type_id t) (tstr t);
+		match t with
+		| HObj o ->
+			line (Printf.sprintf "#define %s__val &type$%d" (tname o.pname) i)
+		| HEnum e ->
+			line (Printf.sprintf "#define %s__val &type$%d" (tname e.ename) i)
+		| _ ->
+			()
+	) types.arr;
+
+	line "";
 	line "// Globals";
 	Array.iteri (fun i t ->
 		let name = "global$" ^ string_of_int i in
 		sexpr "static %s = 0" (var_type name t)
 	) code.globals;
-	line "";
 
+	line "";
 	line "// Natives functions";
 	Array.iter (fun (lib,name,t,idx) ->
 		match t with
@@ -5651,6 +5694,7 @@ let write_c version ch (code:code) =
 		| _ ->
 			assert false
 	) code.natives;
+
 	line "";
 	line "// Functions declaration";
 	Array.iter (fun f ->
@@ -5661,7 +5705,7 @@ let write_c version ch (code:code) =
 		| _ ->
 			assert false
 	) code.functions;
-	sexpr "void hl_entry_point() { fun$%d(); }" code.entrypoint;
+
 	line "";
 	line "// Strings";
 	Array.iteri (fun i str ->
@@ -5671,8 +5715,99 @@ let write_c version ch (code:code) =
 			let c = String.get s i in
 			string_of_int (int_of_char c) :: loop (i+1)
 		in
-		sexpr "vbytes string$%d[] = {%s} /* %s */" i (String.concat "," (loop 0)) str
+		sexpr "static vbytes string$%d[] = {%s} /* %s */" i (String.concat "," (loop 0)) str
 	) code.strings;
+
+	let type_value t =
+		let index = lookup types t (fun() -> assert false) in
+		"&type$" ^ string_of_int index
+	in
+
+	line "";
+	line "// Types values data";
+	DynArray.iteri (fun i t ->
+		match t with
+		| HObj o ->
+			let field_value (name,name_id,t) =
+				sprintf "{(const uchar*)string$%d, %s, %ld}" name_id (type_value t) (hash name)
+			in
+			let proto_value p =
+				sprintf "{(const uchar*)string$%d, %d, %d, %ld}" p.fid p.fmethod (match p.fvirtual with None -> -1 | Some i -> i) (hash p.fname)
+			in
+			let fields =
+				if Array.length o.pfields = 0 then "NULL" else
+				let name = sprintf "fields$%d" i in
+				sexpr "static hl_obj_field %s[] = {%s}" name (String.concat "," (List.map field_value (Array.to_list o.pfields)));
+				name
+			in
+			let proto =
+				if Array.length o.pproto = 0 then "NULL" else
+				let name = sprintf "proto$%d" i in
+				sexpr "static hl_obj_proto %s[] = {%s}" name (String.concat "," (List.map proto_value (Array.to_list o.pproto)));
+				name
+			in
+			let ofields = [
+				string_of_int (Array.length o.pfields);
+				string_of_int (Array.length o.pproto);
+				sprintf "(const uchar*)string$%d" o.pid;
+				(match o.psuper with None -> "NULL" | Some c -> sprintf "%s__val" (tname c.pname));
+				fields;
+				proto
+			] in
+			sexpr "static hl_type_obj obj$%d = {%s}" i (String.concat "," ofields);
+		| HEnum _ ->
+			()
+		| _ ->
+			()
+	) types.arr;
+
+
+	line "";
+	line "// Entry point";
+	line "void hl_entry_point() {";
+	block();
+	let rec loop i =
+		if i = Array.length code.functions + Array.length code.natives then [] else
+		("fun$" ^ string_of_int i) :: loop (i + 1)
+	in
+	sexpr "static void *functions_ptrs[] = {%s}" (String.concat "," (loop 0));
+	let rec loop i =
+		if i = Array.length code.functions + Array.length code.natives then [] else
+		let args, t = tfuns.(i) in
+		(type_value (HFun (args,t))) :: loop (i + 1)
+	in
+	sexpr "static hl_type *functions_types[] = {%s}" (String.concat "," (loop 0));
+	expr "hl_module_context ctx";
+	expr "hl_alloc_init(&ctx.alloc)";
+	expr "ctx.functions_ptrs = functions_ptrs";
+	expr "ctx.functions_types = functions_types";
+	DynArray.iteri (fun i t ->
+		match t with
+		| HObj o ->
+			sexpr "obj$%d.m = &ctx" i;
+			sexpr "type$%d.obj = &obj$%d" i i;
+		| HEnum _ ->
+			line "// TODO : enum"
+		| _ ->
+			()
+	) types.arr;
+	sexpr "fun$%d()" code.entrypoint;
+	unblock();
+	line "}";
+
+	line "";
+	line "// Static data";
+	Array.iter (fun f ->
+		Array.iteri (fun i op ->
+			match op with
+			| OGetFunction (_,fid) ->
+				let args, t = tfuns.(fid) in
+				sexpr "static vclosure cl$%d = { %s, fun$%d, 0 }" fid (type_value (HFun (args,t))) fid;
+			| _ ->
+				()
+		) f.code
+	) code.functions;
+
 	line "";
 	line "// Functions code";
 	Array.iter (fun f ->
@@ -5704,9 +5839,31 @@ let write_c version ch (code:code) =
 			sexpr "%sfun$%d(%s)" rstr fid (String.concat "," (List.map2 rcast args targs))
 		in
 
+		let set_field obj fid v =
+			match rtype obj with
+			| HObj o ->
+				let name, t = resolve_field o fid in
+				sexpr "%s->%s = %s" (reg obj) (ident name) (rcast v t)
+			| HVirtual v ->
+				sexpr "hl_fatal(\"%s\")" "SETFIELD-VIRTUAL"
+			| _ ->
+				assert false
+		in
+
+		let get_field r obj fid =
+			match rtype obj with
+			| HObj o ->
+				let name, t = resolve_field o fid in
+				sexpr "%s%s->%s" (rassign r t) (reg obj) (ident name)
+			| HVirtual v ->
+				sexpr "hl_fatal(\"%s\")" "GETFIELD-VIRTUAL"
+			| _ ->
+				assert false
+		in
+
 		let fret = (match f.ftype with
 		| HFun (args,t) ->
-			line (Printf.sprintf "%s fun$%d(%s) {" (ctype t) f.findex (String.concat "," (List.map (fun t -> incr rid; var_type (reg !rid) t) args)));
+			line (Printf.sprintf "static %s fun$%d(%s) {" (ctype t) f.findex (String.concat "," (List.map (fun t -> incr rid; var_type (reg !rid) t) args)));
 			t
 		| _ ->
 			assert false
@@ -5801,7 +5958,10 @@ let write_c version ch (code:code) =
 	| OCallMethod of reg * field index * reg list
 	| OCallThis of reg * field index * reg list
 	| OCallClosure of reg * reg * reg list
-	| OGetFunction of reg * functable index (* closure *)
+	*)
+			| OGetFunction (r,fid) ->
+				sexpr "%s = &cl$%d" (reg r) fid
+	(*
 	| OClosure of reg * functable index * reg (* closure *)
 	*)
 
@@ -5837,39 +5997,71 @@ let write_c version ch (code:code) =
 				if not (flabels.(i)) then line (label (-1) ^ ":")
 
 			(*
-	| OToDyn of reg * reg
-	| OToSFloat of reg * reg
-	| OToUFloat of reg * reg
-	| OToInt of reg * reg
-	| ONew of reg
-	| OField of reg * reg * field index
+	| OToDyn of reg * reg *)
+
+			| OToSFloat (r,v) ->
+				sexpr "%s = %s" (reg r) (reg v)
+			| OToUFloat (r,v) ->
+				sexpr "%s = (unsigned)%s" (reg r) (reg v)
+			| OToInt (r,v) ->
+				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) (tname o.pname ^ "__val")
+				| HDynObj -> sexpr "%s = hl_alloc_dynobj()" (reg r)
+				| _ -> assert false)
+			| OField (r,obj,fid) ->
+				get_field r obj fid
+	(*
 	| OMethod of reg * reg * field index (* closure *)
-	| OSetField of reg * field index * reg
-	| OGetThis of reg * field index
-	| OSetThis of field index * reg
+	*)
+
+			| OSetField (obj,fid,v) ->
+				set_field obj fid v
+			| OGetThis (r,fid) ->
+				get_field r 0 fid
+			| OSetThis (fid,r) ->
+				set_field 0 fid r
+	(*
 	| OThrow of reg
 	| ORethrow of reg
-	| OGetI8 of reg * reg * reg
-	| OGetI32 of reg * reg * reg
-	| OGetF32 of reg * reg * reg
-	| OGetF64 of reg * reg * reg
-	| OGetArray of reg * reg * reg
-	| OSetI8 of reg * reg * reg
-	| OSetI32 of reg * reg * reg
-	| OSetF32 of reg * reg * reg
-	| OSetF64 of reg * reg * reg
+	*)
+			| OGetI8 (r,b,idx) ->
+				sexpr "%s = *(unsigned char*)(%s + %s)" (reg r) (reg b) (reg idx)
+			| OGetI32 (r,b,idx) ->
+				sexpr "%s = *(int*)(%s + %s)" (reg r) (reg b) (reg idx)
+			| OGetF32 (r,b,idx) ->
+				sexpr "%s = *(float*)(%s + %s)" (reg r) (reg b) (reg idx)
+			| OGetF64 (r,b,idx) ->
+				sexpr "%s = *(double*)(%s + %s)" (reg r) (reg b) (reg idx)
+(*	| OGetArray of reg * reg * reg *)
+			| OSetI8 (b,idx,r) ->
+				sexpr "*(unsigned char*)(%s + %s) = %s" (reg b) (reg idx) (reg r)
+			| OSetI32 (b,idx,r) ->
+				sexpr "*(int*)(%s + %s) = %s" (reg b) (reg idx) (reg r)
+			| OSetF32 (b,idx,r) ->
+				sexpr "*(float*)(%s + %s) = %s" (reg b) (reg idx) (reg r)
+			| OSetF64 (b,idx,r) ->
+				sexpr "*(double*)(%s + %s) = %s" (reg b) (reg idx) (reg r)
+(*
 	| OSetArray of reg * reg * reg
 	| OSafeCast of reg * reg
 	| OUnsafeCast of reg * reg
 	| OArraySize of reg * reg
 	| OError of string index
-	| OType of reg * ttype
-	| OGetType of reg * reg
+	*)
+			| OType (r,t) ->
+				sexpr "%s = %s" (reg r) (type_value t)
+	(*| OGetType of reg * reg
 	| OGetTID of reg * reg
-	| ORef of reg * reg
-	| OUnref of reg * reg
-	| OSetref of reg * reg
-	| OToVirtual of reg * reg
+	*)
+			| ORef (r,v) ->
+				sexpr "%s = &%s" (reg r) (reg v)
+			| OUnref (r,v) ->
+				sexpr "%s = *%s" (reg r) (reg v)
+			| OSetref (r,v) ->
+				sexpr "*%s = %s" (reg r) (reg v)
+	(* | OToVirtual of reg * reg
 	| OUnVirtual of reg * reg
 	| ODynGet of reg * reg * string index
 	| ODynSet of reg * string index * reg
@@ -5879,7 +6071,10 @@ let write_c version ch (code:code) =
 	| OEnumField of reg * reg * field index * int
 	| OSetEnumField of reg * int * reg
 	| OSwitch of reg * int array
-	| ONullCheck of reg
+	*)
+			| ONullCheck r ->
+				sexpr "if( %s == NULL ) hl_error_msg(USTR(\"Null access\"))" (reg r)
+	(*
 	| OTrap of reg * int
 	| OEndTrap of unused
 	| ODump of reg*)

std/hl/types/Api.hx

@@ -2,14 +2,14 @@ package hl.types;
 
 extern class Api {
 
-	@:hlNative("std","get_field") static function getField( obj : Dynamic, hash : Int ) : Dynamic;
-	@:hlNative("std","set_field") static function setField( obj : Dynamic, hash : Int, value : Dynamic ) : Void;
-	@:hlNative("std","has_field") static function hasField( obj : Dynamic, hash : Int ) : Bool;
-	@:hlNative("std","delete_field") static function deleteField( obj : Dynamic, hash : Int ) : Bool;
+	@:hlNative("std","obj_get_field") static function getField( obj : Dynamic, hash : Int ) : Dynamic;
+	@:hlNative("std","obj_set_field") static function setField( obj : Dynamic, hash : Int, value : Dynamic ) : Void;
+	@:hlNative("std","obj_has_field") static function hasField( obj : Dynamic, hash : Int ) : Bool;
+	@:hlNative("std","obj_delete_field") static function deleteField( obj : Dynamic, hash : Int ) : Bool;
 	@:hlNative("std","call_method") static function callMethod( f : haxe.Constraints.Function, args : NativeArray<Dynamic> ) : Dynamic;
 	@:hlNative("std","get_closure_value") static function getClosureValue( f : haxe.Constraints.Function ) : Dynamic;
 	@:hlNative("std","no_closure") static function noClosure( f : haxe.Constraints.Function ) : haxe.Constraints.Function;
 	@:hlNative("std", "safe_cast") static function safeCast( v : Dynamic, t : Type ) : Dynamic;
-	@:hlNative("std", "make_var_args") static function makeVarArgs( v : NativeArray<Dynamic> -> Dynamic ) : Dynamic;
+	@:hlNative("std", "make_var_args") static function makeVarArgs( v : NativeArray<Dynamic> -> Dynamic ) : haxe.Constraints.Function;
 
 }