(* * haXe/CPP Compiler * Copyright (c)2008 Hugh Sanderson * based on and including code by (c)2005-2008 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Ast open Type open Common (* Code for generating source files. It manages creating diretories, indents, blocks and only modifying files when the content changes. *) (* A class_path is made from a package (array of strings) and a class name. Join these together, inclding a separator. eg, "/" for includes : pack1/pack2/Name or "::" for namespace "pack1::pack2::Name" *) let join_class_path path separator = let result = match fst path, snd path with | [], s -> s | el, s -> String.concat separator el ^ separator ^ s in if (String.contains result '+') then begin let idx = String.index result '+' in (String.sub result 0 idx) ^ (String.sub result (idx+1) ((String.length result) - idx -1 ) ) end else result;; class source_writer write_func close_func= object(this) val indent_str = "\t" val mutable indent = "" val mutable indents = [] val mutable just_finished_block = false method close = close_func(); () method write x = write_func x; just_finished_block <- false method indent_one = this#write indent_str method push_indent = indents <- indent_str::indents; indent <- String.concat "" indents method pop_indent = match indents with | h::tail -> indents <- tail; indent <- String.concat "" indents | [] -> indent <- "/*?*/"; method write_i x = this#write (indent ^ x) method get_indent = indent method begin_block = this#write ("{\n"); this#push_indent method end_block = this#pop_indent; this#write_i "}\n"; just_finished_block <- true method end_block_line = this#pop_indent; this#write_i "}"; just_finished_block <- true method terminate_line = this#write (if just_finished_block then "" else ";\n") method add_include class_path = this#write ("#ifndef INCLUDED_" ^ (join_class_path class_path "_") ^ "\n"); this#write ("#include <" ^ (join_class_path class_path "/") ^ ".h>\n"); this#write ("#endif\n") end;; let file_source_writer filename = let out_file = open_out filename in new source_writer (output_string out_file) (fun ()-> close_out out_file);; let read_whole_file chan = Std.input_all chan;; (* The cached_source_writer will not write to the file if it has not changed, thus allowing the makefile dependencies to work correctly *) let cached_source_writer filename = try let in_file = open_in filename in let old_contents = read_whole_file in_file in close_in in_file; let buffer = Buffer.create 0 in let add_buf str = Buffer.add_string buffer str in let close = fun () -> let contents = Buffer.contents buffer in if (not (contents=old_contents) ) then begin let out_file = open_out filename in output_string out_file contents; close_out out_file; end; in new source_writer (add_buf) (close); with _ -> file_source_writer filename;; let rec make_class_directories base dir_list = ( match dir_list with | [] -> () | dir :: remaining -> let path = match base with | "" -> dir | "/" -> "/" ^ dir | _ -> base ^ "/" ^ dir in if ( not ( (path="") || ( ((String.length path)=2) && ((String.sub path 1 1)=":") ) ) ) then if not (Sys.file_exists path) then Unix.mkdir path 0o755; make_class_directories (if (path="") then "/" else path) remaining );; let new_source_file base_dir sub_dir extension class_path = make_class_directories base_dir ( sub_dir :: (fst class_path)); cached_source_writer ( base_dir ^ "/" ^ sub_dir ^ "/" ^ ( String.concat "/" (fst class_path) ) ^ "/" ^ (snd class_path) ^ extension);; let new_cpp_file base_dir = new_source_file base_dir "src" ".cpp";; let new_header_file base_dir = new_source_file base_dir "include" ".h";; let make_base_directory file = make_class_directories "" ( ( Str.split_delim (Str.regexp "[\\/]+") file ) ); (* CPP code generation context *) type context = { mutable ctx_common : Common.context; mutable ctx_output : string -> unit; mutable ctx_dbgout : string -> unit; mutable ctx_writer : source_writer; mutable ctx_calling : bool; mutable ctx_assigning : bool; mutable ctx_return_from_block : bool; (* This is for returning from the child nodes of TMatch, TSwitch && TTry *) mutable ctx_return_from_internal_node : bool; mutable ctx_debug : bool; mutable ctx_debug_type : bool; mutable ctx_real_this_ptr : bool; mutable ctx_dynamic_this_ptr : bool; mutable ctx_push_src_pos : string; mutable ctx_static_id_curr : int; mutable ctx_static_id_used : int; mutable ctx_static_id_depth : int; mutable ctx_switch_id : int; mutable ctx_class_name : string; mutable ctx_local_function_args : (string,string) Hashtbl.t; mutable ctx_local_return_block_args : (string,string) Hashtbl.t; mutable ctx_class_member_types : (string,string) Hashtbl.t; } let new_context common_ctx writer debug = { ctx_common = common_ctx; ctx_writer = writer; ctx_output = (writer#write); ctx_dbgout = if debug then (writer#write) else (fun _ -> ()); ctx_calling = false; ctx_assigning = false; ctx_debug = debug; ctx_debug_type = debug; ctx_push_src_pos = ""; ctx_return_from_block = false; ctx_return_from_internal_node = false; ctx_real_this_ptr = true; ctx_dynamic_this_ptr = false; ctx_static_id_curr = 0; ctx_static_id_used = 0; ctx_static_id_depth = 0; ctx_switch_id = 0; ctx_class_name = ""; ctx_local_function_args = Hashtbl.create 0; ctx_local_return_block_args = Hashtbl.create 0; ctx_class_member_types = Hashtbl.create 0; } (* The internal classes are implemented by the core hxcpp system, so the cpp classes should not be generated *) let is_internal_class = function | ([],"Int") | ([],"Void") | ([],"String") | ([], "Null") | ([], "Float") | ([],"Array") | ([], "Class") | ([], "Enum") | ([], "Bool") | ([], "Dynamic") | ([], "ArrayAccess") | (["cpp"], "FastIterator")-> true | (["cpp"], "CppInt32__") | ([],"Math") | (["haxe";"io"], "Unsigned_char__") -> true | _ -> false (* The internal header files are also defined in the hx/Object.h file, so you do #include them separately. However, the Int32 and Math classes do have their own header files (these are under the hxcpp tree) so these should be included *) let include_class_header = function | ([],"@Main") -> false | (["cpp"], "CppInt32__") | ([],"Math") -> true | path -> not ( is_internal_class path ) let is_cpp_class = function | ("cpp"::_ , _) -> true | ( [] , "Xml" ) -> true | ( [] , "EReg" ) -> true | ( ["haxe"] , "Log" ) -> true | _ -> false;; let is_block exp = match exp.eexpr with | TBlock _ -> true | _ -> false ;; let to_block expression = if is_block expression then expression else (mk_block expression);; (* todo - is this how it's done? *) let hash_keys hash = let key_list = ref [] in Hashtbl.iter (fun key value -> key_list := key :: !key_list ) hash; !key_list;; let pmap_keys pmap = let key_list = ref [] in PMap.iter (fun key value -> key_list := key :: !key_list ) pmap; !key_list;; (* The Hashtbl structure seems a little odd - but here is a helper function *) let hash_iterate hash visitor = let result = ref [] in Hashtbl.iter (fun key value -> result := (visitor key value) :: !result ) hash; !result (* Convert function names that can't be written in c++ ... *) let keyword_remap name = match name with | "int" | "auto" | "char" | "const" | "delete" | "double" | "enum" | "extern" | "float" | "friend" | "goto" | "long" | "operator" | "protected" | "register" | "short" | "signed" | "sizeof" | "template" | "typedef" | "union" | "unsigned" | "void" | "volatile" | "or" | "and" | "xor" | "or_eq" | "not" | "and_eq" | "xor_eq" | "typeof" | "stdin" | "stdout" | "stderr" | "BIG_ENDIAN" | "LITTLE_ENDIAN" | "assert" | "NULL" | "wchar_t" | "EOF" | "bool" | "const_cast" | "dynamic_cast" | "explicit" | "export" | "mutable" | "namespace" | "reinterpret_cast" | "static_cast" | "typeid" | "typename" | "virtual" | "struct" -> "_" ^ name | "asm" -> "_asm_" | x -> x (* While #include "Math.h" sould be different from "#include ", and it may be possible to use include paths to get this right, I think it is easier just to chnage the name *) let include_remap = function | ([],"Math") -> ([],"hxMath") | x -> x;; let get_code meta key = let rec loop = function | [] -> "" | (k,[Ast.EConst (Ast.String name),_],_) :: _ when k=key-> name ^ "\n" | _ :: l -> loop l in loop meta ;; (* Add include to source code *) let add_include writer class_path = writer#add_include (include_remap class_path);; (* This gets the class include order correct. In the header files, we forward declare the class types so the header file does not have any undefined variables. In the cpp files, we include all the required header files, providing the actual types for everything. This way there is no problem with circular class references. *) let gen_forward_decl writer class_path = if ( class_path = (["cpp"],"CppInt32__")) then writer#add_include class_path else begin let output = writer#write in output ("HX_DECLARE_CLASS" ^ (string_of_int (List.length (fst class_path) ) ) ^ "("); List.iter (fun package_part -> output (package_part ^ ",") ) (fst class_path); output ( (snd class_path) ^ ")\n") end;; let real_interfaces = List.filter (function (t,pl) -> match t, pl with | { cl_path = ["cpp";"rtti"],_ },[] -> false | _ -> true );; let rec is_function_expr expr = match expr.eexpr with | TParenthesis expr -> is_function_expr expr | TCast (e,None) -> is_function_expr e | TFunction _ -> true | _ -> false;; let rec has_rtti_interface c interface = List.exists (function (t,pl) -> (snd t.cl_path) = interface && (match fst t.cl_path with | ["cpp";"rtti"] -> true | _ -> false ) ) c.cl_implements || (match c.cl_super with None -> false | Some (c,_) -> has_rtti_interface c interface);; let has_field_integer_lookup class_def = has_rtti_interface class_def "FieldIntegerLookup";; let has_field_integer_numeric_lookup class_def = has_rtti_interface class_def "FieldNumericIntegerLookup";; (* Output required code to place contents in required namespace *) let gen_open_namespace output class_path = List.iter (fun namespace -> output ("namespace " ^ namespace ^ "{\n")) (fst class_path);; let gen_close_namespace output class_path = List.iter (fun namespace -> output ( "}" ^ " // end namespace " ^ namespace ^"\n")) (fst class_path);; (* The basic types can have default values and are passesby value *) let cant_be_null = function | "Int" | "Bool" | "Float" | "::String" | "::haxe::io::Unsigned_char__" -> true | "int" | "bool" | "double" -> true | _ -> false (* Get a string to represent a type. The "suffix" will be nothing or "_obj", depending if we want the name of the pointer class or the pointee (_obj class *) let rec class_string klass suffix params = (match klass.cl_path with (* Array class *) | ([],"Array") when is_dynamic_array_param (List.hd params) -> "Dynamic" | ([],"Array") -> (snd klass.cl_path) ^ suffix ^ "< " ^ (String.concat "," (List.map type_string params) ) ^ " >" (* FastIterator class *) | (["cpp"],"FastIterator") -> "::cpp::FastIterator" ^ suffix ^ "< " ^ (String.concat "," (List.map type_string params) ) ^ " >" | _ when klass.cl_kind=KTypeParameter -> "Dynamic" | ([],"#Int") -> "/* # */int" | (["haxe";"io"],"Unsigned_char__") -> "unsigned char" | ([],"Class") -> "::Class" | ([],"Null") -> (match params with | [t] -> (match follow t with | TInst ({ cl_path = [],"Int" },_) | TInst ({ cl_path = [],"Float" },_) | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic" | _ -> "/*NULL*/" ^ (type_string t) ) | _ -> assert false); (* Normal class *) | path when klass.cl_extern && (not (is_internal_class path) )-> (join_class_path klass.cl_path "::") ^ suffix | _ -> "::" ^ (join_class_path klass.cl_path "::") ^ suffix ) and type_string_suff suffix haxe_type = (match haxe_type with | TMono r -> (match !r with None -> "Dynamic" ^ suffix | Some t -> type_string_suff suffix t) | TEnum ({ e_path = ([],"Void") },[]) -> "Void" | TEnum ({ e_path = ([],"Bool") },[]) -> "bool" | TInst ({ cl_path = ([],"Float") },[]) -> "double" | TInst ({ cl_path = ([],"Int") },[]) -> "int" | TEnum (enum,params) -> "::" ^ (join_class_path enum.e_path "::") ^ suffix | TInst (klass,params) -> (class_string klass suffix params) | TType (type_def,params) -> (match type_def.t_path with | [] , "Null" -> (match params with | [t] -> (match follow t with | TInst ({ cl_path = [],"Int" },_) | TInst ({ cl_path = [],"Float" },_) | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic" ^ suffix | _ -> type_string_suff suffix t) | _ -> assert false); | [] , "Array" -> (match params with | [t] when (type_string (follow t)) = "Dynamic" -> "Dynamic" | [t] -> "Array< " ^ (type_string (follow t) ) ^ " >" | _ -> assert false) | ["cpp"] , "FastIterator" -> (match params with | [t] -> "::cpp::FastIterator< " ^ (type_string (follow t) ) ^ " >" | _ -> assert false) | _ -> type_string_suff suffix (apply_params type_def.t_types params type_def.t_type) ) | TFun (args,haxe_type) -> "Dynamic" ^ suffix | TAnon a -> "Dynamic" (* (match !(a.a_status) with | Statics c -> type_string_suff suffix (TInst (c,List.map snd c.cl_types)) | EnumStatics e -> type_string_suff suffix (TEnum (e,List.map snd e.e_types)) | _ -> "Dynamic" ^ suffix ) *) | TDynamic haxe_type -> "Dynamic" ^ suffix | TLazy func -> type_string_suff suffix ((!func)()) ) and type_string haxe_type = type_string_suff "" haxe_type and is_dynamic_array_param haxe_type = if (type_string (follow haxe_type)) = "Dynamic" then true else (match follow haxe_type with | TInst (klass,params) -> (match klass.cl_path with | ([],"Array") | ([],"Class") | (["cpp"],"FastIterator") -> false | _ -> klass.cl_kind = KTypeParameter ) | _ -> false ) ;; let is_array haxe_type = match follow haxe_type with | TInst (klass,params) -> (match klass.cl_path with | [] , "Array" -> not (is_dynamic_array_param (List.hd params)) | _ -> false ) | TType (type_def,params) -> (match type_def.t_path with | [] , "Array" -> not (is_dynamic_array_param (List.hd params)) | _ -> false ) | _ -> false ;; let is_array_implementer haxe_type = match follow haxe_type with | TInst (klass,params) -> (match klass.cl_array_access with | Some _ -> true | _ -> false ) | _ -> false ;; (* Get the type and output it to the stream *) let gen_type ctx haxe_type = ctx.ctx_output (type_string haxe_type) ;; (* Get the type and output it to the stream *) let gen_type_suff ctx haxe_type suff = ctx.ctx_output (type_string_suff suff haxe_type);; let member_type ctx field_object member = let name = (if (is_array field_object.etype) then "::Array" else (type_string field_object.etype)) ^ "." ^ member in try ( Hashtbl.find ctx.ctx_class_member_types name ) with Not_found -> "?";; let is_interface_type t = match follow t with | TInst (klass,params) -> klass.cl_interface | _ -> false ;; let is_interface obj = is_interface_type obj.etype;; let is_function_member expression = match (follow expression.etype) with | TFun (_,_) -> true | _ -> false;; let is_internal_member member = match member with | "__Field" | "__IField" | "__Run" | "__Is" | "__GetClass" | "__GetType" | "__ToString" | "__s" | "__GetPtr" | "__SetField" | "__length" | "__IsArray" | "__SetThis" | "__Internal" | "__EnumParams" | "__Index" | "__Tag" | "__GetFields" | "toString" | "__HasField" -> true | _ -> false;; let is_dynamic_accessor name acc field class_def = ( ( acc ^ "_" ^ field.cf_name) = name ) && ( not (List.exists (fun f -> f.cf_name=name) class_def.cl_ordered_fields) ) ;; let gen_arg_type_name name default_val arg_type prefix = let remap_name = keyword_remap name in let type_str = (type_string arg_type) in match default_val with | Some TNull -> (type_str,remap_name) | Some constant when (cant_be_null type_str) -> ("Dynamic",prefix ^ remap_name) | Some constant -> (type_str,prefix ^ remap_name) | _ -> (type_str,remap_name);; (* Generate prototype text, including allowing default values to be null *) let gen_arg name default_val arg_type prefix = let pair = gen_arg_type_name name default_val arg_type prefix in (fst pair) ^ " " ^ (snd pair);; let rec gen_arg_list arg_list prefix = String.concat "," (List.map (fun (v,o) -> (gen_arg v.v_name o v.v_type prefix) ) arg_list) let rec gen_tfun_arg_list arg_list = match arg_list with | [] -> "" | [(name,o,arg_type)] -> gen_arg name None arg_type "" | (name,o,arg_type) :: remaining -> (gen_arg name None arg_type "") ^ "," ^ (gen_tfun_arg_list remaining) (* Check to see if we are the first object in the parent tree to implement a dynamic interface *) let implement_dynamic_here class_def = let implements_dynamic c = match c.cl_dynamic with None -> false | _ -> true in let rec super_implements_dynamic c = match c.cl_super with | None -> false | Some (csup, _) -> if (implements_dynamic csup) then true else super_implements_dynamic csup; in ( (implements_dynamic class_def) && (not (super_implements_dynamic class_def) ) );; (* Make string printable for c++ code *) (* Here we know there are no utf8 characters, so use the L"" notation to avoid conversion *) let escape_stringw s l = let b = Buffer.create 0 in Buffer.add_char b 'L'; Buffer.add_char b '"'; let skip = ref 0 in for i = 0 to String.length s - 1 do if (!skip>0) then begin skip := !skip -1; l := !l-1; end else match Char.code (String.unsafe_get s i) with | c when (c>127) -> let encoded = ((c land 0x3F) lsl 6) lor ( Char.code ((String.unsafe_get s (i+1))) land 0x7F) in skip := 1; Buffer.add_string b (Printf.sprintf "\\x%X\"L\"" encoded) | c when (c < 32) -> Buffer.add_string b (Printf.sprintf "\\x%X\"L\"" c) | c -> Buffer.add_char b (Char.chr c) done; Buffer.add_char b '"'; Buffer.contents b;; let special_to_hex s = let l = String.length s in let b = Buffer.create 0 in for i = 0 to l - 1 do match Char.code (String.unsafe_get s i) with | c when (c>127) || (c<32) -> Buffer.add_string b (Printf.sprintf "\\x%02x\"\"" c) | c -> Buffer.add_char b (Char.chr c) done; Buffer.contents b;; let has_utf8_chars s = let result = ref false in for i = 0 to String.length s - 1 do result := !result || ( Char.code (String.unsafe_get s i) > 127 ) done; !result;; let escape_null s = let b = Buffer.create 0 in String.iter (fun ch -> if (ch=='\x00') then Buffer.add_string b "\\000" else Buffer.add_char b ch ) s; Buffer.contents b;; let str s = let escaped = Ast.s_escape s in let null_escaped = escape_null escaped in if (has_utf8_chars escaped) then begin (* Output both wide and thin versions - let the compiler choose ... *) let l = ref (String.length escaped) in let q = escape_stringw (Ast.s_escape s) l in ("HX_CSTRING2(" ^ q ^ "," ^ (string_of_int !l) ^ ",\"" ^ (special_to_hex null_escaped) ^ "\" )") end else (* The wide and thin versions are the same ... *) ("HX_CSTRING(\"" ^ null_escaped ^ "\")") ;; (* When we are in a "real" object, we refer to ourselves as "this", but if we are in a local class that is used to generate return values, we use the fake "__this" pointer. If we are in an "Anon" object, then the "this" refers to the anon object (eg List iterator) *) let clear_real_this_ptr ctx dynamic_this = let old_flag = ctx.ctx_real_this_ptr in let old_dynamic = ctx.ctx_dynamic_this_ptr in ctx.ctx_real_this_ptr <- false; ctx.ctx_dynamic_this_ptr <- dynamic_this; fun () -> ( ctx.ctx_real_this_ptr <- old_flag; ctx.ctx_dynamic_this_ptr <- old_dynamic; );; (* Generate temp variable names *) let next_anon_function_name ctx = ctx.ctx_static_id_curr <- ctx.ctx_static_id_curr + 1; "_Function_" ^ (string_of_int ctx.ctx_static_id_depth) ^"_"^ (string_of_int ctx.ctx_static_id_curr);; let use_anon_function_name ctx = ctx.ctx_static_id_used <- ctx.ctx_static_id_used + 1; "_Function_" ^ (string_of_int ctx.ctx_static_id_depth) ^"_"^ (string_of_int ctx.ctx_static_id_used);; let push_anon_names ctx = let old_used = ctx.ctx_static_id_used in let old_curr = ctx.ctx_static_id_curr in let old_depth = ctx.ctx_static_id_depth in ctx.ctx_static_id_used <- 0; ctx.ctx_static_id_curr <- 0; ctx.ctx_static_id_depth <- ctx.ctx_static_id_depth + 1; ( function () -> ( ctx.ctx_static_id_used <- old_used; ctx.ctx_static_id_curr <- old_curr; ctx.ctx_static_id_depth <- old_depth; ) ) ;; let get_switch_var ctx = ctx.ctx_switch_id <- ctx.ctx_switch_id + 1; "_switch_" ^ (string_of_int ctx.ctx_switch_id) (* If you put on the "-debug" flag, you get extra comments in the source code *) let debug_expression expression type_too = "/* " ^ Type.s_expr_kind expression ^ (if (type_too) then " = " ^ (type_string expression.etype) else "") ^ " */";; (* This is like the Type.iter, but also keeps the "retval" flag up to date *) let rec iter_retval f retval e = match e.eexpr with | TConst _ | TLocal _ | TEnumField _ | TBreak | TContinue | TTypeExpr _ -> () | TArray (e1,e2) | TBinop (_,e1,e2) -> f true e1; f true e2; | TWhile (e1,e2,_) -> f true e1; f false e2; | TFor (_,e1,e2) -> f true e1; f false e2; | TThrow e | TField (e,_) | TClosure (e,_) | TUnop (_,_,e) -> f true e | TParenthesis e -> f retval e | TBlock expr_list when retval -> let rec return_last = function | [] -> () | expr :: [] -> f true expr | expr :: exprs -> f false expr; return_last exprs in return_last expr_list | TArrayDecl el | TNew (_,_,el) -> List.iter (f true ) el | TBlock el -> List.iter (f false ) el | TObjectDecl fl -> List.iter (fun (_,e) -> f true e) fl | TCall (e,el) -> f true e; List.iter (f true) el | TVars vl -> List.iter (fun (_,e) -> match e with None -> () | Some e -> f true e) vl | TFunction fu -> f false fu.tf_expr | TIf (e,e1,e2) -> f true e; f retval e1; (match e2 with None -> () | Some e -> f retval e) | TSwitch (e,cases,def) -> f true e; List.iter (fun (el,e2) -> List.iter (f true) el; f retval e2) cases; (match def with None -> () | Some e -> f retval e) | TMatch (e,_,cases,def) -> f true e; List.iter (fun (_,_,e) -> f false e) cases; (match def with None -> () | Some e -> f false e) | TTry (e,catches) -> f retval e; List.iter (fun (_,e) -> f false e) catches | TReturn eo -> (match eo with None -> () | Some e -> f true e) | TCast (e,None) -> f retval e | TCast (e,_) -> f true e ;; (* Convert an array to a comma separated list of values *) let array_arg_list inList = let i = ref (0-1) in String.concat "," (List.map (fun _ -> incr i; "inArgs[" ^ (string_of_int !i) ^ "]" ) inList) let list_num l = string_of_int (List.length l);; let only_int_cases cases = match cases with | [] -> false | _ -> not (List.exists (fun (cases,expression) -> List.exists (fun case -> match case.eexpr with TConst (TInt _) -> false | _ -> true ) cases ) cases );; (* See if there is a haxe break statement that will be swollowed by c++ break *) exception BreakFound;; let contains_break expression = try ( let rec check_all expression = Type.iter (fun expr -> match expr.eexpr with | TBreak -> raise BreakFound | TFor _ | TFunction _ | TWhile (_,_,_) -> () | _ -> check_all expr; ) expression in check_all expression; false; ) with BreakFound -> true;; (* Decide is we should look the field up by name *) let dynamic_internal = function | "__Is" -> true | _ -> false (* Get a list of variables to extract from a enum tmatch *) let tmatch_params_to_args params = (match params with | None | Some [] -> [] | Some l -> let n = ref (-1) in List.fold_left (fun acc v -> incr n; match v with None -> acc | Some v -> (v.v_name,v.v_type,!n) :: acc) [] l) let rec is_null expr = match expr.eexpr with | TConst TNull -> true | TParenthesis expr -> is_null expr | TCast (e,None) -> is_null e | _ -> false ;; let find_undeclared_variables_ctx ctx undeclared declarations this_suffix allow_this expression = let output = ctx.ctx_output in let rec find_undeclared_variables undeclared declarations this_suffix allow_this expression = match expression.eexpr with | TVars var_list -> List.iter (fun (tvar, optional_init) -> Hashtbl.add declarations (keyword_remap tvar.v_name) (); if (ctx.ctx_debug) then output ("/* found var " ^ tvar.v_name ^ "*/ "); match optional_init with | Some expression -> find_undeclared_variables undeclared declarations this_suffix allow_this expression | _ -> () ) var_list | TFunction func -> List.iter ( fun (tvar, opt_val) -> if (ctx.ctx_debug) then output ("/* found arg " ^ tvar.v_name ^ " = " ^ (type_string tvar.v_type) ^ " */ "); Hashtbl.add declarations (keyword_remap tvar.v_name) () ) func.tf_args; find_undeclared_variables undeclared declarations this_suffix false func.tf_expr | TTry (try_block,catches) -> find_undeclared_variables undeclared declarations this_suffix allow_this try_block; List.iter (fun (tvar,catch_expt) -> let old_decs = Hashtbl.copy declarations in Hashtbl.add declarations (keyword_remap tvar.v_name) (); find_undeclared_variables undeclared declarations this_suffix allow_this catch_expt; Hashtbl.clear declarations; Hashtbl.iter ( Hashtbl.add declarations ) old_decs ) catches; | TLocal tvar -> let name = keyword_remap tvar.v_name in if not (Hashtbl.mem declarations name) then Hashtbl.replace undeclared name (type_string expression.etype) | TMatch (condition, enum, cases, default) -> find_undeclared_variables undeclared declarations this_suffix allow_this condition; List.iter (fun (case_ids,params,expression) -> let old_decs = Hashtbl.copy declarations in (match params with | None -> () | Some l -> List.iter (fun (opt_var) -> match opt_var with | Some v -> Hashtbl.add declarations (keyword_remap v.v_name) () | _ -> () ) l ); find_undeclared_variables undeclared declarations this_suffix allow_this expression; Hashtbl.clear declarations; Hashtbl.iter ( Hashtbl.add declarations ) old_decs ) cases; (match default with | None -> () | Some expr -> find_undeclared_variables undeclared declarations this_suffix allow_this expr; ); | TFor (tvar, init, loop) -> let old_decs = Hashtbl.copy declarations in Hashtbl.add declarations (keyword_remap tvar.v_name) (); find_undeclared_variables undeclared declarations this_suffix allow_this init; find_undeclared_variables undeclared declarations this_suffix allow_this loop; Hashtbl.clear declarations; Hashtbl.iter ( Hashtbl.add declarations ) old_decs | TConst TSuper | TConst TThis -> if ((not (Hashtbl.mem declarations "this")) && allow_this) then Hashtbl.replace undeclared "this" (type_string_suff this_suffix expression.etype) | TBlock expr_list -> let old_decs = Hashtbl.copy declarations in List.iter (find_undeclared_variables undeclared declarations this_suffix allow_this ) expr_list; (* what is the best way for this ? *) Hashtbl.clear declarations; Hashtbl.iter ( Hashtbl.add declarations ) old_decs | _ -> Type.iter (find_undeclared_variables undeclared declarations this_suffix allow_this) expression in find_undeclared_variables undeclared declarations this_suffix allow_this expression ;; let rec is_dynamic_in_cpp ctx expr = let expr_type = type_string ( match follow expr.etype with TFun (args,ret) -> ret | _ -> expr.etype) in ctx.ctx_dbgout ( "/* idic: " ^ expr_type ^ " */" ); if ( expr_type="Dynamic" ) then true else begin let result = ( match expr.eexpr with | TField( obj, name ) -> ctx.ctx_dbgout ("/* ?tfield "^name^" */"); if (is_dynamic_member_lookup_in_cpp ctx obj name) then ( ctx.ctx_dbgout "/* tf=dynobj */"; true ) else if (is_dynamic_member_return_in_cpp ctx obj name) then ( ctx.ctx_dbgout "/* tf=dynret */"; true ) else ( ctx.ctx_dbgout "/* tf=notdyn */"; false ) | TConst TThis when ((not ctx.ctx_real_this_ptr) && ctx.ctx_dynamic_this_ptr) -> ctx.ctx_dbgout ("/* dthis */"); true | TArray (obj,index) -> let dyn = is_dynamic_in_cpp ctx obj in ctx.ctx_dbgout ("/* aidr:" ^ (if dyn then "Dyn" else "Not") ^ " */"); dyn; | TTypeExpr _ -> false | TCall(func,args) -> (match follow func.etype with | TFun (args,ret) -> ctx.ctx_dbgout ("/* ret = "^ (type_string ret) ^" */"); is_dynamic_in_cpp ctx func | _ -> ctx.ctx_dbgout "/* not TFun */"; true ); | TParenthesis(expr) -> is_dynamic_in_cpp ctx expr | TCast (e,None) -> is_dynamic_in_cpp ctx e | TLocal { v_name = "__global__" } -> false | TConst TNull -> true | _ -> ctx.ctx_dbgout "/* other */"; false (* others ? *) ) in ctx.ctx_dbgout (if result then "/* Y */" else "/* N */" ); result end and is_dynamic_member_lookup_in_cpp ctx field_object member = ctx.ctx_dbgout ("/*mem."^member^".*/"); if (is_internal_member member) then false else if (match field_object.eexpr with | TTypeExpr _ -> ctx.ctx_dbgout "/*!TTypeExpr*/"; true | _ -> false) then false else if (is_dynamic_in_cpp ctx field_object) then true else if (is_array field_object.etype) then false else ( let tstr = type_string field_object.etype in ctx.ctx_dbgout ("/* ts:"^tstr^"*/"); match tstr with (* Internal classes have no dynamic members *) | "::String" | "Null" | "::Class" | "::Enum" | "::Math" | "::ArrayAccess" -> ctx.ctx_dbgout ("/* ok:" ^ (type_string field_object.etype) ^ " */"); false | "Dynamic" -> true | name -> let full_name = name ^ "." ^ member in ctx.ctx_dbgout ("/* t:" ^ full_name ^ " */"); try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in ctx.ctx_dbgout ("/* =" ^ mem_type ^ "*/"); false ) with Not_found -> true ) and is_dynamic_member_return_in_cpp ctx field_object member = if (is_array field_object.etype) then false else if (is_internal_member member) then false else match field_object.eexpr with | TTypeExpr t -> let full_name = "::" ^ (join_class_path (t_path t) "::" ) ^ "." ^ member in ctx.ctx_dbgout ("/*static:"^ full_name^"*/"); ( try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in mem_type="Dynamic" ) with Not_found -> true ) | _ -> let tstr = type_string field_object.etype in (match tstr with (* Internal classes have no dynamic members *) | "::String" | "Null" | "::Class" | "::Enum" | "::Math" | "::ArrayAccess" -> false | "Dynamic" -> ctx.ctx_dbgout "/*D*/"; true | name -> let full_name = name ^ "." ^ member in ctx.ctx_dbgout ("/*R:"^full_name^"*/"); try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in mem_type="Dynamic" ) with Not_found -> true ) ;; let cast_if_required ctx expr to_type = let expr_type = (type_string expr.etype) in ctx.ctx_dbgout ( "/* cir: " ^ expr_type ^ " */" ); if (is_dynamic_in_cpp ctx expr) then ctx.ctx_output (".Cast< " ^ to_type ^ " >()" ) ;; (* This is the big one. Once you get inside a function, all code is generated (recursively) as a "expression". "retval" is tracked to determine whether the value on an expression is actually used. eg, if the result of a block (ie, the last expression in the list) is used, then we have to do some funky stuff to generate a local function. Some things that change less often are stored in the context and are extracted at the top for simplicity. *) let rec define_local_function_ctx ctx func_name func_def = let writer = ctx.ctx_writer in let output_i = writer#write_i in let output = ctx.ctx_output in let remap_this = function | "this" -> "__this" | other -> other in let rec define_local_function func_name func_def = let declarations = Hashtbl.create 0 in let undeclared = Hashtbl.create 0 in (* Add args as defined variables *) List.iter ( fun (arg_var, opt_val) -> if (ctx.ctx_debug) then output ("/* found arg " ^ arg_var.v_name ^ " = " ^ (type_string arg_var.v_type) ^" */ "); Hashtbl.add declarations (keyword_remap arg_var.v_name) () ) func_def.tf_args; find_undeclared_variables_ctx ctx undeclared declarations "" true func_def.tf_expr; let has_this = Hashtbl.mem undeclared "this" in if (has_this) then Hashtbl.remove undeclared "this"; let typed_vars = hash_iterate undeclared (fun key value -> value ^ "," ^ (keyword_remap key) ) in let func_name_sep = func_name ^ (if List.length typed_vars > 0 then "," else "") in output_i ("HX_BEGIN_LOCAL_FUNC_S" ^ (list_num typed_vars) ^ "(" ^ (if has_this then "hx::LocalThisFunc," else "hx::LocalFunc,") ^ func_name_sep ^ (String.concat "," typed_vars) ^ ")\n" ); (* actual function, called "run" *) let args_and_types = List.map (fun (v,_) -> (type_string v.v_type) ^ " " ^ (keyword_remap v.v_name) ) func_def.tf_args in let block = is_block func_def.tf_expr in let func_type = type_string func_def.tf_type in output_i (func_type ^ " run(" ^ (String.concat "," args_and_types) ^ ")"); let pop_real_this_ptr = clear_real_this_ptr ctx true in if (block) then begin writer#begin_block; gen_expression ctx false func_def.tf_expr; output_i "return null();\n"; writer#end_block; end else begin writer#begin_block; (* Save old values, and equalize for new input ... *) let pop_names = push_anon_names ctx in find_local_functions_and_return_blocks_ctx ctx false func_def.tf_expr; (match func_def.tf_expr.eexpr with | TReturn (Some return_expression) when (func_type<>"Void") -> output_i "return "; gen_expression ctx true return_expression; | TReturn (Some return_expression) -> output_i ""; gen_expression ctx false return_expression; | _ -> output_i ""; gen_expression ctx false (to_block func_def.tf_expr); ); output ";\n"; output_i "return null();\n"; pop_names(); writer#end_block; end; pop_real_this_ptr(); let return = if (type_string func_def.tf_type ) = "Void" then "(void)" else "return" in output_i ("HX_END_LOCAL_FUNC" ^ (list_num args_and_types) ^ "(" ^ return ^ ")\n\n"); Hashtbl.replace ctx.ctx_local_function_args func_name (if (ctx.ctx_real_this_ptr) then String.concat "," (hash_keys undeclared) else String.concat "," (List.map remap_this (hash_keys undeclared)) ) in define_local_function func_name func_def and find_local_functions_and_return_blocks_ctx ctx retval expression = let output = ctx.ctx_output in let rec find_local_functions_and_return_blocks retval expression = match expression.eexpr with | TBlock _ -> if (retval) then begin define_local_return_block_ctx ctx expression (next_anon_function_name ctx); end (* else we are done *) | TMatch (_, _, _, _) | TTry (_, _) | TSwitch (_, _, _) when retval -> define_local_return_block_ctx ctx expression (next_anon_function_name ctx) | TObjectDecl ( ("fileName" , { eexpr = (TConst (TString file)) }) :: ("lineNumber" , { eexpr = (TConst (TInt line)) }) :: ("className" , { eexpr = (TConst (TString class_name)) }) :: ("methodName", { eexpr = (TConst (TString meth)) }) :: [] ) -> () | TObjectDecl decl_list -> let name = next_anon_function_name ctx in define_local_return_block_ctx ctx expression name; (*| TCall (e,el) -> (* visit function object first, then args *) find_local_functions_and_return_blocks e; List.iter find_local_functions_and_return_blocks el *) | TFunction func -> let func_name = next_anon_function_name ctx in output "\n"; define_local_function_ctx ctx func_name func | TField (obj,_) when (is_null obj) -> ( ) | TArray (obj,_) when (is_null obj) -> ( ) | TIf ( _ , _ , _ ) when retval -> (* ? operator style *) iter_retval find_local_functions_and_return_blocks retval expression | TMatch (_, _, _, _) | TSwitch (_, _, _) when retval -> ( ) | TMatch ( cond , _, _, _) | TWhile ( cond , _, _ ) | TIf ( cond , _, _ ) | TSwitch ( cond , _, _) -> iter_retval find_local_functions_and_return_blocks true cond | _ -> iter_retval find_local_functions_and_return_blocks retval expression in find_local_functions_and_return_blocks retval expression and define_local_return_block_ctx ctx expression name = let writer = ctx.ctx_writer in let output_i = writer#write_i in let output = ctx.ctx_output in let check_this = function | "this" when not ctx.ctx_real_this_ptr -> "__this" | x -> x in let reference = function | "this" -> " *__this" | name -> " &" ^name in let rec define_local_return_block expression = let declarations = Hashtbl.create 0 in let undeclared = Hashtbl.create 0 in find_undeclared_variables_ctx ctx undeclared declarations "_obj" true expression; let vars = (hash_keys undeclared) in let args = String.concat "," (List.map check_this (hash_keys undeclared)) in Hashtbl.replace ctx.ctx_local_return_block_args name args; output_i ("struct " ^ name); writer#begin_block; let ret_type = match expression.eexpr with | TObjectDecl _ -> "Dynamic" | _ -> type_string expression.etype in output_i ("inline static " ^ ret_type ^ " Block( "); output (String.concat "," ( (List.map (fun var -> (Hashtbl.find undeclared var) ^ (reference var)) ) vars)); output (")"); let return_data = ret_type <> "Void" in writer#begin_block; output_i ""; let pop_real_this_ptr = clear_real_this_ptr ctx false in (match expression.eexpr with | TObjectDecl decl_list -> writer#begin_block; output_i "hx::Anon __result = hx::Anon_obj::Create();\n"; let pop_names = push_anon_names ctx in List.iter (function (name,value) -> find_local_functions_and_return_blocks_ctx ctx true value; output_i ( "__result->Add(" ^ (str name) ^ " , "); gen_expression ctx true value; output (if is_function_expr value then ",true" else ",false" ); output (");\n"); ) decl_list; pop_names(); output_i "return __result;\n"; writer#end_block; | TBlock _ -> ctx.ctx_return_from_block <- return_data; ctx.ctx_return_from_internal_node <- false; gen_expression ctx false expression; | _ -> ctx.ctx_return_from_block <- false; ctx.ctx_return_from_internal_node <- return_data; gen_expression ctx false (to_block expression); ); output_i "return null();\n"; writer#end_block; pop_real_this_ptr(); writer#end_block_line; output ";\n"; in define_local_return_block expression and gen_expression ctx retval expression = let output = ctx.ctx_output in let writer = ctx.ctx_writer in let output_i = writer#write_i in let calling = ctx.ctx_calling in ctx.ctx_calling <- false; let assigning = ctx.ctx_assigning in ctx.ctx_assigning <- false; let return_from_block = ctx.ctx_return_from_block in ctx.ctx_return_from_block <- false; let return_from_internal_node = ctx.ctx_return_from_internal_node in ctx.ctx_return_from_internal_node <- false; let push_src_pos = ctx.ctx_push_src_pos in ctx.ctx_push_src_pos <- ""; (* Annotate source code with debug - can get a bit verbose. Mainly for debugging code gen, rather than the run time *) if (ctx.ctx_debug) then begin (*if calling then output "/* Call */";*) (*if ctx.ctx_real_this_ptr then output "/* this */" else output "/* FAKE __this */";*) output (debug_expression expression ctx.ctx_debug_type); end; (* Write comma separated list of variables - useful for function args. *) let rec gen_expression_list expressions = (match expressions with | [] -> () | [single] -> gen_expression ctx true single | first :: remaining -> gen_expression ctx true first; output ","; gen_expression_list remaining ) in let rec gen_bin_op_string expr1 op expr2 = let cast = (match op with | ">>" | "<<" | "&" | "|" | "^" -> "int(" | "&&" | "||" -> "bool(" | "/" -> "double(" | _ -> "") in if (op <> "=") then output "("; if ( cast <> "") then output cast; gen_expression ctx true expr1; if ( cast <> "") then output ")"; output (" " ^ op ^ " "); if ( cast <> "") then output cast; gen_expression ctx true expr2; if ( cast <> "") then output ")"; if (op <> "=") then output ")"; in let rec gen_bin_op op expr1 expr2 = match op with | Ast.OpAssign -> ctx.ctx_assigning <- true; gen_bin_op_string expr1 "=" expr2 | Ast.OpUShr -> output "hx::UShr("; gen_expression ctx true expr1; output ","; gen_expression ctx true expr2; output ")"; | Ast.OpMod -> output "hx::Mod("; gen_expression ctx true expr1; output ","; gen_expression ctx true expr2; output ")"; | Ast.OpAssignOp bin_op -> output (match bin_op with | Ast.OpAdd -> "hx::AddEq(" | Ast.OpMult -> "hx::MultEq(" | Ast.OpDiv -> "hx::DivEq(" | Ast.OpSub -> "hx::SubEq(" | Ast.OpAnd -> "hx::AndEq(" | Ast.OpOr -> "hx::OrEq(" | Ast.OpXor -> "hx::XorEq(" | Ast.OpShl -> "hx::ShlEq(" | Ast.OpShr -> "hx::ShrEq(" | Ast.OpUShr -> "hx::UShrEq(" | Ast.OpMod -> "hx::ModEq(" | _ -> error "Unknown OpAssignOp" expression.epos ); ctx.ctx_assigning <- true; gen_expression ctx true expr1; output ","; gen_expression ctx true expr2; output ")" | Ast.OpNotEq -> gen_bin_op_string expr1 "!=" expr2 | Ast.OpEq -> gen_bin_op_string expr1 "==" expr2 | _ -> gen_bin_op_string expr1 (Ast.s_binop op) expr2 in (match expression.eexpr with | TConst TNull when not retval -> output "Dynamic()"; | TCall (func, arg_list) when (match func.eexpr with | TConst TSuper -> true | _ -> false ) -> output "super::__construct("; gen_expression_list arg_list; output ")"; | TCall (func, arg_list) -> let rec is_variable e = match e.eexpr with | TField _ -> false | TEnumField _ -> false | TLocal { v_name = "__global__" } -> false | TParenthesis p -> is_variable p | TCast (e,None) -> is_variable e | _ -> true in let expr_type = type_string expression.etype in if (ctx.ctx_debug_type) then output ("/* TCALL ret=" ^ expr_type ^ "*/"); ctx.ctx_calling <- true; gen_expression ctx true func; output "("; gen_expression_list arg_list; output ")"; if ( (is_variable func) && (expr_type<>"Dynamic") ) then ctx.ctx_output (".Cast< " ^ expr_type ^ " >()" ); | TBlock expr_list -> if (retval) then begin let func_name = use_anon_function_name ctx in ( try output ( func_name ^ "::Block(" ^ (Hashtbl.find ctx.ctx_local_return_block_args func_name) ^ ")" ) with Not_found -> (*error ("Block function " ^ func_name ^ " not found" ) expression.epos;*) output ("/* Block function " ^ func_name ^ " not found */" ); ) end else begin writer#begin_block; if (push_src_pos<>"") then output_i ("HX_SOURCE_PUSH(\"" ^ push_src_pos ^ "\")\n"); (* Save old values, and equalize for new input ... *) let pop_names = push_anon_names ctx in let remaining = ref (List.length expr_list) in List.iter (fun expression -> let want_value = (return_from_block && !remaining = 1) in find_local_functions_and_return_blocks_ctx ctx want_value expression; let line = Lexer.get_error_line expression.epos in output_i ("HX_SOURCE_POS(\"" ^ (Ast.s_escape expression.epos.pfile) ^ "\"," ^ (string_of_int line) ^ ")\n" ); output_i ""; ctx.ctx_return_from_internal_node <- return_from_internal_node; if (want_value) then output "return "; gen_expression ctx want_value expression; decr remaining; writer#terminate_line ) expr_list; writer#end_block; pop_names() end | TTypeExpr type_expr -> let klass = "::" ^ (join_class_path (t_path type_expr) "::" ) in let klass1 = if klass="::Array" then "Array" else klass in output ("hx::ClassOf< " ^ klass1 ^ " >()") | TReturn optional_expr -> output ""; ( match optional_expr with | Some return_expression when ( (type_string expression.etype)="Void") -> output "return null("; gen_expression ctx true return_expression; output ")"; | Some return_expression -> output "return "; gen_expression ctx true return_expression | _ -> output "return null()" ) | TConst const -> (match const with | TInt i -> output (Printf.sprintf "(int)%ld" i) | TFloat float_as_string -> output float_as_string | TString s -> output (str s) | TBool b -> output (if b then "true" else "false") (*| TNull -> output ("((" ^ (type_string expression.etype) ^ ")null())")*) | TNull -> output "null()" | TThis -> output (if ctx.ctx_real_this_ptr then "hx::ObjectPtr(this)" else "__this") | TSuper -> output ("hx::ObjectPtr(" ^ (if ctx.ctx_real_this_ptr then "this" else "__this.mPtr") ^ ")") ) | TLocal v -> output (keyword_remap v.v_name); | TEnumField (enum, name) -> output ("::" ^ (join_class_path enum.e_path "::") ^ "_obj::" ^ name); if ( not calling ) then output "_dyn()"; | TArray (array_expr,_) when (is_null array_expr) -> output "Dynamic()" | TArray (array_expr,index) -> let dynamic = is_dynamic_in_cpp ctx array_expr in if ( assigning && (not dynamic) ) then begin if (is_array_implementer array_expr.etype) then begin output "hx::__ArrayImplRef("; gen_expression ctx true array_expr; output ","; gen_expression ctx true index; output ")"; end else begin gen_expression ctx true array_expr; output "["; gen_expression ctx true index; output "]"; end end else if (assigning) then begin (* output (" /*" ^ (type_string array_expr.etype) ^ " */ "); *) output "hx::IndexRef(("; gen_expression ctx true array_expr; output ").mPtr,"; gen_expression ctx true index; output ")"; end else if ( dynamic ) then begin gen_expression ctx true array_expr; output "->__GetItem("; gen_expression ctx true index; output ")"; end else begin gen_expression ctx true array_expr; output "->__get("; gen_expression ctx true index; output ")"; end (* Get precidence matching haxe ? *) | TBinop (op,expr1,expr2) -> gen_bin_op op expr1 expr2 | TField (expr,name) when (is_null expr) -> output "Dynamic()" | TClosure (field_object,member) | TField (field_object,member) -> let remap_name = keyword_remap member in let already_dynamic = ref false in (match field_object.eexpr with (* static access ... *) | TTypeExpr type_def -> let class_name = "::" ^ (join_class_path (t_path type_def) "::" ) in if (class_name="::String") then output ("::String::" ^ remap_name) else output (class_name ^ "_obj::" ^ remap_name); (* Special internal access *) | TLocal { v_name = "__global__" } -> output ("::" ^ member ) | TConst TSuper -> output (if ctx.ctx_real_this_ptr then "this" else "__this"); output ("->super::" ^ remap_name) | TConst TThis when ctx.ctx_real_this_ptr -> output ( "this->" ^ remap_name ) | TConst TNull -> output "null()" | _ -> gen_expression ctx true field_object; ctx.ctx_dbgout "/* TField */"; if (is_internal_member member) then begin output ( "->" ^ member ); end else if (is_dynamic_member_lookup_in_cpp ctx field_object member) then begin let access = (if assigning then "->__FieldRef" else "->__Field") in (* output ( "/* " ^ (type_string field_object.etype) ^ " */" ); *) output ( access ^ "(" ^ (str member) ^ ")" ); already_dynamic := true; end else begin if ((type_string field_object.etype)="::String" ) then output ( "." ^ remap_name ) else begin cast_if_required ctx field_object (type_string field_object.etype); output ( "->" ^ remap_name ) end; end; ); if ( (not !already_dynamic) && (not calling) && (not assigning) && (is_function_member expression) ) then output "_dyn()"; | TParenthesis expr when not retval -> gen_expression ctx retval expr; | TParenthesis expr -> output "("; gen_expression ctx retval expr; output ")" | TObjectDecl ( ("fileName" , { eexpr = (TConst (TString file)) }) :: ("lineNumber" , { eexpr = (TConst (TInt line)) }) :: ("className" , { eexpr = (TConst (TString class_name)) }) :: ("methodName", { eexpr = (TConst (TString meth)) }) :: [] ) -> output ("hx::SourceInfo(" ^ (str file) ^ "," ^ (Printf.sprintf "%ld" line) ^ "," ^ (str class_name) ^ "," ^ (str meth) ^ ")" ) | TObjectDecl decl_list -> let func_name = use_anon_function_name ctx in (try output ( func_name ^ "::Block(" ^ (Hashtbl.find ctx.ctx_local_return_block_args func_name) ^ ")" ) with Not_found -> output ("/* TObjectDecl block " ^ func_name ^ " not found */" ); ) | TArrayDecl decl_list -> (* gen_type output expression.etype; *) let tstr = (type_string_suff "_obj" expression.etype) in if tstr="Dynamic" then output "Dynamic( Array_obj::__new()" else output ( (type_string_suff "_obj" expression.etype) ^ "::__new()"); List.iter ( fun elem -> output ".Add("; gen_expression ctx true elem; output ")" ) decl_list; if tstr="Dynamic" then output ")"; | TNew (klass,params,expressions) -> let is_param_array = match klass.cl_path with | ([],"Array") when is_dynamic_array_param (List.hd params) -> true | _ -> false in if is_param_array then output "Dynamic( Array_obj::__new() )" else begin if (klass.cl_path = ([],"String")) then output "::String(" else output ( ( class_string klass "_obj" params) ^ "::__new(" ); gen_expression_list expressions; output ")" end | TUnop (Ast.NegBits,Ast.Prefix,expr) -> output "~(int)("; gen_expression ctx true expr; output ")" | TUnop (op,Ast.Prefix,expr) -> ctx.ctx_assigning <- (match op with Ast.Increment | Ast.Decrement -> true | _ ->false); output (Ast.s_unop op); output "("; gen_expression ctx true expr; output ")" | TUnop (op,Ast.Postfix,expr) -> ctx.ctx_assigning <- true; output "("; gen_expression ctx true expr; output ")"; output (Ast.s_unop op) | TFunction func -> let func_name = use_anon_function_name ctx in ( try output ( " Dynamic(new " ^ func_name ^ "(" ^ (Hashtbl.find ctx.ctx_local_function_args func_name) ^ "))" ) with Not_found -> (*error ("function " ^ func_name ^ " not found.") expression.epos; *) output ("function " ^ func_name ^ " not found."); ) | TVars var_list -> let count = ref (List.length var_list) in List.iter (fun (tvar, optional_init) -> if (retval && !count==1) then (match optional_init with | None -> output "null()" | Some expression -> gen_expression ctx true expression ) else begin let type_name = (type_string tvar.v_type) in output (if type_name="Void" then "Dynamic" else type_name ); output (" " ^ (keyword_remap tvar.v_name) ); (match optional_init with | None -> () | Some expression -> output " = "; gen_expression ctx true expression); count := !count -1; if (!count > 0) then begin output ";\n"; output_i "" end end ) var_list | TFor (tvar, init, loop) -> output ("for(::cpp::FastIterator_obj< " ^ (type_string tvar.v_type) ^ " > *__it = ::cpp::CreateFastIterator< "^(type_string tvar.v_type) ^ " >("); gen_expression ctx true init; output ("); __it->hasNext(); )"); ctx.ctx_writer#begin_block; output_i ( (type_string tvar.v_type) ^ " " ^ (keyword_remap tvar.v_name) ^ " = __it->next();\n" ); output_i ""; gen_expression ctx false loop; output ";\n"; ctx.ctx_writer#end_block; | TIf (condition, if_expr, optional_else_expr) -> (match optional_else_expr with | Some else_expr -> if (retval) then begin output "( ("; gen_expression ctx true condition; output ") ? "; let type_str = match (type_string expression.etype) with | "Void" -> "Dynamic" | other -> other in output (type_str ^ "("); gen_expression ctx true if_expr; output ") : "; output (type_str ^ "("); gen_expression ctx true else_expr; output ") )"; end else begin output "if ("; gen_expression ctx true condition; output ")"; gen_expression ctx false (to_block if_expr); output_i "else"; gen_expression ctx false (to_block else_expr); end | _ -> output "if ("; gen_expression ctx true condition; output ")"; gen_expression ctx false (to_block if_expr); ) | TWhile (condition, repeat, Ast.NormalWhile ) -> output "while("; gen_expression ctx true condition; output ")"; gen_expression ctx false (to_block repeat) | TWhile (condition, repeat, Ast.DoWhile ) -> output "do"; gen_expression ctx false (to_block repeat); output "while("; gen_expression ctx true condition; output ")" (* These have already been defined in find_local_return_blocks ... *) | TTry (_,_) | TSwitch (_,_,_) | TMatch (_, _, _, _) when (retval && (not return_from_internal_node) )-> let func_name = use_anon_function_name ctx in (try output ( func_name ^ "::Block(" ^ (Hashtbl.find ctx.ctx_local_return_block_args func_name) ^ ")" ) with Not_found -> output ("/* return block " ^ func_name ^ " not found */" ); ) (*error ("return block " ^ func_name ^ " not found" ) expression.epos;*) | 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 output "switch( (int)"; gen_expression ctx true condition; output ")"; ctx.ctx_writer#begin_block; List.iter (fun (cases_list,expression) -> output_i ""; List.iter (fun value -> output "case "; gen_expression ctx true value; output ": " ) cases_list; ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block expression); output_i ";break;\n"; ) cases; (match optional_default with | None -> () | Some default -> output_i "default: "; ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block default); ); ctx.ctx_writer#end_block; end else begin let tmp_name = get_switch_var ctx in output ( (type_string condition.etype) ^ " " ^ tmp_name ^ " = " ); gen_expression ctx true condition; output ";\n"; let else_str = ref "" in if (List.length cases > 0) then List.iter (fun (cases,expression) -> output_i ( !else_str ^ "if ( "); else_str := "else "; let or_str = ref "" in List.iter (fun value -> output (!or_str ^ " ( " ^ tmp_name ^ "=="); gen_expression ctx true value; output ")"; or_str := " || "; ) cases; output (")"); ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block expression); ) cases; (match optional_default with | None -> () | Some default -> output_i ( !else_str ^ " "); ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block default); output ";\n"; ); end | TMatch (condition, enum, cases, default) -> let tmp_var = get_switch_var ctx in writer#begin_block; output ( (type_string condition.etype) ^ " " ^ tmp_var ^ " = " ); gen_expression ctx true condition; output ";\n"; let use_if_statements = contains_break expression in let dump_condition = if (use_if_statements) then begin let tmp_name = get_switch_var ctx in output_i ( "int " ^ tmp_name ^ " = (" ^ tmp_var ^ ")->GetIndex();" ); let elif = ref "if" in ( fun case_ids -> output (!elif ^ " (" ); elif := "else if"; output (String.concat "||" (List.map (fun id -> (string_of_int id) ^ "==" ^ tmp_name ) case_ids ) ); output ") " ) end else begin output_i ("switch((" ^ tmp_var ^ ")->GetIndex())"); ( fun case_ids -> List.iter (fun id -> output ("case " ^ (string_of_int id) ^ ": ") ) case_ids; ) end in writer#begin_block; List.iter (fun (case_ids,params,expression) -> output_i ""; dump_condition case_ids; let has_params = match params with | Some _ -> true | _ -> false in if (has_params) then begin writer#begin_block; List.iter (fun (name,vtype,id) -> output_i ((type_string vtype) ^ " " ^ (keyword_remap name) ^ " = " ^ tmp_var ^ "->__Param(" ^ (string_of_int id) ^ ");\n")) (tmatch_params_to_args params); end; ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block expression); if (has_params) then writer#end_block; if (not use_if_statements) then output_i ";break;\n"; ) cases; (match default with | None -> () | Some e -> if (use_if_statements) then output_i "else " else output_i "default: "; ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block e); ); writer#end_block; writer#end_block; | TTry (expression, catch_list) -> output "try"; (* Move this "inside" the try call ... *) ctx.ctx_return_from_block <-return_from_internal_node; gen_expression ctx false (to_block expression); if (List.length catch_list > 0 ) then begin output_i "catch(Dynamic __e)"; ctx.ctx_writer#begin_block; let seen_dynamic = ref false in let else_str = ref "" in List.iter (fun (v,expression) -> let type_name = type_string v.v_type in if (type_name="Dynamic") then begin seen_dynamic := true; output_i !else_str; end else output_i (!else_str ^ "if (__e.IsClass< " ^ type_name ^ " >() )"); ctx.ctx_writer#begin_block; output_i (type_name ^ " " ^ v.v_name ^ " = __e;"); (* Move this "inside" the catch call too ... *) ctx.ctx_return_from_block <-return_from_internal_node; gen_expression ctx false (to_block expression); ctx.ctx_writer#end_block; else_str := "else "; ) catch_list; if (not !seen_dynamic) then begin output_i "else throw(__e);\n"; end; ctx.ctx_writer#end_block; end; | TBreak -> output "break" | TContinue -> output "continue" | TThrow expression -> output "hx::Throw ("; gen_expression ctx true expression; output ")" | TCast (cast,None) -> let void_cast = retval && ((type_string expression.etype)="Void" ) in if (void_cast) then output "Void("; gen_expression ctx retval cast; if (void_cast) then output ")"; | TCast (e1,Some t) -> let class_name = (join_class_path (t_path t) "::" ) in if (class_name="Array") then output ("hx::TCastToArray(" ) else output ("hx::TCast< " ^ class_name ^ " >::cast(" ); gen_expression ctx true e1; output ")"; );; (* let is_dynamic_haxe_method f = match follow f.cf_type with | TFun _ when f.cf_expr = None -> true | _ -> (match f.cf_expr with | Some { eexpr = TFunction fd } when f.cf_set = MethodAccess true -> true | Some { eexpr = TFunction fd } when f.cf_set = NormalAccess -> true | _ -> false);; *) let is_dynamic_haxe_method f = (match f.cf_expr, f.cf_kind with | Some { eexpr = TFunction _ }, (Var _ | Method MethDynamic) -> true | _ -> false);; let is_data_member field = match field.cf_expr with | Some { eexpr = TFunction function_def } -> is_dynamic_haxe_method field | _ -> true;; let is_override class_def field = List.mem field class_def.cl_overrides ;; (* external mem Dynamic & *) let default_value_string = function | TInt i -> Printf.sprintf "%ld" i | TFloat float_as_string -> float_as_string | TString s -> str s | TBool b -> (if b then "true" else "false") | TNull -> "null()" | _ -> "/* Hmmm */" let generate_default_values ctx args prefix = List.iter ( fun (v,o) -> let type_str = type_string v.v_type in match o with | Some TNull -> () | Some const when (type_str=="::String") -> ctx.ctx_output ("if (" ^ v.v_name ^ " == null() ) " ^ v.v_name ^ "=" ^ (default_value_string const) ^ ");\n") | Some const -> ctx.ctx_output (type_str ^ " " ^ v.v_name ^ " = " ^ prefix ^ v.v_name ^ ".Default(" ^ (default_value_string const) ^ ");\n") | _ -> () ) args;; let has_default_values args = List.exists ( fun (_,o) -> match o with | Some TNull -> false | Some _ -> true | _ -> false ) args ;; (* When a specialized class inherits from a templated class, the inherited class contains the specialized type, rather than the generic template (Dynamic) type. C++ needs the inhertied functions to have the same types as the base types. use Codegen.fix_overrides *) (* let rec inherit_temlpate_types class_def name is_static in_def = match class_def.cl_super with | None -> in_def | Some (super,params) -> let funcs = if is_static then super.cl_statics else super.cl_fields in if (PMap.mem name funcs) then begin let field = PMap.find name funcs in match field.cf_expr with | Some { eexpr = TFunction parent_def } -> inherit_temlpate_types super name is_static { tf_args = List.map2 (fun (n,_,_) (_,c,t) -> n,c,t) in_def.tf_args parent_def.tf_args; tf_type = parent_def.tf_type; tf_expr = in_def.tf_expr; } | _ -> inherit_temlpate_types super name is_static in_def; end else inherit_temlpate_types super name is_static in_def; ;; *) let gen_field ctx class_def class_name ptr_name is_static is_interface field = let output = ctx.ctx_output in ctx.ctx_real_this_ptr <- not is_static; let remap_name = keyword_remap field.cf_name in if (is_interface) then begin (* Just the dynamic glue ... *) match follow field.cf_type, field.cf_kind with | TFun (args,result), Method _ -> if (is_static) then output "STATIC_"; let ret = if ((type_string result ) = "Void" ) then "" else "return " in output ("HX_DEFINE_DYNAMIC_FUNC" ^ (string_of_int (List.length args)) ^ "(" ^ class_name ^ "," ^ remap_name ^ "," ^ ret ^ ")\n\n"); | _ -> () end else (match field.cf_expr with (* Function field *) | Some { eexpr = TFunction function_def } -> let return_type = (type_string function_def.tf_type) in let nargs = string_of_int (List.length function_def.tf_args) in let is_void = (type_string function_def.tf_type ) = "Void" in let ret = if is_void then "(void)" else "return " in let src_name = class_name ^ "::" ^ field.cf_name in if (not (is_dynamic_haxe_method field)) then begin (* The actual function definition *) output return_type; output (" " ^ class_name ^ "::" ^ remap_name ^ "( " ); output (gen_arg_list function_def.tf_args "__o_"); output ")"; ctx.ctx_real_this_ptr <- true; ctx.ctx_dynamic_this_ptr <- false; let code = (get_code field.cf_meta ":functionCode") in let tail_code = (get_code field.cf_meta ":functionTailCode") in if (has_default_values function_def.tf_args) then begin ctx.ctx_writer#begin_block; generate_default_values ctx function_def.tf_args "__o_"; output ("\tHX_SOURCE_PUSH(\"" ^ src_name ^ "\");\n"); output code; gen_expression ctx false function_def.tf_expr; output tail_code; if (is_void) then output "return null();\n"; ctx.ctx_writer#end_block; end else begin let add_block = is_void || (code <> "") || (tail_code <> "") in if (add_block) then ctx.ctx_writer#begin_block; ctx.ctx_push_src_pos <- src_name; output code; gen_expression ctx false (to_block function_def.tf_expr); output tail_code; if (add_block) then begin if (is_void) then output "return null();\n"; ctx.ctx_writer#end_block; end; end; output "\n\n"; (* generate dynamic version too ... *) if (is_static) then output "STATIC_"; output ("HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," ^ remap_name ^ "," ^ ret ^ ")\n\n"); end else begin ctx.ctx_real_this_ptr <- false; ctx.ctx_dynamic_this_ptr <- false; let func_name = "__default_" ^ (remap_name) in output ("HX_BEGIN_DEFAULT_FUNC(" ^ func_name ^ "," ^ class_name ^ ")\n"); output return_type; output (" run(" ^ (gen_arg_list function_def.tf_args "") ^ ")"); ctx.ctx_push_src_pos <- src_name; if (is_void) then begin ctx.ctx_writer#begin_block; gen_expression ctx false function_def.tf_expr; output "return null();\n"; ctx.ctx_writer#end_block; end else gen_expression ctx false (to_block function_def.tf_expr); output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); output ("HX_END_DEFAULT_FUNC\n\n"); if (is_static) then output ( "Dynamic " ^ class_name ^ "::" ^ remap_name ^ ";\n\n"); end (* Data field *) | _ -> if is_static then begin gen_type ctx field.cf_type; output ( " " ^ class_name ^ "::" ^ remap_name ^ ";\n\n"); end ) ;; let gen_field_init ctx field = let output = ctx.ctx_output in let remap_name = keyword_remap field.cf_name in (match field.cf_expr with (* Function field *) | Some { eexpr = TFunction function_def } -> if (is_dynamic_haxe_method field) then begin let func_name = "__default_" ^ (remap_name) in output ( " hx::Static(" ^ remap_name ^ ") = new " ^ func_name ^ ";\n\n" ); end (* Data field *) | _ -> (match field.cf_expr with | Some expr -> find_local_functions_and_return_blocks_ctx ctx true expr; output ( " hx::Static(" ^ remap_name ^ ") = "); gen_expression ctx true expr; output ";\n" | _ -> output ( " hx::Static(" ^ remap_name ^ ");\n"); ); ) ;; let gen_member_def ctx class_def is_static is_interface field = let output = ctx.ctx_output in let remap_name = keyword_remap field.cf_name in output (if is_static then " static " else " "); if (is_interface) then begin match follow field.cf_type, field.cf_kind with | TFun (args,return_type), Method _ -> output ( (if (not is_static) then "virtual " else "" ) ^ type_string return_type); output (" " ^ remap_name ^ "( " ); output (String.concat "," (List.map (fun (name,opt,typ) -> (type_string typ) ^ " " ^ name ^ (if opt then "=null()" else "")) args)); output (if (not is_static) then ")=0;\n" else ");\n"); (*if (not is_interface) then begin*) output (if is_static then " static " else " "); output ("Dynamic " ^ remap_name ^ "_dyn();\n" ); (*end else output (" virtual Dynamic " ^ remap_name ^ "_dyn() = 0;\n\n" );*) | _ -> if (is_interface) then begin (* output "virtual "; gen_type ctx field.cf_type; output (" & __get_" ^ remap_name ^ "()=0;\n" ) *) output "\n"; end else begin gen_type ctx field.cf_type; output (" " ^ remap_name ^ ";\n" ); end end else (match field.cf_expr with | Some { eexpr = TFunction function_def } -> if ( is_dynamic_haxe_method field ) then begin if ( not (is_override class_def field.cf_name ) ) then begin output ("Dynamic " ^ remap_name ^ ";\n"); output (if is_static then " static " else " "); output ("inline Dynamic &" ^ remap_name ^ "_dyn() " ^ "{return " ^ remap_name^ "; }\n") end end else begin let return_type = (type_string function_def.tf_type) in if (not is_static) then output "virtual "; output return_type; output (" " ^ remap_name ^ "( " ); output (gen_arg_list function_def.tf_args "" ); output ");\n"; output (if is_static then " static " else " "); output ("Dynamic " ^ remap_name ^ "_dyn();\n" ) end; output "\n"; | _ -> (* Variable access *) gen_type ctx field.cf_type; output (" " ^ remap_name ^ "; /* REM */ \n" ); (* Add a "dyn" function for variable to unify variable/function access *) (match follow field.cf_type with | TFun (_,_) -> output (if is_static then " static " else " "); gen_type ctx field.cf_type; output (" &" ^ remap_name ^ "_dyn() { return " ^ remap_name ^ ";}\n" ) | _ -> (match field.cf_kind with | Var { v_read = AccCall name } when (not is_static) && (is_dynamic_accessor name "get" field class_def) -> output ("\t\tDynamic get_" ^ field.cf_name ^ ";\n" ) | _ -> () ); (match field.cf_kind with | Var { v_write = AccCall name } when (not is_static) && (is_dynamic_accessor name "set" field class_def) -> output ("\t\tDynamic set_" ^ field.cf_name ^ ";\n" ) | _ -> () ) ) ) ;; (* Get a list of all classes referred to by the class/enum definition These are used for "#include"ing the appropriate header files. *) let find_referenced_types ctx obj super_deps constructor_deps header_only = let types = ref PMap.empty in let rec add_type in_path = if ( not (PMap.mem in_path !types)) then begin types := (PMap.add in_path () !types); try List.iter add_type (Hashtbl.find super_deps in_path); with Not_found -> () end in let rec visit_type in_type = match (follow in_type) with | TMono r -> (match !r with None -> () | Some t -> visit_type t) (*| TEnum ({ e_path = ([],"Void") },[]) -> () | TEnum ({ e_path = ([],"Bool") },[]) -> () *) | TEnum (enum,params) -> add_type enum.e_path (* If a class has a template parameter, then we treat it as dynamic - except for the Array or Class class, for which we do a fully typed object *) | TInst (klass,params) -> (match klass.cl_path with | ([],"Array") | ([],"Class") | (["cpp"],"FastIterator") -> List.iter visit_type params | (["cpp"],"CppInt32__") -> add_type klass.cl_path; | _ when klass.cl_extern -> () | _ -> if (klass.cl_kind <> KTypeParameter ) then add_type klass.cl_path; ) | TFun (args,haxe_type) -> visit_type haxe_type; List.iter (fun (_,_,t) -> visit_type t; ) args; | _ -> () in let rec visit_types expression = begin let rec visit_expression = fun expression -> (* Expand out TTypeExpr ... *) (match expression.eexpr with | TTypeExpr type_def -> add_type (t_path type_def) (* Must visit the types, Type.iter will visit the expressions ... *) | TTry (e,catches) -> List.iter (fun (v,_) -> visit_type v.v_type) catches (* Must visit the enum param types, Type.iter will visit the rest ... *) | TMatch (_,_,cases,_) -> List.iter (fun (case_ids,params,expression) -> (match params with | None -> () | Some l -> List.iter (function None -> () | Some v -> visit_type v.v_type) l ) ) cases; (* Must visit type too, Type.iter will visit the expressions ... *) | TNew (klass,params,_) -> begin visit_type (TInst (klass,params)); try let construct_type = Hashtbl.find constructor_deps klass.cl_path in visit_type construct_type.cf_type with Not_found -> (); end (* Must visit type too, Type.iter will visit the expressions ... *) | TVars var_list -> List.iter (fun (v, _) -> visit_type v.v_type) var_list (* Must visit args too, Type.iter will visit the expressions ... *) | TFunction func_def -> List.iter (fun (v,_) -> visit_type v.v_type) func_def.tf_args; | TConst TSuper -> (match expression.etype with | TInst (klass,params) -> (try let construct_type = Hashtbl.find constructor_deps klass.cl_path in visit_type construct_type.cf_type with Not_found -> () ) | _ -> print_endline ("TSuper : Odd etype?") ) | _ -> () ); Type.iter visit_expression expression; visit_type (follow expression.etype) in visit_expression expression end in let visit_field field = (* Add the type of the expression ... *) visit_type field.cf_type; if (not header_only) then (match field.cf_expr with | Some expression -> visit_types expression | _ -> ()); in let visit_class class_def = let fields = List.append class_def.cl_ordered_fields class_def.cl_ordered_statics in let fields_and_constructor = List.append fields (match class_def.cl_constructor with | Some expr -> [expr] | _ -> [] ) in List.iter visit_field fields_and_constructor; (* Add super & interfaces *) add_type class_def.cl_path; in let visit_enum enum_def = add_type enum_def.e_path; PMap.iter (fun _ constructor -> (match constructor.ef_type with | TFun (args,_) -> List.iter (fun (_,_,t) -> visit_type t; ) args; | _ -> () ); ) enum_def.e_constrs; if (not header_only) then begin let meta = Codegen.build_metadata ctx (TEnumDecl enum_def) in match meta with Some expr -> visit_types expr | _ -> (); end; in let inc_cmp i1 i2 = String.compare (join_class_path i1 ".") (join_class_path i2 ".") in (* Body of main function *) (match obj with | TClassDecl class_def -> visit_class class_def; (match class_def.cl_init with Some expression -> visit_types expression | _ -> ()) | TEnumDecl enum_def -> visit_enum enum_def | TTypeDecl _ -> (* These are expanded *) ()); List.sort inc_cmp (List.filter (fun path -> (include_class_header path) ) (pmap_keys !types)) ;; let generate_main common_ctx member_types super_deps class_def = (* main routine should be a single static function *) let main_expression = (match class_def.cl_ordered_statics with | [{ cf_expr = Some expression }] -> expression; | _ -> assert false ) in let referenced = find_referenced_types common_ctx (TClassDecl class_def) super_deps (Hashtbl.create 0) false in let generate_startup filename is_main = (*make_class_directories base_dir ( "src" :: []);*) let cpp_file = new_cpp_file common_ctx.file ([],filename) in let output_main = (cpp_file#write) in let ctx = new_context common_ctx cpp_file false in ctx.ctx_class_name <- "?"; ctx.ctx_class_member_types <- member_types; output_main "#include \n\n"; output_main "#include \n\n"; List.iter ( add_include cpp_file ) referenced; output_main "\n\n"; output_main ( if is_main then "HX_BEGIN_MAIN\n\n" else "HX_BEGIN_LIB_MAIN\n\n" ); gen_expression (new_context common_ctx cpp_file false) false main_expression; output_main ";\n"; output_main ( if is_main then "HX_END_MAIN\n\n" else "HX_END_LIB_MAIN\n\n" ); cpp_file#close; in generate_startup "__main__" true; generate_startup "__lib__" false ;; let generate_dummy_main common_ctx = let generate_startup filename is_main = let main_file = new_cpp_file common_ctx.file ([],filename) in let output_main = (main_file#write) in output_main "#include \n\n"; output_main "#include \n\n"; output_main ( if is_main then "HX_BEGIN_MAIN\n\n" else "HX_BEGIN_LIB_MAIN\n\n" ); output_main ( if is_main then "HX_END_MAIN\n\n" else "HX_END_LIB_MAIN\n\n" ); main_file#close; in generate_startup "__main__" true; generate_startup "__lib__" false ;; let generate_boot common_ctx boot_classes init_classes = (* Write boot class too ... *) let base_dir = common_ctx.file in let boot_file = new_cpp_file base_dir ([],"__boot__") in let output_boot = (boot_file#write) in output_boot "#include \n\n"; List.iter ( fun class_path -> output_boot ("#include <" ^ ( join_class_path (include_remap class_path) "/" ) ^ ".h>\n") ) boot_classes; output_boot "\nvoid __boot_all()\n{\n"; output_boot "hx::RegisterResources( hx::GetResources() );\n"; List.iter ( fun class_path -> output_boot ("::" ^ ( join_class_path class_path "::" ) ^ "_obj::__register();\n") ) boot_classes; List.iter ( fun class_path -> output_boot ("::" ^ ( join_class_path class_path "::" ) ^ "_obj::__init__();\n") ) (List.rev init_classes); let dump_boot = List.iter ( fun class_path -> output_boot ("::" ^ ( join_class_path class_path "::" ) ^ "_obj::__boot();\n") ) in dump_boot (List.filter (fun path -> is_cpp_class path ) (List.rev boot_classes)); dump_boot (List.filter (fun path -> not (is_cpp_class path) ) (List.rev boot_classes)); output_boot "}\n\n"; boot_file#close;; let begin_header_file output_h def_string = output_h ("#ifndef INCLUDED_" ^ def_string ^ "\n"); output_h ("#define INCLUDED_" ^ def_string ^ "\n\n"); output_h "#ifndef HXCPP_H\n"; output_h "#include \n"; output_h "#endif\n\n";; let end_header_file output_h def_string = output_h ("\n#endif /* INCLUDED_" ^ def_string ^ " */ \n");; let new_placed_cpp_file common_ctx class_path = let base_dir = common_ctx.file in if (Common.defined common_ctx "vcproj" ) then begin make_class_directories base_dir ("src"::[]); cached_source_writer ( base_dir ^ "/src/" ^ ( String.concat "-" (fst class_path) ) ^ "-" ^ (snd class_path) ^ ".cpp") end else new_cpp_file common_ctx.file class_path;; let generate_enum_files common_ctx enum_def super_deps meta = let class_path = enum_def.e_path in let just_class_name = (snd class_path) in let class_name = just_class_name ^ "_obj" in let smart_class_name = ("::" ^ (join_class_path class_path "::") ) in (*let cpp_file = new_cpp_file common_ctx.file class_path in*) let cpp_file = new_placed_cpp_file common_ctx class_path in let output_cpp = (cpp_file#write) in let debug = false in let ctx = new_context common_ctx cpp_file debug in let has_meta = ( match meta with Some _ -> true | _ -> false ) in if (debug) then print_endline ("Found enum definition:" ^ (join_class_path class_path "::" )); output_cpp "#include \n\n"; let referenced = find_referenced_types common_ctx (TEnumDecl enum_def) super_deps (Hashtbl.create 0) false in List.iter (add_include cpp_file) referenced; gen_open_namespace output_cpp class_path; output_cpp "\n"; PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in match constructor.ef_type with | TFun (args,_) -> output_cpp (smart_class_name ^ " " ^ class_name ^ "::" ^ name ^ "(" ^ (gen_tfun_arg_list args) ^")\n"); output_cpp (" { return hx::CreateEnum< " ^ class_name ^ " >(" ^ (str name) ^ "," ^ (string_of_int constructor.ef_index) ^ ",hx::DynamicArray(0," ^ (string_of_int (List.length args)) ^ ")" ); List.iter (fun (arg,_,_) -> output_cpp (".Add(" ^ (keyword_remap arg) ^ ")")) args; output_cpp "); }\n\n" | _ -> output_cpp ( smart_class_name ^ " " ^ class_name ^ "::" ^ name ^ ";\n\n" ) ) enum_def.e_constrs; output_cpp ("HX_DEFINE_CREATE_ENUM(" ^ class_name ^ ")\n\n"); output_cpp ("int " ^ class_name ^ "::__FindIndex(::String inName)\n{\n"); PMap.iter (fun _ constructor -> let name = constructor.ef_name in let idx = string_of_int constructor.ef_index in output_cpp (" if (inName==" ^ (str name) ^ ") return " ^ idx ^ ";\n") ) enum_def.e_constrs; output_cpp (" return super::__FindIndex(inName);\n"); output_cpp ("}\n\n"); let constructor_arg_count constructor = (match constructor.ef_type with | TFun(args,_) -> List.length args | _ -> 0 ) in (* Dynamic versions of constructors *) let dump_dynamic_constructor _ constr = let count = constructor_arg_count constr in if (count>0) then begin let nargs = string_of_int count in output_cpp ("STATIC_HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," ^ (keyword_remap constr.ef_name) ^ ",return)\n\n"); end in PMap.iter dump_dynamic_constructor enum_def.e_constrs; output_cpp ("int " ^ class_name ^ "::__FindArgCount(::String inName)\n{\n"); PMap.iter (fun _ constructor -> let name = constructor.ef_name in let count = string_of_int (constructor_arg_count constructor) in output_cpp (" if (inName==" ^ (str name) ^ ") return " ^ count ^ ";\n") ) enum_def.e_constrs; output_cpp (" return super::__FindArgCount(inName);\n"); output_cpp ("}\n\n"); (* Dynamic "Get" Field function - string version *) output_cpp ("Dynamic " ^ class_name ^ "::__Field(const ::String &inName)\n{\n"); if (has_meta) then output_cpp " if (inName==HX_CSTRING(\"__meta__\")) return __meta__;\n"; let dump_constructor_test _ constr = output_cpp (" if (inName==" ^ (str constr.ef_name) ^ ") return " ^ (keyword_remap constr.ef_name) ); if ( (constructor_arg_count constr) > 0 ) then output_cpp "_dyn()"; output_cpp (";\n") in PMap.iter dump_constructor_test enum_def.e_constrs; output_cpp (" return super::__Field(inName);\n}\n\n"); if (has_meta) then output_cpp ("Dynamic " ^ class_name ^ "::__meta__;\n"); output_cpp "static ::String sStaticFields[] = {\n"; let sorted = List.sort (fun f1 f2 -> (PMap.find f1 enum_def.e_constrs ).ef_index - (PMap.find f2 enum_def.e_constrs ).ef_index ) (pmap_keys enum_def.e_constrs) in List.iter (fun name -> output_cpp (" " ^ (str name) ^ ",\n") ) sorted; output_cpp " ::String(null()) };\n\n"; (* ENUM - MARK function - only used with internal GC *) output_cpp "static void sMarkStatics(HX_MARK_PARAMS) {\n"; PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in match constructor.ef_type with | TFun (_,_) -> () | _ -> output_cpp (" HX_MARK_MEMBER_NAME(" ^ class_name ^ "::" ^ name ^ ",\"" ^ name ^ "\");\n") ) enum_def.e_constrs; if (has_meta) then output_cpp (" HX_MARK_MEMBER_NAME(" ^ class_name ^ "::__meta__,\"__meta__\");\n"); output_cpp "};\n\n"; output_cpp "static ::String sMemberFields[] = { ::String(null()) };\n"; output_cpp ("Class " ^ class_name ^ "::__mClass;\n\n"); output_cpp ("Dynamic __Create_" ^ class_name ^ "() { return new " ^ class_name ^ "; }\n\n"); output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); let text_name = str (join_class_path class_path ".") in output_cpp ("\nStatic(__mClass) = hx::RegisterClass(" ^ text_name ^ ", hx::TCanCast< " ^ class_name ^ " >,sStaticFields,sMemberFields,\n"); output_cpp (" &__Create_" ^ class_name ^ ", &__Create,\n"); output_cpp (" &super::__SGetClass(), &Create" ^ class_name ^ ", sMarkStatics);\n"); output_cpp ("}\n\n"); output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); (match meta with | Some expr -> let ctx = new_context common_ctx cpp_file false in find_local_functions_and_return_blocks_ctx ctx true expr; output_cpp ("Static(__meta__) = "); gen_expression ctx true expr; output_cpp ";\n" | _ -> () ); PMap.iter (fun _ constructor -> let name = constructor.ef_name in match constructor.ef_type with | TFun (_,_) -> () | _ -> output_cpp ( "Static(" ^ (keyword_remap name) ^ ") = hx::CreateEnum< " ^ class_name ^ " >(" ^ (str name) ^ "," ^ (string_of_int constructor.ef_index) ^ ");\n" ) ) enum_def.e_constrs; output_cpp ("}\n\n"); output_cpp "\n"; gen_close_namespace output_cpp class_path; cpp_file#close; let h_file = new_header_file common_ctx.file class_path in let super = "hx::EnumBase_obj" in let output_h = (h_file#write) in let def_string = join_class_path class_path "_" in ctx.ctx_output <- output_h; begin_header_file output_h def_string; List.iter (gen_forward_decl h_file ) referenced; gen_open_namespace output_h class_path; output_h "\n\n"; output_h ("class " ^ class_name ^ " : public " ^ super ^ "\n"); output_h ("{\n typedef " ^ super ^ " super;\n"); output_h (" typedef " ^ class_name ^ " OBJ_;\n"); output_h "\n public:\n"; output_h (" " ^ class_name ^ "() {};\n"); output_h (" HX_DO_ENUM_RTTI;\n"); output_h (" static void __boot();\n"); output_h (" static void __register();\n"); output_h (" ::String GetEnumName( ) const { return " ^ (str (join_class_path class_path ".")) ^ "; }\n" ); output_h (" ::String __ToString() const { return " ^ (str (just_class_name ^ ".") )^ " + tag; }\n\n"); if (has_meta) then output_h (" static Dynamic __meta__;\n"); PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in output_h ( " static " ^ smart_class_name ^ " " ^ name ); match constructor.ef_type with | TFun (args,_) -> output_h ( "(" ^ (gen_tfun_arg_list args) ^");\n"); output_h ( " static Dynamic " ^ name ^ "_dyn();\n"); | _ -> output_h ";\n"; output_h ( " static inline " ^ smart_class_name ^ " " ^ name ^ "_dyn() { return " ^name ^ "; }\n" ); ) enum_def.e_constrs; output_h "};\n\n"; gen_close_namespace output_h class_path; end_header_file output_h def_string; h_file#close; referenced;; let has_init_field class_def = match class_def.cl_init with | Some _ -> true | _ -> false;; let is_macro meta = Type.has_meta ":macro" meta ;; let generate_class_files common_ctx member_types super_deps constructor_deps class_def = let class_path = class_def.cl_path in let class_name = (snd class_def.cl_path) ^ "_obj" in let smart_class_name = (snd class_def.cl_path) in (*let cpp_file = new_cpp_file common_ctx.file class_path in*) let cpp_file = new_placed_cpp_file common_ctx class_path in let output_cpp = (cpp_file#write) in let debug = false in let ctx = new_context common_ctx cpp_file debug in ctx.ctx_class_name <- "::" ^ (join_class_path class_path "::"); ctx.ctx_class_member_types <- member_types; if debug then print_endline ("Found class definition:" ^ ctx.ctx_class_name); let ptr_name = "hx::ObjectPtr< " ^ class_name ^ " >" in let constructor_type_var_list = match class_def.cl_constructor with | Some definition -> (match definition.cf_expr with | Some { eexpr = TFunction function_def } -> List.map (fun (v,o) -> gen_arg_type_name v.v_name o v.v_type "__o_") function_def.tf_args; | _ -> (match follow definition.cf_type with | TFun (args,_) -> List.map (fun (a,_,t) -> (type_string t,a) ) args | _ -> []) ) | _ -> [] in let constructor_var_list = List.map snd constructor_type_var_list in let constructor_type_args = String.concat "," (List.map (fun (t,a) -> t ^ " " ^ a) constructor_type_var_list) in let constructor_args = String.concat "," constructor_var_list in let implement_dynamic = implement_dynamic_here class_def in output_cpp "#include \n\n"; let field_integer_dynamic = has_field_integer_lookup class_def in let field_integer_numeric = has_field_integer_numeric_lookup class_def in let all_referenced = find_referenced_types ctx.ctx_common (TClassDecl class_def) super_deps constructor_deps false in List.iter ( add_include cpp_file ) all_referenced; (* All interfaces (and sub-interfaces) implemented *) let implemented_hash = Hashtbl.create 0 in List.iter (fun imp -> let rec descend_interface interface = let imp_path = (fst interface).cl_path in let interface_name = "::" ^ (join_class_path imp_path "::" ) in if ( not (Hashtbl.mem implemented_hash interface_name) ) then begin Hashtbl.add implemented_hash interface_name (); List.iter descend_interface (fst interface).cl_implements; end in descend_interface imp ) (real_interfaces class_def.cl_implements); let implemented = hash_keys implemented_hash in output_cpp ( get_code class_def.cl_meta ":cppFileCode" ); gen_open_namespace output_cpp class_path; output_cpp "\n"; output_cpp ( get_code class_def.cl_meta ":cppNamespaceCode" ); if (not class_def.cl_interface) then begin output_cpp ("Void " ^ class_name ^ "::__construct(" ^ constructor_type_args ^ ")\n{\n"); (match class_def.cl_constructor with | Some definition -> (match definition.cf_expr with | Some { eexpr = TFunction function_def } -> if (has_default_values function_def.tf_args) then begin generate_default_values ctx function_def.tf_args "__o_"; gen_expression ctx false (to_block function_def.tf_expr); output_cpp ";\n"; end else begin gen_expression ctx false (to_block function_def.tf_expr); output_cpp ";\n"; (*gen_expression (new_context common_ctx cpp_file debug ) false function_def.tf_expr;*) end | _ -> () ) | _ -> ()); output_cpp " return null();\n"; output_cpp "}\n\n"; (* Destructor goes in the cpp file so we can "see" the full definition of the member vars *) output_cpp ( class_name ^ "::~" ^ class_name ^ "() { }\n\n"); output_cpp ("Dynamic " ^ class_name ^ "::__CreateEmpty() { return new " ^ class_name ^ "; }\n"); output_cpp (ptr_name ^ " " ^ class_name ^ "::__new(" ^constructor_type_args ^")\n"); let create_result () = output_cpp ("{ " ^ ptr_name ^ " result = new " ^ class_name ^ "();\n"); in create_result (); output_cpp (" result->__construct(" ^ constructor_args ^ ");\n"); output_cpp (" return result;}\n\n"); output_cpp ("Dynamic " ^ class_name ^ "::__Create(hx::DynamicArray inArgs)\n"); create_result (); output_cpp (" result->__construct(" ^ (array_arg_list constructor_var_list) ^ ");\n"); output_cpp (" return result;}\n\n"); if ( (List.length implemented) > 0 ) then begin output_cpp ("hx::Object *" ^ class_name ^ "::__ToInterface(const type_info &inType) {\n"); List.iter (fun interface_name -> output_cpp (" if (inType==typeid( " ^ interface_name ^ "_obj)) " ^ "return operator " ^ interface_name ^ "_obj *();\n"); ) implemented; output_cpp (" return super::__ToInterface(inType);\n}\n\n"); end; end; (match class_def.cl_init with | Some expression -> output_cpp ("void " ^ class_name^ "::__init__()"); gen_expression (new_context common_ctx cpp_file debug) false (to_block expression); output_cpp "\n\n"; | _ -> ()); List.iter (gen_field ctx class_def class_name smart_class_name false class_def.cl_interface) class_def.cl_ordered_fields; List.iter (gen_field ctx class_def class_name smart_class_name true class_def.cl_interface) class_def.cl_ordered_statics; output_cpp "\n"; (* Initialise non-static variables *) if (not class_def.cl_interface) then begin output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); if (implement_dynamic) then output_cpp " HX_INIT_IMPLEMENT_DYNAMIC;\n"; List.iter (fun field -> let remap_name = keyword_remap field.cf_name in match field.cf_expr with | Some { eexpr = TFunction function_def } -> if (is_dynamic_haxe_method field) then output_cpp (" " ^ remap_name ^ " = new __default_" ^ remap_name ^ "(this);\n") | _ -> () ) class_def.cl_ordered_fields; output_cpp "}\n\n"; (* MARK function - only used with internal GC *) output_cpp ("void " ^ class_name ^ "::__Mark(HX_MARK_PARAMS)\n{\n"); output_cpp (" HX_MARK_BEGIN_CLASS(" ^ smart_class_name ^ ");\n"); if (implement_dynamic) then output_cpp " HX_MARK_DYNAMIC;\n"; List.iter (fun field -> if (is_data_member field) then begin let remap_name = keyword_remap field.cf_name in output_cpp (" HX_MARK_MEMBER_NAME(" ^ remap_name ^ ",\"" ^ field.cf_name^ "\");\n"); (match field.cf_kind with Var { v_read = AccCall name } when (is_dynamic_accessor name "get" field class_def) -> output_cpp ("\tHX_MARK_MEMBER_NAME(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n" ) | _ -> ()); (match field.cf_kind with Var { v_write = AccCall name } when (is_dynamic_accessor name "set" field class_def) -> output_cpp ("\tHX_MARK_MEMBER_NAME(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n" ) | _ -> ()); end ) class_def.cl_ordered_fields; (match class_def.cl_super with Some _ -> output_cpp " super::__Mark(HX_MARK_ARG);\n" | _ -> () ); output_cpp " HX_MARK_END_CLASS();\n"; output_cpp "}\n\n"; let variable_field field = (match field.cf_expr with | Some { eexpr = TFunction function_def } -> is_dynamic_haxe_method field | _ -> true) in let all_fields = class_def.cl_ordered_statics @ class_def.cl_ordered_fields in let all_variables = List.filter variable_field all_fields in let dump_quick_field_test fields = if ( (List.length fields) > 0) then begin let len = function (_,l,_) -> l in let sfields = List.sort (fun f1 f2 -> (len f1)-(len f2)) fields in let len_case = ref (-1) in output_cpp " switch(inName.length) {\n"; List.iter (fun (field,l,result) -> if (l <> !len_case) then begin if (!len_case>=0) then output_cpp " break;\n"; output_cpp (" case " ^ (string_of_int l) ^ ":\n"); len_case := l; end; output_cpp (" if (HX_FIELD_EQ(inName,\"" ^ (Ast.s_escape field) ^ "\") ) { " ^ result ^ " }\n"); ) sfields; output_cpp " }\n"; end; in (* Dynamic "Get" Field function - string version *) output_cpp ("Dynamic " ^ class_name ^ "::__Field(const ::String &inName)\n{\n"); let get_field_dat = List.map (fun f -> (f.cf_name, String.length f.cf_name, "return " ^ (match f.cf_kind with | Var { v_read = AccCall prop } -> (keyword_remap prop) ^ "()" | _ -> ((keyword_remap f.cf_name) ^ if (variable_field f) then "" else "_dyn()") ) ^ ";" ) ) in dump_quick_field_test (get_field_dat all_fields); if (implement_dynamic) then output_cpp " HX_CHECK_DYNAMIC_GET_FIELD(inName);\n"; output_cpp (" return super::__Field(inName);\n}\n\n"); (* Dynamic "Get" Field function - int version *) if ( field_integer_numeric || field_integer_dynamic) then begin let dump_static_ids = (fun field -> let remap_name = keyword_remap field.cf_name in output_cpp ("static int __id_" ^ remap_name ^ " = __hxcpp_field_to_id(\"" ^ (field.cf_name) ^ "\");\n"); ) in List.iter dump_static_ids all_fields; output_cpp "\n\n"; let output_ifield return_type function_name = output_cpp (return_type ^" " ^ class_name ^ "::" ^ function_name ^ "(int inFieldID)\n{\n"); let dump_field_test = (fun f -> let remap_name = keyword_remap f.cf_name in output_cpp (" if (inFieldID==__id_" ^ remap_name ^ ") return " ^ ( if (return_type="double") then "hx::ToDouble( " else "" ) ^ (match f.cf_kind with | Var { v_read = AccCall prop } -> (keyword_remap prop) ^ "()" | _ -> ((keyword_remap f.cf_name) ^ if ( variable_field f) then "" else "_dyn()") ) ^ ( if (return_type="double") then " ) " else "" ) ^ ";\n"); ) in List.iter dump_field_test all_fields; if (implement_dynamic) then output_cpp " HX_CHECK_DYNAMIC_GET_INT_FIELD(inFieldID);\n"; output_cpp (" return super::" ^ function_name ^ "(inFieldID);\n}\n\n"); in if (field_integer_dynamic) then output_ifield "Dynamic" "__IField"; if (field_integer_numeric) then output_ifield "double" "__INumField"; end; (* Dynamic "Set" Field function *) output_cpp ("Dynamic " ^ class_name ^ "::__SetField(const ::String &inName," ^ "const Dynamic &inValue)\n{\n"); let set_field_dat = List.map (fun f -> (f.cf_name, String.length f.cf_name, (match f.cf_kind with | Var { v_write = AccCall prop } -> "return " ^ (keyword_remap prop) ^ "(inValue);" | _ -> (keyword_remap f.cf_name) ^ "=inValue.Cast< " ^ (type_string f.cf_type) ^ " >(); return inValue;" ) ) ) in dump_quick_field_test (set_field_dat all_variables); if (implement_dynamic) then begin output_cpp (" try { return super::__SetField(inName,inValue); }\n"); output_cpp (" catch(Dynamic e) { HX_DYNAMIC_SET_FIELD(inName,inValue); }\n"); output_cpp " return inValue;\n}\n\n"; end else output_cpp (" return super::__SetField(inName,inValue);\n}\n\n"); (* For getting a list of data members (eg, for serialization) *) let append_field = (fun field -> output_cpp (" outFields->push(" ^( str field.cf_name )^ ");\n")) in let is_data_field field = (match follow field.cf_type with | TFun _ -> false | _ -> true) in output_cpp ("void " ^ class_name ^ "::__GetFields(Array< ::String> &outFields)\n{\n"); List.iter append_field (List.filter is_data_field class_def.cl_ordered_fields); if (implement_dynamic) then output_cpp " HX_APPEND_DYNAMIC_FIELDS(outFields);\n"; output_cpp " super::__GetFields(outFields);\n"; output_cpp "};\n\n"; let dump_field_name = (fun field -> output_cpp (" " ^ (str field.cf_name) ^ ",\n")) in output_cpp "static ::String sStaticFields[] = {\n"; List.iter dump_field_name class_def.cl_ordered_statics; output_cpp " String(null()) };\n\n"; output_cpp "static ::String sMemberFields[] = {\n"; List.iter dump_field_name class_def.cl_ordered_fields; output_cpp " String(null()) };\n\n"; (* MARK function - only used with internal GC *) output_cpp "static void sMarkStatics(HX_MARK_PARAMS) {\n"; List.iter (fun field -> if (is_data_member field) then output_cpp (" HX_MARK_MEMBER_NAME(" ^ class_name ^ "::" ^ (keyword_remap field.cf_name) ^ ",\"" ^ field.cf_name ^ "\");\n") ) class_def.cl_ordered_statics; output_cpp "};\n\n"; end; (* Initialise static in boot function ... *) if (not class_def.cl_interface) then begin (* Remap the specialised "extern" classes back to the generic names *) let class_name_text = match class_path with | path -> join_class_path path "." in output_cpp ("Class " ^ class_name ^ "::__mClass;\n\n"); output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); output_cpp (" Static(__mClass) = hx::RegisterClass(" ^ (str class_name_text) ^ ", hx::TCanCast< " ^ class_name ^ "> ,sStaticFields,sMemberFields,\n"); output_cpp (" &__CreateEmpty, &__Create,\n"); output_cpp (" &super::__SGetClass(), 0, sMarkStatics);\n"); output_cpp ("}\n\n"); output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); List.iter (gen_field_init ctx ) class_def.cl_ordered_statics; output_cpp ("}\n\n"); end else begin let class_name_text = join_class_path class_path "." in output_cpp ("Class " ^ class_name ^ "::__mClass;\n\n"); output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); output_cpp (" Static(__mClass) = hx::RegisterClass(" ^ (str class_name_text) ^ ", hx::TCanCast< " ^ class_name ^ "> ,0,0,\n"); output_cpp (" 0, 0,\n"); output_cpp (" &super::__SGetClass(), 0, 0);\n"); output_cpp ("}\n\n"); end; gen_close_namespace output_cpp class_path; cpp_file#close; let h_file = new_header_file common_ctx.file class_path in let super = match class_def.cl_super with | Some (klass,params) -> (class_string klass "_obj" params) | _ -> if (class_def.cl_interface) then "hx::Interface" else "hx::Object" in let output_h = (h_file#write) in let def_string = join_class_path class_path "_" in ctx.ctx_output <- output_h; begin_header_file output_h def_string; (* Include the real header file for the super class *) (match class_def.cl_super with | Some super -> let super_path = (fst super).cl_path in output_h ("#include <" ^ ( join_class_path super_path "/" ) ^ ".h>\n") | _ -> () ); (* And any interfaces ... *) List.iter (fun imp-> let imp_path = (fst imp).cl_path in output_h ("#include <" ^ ( join_class_path imp_path "/" ) ^ ".h>\n") ) (real_interfaces class_def.cl_implements); (* Only need to foreward-declare classes that are mentioned in the header file (ie, not the implementation) *) let referenced = find_referenced_types ctx.ctx_common (TClassDecl class_def) super_deps (Hashtbl.create 0) true in List.iter ( gen_forward_decl h_file ) referenced; output_h ( get_code class_def.cl_meta ":headerCode" ); gen_open_namespace output_h class_path; output_h "\n\n"; output_h ( get_code class_def.cl_meta ":headerNamespaceCode" ); output_h ("class " ^ class_name ^ " : public " ^ super ); output_h "{\n public:\n"; output_h (" typedef " ^ super ^ " super;\n"); output_h (" typedef " ^ class_name ^ " OBJ_;\n"); if (not class_def.cl_interface) then begin output_h (" " ^ class_name ^ "();\n"); output_h (" Void __construct(" ^ constructor_type_args ^ ");\n"); output_h "\n public:\n"; output_h (" static " ^ptr_name^ " __new(" ^constructor_type_args ^");\n"); output_h (" static Dynamic __CreateEmpty();\n"); output_h (" static Dynamic __Create(hx::DynamicArray inArgs);\n"); output_h (" ~" ^ class_name ^ "();\n\n"); output_h (" HX_DO_RTTI;\n"); if (field_integer_dynamic) then output_h " Dynamic __IField(int inFieldID);\n"; if (field_integer_numeric) then output_h " double __INumField(int inFieldID);\n"; if (implement_dynamic) then output_h (" HX_DECLARE_IMPLEMENT_DYNAMIC;\n"); output_h (" static void __boot();\n"); output_h (" static void __register();\n"); output_h (" void __Mark(HX_MARK_PARAMS);\n"); List.iter (fun interface_name -> output_h (" inline operator " ^ interface_name ^ "_obj *()\n " ^ "{ return new " ^ interface_name ^ "_delegate_< " ^ class_name ^" >(this); }\n" ); ) implemented; if ( (List.length implemented) > 0 ) then output_h " hx::Object *__ToInterface(const type_info &inType);\n"; if (has_init_field class_def) then output_h " static void __init__();\n\n"; output_h (" ::String __ToString() const { return " ^ (str smart_class_name) ^ "; }\n\n"); end else begin output_h (" HX_DO_INTERFACE_RTTI;\n"); end; (match class_def.cl_array_access with | Some t -> output_h (" typedef " ^ (type_string t) ^ " __array_access;\n") | _ -> ()); let interface = class_def.cl_interface in List.iter (gen_member_def ctx class_def false interface) class_def.cl_ordered_fields; List.iter (gen_member_def ctx class_def true interface) class_def.cl_ordered_statics; output_h ( get_code class_def.cl_meta ":headerClassCode" ); output_h "};\n\n"; if (class_def.cl_interface) then begin output_h ("#define DELEGATE_" ^ (join_class_path class_def.cl_path "_" ) ^ " \\\n"); List.iter (fun field -> match follow field.cf_type, field.cf_kind with | TFun (args,return_type), Method _ -> (* TODO : virtual ? *) let remap_name = keyword_remap field.cf_name in output_h ( "virtual " ^ (type_string return_type) ^ " " ^ remap_name ^ "( " ); output_h (String.concat "," (List.map (fun (name,opt,typ) -> (type_string typ) ^ " " ^ name ^ (if opt then "=null()" else "")) args)); output_h (") { return mDelegate->" ^ remap_name^ "("); output_h (String.concat "," (List.map (fun (name,opt,typ) -> name) args)); output_h ");} \\\n"; output_h ("virtual Dynamic " ^ remap_name ^ "_dyn() { return mDelegate->" ^ remap_name ^ "_dyn();} \\\n"); | _ -> () ) class_def.cl_ordered_fields; output_h ("\n\n"); output_h ("template\n"); output_h ("class " ^ smart_class_name ^ "_delegate_ : public " ^ class_name^"\n"); output_h "{\n protected:\n"; output_h (" IMPL *mDelegate;\n"); output_h " public:\n"; output_h (" " ^ smart_class_name ^ "_delegate_(IMPL *inDelegate) : mDelegate(inDelegate) {}\n"); output_h (" hx::Object *__GetRealObject() { return mDelegate; }\n"); let rec dump_delegate interface = output_h (" DELEGATE_" ^ (join_class_path interface.cl_path "_" ) ^ "\n"); match interface.cl_super with | Some super -> dump_delegate (fst super) | _ -> (); in dump_delegate class_def; output_h "};\n\n"; end; gen_close_namespace output_h class_path; end_header_file output_h def_string; h_file#close; all_referenced;; let gen_deps deps = let project_deps = List.filter (fun path -> not (is_internal_class path) ) deps in String.concat " " (List.map (fun class_path -> "include/" ^ (join_class_path class_path "/") ^ ".h") project_deps );; let add_class_to_makefile makefile add_obj class_def = let class_path = fst class_def in let deps = snd class_def in let obj_file = "obj/" ^ (join_class_path class_path "-") ^ "$(OBJ)" in let cpp = (join_class_path class_path "/") ^ ".cpp" in output_string makefile ( obj_file ^ " : src/" ^ cpp ^ " " ^ (gen_deps deps) ^ "\n"); output_string makefile ("\t$(COMPILE) src/" ^ cpp ^ " $(OUT_FLAGS)$@\n\n"); output_string makefile (add_obj ^ " " ^ obj_file ^ "\n\n" );; let kind_string = function | KNormal -> "KNormal" | KTypeParameter -> "KTypeParameter" | KExtension _ -> "KExtension" | KExpr _ -> "KExpr" | KGeneric -> "KGeneric" | KMacroType -> "KMacroType" | KGenericInstance _ -> "KGenericInstance";; let write_resources common_ctx = let resource_file = new_cpp_file common_ctx.file ([],"__resources__") in resource_file#write "#include \n\n"; let idx = ref 0 in Hashtbl.iter (fun _ data -> resource_file#write_i ("static unsigned char __res_" ^ (string_of_int !idx) ^ "[] = {\n"); for i = 0 to String.length data - 1 do let code = Char.code (String.unsafe_get data i) in resource_file#write (Printf.sprintf "0x%.2x, " code); if ( (i mod 10) = 9) then resource_file#write "\n"; done; resource_file#write ("};\n"); incr idx; ) common_ctx.resources; idx := 0; resource_file#write "hx::Resource __Resources[] ="; resource_file#begin_block; Hashtbl.iter (fun name data -> resource_file#write_i ("{ " ^ (str name) ^ "," ^ (string_of_int (String.length data)) ^ "," ^ "__res_" ^ (string_of_int !idx) ^ " },\n"); incr idx; ) common_ctx.resources; resource_file#write_i "{String(null()),0,0}"; resource_file#end_block_line; resource_file#write ";\n\n"; resource_file#write "namespace hx { Resource *GetResources() { return __Resources; } } \n\n"; resource_file#close;; let add_class_to_buildfile buildfile class_def = let class_path = fst class_def in let deps = snd class_def in let cpp = (join_class_path class_path "/") ^ ".cpp" in output_string buildfile ( " \n" ); let project_deps = List.filter (fun path -> not (is_internal_class path) ) deps in List.iter (fun path-> output_string buildfile (" \n") ) project_deps; output_string buildfile ( " \n" );; let write_build_data filename classes main_deps build_extra exe_name = let buildfile = open_out filename in output_string buildfile "\n"; output_string buildfile "\n"; output_string buildfile "\n"; List.iter (add_class_to_buildfile buildfile) classes; add_class_to_buildfile buildfile ( ( [] , "__boot__") , [] ); add_class_to_buildfile buildfile ( ( [] , "__resources__") , [] ); output_string buildfile "\n"; output_string buildfile "\n"; output_string buildfile "\n"; add_class_to_buildfile buildfile ( ( [] , "__lib__") , main_deps ); output_string buildfile "\n"; output_string buildfile "\n"; output_string buildfile "\n"; add_class_to_buildfile buildfile ( ( [] , "__main__") , main_deps ); output_string buildfile "\n"; output_string buildfile ("\n"); output_string buildfile "\n"; output_string buildfile build_extra; output_string buildfile "\n"; close_out buildfile;; let write_build_options filename options = let writer = cached_source_writer filename in PMap.iter ( fun name _ -> if (name <> "debug") then writer#write ( name ^ "\n") ) options; let cmd = Unix.open_process_in "haxelib path hxcpp" in writer#write (Pervasives.input_line cmd); Pervasives.ignore (Unix.close_process_in cmd); writer#close;; let create_member_types common_ctx = let result = Hashtbl.create 0 in let add_member class_name interface member = match follow member.cf_type, member.cf_kind with | _, Var _ when interface -> () | TFun (_,ret), _ -> (*print_endline (class_name ^ "." ^ member.cf_name ^ "=" ^ (type_string ret) );*) Hashtbl.add result (class_name ^ "." ^ member.cf_name) (type_string ret) | _,_ when not interface -> Hashtbl.add result (class_name ^ "." ^ member.cf_name) (type_string member.cf_type) | _ -> () in List.iter (fun object_def -> (match object_def with | TClassDecl class_def -> let class_name = "::" ^ (join_class_path class_def.cl_path "::") in let rec add_all_fields class_def = (match class_def.cl_super with Some super -> add_all_fields (fst super) | _->();); List.iter (add_member class_name class_def.cl_interface) class_def.cl_ordered_fields; List.iter (add_member class_name class_def.cl_interface) class_def.cl_ordered_statics in add_all_fields class_def | _ -> ( ) ) ) common_ctx.types; result;; (* Builds inheritance tree, so header files can include parents defs. *) let create_super_dependencies common_ctx = let result = Hashtbl.create 0 in List.iter (fun object_def -> (match object_def with | TClassDecl class_def -> let deps = ref [] in (match class_def.cl_super with Some super -> deps := ((fst super).cl_path) :: !deps | _ ->() ); List.iter (fun imp -> deps := (fst imp).cl_path :: !deps) (real_interfaces class_def.cl_implements); Hashtbl.add result class_def.cl_path !deps; | TEnumDecl enum_def -> Hashtbl.add result enum_def.e_path []; | _ -> () ); ) common_ctx.types; result;; let create_constructor_dependencies common_ctx = let result = Hashtbl.create 0 in List.iter (fun object_def -> (match object_def with | TClassDecl class_def -> (match class_def.cl_constructor with | Some func_def -> Hashtbl.add result class_def.cl_path func_def | _ -> () ) | _ -> () ); ) common_ctx.types; result;; (* The common_ctx contains the haxe AST in the "types" field and the resources *) let generate common_ctx = make_base_directory common_ctx.file; let debug = false in let exe_classes = ref [] in let boot_classes = ref [] in let init_classes = ref [] in let class_text path = join_class_path path "::" in let member_types = create_member_types common_ctx in let super_deps = create_super_dependencies common_ctx in let constructor_deps = create_constructor_dependencies common_ctx in let main_deps = ref [] in let build_xml = ref "" in List.iter (fun object_def -> (match object_def with | TClassDecl class_def when class_def.cl_extern -> () | TClassDecl class_def -> let name = class_text class_def.cl_path in let is_internal = is_internal_class class_def.cl_path in if (is_internal || (is_macro class_def.cl_meta) ) then ( if debug then print_endline (" internal class " ^ name )) else begin build_xml := !build_xml ^ (get_code class_def.cl_meta ":buildXml"); boot_classes := class_def.cl_path :: !boot_classes; if (has_init_field class_def) then init_classes := class_def.cl_path :: !init_classes; let deps = generate_class_files common_ctx member_types super_deps constructor_deps class_def in exe_classes := (class_def.cl_path, deps) :: !exe_classes; end | TEnumDecl enum_def -> let name = class_text enum_def.e_path in let is_internal = is_internal_class enum_def.e_path in if (is_internal) then (if debug then print_endline (" internal enum " ^ name )) else begin let meta = Codegen.build_metadata common_ctx object_def in if (enum_def.e_extern) then (if debug then print_endline ("external enum " ^ name )); boot_classes := enum_def.e_path :: !boot_classes; let deps = generate_enum_files common_ctx enum_def super_deps meta in exe_classes := (enum_def.e_path, deps) :: !exe_classes; end | TTypeDecl _ -> (* already done *) () ); ) common_ctx.types; (match common_ctx.main with | None -> generate_dummy_main common_ctx | Some e -> let main_field = { cf_name = "__main__"; cf_type = t_dynamic; cf_expr = Some e; cf_pos = e.epos; cf_public = true; cf_meta = []; cf_doc = None; cf_kind = Var { v_read = AccNormal; v_write = AccNormal; }; cf_params = [] } in let class_def = { null_class with cl_path = ([],"@Main"); cl_ordered_statics = [main_field] } in main_deps := find_referenced_types common_ctx (TClassDecl class_def) super_deps constructor_deps false; generate_main common_ctx member_types super_deps class_def ); generate_boot common_ctx !boot_classes !init_classes; write_resources common_ctx; let output_name = match common_ctx.main_class with | Some path -> (snd path) | _ -> "output" in write_build_data (common_ctx.file ^ "/Build.xml") !exe_classes !main_deps !build_xml output_name; write_build_options (common_ctx.file ^ "/Options.txt") common_ctx.defines; if ( not (Common.defined common_ctx "no-compilation") ) then begin let old_dir = Sys.getcwd() in Sys.chdir common_ctx.file; let cmd = ref "haxelib run hxcpp Build.xml haxe" in if (common_ctx.debug) then cmd := !cmd ^ " -Ddebug"; PMap.iter ( fun name _ -> cmd := !cmd ^ " -D" ^ name ^ "" ) common_ctx.defines; print_endline !cmd; if Sys.command !cmd <> 0 then failwith "Build failed"; Sys.chdir old_dir; end ;;