diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index cba7acea52e..f30a0bd0cfc 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -1,6 +1,45 @@ open Type open Globals +module PathMap = Map.Make(struct type t = path let compare i1 i2 = String.compare (s_type_path i2) (s_type_path i1) end) + +module ObjectIds = struct + type t = { + ids : int32 PathMap.t; + cache : unit Int32Map.t; + } + + let empty = { ids = PathMap.empty; cache = Int32Map.empty } + + let add path id store = + { ids = PathMap.add path id store.ids; cache = Int32Map.add id () store.cache } + + let find_opt path store = + PathMap.find_opt path store.ids + + let collision id store = + Int32Map.mem id store.cache +end + +module InterfaceSlots = struct + type t = { + hash : int StringMap.t; + next : int; + } + + let empty = { hash = StringMap.empty; next = 2 } + + let add name slots = + match StringMap.find_opt name slots.hash with + | Some slot -> + slots + | None -> + { hash = StringMap.add name slots.next slots.hash; next = slots.next + 1 } + + let find_opt name slots = + StringMap.find_opt name slots.hash +end + type tcpp = | TCppDynamic | TCppUnchanged @@ -44,7 +83,7 @@ and tcpp_closure = { close_args : (tvar * texpr option) list; close_expr : tcppexpr; close_id : int; - close_undeclared : (string, tvar) Hashtbl.t; + close_undeclared : tvar StringMap.t; close_this : tcppthis option; } @@ -152,3 +191,109 @@ and tcpp_expr_expr = | CppCastObjCBlock of tcppexpr * tcpp list * tcpp | CppCastProtocol of tcppexpr * tclass | CppCastNative of tcppexpr + +and tcpp_class_container = + | Current (* If the current class holds GC variables *) + | Parent (* If one of the current classes parents holds GC variables *) + +and tcpp_class_flags = + | QuickAlloc + | Scriptable + | MemberGet + | MemberSet + | StaticGet + | StaticSet + | GetFields + | Compare + | Boot + +and tcpp_class_function = { + tcf_field : tclass_field; + tcf_name : string; + tcf_func : tfunc; + + tcf_is_virtual : bool; + tcf_is_reflective : bool; + tcf_is_external : bool; + tcf_is_scriptable : bool; + tcf_is_overriding : bool; +} + +and tcpp_class_variable = { + tcv_field : tclass_field; + tcv_name : string; + tcv_type : t; + tcv_default : texpr option; + + tcv_is_stackonly : bool; + tcv_is_gc_element : bool; + tcv_is_reflective : bool; +} + +and tcpp_class = { + tcl_class : tclass; + tcl_params : tparams; + tcl_name : string; + tcl_id : int32; + tcl_flags : int; + tcl_debug_level : int; + tcl_super : tcpp_class option; + tcl_container : tcpp_class_container option; + + tcl_haxe_interfaces : tcpp_interface list; + tcl_native_interfaces : tcpp_interface list; + + tcl_static_variables : tcpp_class_variable list; + tcl_static_properties : tcpp_class_variable list; + tcl_static_functions : tcpp_class_function list; + tcl_static_dynamic_functions : tcpp_class_function list; + + tcl_variables : tcpp_class_variable list; + tcl_properties : tcpp_class_variable list; + tcl_functions : tcpp_class_function list; + tcl_dynamic_functions : tcpp_class_function list; + + tcl_meta : texpr option; + tcl_rtti : texpr option; + tcl_init : texpr option; +} + +and tcpp_interface_function = { + iff_field : tclass_field; + iff_name : string; + iff_args : (string * bool * t) list; + iff_return : t; + iff_script_slot : int option; +} + +and tcpp_interface = { + if_class : tclass; + if_name : string; + if_hash : string; + if_debug_level : int; + if_functions : tcpp_interface_function list; + if_variables : tclass_field list; + if_extends : tcpp_interface option; + if_meta : texpr option; + if_rtti : texpr option; + if_scriptable : bool; +} + +and tcpp_enum_field = { + tef_field : tenum_field; + tef_name : string; + tef_hash : string; +} + +and tcpp_enum = { + te_enum : tenum; + te_id : int32; + te_constructors : tcpp_enum_field list; +} + +and tcpp_decl = + | ManagedClass of tcpp_class + | NativeClass of tcpp_class + | ManagedInterface of tcpp_interface + | NativeInterface of tcpp_interface + | Enum of tcpp_enum diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index 19873479286..705e9c33a54 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -6,6 +6,8 @@ open CppTypeUtils let follow = Abstract.follow_with_abstracts +let string_map_of_list bs = List.fold_left (fun m (k, v) -> StringMap.add k v m) StringMap.empty bs + (* 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 "::" @@ -588,6 +590,19 @@ and array_element_type haxe_type = | _ -> "::Dynamic" and cpp_function_signature tfun abi = + let gen_interface_arg_type_name name opt typ = + let type_str = (type_string typ) in + (* type_str may have already converted Null to Dynamic because of NotNull tag ... *) + (if (opt && (cant_be_null typ) && type_str<>"Dynamic" ) then + "::hx::Null< " ^ type_str ^ " > " + else + type_str ) ^ " " ^ (keyword_remap name) + in + + let gen_tfun_interface_arg_list args = + String.concat "," (List.map (fun (name,opt,typ) -> gen_interface_arg_type_name name opt typ) args) + in + match follow tfun with | TFun(args,ret) -> (type_string ret) ^ " " ^ abi ^ "(" ^ (gen_tfun_interface_arg_list args) ^ ")" | _ -> "void *" @@ -600,18 +615,7 @@ and cpp_function_signature_params params = match params with | _ -> print_endline ("Params:" ^ (String.concat "," (List.map type_string params) )); die "" __LOC__; - -and gen_interface_arg_type_name name opt typ = - let type_str = (type_string typ) in - (* type_str may have already converted Null to Dynamic because of NotNull tag ... *) - (if (opt && (cant_be_null typ) && type_str<>"Dynamic" ) then - "::hx::Null< " ^ type_str ^ " > " - else - type_str ) ^ " " ^ (keyword_remap name) - -and gen_tfun_interface_arg_list args = - String.concat "," (List.map (fun (name,opt,typ) -> gen_interface_arg_type_name name opt typ) args) - + and cant_be_null haxe_type = is_numeric haxe_type || (type_has_meta_key Meta.NotNull haxe_type ) @@ -725,3 +729,37 @@ let enum_getter_type t = | TCppScalar "bool" -> "Bool" | TCppScalar x -> x | _ -> "Object" + +let int_of_tcpp_class_flag (flag:tcpp_class_flags) = + Obj.magic flag + +let set_tcpp_class_flag flags c = + set_flag flags (int_of_tcpp_class_flag c) + +let has_tcpp_class_flag c flag = + has_flag c.tcl_flags (int_of_tcpp_class_flag flag) + +let all_interface_functions tcpp_interface = + let add_interface_functions existing interface = + let folder acc cur = + if List.exists (fun f -> f.iff_name = cur.iff_name) acc then + acc + else + cur :: acc + in + List.fold_left folder existing interface.if_functions + in + + let rec visit_interface existing interface = + let initial = + match interface.if_extends with + | None -> + existing + | Some super -> + visit_interface existing super + in + + add_interface_functions initial interface + in + + visit_interface [] tcpp_interface |> List.rev diff --git a/src/generators/cpp/cppContext.ml b/src/generators/cpp/cppContext.ml index 37850d973c4..bcf900708df 100644 --- a/src/generators/cpp/cppContext.ml +++ b/src/generators/cpp/cppContext.ml @@ -1,4 +1,6 @@ open Gctx +open Globals +open Type open CppAstTools (* CPP code generation context *) @@ -17,20 +19,19 @@ type context = { mutable ctx_debug_level : int; (* cached as required *) mutable ctx_file_info : (string, string) PMap.t ref; - ctx_type_ids : (string, Int32.t) Hashtbl.t; (* Per file *) ctx_output : string -> unit; ctx_writer : CppSourceWriter.source_writer; ctx_file_id : int ref; ctx_is_header : bool; - ctx_interface_slot : (string, int) Hashtbl.t ref; - ctx_interface_slot_count : int ref; + ctx_super_deps : path list CppAst.PathMap.t; + ctx_constructor_deps : tclass_field CppAst.PathMap.t; + ctx_class_member_types : string StringMap.t; (* This is for returning from the child nodes of TSwitch && TTry *) mutable ctx_real_this_ptr : bool; - mutable ctx_class_member_types : (string, string) Hashtbl.t; } -let new_context common_ctx debug file_info member_types = +let new_context common_ctx debug file_info member_types super_deps constructor_deps = let null_file = new CppSourceWriter.source_writer common_ctx ignore ignore (fun () -> ()) in @@ -40,11 +41,8 @@ let new_context common_ctx debug file_info member_types = ctx_common = common_ctx; ctx_writer = null_file; ctx_file_id = ref (-1); - ctx_type_ids = Hashtbl.create 0; ctx_is_header = false; ctx_output = null_file#write; - ctx_interface_slot = ref (Hashtbl.create 0); - ctx_interface_slot_count = ref 2; ctx_debug_level = (if has_def Define.AnnotateSource then 3 else if has_def Define.HxcppDebugger then 2 @@ -52,6 +50,8 @@ let new_context common_ctx debug file_info member_types = ctx_real_this_ptr = true; ctx_class_member_types = member_types; ctx_file_info = file_info; + ctx_super_deps = super_deps; + ctx_constructor_deps = constructor_deps; } in result diff --git a/src/generators/cpp/cppExprUtils.ml b/src/generators/cpp/cppExprUtils.ml deleted file mode 100644 index d64e040beba..00000000000 --- a/src/generators/cpp/cppExprUtils.ml +++ /dev/null @@ -1,19 +0,0 @@ -open Type - -let rec remove_parens expression = - match expression.eexpr with - | TParenthesis e -> remove_parens e - | TMeta(_,e) -> remove_parens e - | _ -> expression - -let rec remove_parens_cast expression = - match expression.eexpr with - | TParenthesis e -> remove_parens_cast e - | TMeta(_,e) -> remove_parens_cast e - | TCast ( e,None) -> remove_parens_cast e - | _ -> expression - -let is_static_access obj = - match (remove_parens obj).eexpr with - | TTypeExpr _ -> true - | _ -> false diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 03a455b2946..d48d9d093f7 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -180,48 +180,69 @@ let cpp_function_type_of_string = cpp_function_type_of_string [] let cpp_function_type_of_args_ret = cpp_function_type_of_args_ret [] let cpp_instance_type = cpp_instance_type [] +type retyper_ctx = { + closure_id : int; + closures : tcpp_closure list; + injection : bool; + declarations : unit StringMap.t; + undeclared : tvar StringMap.t; + uses_this : tcppthis option; + this_real : tcppthis; + gc_stack : bool; + function_return_type : tcpp; + goto_id : int; + loop_stack : (int * bool) list; +} + let expression ctx request_type function_args function_type expression_tree forInjection = - let rev_closures = ref [] in - let closureId = ref 0 in - let declarations = ref (Hashtbl.create 0) in - let undeclared = ref (Hashtbl.create 0) in - let uses_this = ref None in - let gc_stack = ref false in - let injection = ref forInjection in - let this_real = ref (if ctx.ctx_real_this_ptr then ThisReal else ThisDynamic) in - let file_id = ctx.ctx_file_id in - let function_return_type = ref (cpp_type_of function_type) in - let loop_stack = ref [] in let forCppia = Gctx.defined ctx.ctx_common Define.Cppia in - let alloc_file_id () = - incr file_id; - !file_id - in - let begin_loop () = - loop_stack := (alloc_file_id (), ref false) :: !loop_stack; - fun () -> - match !loop_stack with - | (label_id, used) :: tl -> - loop_stack := tl; - if !used then label_id else -1 - | [] -> abort "Invalid inernal loop handling" expression_tree.epos + let initial_ctx = { + closures = []; + closure_id = 0; + injection = forInjection; + undeclared = StringMap.empty; + declarations = function_args |> List.map (fun a -> a.v_name, ()) |> string_map_of_list |> StringMap.add "__trace" (); (* '__trace' is at the top-level *) + uses_this = None; + this_real = if ctx.ctx_real_this_ptr then ThisReal else ThisDynamic; + gc_stack = false; + function_return_type = cpp_type_of function_type; + goto_id = 0; + loop_stack = []; + } in + + (* Helper functions *) + + let alloc_file_id retyper_ctx = + ({ retyper_ctx with goto_id = retyper_ctx.goto_id + 1 }, retyper_ctx.goto_id + 1) in - (* '__trace' is at the top-level *) - Hashtbl.add !declarations "__trace" (); - List.iter (fun arg -> Hashtbl.add !declarations arg.v_name ()) function_args; + let begin_loop retyper_ctx = + let new_ctx = { + retyper_ctx with + goto_id = retyper_ctx.goto_id + 1; + loop_stack = (retyper_ctx.goto_id + 1, false) :: retyper_ctx.loop_stack + } in + let resolver = + fun retyper_ctx -> + match retyper_ctx.loop_stack with + | (label_id, used) :: tl -> + { retyper_ctx with loop_stack = tl }, if used then label_id else -1 + | [] -> + abort "Invalid inernal loop handling" expression_tree.epos + in - (* Helper functions *) + new_ctx, resolver + in - let cpp_const_type cval = + let cpp_const_type retyper_ctx cval = match cval with - | TInt i -> (CppInt i, TCppScalar "int") - | TBool b -> (CppBool b, TCppScalar "bool") - | TFloat f -> (CppFloat (Texpr.replace_separators f ""), TCppScalar "Float") - | TString s -> (CppString s, TCppString) + | TInt i -> (retyper_ctx, CppInt i, TCppScalar "int") + | TBool b -> (retyper_ctx, CppBool b, TCppScalar "bool") + | TFloat f -> (retyper_ctx, CppFloat (Texpr.replace_separators f ""), TCppScalar "Float") + | TString s -> (retyper_ctx, CppString s, TCppString) | _ -> (* TNull, TThis & TSuper should already be handled *) - (CppNull, TCppNull) + (retyper_ctx, CppNull, TCppNull) in let cpp_return_type haxe_type = @@ -364,623 +385,614 @@ let expression ctx request_type function_args function_type expression_tree forI in (* Core Retyping *) - let rec retype return_type expr = + let rec retype retyper_ctx return_type expr = let cpp_type_of t = cpp_type_of t in let mk_cppexpr newExpr newType = { cppexpr = newExpr; cpptype = newType; cpppos = expr.epos } in - let retype_function_args args arg_types = - let rec map_pair args types result = - match (args, types) with - | args, [ TCppRest rest ] -> - List.rev (List.map (retype rest) args) @ result - | [], [] -> result - | a :: arest, t :: trest -> map_pair arest trest (retype t a :: result) - | _, [] -> abort "Too many args" expr.epos - | [], _ -> abort "Too many types" expr.epos + let retype_function_args retyper_ctx args arg_types = + let folder (acc_ctx, acc_exprs) arg t = + let new_ctx, new_expr = retype acc_ctx t arg in + new_ctx, new_expr :: acc_exprs in - List.rev (map_pair args arg_types []) + + arg_types + |> ExtList.List.fold_left2 folder (retyper_ctx, []) args + |> fun (ctx, acc) -> (ctx, List.rev acc) in - let retypedExpr, retypedType = + let retyper_ctx, retypedExpr, retypedType = match expr.eexpr with | TEnumParameter (enumObj, enumField, enumIndex) -> - let retypedObj = retype TCppDynamic enumObj in - ( CppEnumParameter (retypedObj, enumField, enumIndex), + let retyper_ctx, retypedObj = retype retyper_ctx TCppDynamic enumObj in + ( retyper_ctx, + CppEnumParameter (retypedObj, enumField, enumIndex), cpp_cast_variant_type_of (cpp_type_of (get_nth_type enumField enumIndex)) ) | TEnumIndex enumObj -> - let retypedObj = retype TCppDynamic enumObj in - (CppEnumIndex retypedObj, TCppScalar "int") + let retyper_ctx, retypedObj = retype retyper_ctx TCppDynamic enumObj in + (retyper_ctx, CppEnumIndex retypedObj, TCppScalar "int") | TConst TThis -> - uses_this := Some !this_real; - ( CppThis !this_real, - if !this_real = ThisDynamic then TCppDynamic + let retyper_ctx = { retyper_ctx with uses_this = Some retyper_ctx.this_real } in + ( retyper_ctx, + CppThis retyper_ctx.this_real, + if retyper_ctx.this_real = ThisDynamic then TCppDynamic else cpp_type_of expr.etype ) | TConst TSuper -> - uses_this := Some !this_real; - ( CppSuper !this_real, - if !this_real = ThisDynamic then TCppDynamic + let retyper_ctx = { retyper_ctx with uses_this = Some retyper_ctx.this_real } in + ( retyper_ctx, + CppSuper retyper_ctx.this_real, + if retyper_ctx.this_real = ThisDynamic then TCppDynamic else cpp_type_of expr.etype ) - | TConst TNull when is_objc_type expr.etype -> (CppNil, TCppNull) - | TConst x -> cpp_const_type x + | TConst TNull when is_objc_type expr.etype -> (retyper_ctx, CppNil, TCppNull) + | TConst x -> cpp_const_type retyper_ctx x | TIdent "__global__" -> (* functions/vars will appear to be members of the virtual global object *) - (CppClassOf (([], ""), false), TCppGlobal) + (retyper_ctx, CppClassOf (([], ""), false), TCppGlobal) | TLocal tvar -> let name = tvar.v_name in - if Hashtbl.mem !declarations name then - (*print_endline ("Using existing tvar " ^ tvar.v_name);*) - (CppVar (VarLocal tvar), cpp_type_of tvar.v_type) + if StringMap.mem name retyper_ctx.declarations then + (retyper_ctx, CppVar (VarLocal tvar), cpp_type_of tvar.v_type) else ( - (*print_endline ("Missing tvar " ^ tvar.v_name);*) - Hashtbl.replace !undeclared name tvar; + let new_ctx = { retyper_ctx with undeclared = StringMap.add name tvar retyper_ctx.undeclared } in if has_var_flag tvar VCaptured then - (CppVar (VarClosure tvar), cpp_type_of tvar.v_type) - else (CppExtern (name, false), cpp_type_of tvar.v_type)) - | TIdent name -> (CppExtern (name, false), return_type) + (new_ctx, CppVar (VarClosure tvar), cpp_type_of tvar.v_type) + else + (new_ctx, CppExtern (name, false), cpp_type_of tvar.v_type)) + | TIdent name -> (retyper_ctx, CppExtern (name, false), return_type) | TBreak -> ( - if forCppia then (CppBreak, TCppVoid) + if forCppia then + (retyper_ctx, CppBreak, TCppVoid) else - match !loop_stack with - | [] -> (CppBreak, TCppVoid) - | (label_id, used) :: _ -> - used := true; - (CppGoto label_id, TCppVoid)) - | TContinue -> (CppContinue, TCppVoid) - | TThrow e1 -> (CppThrow (retype TCppDynamic e1), TCppVoid) + match retyper_ctx.loop_stack with + | [] -> + (retyper_ctx, CppBreak, TCppVoid) + | (label_id, used) :: tl -> + ({ retyper_ctx with loop_stack = (label_id, true) :: tl }, CppGoto label_id, TCppVoid)) + | TContinue -> (retyper_ctx, CppContinue, TCppVoid) + | TThrow e1 -> + let retyper_ctx, retyped_expr = retype retyper_ctx TCppDynamic e1 in + (retyper_ctx, CppThrow retyped_expr, TCppVoid) | TMeta ((Meta.Fixed, _, _), e) -> ( - let cppType = retype return_type e in + let retyper_ctx, cppType = retype retyper_ctx return_type e in match cppType.cppexpr with | CppObjectDecl (def, false) -> - (CppObjectDecl (def, true), cppType.cpptype) - | _ -> (cppType.cppexpr, cppType.cpptype)) + (retyper_ctx, CppObjectDecl (def, true), cppType.cpptype) + | _ -> + (retyper_ctx, cppType.cppexpr, cppType.cpptype)) | TMeta (_, e) | TParenthesis e -> - let cppType = retype return_type e in - (cppType.cppexpr, cppType.cpptype) + let retyper_ctx, cppType = retype retyper_ctx return_type e in + (retyper_ctx, cppType.cppexpr, cppType.cpptype) | TField (obj, field) -> ( match field with | FInstance (clazz, params, member) | FClosure (Some (clazz, params), member) -> ( - let funcReturn = cpp_member_return_type member in - let clazzType = cpp_instance_type clazz params in - let retypedObj = retype clazzType obj in - let exprType = cpp_type_of member.cf_type in - let is_objc = is_cpp_objc_type retypedObj.cpptype in - - if retypedObj.cpptype = TCppNull then (CppNullAccess, TCppDynamic) - else if - retypedObj.cpptype = TCppDynamic - && not (has_class_flag clazz CInterface) - then - if is_internal_member member.cf_name then - ( CppFunction - (FuncInstance (retypedObj, InstPtr, member), funcReturn), + let funcReturn = cpp_member_return_type member in + let clazzType = cpp_instance_type clazz params in + let retyper_ctx, retypedObj = retype retyper_ctx clazzType obj in + let exprType = cpp_type_of member.cf_type in + let is_objc = is_cpp_objc_type retypedObj.cpptype in + + if retypedObj.cpptype = TCppNull then + (retyper_ctx, CppNullAccess, TCppDynamic) + else if retypedObj.cpptype = TCppDynamic && not (has_class_flag clazz CInterface) then + if is_internal_member member.cf_name then + ( retyper_ctx, + CppFunction (FuncInstance (retypedObj, InstPtr, member), funcReturn), + exprType ) + else + (retyper_ctx, CppDynamicField (retypedObj, member.cf_name), TCppVariant) + else if cpp_is_struct_access retypedObj.cpptype then + match retypedObj.cppexpr with + | CppThis ThisReal -> + (retyper_ctx, CppVar (VarThis (member, retypedObj.cpptype)), exprType) + | CppSuper this -> + ( retyper_ctx, + CppFunction ( FuncSuper (this, retypedObj.cpptype, member), funcReturn ), + exprType ) + | _ -> + if is_var_field member then + ( retyper_ctx, + CppVar (VarInstance (retypedObj, member, tcpp_to_string clazzType, ".")), + exprType ) + else + ( retyper_ctx, + CppFunction ( FuncInstance (retypedObj, InstStruct, member), funcReturn ), + exprType ) + else if is_var_field member then + let exprType = + match (retypedObj.cpptype, exprType) with + | TCppPointer (_, t), TCppDynamic + | ( TCppRawPointer (_, t), + TCppDynamic + (* the 'type parameter' will show up as Dynamic *) ) -> + t + | _ -> exprType + in + + match retypedObj.cppexpr with + | CppThis ThisReal -> + (retyper_ctx, CppVar (VarThis (member, retypedObj.cpptype)), exprType) + | _ -> ( + match (retypedObj.cpptype, member.cf_name) with + (* Special variable remapping ... *) + | TCppDynamicArray, "length" when not forCppia -> + ( retyper_ctx, + CppCall (FuncInternal (retypedObj, "get_length", "->"), []), + exprType ) + | TCppInterface _, _ | TCppDynamic, _ -> + ( retyper_ctx, + CppDynamicField (retypedObj, member.cf_name), + TCppVariant ) + | TCppObjC _, _ -> + ( retyper_ctx, + CppVar (VarInstance ( retypedObj, member, tcpp_to_string clazzType, "." )), exprType ) - else (CppDynamicField (retypedObj, member.cf_name), TCppVariant) - else if cpp_is_struct_access retypedObj.cpptype then - match retypedObj.cppexpr with - | CppThis ThisReal -> - (CppVar (VarThis (member, retypedObj.cpptype)), exprType) - | CppSuper this -> - ( CppFunction - ( FuncSuper (this, retypedObj.cpptype, member), - funcReturn ), - exprType ) | _ -> - if is_var_field member then - ( CppVar - (VarInstance - (retypedObj, member, tcpp_to_string clazzType, ".")), - exprType ) + let operator = + if cpp_is_struct_access retypedObj.cpptype || retypedObj.cpptype = TCppString then + "." else - ( CppFunction - ( FuncInstance (retypedObj, InstStruct, member), - funcReturn ), - exprType ) - else if is_var_field member then - let exprType = - match (retypedObj.cpptype, exprType) with + "->" + in + ( retyper_ctx, + CppVar (VarInstance ( retypedObj, member, tcpp_to_string clazzType, operator )), + exprType )) + else if has_class_flag clazz CInterface && not is_objc (* Use instance call for objc interfaces *) then + ( retyper_ctx, + CppFunction (FuncInterface (retypedObj, clazz, member), funcReturn), + exprType ) + else + let isArrayObj = + match retypedObj.cpptype with + | TCppDynamicArray | TCppObjectArray _ | TCppScalarArray _ -> + true + | _ -> + false + in + (* Special array return values *) + let funcReturn = + if isArrayObj then + match member.cf_name with + | "map" -> TCppDynamicArray + | "splice" | "slice" | "concat" | "copy" | "filter" -> + retypedObj.cpptype + | _ -> funcReturn + else + match (retypedObj.cpptype, funcReturn) with | TCppPointer (_, t), TCppDynamic | ( TCppRawPointer (_, t), - TCppDynamic - (* the 'type parameter' will show up as Dynamic *) ) -> - t - | _ -> exprType - in - - match retypedObj.cppexpr with - | CppThis ThisReal -> - (CppVar (VarThis (member, retypedObj.cpptype)), exprType) - | _ -> ( - match (retypedObj.cpptype, member.cf_name) with - (* Special variable remapping ... *) - | TCppDynamicArray, "length" when not forCppia -> - ( CppCall - (FuncInternal (retypedObj, "get_length", "->"), []), - exprType ) - | TCppInterface _, _ | TCppDynamic, _ -> - ( CppDynamicField (retypedObj, member.cf_name), - TCppVariant ) - | TCppObjC _, _ -> - ( CppVar - (VarInstance - ( retypedObj, - member, - tcpp_to_string clazzType, - "." )), - exprType ) - | _ -> - let operator = - if - cpp_is_struct_access retypedObj.cpptype - || retypedObj.cpptype = TCppString - then "." - else "->" - in - ( CppVar - (VarInstance - ( retypedObj, - member, - tcpp_to_string clazzType, - operator )), - exprType )) - else if - has_class_flag clazz CInterface - && not is_objc (* Use instance call for objc interfaces *) - then - ( CppFunction - (FuncInterface (retypedObj, clazz, member), funcReturn), + TCppDynamic + (* the 'type parameter' will show up as Dynamic *) ) -> + t + | _ -> funcReturn + in + match retypedObj.cppexpr with + | CppThis ThisReal -> + ( retyper_ctx, + CppFunction (FuncThis (member, retypedObj.cpptype), funcReturn), exprType ) - else - let isArrayObj = - match retypedObj.cpptype with - | TCppDynamicArray | TCppObjectArray _ | TCppScalarArray _ -> - true - | _ -> false - in - (* Special array return values *) - let funcReturn = - if isArrayObj then - match member.cf_name with - | "map" -> TCppDynamicArray - | "splice" | "slice" | "concat" | "copy" | "filter" -> - retypedObj.cpptype - | _ -> funcReturn - else - match (retypedObj.cpptype, funcReturn) with - | TCppPointer (_, t), TCppDynamic - | ( TCppRawPointer (_, t), - TCppDynamic - (* the 'type parameter' will show up as Dynamic *) ) -> - t - | _ -> funcReturn - in - match retypedObj.cppexpr with - | CppThis ThisReal -> - ( CppFunction - (FuncThis (member, retypedObj.cpptype), funcReturn), - exprType ) - | CppSuper this -> - ( CppFunction - ( FuncSuper (this, retypedObj.cpptype, member), - funcReturn ), - exprType ) - | _ -> - ( CppFunction - ( FuncInstance - ( retypedObj, - (if is_objc then InstObjC else InstPtr), - member ), - funcReturn ), - exprType )) + | CppSuper this -> + ( retyper_ctx, + CppFunction ( FuncSuper (this, retypedObj.cpptype, member), funcReturn ), + exprType ) + | _ -> + ( retyper_ctx, + CppFunction + ( FuncInstance + ( retypedObj, + (if is_objc then InstObjC else InstPtr), + member ), + funcReturn ), + exprType )) | FStatic (_, ({ cf_name = "nativeFromStaticFunction" } as member)) -> - let funcReturn = cpp_member_return_type member in - let exprType = cpp_type_of member.cf_type in - (CppFunction (FuncFromStaticFunction, funcReturn), exprType) + let funcReturn = cpp_member_return_type member in + let exprType = cpp_type_of member.cf_type in + (retyper_ctx, CppFunction (FuncFromStaticFunction, funcReturn), exprType) | FStatic (clazz, member) -> - let funcReturn = cpp_member_return_type member in - let exprType = cpp_type_of member.cf_type in - let objC = is_objc_class clazz in - if is_var_field member then - (CppVar (VarStatic (clazz, objC, member)), exprType) - else - ( CppFunction (FuncStatic (clazz, objC, member), funcReturn), - exprType ) + let funcReturn = cpp_member_return_type member in + let exprType = cpp_type_of member.cf_type in + let objC = is_objc_class clazz in + if is_var_field member then + (retyper_ctx, CppVar (VarStatic (clazz, objC, member)), exprType) + else + ( retyper_ctx, + CppFunction (FuncStatic (clazz, objC, member), funcReturn), + exprType ) | FClosure (None, field) | FAnon field -> - let obj = retype TCppDynamic obj in - let fieldName = field.cf_name in - if obj.cpptype = TCppGlobal then - (CppExtern (fieldName, true), cpp_type_of expr.etype) - else if obj.cpptype = TCppNull then (CppNullAccess, TCppDynamic) - else if is_internal_member fieldName then - let cppType = cpp_return_type expr.etype in - if obj.cpptype = TCppString then - ( CppFunction (FuncInternal (obj, fieldName, "."), cppType), - cppType ) - else - ( CppFunction (FuncInternal (obj, fieldName, "->"), cppType), - cppType ) - else (CppDynamicField (obj, field.cf_name), TCppVariant) + let retyper_ctx, obj = retype retyper_ctx TCppDynamic obj in + let fieldName = field.cf_name in + if obj.cpptype = TCppGlobal then + (retyper_ctx, CppExtern (fieldName, true), cpp_type_of expr.etype) + else if obj.cpptype = TCppNull then (retyper_ctx, CppNullAccess, TCppDynamic) + else if is_internal_member fieldName then + let cppType = cpp_return_type expr.etype in + if obj.cpptype = TCppString then + ( retyper_ctx, + CppFunction (FuncInternal (obj, fieldName, "."), cppType), + cppType ) + else + ( retyper_ctx, + CppFunction (FuncInternal (obj, fieldName, "->"), cppType), + cppType ) + else (retyper_ctx, CppDynamicField (obj, field.cf_name), TCppVariant) | FDynamic fieldName -> - let obj = retype TCppDynamic obj in - if obj.cpptype = TCppNull then (CppNullAccess, TCppDynamic) + let retyper_ctx, obj = retype retyper_ctx TCppDynamic obj in + if obj.cpptype = TCppNull then (retyper_ctx, CppNullAccess, TCppDynamic) else if fieldName = "cca" && obj.cpptype = TCppString then - ( CppFunction (FuncInternal (obj, "cca", "."), TCppScalar "int"), + ( retyper_ctx, + CppFunction (FuncInternal (obj, "cca", "."), TCppScalar "int"), TCppDynamic ) else if fieldName = "__s" && obj.cpptype = TCppString then - ( CppVar (VarInternal (obj, ".", "utf8_str()")), + ( retyper_ctx, + CppVar (VarInternal (obj, ".", "utf8_str()")), TCppRawPointer ("const ", TCppScalar "char") ) else if fieldName = "__Index" then - (CppEnumIndex obj, TCppScalar "int") + (retyper_ctx, CppEnumIndex obj, TCppScalar "int") else if is_internal_member fieldName || cpp_is_real_array obj then let cppType = cpp_return_type expr.etype in if obj.cpptype = TCppString then - ( CppFunction (FuncInternal (obj, fieldName, "."), cppType), + ( retyper_ctx, + CppFunction (FuncInternal (obj, fieldName, "."), cppType), cppType ) else - ( CppFunction (FuncInternal (obj, fieldName, "->"), cppType), + ( retyper_ctx, + CppFunction (FuncInternal (obj, fieldName, "->"), cppType), cppType ) else if obj.cpptype = TCppGlobal then - (CppExtern (fieldName, true), cpp_type_of expr.etype) + (retyper_ctx, CppExtern (fieldName, true), cpp_type_of expr.etype) else if obj.cpptype = TCppClass then match obj.cppexpr with | CppClassOf (path, _) -> - ( CppExtern - ( join_class_path_remap path "::" ^ "_obj::" ^ fieldName, - true ), - cpp_type_of expr.etype ) + ( retyper_ctx, + CppExtern ( join_class_path_remap path "::" ^ "_obj::" ^ fieldName, true ), + cpp_type_of expr.etype ) | _ -> - ( CppVar (VarInternal (obj, "->", fieldName)), - cpp_type_of expr.etype ) - else (CppDynamicField (obj, fieldName), TCppVariant) + ( retyper_ctx, + CppVar (VarInternal (obj, "->", fieldName)), + cpp_type_of expr.etype ) + else (retyper_ctx, CppDynamicField (obj, fieldName), TCppVariant) | FEnum (enum, enum_field) -> - (CppEnumField (enum, enum_field), TCppEnum enum)) + (retyper_ctx, CppEnumField (enum, enum_field), TCppEnum enum)) | TCall ({ eexpr = TIdent "__cpp__" }, arg_list) -> - let cppExpr = - match arg_list with - | [ { eexpr = TConst (TString code) } ] -> CppCode (code, []) - | { eexpr = TConst (TString code) } :: remaining -> - let retypedArgs = - List.map - (fun arg -> retype (TCppCode (cpp_type_of arg.etype)) arg) - remaining - in - CppCode (code, retypedArgs) - | _ -> abort "__cpp__'s first argument must be a string" expr.epos - in - (cppExpr, TCppCode (cpp_type_of expr.etype)) + let retyper_ctx, cppExpr = + match arg_list with + | [ { eexpr = TConst (TString code) } ] -> retyper_ctx, CppCode (code, []) + | { eexpr = TConst (TString code) } :: remaining -> + let folder (cur_ctx, args) arg = + let new_ctx, new_arg = retype cur_ctx (TCppCode (cpp_type_of arg.etype)) arg in + new_ctx, new_arg :: args + in + let retyper_ctx, retypedArgs = List.fold_left folder (retyper_ctx, []) remaining in + retyper_ctx, CppCode (code, List.rev retypedArgs) + | _ -> abort "__cpp__'s first argument must be a string" expr.epos + in + (retyper_ctx, cppExpr, TCppCode (cpp_type_of expr.etype)) | TCall (func, args) -> ( - let retypedFunc = retype TCppUnchanged func in + let retyper_ctx, retypedFunc = retype retyper_ctx TCppUnchanged func in match retypedFunc.cpptype with - | TCppNull -> (CppNullAccess, TCppDynamic) + | TCppNull -> (retyper_ctx, CppNullAccess, TCppDynamic) | TCppFunction (argTypes, retType, _) -> - let retypedArgs = retype_function_args args argTypes in - (CppCall (FuncExpression retypedFunc, retypedArgs), retType) + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args argTypes in + (retyper_ctx, CppCall (FuncExpression retypedFunc, retypedArgs), retType) | TCppObjCBlock (argTypes, retType) -> - let retypedArgs = retype_function_args args argTypes in - (CppCall (FuncExpression retypedFunc, retypedArgs), retType) + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args argTypes in + (retyper_ctx, CppCall (FuncExpression retypedFunc, retypedArgs), retType) | _ -> ( - let cppType = cpp_type_of expr.etype in - match retypedFunc.cppexpr with - | CppFunction (FuncFromStaticFunction, returnType) -> ( - let retypedArgs = List.map (retype TCppDynamic) args in - match retypedArgs with - | [ - { - cppexpr = - CppFunction - (FuncStatic (clazz, false, member), funcReturn); - }; - ] -> - (CppFunctionAddress (clazz, member), funcReturn) - | _ -> - abort - "cpp.Function.fromStaticFunction must be called on \ - static function" - expr.epos) - | CppEnumIndex _ -> - (* Not actually a TCall...*) - (retypedFunc.cppexpr, retypedFunc.cpptype) - | CppFunction (FuncInstance (obj, InstPtr, member), _) - when (not forCppia) && return_type = TCppVoid - && is_array_splice_call obj member -> - let retypedArgs = List.map (retype TCppDynamic) args in - ( CppCall - ( FuncInstance - (obj, InstPtr, { member with cf_name = "removeRange" }), - retypedArgs ), - TCppVoid ) - | CppFunction (FuncInstance (obj, InstPtr, member), _) - when is_array_concat_call obj member -> - let retypedArgs = List.map (retype obj.cpptype) args in - ( CppCall (FuncInstance (obj, InstPtr, member), retypedArgs), - return_type ) - | CppFunction (FuncStatic (obj, false, member), _) - when member.cf_name = "::hx::AddressOf" -> - let arg = retype TCppUnchanged (List.hd args) in - let rawType = - match arg.cpptype with TCppReference x -> x | x -> x - in - (CppAddressOf arg, TCppRawPointer ("", rawType)) - | CppFunction (FuncStatic (obj, false, member), _) - when member.cf_name = "::hx::StarOf" -> - let arg = retype TCppUnchanged (List.hd args) in - let rawType = - match arg.cpptype with TCppReference x -> x | x -> x - in - (CppAddressOf arg, TCppStar (rawType, false)) - | CppFunction (FuncStatic (obj, false, member), _) - when member.cf_name = "::hx::Dereference" -> - let arg = retype TCppUnchanged (List.hd args) in - let rawType = - match arg.cpptype with TCppStar (x, _) -> x | x -> x - in - (CppDereference arg, TCppReference rawType) - | CppFunction (FuncStatic (obj, false, member), _) - when member.cf_name = "_hx_create_array_length" -> ( - let retypedArgs = List.map (retype TCppDynamic) args in - (* gc_stack - not needed yet *) + let cppType = cpp_type_of expr.etype in + match retypedFunc.cppexpr with + | CppFunction (FuncFromStaticFunction, returnType) -> ( + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + match retypedArgs with + | [ + { + cppexpr = + CppFunction + (FuncStatic (clazz, false, member), funcReturn); + }; + ] -> + (retyper_ctx, CppFunctionAddress (clazz, member), funcReturn) + | _ -> + abort + "cpp.Function.fromStaticFunction must be called on \ + static function" + expr.epos) + | CppEnumIndex _ -> + (* Not actually a TCall...*) + (retyper_ctx, retypedFunc.cppexpr, retypedFunc.cpptype) + | CppFunction (FuncInstance (obj, InstPtr, member), _) + when (not forCppia) && return_type = TCppVoid && is_array_splice_call obj member -> + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + ( retyper_ctx, + CppCall ( FuncInstance (obj, InstPtr, { member with cf_name = "removeRange" }), retypedArgs ), + TCppVoid ) + | CppFunction (FuncInstance (obj, InstPtr, member), _) + when is_array_concat_call obj member -> + let arg_types = List.map (fun _ -> obj.cpptype) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + ( retyper_ctx, + CppCall (FuncInstance (obj, InstPtr, member), retypedArgs), + return_type ) + | CppFunction (FuncStatic (obj, false, member), _) + when member.cf_name = "::hx::AddressOf" -> + let retyper_ctx, arg = retype retyper_ctx TCppUnchanged (List.hd args) in + let rawType = match arg.cpptype with TCppReference x -> x | x -> x in + (retyper_ctx, CppAddressOf arg, TCppRawPointer ("", rawType)) + | CppFunction (FuncStatic (obj, false, member), _) + when member.cf_name = "::hx::StarOf" -> + let retyper_ctx, arg = retype retyper_ctx TCppUnchanged (List.hd args) in + let rawType = match arg.cpptype with TCppReference x -> x | x -> x in + (retyper_ctx, CppAddressOf arg, TCppStar (rawType, false)) + | CppFunction (FuncStatic (obj, false, member), _) + when member.cf_name = "::hx::Dereference" -> + let retyper_ctx, arg = retype retyper_ctx TCppUnchanged (List.hd args) in + let rawType = match arg.cpptype with TCppStar (x, _) -> x | x -> x in + (retyper_ctx, CppDereference arg, TCppReference rawType) + | CppFunction (FuncStatic (obj, false, member), _) + when member.cf_name = "_hx_create_array_length" -> ( + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + (* gc_stack - not needed yet *) + match return_type with + | TCppObjectArray _ | TCppScalarArray _ -> + (retyper_ctx, CppCall (FuncNew return_type, retypedArgs), return_type) + | _ -> + ( retyper_ctx, CppCall (FuncNew TCppDynamicArray, retypedArgs), return_type )) + | CppFunction (FuncStatic (obj, false, member), returnType) + when cpp_is_templated_call ctx member -> ( + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + match retypedArgs with + | { cppexpr = CppClassOf (path, native) } :: rest -> + ( retyper_ctx, CppCall (FuncTemplate (obj, member, path, native), rest), returnType ) + | _ -> + abort + "First parameter of template function must be a Class" + retypedFunc.cpppos) + | CppFunction (FuncInstance (obj, InstPtr, member), _) + when is_map_get_call obj member -> + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + let fname, cppType = match return_type with - | TCppObjectArray _ | TCppScalarArray _ -> - (CppCall (FuncNew return_type, retypedArgs), return_type) - | _ -> - ( CppCall (FuncNew TCppDynamicArray, retypedArgs), - return_type )) - | CppFunction (FuncStatic (obj, false, member), returnType) - when cpp_is_templated_call ctx member -> ( - let retypedArgs = List.map (retype TCppDynamic) args in + | TCppVoid | TCppScalar "bool" -> + ( (if forCppia then "getBool" else "get_bool"), + return_type ) + | TCppScalar "int" -> + ((if forCppia then "getInt" else "get_int"), return_type) + | TCppScalar "::cpp::Int64" -> + ( (if forCppia then "getInt64" else "get_int64"), + return_type ) + | TCppScalar "Float" -> + ( (if forCppia then "getFloat" else "get_float"), + return_type ) + | TCppString -> + ( (if forCppia then "getString" else "get_string"), + return_type ) + | _ -> ("get", TCppDynamic) + in + let func = + FuncInstance (obj, InstPtr, { member with cf_name = fname }) + in + (* + if cpp_can_static_cast cppType return_type then begin + let call = mk_cppexpr (CppCall(func,retypedArgs)) cppType in + CppCastStatic(call, cppType), cppType + end else + *) + (retyper_ctx, CppCall (func, retypedArgs), cppType) + | CppFunction (FuncInstance (obj, InstPtr, member), _) + when forCppia && is_map_set_call obj member -> + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + let fname = match retypedArgs with - | { cppexpr = CppClassOf (path, native) } :: rest -> - ( CppCall (FuncTemplate (obj, member, path, native), rest), - returnType ) - | _ -> - abort - "First parameter of template function must be a Class" - retypedFunc.cpppos) - | CppFunction (FuncInstance (obj, InstPtr, member), _) - when is_map_get_call obj member -> - let retypedArgs = List.map (retype TCppDynamic) args in - let fname, cppType = - match return_type with - | TCppVoid | TCppScalar "bool" -> - ( (if forCppia then "getBool" else "get_bool"), - return_type ) - | TCppScalar "int" -> - ((if forCppia then "getInt" else "get_int"), return_type) - | TCppScalar "::cpp::Int64" -> - ( (if forCppia then "getInt64" else "get_int64"), - return_type ) - | TCppScalar "Float" -> - ( (if forCppia then "getFloat" else "get_float"), - return_type ) - | TCppString -> - ( (if forCppia then "getString" else "get_string"), - return_type ) - | _ -> ("get", TCppDynamic) - in - let func = - FuncInstance (obj, InstPtr, { member with cf_name = fname }) - in - (* - if cpp_can_static_cast cppType return_type then begin - let call = mk_cppexpr (CppCall(func,retypedArgs)) cppType in - CppCastStatic(call, cppType), cppType - end else - *) - (CppCall (func, retypedArgs), cppType) - | CppFunction (FuncInstance (obj, InstPtr, member), _) - when forCppia && is_map_set_call obj member -> - let retypedArgs = List.map (retype TCppDynamic) args in - let fname = - match retypedArgs with - | [ _; { cpptype = TCppScalar "bool" } ] -> "setBool" - | [ _; { cpptype = TCppScalar "int" } ] -> "setInt" - | [ _; { cpptype = TCppScalar "::cpp::Int64" } ] -> - "setInt64" - | [ _; { cpptype = TCppScalar "Float" } ] -> "setFloat" - | [ _; { cpptype = TCppString } ] -> "setString" - | _ -> "set" - in - let func = - FuncInstance (obj, InstPtr, { member with cf_name = fname }) - in - (CppCall (func, retypedArgs), cppType) - | CppFunction - ((FuncInstance (obj, InstPtr, member) as func), returnType) - when cpp_can_static_cast returnType cppType -> - let retypedArgs = List.map (retype TCppDynamic) args in - let call = - mk_cppexpr (CppCall (func, retypedArgs)) returnType - in - (CppCastStatic (call, cppType), cppType) - (* - let error_printer file line = Printf.sprintf "%s:%d:" file line in - let epos = Lexer.get_error_pos error_printer expr.epos in - print_endline ( "fixed override " ^ member.cf_name ^ " @ " ^ epos ^ " " ^ (tcpp_to_string returnType) ^ "->" ^ (ctx_type_string ctx expr.etype) ); - CppCall(func,retypedArgs), returnType - *) - (* Other functions ... *) - | CppFunction - ( (FuncInstance - (_, InstStruct, { cf_type = TFun (arg_types, _) }) as - func), - return_type ) -> - (* For struct access classes use the types of the arguments instead of the function argument types *) - (* In the case of generic extern classes a TFun arg type could be `MyClass.T` instead of the real type *) - let map_args func_arg passed_arg = - let name, opt, _ = func_arg in - (name, opt, passed_arg.etype) - in - let real_types = List.map2 map_args arg_types args in - let arg_types = - List.map - (fun (_, opt, t) -> cpp_tfun_arg_type_of opt t) - real_types - in - let retypedArgs = retype_function_args args arg_types in - (CppCall (func, retypedArgs), return_type) - | CppFunction - ( (FuncInstance (_, _, { cf_type = TFun (arg_types, _) }) as - func), - returnType ) - | CppFunction - ( (FuncStatic (_, _, { cf_type = TFun (arg_types, _) }) as func), - returnType ) - | CppFunction - ( (FuncThis ({ cf_type = TFun (arg_types, _) }, _) as func), - returnType ) -> - let arg_types = - List.map - (fun (_, opt, t) -> cpp_tfun_arg_type_of opt t) - arg_types - in - (* retype args specifically (not just CppDynamic) *) - let retypedArgs = retype_function_args args arg_types in - (CppCall (func, retypedArgs), returnType) - | CppFunction (func, returnType) -> - let retypedArgs = List.map (retype TCppDynamic) args in - (CppCall (func, retypedArgs), returnType) - | CppEnumField (enum, field) -> - (* TODO - proper re-typing *) - let retypedArgs = List.map (retype TCppDynamic) args in - ( CppCall (FuncEnumConstruct (enum, field), retypedArgs), + | [ _; { cpptype = TCppScalar "bool" } ] -> "setBool" + | [ _; { cpptype = TCppScalar "int" } ] -> "setInt" + | [ _; { cpptype = TCppScalar "::cpp::Int64" } ] -> + "setInt64" + | [ _; { cpptype = TCppScalar "Float" } ] -> "setFloat" + | [ _; { cpptype = TCppString } ] -> "setString" + | _ -> "set" + in + let func = FuncInstance (obj, InstPtr, { member with cf_name = fname }) in + (retyper_ctx, CppCall (func, retypedArgs), cppType) + | CppFunction + ((FuncInstance (obj, InstPtr, member) as func), returnType) + when cpp_can_static_cast returnType cppType -> + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + let call = + mk_cppexpr (CppCall (func, retypedArgs)) returnType + in + (retyper_ctx, CppCastStatic (call, cppType), cppType) + (* + let error_printer file line = Printf.sprintf "%s:%d:" file line in + let epos = Lexer.get_error_pos error_printer expr.epos in + print_endline ( "fixed override " ^ member.cf_name ^ " @ " ^ epos ^ " " ^ (tcpp_to_string returnType) ^ "->" ^ (ctx_type_string ctx expr.etype) ); + CppCall(func,retypedArgs), returnType + *) + (* Other functions ... *) + | CppFunction ( (FuncInstance (_, InstStruct, { cf_type = TFun (arg_types, _) }) as func), return_type ) -> + (* For struct access classes use the types of the arguments instead of the function argument types *) + (* In the case of generic extern classes a TFun arg type could be `MyClass.T` instead of the real type *) + let map_args func_arg passed_arg = + let name, opt, _ = func_arg in + (name, opt, passed_arg.etype) + in + let real_types = List.map2 map_args arg_types args in + let arg_types = + List.map + (fun (_, opt, t) -> cpp_tfun_arg_type_of opt t) + real_types + in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + (retyper_ctx, CppCall (func, retypedArgs), return_type) + | CppFunction ( (FuncInstance (_, _, { cf_type = TFun (arg_types, _) }) as func), returnType ) + | CppFunction ( (FuncStatic (_, _, { cf_type = TFun (arg_types, _) }) as func), returnType ) + | CppFunction ( (FuncThis ({ cf_type = TFun (arg_types, _) }, _) as func), returnType ) -> + let arg_types = + List.map + (fun (_, opt, t) -> cpp_tfun_arg_type_of opt t) + arg_types + in + (* retype args specifically (not just CppDynamic) *) + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + (retyper_ctx, CppCall (func, retypedArgs), returnType) + | CppFunction (func, returnType) -> + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + (retyper_ctx, CppCall (func, retypedArgs), returnType) + | CppEnumField (enum, field) -> + (* TODO - proper re-typing *) + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + ( retyper_ctx, CppCall (FuncEnumConstruct (enum, field), retypedArgs), cppType ) + | CppSuper _ -> + (* TODO - proper re-typing *) + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + ( retyper_ctx, CppCall (FuncSuperConstruct retypedFunc.cpptype, retypedArgs), TCppVoid ) + | CppDynamicField (expr, name) -> ( + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + (* Special function calls *) + match (expr.cpptype, name) with + | TCppGlobal, _ -> + (retyper_ctx, CppCall (FuncExtern (name, true), retypedArgs), cppType) + | TCppString, _ -> + ( retyper_ctx, + CppCall (FuncInternal (expr, name, "."), retypedArgs), cppType ) - | CppSuper _ -> - (* TODO - proper re-typing *) - let retypedArgs = List.map (retype TCppDynamic) args in - ( CppCall (FuncSuperConstruct retypedFunc.cpptype, retypedArgs), - TCppVoid ) - | CppDynamicField (expr, name) -> ( - let retypedArgs = List.map (retype TCppDynamic) args in - (* Special function calls *) - match (expr.cpptype, name) with - | TCppGlobal, _ -> - let retypedArgs = List.map (retype TCppUnchanged) args in - (CppCall (FuncExtern (name, true), retypedArgs), cppType) - | TCppString, _ -> - ( CppCall (FuncInternal (expr, name, "."), retypedArgs), - cppType ) - | _, "__Tag" -> - ( CppCall - (FuncInternal (expr, "_hx_getTag", "->"), retypedArgs), - cppType ) - | _, name when is_internal_member name -> - ( CppCall (FuncInternal (expr, name, "->"), retypedArgs), - cppType ) - | _ -> - (* not special *) - ( CppCall (FuncExpression retypedFunc, retypedArgs), - TCppDynamic )) - | CppExtern (name, isGlobal) -> - let retypedArgs = List.map (retype TCppUnchanged) args in - (CppCall (FuncExtern (name, isGlobal), retypedArgs), cppType) - | _ -> - let retypedArgs = List.map (retype TCppDynamic) args in - ( CppCall (FuncExpression retypedFunc, retypedArgs), - TCppDynamic ))) + | _, "__Tag" -> + ( retyper_ctx, + CppCall (FuncInternal (expr, "_hx_getTag", "->"), retypedArgs), + cppType ) + | _, name when is_internal_member name -> + ( retyper_ctx, CppCall (FuncInternal (expr, name, "->"), retypedArgs), cppType ) + | _ -> + (* not special *) + ( retyper_ctx, CppCall (FuncExpression retypedFunc, retypedArgs), TCppDynamic )) + | CppExtern (name, isGlobal) -> + let arg_types = List.map (fun _ -> TCppUnchanged) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + (retyper_ctx, CppCall (FuncExtern (name, isGlobal), retypedArgs), cppType) + | _ -> + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + ( retyper_ctx, + CppCall (FuncExpression retypedFunc, retypedArgs), + TCppDynamic ))) | TNew (class_def, params, args) -> - let constructor_type = - match - OverloadResolution.maybe_resolve_constructor_overload class_def - params args - with - | None -> abort "Could not find overload" expr.epos - | Some (_, constructor, _) -> constructor.cf_type - in - let arg_types, _ = cpp_function_type_of_args_ret constructor_type in - let retypedArgs = retype_function_args args arg_types in - let created_type = cpp_type_of expr.etype in - (gc_stack := - !gc_stack - || - match created_type with - | TCppInst (t, _) -> not (is_native_class t) - | _ -> false); - (CppCall (FuncNew created_type, retypedArgs), created_type) + let constructor_type = + match + OverloadResolution.maybe_resolve_constructor_overload class_def + params args + with + | None -> abort "Could not find overload" expr.epos + | Some (_, constructor, _) -> constructor.cf_type + in + let arg_types, _ = cpp_function_type_of_args_ret constructor_type in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in + let created_type = cpp_type_of expr.etype in + let gc_stack = + retyper_ctx.gc_stack || match created_type with + | TCppInst (t, _) -> not (is_native_class t) + | _ -> false in + ({ retyper_ctx with gc_stack = gc_stack }, CppCall (FuncNew created_type, retypedArgs), created_type) | TFunction func -> - let old_this_real = !this_real in - this_real := ThisFake; - (* TODO - this_dynamic ? *) - let old_undeclared = Hashtbl.copy !undeclared in - let old_declarations = Hashtbl.copy !declarations in - let old_uses_this = !uses_this in - let old_gc_stack = !gc_stack in - let old_return_type = !function_return_type in - let ret = cpp_type_of func.tf_type in - function_return_type := ret; - uses_this := None; - undeclared := Hashtbl.create 0; - declarations := Hashtbl.create 0; - List.iter - (fun (tvar, _) -> Hashtbl.add !declarations tvar.v_name ()) - func.tf_args; - let cppExpr = retype TCppVoid (mk_block func.tf_expr) in - let result = - { - close_expr = cppExpr; - close_id = !closureId; - close_undeclared = !undeclared; - close_type = ret; - close_args = func.tf_args; - close_this = !uses_this; - } + (* TODO - this_dynamic ? *) + + let new_ctx = { + retyper_ctx with + declarations = func.tf_args |> List.map (fun (a, _) -> a.v_name, ()) |> string_map_of_list; + undeclared = StringMap.empty; + this_real = ThisFake; + uses_this = None; + function_return_type = cpp_type_of func.tf_type; + } in + let new_ctx, cppExpr = retype new_ctx TCppVoid (mk_block func.tf_expr) in + + let result = + { + close_expr = cppExpr; + close_id = retyper_ctx.closure_id; + close_undeclared = new_ctx.undeclared; + close_type = new_ctx.function_return_type; + close_args = func.tf_args; + close_this = new_ctx.uses_this; + } + in + let folder acc (name, tvar) = + if not (StringMap.mem name retyper_ctx.declarations) then + StringMap.add name tvar acc + else + acc + in + let new_undeclared = + List.fold_left + folder + retyper_ctx.undeclared + (StringMap.bindings new_ctx.undeclared) in - incr closureId; - declarations := old_declarations; - undeclared := old_undeclared; - Hashtbl.iter - (fun name tvar -> - if not (Hashtbl.mem !declarations name) then - Hashtbl.replace !undeclared name tvar) - result.close_undeclared; - function_return_type := old_return_type; - this_real := old_this_real; - uses_this := - if !uses_this != None then Some old_this_real else old_uses_this; - gc_stack := old_gc_stack; - rev_closures := result :: !rev_closures; - (CppClosure result, TCppDynamic) + + let retyper_ctx = { + retyper_ctx with + closure_id = retyper_ctx.closure_id + 1; + closures = result :: retyper_ctx.closures; + undeclared = new_undeclared; + uses_this = if new_ctx.uses_this != None then Some retyper_ctx.this_real else retyper_ctx.uses_this; + } in + + (retyper_ctx, CppClosure result, TCppDynamic) | TArray (e1, e2) -> - let arrayExpr, elemType = + let retyper_ctx, arrayExpr, elemType = match cpp_is_native_array_access (cpp_type_of e1.etype) with | true -> - let retypedObj = retype TCppUnchanged e1 in - let retypedIdx = retype (TCppScalar "int") e2 in - ( CppArray (ArrayRawPointer (retypedObj, retypedIdx)), + let retyper_ctx, retypedObj = retype retyper_ctx TCppUnchanged e1 in + let retyper_ctx, retypedIdx = retype retyper_ctx (TCppScalar "int") e2 in + ( retyper_ctx, + CppArray (ArrayRawPointer (retypedObj, retypedIdx)), cpp_type_of expr.etype ) | false -> ( - let retypedObj = retype TCppDynamic e1 in - let retypedIdx = retype (TCppScalar "int") e2 in + let retyper_ctx, retypedObj = retype retyper_ctx TCppDynamic e1 in + let retyper_ctx, retypedIdx = retype retyper_ctx (TCppScalar "int") e2 in match retypedObj.cpptype with | TCppScalarArray scalar -> - ( CppArray (ArrayTyped (retypedObj, retypedIdx, scalar)), + ( retyper_ctx, + CppArray (ArrayTyped (retypedObj, retypedIdx, scalar)), scalar ) | TCppPointer (_, elem) -> - (CppArray (ArrayPointer (retypedObj, retypedIdx)), elem) + (retyper_ctx, CppArray (ArrayPointer (retypedObj, retypedIdx)), elem) | TCppRawPointer (_, elem) -> - (CppArray (ArrayRawPointer (retypedObj, retypedIdx)), elem) + (retyper_ctx, CppArray (ArrayRawPointer (retypedObj, retypedIdx)), elem) | TCppObjectArray TCppDynamic -> - ( CppArray - (ArrayObject (retypedObj, retypedIdx, TCppDynamic)), + ( retyper_ctx, + CppArray (ArrayObject (retypedObj, retypedIdx, TCppDynamic)), TCppDynamic ) | TCppObjectArray elem -> - (CppArray (ArrayObject (retypedObj, retypedIdx, elem)), elem) + (retyper_ctx, CppArray (ArrayObject (retypedObj, retypedIdx, elem)), elem) | TCppInst (({ cl_array_access = Some _ } as klass), _) -> - ( CppArray (ArrayImplements (klass, retypedObj, retypedIdx)), + ( retyper_ctx, CppArray (ArrayImplements (klass, retypedObj, retypedIdx)), cpp_type_of expr.etype ) | TCppDynamicArray -> - ( CppArray (ArrayVirtual (retypedObj, retypedIdx)), + ( retyper_ctx, + CppArray (ArrayVirtual (retypedObj, retypedIdx)), TCppDynamic ) | _ -> - ( CppArray (ArrayDynamic (retypedObj, retypedIdx)), + ( retyper_ctx, + CppArray (ArrayDynamic (retypedObj, retypedIdx)), TCppDynamic )) in let returnType = cpp_type_of expr.etype in if cpp_can_static_cast elemType returnType then - ( CppCastStatic (mk_cppexpr arrayExpr returnType, returnType), + ( retyper_ctx, + CppCastStatic (mk_cppexpr arrayExpr returnType, returnType), returnType ) - else (arrayExpr, elemType) + else + (retyper_ctx, arrayExpr, elemType) | TTypeExpr module_type -> (* If we try and use the coreType / runtimeValue cpp.Int64 abstract with Class then we get a class decl of the abstract *) (* as that abstract has functions in its declaration *) @@ -991,19 +1003,22 @@ let expression ctx request_type function_args function_type expression_tree forI ([ "cpp" ], "Int64") | _ -> t_path module_type in - (CppClassOf (path, is_native_gen_module module_type), TCppClass) + (retyper_ctx, CppClassOf (path, is_native_gen_module module_type), TCppClass) | TBinop (op, left, right) -> ( - let binOpType = + let retyper_ctx, binOpType = match op with - | OpDiv -> TCppScalar "Float" - | OpBoolAnd | OpBoolOr -> TCppScalar "bool" - | OpAnd | OpOr | OpXor | OpShl | OpShr | OpUShr -> TCppScalar "int" - | OpAssign -> (retype TCppUnchanged left).cpptype - | OpMult | OpSub -> cpp_type_of expr.etype - | _ -> TCppUnchanged + | OpDiv -> retyper_ctx, TCppScalar "Float" + | OpBoolAnd | OpBoolOr -> retyper_ctx, TCppScalar "bool" + | OpAnd | OpOr | OpXor | OpShl | OpShr | OpUShr -> retyper_ctx, TCppScalar "int" + | OpAssign -> + let retyper_ctx, retyped_expr = (retype retyper_ctx TCppUnchanged left) in + (retyper_ctx, retyped_expr.cpptype) + | OpMult | OpSub -> + retyper_ctx, cpp_type_of expr.etype + | _ -> retyper_ctx, TCppUnchanged in - let e1 = retype binOpType left in - let e2 = retype binOpType right in + let retyper_ctx, e1 = retype retyper_ctx binOpType left in + let retyper_ctx, e2 = retype retyper_ctx binOpType right in let complex = is_complex_compare e1.cpptype || is_complex_compare e2.cpptype @@ -1016,46 +1031,47 @@ let expression ctx request_type function_args function_type expression_tree forI in let e1_null = e1.cpptype = TCppNull in let e2_null = e2.cpptype = TCppNull in - let reference = + let retyper_ctx, reference = match op with | OpAssign -> let lvalue, gc = to_lvalue e1 in - if gc then gc_stack := true; - CppSet (lvalue, e2) + let new_ctx = if gc then { retyper_ctx with gc_stack = true } else retyper_ctx in + new_ctx, CppSet (lvalue, e2) | OpAssignOp op -> let lvalue, gc = to_lvalue e1 in - if gc then gc_stack := true; - CppModify (op, lvalue, e2) - | OpEq when e1_null && e2_null -> CppBool true - | OpGte when e1_null && e2_null -> CppBool true - | OpLte when e1_null && e2_null -> CppBool true - | OpNotEq when e1_null && e2_null -> CppBool false - | _ when e1_null && e2_null -> CppBool false - | OpEq when e1_null -> CppNullCompare ("IsNull", e2) - | OpGte when e1_null -> CppNullCompare ("IsNull", e2) - | OpLte when e1_null -> CppNullCompare ("IsNull", e2) - | OpNotEq when e1_null -> CppNullCompare ("IsNotNull", e2) - | OpEq when e2_null -> CppNullCompare ("IsNull", e1) - | OpGte when e2_null -> CppNullCompare ("IsNull", e1) - | OpLte when e2_null -> CppNullCompare ("IsNull", e1) - | OpNotEq when e2_null -> CppNullCompare ("IsNotNull", e1) - | OpEq when instance -> CppCompare ("IsInstanceEq", e1, e2, op) - | OpNotEq when instance -> CppCompare ("IsInstanceNotEq", e1, e2, op) - | OpEq when pointer -> CppCompare ("IsPointerEq", e1, e2, op) - | OpNotEq when pointer -> CppCompare ("IsPointerNotEq", e1, e2, op) - | OpEq when complex -> CppCompare ("IsEq", e1, e2, op) - | OpNotEq when complex -> CppCompare ("IsNotEq", e1, e2, op) - | OpGte when complex -> CppCompare ("IsGreaterEq", e1, e2, op) - | OpLte when complex -> CppCompare ("IsLessEq", e1, e2, op) - | OpGt when complex -> CppCompare ("IsGreater", e1, e2, op) - | OpLt when complex -> CppCompare ("IsLess", e1, e2, op) - | _ -> CppBinop (op, e1, e2) + let new_ctx = if gc then { retyper_ctx with gc_stack = true } else retyper_ctx in + new_ctx, CppModify (op, lvalue, e2) + | OpEq when e1_null && e2_null -> retyper_ctx, CppBool true + | OpGte when e1_null && e2_null -> retyper_ctx, CppBool true + | OpLte when e1_null && e2_null -> retyper_ctx, CppBool true + | OpNotEq when e1_null && e2_null -> retyper_ctx, CppBool false + | _ when e1_null && e2_null -> retyper_ctx, CppBool false + | OpEq when e1_null -> retyper_ctx, CppNullCompare ("IsNull", e2) + | OpGte when e1_null -> retyper_ctx, CppNullCompare ("IsNull", e2) + | OpLte when e1_null -> retyper_ctx, CppNullCompare ("IsNull", e2) + | OpNotEq when e1_null -> retyper_ctx, CppNullCompare ("IsNotNull", e2) + | OpEq when e2_null -> retyper_ctx, CppNullCompare ("IsNull", e1) + | OpGte when e2_null -> retyper_ctx, CppNullCompare ("IsNull", e1) + | OpLte when e2_null -> retyper_ctx, CppNullCompare ("IsNull", e1) + | OpNotEq when e2_null -> retyper_ctx, CppNullCompare ("IsNotNull", e1) + | OpEq when instance -> retyper_ctx, CppCompare ("IsInstanceEq", e1, e2, op) + | OpNotEq when instance -> retyper_ctx, CppCompare ("IsInstanceNotEq", e1, e2, op) + | OpEq when pointer -> retyper_ctx, CppCompare ("IsPointerEq", e1, e2, op) + | OpNotEq when pointer -> retyper_ctx, CppCompare ("IsPointerNotEq", e1, e2, op) + | OpEq when complex -> retyper_ctx, CppCompare ("IsEq", e1, e2, op) + | OpNotEq when complex -> retyper_ctx, CppCompare ("IsNotEq", e1, e2, op) + | OpGte when complex -> retyper_ctx, CppCompare ("IsGreaterEq", e1, e2, op) + | OpLte when complex -> retyper_ctx, CppCompare ("IsLessEq", e1, e2, op) + | OpGt when complex -> retyper_ctx, CppCompare ("IsGreater", e1, e2, op) + | OpLt when complex -> retyper_ctx, CppCompare ("IsLess", e1, e2, op) + | _ -> retyper_ctx, CppBinop (op, e1, e2) in match (op, e1.cpptype, e2.cpptype) with (* Variant + Variant = Variant *) | OpAdd, _, TCppVariant | OpAdd, TCppVariant, _ -> - (reference, TCppVariant) - | _, _, _ -> (reference, cpp_type_of expr.etype)) + (retyper_ctx, reference, TCppVariant) + | _, _, _ -> + (retyper_ctx, reference, cpp_type_of expr.etype)) | TUnop (op, pre, e1) -> let targetType = match op with @@ -1064,69 +1080,83 @@ let expression ctx request_type function_args function_type expression_tree forI | _ -> cpp_type_of e1.etype in - let e1 = retype targetType e1 in - let reference = + let retyper_ctx, e1 = retype retyper_ctx targetType e1 in + let retyper_ctx, reference = match op with | Increment -> let lvalue, gc = to_lvalue e1 in - if gc then gc_stack := true; - CppCrement (CppIncrement, pre, lvalue) + let new_ctx = if gc then { retyper_ctx with gc_stack = true } else retyper_ctx in + new_ctx, CppCrement (CppIncrement, pre, lvalue) | Decrement -> let lvalue, gc = to_lvalue e1 in - if gc then gc_stack := true; - CppCrement (CppDecrement, pre, lvalue) - | Neg -> CppUnop (CppNeg, e1) - | Not -> CppUnop (CppNot, e1) - | NegBits -> CppUnop (CppNegBits, e1) + let new_ctx = if gc then { retyper_ctx with gc_stack = true } else retyper_ctx in + new_ctx, CppCrement (CppDecrement, pre, lvalue) + | Neg -> retyper_ctx, CppUnop (CppNeg, e1) + | Not -> retyper_ctx, CppUnop (CppNot, e1) + | NegBits -> retyper_ctx, CppUnop (CppNegBits, e1) | Spread -> die ~p:expr.epos "Unexpected spread operator" __LOC__ in - (reference, cpp_type_of expr.etype) + (retyper_ctx, reference, cpp_type_of expr.etype) | TFor (v, init, block) -> - let old_declarations = Hashtbl.copy !declarations in - Hashtbl.add !declarations v.v_name (); - let init = retype (cpp_type_of v.v_type) init in - let block = retype TCppVoid (mk_block block) in - declarations := old_declarations; - (CppFor (v, init, block), TCppVoid) + let retyper_ctx = { retyper_ctx with declarations = StringMap.add v.v_name () retyper_ctx.declarations } in + let retyper_ctx, init = retype retyper_ctx (cpp_type_of v.v_type) init in + let retyper_ctx, block = retype retyper_ctx TCppVoid (mk_block block) in + let retyper_ctx = { retyper_ctx with declarations = StringMap.remove v.v_name retyper_ctx.declarations } in + (retyper_ctx, CppFor (v, init, block), TCppVoid) | TWhile (e1, e2, flag) -> - let condition = retype (TCppScalar "bool") e1 in - let close = begin_loop () in - let block = retype TCppVoid (mk_block e2) in - (CppWhile (condition, block, flag, close ()), TCppVoid) + let retyper_ctx, condition = retype retyper_ctx (TCppScalar "bool") e1 in + let retyper_ctx, close = begin_loop retyper_ctx in + let retyper_ctx, block = retype retyper_ctx TCppVoid (mk_block e2) in + let retyper_ctx, id = close retyper_ctx in + (retyper_ctx, CppWhile (condition, block, flag, id), TCppVoid) | TArrayDecl el -> - let retypedEls = List.map (retype TCppDynamic) el in - (CppArrayDecl retypedEls, cpp_type_of expr.etype) + let el_types = List.map (fun _ -> TCppDynamic) el in + let retyper_ctx, retypedEls = retype_function_args retyper_ctx el el_types in + (retyper_ctx, CppArrayDecl retypedEls, cpp_type_of expr.etype) | TBlock expr_list -> - let inject = !injection in - injection := false; if return_type <> TCppVoid && not forCppia then print_endline ("Value from a block not handled " ^ expr.epos.pfile ^ " " ^ string_of_int (Lexer.get_error_line expr.epos)); - let old_declarations = Hashtbl.copy !declarations in - let old_closures = !rev_closures in - rev_closures := []; - let local_closures = ref [] in - let remaining = ref (List.length expr_list) in - let cppExprs = - List.map - (fun expr -> + let new_ctx = { retyper_ctx with closures = []; injection = false } in + let new_ctx, cppExprs, _ = + List.fold_left + (fun (cur_ctx, exprs, remaining) expr -> let targetType = - if inject && !remaining = 1 then cpp_type_of expr.etype - else TCppVoid - in - decr remaining; - let result = retype targetType expr in - local_closures := !rev_closures @ !local_closures; - rev_closures := []; - result) + if retyper_ctx.injection && remaining = 1 then + cpp_type_of expr.etype + else + TCppVoid in + let new_ctx, result = retype cur_ctx targetType expr in + new_ctx, result :: exprs, remaining - 1) + (new_ctx, [], List.length expr_list) expr_list in - declarations := old_declarations; - rev_closures := old_closures; - (CppBlock (cppExprs, List.rev !local_closures, !gc_stack), TCppVoid) + (* Add back any undeclared variables *) + (* Needed for tracking variables captured by variables *) + let folder acc (name, tvar) = + if not (StringMap.mem name retyper_ctx.declarations) then + StringMap.add name tvar acc + else + acc + in + let new_undeclared = + List.fold_left + folder + retyper_ctx.undeclared + (StringMap.bindings new_ctx.undeclared) + in + + ( + { new_ctx with + declarations = retyper_ctx.declarations; + undeclared = new_undeclared; + closures = retyper_ctx.closures }, + CppBlock (List.rev cppExprs, List.rev new_ctx.closures, new_ctx.gc_stack), + TCppVoid + ) | TObjectDecl [ (("fileName", _, _), { eexpr = TConst (TString file) }); @@ -1134,33 +1164,41 @@ let expression ctx request_type function_args function_type expression_tree forI (("className", _, _), { eexpr = TConst (TString class_name) }); (("methodName", _, _), { eexpr = TConst (TString meth) }); ] -> - (CppPosition (file, line, class_name, meth), TCppDynamic) + (retyper_ctx, CppPosition (file, line, class_name, meth), TCppDynamic) | TObjectDecl el -> ( - let retypedEls = - List.map (fun ((v, _, _), e) -> (v, retype TCppDynamic e)) el + let el_exprs = List.map (fun ((_, _, _), e) -> e) el in + let el_names = List.map (fun ((v, _, _), _) -> v) el in + + let retyper_ctx, retyped_els = + List.map (fun _ -> TCppDynamic) el |> retype_function_args retyper_ctx el_exprs in + let joined = List.combine el_names retyped_els in + match return_type with - | TCppVoid -> (CppObjectDecl (retypedEls, false), TCppVoid) - | _ -> (CppObjectDecl (retypedEls, false), TCppDynamic)) + | TCppVoid -> (retyper_ctx, CppObjectDecl (joined, false), TCppVoid) + | _ -> (retyper_ctx, CppObjectDecl (joined, false), TCppDynamic)) | TVar (v, eo) -> let varType = cpp_type_of v.v_type in - let init = - match eo with None -> None | Some e -> Some (retype varType e) + let retyper_ctx, init = + match eo with + | None -> retyper_ctx, None + | Some e -> retype retyper_ctx varType e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in - Hashtbl.add !declarations v.v_name (); - (CppVarDecl (v, init), varType) + let retyper_ctx = { retyper_ctx with declarations = StringMap.add v.v_name () retyper_ctx.declarations } in + (retyper_ctx, CppVarDecl (v, init), varType) | TIf (ec, e1, e2) -> - let ec = retype (TCppScalar "bool") ec in + let retyper_ctx, ec = retype retyper_ctx (TCppScalar "bool") ec in let blockify = if return_type != TCppVoid then fun e -> e else mk_block in - let e1 = retype return_type (blockify e1) in - let e2 = + let retyper_ctx, e1 = retype retyper_ctx return_type (blockify e1) in + let retyper_ctx, e2 = match e2 with - | None -> None - | Some e -> Some (retype return_type (blockify e)) + | None -> retyper_ctx, None + | Some e -> retype retyper_ctx return_type (blockify e) |> (fun (new_ctx, expr) -> new_ctx, Some expr) in - ( CppIf (ec, e1, e2), + ( retyper_ctx, + CppIf (ec, e1, e2), if return_type = TCppVoid then TCppVoid else cpp_type_of expr.etype ) (* Switch internal return - wrap whole thing in block *) @@ -1174,40 +1212,49 @@ let expression ctx request_type function_args function_type expression_tree forI abort "Value from a switch not handled" expr.epos; let conditionType = cpp_type_of condition.etype in - let condition = retype conditionType condition in - let cppDef = + let retyper_ctx, condition = retype retyper_ctx conditionType condition in + let retyper_ctx, cppDef = match def with - | None -> None - | Some e -> Some (retype TCppVoid (mk_block e)) + | None -> retyper_ctx, None + | Some e -> retype retyper_ctx TCppVoid (mk_block e) |> (fun (new_ctx, expr) -> new_ctx, Some expr) in if forCppia then - let cases = - List.map - (fun { case_patterns = el; case_expr = e2 } -> - let cppBlock = retype TCppVoid (mk_block e2) in - (List.map (retype conditionType) el, cppBlock)) + let retyper_ctx, cases = + List.fold_left + (fun (cur_ctx, acc) { case_patterns = el; case_expr = e2 } -> + let new_ctx, cppBlock = retype cur_ctx TCppVoid (mk_block e2) in + let new_ctx, blocks = + List.fold_left + (fun (cur_ctx, acc) t -> retype cur_ctx conditionType t |> (fun (new_ctx, expr) -> new_ctx, expr :: acc)) + (new_ctx, []) + el + in + new_ctx, (List.rev blocks, cppBlock) :: acc) + (retyper_ctx, []) cases in - (CppSwitch (condition, conditionType, cases, cppDef, -1), TCppVoid) + (retyper_ctx, CppSwitch (condition, conditionType, List.rev cases, cppDef, -1), TCppVoid) else try (match conditionType with | TCppScalar "int" | TCppScalar "bool" -> () | _ -> raise Not_found); - let cases = - List.map - (fun { case_patterns = el; case_expr = e2 } -> - (List.map const_int_of el, retype TCppVoid (mk_block e2))) + let retyper_ctx, cases = + List.fold_left + (fun (cur_ctx, acc) { case_patterns = el; case_expr = e2 } -> + let new_ctx, expr = retype cur_ctx TCppVoid (mk_block e2) in + new_ctx, (List.map const_int_of el, expr) :: acc) + (retyper_ctx, []) cases in - (CppIntSwitch (condition, cases, cppDef), TCppVoid) + (retyper_ctx, CppIntSwitch (condition, List.rev cases, cppDef), TCppVoid) with Not_found -> - let label = alloc_file_id () in + let retyper_ctx, label = alloc_file_id retyper_ctx in (* do something better maybe ... *) - let cases = - List.map - (fun { case_patterns = el; case_expr = e2 } -> - let cppBlock = retype TCppVoid (mk_block e2) in + let retyper_ctx, cases = + List.fold_left + (fun (cur_ctx, acc) { case_patterns = el; case_expr = e2 } -> + let new_ctx, cppBlock = retype cur_ctx TCppVoid (mk_block e2) in let gotoExpr = { cppexpr = CppGoto label; @@ -1216,61 +1263,69 @@ let expression ctx request_type function_args function_type expression_tree forI } in let cppBlock = cpp_append_block cppBlock gotoExpr in - (List.map (retype conditionType) el, cppBlock)) + let new_ctx, blocks = + List.fold_left + (fun (cur_ctx, acc) t -> retype cur_ctx conditionType t |> (fun (new_ctx, expr) -> new_ctx, expr :: acc)) + (new_ctx, []) + el in + new_ctx, (List.rev blocks, cppBlock) :: acc) + (retyper_ctx, []) cases in - ( CppSwitch (condition, conditionType, cases, cppDef, label), + ( retyper_ctx, + CppSwitch (condition, conditionType, List.rev cases, cppDef, label), TCppVoid )) | TTry (try_block, catches) -> (* TTry internal return - wrap whole thing in block ? *) if return_type <> TCppVoid then abort "Value from a try-block not handled" expr.epos; - let cppBlock = retype TCppVoid try_block in - let cppCatches = - List.map - (fun (tvar, catch_block) -> - let old_declarations = Hashtbl.copy !declarations in - Hashtbl.add !declarations tvar.v_name (); - let cppCatchBlock = retype TCppVoid catch_block in - declarations := old_declarations; - (tvar, cppCatchBlock)) + let retyper_ctx, cppBlock = retype retyper_ctx TCppVoid try_block in + let retyper_ctx, cppCatches = + List.fold_left + (fun (retyper_ctx, acc) (tvar, catch_block) -> + let retyper_ctx = { retyper_ctx with declarations = StringMap.add tvar.v_name () retyper_ctx.declarations } in + let retyper_ctx, cppCatchBlock = retype retyper_ctx TCppVoid catch_block in + let retyper_ctx = { retyper_ctx with declarations = StringMap.remove tvar.v_name retyper_ctx.declarations } in + retyper_ctx, (tvar, cppCatchBlock) :: acc) + (retyper_ctx, []) catches in - (CppTry (cppBlock, cppCatches), TCppVoid) + (retyper_ctx, CppTry (cppBlock, List.rev cppCatches), TCppVoid) | TReturn eo -> - ( CppReturn - (match eo with - | None -> None - | Some e -> Some (retype !function_return_type e)), + let retyper_ctx, expr = match eo with + | None -> retyper_ctx, None + | Some e -> retype retyper_ctx retyper_ctx.function_return_type e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in + ( retyper_ctx, + CppReturn expr, TCppVoid ) | TCast (base, None) -> ( (* Use auto-cast rules *) let return_type = cpp_type_of expr.etype in - let baseCpp = retype return_type base in + let retyper_ctx, baseCpp = retype retyper_ctx return_type base in let baseStr = tcpp_to_string baseCpp.cpptype in let returnStr = tcpp_to_string return_type in if baseStr = returnStr then - (baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) + (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) else match return_type with - | TCppObjC k -> (CppCastObjC (baseCpp, k), return_type) + | TCppObjC k -> (retyper_ctx, CppCastObjC (baseCpp, k), return_type) | TCppPointer (_, _) | TCppRawPointer (_, _) | TCppStar _ | TCppInst _ -> - (CppCast (baseCpp, return_type), return_type) - | TCppString -> (CppCastScalar (baseCpp, "::String"), return_type) + (retyper_ctx, CppCast (baseCpp, return_type), return_type) + | TCppString -> (retyper_ctx, CppCastScalar (baseCpp, "::String"), return_type) | TCppCode t when baseStr <> tcpp_to_string t -> - (CppCast (baseCpp, t), t) - | TCppNativePointer klass -> (CppCastNative baseCpp, return_type) + (retyper_ctx, CppCast (baseCpp, t), t) + | TCppNativePointer klass -> (retyper_ctx, CppCastNative baseCpp, return_type) | TCppObjCBlock (args, ret) -> - (CppCastObjCBlock (baseCpp, args, ret), return_type) - | TCppProtocol p -> (CppCastProtocol (baseCpp, p), return_type) + (retyper_ctx, CppCastObjCBlock (baseCpp, args, ret), return_type) + | TCppProtocol p -> (retyper_ctx, CppCastProtocol (baseCpp, p), return_type) | TCppDynamic when baseCpp.cpptype = TCppClass -> - (CppCast (baseCpp, TCppDynamic), TCppDynamic) - | _ -> (baseCpp.cppexpr, baseCpp.cpptype (* use autocasting rules *)) + (retyper_ctx, CppCast (baseCpp, TCppDynamic), TCppDynamic) + | _ -> (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype (* use autocasting rules *)) ) | TCast (base, Some t) -> ( - let baseCpp = retype (cpp_type_of base.etype) base in + let retyper_ctx, baseCpp = retype retyper_ctx (cpp_type_of base.etype) base in let baseStr = tcpp_to_string baseCpp.cpptype in let default_return_type = if return_type = TCppUnchanged then cpp_type_of expr.etype @@ -1282,71 +1337,75 @@ let expression ctx request_type function_args function_type expression_tree forI let returnStr = tcpp_to_string return_type in if baseStr = returnStr then - (baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) + (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) else match return_type with - | TCppNativePointer klass -> (CppCastNative baseCpp, return_type) + | TCppNativePointer klass -> + ( retyper_ctx, CppCastNative baseCpp, return_type) | TCppVoid -> - (CppTCast (baseCpp, cpp_type_of expr.etype), return_type) - | TCppDynamic -> (baseCpp.cppexpr, baseCpp.cpptype) - | _ -> (CppTCast (baseCpp, return_type), return_type)) + (retyper_ctx, CppTCast (baseCpp, cpp_type_of expr.etype), return_type) + | TCppDynamic -> + (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype) + | _ -> + (retyper_ctx, CppTCast (baseCpp, return_type), return_type)) in let cppExpr = mk_cppexpr retypedExpr retypedType in (* Autocast rules... *) - if return_type = TCppVoid then mk_cppexpr retypedExpr TCppVoid + if return_type = TCppVoid then + retyper_ctx, mk_cppexpr retypedExpr TCppVoid else if return_type = TCppVarArg then match cpp_variant_type_of cppExpr.cpptype with - | TCppVoidStar | TCppScalar _ -> cppExpr + | TCppVoidStar | TCppScalar _ -> retyper_ctx, cppExpr | TCppString -> - mk_cppexpr + retyper_ctx, mk_cppexpr (CppVar (VarInternal (cppExpr, ".", "raw_ptr()"))) (TCppPointer ("ConstPointer", TCppScalar "char")) - | TCppDynamic -> mk_cppexpr (CppCastNative cppExpr) TCppVoidStar + | TCppDynamic -> retyper_ctx, mk_cppexpr (CppCastNative cppExpr) TCppVoidStar | _ -> let toDynamic = mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic in - mk_cppexpr (CppCastNative toDynamic) TCppVoidStar + retyper_ctx, mk_cppexpr (CppCastNative toDynamic) TCppVoidStar else if cppExpr.cpptype = TCppVariant || cppExpr.cpptype = TCppDynamic || cppExpr.cpptype == TCppObject then match return_type with - | TCppUnchanged -> cppExpr + | TCppUnchanged -> retyper_ctx, cppExpr | TCppInst (t, _) when Meta.has Meta.StructAccess t.cl_meta -> let structType = TCppStruct (TCppInst (t, [])) in let structCast = mk_cppexpr (CppCast (cppExpr, structType)) structType in - mk_cppexpr (CppCast (structCast, TCppInst (t, []))) (TCppInst (t, [])) + retyper_ctx, mk_cppexpr (CppCast (structCast, TCppInst (t, []))) (TCppInst (t, [])) | TCppObjectArray _ | TCppScalarArray _ | TCppNativePointer _ | TCppDynamicArray | TCppObjectPtr | TCppVarArg | TCppInst _ -> - mk_cppexpr (CppCast (cppExpr, return_type)) return_type - | TCppObjC k -> mk_cppexpr (CppCastObjC (cppExpr, k)) return_type + retyper_ctx, mk_cppexpr (CppCast (cppExpr, return_type)) return_type + | TCppObjC k -> retyper_ctx, mk_cppexpr (CppCastObjC (cppExpr, k)) return_type | TCppObjCBlock (ret, args) -> - mk_cppexpr (CppCastObjCBlock (cppExpr, ret, args)) return_type + retyper_ctx, mk_cppexpr (CppCastObjCBlock (cppExpr, ret, args)) return_type | TCppScalar scalar -> - mk_cppexpr (CppCastScalar (cppExpr, scalar)) return_type + retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, scalar)) return_type | TCppString -> - mk_cppexpr (CppCastScalar (cppExpr, "::String")) return_type + retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, "::String")) return_type | TCppInterface _ when cppExpr.cpptype = TCppVariant -> - mk_cppexpr (CppCastVariant cppExpr) return_type + retyper_ctx, mk_cppexpr (CppCastVariant cppExpr) return_type | TCppDynamic when cppExpr.cpptype = TCppVariant -> - mk_cppexpr (CppCastVariant cppExpr) return_type + retyper_ctx, mk_cppexpr (CppCastVariant cppExpr) return_type | TCppStar (t, const) -> let ptrType = TCppPointer ((if const then "ConstPointer" else "Pointer"), t) in let ptrCast = mk_cppexpr (CppCast (cppExpr, ptrType)) ptrType in - mk_cppexpr + retyper_ctx, mk_cppexpr (CppCast (ptrCast, TCppStar (t, const))) (TCppStar (t, const)) - | _ -> cppExpr + | _ -> retyper_ctx, cppExpr else match (cppExpr.cpptype, return_type) with - | _, TCppUnchanged -> cppExpr + | _, TCppUnchanged -> retyper_ctx, cppExpr (* Using the 'typedef hack', where we use typedef X = T, allows the haxe compiler to use these types interchangeably. We then work @@ -1377,55 +1436,395 @@ let expression ctx request_type function_args function_type expression_tree forI *) | TCppAutoCast, _ | TCppObjC _, TCppDynamic | TCppObjCBlock _, TCppDynamic -> - mk_cppexpr (CppCast (cppExpr, return_type)) return_type + retyper_ctx, mk_cppexpr (CppCast (cppExpr, return_type)) return_type (* Infer type from right-hand-side for pointer or reference to Dynamic *) - | TCppReference TCppDynamic, TCppReference _ -> cppExpr - | TCppReference TCppDynamic, t -> mk_cppexpr retypedExpr (TCppReference t) - | TCppStar (TCppDynamic, _), TCppStar (_, _) -> cppExpr + | TCppReference TCppDynamic, TCppReference _ -> retyper_ctx, cppExpr + | TCppReference TCppDynamic, t -> retyper_ctx, mk_cppexpr retypedExpr (TCppReference t) + | TCppStar (TCppDynamic, _), TCppStar (_, _) -> retyper_ctx, cppExpr | TCppStar (TCppDynamic, const), t -> - mk_cppexpr retypedExpr (TCppStar (t, const)) + retyper_ctx, mk_cppexpr retypedExpr (TCppStar (t, const)) | TCppStar (t, const), TCppDynamic -> let ptrType = TCppPointer ((if const then "ConstPointer" else "Pointer"), t) in let ptrCast = mk_cppexpr (CppCast (cppExpr, ptrType)) ptrType in - mk_cppexpr (CppCast (ptrCast, TCppDynamic)) TCppDynamic + retyper_ctx, mk_cppexpr (CppCast (ptrCast, TCppDynamic)) TCppDynamic | TCppStar (t, const), TCppReference _ | TCppStar (t, const), TCppInst _ | TCppStar (t, const), TCppStruct _ -> - mk_cppexpr (CppDereference cppExpr) return_type + retyper_ctx, mk_cppexpr (CppDereference cppExpr) return_type | TCppInst (t, _), TCppStar _ when is_native_class t && match cppExpr.cppexpr with | CppCall (FuncNew _, _) -> true | _ -> false -> - mk_cppexpr (CppNewNative cppExpr) return_type + retyper_ctx, mk_cppexpr (CppNewNative cppExpr) return_type | TCppInst _, TCppStar (p, const) | TCppStruct _, TCppStar (p, const) -> - mk_cppexpr (CppAddressOf cppExpr) return_type - | TCppObjectPtr, TCppObjectPtr -> cppExpr + retyper_ctx, mk_cppexpr (CppAddressOf cppExpr) return_type + | TCppObjectPtr, TCppObjectPtr -> retyper_ctx, cppExpr | TCppObjectPtr, _ -> - mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic - | TCppProtocol _, TCppProtocol _ -> cppExpr + retyper_ctx, mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic + | TCppProtocol _, TCppProtocol _ -> retyper_ctx, cppExpr | t, TCppProtocol protocol -> - mk_cppexpr (CppCastProtocol (cppExpr, protocol)) return_type + retyper_ctx, mk_cppexpr (CppCastProtocol (cppExpr, protocol)) return_type | TCppInst (t, _), TCppDynamic when Meta.has Meta.StructAccess t.cl_meta -> let structType = TCppStruct (TCppInst (t, [])) in let structCast = mk_cppexpr (CppCast (cppExpr, structType)) structType in - mk_cppexpr (CppCast (structCast, TCppDynamic)) TCppDynamic + retyper_ctx, mk_cppexpr (CppCast (structCast, TCppDynamic)) TCppDynamic | _, TCppObjectPtr -> - mk_cppexpr (CppCast (cppExpr, TCppObjectPtr)) TCppObjectPtr + retyper_ctx, mk_cppexpr (CppCast (cppExpr, TCppObjectPtr)) TCppObjectPtr | TCppDynamicArray, TCppScalarArray _ | TCppDynamicArray, TCppObjectArray _ | TCppScalarArray _, TCppDynamicArray | TCppObjectArray _, TCppDynamicArray when forCppia -> - mk_cppexpr (CppCast (cppExpr, return_type)) return_type + retyper_ctx, mk_cppexpr (CppCast (cppExpr, return_type)) return_type | TCppScalar from, TCppScalar too when from <> too -> - mk_cppexpr (CppCastScalar (cppExpr, too)) return_type - | _ -> cppExpr + retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, too)) return_type + | _ -> retyper_ctx, cppExpr + in + retype initial_ctx request_type expression_tree |> snd + +let rec get_id path ids = + let class_name = class_text path in + let needs_new_id id = + (* IDs less than 100 are reserved for hxcpp internal classes *) + (* If the map already contains this ID we also need a new one *) + id < Int32.of_int 100 || ObjectIds.collision id ids in - retype request_type expression_tree + + let rec make_id seed = + let id = CppStrings.gen_hash32 seed class_name in + if needs_new_id id then + make_id (seed + 100) + else + id + in + + match ObjectIds.find_opt path ids with + | Some existing -> + (existing, ids) + | None -> + let new_id = make_id 0 in + (new_id, ObjectIds.add path new_id ids) + +let native_field_name_remap field = + match get_meta_string field.cf_meta Meta.Native with + | Some nativeImpl -> + keyword_remap nativeImpl + | None -> + keyword_remap field.cf_name + +let rec tcpp_class_from_tclass ctx ids slots class_def class_params = + let scriptable = Gctx.defined ctx.ctx_common Define.Scriptable in + + let create_function field func = { + tcf_field = field; + tcf_name = native_field_name_remap field; + tcf_func = func; + tcf_is_virtual = not (has_meta Meta.NonVirtual field.cf_meta); + tcf_is_reflective = reflective class_def field; + tcf_is_external = not (is_internal_member field.cf_name); + tcf_is_overriding = is_override field; + tcf_is_scriptable = scriptable; + } in + + let create_variable field = { + tcv_field = field; + tcv_name = native_field_name_remap field; + tcv_type = field.cf_type; + tcv_default = None; + + tcv_is_stackonly = has_meta Meta.StackOnly field.cf_meta; + tcv_is_reflective = reflective class_def field; + tcv_is_gc_element = cpp_type_of field.cf_type |> is_gc_element ctx; + } in + + let filter_functions is_static field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> + Some (create_function field func) + | Method MethNormal, _ when has_class_field_flag field CfAbstract -> + (* We need to fetch the default values for abstract functions from the @:Value meta *) + let abstract_tfunc = + match field.cf_type with + | TFun (args, ret) -> + let get_default_value name = + try + match Meta.get Meta.Value field.cf_meta with + | _, [ (EObjectDecl decls, _) ], _ -> + Some + (decls + |> List.find (fun ((n, _, _), _) -> n = name) + |> snd + |> type_constant_value ctx.ctx_common.basic) + | _ -> None + with Not_found -> None + in + + (* Generate a no op tfunc for our abstract *) + (* This allows it to go through the rest of the generator with no special cases *) + (* We can't implement abstract functions as pure virtual due to cppia needing to construct the class *) + let map_arg (name, _, t) = + ( (alloc_var VGenerated name t null_pos), (get_default_value name) ) in + let expr = + match follow ret with + | TAbstract ({ a_path = ([], "Void") }, _) -> + { eexpr = TReturn None; etype = ret; epos = null_pos } + | _ -> + let zero_val = Some { eexpr = TConst (TInt Int32.zero); etype = ret; epos = null_pos } in + { eexpr = TReturn zero_val; etype = ret; epos = null_pos } in + + { + tf_args = args |> List.map map_arg; + tf_type = ret; + tf_expr = expr; + } + | _ -> + die "expected abstract field type to be TFun" __LOC__ + in + + Some (create_function field abstract_tfunc) + | _ -> + None + else + None + in + + let filter_dynamic_functions func_for_static_field field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method MethDynamic, Some { eexpr = TFunction func } -> + Some (create_function field func) + (* static variables with a default function value get a dynamic function generated as the implementation *) + | Var _, Some { eexpr = TFunction func } when func_for_static_field -> + Some (create_function field func) + | _ -> + None + else + None + in + + let filter_variables field = + if is_physical_field field then + match (field.cf_kind, field.cf_expr) with + | Var _, _ -> + Some (create_variable field) + (* Dynamic methods are implemented as a physical field holding a closure *) + | Method MethDynamic, Some { eexpr = TFunction func } -> + Some (create_variable { field with cf_expr = None; cf_kind = Var ({ v_read = AccNormal; v_write = AccNormal }) }) + (* Below should cause abstracts which have functions with no implementation to be generated as a field *) + (* See Int32.hx as an example *) + | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> + Some (create_variable field) + | _ -> + None + else + None + in + + let filter_properties field = + match field.cf_kind with + | Var _ when not (is_physical_var_field field) -> + Some (create_variable field) + | _ -> + None in + + let id, ids = get_id class_def.cl_path ids in + + let static_functions = + class_def.cl_ordered_statics + |> List.filter_map (filter_functions true) in + + let static_dynamic_functions = + class_def.cl_ordered_statics + |> List.filter_map (filter_dynamic_functions true) in + + let static_variables = + class_def.cl_ordered_statics + |> List.filter (fun field -> field.cf_name <> "__meta__" && field.cf_name <> "__rtti") + |> List.filter_map filter_variables in + + let static_properties = + class_def.cl_ordered_statics + |> List.filter (fun field -> field.cf_name <> "__meta__" && field.cf_name <> "__rtti") + |> List.filter_map filter_properties in + + let functions = + class_def.cl_ordered_fields + |> List.filter_map (filter_functions true) in + + let dynamic_functions = + class_def.cl_ordered_fields + |> List.filter_map (filter_dynamic_functions false) in + + let variables = + class_def.cl_ordered_fields + |> List.filter_map filter_variables in + + let properties = + class_def.cl_ordered_fields + |> List.filter_map filter_properties in + + (* All interfaces (and sub-interfaces) implemented *) + let rec folder (slots, haxe, native) (interface, _) = + let slots, retyped = tcpp_interface_from_tclass ctx slots interface in + let acc = if is_native_class interface then + List.fold_left folder (slots, haxe, PathMap.add interface.cl_path retyped native) interface.cl_implements + else + List.fold_left folder (slots, PathMap.add interface.cl_path retyped haxe, native) interface.cl_implements in + + match interface.cl_super with + | Some super -> folder acc super + | None -> acc + in + let values (slots, haxe, native) = + slots, haxe |> PathMap.bindings |> List.map (fun (_, v) -> v), native |> PathMap.bindings |> List.map (fun (_, v) -> v) in + + let (slots, ids, parent) = + match class_def.cl_super with + | Some (cls, params) -> + let slots, ids, parent = tcpp_class_from_tclass ctx ids slots cls params in + (slots, ids, Some parent) + | None -> + (slots, ids, None) + in + let slots, haxe_implementations, native_implementations = + class_def.cl_implements + |> real_interfaces + |> List.fold_left folder (slots, PathMap.empty, PathMap.empty) + |> values in + + let gc_container_type = + let type_cant_be_null t = + match cpp_type_of t with TCppScalar _ -> true | _ -> false in + + let rec gc_container variables super v = + match List.exists (fun v -> not (type_cant_be_null v.tcv_type)) variables, super with + | true, _ -> Some v + | false, Some super -> gc_container super.tcl_variables super.tcl_super Parent + | false, None -> None + in + + gc_container variables parent Current + in + + let flags = 0 + |> (fun f -> if scriptable && not class_def.cl_private then set_tcpp_class_flag f Scriptable else f) + |> (fun f -> if can_quick_alloc class_def then set_tcpp_class_flag f QuickAlloc else f) + |> (fun f -> if has_get_member_field class_def then set_tcpp_class_flag f MemberGet else f) + |> (fun f -> if has_set_member_field class_def then set_tcpp_class_flag f MemberSet else f) + |> (fun f -> if has_get_static_field class_def then set_tcpp_class_flag f StaticGet else f) + |> (fun f -> if has_set_static_field class_def then set_tcpp_class_flag f StaticSet else f) + |> (fun f -> if has_get_fields class_def then set_tcpp_class_flag f GetFields else f) + |> (fun f -> if has_compare_field class_def then set_tcpp_class_flag f Compare else f) + |> (fun f -> if has_boot_field class_def then set_tcpp_class_flag f Boot else f) + in + + let meta_field = List.find_opt (fun field -> field.cf_name = "__meta__") class_def.cl_ordered_statics |> Option.map (fun f -> Option.get f.cf_expr) in + let rtti_field = List.find_opt (fun field -> field.cf_name = "__rtti") class_def.cl_ordered_statics |> Option.map (fun f -> Option.get f.cf_expr) in + + let cls = { + tcl_class = class_def; + tcl_params = class_params; + tcl_id = id; + tcl_name = class_name class_def; + tcl_flags = flags; + tcl_super = parent; + tcl_container = gc_container_type; + tcl_debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Gctx.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level; + tcl_static_variables = static_variables; + tcl_static_properties = static_properties; + tcl_static_functions = static_functions; + tcl_static_dynamic_functions = static_dynamic_functions; + tcl_variables = variables; + tcl_properties = properties; + tcl_functions = functions; + tcl_dynamic_functions = dynamic_functions; + tcl_haxe_interfaces = haxe_implementations; + tcl_native_interfaces = native_implementations; + tcl_meta = meta_field; + tcl_rtti = rtti_field; + tcl_init = TClass.get_cl_init class_def; + } in + + (slots, ids, cls) + +and tcpp_interface_from_tclass ctx slots class_def = + + let scriptable = Gctx.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private in + + let function_filter (slots, fields) field = + match (field.cf_type, field.cf_kind) with + | TFun (args, ret), Method _ -> + let slots = if scriptable then + CppAst.InterfaceSlots.add field.cf_name slots + else + slots + in + let retyped = { + iff_field = field; + iff_name = native_field_name_remap field; + iff_args = args |> List.map (fun (name, opt, t) -> (keyword_remap name, opt, t)); + iff_return = ret; + iff_script_slot = CppAst.InterfaceSlots.find_opt field.cf_name slots + } in + (slots, retyped :: fields) + | _ -> + (slots, fields) + in + let variable_filter field = + match field.cf_kind with + | Var _ when is_physical_var_field field -> true + | _ -> false + in + + let debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Gctx.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level in + let meta_field = List.find_opt (fun field -> field.cf_name = "__meta__") class_def.cl_ordered_statics |> Option.map (fun f -> Option.get f.cf_expr) in + let rtti_field = List.find_opt (fun field -> field.cf_name = "__rtti") class_def.cl_ordered_statics |> Option.map (fun f -> Option.get f.cf_expr) in + let slots, extends = + match class_def.cl_super with + | Some (s, _) -> + let extra, iface = tcpp_interface_from_tclass ctx slots s in + (extra, Some iface) + | None -> + (slots, None) + in + + let slots, functions = List.fold_left function_filter (slots, []) class_def.cl_ordered_fields in + + let iface = { + if_class = class_def; + if_name = class_name class_def; + if_hash = CppStrings.gen_hash 0 (join_class_path class_def.cl_path "::"); + if_debug_level = debug_level; + if_functions = functions |> List.rev; + if_variables = List.filter variable_filter class_def.cl_ordered_fields; + if_meta = meta_field; + if_rtti = rtti_field; + if_extends = extends; + if_scriptable = scriptable; + } in + + (slots, iface) + +and tcpp_enum_from_tenum ctx ids enum_def = + let sort_constructors f1 f2 = + f1.ef_index - f2.ef_index in + + let self_id, ids = get_id enum_def.e_path ids in + let strq = CppStrings.strq ctx.ctx_common in + let constructors = + enum_def.e_constrs + |> pmap_values + |> List.sort sort_constructors + |> List.map (fun f -> { tef_field = f; tef_name = keyword_remap f.ef_name; tef_hash = strq f.ef_name}) + in + let enum = { te_enum = enum_def; te_id = self_id; te_constructors = constructors } in + + (ids, enum) \ No newline at end of file diff --git a/src/generators/cpp/cppTypeUtils.ml b/src/generators/cpp/cppTypeUtils.ml index 50d5c37faf8..ee4c96e3d83 100644 --- a/src/generators/cpp/cppTypeUtils.ml +++ b/src/generators/cpp/cppTypeUtils.ml @@ -65,6 +65,24 @@ let is_internal_class = function let is_native_class class_def = (is_extern_class class_def || is_native_gen_class class_def) && not (is_internal_class class_def.cl_path) +let can_quick_alloc klass = + let rec implements_native_interface class_def = + List.exists + (fun (intf_def, _) -> is_native_gen_class intf_def || implements_native_interface intf_def) class_def.cl_implements || + match class_def.cl_super with + | Some (i, _) -> implements_native_interface i + | _ -> false + in + + (not (is_native_class klass)) && not (implements_native_interface klass) + +let real_interfaces classes = + List.filter (function t, pl -> + (match (t, pl) with + | { cl_path = [ "cpp"; "rtti" ], _ }, [] -> false + | _ -> true)) + classes + let is_interface_type t = match follow t with | TInst (klass,params) -> (has_class_flag klass CInterface) @@ -129,12 +147,7 @@ let is_numeric t = -> true | _ -> false - -let is_cpp_function_instance t = - match follow t with - | TInst ({ cl_path = (["cpp"], "Function") }, _) -> true - | _ -> false - + let is_objc_class klass = has_class_flag klass CExtern && Meta.has Meta.Objc klass.cl_meta @@ -178,23 +191,6 @@ let is_array_or_dyn_array haxe_type = | TType ({ t_path = ([], "Array")}, _) -> true | _ -> false -let is_array_implementer haxe_type = - match follow haxe_type with - | TInst ({ cl_array_access = Some _ }, _) -> 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" - let should_implement_field x = is_physical_field x let is_scalar_abstract abstract_def = @@ -318,33 +314,6 @@ let has_boot_field class_def = | None -> List.exists has_field_init (List.filter should_implement_field class_def.cl_ordered_statics) | _ -> true -(* - Functions are added in reverse order (oldest on right), then list is reversed because this is easier in ocaml - The order is important because cppia looks up functions by index -*) -let current_virtual_functions_rev clazz base_functions = - List.fold_left (fun result elem -> match follow elem.cf_type, elem.cf_kind with - | _, Method MethDynamic -> result - | TFun (args,return_type), Method _ -> - if (is_override elem ) then - if List.exists (fun (e,a,r) -> e.cf_name=elem.cf_name ) result then - result - else - (elem,args,return_type) :: result - else - (elem,args,return_type) :: result - | _,_ -> result - ) base_functions clazz.cl_ordered_fields - -let all_virtual_functions clazz = - let rec all_virtual_functions_rec clazz = - current_virtual_functions_rev clazz (match clazz.cl_super with - | Some def -> all_virtual_functions_rec (fst def) - | _ -> [] - ) - in - List.rev (all_virtual_functions_rec clazz) - let class_name class_def = let (_, class_path) = class_def.cl_path in let nativeGen = Meta.has Meta.NativeGen class_def.cl_meta in diff --git a/src/generators/cpp/gen/cppCppia.ml b/src/generators/cpp/gen/cppCppia.ml index 85468f61e64..5b49edcbfbd 100644 --- a/src/generators/cpp/gen/cppCppia.ml +++ b/src/generators/cpp/gen/cppCppia.ml @@ -2,7 +2,6 @@ open Ast open Type open Error open Globals -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools @@ -353,6 +352,19 @@ let rec is_null expr = let is_virtual_array expr = type_string expr.etype = "cpp::VirtualArray" +let rec remove_parens expression = + match expression.eexpr with + | TParenthesis e -> remove_parens e + | TMeta(_,e) -> remove_parens e + | _ -> expression + +let rec remove_parens_cast expression = + match expression.eexpr with + | TParenthesis e -> remove_parens_cast e + | TMeta(_,e) -> remove_parens_cast e + | TCast ( e,None) -> remove_parens_cast e + | _ -> expression + let is_this expression = match (remove_parens expression).eexpr with | TConst TThis -> true @@ -447,7 +459,7 @@ and is_dynamic_member_lookup_in_cpp (ctx : context) field_object field = | "Dynamic" -> true | name -> let full_name = name ^ "." ^ member in - if Hashtbl.mem ctx.ctx_class_member_types full_name then false + if StringMap.mem full_name ctx.ctx_class_member_types then false else not (is_extern_class_instance field_object) and is_dynamic_member_return_in_cpp ctx field_object field = @@ -462,7 +474,7 @@ and is_dynamic_member_return_in_cpp ctx field_object field = "::" ^ join_class_path_remap (t_path t) "::" ^ "." ^ member in try - let mem_type = Hashtbl.find ctx.ctx_class_member_types full_name in + let mem_type = StringMap.find full_name ctx.ctx_class_member_types in mem_type = "Dynamic" || mem_type = "cpp::ArrayBase" || mem_type = "cpp::VirtualArray" @@ -479,7 +491,7 @@ and is_dynamic_member_return_in_cpp ctx field_object field = let full_name = name ^ "." ^ member in try let mem_type = - Hashtbl.find ctx.ctx_class_member_types full_name + StringMap.find full_name ctx.ctx_class_member_types in mem_type = "Dynamic" || mem_type = "cpp::ArrayBase" diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 6b39f3bb915..4d382805c6d 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -67,44 +67,18 @@ let print_arg_list_name arg_list prefix = let print_arg_names args = String.concat "," (List.map (fun (name, _, _) -> keyword_remap name) args) -let rec print_tfun_arg_list include_names arg_list = +let print_tfun_arg_list include_names arg_list = let oType o arg_type = let type_str = type_to_string arg_type in (* type_str may have already converted Null to Dynamic because of NotNull tag ... *) if o && type_cant_be_null arg_type && type_str <> "Dynamic" then "::hx::Null< " ^ type_str ^ " > " - else type_str - in - match arg_list with - | [] -> "" - | [ (name, o, arg_type) ] -> - oType o arg_type ^ if include_names then " " ^ keyword_remap name else "" - | (name, o, arg_type) :: remaining -> - oType o arg_type - ^ (if include_names then " " ^ keyword_remap name else "") - ^ "," - ^ print_tfun_arg_list include_names remaining - -let has_new_gc_references class_def = - let is_gc_reference field = - should_implement_field field - && is_data_member field - && not (type_cant_be_null field.cf_type) + else + type_str in - List.exists is_gc_reference class_def.cl_ordered_fields - -let rec has_gc_references class_def = - (match class_def.cl_super with - | Some def when has_gc_references (fst def) -> true - | _ -> false) - || has_new_gc_references class_def - -let rec find_next_super_iteration class_def = - match class_def.cl_super with - | Some (klass, params) when has_new_gc_references klass -> - tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) - | Some (klass, _) -> find_next_super_iteration klass - | _ -> "" + arg_list + |> List.map (fun (name, o, arg_type) -> (oType o arg_type) ^ (if include_names then " " ^ keyword_remap name else "")) + |> String.concat "," let cpp_member_name_of member = match get_meta_string member.cf_meta Meta.Native with @@ -175,19 +149,6 @@ let cpp_class_name klass = let path = globalNamespace ^ join_class_path_remap klass.cl_path "::" in if is_native_class klass || path = "::String" then path else path ^ "_obj" -let rec implements_native_interface class_def = - List.exists - (fun (intf_def, _) -> - is_native_gen_class intf_def || implements_native_interface intf_def) - class_def.cl_implements - || - match class_def.cl_super with - | Some (i, _) -> implements_native_interface i - | _ -> false - -let can_quick_alloc klass = - (not (is_native_class klass)) && not (implements_native_interface klass) - let only_stack_access haxe_type = match cpp_type_of haxe_type with | TCppInst (klass, _) -> Meta.has Meta.StackOnly klass.cl_meta @@ -382,63 +343,7 @@ let hx_stack_push ctx output clazz func_name pos gc_stack = (* Add include to source code *) let add_include writer class_path = writer#add_include class_path -let real_interfaces = - List.filter (function t, pl -> - (match (t, pl) with - | { cl_path = [ "cpp"; "rtti" ], _ }, [] -> false - | _ -> true)) - -let native_field_name_remap is_static field = - let remap_name = keyword_remap field.cf_name in - if not is_static then remap_name - else - match get_meta_string field.cf_meta Meta.Native with - | Some nativeImpl -> - let r = Str.regexp "^[a-zA-Z_0-9]+$" in - if Str.string_match r remap_name 0 then "_hx_" ^ remap_name - else "_hx_f" ^ gen_hash 0 remap_name - | None -> remap_name - -let rec 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)) - && - match class_def.cl_super with - | None -> true - | Some (parent, _) -> is_dynamic_accessor name acc field parent - -(* Builds inheritance tree, so header files can include parents defs. *) -let create_super_dependencies common_ctx = - let result = Hashtbl.create 0 in - let real_non_native_interfaces = - List.filter (function t, pl -> - (match (t, pl) with - | { cl_path = [ "cpp"; "rtti" ], _ }, [] -> false - | _ -> not (is_native_gen_class t))) - in - let iterator object_def = - match object_def with - | TClassDecl class_def when not (has_class_flag class_def CExtern) -> - let deps = ref [] in - (match class_def.cl_super with - | Some super -> - if not (has_class_flag (fst super) CExtern) then - deps := (fst super).cl_path :: !deps - | _ -> ()); - List.iter - (fun imp -> - if not (has_class_flag (fst imp) CExtern) then - deps := (fst imp).cl_path :: !deps) - (real_non_native_interfaces class_def.cl_implements); - Hashtbl.add result class_def.cl_path !deps - | TEnumDecl enum_def when not (has_enum_flag enum_def EnExtern) -> - Hashtbl.add result enum_def.e_path [] - | _ -> () - in - List.iter iterator common_ctx.types; - result - -let can_inline_constructor baseCtx class_def super_deps constructor_deps = +let can_inline_constructor base_ctx class_def = match class_def.cl_constructor with | Some { cf_expr = Some super_func } -> let is_simple = ref true in @@ -461,25 +366,12 @@ let can_inline_constructor baseCtx class_def super_deps constructor_deps = (* Check to see if all the types required by the constructor are already in the header *) (* This is quite restrictive, since most classes are forward-declared *) let deps, _ = - CppReferences.find_referenced_types_flags baseCtx (TClassDecl class_def) - "new" super_deps constructor_deps false false true + CppReferences.find_referenced_types_flags base_ctx (TClassDecl class_def) + (Some "new") base_ctx.ctx_super_deps base_ctx.ctx_constructor_deps false false true in List.for_all (fun dep -> List.mem dep allowed) deps | _ -> true -let create_constructor_dependencies common_ctx = - let result = Hashtbl.create 0 in - List.iter - (fun object_def -> - match object_def with - | TClassDecl class_def when not (has_class_flag class_def CExtern) -> ( - match class_def.cl_constructor with - | Some func_def -> Hashtbl.add result class_def.cl_path func_def - | _ -> ()) - | _ -> ()) - common_ctx.types; - result - let begin_namespace output class_path = List.iter (fun namespace -> output ("namespace " ^ namespace ^ "{\n")) @@ -511,80 +403,44 @@ let cpp_tfun_signature include_names args return_type = let returnType = type_to_string return_type in "( " ^ returnType ^ " (::hx::Object::*)(" ^ argList ^ "))" -exception FieldFound of tclass_field - -let find_class_implementation class_def name interface = +let find_class_implementation func tcpp_class = let rec find def = - List.iter - (fun f -> if f.cf_name = name then raise (FieldFound f)) - def.cl_ordered_fields; - match def.cl_super with Some (def, _) -> find def | _ -> () + match List.find_opt (fun f -> f.tcf_name = func.iff_name) def.tcl_functions with + | Some f -> Some f.tcf_field + | None -> + match def.tcl_super with + | Some s -> find s + | None -> None in - try - find class_def; - abort - ("Could not find implementation of " ^ name ^ " in " - ^ join_class_path class_def.cl_path "." - ^ " required by " - ^ join_class_path interface.cl_path ".") - class_def.cl_pos - with FieldFound field -> ( - match (follow field.cf_type, field.cf_kind) with - | _, Method MethDynamic -> "" - | TFun (args, return_type), Method _ -> - cpp_tfun_signature false args return_type - | _, _ -> "") + + match find tcpp_class with + | Some { cf_type = TFun (args, ret) } -> + cpp_tfun_signature false args ret + | _ -> + "" let gen_gc_name class_path = let class_name_text = join_class_path class_path "." in const_char_star class_name_text -(* All interfaces (and sub-interfaces) implemented *) -let implementations class_def = - let implemented_hash = Hashtbl.create 0 in - let native_implemented = Hashtbl.create 0 in - - let cpp_interface_impl_name interface = - "_hx_" ^ join_class_path interface.cl_path "_" +let needed_interface_functions implemented_instance_fields native_implementations = + let have = + implemented_instance_fields + |> List.map (fun (func) -> (func.tcf_name, ())) + |> string_map_of_list in - let iterator impl = - let rec descend_interface interface = - let intf_def = fst interface in - let interface_name = cpp_interface_impl_name intf_def in - let hash = - if is_native_gen_class intf_def then native_implemented - else implemented_hash - in - if not (Hashtbl.mem hash interface_name) then ( - Hashtbl.replace hash interface_name intf_def; - List.iter descend_interface intf_def.cl_implements); - match intf_def.cl_super with - | Some (interface, params) -> descend_interface (interface, params) - | _ -> () - in - descend_interface impl + let func_folder (have, acc) func = + if StringMap.mem func.iff_name have then + (have, acc) + else + (StringMap.add func.iff_name () have, func :: acc) in - - List.iter iterator (real_interfaces class_def.cl_implements); - (implemented_hash, native_implemented) - -let needed_interface_functions implemented_instance_fields - native_implementations = - let have = - List.map (fun field -> (field.cf_name, ())) implemented_instance_fields - |> List.to_seq |> Hashtbl.of_seq + let iface_folder acc iface = + List.fold_left func_folder acc iface.if_functions in - let want = ref [] in - Hashtbl.iter - (fun _ intf_def -> - List.iter - (fun field -> - if not (Hashtbl.mem have field.cf_name) then ( - Hashtbl.replace have field.cf_name (); - want := field :: !want)) - intf_def.cl_ordered_fields) - native_implementations; - !want + native_implementations + |> List.fold_left iface_folder (have, []) + |> snd let gen_cpp_ast_expression_tree ctx class_name func_name function_args function_type injection tree = @@ -1087,7 +943,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args separator := "," | _ -> ()); - Hashtbl.iter + StringMap.iter (fun name value -> out !separator; separator := ","; @@ -1603,8 +1459,9 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args | OpIn -> " in " | OpNullCoal -> "??" | OpAssign | OpAssignOp _ -> abort "Unprocessed OpAssign" pos + and gen_closure closure = - let argc = Hashtbl.length closure.close_undeclared in + let argc = StringMap.bindings closure.close_undeclared |> List.length in let size = string_of_int argc in if argc >= 62 then (* Limited by c++ macro size of 128 args *) @@ -1617,7 +1474,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args (if closure.close_this != None then "::hx::LocalThisFunc," else "::hx::LocalFunc,"); out ("_hx_Closure_" ^ string_of_int closure.close_id); - Hashtbl.iter + StringMap.iter (fun name var -> out ("," ^ cpp_macro_var_type_of var ^ "," ^ keyword_remap name)) closure.close_undeclared; @@ -1697,11 +1554,11 @@ let generate_main ctx super_deps class_def = | _ -> die "" __LOC__ in CppReferences.find_referenced_types ctx (TClassDecl class_def) super_deps - (Hashtbl.create 0) false false false + PathMap.empty false false false |> ignore; let depend_referenced = CppReferences.find_referenced_types ctx (TClassDecl class_def) super_deps - (Hashtbl.create 0) false true false + PathMap.empty false true false in let generate_startup filename is_main = (*make_class_directories base_dir ( "src" :: []);*) @@ -1739,7 +1596,7 @@ let generate_dummy_main common_ctx = generate_startup "__main__" true; generate_startup "__lib__" false -let generate_boot ctx boot_enums boot_classes nonboot_classes init_classes = +let generate_boot ctx boot_enums boot_classes nonboot_classes init_classes (slots:CppAst.InterfaceSlots.t) = let common_ctx = ctx.ctx_common in (* Write boot class too ... *) let base_dir = common_ctx.file in @@ -1754,9 +1611,10 @@ let generate_boot ctx boot_enums boot_classes nonboot_classes init_classes = let newScriptable = Gctx.defined common_ctx Define.Scriptable in if newScriptable then ( output_boot "#include \n"; - let funcs = - hash_iterate !(ctx.ctx_interface_slot) (fun name id -> (name, id)) - in + + + + let funcs = StringMap.bindings slots.hash in let sorted = List.sort (fun (_, id1) (_, id2) -> id1 - id2) funcs in output_boot "static const char *scriptableInterfaceFuncs[] = {\n\t0,\n\t0,\n"; @@ -1773,7 +1631,7 @@ let generate_boot ctx boot_enums boot_classes nonboot_classes init_classes = if newScriptable then output_boot ("::hx::ScriptableRegisterNameSlots(scriptableInterfaceFuncs," - ^ string_of_int !(ctx.ctx_interface_slot_count) + ^ string_of_int slots.next ^ ");\n"); List.iter @@ -1905,33 +1763,27 @@ let gen_cpp_function_body ctx clazz is_static func_name function_def head_code let constructor_arg_var_list class_def = match class_def.cl_constructor with - | Some definition -> ( - match definition.cf_expr with - | Some { eexpr = TFunction function_def } -> - List.map - (fun (v, o) -> - (v.v_name, type_arg_to_string 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) -> (a, (type_to_string t, a))) args - | _ -> [])) + | Some { cf_expr = Some { eexpr = TFunction function_def } } -> + List.map + (fun (v, o) -> type_arg_to_string v.v_name o v.v_type "__o_") + function_def.tf_args + | Some definition -> + (match follow definition.cf_type with + | TFun (args, _) -> List.map (fun (a, _, t) -> type_to_string t, a) args + | _ -> []) | _ -> [] -let generate_constructor ctx out class_def isHeader = - let class_name = class_name class_def in - let ptr_name = class_pointer class_def in - let can_quick_alloc = can_quick_alloc class_def in - let gcName = gen_gc_name class_def.cl_path in - let isContainer = if has_gc_references class_def then "true" else "false" in - let cargs = constructor_arg_var_list class_def in - let constructor_type_var_list = List.map snd cargs in +let generate_constructor ctx out tcpp_class isHeader = + let class_name = tcpp_class.tcl_name in + let ptr_name = class_pointer tcpp_class.tcl_class in + let can_quick_alloc = has_tcpp_class_flag tcpp_class QuickAlloc in + let gcName = gen_gc_name tcpp_class.tcl_class.cl_path in + let cargs = constructor_arg_var_list tcpp_class.tcl_class in let constructor_type_args = String.concat "," - (List.map (fun (t, a) -> t ^ " " ^ a) constructor_type_var_list) + (List.map (fun (t, a) -> t ^ " " ^ a) cargs) in - let constructor_var_list = List.map snd constructor_type_var_list in + let constructor_var_list = List.map snd cargs in let constructor_args = String.concat "," constructor_var_list in let classScope = if isHeader then "" else class_name ^ "::" in @@ -1949,10 +1801,9 @@ let generate_constructor ctx out class_def isHeader = (staticHead ^ ptr_name ^ " " ^ classScope ^ "__alloc(::hx::Ctx *_hx_ctx" ^ (if constructor_type_args = "" then "" else "," ^ constructor_type_args) ^ ") {\n"); - out - ("\t" ^ class_name ^ " *__this = (" ^ class_name - ^ "*)(::hx::Ctx::alloc(_hx_ctx, sizeof(" ^ class_name ^ "), " ^ isContainer - ^ ", " ^ gcName ^ "));\n"); + Printf.sprintf + "\t%s* __this = (%s*)(::hx::Ctx::alloc(_hx_ctx, sizeof(%s), %b, %s));\n" + class_name class_name class_name (Option.is_some tcpp_class.tcl_container) gcName |> out; out ("\t*(void **)__this = " ^ class_name ^ "::_hx_vtable;\n"); let rec dump_dynamic class_def = if has_dynamic_member_functions class_def then @@ -1965,16 +1816,16 @@ let generate_constructor ctx out class_def isHeader = | Some super -> dump_dynamic (fst super) | _ -> () in - dump_dynamic class_def; + dump_dynamic tcpp_class.tcl_class; if isHeader then - match class_def.cl_constructor with + match tcpp_class.tcl_class.cl_constructor with | Some ({ cf_expr = Some { eexpr = TFunction function_def } } as definition) -> with_debug ctx definition.cf_meta (fun no_debug -> ctx.ctx_real_this_ptr <- false; - gen_cpp_function_body ctx class_def false "new" function_def "" "" + gen_cpp_function_body ctx tcpp_class.tcl_class false "new" function_def "" "" no_debug; out "\n") | _ -> () @@ -1984,12 +1835,12 @@ let generate_constructor ctx out class_def isHeader = out "}\n\n") let generate_native_constructor ctx out class_def isHeader = - let cargs = constructor_arg_var_list class_def in - let constructor_type_var_list = List.map snd cargs in let constructor_type_args = - String.concat "," - (List.map (fun (t, a) -> t ^ " " ^ a) constructor_type_var_list) - in + class_def + |> constructor_arg_var_list + |> List.map (fun (t, a) -> Printf.sprintf "%s %s" t a) + |> String.concat "," in + let class_name = class_name class_def in match class_def.cl_constructor with @@ -2035,13 +1886,3 @@ let generate_native_constructor ctx out class_def isHeader = gen_cpp_function_body ctx class_def false "new" function_def head_code tail_code no_debug) | _ -> () - -let dynamic_functions class_def = - List.fold_left - (fun result field -> - match field.cf_expr with - | Some { eexpr = TFunction function_def } - when is_dynamic_haxe_method field -> - keyword_remap field.cf_name :: result - | _ -> result) - [] class_def.cl_ordered_fields diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 9d0b0eff293..4c743107910 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -10,246 +10,70 @@ open CppSourceWriter open CppContext open CppGen -let gen_member_def ctx class_def is_static is_interface field = +let gen_member_variable ctx class_def is_static (var:tcpp_class_variable) = + let tcpp = cpp_type_of var.tcv_type in + let tcpp_str = tcpp_to_string tcpp in + + if not is_static && var.tcv_is_stackonly then + abort (Printf.sprintf "%s is marked as stack only and therefor cannot be used as the type for a non static variable" tcpp_str) var.tcv_field.cf_pos; + let output = ctx.ctx_output in - let remap_name = keyword_remap field.cf_name in - let nativeGen = Meta.has Meta.NativeGen class_def.cl_meta in - - if is_interface then - match (follow field.cf_type, field.cf_kind) with - | _, Method MethDynamic -> () - | TFun (args, return_type), Method _ -> - let gen_args = print_tfun_arg_list true in - if is_static || nativeGen then ( - output - ((if not is_static then "\t\tvirtual " else "\t\t") - ^ type_to_string return_type); - output (" " ^ remap_name ^ "( "); - output (gen_args args); - output (if not is_static then ")=0;\n" else ");\n"); - if reflective class_def field then - if Gctx.defined ctx.ctx_common Define.DynamicInterfaceClosures - then - output - ("\t\tinline ::Dynamic " ^ remap_name - ^ "_dyn() { return __Field( " - ^ strq ctx.ctx_common field.cf_name - ^ ", ::hx::paccDynamic); }\n") - else output ("\t\tvirtual ::Dynamic " ^ remap_name ^ "_dyn()=0;\n")) - else - let argList = gen_args args in - let returnType = type_to_string return_type in - let returnStr = if returnType = "void" then "" else "return " in - let commaArgList = if argList = "" then argList else "," ^ argList in - let cast = - "::hx::interface_cast< ::" - ^ join_class_path_remap class_def.cl_path "::" - ^ "_obj *>" - in - output - ("\t\t" ^ returnType ^ " (::hx::Object :: *_hx_" ^ remap_name ^ ")(" - ^ argList ^ "); \n"); - output - ("\t\tstatic inline " ^ returnType ^ " " ^ remap_name - ^ "( ::Dynamic _hx_" ^ commaArgList ^ ") {\n"); - output "\t\t\t#ifdef HXCPP_CHECK_POINTER\n"; - output - "\t\t\tif (::hx::IsNull(_hx_)) ::hx::NullReference(\"Object\", \ - false);\n"; - output "\t\t\t#ifdef HXCPP_GC_CHECK_POINTER\n"; - output "\t\t\t\tGCCheckPointer(_hx_.mPtr);\n"; - output "\t\t\t#endif\n"; - output "\t\t\t#endif\n"; - output - ("\t\t\t" ^ returnStr ^ "(_hx_.mPtr->*( " ^ cast - ^ "(_hx_.mPtr->_hx_getInterface(" ^ cpp_class_hash class_def - ^ ")))->_hx_" ^ remap_name ^ ")(" ^ print_arg_names args - ^ ");\n\t\t}\n") - | _ -> () - else - let nonVirtual = Meta.has Meta.NonVirtual field.cf_meta in - let doDynamic = - (nonVirtual || not (is_override field)) && reflective class_def field - in - let decl = get_meta_string field.cf_meta Meta.Decl in - let has_decl = match decl with Some _ -> true | None -> false in - if has_decl then output (" typedef " ^ (decl |> Option.get) ^ ";\n"); - output (if is_static then "\t\tstatic " else "\t\t"); - match field.cf_expr with - | Some { eexpr = TFunction function_def } -> - (if is_dynamic_haxe_method field then ( - if doDynamic then ( - output ("::Dynamic " ^ remap_name ^ ";\n"); - if (not is_static) && is_gc_element ctx TCppDynamic then - output - ("\t\tinline ::Dynamic _hx_set_" ^ remap_name - ^ "(::hx::StackContext *_hx_ctx,::Dynamic _hx_v) { \ - HX_OBJ_WB(this,_hx_v.mPtr) return " ^ remap_name - ^ "=_hx_v; }\n"); - output (if is_static then "\t\tstatic " else "\t\t"); - output - ("inline ::Dynamic &" ^ remap_name ^ "_dyn() " ^ "{return " - ^ remap_name ^ "; }\n"))) - else - let return_type = type_to_string function_def.tf_type in - (if (not is_static) && not nonVirtual then - let scriptable = - Gctx.defined ctx.ctx_common Define.Scriptable - in - if (not (is_internal_member field.cf_name)) && not scriptable then - let key = - join_class_path class_def.cl_path "." ^ "." ^ field.cf_name - in - try output (Hashtbl.find ctx.ctx_class_member_types key) - with Not_found -> () - else output "virtual "); - output (if return_type = "Void" then "void" else return_type); - - let remap_name = native_field_name_remap is_static field in - output (" " ^ remap_name ^ "("); - output (print_arg_list function_def.tf_args ""); - output ");\n"; - if doDynamic then ( - output (if is_static then "\t\tstatic " else "\t\t"); - output ("::Dynamic " ^ remap_name ^ "_dyn();\n"))); - output "\n" - | _ when has_class_field_flag field CfAbstract -> - let ctx_arg_list ctx arg_list prefix = - let get_default_value name = - try - match Meta.get Meta.Value field.cf_meta with - | _, [ (EObjectDecl decls, _) ], _ -> - Some - (List.find (fun ((n, _, _), _) -> n = name) decls - |> snd - |> type_constant_value ctx.ctx_common.basic) - | _ -> None - with Not_found -> None - in + let suffix = if is_static then "\t\tstatic " else "\t\t" in - String.concat "," - (List.map - (fun (n, o, t) -> print_arg n (get_default_value n) t prefix) - arg_list) - in - let tl, tr = - match follow field.cf_type with - | TFun (tl, tr) -> (tl, tr) - | _ -> die "" __LOC__ - in - let return_type = type_to_string tr in - let remap_name = native_field_name_remap is_static field in - output "virtual "; - output (if return_type = "Void" then "void" else return_type); - output (" " ^ remap_name ^ "("); - output (ctx_arg_list ctx tl ""); - output - (") " - ^ (if return_type = "void" then "{}" else "{ return 0; }") - ^ "\n"); - if doDynamic then output ("\t\t::Dynamic " ^ remap_name ^ "_dyn();\n") - | _ when has_decl -> output (remap_name ^ "_decl " ^ remap_name ^ ";\n") - (* Variable access *) - | _ -> ( - (* Variable access *) - let tcpp = cpp_type_of field.cf_type in - let tcppStr = tcpp_to_string tcpp in - if (not is_static) && only_stack_access field.cf_type then - abort - ("Variables of type " ^ tcppStr ^ " may not be used as members") - field.cf_pos; - - output (tcppStr ^ " " ^ remap_name ^ ";\n"); - (if (not is_static) && is_gc_element ctx tcpp then - let getPtr = - match tcpp with TCppString -> ".raw_ref()" | _ -> ".mPtr" - in - output - ("\t\tinline " ^ tcppStr ^ " _hx_set_" ^ remap_name - ^ "(::hx::StackContext *_hx_ctx," ^ tcppStr - ^ " _hx_v) { HX_OBJ_WB(this,_hx_v" ^ getPtr ^ ") return " - ^ remap_name ^ "=_hx_v; }\n")); - - (* Add a "dyn" function for variable to unify variable/function access *) - match follow field.cf_type with - | _ when nativeGen -> () - | TFun (_, _) -> - output (if is_static then "\t\tstatic " else "\t\t"); - output - ("Dynamic " ^ remap_name ^ "_dyn() { return " ^ remap_name - ^ ";}\n") - | _ -> ( - (match field.cf_kind with - | Var { v_read = AccCall } - when (not is_static) - && is_dynamic_accessor ("get_" ^ field.cf_name) "get" field - class_def -> - output ("\t\tDynamic get_" ^ field.cf_name ^ ";\n") - | _ -> ()); - match field.cf_kind with - | Var { v_write = AccCall } - when (not is_static) - && is_dynamic_accessor ("set_" ^ field.cf_name) "set" field - class_def -> - output ("\t\tDynamic set_" ^ field.cf_name ^ ";\n") - | _ -> ())) - -let generate baseCtx class_def = - let common_ctx = baseCtx.ctx_common in - let class_path = class_def.cl_path in - let nativeGen = Meta.has Meta.NativeGen class_def.cl_meta in - let smart_class_name = snd class_path in - let scriptable = - Gctx.defined common_ctx Define.Scriptable && not class_def.cl_private - in - let class_name = class_name class_def in - let ptr_name = class_pointer class_def in - let can_quick_alloc = can_quick_alloc class_def in - let gcName = gen_gc_name class_def.cl_path in - let isContainer = if has_gc_references class_def then "true" else "false" in - let cargs = constructor_arg_var_list class_def in - let constructor_type_var_list = List.map snd cargs in - let constructor_type_args = - String.concat "," - (List.map (fun (t, a) -> t ^ " " ^ a) constructor_type_var_list) + Printf.sprintf "%s%s %s;\n" suffix tcpp_str var.tcv_name |> output; + + if not is_static && var.tcv_is_gc_element then ( + let get_ptr = match tcpp with TCppString -> ".raw_ref()" | _ -> ".mPtr" in + Printf.sprintf + "\t\tinline %s _hx_set_%s(::hx::StackContext* _hx_ctx, %s _hx_v) { HX_OBJ_WB(this, _hx_v%s) return %s = _hx_v; }\n" + tcpp_str var.tcv_name tcpp_str get_ptr var.tcv_name |> output;) + +let gen_dynamic_function ctx class_def is_static func = + let output = ctx.ctx_output in + let prefix = if is_static then "\t\tstatic " else "\t\t" in + + Printf.sprintf "%sinline ::Dynamic& %s_dyn() { return %s; }\n" prefix func.tcf_name func.tcf_name |> output + +let gen_member_function ctx class_def is_static func = + let output = ctx.ctx_output in + + let fold_static acc = if is_static then "static" :: acc else acc in + let fold_virtual acc = + if not is_static && func.tcf_is_virtual then ( + if func.tcf_is_external && not func.tcf_is_scriptable then + let key = Printf.sprintf "%s.%s" (join_class_path class_def.cl_path ".") func.tcf_field.cf_name in + match StringMap.find_opt key ctx.ctx_class_member_types with + | Some v -> v :: acc + | None -> acc + else + "virtual" :: acc) + else + acc in - (*let cpp_file = new_cpp_file common_ctx.file class_path in*) - let debug = - if - Meta.has Meta.NoDebug class_def.cl_meta - || Gctx.defined baseCtx.ctx_common Define.NoDebug - then 0 - else 1 + let attributes = [] + |> fold_static + |> fold_virtual + |> String.concat " " in - let h_file = new_header_file common_ctx common_ctx.file class_path in - let ctx = file_context baseCtx h_file debug true in - let strq = strq ctx.ctx_common in + let return_type = type_to_string func.tcf_func.tf_type in + let return_type_str = if return_type = "Void" then "void" else return_type in + Printf.sprintf "\t\t%s %s %s(%s);\n" attributes return_type_str func.tcf_name (print_arg_list func.tcf_func.tf_args "") |> output; - let parent, super = - match class_def.cl_super with - | Some (klass, params) -> - let name = - tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) - in - ( (if has_class_flag class_def CInterface && nativeGen then "virtual " - else "") - ^ name, - name ) - | None when nativeGen && has_class_flag class_def CInterface -> - ("virtual ::hx::NativeInterface", "::hx::NativeInterface") - | None when has_class_flag class_def CInterface -> ("", "::hx::Object") - | None when nativeGen -> ("", "") - | None -> ("::hx::Object", "::hx::Object") - in - let output_h = h_file#write in + if (not func.tcf_is_virtual || not func.tcf_is_overriding) && func.tcf_is_reflective then + Printf.sprintf "\t\t%s::Dynamic %s_dyn();\n" (if is_static then "static " else "") func.tcf_name |> output; + + output "\n" + +let gen_class_header ctx tcpp_class h_file scriptable parents = + let class_path = tcpp_class.tcl_class.cl_path in let def_string = join_class_path class_path "_" in - begin_header_file h_file#write_h def_string nativeGen; + begin_header_file h_file#write_h def_string false; (* Include the real header file for the super class *) - (match class_def.cl_super with + (match tcpp_class.tcl_class.cl_super with | Some super -> let klass = fst super in let include_files = get_all_meta_string_path klass.cl_meta Meta.Include in @@ -272,274 +96,289 @@ let generate baseCtx class_def = (fun inc -> h_file#add_include (path_of_string inc)) include_files else h_file#add_include interface.cl_path) - (real_interfaces class_def.cl_implements); + (real_interfaces tcpp_class.tcl_class.cl_implements); (* Only need to forward-declare classes that are mentioned in the header file (ie, not the implementation) *) - let super_deps = create_super_dependencies common_ctx in + let output_h = h_file#write in + let class_path = tcpp_class.tcl_class.cl_path in let header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl class_def) "*" - super_deps (Hashtbl.create 0) true false scriptable + CppReferences.find_referenced_types_flags ctx (TClassDecl tcpp_class.tcl_class) None + ctx.ctx_super_deps PathMap.empty true false scriptable in List.iter2 (fun r f -> gen_forward_decl h_file r f) header_referenced header_flags; output_h "\n"; - output_h (get_class_code class_def Meta.HeaderCode); + output_h (get_class_code tcpp_class.tcl_class Meta.HeaderCode); let includes = - get_all_meta_string_path class_def.cl_meta Meta.HeaderInclude + get_all_meta_string_path tcpp_class.tcl_class.cl_meta Meta.HeaderInclude in let printer inc = output_h ("#include \"" ^ inc ^ "\"\n") in List.iter printer includes; begin_namespace output_h class_path; output_h "\n\n"; - output_h (get_class_code class_def Meta.HeaderNamespaceCode); + output_h (get_class_code tcpp_class.tcl_class Meta.HeaderNamespaceCode); - let extern_class = Gctx.defined common_ctx Define.DllExport in + let extern_class = Gctx.defined ctx.ctx_common Define.DllExport in let attribs = "HXCPP_" ^ (if extern_class then "EXTERN_" else "") ^ "CLASS_ATTRIBUTES" in - let dump_native_interfaces () = - List.iter - (fun (c, params) -> - output_h (" , public virtual " ^ join_class_path c.cl_path "::")) - (List.filter - (fun (t, _) -> is_native_gen_class t) - class_def.cl_implements) + let folder acc (cls, _) = + if is_native_class cls then + (Printf.sprintf "public virtual %s" (join_class_path cls.cl_path "::")) :: acc + else + acc + in + let all_parents = + tcpp_class.tcl_class.cl_implements + |> List.fold_left folder parents + |> List.rev in + let parent_string = + match all_parents with + | [] -> "" + | xs -> " : " ^ String.concat ", " xs in + + Printf.sprintf "class %s %s%s\n{\n\tpublic:\n" attribs tcpp_class.tcl_name parent_string |> output_h + +let generate_native_header base_ctx tcpp_class = + let common_ctx = base_ctx.ctx_common in + let class_def = tcpp_class.tcl_class in + let class_path = class_def.cl_path in + let scriptable = has_tcpp_class_flag tcpp_class Scriptable in + + let h_file = new_header_file common_ctx common_ctx.file class_path in + let ctx = file_context base_ctx h_file tcpp_class.tcl_debug_level true in + + let parent, super = + match class_def.cl_super with + | Some (klass, params) -> + let name = + tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) + in + ( name, name ) + | None -> ("", "") in + let output_h = h_file#write in + let def_string = join_class_path class_path "_" in - if has_class_flag class_def CInterface && not nativeGen then ( - output_h ("class " ^ attribs ^ " " ^ class_name ^ " {\n"); - output_h "\tpublic:\n"; - output_h ("\t\ttypedef " ^ super ^ " super;\n")) - else if super = "" then ( - output_h ("class " ^ attribs ^ " " ^ class_name); - dump_native_interfaces (); - output_h "\n{\n\tpublic:\n") - else ( - output_h ("class " ^ attribs ^ " " ^ class_name ^ " : public " ^ parent); - dump_native_interfaces (); - output_h "\n{\n\tpublic:\n"; - if not nativeGen then ( - output_h ("\t\ttypedef " ^ super ^ " super;\n"); - output_h ("\t\ttypedef " ^ class_name ^ " OBJ_;\n"))); - - let classId = - try Hashtbl.find baseCtx.ctx_type_ids (class_text class_def.cl_path) - with Not_found -> Int32.zero + gen_class_header ctx tcpp_class h_file scriptable (if super = "" then [] else [ (Printf.sprintf "public %s" parent) ]); + + CppGen.generate_native_constructor ctx output_h class_def true; + + if has_tcpp_class_flag tcpp_class Boot then output_h "\t\tstatic void __boot();\n"; + + tcpp_class.tcl_static_variables + |> List.iter (gen_member_variable ctx class_def true); + + tcpp_class.tcl_static_functions + |> List.iter (gen_member_function ctx class_def true); + + tcpp_class.tcl_static_dynamic_functions + |> List.iter (gen_dynamic_function ctx class_def true); + + tcpp_class.tcl_variables + |> List.iter (gen_member_variable ctx class_def false); + + tcpp_class.tcl_functions + |> List.iter (gen_member_function ctx class_def false); + + tcpp_class.tcl_dynamic_functions + |> List.iter (gen_dynamic_function ctx class_def false); + + output_h (get_class_code class_def Meta.HeaderClassCode); + output_h "};\n\n"; + + end_namespace output_h class_path; + + end_header_file output_h def_string; + + h_file#close + +let generate_managed_header base_ctx tcpp_class = + let common_ctx = base_ctx.ctx_common in + let class_def = tcpp_class.tcl_class in + let class_path = class_def.cl_path in + let smart_class_name = snd class_path in + let scriptable = has_tcpp_class_flag tcpp_class Scriptable in + let class_name = tcpp_class.tcl_name in + let ptr_name = class_pointer class_def in + let can_quick_alloc = has_tcpp_class_flag tcpp_class QuickAlloc in + let gcName = gen_gc_name class_def.cl_path in + + let constructor_type_args = + tcpp_class.tcl_class + |> constructor_arg_var_list + |> List.map (fun (t, a) -> Printf.sprintf "%s %s" t a) + |> String.concat "," in + + let h_file = new_header_file common_ctx common_ctx.file class_path in + let ctx = file_context base_ctx h_file tcpp_class.tcl_debug_level true in + let strq = strq ctx.ctx_common in + + let parent, super = + match tcpp_class.tcl_super with + | Some super -> + let name = tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class super.tcl_params) in + ( name, name ) + | None -> ("::hx::Object", "::hx::Object") in - let classIdTxt = Printf.sprintf "0x%08lx" classId in + let output_h = h_file#write in + let def_string = join_class_path class_path "_" in - if (not (has_class_flag class_def CInterface)) && not nativeGen then ( - output_h ("\t\t" ^ class_name ^ "();\n"); - output_h "\n\tpublic:\n"; - output_h ("\t\tenum { _hx_ClassId = " ^ classIdTxt ^ " };\n\n"); - output_h ("\t\tvoid __construct(" ^ constructor_type_args ^ ");\n"); + gen_class_header ctx tcpp_class h_file scriptable [ (Printf.sprintf "public %s" parent) ]; + + Printf.sprintf "\t\ttypedef %s super;\n" super |> output_h; + Printf.sprintf "\t\ttypedef %s OBJ_;\n" class_name |> output_h; + + let classIdTxt = Printf.sprintf "0x%08lx" tcpp_class.tcl_id in + + output_h ("\t\t" ^ class_name ^ "();\n"); + output_h "\n\tpublic:\n"; + output_h ("\t\tenum { _hx_ClassId = " ^ classIdTxt ^ " };\n\n"); + output_h ("\t\tvoid __construct(" ^ constructor_type_args ^ ");\n"); + Printf.sprintf "\t\tinline void *operator new(size_t inSize, bool inContainer=%b, const char* inName=%s)\n" (Option.is_some tcpp_class.tcl_container) gcName |> output_h; + output_h + "\t\t\t{ return ::hx::Object::operator new(inSize,inContainer,inName); }\n"; + output_h "\t\tinline void *operator new(size_t inSize, int extra)\n"; + Printf.sprintf "\t\t\t{ return ::hx::Object::operator new(inSize + extra, %b, %s); }\n" (Option.is_some tcpp_class.tcl_container) gcName |> output_h; + if has_class_flag class_def CAbstract then output_h "\n" + else if + can_inline_constructor base_ctx class_def + then ( + output_h "\n"; + CppGen.generate_constructor ctx + (fun str -> output_h ("\t\t" ^ str)) + tcpp_class true) + else ( output_h - ("\t\tinline void *operator new(size_t inSize, bool inContainer=" - ^ isContainer ^ ",const char *inName=" ^ gcName ^ ")\n"); + ("\t\tstatic " ^ ptr_name ^ " __new(" ^ constructor_type_args ^ ");\n"); + if can_quick_alloc then + output_h + ("\t\tstatic " ^ ptr_name ^ " __alloc(::hx::Ctx *_hx_ctx" + ^ (if constructor_type_args = "" then "" + else "," ^ constructor_type_args) + ^ ");\n")); + if not (has_class_flag class_def CAbstract) then ( + output_h "\t\tstatic void * _hx_vtable;\n"; + output_h "\t\tstatic Dynamic __CreateEmpty();\n"; + output_h "\t\tstatic Dynamic __Create(::hx::DynamicArray inArgs);\n"); + if List.length (tcpp_class.tcl_dynamic_functions) > 0 then output_h - "\t\t\t{ return ::hx::Object::operator new(inSize,inContainer,inName); }\n"; - output_h "\t\tinline void *operator new(size_t inSize, int extra)\n"; + ("\t\tstatic void __alloc_dynamic_functions(::hx::Ctx *_hx_alloc," ^ class_name ^ " *_hx_obj);\n"); + if scriptable then + output_h "\t\tstatic ::hx::ScriptFunction __script_construct;\n"; + output_h ("\t\t//~" ^ class_name ^ "();\n\n"); + output_h "\t\tHX_DO_RTTI_ALL;\n"; + if has_tcpp_class_flag tcpp_class MemberGet then output_h - ("\t\t\t{ return ::hx::Object::operator new(inSize+extra," ^ isContainer - ^ "," ^ gcName ^ "); }\n"); - if has_class_flag class_def CAbstract then output_h "\n" - else if - can_inline_constructor baseCtx class_def super_deps - (create_constructor_dependencies common_ctx) - then ( - output_h "\n"; - CppGen.generate_constructor ctx - (fun str -> output_h ("\t\t" ^ str)) - class_def true) - else ( - output_h - ("\t\tstatic " ^ ptr_name ^ " __new(" ^ constructor_type_args ^ ");\n"); - if can_quick_alloc then - output_h - ("\t\tstatic " ^ ptr_name ^ " __alloc(::hx::Ctx *_hx_ctx" - ^ (if constructor_type_args = "" then "" - else "," ^ constructor_type_args) - ^ ");\n")); - if not (has_class_flag class_def CAbstract) then ( - output_h "\t\tstatic void * _hx_vtable;\n"; - output_h "\t\tstatic Dynamic __CreateEmpty();\n"; - output_h "\t\tstatic Dynamic __Create(::hx::DynamicArray inArgs);\n"); - if List.length (CppGen.dynamic_functions class_def) > 0 then - output_h - ("\t\tstatic void __alloc_dynamic_functions(::hx::Ctx *_hx_alloc," - ^ class_name ^ " *_hx_obj);\n"); - if scriptable then - output_h "\t\tstatic ::hx::ScriptFunction __script_construct;\n"; - output_h ("\t\t//~" ^ class_name ^ "();\n\n"); - output_h "\t\tHX_DO_RTTI_ALL;\n"; - if has_get_member_field class_def then - output_h - "\t\t::hx::Val __Field(const ::String &inString, ::hx::PropertyAccess \ - inCallProp);\n"; - if has_get_static_field class_def then - output_h - "\t\tstatic bool __GetStatic(const ::String &inString, Dynamic \ - &outValue, ::hx::PropertyAccess inCallProp);\n"; - if has_set_member_field class_def then - output_h - "\t\t::hx::Val __SetField(const ::String &inString,const ::hx::Val \ - &inValue, ::hx::PropertyAccess inCallProp);\n"; - if has_set_static_field class_def then + "\t\t::hx::Val __Field(const ::String &inString, ::hx::PropertyAccess inCallProp);\n"; + if has_tcpp_class_flag tcpp_class StaticGet then + output_h + "\t\tstatic bool __GetStatic(const ::String &inString, Dynamic &outValue, ::hx::PropertyAccess inCallProp);\n"; + if has_tcpp_class_flag tcpp_class MemberSet then + output_h + "\t\t::hx::Val __SetField(const ::String &inString,const ::hx::Val &inValue, ::hx::PropertyAccess inCallProp);\n"; + if has_tcpp_class_flag tcpp_class StaticSet then + output_h + "\t\tstatic bool __SetStatic(const ::String &inString, Dynamic &ioValue, ::hx::PropertyAccess inCallProp);\n"; + if has_tcpp_class_flag tcpp_class GetFields then + output_h + "\t\tvoid __GetFields(Array< ::String> &outFields);\n"; + if has_tcpp_class_flag tcpp_class Compare then + output_h + ("\t\tint __Compare(const ::hx::Object *inRHS) const { " + ^ "return const_cast<" ^ class_name + ^ " *>(this)->__compare(Dynamic((::hx::Object *)inRHS)); }\n"); + + output_h "\t\tstatic void __register();\n"; + if tcpp_class.tcl_container = Some Current then ( + output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; + output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\n"); + + if List.length tcpp_class.tcl_native_interfaces > 0 then ( + output_h "\n\t\tHX_NATIVE_IMPLEMENTATION\n"; + + tcpp_class.tcl_native_interfaces + |> CppGen.needed_interface_functions tcpp_class.tcl_functions + |> List.iter (fun func -> + let retVal = type_to_string func.iff_return in + let ret = if retVal = "void" then "" else "return " in + let argNames = List.map (fun (name, _, _) -> name) func.iff_args in output_h - "\t\tstatic bool __SetStatic(const ::String &inString, Dynamic \ - &ioValue, ::hx::PropertyAccess inCallProp);\n"; - if has_get_fields class_def then - output_h "\t\tvoid __GetFields(Array< ::String> &outFields);\n"; - - if has_compare_field class_def then + ("\t\t" ^ retVal ^ " " ^ func.iff_name ^ "( " ^ print_tfun_arg_list true func.iff_args ^ ") {\n"); output_h - ("\t\tint __Compare(const ::hx::Object *inRHS) const { " - ^ "return const_cast<" ^ class_name - ^ " *>(this)->__compare(Dynamic((::hx::Object *)inRHS)); }\n"); - - output_h "\t\tstatic void __register();\n"; - let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in - let needs_gc_funcs = (not native_gen) && has_new_gc_references class_def in - if needs_gc_funcs then ( - output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; - output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\n"); - - let haxe_implementations, native_implementations = - CppGen.implementations class_def - in - let implements_haxe = Hashtbl.length haxe_implementations > 0 in - let implements_native = Hashtbl.length native_implementations > 0 in + ("\t\t\t" ^ ret ^ "super::" ^ func.iff_name ^ "( " ^ String.concat "," argNames ^ ");\n\t\t}\n")); - if implements_native then ( - let implemented_instance_fields = - List.filter should_implement_field class_def.cl_ordered_fields - in - let neededInterfaceFunctions = - match implements_native with - | true -> - CppGen.needed_interface_functions implemented_instance_fields - native_implementations - | false -> [] - in + output_h "\n"); - output_h "\n\t\tHX_NATIVE_IMPLEMENTATION\n"; - List.iter - (fun field -> - match (follow field.cf_type, field.cf_kind) with - | _, Method MethDynamic -> () - | TFun (args, return_type), _ -> - let retVal = type_to_string return_type in - let ret = if retVal = "void" then "" else "return " in - let name = keyword_remap field.cf_name in - let argNames = - List.map (fun (name, _, _) -> keyword_remap name) args - in - output_h - ("\t\t" ^ retVal ^ " " ^ name ^ "( " - ^ print_tfun_arg_list true args - ^ ") {\n"); - output_h - ("\t\t\t" ^ ret ^ "super::" ^ name ^ "( " - ^ String.concat "," argNames ^ ");\n\t\t}\n") - | _ -> ()) - neededInterfaceFunctions; - output_h "\n"); - - output_h "\t\tbool _hx_isInstanceOf(int inClassId);\n"; - if implements_haxe then ( - output_h "\t\tvoid *_hx_getInterface(int inHash);\n"; - (* generate header glue *) - let alreadyGlued = Hashtbl.create 0 in - Hashtbl.iter - (fun interface_name src -> - let rec check_interface interface = - let check_field field = - match (follow field.cf_type, field.cf_kind) with - | _, Method MethDynamic -> () - | TFun (args, return_type), Method _ -> - let cast = cpp_tfun_signature false args return_type in - let class_implementation = - find_class_implementation class_def field.cf_name interface - in - let realName = cpp_member_name_of field in - let castKey = realName ^ "::" ^ cast in - let castKey = - if interface_name = "_hx_haxe_IMap" && realName = "set" then - castKey ^ "*" - else castKey - in - let implementationKey = - realName ^ "::" ^ class_implementation - in - if castKey <> implementationKey then - let glue = - Printf.sprintf "%s_%08lx" field.cf_name - (gen_hash32 0 cast) - in - if not (Hashtbl.mem alreadyGlued castKey) then ( - Hashtbl.replace alreadyGlued castKey (); - let argList = print_tfun_arg_list true args in - let returnType = type_to_string return_type in - let headerCode = - "\t\t" ^ returnType ^ " " ^ glue ^ "(" ^ argList - ^ ");\n" - in - output_h headerCode; - output_h "\n") - | _ -> () + output_h "\t\tbool _hx_isInstanceOf(int inClassId);\n"; + if List.length tcpp_class.tcl_haxe_interfaces > 0 then ( + output_h "\t\tvoid *_hx_getInterface(int inHash);\n"; + (* generate header glue *) + let alreadyGlued = Hashtbl.create 0 in + List.iter + (fun src -> + let rec check_interface (interface:tcpp_interface) = + let check_field func = + let cast = cpp_tfun_signature false func.iff_args func.iff_return in + let class_implementation = find_class_implementation func tcpp_class in - (match interface.cl_super with - | Some (super, _) -> check_interface super - | _ -> ()); - List.iter check_field interface.cl_ordered_fields + let realName = cpp_member_name_of func.iff_field in + let castKey = realName ^ "::" ^ cast in + let castKey = match interface.if_class.cl_path with + | ([ "haxe" ], "IMap") when realName = "set" -> + castKey ^ "*" + | _ -> + castKey + in + let implementationKey = + realName ^ "::" ^ class_implementation + in + if castKey <> implementationKey then + let glue = Printf.sprintf "%s_%08lx" func.iff_field.cf_name (gen_hash32 0 cast) in + if not (Hashtbl.mem alreadyGlued castKey) then ( + Hashtbl.replace alreadyGlued castKey (); + let argList = print_tfun_arg_list true func.iff_args in + let returnType = type_to_string func.iff_return in + let headerCode = "\t\t" ^ returnType ^ " " ^ glue ^ "(" ^ argList ^ ");\n" in + output_h headerCode; + output_h "\n") in - check_interface src) - haxe_implementations); + (match interface.if_extends with + | Some super -> check_interface super + | _ -> ()); + List.iter check_field interface.if_functions + in + check_interface src) + tcpp_class.tcl_haxe_interfaces); - if has_init_field class_def then output_h "\t\tstatic void __init__();\n\n"; - output_h - ("\t\t::String __ToString() const { return " ^ strq smart_class_name - ^ "; }\n\n")) - else if not nativeGen then output_h "\t\tHX_DO_INTERFACE_RTTI;\n\n" - else ( - CppGen.generate_native_constructor ctx output_h class_def true; - (* native interface *) ()); + if Option.is_some tcpp_class.tcl_init then output_h "\t\tstatic void __init__();\n\n"; + output_h + ("\t\t::String __ToString() const { return " ^ strq smart_class_name ^ "; }\n\n"); - if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; + if has_tcpp_class_flag tcpp_class Boot then output_h "\t\tstatic void __boot();\n"; - (match class_def.cl_array_access with - | Some t -> output_h ("\t\ttypedef " ^ type_string t ^ " __array_access;\n") - | _ -> ()); + tcpp_class.tcl_static_functions + |> List.iter (gen_member_function ctx class_def true); - List.iter - (gen_member_def ctx class_def true (has_class_flag class_def CInterface)) - (List.filter should_implement_field class_def.cl_ordered_statics); + tcpp_class.tcl_static_dynamic_functions + |> List.iter (gen_dynamic_function ctx class_def true); - let not_toString (field, args, _) = - field.cf_name <> "toString" || has_class_flag class_def CInterface - in - let functions = List.filter not_toString (all_virtual_functions class_def) in - if has_class_flag class_def CInterface then - List.iter - (fun (field, _, _) -> gen_member_def ctx class_def false true field) - functions - else - List.iter - (gen_member_def ctx class_def false false) - (List.filter should_implement_field class_def.cl_ordered_fields); - - (if has_class_flag class_def CInterface then - match get_meta_string class_def.cl_meta Meta.ObjcProtocol with - | Some protocol -> - output_h - ("\t\tstatic id<" ^ protocol - ^ "> _hx_toProtocol(Dynamic inImplementation);\n") - | None -> ()); + tcpp_class.tcl_static_variables + |> List.iter (gen_member_variable ctx class_def true); + + tcpp_class.tcl_functions + |> List.iter (gen_member_function ctx class_def false); + + tcpp_class.tcl_dynamic_functions + |> List.iter (gen_dynamic_function ctx class_def false); + + tcpp_class.tcl_variables + |> List.iter (fun field -> gen_member_variable ctx class_def false field); output_h (get_class_code class_def Meta.HeaderClassCode); output_h "};\n\n"; diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 845579e2781..36c57094114 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -10,297 +10,288 @@ open CppSourceWriter open CppContext open CppGen -let gen_field ctx class_def class_name is_static field = - ctx.ctx_real_this_ptr <- not is_static; - - let output = ctx.ctx_output in - let remap_name = keyword_remap field.cf_name in - let decl = get_meta_string field.cf_meta Meta.Decl in - let has_decl = match decl with Some _ -> true | None -> false in - match field.cf_expr with - (* Function field *) - | Some { eexpr = TFunction function_def } -> - let return_type_str = type_to_string function_def.tf_type in - let nargs = string_of_int (List.length function_def.tf_args) in - let return_type = cpp_type_of function_def.tf_type in - let is_void = return_type = TCppVoid in - let ret = if is_void then "(void)" else "return " in - - let needsWrapper t = - match t with - | TCppStar _ -> true - | TCppInst (t, _) -> Meta.has Meta.StructAccess t.cl_meta - | _ -> false - in - let orig_debug = ctx.ctx_debug_level in - let no_debug = Meta.has Meta.NoDebug field.cf_meta in - - if not (is_dynamic_haxe_method field) then ( - (* The actual function definition *) - let remap_name = native_field_name_remap is_static field in - output (if is_void then "void" else return_type_str); - output (" " ^ class_name ^ "::" ^ remap_name ^ "("); - output (print_arg_list function_def.tf_args "__o_"); - output ")"; - ctx.ctx_real_this_ptr <- true; - let code = get_code field.cf_meta Meta.FunctionCode in - let tail_code = get_code field.cf_meta Meta.FunctionTailCode in - - match get_meta_string field.cf_meta Meta.Native with - | Some nativeImpl when is_static -> - output " {\n"; - output - ("\t" ^ ret ^ "::" ^ nativeImpl ^ "(" - ^ print_arg_list_name function_def.tf_args "__o_" - ^ ");\n"); - output "}\n\n" - | _ -> - gen_cpp_function_body ctx class_def is_static field.cf_name - function_def code tail_code no_debug; - - output "\n\n"; - let nonVirtual = Meta.has Meta.NonVirtual field.cf_meta in - let doDynamic = - (nonVirtual || not (is_override field)) - && reflective class_def field - in - (* generate dynamic version too ... *) - if doDynamic then - let tcpp_args = - List.map - (fun (v, _) -> cpp_type_of v.v_type) - function_def.tf_args - in - let wrap = - needsWrapper return_type || List.exists needsWrapper tcpp_args - in - if wrap then ( - let wrapName = "_hx_wrap" ^ class_name ^ "_" ^ remap_name in - output ("static ::Dynamic " ^ wrapName ^ "( "); - let sep = ref " " in - if not is_static then ( - output "::hx::Object *obj"; - sep := ","); - ExtList.List.iteri - (fun i _ -> - output (!sep ^ "const Dynamic &a" ^ string_of_int i); - sep := ",") - tcpp_args; - output ") {\n\t"; - (if not is_void then - match return_type with - | TCppStar _ -> output "return (cpp::Pointer) " - | TCppInst (t, _) when Meta.has Meta.StructAccess t.cl_meta - -> - output - ("return (cpp::Struct< " ^ tcpp_to_string return_type - ^ " >) ") - | _ -> output "return "); - - if is_static then output (class_name ^ "::" ^ remap_name ^ "(") - else - output - ("reinterpret_cast< " ^ class_name ^ " *>(obj)->" - ^ remap_name ^ "("); - - sep := ""; - ExtList.List.iteri - (fun i arg -> - output !sep; - sep := ","; - (match arg with - | TCppStar (t, const) -> - output - ("(cpp::" - ^ (if const then "Const" else "") - ^ "Pointer<" ^ tcpp_to_string t ^ " >) ") - | TCppInst (t, _) when Meta.has Meta.StructAccess t.cl_meta - -> - output ("(cpp::Struct< " ^ tcpp_to_string arg ^ " >) ") - | _ -> ()); - output ("a" ^ string_of_int i)) - tcpp_args; - - output ");\n"; - - if is_void then output "\treturn null();\n"; - output "}\n"; - let nName = string_of_int (List.length tcpp_args) in - output - ("::Dynamic " ^ class_name ^ "::" ^ remap_name - ^ "_dyn() {\n\treturn "); - if is_static then - output - ("::hx::CreateStaticFunction" ^ nName ^ "(\"" ^ remap_name - ^ "\"," ^ wrapName ^ ");") - else - output - ("::hx::CreateMemberFunction" ^ nName ^ "(\"" ^ remap_name - ^ "\",this," ^ wrapName ^ ");"); - output "}\n") - else ( - if is_static then output "STATIC_"; - output - ("HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," - ^ remap_name ^ "," ^ ret ^ ")\n\n"))) - else ( - ctx.ctx_real_this_ptr <- false; - let func_name = "__default_" ^ remap_name in - output ("HX_BEGIN_DEFAULT_FUNC(" ^ func_name ^ "," ^ class_name ^ ")\n"); - output return_type_str; - output - (" _hx_run(" ^ print_arg_list function_def.tf_args "__o_" ^ ")"); - gen_cpp_function_body ctx class_def is_static func_name function_def "" - "" no_debug; +let gen_function ctx class_def class_name is_static func = + let output = ctx.ctx_output in + let return_type_str = type_to_string func.tcf_func.tf_type in + let return_type = cpp_type_of func.tcf_func.tf_type in + let is_void = return_type = TCppVoid in + let ret = if is_void then "(void)" else "return " in + let needsWrapper t = + match t with + | TCppStar _ -> true + | TCppInst (t, _) -> Meta.has Meta.StructAccess t.cl_meta + | _ -> false + in - output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); - output "HX_END_DEFAULT_FUNC\n\n"; + (* The actual function definition *) + output (if is_void then "void" else return_type_str); + output (" " ^ class_name ^ "::" ^ func.tcf_name ^ "("); + output (print_arg_list func.tcf_func.tf_args "__o_"); + output ")"; + ctx.ctx_real_this_ptr <- true; + let code = get_code func.tcf_field.cf_meta Meta.FunctionCode in + let tail_code = get_code func.tcf_field.cf_meta Meta.FunctionTailCode in + + match get_meta_string func.tcf_field.cf_meta Meta.Native with + | Some nativeImpl when is_static -> + output " {\n"; + output + ("\t" ^ ret ^ "::" ^ nativeImpl ^ "(" + ^ print_arg_list_name func.tcf_func.tf_args "__o_" + ^ ");\n"); + output "}\n\n" + | _ -> + with_debug + ctx + func.tcf_field.cf_meta + (gen_cpp_function_body ctx class_def is_static func.tcf_field.cf_name func.tcf_func code tail_code); + + output "\n\n"; + + (* generate dynamic version too ... *) + if (not func.tcf_is_virtual || not func.tcf_is_overriding) && func.tcf_is_reflective then + let tcpp_args = List.map (fun (v, _) -> cpp_type_of v.v_type) func.tcf_func.tf_args in + let wrap = needsWrapper return_type || List.exists needsWrapper tcpp_args in + + if wrap then ( + let wrapName = "_hx_wrap" ^ class_name ^ "_" ^ func.tcf_name in + output ("static ::Dynamic " ^ wrapName ^ "( "); + + let initial = if is_static then [] else [ "::hx::Object *obj" ] in + + initial @ (List.init (List.length tcpp_args) (fun idx -> Printf.sprintf "const ::Dynamic &a%i" idx)) + |> String.concat "," + |> output; + + output ") {\n\t"; + (if not is_void then + match return_type with + | TCppStar _ -> output "return (cpp::Pointer) " + | TCppInst (t, _) when Meta.has Meta.StructAccess t.cl_meta + -> + output ("return (cpp::Struct< " ^ tcpp_to_string return_type ^ " >) ") + | _ -> output "return "); if is_static then - output ("::Dynamic " ^ class_name ^ "::" ^ remap_name ^ ";\n\n")); - ctx.ctx_debug_level <- orig_debug - (* Data field *) - | _ when has_decl -> - if is_static then ( - output (class_name ^ "::" ^ remap_name ^ "_decl "); - output (" " ^ class_name ^ "::" ^ remap_name ^ ";\n\n")) - | _ -> - if is_static && is_physical_field field then ( - gen_type ctx field.cf_type; - output (" " ^ class_name ^ "::" ^ remap_name ^ ";\n\n")) - else if has_class_field_flag field CfAbstract then - let tl, tr = - match follow field.cf_type with - | TFun (tl, tr) -> (tl, tr) - | _ -> die "" __LOC__ - in - let nargs = string_of_int (List.length tl) in - let return_type = cpp_type_of tr in - let is_void = return_type = TCppVoid in - let ret = if is_void then "(void)" else "return " in + output (class_name ^ "::" ^ func.tcf_name ^ "(") + else + output ("reinterpret_cast< " ^ class_name ^ " *>(obj)->" ^ func.tcf_name ^ "("); + + let cast_prefix idx arg = + match arg with + | TCppStar (t, const) -> + Printf.sprintf "(::cpp::%sPointer< %s >) a%i" (if const then "Const" else "") (tcpp_to_string t) idx + | TCppInst (t, _) when Meta.has Meta.StructAccess t.cl_meta -> + Printf.sprintf "(::cpp::Struct< %s >) a%i" (tcpp_to_string arg) idx + | _ -> + Printf.sprintf "a%i" idx in + + tcpp_args + |> ExtList.List.mapi cast_prefix + |> String.concat ", " + |> output; + + output ");\n"; + + if is_void then output "\treturn null();\n"; + output "}\n"; + let nName = string_of_int (List.length tcpp_args) in output - ("HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," - ^ remap_name ^ "," ^ ret ^ ")\n\n") + ("::Dynamic " ^ class_name ^ "::" ^ func.tcf_name ^ "_dyn() {\n\treturn "); + if is_static then + output + ("::hx::CreateStaticFunction" ^ nName ^ "(\"" ^ func.tcf_name ^ "\"," ^ wrapName ^ ");") + else + output + ("::hx::CreateMemberFunction" ^ nName ^ "(\"" ^ func.tcf_name ^ "\",this," ^ wrapName ^ ");"); + output "}\n") + else + let prefix = if is_static then "STATIC_" else "" in + Printf.sprintf "%sHX_DEFINE_DYNAMIC_FUNC%i(%s, %s, %s)\n\n" prefix (List.length func.tcf_func.tf_args) class_name func.tcf_name ret |> output + +let gen_dynamic_function ctx class_def class_name is_static is_for_static_var (func:tcpp_class_function) = + let output = ctx.ctx_output in + let func_name = "__default_" ^ func.tcf_name in + let nargs = string_of_int (List.length func.tcf_func.tf_args) in + let return_type_str = type_to_string func.tcf_func.tf_type in + let return_type = cpp_type_of func.tcf_func.tf_type in + let no_debug = Meta.has Meta.NoDebug func.tcf_field.cf_meta in + let is_void = return_type = TCppVoid in + let ret = if is_void then "(void)" else "return " in -let gen_field_init ctx class_def field = - let dot_name = join_class_path class_def.cl_path "." in + ctx.ctx_real_this_ptr <- false; + Printf.sprintf "HX_BEGIN_DEFAULT_FUNC(%s, %s)\n" func_name class_name |> output; + Printf.sprintf "%s _hx_run(%s)" return_type_str (print_arg_list func.tcf_func.tf_args "__o_") |> output; + + gen_cpp_function_body ctx class_def is_static func_name func.tcf_func "" "" no_debug; + + output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); + output "HX_END_DEFAULT_FUNC\n\n" + +let gen_static_variable ctx class_def class_name (var:tcpp_class_variable) = let output = ctx.ctx_output in - let remap_name = keyword_remap field.cf_name in + Printf.sprintf "%s %s::%s;\n\n" (type_to_string var.tcv_type) class_name var.tcv_name |> output - match field.cf_expr with - (* Function field *) +let gen_dynamic_function_init ctx class_def func = + match func.tcf_field.cf_expr with | Some { eexpr = TFunction function_def } -> - if is_dynamic_haxe_method field then - let func_name = "__default_" ^ remap_name in - output ("\t" ^ remap_name ^ " = new " ^ func_name ^ ";\n\n") - (* Data field *) + Printf.sprintf "\t%s = new %s;\n\n" func.tcf_name ("__default_" ^ func.tcf_name) |> ctx.ctx_output + | _ -> + () + +let gen_var_init ctx class_def var = + match var.tcv_field.cf_expr with | Some expr -> - let var_name = - match remap_name with - | "__meta__" -> "__mClass->__meta__" - | "__rtti" -> "__mClass->__rtti__" - | _ -> remap_name + gen_cpp_init ctx (join_class_path class_def.cl_path ".") "boot" (var.tcv_name ^ " = ") expr + | _ -> () + +let gen_boot_field ctx output_cpp tcpp_class = + if has_tcpp_class_flag tcpp_class Boot then ( + output_cpp ("void " ^ tcpp_class.tcl_name ^ "::__boot()\n{\n"); + + let dot_name = join_class_path tcpp_class.tcl_class.cl_path "." in + + (match tcpp_class.tcl_meta with + | Some expr -> gen_cpp_init ctx dot_name "boot" "__mClass->__meta__ = " expr + | None -> ()); + + (match tcpp_class.tcl_rtti with + | Some expr -> gen_cpp_init ctx dot_name "boot" "__mClass->__rtti__ = " expr + | None -> ()); + + List.iter (gen_var_init ctx tcpp_class.tcl_class) tcpp_class.tcl_static_variables; + List.iter (gen_dynamic_function_init ctx tcpp_class.tcl_class) tcpp_class.tcl_static_dynamic_functions; + + output_cpp "}\n\n") + +let gen_init_function ctx output_cpp tcpp_class = + match tcpp_class.tcl_init with + | Some expression -> + output_cpp ("void " ^ tcpp_class.tcl_name ^ "::__init__()"); + gen_cpp_init ctx (cpp_class_name tcpp_class.tcl_class) "__init__" "" (mk_block expression); + output_cpp "\n\n" + | None -> + () + +let gen_dynamic_function_allocator ctx output_cpp tcpp_class = + match tcpp_class.tcl_dynamic_functions with + | [] -> () + | functions -> + let mapper func = + Printf.sprintf "\tif (!_hx_obj->%s.mPtr) { _hx_obj->%s = new __default_%s(_hx_obj); }" func.tcf_name func.tcf_name func.tcf_name in + let rec folder acc class_def = + if has_dynamic_member_functions class_def then + let super_name = join_class_path_remap class_def.cl_path "::" ^ "_obj" in + + Printf.sprintf "\t%s::__alloc_dynamic_functions(_hx_ctx, _hx_obj);" super_name :: acc + else + match class_def.cl_super with + | Some (super, _) -> folder acc super + | _ -> acc in - gen_cpp_init ctx dot_name "boot" (var_name ^ " = ") expr - | _ -> () + let initial = functions |> List.map mapper in + let allocs = match tcpp_class.tcl_class.cl_super with + | Some (super, _) -> + folder initial super + | _ -> + initial in -let cpp_get_interface_slot ctx name = - try Hashtbl.find !(ctx.ctx_interface_slot) name - with Not_found -> - let result = !(ctx.ctx_interface_slot_count) in - Hashtbl.replace !(ctx.ctx_interface_slot) name result; - ctx.ctx_interface_slot_count := !(ctx.ctx_interface_slot_count) + 1; - result - -let generate_protocol_delegate ctx class_def output = - let protocol = - get_meta_string class_def.cl_meta Meta.ObjcProtocol |> Option.default "" - in - let full_class_name = - ("::" ^ join_class_path_remap class_def.cl_path "::") ^ "_obj" + let str = allocs |> List.rev |> String.concat "\n" in + + Printf.sprintf "void %s::__alloc_dynamic_functions(::hx::Ctx* _hx_ctx, %s* _hx_obj) {\n%s\n}\n" tcpp_class.tcl_name tcpp_class.tcl_name str |> output_cpp + +let print_reflective_fields ctx_common class_def variables functions = + let filter_vars var acc = + if var.tcv_is_reflective then + Printf.sprintf "\t%s" (strq ctx_common var.tcv_field.cf_name) :: acc + else + acc in + let filter_funcs func acc = + if func.tcf_is_reflective then + Printf.sprintf "\t%s" (strq ctx_common func.tcf_field.cf_name) :: acc + else + acc in + + let calls = + [ "\t::String(null())" ] + |> List.fold_right filter_vars variables + |> List.fold_right filter_funcs functions in - let name = "_hx_" ^ protocol ^ "_delegate" in - output ("@interface " ^ name ^ " : NSObject<" ^ protocol ^ "> {\n"); - output "\t::hx::Object *haxeObj;\n"; - output "}\n"; - output "@end\n\n"; - output ("@implementation " ^ name ^ "\n"); - output "- (id)initWithImplementation:( ::hx::Object *)inInplemnetation {\n"; - output " if (self = [super init]) {\n"; - output " self->haxeObj = inInplemnetation;\n"; - output " GCAddRoot(&self->haxeObj);\n"; - output " }\n"; - output " return self;\n"; - output "}\n"; - output "- (void)dealloc {\n"; - output " GCRemoveRoot(&self->haxeObj);\n"; - output " #ifndef OBJC_ARC\n"; - output " [super dealloc];\n"; - output " #endif\n"; - output "}\n\n"; - - let dump_delegate field = - match field.cf_type with - | TFun (args, ret) -> - let retStr = type_to_string ret in - let fieldName, argNames = - match get_meta_string field.cf_meta Meta.ObjcProtocol with - | Some nativeName -> - let parts = ExtString.String.nsplit nativeName ":" in - (List.hd parts, parts) - | None -> (field.cf_name, List.map (fun (n, _, _) -> n) args) - in - output ("- (" ^ retStr ^ ") " ^ fieldName); - - let first = ref true in - (try - List.iter2 - (fun (name, _, argType) signature_name -> - if !first then - output (" :(" ^ type_to_string argType ^ ")" ^ name) - else - output - (" " ^ signature_name ^ ":(" ^ type_to_string argType ^ ")" - ^ name); - first := false) - args argNames - with Invalid_argument _ -> - abort - (let argString = - String.concat "," (List.map (fun (name, _, _) -> name) args) - in - "Invalid arg count in delegate in " ^ field.cf_name ^ " '" - ^ field.cf_name ^ "," ^ argString ^ "' != '" - ^ String.concat "," argNames ^ "'") - field.cf_pos); - output " {\n"; - output "\t::hx::NativeAttach _hx_attach;\n"; - output - ((if retStr = "void" then "\t" else "\treturn ") - ^ full_class_name ^ "::" - ^ keyword_remap field.cf_name - ^ "(haxeObj"); - List.iter (fun (name, _, _) -> output ("," ^ name)) args; - output ");\n}\n\n" - | _ -> () + + if List.length calls > 1 then + Some (String.concat ",\n" calls) + else + None + +let cpp_interface_impl_name cls = + "_hx_" ^ join_class_path cls.cl_path "_" + +let generate_native_class base_ctx tcpp_class = + let class_def = tcpp_class.tcl_class in + let class_path = class_def.cl_path in + let debug = tcpp_class.tcl_debug_level in + let cpp_file = new_placed_cpp_file base_ctx.ctx_common class_path in + let cpp_ctx = file_context base_ctx cpp_file debug false in + let ctx = cpp_ctx in + let output_cpp = cpp_file#write in + let scriptable = has_tcpp_class_flag tcpp_class Scriptable in + + cpp_file#write_h "#include \n\n"; + + let all_referenced = + CppReferences.find_referenced_types ctx (TClassDecl class_def) ctx.ctx_super_deps + ctx.ctx_constructor_deps false false scriptable in - List.iter dump_delegate class_def.cl_ordered_fields; + List.iter (add_include cpp_file) all_referenced; + + if scriptable then cpp_file#write_h "#include \n"; + + cpp_file#write_h "\n"; + + output_cpp (get_class_code class_def Meta.CppFileCode); + let includes = get_all_meta_string_path class_def.cl_meta Meta.CppInclude in + let printer inc = output_cpp ("#include \"" ^ inc ^ "\"\n") in + List.iter printer includes; + + begin_namespace output_cpp class_path; + output_cpp "\n"; + + output_cpp (get_class_code class_def Meta.CppNamespaceCode); + + let class_name = tcpp_class.tcl_name in + + gen_init_function ctx output_cpp tcpp_class; - output "@end\n\n" + List.iter (gen_function ctx class_def class_name false) tcpp_class.tcl_functions; + List.iter (gen_dynamic_function ctx class_def class_name false false) tcpp_class.tcl_dynamic_functions; -let generate baseCtx class_def = - let common_ctx = baseCtx.ctx_common in + List.iter (gen_function ctx class_def class_name true) tcpp_class.tcl_static_functions; + List.iter (gen_dynamic_function ctx class_def class_name true false) tcpp_class.tcl_static_dynamic_functions; + List.iter (gen_static_variable ctx class_def class_name) tcpp_class.tcl_static_variables; + + output_cpp "\n"; + + gen_dynamic_function_allocator ctx output_cpp tcpp_class; + + generate_native_constructor ctx output_cpp class_def false; + gen_boot_field ctx output_cpp tcpp_class; + + end_namespace output_cpp class_path; + + cpp_file#close + +let generate_managed_class base_ctx tcpp_class = + let common_ctx = base_ctx.ctx_common in + let class_def = tcpp_class.tcl_class in let class_path = class_def.cl_path in - let debug = baseCtx.ctx_debug_level in - let cpp_file = new_placed_cpp_file baseCtx.ctx_common class_path in - let cpp_ctx = file_context baseCtx cpp_file debug false in + let debug = tcpp_class.tcl_debug_level in + let cpp_file = new_placed_cpp_file base_ctx.ctx_common class_path in + let cpp_ctx = file_context base_ctx cpp_file debug false in let ctx = cpp_ctx in let output_cpp = cpp_file#write in let strq = strq ctx.ctx_common in - let scriptable = - Gctx.defined common_ctx Define.Scriptable && not class_def.cl_private - in + let scriptable = has_tcpp_class_flag tcpp_class Scriptable in let class_super_name = match class_def.cl_super with @@ -308,17 +299,12 @@ let generate baseCtx class_def = tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) | _ -> "" in - if debug > 1 then - print_endline - ("Found class definition:" ^ join_class_path class_def.cl_path "::"); cpp_file#write_h "#include \n\n"; - let constructor_deps = create_constructor_dependencies common_ctx in - let super_deps = create_super_dependencies common_ctx in let all_referenced = - CppReferences.find_referenced_types ctx (TClassDecl class_def) super_deps - constructor_deps false false scriptable + CppReferences.find_referenced_types ctx (TClassDecl class_def) ctx.ctx_super_deps + ctx.ctx_constructor_deps false false scriptable in List.iter (add_include cpp_file) all_referenced; @@ -336,664 +322,523 @@ let generate baseCtx class_def = output_cpp (get_class_code class_def Meta.CppNamespaceCode); - let nativeGen = Meta.has Meta.NativeGen class_def.cl_meta in - let class_name = class_name class_def in + let class_name = tcpp_class.tcl_name in let cargs = constructor_arg_var_list class_def in - let constructor_type_var_list = List.map snd cargs in - let constructor_var_list = List.map snd constructor_type_var_list in + let constructor_var_list = List.map snd cargs in let constructor_type_args = - String.concat "," - (List.map (fun (t, a) -> t ^ " " ^ a) constructor_type_var_list) + cargs + |> List.map (fun (t, a) -> Printf.sprintf "%s %s" t a) + |> String.concat "," in + + output_cpp + ("void " ^ class_name ^ "::__construct(" ^ constructor_type_args ^ ")"); + (match class_def.cl_constructor with + | Some ({ cf_expr = Some { eexpr = TFunction function_def } } as definition) + -> + with_debug ctx definition.cf_meta (fun no_debug -> + gen_cpp_function_body ctx class_def false "new" function_def "" "" + no_debug; + output_cpp "\n") + | _ -> output_cpp " { }\n\n"); + + (* Destructor goes in the cpp file so we can "see" the full definition of the member vars *) + if not (has_class_flag class_def CAbstract) then ( + let ptr_name = class_pointer class_def in + let array_arg_list inList = + List.init (List.length inList) (fun idx -> Printf.sprintf "inArgs[%i]" idx) |> String.concat "," + in + + Printf.sprintf "::Dynamic %s::__CreateEmpty() { return new %s; }\n\n" class_name class_name |> output_cpp; + + Printf.sprintf "void* %s::_hx_vtable = 0;\n\n" class_name |> output_cpp; + + Printf.sprintf "::Dynamic %s::__Create(::hx::DynamicArray inArgs)\n" class_name |> output_cpp; + Printf.sprintf "{\n\t%s _hx_result = new %s();\n" ptr_name class_name |> output_cpp; + Printf.sprintf "\t_hx_result->__construct(%s);\n" (array_arg_list constructor_var_list) |> output_cpp; + output_cpp "\treturn _hx_result;\n}\n\n"); + + output_cpp ("bool " ^ class_name ^ "::_hx_isInstanceOf(int inClassId) {\n"); + let rec parent_id_folder acc cur = + match cur.tcl_super with + | Some s -> parent_id_folder (cur.tcl_id :: acc) s + | None -> cur.tcl_id :: acc in - let haxe_implementations, native_implementations = - implementations class_def + let implemented_classes = + tcpp_class + |> parent_id_folder [ Int32.of_int 1 ] + |> List.sort compare in + let txt cId = Printf.sprintf "0x%08lx" cId in + let rec dump_classes indent classes = + match classes with + | [] -> () + | [ c ] -> output_cpp (indent ^ "return inClassId==(int)" ^ txt c ^ ";\n") + | [ c; c1 ] -> + output_cpp + (indent ^ "return inClassId==(int)" ^ txt c ^ " || inClassId==(int)" ^ txt c1 ^ ";\n") + | _ -> + let len = List.length classes in + let mid = List.nth classes (len / 2) in + let low, high = List.partition (fun e -> e <= mid) classes in + output_cpp (indent ^ "if (inClassId<=(int)" ^ txt mid ^ ") {\n"); + dump_classes (indent ^ "\t") low; + output_cpp (indent ^ "} else {\n"); + dump_classes (indent ^ "\t") high; + output_cpp (indent ^ "}\n") + in + dump_classes "\t" implemented_classes; + output_cpp "}\n\n"; + + if List.length tcpp_class.tcl_haxe_interfaces > 0 then ( + let cname = cpp_interface_impl_name class_def in + let impl_name = cpp_class_name class_def in + + let fold_interface (glued, acc) interface = + + let rec gen_interface_funcs interface = + + let fold_field (glued, acc) func = + let cast = cpp_tfun_signature false func.iff_args func.iff_return in + let real_name = cpp_member_name_of func.iff_field in + + (* C++ can't work out which function it needs to take the addrss of + when the implementation is overloaded - currently the map-set functions. + Change the castKey to force a glue function in this case (could double-cast the pointer, but it is ugly) + *) + let suffix = + match interface.if_class.cl_path with + | (["haxe"], "IMap") when real_name = "set" -> "*" + | _ -> "" in + let cast_key = Printf.sprintf "%s::%s%s" real_name cast suffix in + let implementation_key = Printf.sprintf "%s::%s" real_name (find_class_implementation func tcpp_class) in + + if cast_key = implementation_key then + (glued, Printf.sprintf "\t%s&%s::%s" cast impl_name real_name :: acc) + else + let glue = Printf.sprintf "%s_%08lx" func.iff_field.cf_name (gen_hash32 0 cast) in + let glued = + if StringMap.mem cast_key glued then + glued + else + let arg_list = print_tfun_arg_list true func.iff_args in + let return_type = type_to_string func.iff_return in + let return_str = if return_type = "void" then "" else "return " in + let cpp_code = + Printf.sprintf + "%s %s::%s(%s) { %s%s(%s); }\n" + return_type + class_name + glue + arg_list + return_str + real_name + (print_arg_names func.iff_args) in + StringMap.add cast_key cpp_code glued + in + (glued, Printf.sprintf "\t%s&%s::%s" cast impl_name glue :: acc) + in - if (not (has_class_flag class_def CInterface)) && not nativeGen then ( - output_cpp - ("void " ^ class_name ^ "::__construct(" ^ constructor_type_args ^ ")"); - (match class_def.cl_constructor with - | Some ({ cf_expr = Some { eexpr = TFunction function_def } } as definition) - -> - with_debug ctx definition.cf_meta (fun no_debug -> - gen_cpp_function_body ctx class_def false "new" function_def "" "" - no_debug; - output_cpp "\n") - | _ -> output_cpp " { }\n\n"); - - (* Destructor goes in the cpp file so we can "see" the full definition of the member vars *) - if not (has_class_flag class_def CAbstract) then ( - let ptr_name = class_pointer class_def in - let array_arg_list inList = - (* Convert an array to a comma separated list of values *) - let i = ref (0 - 1) in - String.concat "," - (List.map - (fun _ -> - incr i; - "inArgs[" ^ string_of_int !i ^ "]") - inList) + let initial = + match interface.if_extends with + | Some super -> gen_interface_funcs super + | _ -> (glued, []) + in + List.fold_left fold_field initial interface.if_functions in - output_cpp - ("Dynamic " ^ class_name ^ "::__CreateEmpty() { return new " - ^ class_name ^ "; }\n\n"); - output_cpp ("void *" ^ class_name ^ "::_hx_vtable = 0;\n\n"); - - output_cpp - ("Dynamic " ^ class_name ^ "::__Create(::hx::DynamicArray inArgs)\n"); - output_cpp - ("{\n\t" ^ ptr_name ^ " _hx_result = new " ^ class_name ^ "();\n"); - output_cpp - ("\t_hx_result->__construct(" - ^ array_arg_list constructor_var_list - ^ ");\n"); - output_cpp "\treturn _hx_result;\n}\n\n"); - let rec addParent cls others = - match cls.cl_super with - | Some (super, _) -> ( - try - let parentId = - Hashtbl.find ctx.ctx_type_ids (class_text super.cl_path) - in - addParent super (parentId :: others) - with Not_found -> others) - | _ -> others - in - let classId = - try Hashtbl.find baseCtx.ctx_type_ids (class_text class_def.cl_path) - with Not_found -> Int32.zero - in - let implemented_classes = addParent class_def [ classId; Int32.of_int 1 ] in - let implemented_classes = List.sort compare implemented_classes in - - output_cpp ("bool " ^ class_name ^ "::_hx_isInstanceOf(int inClassId) {\n"); - let txt cId = Printf.sprintf "0x%08lx" cId in - let rec dump_classes indent classes = - match classes with - | [] -> () - | [ c ] -> output_cpp (indent ^ "return inClassId==(int)" ^ txt c ^ ";\n") - | [ c; c1 ] -> - output_cpp - (indent ^ "return inClassId==(int)" ^ txt c ^ " || inClassId==(int)" - ^ txt c1 ^ ";\n") - | _ -> - let len = List.length classes in - let mid = List.nth classes (len / 2) in - let low, high = List.partition (fun e -> e <= mid) classes in - output_cpp (indent ^ "if (inClassId<=(int)" ^ txt mid ^ ") {\n"); - dump_classes (indent ^ "\t") low; - output_cpp (indent ^ "} else {\n"); - dump_classes (indent ^ "\t") high; - output_cpp (indent ^ "}\n") + let interface_name = cpp_interface_impl_name interface.if_class in + let glued, funcs = gen_interface_funcs interface in + let combined = funcs |> List.rev |> String.concat ",\n" in + let call = Printf.sprintf "static %s %s_%s = {\n%s\n};\n" (cpp_class_name interface.if_class) cname interface_name combined in + (glued, call :: acc) in - dump_classes "\t" implemented_classes; - output_cpp "}\n\n"; + + let glued, calls = + List.fold_left + fold_interface + (StringMap.empty, []) + tcpp_class.tcl_haxe_interfaces in - let implements_haxe_keys = hash_keys haxe_implementations in - let implements_haxe = Hashtbl.length haxe_implementations > 0 in + calls |> String.concat "\n" |> output_cpp; + glued |> StringMap.bindings |> List.map snd |> String.concat "\n" |> output_cpp; - if implements_haxe then ( - let alreadyGlued = Hashtbl.create 0 in - let cname = "_hx_" ^ join_class_path class_def.cl_path "_" in - let implname = cpp_class_name class_def in - let cpp_glue = ref [] in - List.iter - (fun interface_name -> - try - let interface = Hashtbl.find haxe_implementations interface_name in - output_cpp - ("static " ^ cpp_class_name interface ^ " " ^ cname ^ "_" - ^ interface_name ^ "= {\n"); - let rec gen_interface_funcs interface = - let gen_field field = - match (follow field.cf_type, field.cf_kind) with - | _, Method MethDynamic -> () - | TFun (args, return_type), Method _ -> - let cast = cpp_tfun_signature false args return_type in - let class_implementation = - find_class_implementation class_def field.cf_name - interface - in - let realName = cpp_member_name_of field in - let castKey = realName ^ "::" ^ cast in - (* C++ can't work out which function it needs to take the addrss of - when the implementation is overloaded - currently the map-set functions. - Change the castKey to force a glue function in this case (could double-cast the pointer, but it is ugly) - *) - let castKey = - if interface_name = "_hx_haxe_IMap" && realName = "set" - then castKey ^ "*" - else castKey - in - let implementationKey = - realName ^ "::" ^ class_implementation - in - if castKey <> implementationKey then ( - let glue = - Printf.sprintf "%s_%08lx" field.cf_name - (gen_hash32 0 cast) - in - if not (Hashtbl.mem alreadyGlued castKey) then ( - Hashtbl.replace alreadyGlued castKey (); - let argList = print_tfun_arg_list true args in - let returnType = type_to_string return_type in - let returnStr = - if returnType = "void" then "" else "return " - in - let cppCode = - returnType ^ " " ^ class_name ^ "::" ^ glue ^ "(" - ^ argList ^ ") {\n" ^ "\t\t\t" ^ returnStr ^ realName - ^ "(" ^ print_arg_names args ^ ");\n}\n" - in - (* let headerCode = "\t\t" ^ returnType ^ " " ^ glue ^ "(" ^ argList ^ ");\n" in *) - (* header_glue := headerCode :: !header_glue; *) - cpp_glue := cppCode :: !cpp_glue); - output_cpp - ("\t" ^ cast ^ "&" ^ implname ^ "::" ^ glue ^ ",\n")) - else - output_cpp - ("\t" ^ cast ^ "&" ^ implname ^ "::" ^ realName ^ ",\n") - | _ -> () - in - (match interface.cl_super with - | Some super -> gen_interface_funcs (fst super) - | _ -> ()); - List.iter gen_field interface.cl_ordered_fields - in - gen_interface_funcs interface; - output_cpp "};\n\n" - with Not_found -> ()) - implements_haxe_keys; + output_cpp ("void *" ^ class_name ^ "::_hx_getInterface(int inHash) {\n"); + output_cpp "\tswitch(inHash) {\n"; - output_cpp (String.concat "\n" !cpp_glue); + let iter interface = + output_cpp ("\t\tcase (int)" ^ interface.if_hash ^ ": return &" ^ cname ^ "_" ^ cpp_interface_impl_name interface.if_class ^ ";\n") in + List.iter + iter + tcpp_class.tcl_haxe_interfaces; + + output_cpp "\t}\n"; + + if class_super_name = "" then ( + output_cpp "\t#ifdef HXCPP_SCRIPTABLE\n"; + output_cpp "\treturn super::_hx_getInterface(inHash);\n"; + output_cpp "\t#else\n"; + output_cpp "\treturn 0;\n"; + output_cpp "\t#endif\n") + else output_cpp "\treturn super::_hx_getInterface(inHash);\n"; + output_cpp "}\n\n"); - output_cpp ("void *" ^ class_name ^ "::_hx_getInterface(int inHash) {\n"); - output_cpp "\tswitch(inHash) {\n"; - List.iter - (fun interface_name -> - try - let interface = Hashtbl.find haxe_implementations interface_name in - output_cpp - ("\t\tcase (int)" ^ cpp_class_hash interface ^ ": return &" - ^ cname ^ "_" ^ interface_name ^ ";\n") - with Not_found -> ()) - implements_haxe_keys; - - output_cpp "\t}\n"; - - if class_super_name = "" then ( - output_cpp "\t#ifdef HXCPP_SCRIPTABLE\n"; - output_cpp "\treturn super::_hx_getInterface(inHash);\n"; - output_cpp "\t#else\n"; - output_cpp "\treturn 0;\n"; - output_cpp "\t#endif\n") - else output_cpp "\treturn super::_hx_getInterface(inHash);\n"; - output_cpp "}\n\n")); - - (match TClass.get_cl_init class_def with - | Some expression -> - let ctx = file_context baseCtx cpp_file debug false in - output_cpp ("void " ^ class_name ^ "::__init__()"); - gen_cpp_init ctx (cpp_class_name class_def) "__init__" "" - (mk_block expression); - output_cpp "\n\n" - | _ -> ()); - - let dump_field_name field = output_cpp ("\t" ^ strq field.cf_name ^ ",\n") in - let statics_except_meta = statics_except_meta class_def in - let implemented_fields = - List.filter should_implement_field statics_except_meta - in + gen_init_function ctx output_cpp tcpp_class; + + List.iter (gen_function ctx class_def class_name false) tcpp_class.tcl_functions; + List.iter (gen_dynamic_function ctx class_def class_name false false) tcpp_class.tcl_dynamic_functions; + + List.iter (gen_function ctx class_def class_name true) tcpp_class.tcl_static_functions; + List.iter (gen_dynamic_function ctx class_def class_name true false) tcpp_class.tcl_static_dynamic_functions; + List.iter (gen_static_variable ctx class_def class_name) tcpp_class.tcl_static_variables; - List.iter - (gen_field ctx class_def class_name false) - class_def.cl_ordered_fields; - List.iter (gen_field ctx class_def class_name true) statics_except_meta; output_cpp "\n"; - let dynamic_functions = dynamic_functions class_def in - if List.length dynamic_functions > 0 then ( - output_cpp - ("void " ^ class_name ^ "::__alloc_dynamic_functions(::hx::Ctx *_hx_ctx," - ^ class_name ^ " *_hx_obj) {\n"); - List.iter - (fun name -> - output_cpp - ("\tif (!_hx_obj->" ^ name ^ ".mPtr) _hx_obj->" ^ name - ^ " = new __default_" ^ name ^ "(_hx_obj);\n")) - dynamic_functions; - (match class_def.cl_super with - | Some super -> - let rec find_super class_def = - if has_dynamic_member_functions class_def then - let super_name = - join_class_path_remap class_def.cl_path "::" ^ "_obj" - in - output_cpp - ("\t" ^ super_name - ^ "::__alloc_dynamic_functions(_hx_ctx,_hx_obj);\n") - else - match class_def.cl_super with - | Some super -> find_super (fst super) - | _ -> () - in - find_super (fst super) - | _ -> ()); - output_cpp "}\n"); + gen_dynamic_function_allocator ctx output_cpp tcpp_class; let inline_constructor = - can_inline_constructor baseCtx class_def super_deps - (create_constructor_dependencies common_ctx) - in - if - (not (has_class_flag class_def CInterface)) - && (not nativeGen) && (not inline_constructor) - && not (has_class_flag class_def CAbstract) - then generate_constructor ctx output_cpp class_def false - else if nativeGen then - generate_native_constructor ctx output_cpp class_def false; - - let reflect_member_fields = - List.filter (reflective class_def) class_def.cl_ordered_fields - in - let reflect_static_fields = - List.filter (reflective class_def) statics_except_meta + can_inline_constructor base_ctx class_def in + if (not inline_constructor) && not (has_class_flag class_def CAbstract) then + generate_constructor ctx output_cpp tcpp_class false; (* Initialise non-static variables *) - if (not (has_class_flag class_def CInterface)) && not nativeGen then ( - output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); - List.iter - (fun name -> - output_cpp ("\t" ^ name ^ " = new __default_" ^ name ^ "(this);\n")) - dynamic_functions; - output_cpp "}\n\n"; - - let dump_field_iterator macro field = - if is_data_member field then ( - let remap_name = keyword_remap field.cf_name in - output_cpp - ("\t" ^ macro ^ "(" ^ remap_name ^ ",\"" ^ field.cf_name ^ "\");\n"); - - (match field.cf_kind with - | Var { v_read = AccCall } - when is_dynamic_accessor ("get_" ^ field.cf_name) "get" field - class_def -> - let name = "get_" ^ field.cf_name in - output_cpp ("\t" ^ macro ^ "(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n") - | _ -> ()); - match field.cf_kind with - | Var { v_write = AccCall } - when is_dynamic_accessor ("set_" ^ field.cf_name) "set" field - class_def -> - let name = "set_" ^ field.cf_name in - output_cpp ("\t" ^ macro ^ "(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n") - | _ -> ()) + output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); + List.iter + (fun func -> output_cpp ("\t" ^ func.tcf_name ^ " = new __default_" ^ func.tcf_name ^ "(this);\n")) + tcpp_class.tcl_dynamic_functions; + output_cpp "}\n\n"; + + if tcpp_class.tcl_container = Some Current then ( + let rec find_next_super_iteration cls = + match cls.tcl_super with + | Some ({ tcl_container = Some Current } as super) -> + Some (tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class super.tcl_params)) + | Some super -> + find_next_super_iteration super + | None -> + None in - let implemented_instance_fields = - List.filter should_implement_field class_def.cl_ordered_fields + let super_needs_iteration = find_next_super_iteration tcpp_class in + let smart_class_name = snd class_path in + let dump_field_iterator macro var = + Printf.sprintf "\t%s(%s, \"%s\");\n" macro var.tcv_name var.tcv_field.cf_name |> output_cpp in - let override_iteration = - (not nativeGen) && has_new_gc_references class_def - in - if override_iteration then ( - let super_needs_iteration = find_next_super_iteration class_def in - let smart_class_name = snd class_path in - (* MARK function - explicitly mark all child pointers *) - output_cpp ("void " ^ class_name ^ "::__Mark(HX_MARK_PARAMS)\n{\n"); - output_cpp ("\tHX_MARK_BEGIN_CLASS(" ^ smart_class_name ^ ");\n"); - List.iter - (dump_field_iterator "HX_MARK_MEMBER_NAME") - implemented_instance_fields; - (match super_needs_iteration with - | "" -> () - | super -> output_cpp ("\t" ^ super ^ "::__Mark(HX_MARK_ARG);\n")); - output_cpp "\tHX_MARK_END_CLASS();\n"; - output_cpp "}\n\n"; - - (* Visit function - explicitly visit all child pointers *) - output_cpp ("void " ^ class_name ^ "::__Visit(HX_VISIT_PARAMS)\n{\n"); + (* MARK function - explicitly mark all child pointers *) + output_cpp ("void " ^ class_name ^ "::__Mark(HX_MARK_PARAMS)\n{\n"); + output_cpp ("\tHX_MARK_BEGIN_CLASS(" ^ smart_class_name ^ ");\n"); + List.iter (dump_field_iterator "HX_MARK_MEMBER_NAME") tcpp_class.tcl_variables; + (match super_needs_iteration with + | None -> () + | Some super -> output_cpp ("\t" ^ super ^ "::__Mark(HX_MARK_ARG);\n")); + output_cpp "\tHX_MARK_END_CLASS();\n"; + output_cpp "}\n\n"; + + (* Visit function - explicitly visit all child pointers *) + output_cpp ("void " ^ class_name ^ "::__Visit(HX_VISIT_PARAMS)\n{\n"); + List.iter (dump_field_iterator "HX_VISIT_MEMBER_NAME") tcpp_class.tcl_variables; + (match super_needs_iteration with + | None -> () + | Some super -> output_cpp ("\t" ^ super ^ "::__Visit(HX_VISIT_ARG);\n")); + output_cpp "}\n\n"); + + let dump_quick_field_test fields = + if List.length fields > 0 then ( + 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 "\tswitch(inName.length) {\n"; List.iter - (dump_field_iterator "HX_VISIT_MEMBER_NAME") - implemented_instance_fields; - (match super_needs_iteration with - | "" -> () - | super -> output_cpp ("\t" ^ super ^ "::__Visit(HX_VISIT_ARG);\n")); - output_cpp "}\n\n"); - - let dump_quick_field_test fields = - if List.length fields > 0 then ( - 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 "\tswitch(inName.length) {\n"; - List.iter - (fun (field, l, result) -> - if l <> !len_case then ( - if !len_case >= 0 then output_cpp "\t\tbreak;\n"; - output_cpp ("\tcase " ^ string_of_int l ^ ":\n"); - len_case := l); - output_cpp - ("\t\tif (HX_FIELD_EQ(inName,\"" - ^ StringHelper.s_escape field - ^ "\") ) { " ^ result ^ " }\n")) - sfields; - output_cpp "\t}\n") - in + (fun (field, l, result) -> + if l <> !len_case then ( + if !len_case >= 0 then output_cpp "\t\tbreak;\n"; + output_cpp ("\tcase " ^ string_of_int l ^ ":\n"); + len_case := l); + output_cpp + ("\t\tif (HX_FIELD_EQ(inName,\"" + ^ StringHelper.s_escape field + ^ "\") ) { " ^ result ^ " }\n")) + sfields; + output_cpp "\t}\n") + in - let checkPropCall field = - if - Meta.has Meta.NativeProperty class_def.cl_meta - || Meta.has Meta.NativeProperty field.cf_meta - || Gctx.defined common_ctx Define.ForceNativeProperty - then "inCallProp != ::hx::paccNever" - else "inCallProp == ::hx::paccAlways" - in + let checkPropCall field = + if + Meta.has Meta.NativeProperty class_def.cl_meta + || Meta.has Meta.NativeProperty field.cf_meta + || Gctx.defined common_ctx Define.ForceNativeProperty + then "inCallProp != ::hx::paccNever" + else "inCallProp == ::hx::paccAlways" + in - let toCommon t f value = - t ^ "( " - ^ (match cpp_type_of f.cf_type with - | TCppInst (t, _) as inst when Meta.has Meta.StructAccess t.cl_meta -> - "cpp::Struct< " ^ tcpp_to_string inst ^ " >( " ^ value ^ " )" - | TCppStar (t, _) -> "cpp::Pointer( " ^ value ^ " )" - | _ -> value) - ^ " )" + let get_wrapper field value = + match cpp_type_of field.cf_type with + | TCppInst (t, _) as inst when Meta.has Meta.StructAccess t.cl_meta -> + Printf.sprintf "(::cpp::Struct< %s >) %s" (tcpp_to_string inst) value + | TCppStar _ -> + Printf.sprintf "(::cpp::Pointer) %s" value + | _ -> + value in - let toVal f value = toCommon "::hx::Val" f value in - let toDynamic f value = toCommon "" f value in - if has_get_member_field class_def then ( - (* Dynamic "Get" Field function - string version *) - output_cpp - ("::hx::Val " ^ class_name - ^ "::__Field(const ::String &inName,::hx::PropertyAccess inCallProp)\n\ - {\n"); - let get_field_dat = - List.map (fun f -> - ( f.cf_name, - String.length f.cf_name, - match f.cf_kind with - | Var { v_read = AccCall } when not (is_physical_field f) -> - "if (" ^ checkPropCall f ^ ") return " - ^ toVal f (keyword_remap ("get_" ^ f.cf_name) ^ "()") - ^ ";" - | Var { v_read = AccCall } -> - "return " - ^ toVal f - (checkPropCall f ^ " ? " - ^ keyword_remap ("get_" ^ f.cf_name) - ^ "() : " ^ keyword_remap f.cf_name - ^ if variable_field f then "" else "_dyn()") - ^ ";" - | _ -> - "return " - ^ toVal f - (keyword_remap f.cf_name - ^ if variable_field f then "" else "_dyn()") - ^ ";" )) - in - let reflect_member_readable = - List.filter (is_readable class_def) reflect_member_fields - in - dump_quick_field_test (get_field_dat reflect_member_readable); + let print_variable var_printer get_printer (var:tcpp_class_variable) acc = + if var.tcv_is_reflective && not (is_abstract_impl class_def) then + let variable = get_wrapper var.tcv_field var.tcv_name in + + match var.tcv_field.cf_kind with + | Var { v_read = AccCall } -> + let prop_check = checkPropCall var.tcv_field in + let getter = Printf.sprintf "get_%s()" var.tcv_field.cf_name |> get_wrapper var.tcv_field in + + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, get_printer prop_check getter variable) :: acc + | _ -> + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, var_printer variable) :: acc + else + acc + in + + let print_function printer func acc = + if func.tcf_is_reflective then + let ident = get_wrapper func.tcf_field func.tcf_name |> printer in + let length = String.length func.tcf_field.cf_name in + + (func.tcf_field.cf_name, length, ident) :: acc + else + acc + in + + let print_property printer (var:tcpp_class_variable) acc = + if var.tcv_is_reflective && not (is_abstract_impl class_def) then + let prop_check = checkPropCall var.tcv_field in + let getter = Printf.sprintf "get_%s()" var.tcv_field.cf_name |> get_wrapper var.tcv_field in + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, printer prop_check getter) :: acc + else + acc + in + + let castable f = + match cpp_type_of f.cf_type with + | TCppInst (t, _) as inst when Meta.has Meta.StructAccess t.cl_meta -> + "cpp::Struct< " ^ tcpp_to_string inst ^ " > " + | TCppStar (t, _) -> "cpp::Pointer< " ^ tcpp_to_string t ^ " >" + | _ -> type_to_string f.cf_type + in + + if has_tcpp_class_flag tcpp_class MemberGet then ( + (* Dynamic "Get" Field function - string version *) + Printf.sprintf "::hx::Val %s::__Field(const ::String &inName,::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; + + let var_printer ident = Printf.sprintf "return ::hx::Val( %s );" ident in + let get_printer check getter ident = Printf.sprintf "return ::hx::Val( %s ? %s : %s );" check getter ident in + let fun_printer ident = Printf.sprintf "return ::hx::Val( %s_dyn() );" ident in + let prop_printer check ident = Printf.sprintf "if (%s) { return ::hx::Val( %s ); }" check ident in + + let all_fields = [] + |> List.fold_right (print_variable var_printer get_printer) tcpp_class.tcl_variables + |> List.fold_right (print_property prop_printer) tcpp_class.tcl_properties + |> List.fold_right (print_function fun_printer) tcpp_class.tcl_functions in + + if List.length all_fields > 0 then ( + dump_quick_field_test all_fields; output_cpp "\treturn super::__Field(inName,inCallProp);\n}\n\n"); + ); - if has_get_static_field class_def then ( - output_cpp - ("bool " ^ class_name - ^ "::__GetStatic(const ::String &inName, Dynamic &outValue, \ - ::hx::PropertyAccess inCallProp)\n\ - {\n"); - let get_field_dat = - List.map (fun f -> - ( f.cf_name, - String.length f.cf_name, - match f.cf_kind with - | Var { v_read = AccCall } when not (is_physical_field f) -> - "if (" ^ checkPropCall f ^ ") { outValue = " - ^ toDynamic f (keyword_remap ("get_" ^ f.cf_name) ^ "()") - ^ "; return true; }" - | Var { v_read = AccCall } -> - "outValue = " - ^ toDynamic f - (checkPropCall f ^ " ? " - ^ keyword_remap ("get_" ^ f.cf_name) - ^ "() : " ^ keyword_remap f.cf_name - ^ if variable_field f then "" else "_dyn()") - ^ "; return true;" - | _ when variable_field f -> - "outValue = " - ^ toDynamic f (keyword_remap f.cf_name) - ^ "; return true;" - | _ -> - "outValue = " - ^ native_field_name_remap true f - ^ "_dyn(); return true;" )) - in - let reflect_static_readable = - List.filter (is_readable class_def) reflect_static_fields - in - dump_quick_field_test (get_field_dat reflect_static_readable); - output_cpp "\treturn false;\n}\n\n"); - - let castable f = - match cpp_type_of f.cf_type with - | TCppInst (t, _) as inst when Meta.has Meta.StructAccess t.cl_meta -> - "cpp::Struct< " ^ tcpp_to_string inst ^ " > " - | TCppStar (t, _) -> "cpp::Pointer< " ^ tcpp_to_string t ^ " >" - | _ -> type_to_string f.cf_type - in + if has_tcpp_class_flag tcpp_class StaticGet then ( + Printf.sprintf "bool %s::__GetStatic(const ::String &inName, Dynamic &outValue, ::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; - (* Dynamic "Set" Field function *) - if has_set_member_field class_def then ( - output_cpp - ("::hx::Val " ^ class_name - ^ "::__SetField(const ::String &inName,const ::hx::Val \ - &inValue,::hx::PropertyAccess inCallProp)\n\ - {\n"); - - let set_field_dat = - List.map (fun f -> - let default_action = - if is_gc_element ctx (cpp_type_of f.cf_type) then - "_hx_set_" ^ keyword_remap f.cf_name - ^ "(HX_CTX_GET,inValue.Cast< " ^ castable f ^ " >());" - ^ " return inValue;" - else - keyword_remap f.cf_name ^ "=inValue.Cast< " ^ castable f - ^ " >();" ^ " return inValue;" - in - ( f.cf_name, - String.length f.cf_name, - match f.cf_kind with - | Var { v_write = AccCall } -> - let inVal = "(inValue.Cast< " ^ castable f ^ " >())" in - let setter = keyword_remap ("set_" ^ f.cf_name) in - "if (" ^ checkPropCall f ^ ") return " - ^ toVal f (setter ^ inVal) - ^ ";" - ^ if not (is_physical_field f) then "" else default_action - | _ -> default_action )) - in + let var_printer ident = Printf.sprintf "outValue = %s; return true;" ident in + let get_printer check getter ident = Printf.sprintf "outValue = %s ? %s : %s; return true;" check getter ident in + let fun_printer ident = Printf.sprintf "outValue = %s_dyn(); return true;" ident in + let prop_printer check ident = Printf.sprintf "if (%s) { outValue = %s; return true; }" check ident in - let reflect_member_writable = - List.filter (is_writable class_def) reflect_member_fields - in - let reflect_write_member_variables = - List.filter variable_field reflect_member_writable - in - dump_quick_field_test (set_field_dat reflect_write_member_variables); - output_cpp "\treturn super::__SetField(inName,inValue,inCallProp);\n}\n\n"); + let all_fields = [] + |> List.fold_right (print_variable var_printer get_printer) tcpp_class.tcl_static_variables + |> List.fold_right (print_property prop_printer) tcpp_class.tcl_static_properties + |> List.fold_right (print_function fun_printer) tcpp_class.tcl_static_functions in - if has_set_static_field class_def then ( - output_cpp - ("bool " ^ class_name - ^ "::__SetStatic(const ::String &inName,Dynamic \ - &ioValue,::hx::PropertyAccess inCallProp)\n\ - {\n"); - - let set_field_dat = - List.map (fun f -> - let default_action = - keyword_remap f.cf_name ^ "=ioValue.Cast< " ^ castable f - ^ " >(); return true;" - in - ( f.cf_name, - String.length f.cf_name, - match f.cf_kind with - | Var { v_write = AccCall } -> - let inVal = "(ioValue.Cast< " ^ castable f ^ " >())" in - let setter = keyword_remap ("set_" ^ f.cf_name) in - "if (" ^ checkPropCall f ^ ") ioValue = " - ^ toDynamic f (setter ^ inVal) - ^ ";" - ^ - if not (is_physical_field f) then "" - else " else " ^ default_action - | _ -> default_action )) - in + dump_quick_field_test all_fields; + output_cpp "\treturn false;\n}\n\n"); - let reflect_static_writable = - List.filter (is_writable class_def) reflect_static_fields - in - let reflect_write_static_variables = - List.filter variable_field reflect_static_writable - in - dump_quick_field_test (set_field_dat reflect_write_static_variables); - output_cpp "\treturn false;\n}\n\n"); + if has_tcpp_class_flag tcpp_class MemberSet then ( + Printf.sprintf "::hx::Val %s::__SetField(const ::String& inName, const ::hx::Val& inValue, ::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; - (* For getting a list of data members (eg, for serialization) *) - if has_get_fields class_def then ( - let append_field field = - output_cpp ("\toutFields->push(" ^ strq field.cf_name ^ ");\n") - in - let is_data_field field = - match follow field.cf_type with TFun _ -> false | _ -> true - in + let fold_variable (var:tcpp_class_variable) acc = + if var.tcv_is_reflective && not (is_abstract_impl class_def) then + let casted = castable var.tcv_field in + let default = if var.tcv_is_gc_element then + Printf.sprintf "_hx_set_%s(HX_CTX_GET, inValue.Cast< %s >()); return inValue;" var.tcv_name casted + else + Printf.sprintf "%s = inValue.Cast< %s >(); return inValue;" var.tcv_name casted 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); - output_cpp "\tsuper::__GetFields(outFields);\n"; - output_cpp "};\n\n"); - - let storage field = - match cpp_type_of field.cf_type with - | TCppScalar "bool" -> "::hx::fsBool" - | TCppScalar "int" -> "::hx::fsInt" - | TCppScalar "Float" -> "::hx::fsFloat" - | TCppString -> "::hx::fsString" - | o when is_object_element o -> - "::hx::fsObject" ^ " /* " ^ tcpp_to_string o ^ " */ " - | u -> "::hx::fsUnknown" ^ " /* " ^ tcpp_to_string u ^ " */ " - in - let dump_member_storage field = - output_cpp - ("\t{" ^ storage field ^ ",(int)offsetof(" ^ class_name ^ "," - ^ keyword_remap field.cf_name - ^ ")," ^ strq field.cf_name ^ "},\n") + match var.tcv_field.cf_kind with + | Var { v_write = AccCall } -> + let prop_call = checkPropCall var.tcv_field in + let setter = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in + let call = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()) ); } else { %s }" prop_call setter casted default in + + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc + | Var { v_write = AccNormal | AccNo | AccNever } -> + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, default) :: acc + | _ -> + acc + else + acc in - let dump_static_storage field = - output_cpp - ("\t{" ^ storage field ^ ",(void *) &" ^ class_name ^ "::" - ^ keyword_remap field.cf_name - ^ "," ^ strq field.cf_name ^ "},\n") + + let fold_property (var:tcpp_class_variable) acc = + if var.tcv_is_reflective && not (is_abstract_impl class_def) then + let casted = castable var.tcv_field in + + match var.tcv_field.cf_kind with + | Var { v_write = AccCall } -> + let prop_call = checkPropCall var.tcv_field in + let setter = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in + let call = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()) ); }" prop_call setter casted in + + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc + | _ -> + acc + else + acc in - output_cpp "#ifdef HXCPP_SCRIPTABLE\n"; + let all_fields = [] + |> List.fold_right fold_variable tcpp_class.tcl_variables + |> List.fold_right fold_property tcpp_class.tcl_properties in + + dump_quick_field_test all_fields; + output_cpp "\treturn super::__SetField(inName,inValue,inCallProp);\n}\n\n"); - let stored_fields = - List.filter is_data_member implemented_instance_fields + if has_tcpp_class_flag tcpp_class StaticSet then ( + Printf.sprintf "bool %s::__SetStatic(const ::String& inName, ::Dynamic& ioValue, ::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; + + let fold_variable (var:tcpp_class_variable) acc = + if var.tcv_is_reflective && not (is_abstract_impl class_def) then + let casted = castable var.tcv_field in + + match var.tcv_field.cf_kind with + | Var { v_write = AccCall } -> + let prop_call = checkPropCall var.tcv_field in + let setter = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in + let call = Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); } else { %s = ioValue.Cast< %s >(); } return true;" prop_call setter casted var.tcv_name casted in + + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc + | Var { v_write = AccNormal | AccNo } -> + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, Printf.sprintf "%s = ioValue.Cast< %s >(); return true;" var.tcv_name casted) :: acc + | _ -> + acc + else + acc in - if List.length stored_fields > 0 then ( - output_cpp - ("static ::hx::StorageInfo " ^ class_name - ^ "_sMemberStorageInfo[] = {\n"); - List.iter dump_member_storage stored_fields; - output_cpp "\t{ ::hx::fsUnknown, 0, null()}\n};\n") - else - output_cpp - ("static ::hx::StorageInfo *" ^ class_name - ^ "_sMemberStorageInfo = 0;\n"); - let stored_statics = List.filter is_data_member implemented_fields in - if List.length stored_statics > 0 then ( - output_cpp - ("static ::hx::StaticInfo " ^ class_name ^ "_sStaticStorageInfo[] = {\n"); - List.iter dump_static_storage stored_statics; - output_cpp "\t{ ::hx::fsUnknown, 0, null()}\n};\n") - else - output_cpp - ("static ::hx::StaticInfo *" ^ class_name ^ "_sStaticStorageInfo = 0;\n"); + let fold_property (var:tcpp_class_variable) acc = + if var.tcv_is_reflective && not (is_abstract_impl class_def) then + match var.tcv_field.cf_kind with + | Var { v_write = AccCall } -> + let prop_call = checkPropCall var.tcv_field in + let setter = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in + let casted = castable var.tcv_field in - output_cpp "#endif\n\n"); + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); }" prop_call setter casted) :: acc + | _ -> + acc + else + acc + in - (* cl_interface *) - let implemented_instance_fields = - List.filter should_implement_field class_def.cl_ordered_fields + let all_fields = [] + |> List.fold_right fold_variable tcpp_class.tcl_static_variables + |> List.fold_right fold_property tcpp_class.tcl_static_properties in + + dump_quick_field_test all_fields; + output_cpp "\treturn false;\n}\n\n"); + + (* For getting a list of data members (eg, for serialization) *) + if has_tcpp_class_flag tcpp_class GetFields then ( + + let append var acc = (strq var.tcv_field.cf_name |> Printf.sprintf "\toutFields->push(%s);") :: acc in + let fields = + [ "\tsuper::__GetFields(outFields);" ] + |> List.fold_right append tcpp_class.tcl_variables + |> List.fold_right append tcpp_class.tcl_properties + |> String.concat "\n" in + + Printf.sprintf "void %s::__GetFields(::Array< ::String >& outFields)\n{\n%s\n}\n\n" class_name fields |> output_cpp); + + let storage field = + match cpp_type_of field.cf_type with + | TCppScalar "bool" -> "::hx::fsBool" + | TCppScalar "int" -> "::hx::fsInt" + | TCppScalar "Float" -> "::hx::fsFloat" + | TCppString -> "::hx::fsString" + | o when is_object_element o -> + "::hx::fsObject" ^ " /* " ^ tcpp_to_string o ^ " */ " + | u -> "::hx::fsUnknown" ^ " /* " ^ tcpp_to_string u ^ " */ " in - let reflective_members = - List.filter (reflective class_def) implemented_instance_fields + let dump_member_storage (var:tcpp_class_variable) = + Printf.sprintf + "\t{ %s, (int)offsetof(%s, %s), %s },\n" (storage var.tcv_field) class_name var.tcv_name (strq var.tcv_field.cf_name) |> output_cpp in - let sMemberFields = - match reflective_members with - | [] -> "0 /* sMemberFields */" - | _ -> - let memberFields = class_name ^ "_sMemberFields" in - output_cpp ("static ::String " ^ memberFields ^ "[] = {\n"); - List.iter dump_field_name reflective_members; - output_cpp "\t::String(null()) };\n\n"; - memberFields + let dump_static_storage (var:tcpp_class_variable) = + Printf.sprintf "\t{ %s, (void*) &%s::%s, %s },\n" (storage var.tcv_field) class_name var.tcv_name (strq var.tcv_field.cf_name) |> output_cpp in - let hasMarkFunc = - (not nativeGen) && List.exists is_data_member implemented_fields - in + output_cpp "#ifdef HXCPP_SCRIPTABLE\n"; + + if List.length tcpp_class.tcl_variables > 0 then ( + Printf.sprintf "static ::hx::StorageInfo %s_sMemberStorageInfo[] = {\n" class_name |> output_cpp; + List.iter dump_member_storage tcpp_class.tcl_variables; + output_cpp "\t{ ::hx::fsUnknown, 0, null()}\n};\n") + else + Printf.sprintf "static ::hx::StorageInfo* %s_sMemberStorageInfo = 0;\n" class_name |> output_cpp; + + if List.length tcpp_class.tcl_static_variables > 0 then ( + Printf.sprintf "static ::hx::StaticInfo %s_sStaticStorageInfo[] = {\n" class_name |> output_cpp; + List.iter dump_static_storage tcpp_class.tcl_static_variables; + output_cpp "\t{ ::hx::fsUnknown, 0, null()}\n};\n") + else + Printf.sprintf "static ::hx::StaticInfo* %s_sStaticStorageInfo = 0;\n" class_name |> output_cpp; + + output_cpp "#endif\n\n"; + + (match print_reflective_fields ctx.ctx_common class_def tcpp_class.tcl_variables tcpp_class.tcl_functions with + | Some str -> + Printf.sprintf "static ::String %s_sMemberFields[] = {\n%s\n};\n\n" class_name str |> output_cpp + | None -> + Printf.sprintf "static ::String* %s_sMemberFields = 0;\n\n" class_name |> output_cpp); + + if List.length tcpp_class.tcl_static_variables > 0 then ( + let dump_field_iterator macro var = + Printf.sprintf "\t%s(%s::%s, \"%s\");" macro class_name var.tcv_name var.tcv_field.cf_name + in - if hasMarkFunc then ( (* Mark static variables as used *) - output_cpp - ("static void " ^ class_name ^ "_sMarkStatics(HX_MARK_PARAMS) {\n"); - List.iter - (fun field -> - if is_data_member field then - output_cpp - ("\tHX_MARK_MEMBER_NAME(" ^ class_name ^ "::" - ^ keyword_remap field.cf_name - ^ ",\"" ^ field.cf_name ^ "\");\n")) - implemented_fields; - output_cpp "};\n\n"; + let marks = + tcpp_class.tcl_static_variables + |> List.map (dump_field_iterator "HX_MARK_MEMBER_NAME") + |> String.concat "\n" in + + Printf.sprintf "static void %s_sMarkStatics(HX_MARK_PARAMS) { \n%s\n };\n\n" class_name marks |> output_cpp; (* Visit static variables *) + let visits = + tcpp_class.tcl_static_variables + |> List.map (dump_field_iterator "HX_VISIT_MEMBER_NAME") + |> String.concat "\n" in + output_cpp "#ifdef HXCPP_VISIT_ALLOCS\n"; - output_cpp - ("static void " ^ class_name ^ "_sVisitStatics(HX_VISIT_PARAMS) {\n"); - List.iter - (fun field -> - if is_data_member field then - output_cpp - ("\tHX_VISIT_MEMBER_NAME(" ^ class_name ^ "::" - ^ keyword_remap field.cf_name - ^ ",\"" ^ field.cf_name ^ "\");\n")) - implemented_fields; - output_cpp "};\n\n"; + Printf.sprintf "static void %s_sVisitStatics(HX_VISIT_PARAMS) { \n%s\n };\n\n" class_name visits |> output_cpp; output_cpp "#endif\n\n"); let generate_script_function isStatic field scriptName callName = match follow field.cf_type with | TFun (args, return_type) when not (is_data_member field) -> - let isTemplated = - (not isStatic) && not (has_class_flag class_def CInterface) - in + let isTemplated = not isStatic in if isTemplated then output_cpp "\ntemplate"; output_cpp ("\nstatic void CPPIA_CALL " ^ scriptName - ^ "(::hx::CppiaCtx *ctx) {\n"); + ^ "(::hx::CppiaCtx *ctx) {\n"); let ret = match cpp_type_of return_type with | TCppScalar "bool" -> "b" @@ -1004,11 +849,8 @@ let generate baseCtx class_def = ("ctx->return" ^ CppCppia.script_type return_type false ^ "("); let dump_call cast = - if has_class_flag class_def CInterface then - output_cpp - (class_name ^ "::" ^ callName ^ "(ctx->getThis()" - ^ if List.length args > 0 then "," else "") - else if isStatic then output_cpp (class_name ^ "::" ^ callName ^ "(") + if isStatic then + output_cpp (class_name ^ "::" ^ callName ^ "(") else output_cpp ("((" ^ class_name ^ "*)ctx->getThis())->" ^ cast ^ callName ^ "("); @@ -1018,7 +860,7 @@ let generate baseCtx class_def = (fun (signature, sep, size) (_, opt, t) -> output_cpp (sep ^ "ctx->get" ^ CppCppia.script_type t opt ^ "(" ^ size - ^ ")"); + ^ ")"); ( signature ^ CppCppia.script_signature t opt, ",", size ^ "+sizeof(" ^ CppCppia.script_size_type t opt ^ ")" )) @@ -1042,350 +884,208 @@ let generate baseCtx class_def = | _ -> "" in - let newInteface = has_class_flag class_def CInterface in - - if scriptable && not nativeGen then ( - let delegate = "this->" in - let dump_script_field idx (field, f_args, return_t) = - let args = print_tfun_arg_list true f_args in - let names = List.map (fun (n, _, _) -> keyword_remap n) f_args in - let return_type = type_to_string return_t in - let ret = - if return_type = "Void" || return_type = "void" then " " else "return " - in - let name = keyword_remap field.cf_name in - let vtable = "__scriptVTable[" ^ string_of_int (idx + 1) ^ "] " in - let args_varray = - List.fold_left - (fun l n -> l ^ ".Add(" ^ n ^ ")") - "Array()" names - in - - output_cpp ("\t" ^ return_type ^ " " ^ name ^ "( " ^ args ^ " ) {\n"); - if newInteface then ( - output_cpp "\t\t::hx::CppiaCtx *__ctx = ::hx::CppiaCtx::getCurrent();\n"; - output_cpp "\t\t::hx::AutoStack __as(__ctx);\n"; - output_cpp "\t\t__ctx->pushObject(this);\n"; - List.iter - (fun (name, opt, t) -> - output_cpp - ("\t\t__ctx->push" ^ CppCppia.script_type t opt ^ "(" - ^ keyword_remap name ^ ");\n")) - f_args; - let interfaceSlot = string_of_int (-cpp_get_interface_slot ctx name) in - output_cpp - ("\t\t" ^ ret ^ "__ctx->run" - ^ CppCppia.script_type return_t false - ^ "(__GetScriptVTable()[" ^ interfaceSlot ^ "]);\n"); - output_cpp "\t}\n") - else ( - output_cpp ("\tif (" ^ vtable ^ ") {\n"); + if scriptable then ( + let dump_script_func idx func = + match func.tcf_field.cf_type with + | TFun (f_args, _) -> + let args = print_tfun_arg_list true f_args in + let return_type = type_to_string func.tcf_func.tf_type in + let ret = if return_type = "Void" || return_type = "void" then " " else "return " in + let vtable = Printf.sprintf "__scriptVTable[%i]" (idx + 1) in + + Printf.sprintf "\t%s %s(%s) {\n" return_type func.tcf_name args |> output_cpp; + Printf.sprintf ("\tif (%s) {\n") vtable |> output_cpp; output_cpp "\t\t::hx::CppiaCtx *__ctx = ::hx::CppiaCtx::getCurrent();\n"; output_cpp "\t\t::hx::AutoStack __as(__ctx);\n"; - output_cpp - ("\t\t__ctx->pushObject(" - ^ (if has_class_flag class_def CInterface then "mDelegate.mPtr" - else "this") - ^ ");\n"); + output_cpp ("\t\t__ctx->pushObject( this );\n"); + List.iter (fun (name, opt, t) -> - output_cpp - ("\t\t__ctx->push" ^ CppCppia.script_type t opt ^ "(" - ^ keyword_remap name ^ ");\n")) - f_args; + Printf.sprintf "\t\t__ctx->push%s(%s);\n" (CppCppia.script_type t opt) (keyword_remap name) |> output_cpp) + f_args; + output_cpp - ("\t\t" ^ ret ^ "__ctx->run" - ^ CppCppia.script_type return_t false - ^ "(" ^ vtable ^ ");\n"); + ("\t\t" ^ ret ^ "__ctx->run" ^ CppCppia.script_type func.tcf_func.tf_type false ^ "(" ^ vtable ^ ");\n"); output_cpp ("\t} else " ^ ret); - if has_class_flag class_def CInterface then ( - output_cpp - (" " ^ delegate ^ "__Field(HX_CSTRING(\"" ^ field.cf_name - ^ "\"), ::hx::paccNever)"); - if List.length names <= 5 then - output_cpp ("->__run(" ^ String.concat "," names ^ ");") - else output_cpp ("->__Run(" ^ args_varray ^ ");")) - else - output_cpp - (class_name ^ "::" ^ name ^ "(" ^ String.concat "," names ^ ");"); - if return_type <> "void" then output_cpp "return null();"; - output_cpp "}\n"; - let dynamic_interface_closures = - Gctx.defined baseCtx.ctx_common Define.DynamicInterfaceClosures - in - if has_class_flag class_def CInterface && not dynamic_interface_closures - then - output_cpp - ("\tDynamic " ^ name - ^ "_dyn() { return mDelegate->__Field(HX_CSTRING(\"" ^ field.cf_name - ^ "\"), ::hx::paccNever); }\n\n")) - in + let names = List.map (fun (n, _, _) -> keyword_remap n) f_args in - let new_sctipt_functions = - if newInteface then all_virtual_functions class_def - else List.rev (current_virtual_functions_rev class_def []) - in - let sctipt_name = class_name ^ "__scriptable" in - - if newInteface then ( - output_cpp ("class " ^ sctipt_name ^ " : public ::hx::Object {\n"); - output_cpp "public:\n") - else ( - output_cpp ("class " ^ sctipt_name ^ " : public " ^ class_name ^ " {\n"); - output_cpp (" typedef " ^ sctipt_name ^ " __ME;\n"); - output_cpp (" typedef " ^ class_name ^ " super;\n"); - let field_arg_count field = - match (follow field.cf_type, field.cf_kind) with - | _, Method MethDynamic -> -1 - | TFun (args, return_type), Method _ -> List.length args - | _, _ -> -1 - in - let has_funky_toString = - List.exists - (fun f -> f.cf_name = "toString") - class_def.cl_ordered_statics - || List.exists - (fun f -> f.cf_name = "toString" && field_arg_count f <> 0) - class_def.cl_ordered_fields - in - let super_string = - if has_funky_toString then class_name ^ "::super" else class_name - in - output_cpp (" typedef " ^ super_string ^ " __superString;\n"); - if has_class_flag class_def CInterface then - output_cpp " HX_DEFINE_SCRIPTABLE_INTERFACE\n" - else ( output_cpp - (" HX_DEFINE_SCRIPTABLE(HX_ARR_LIST" - ^ string_of_int (List.length constructor_var_list) - ^ ")\n"); - output_cpp "\tHX_DEFINE_SCRIPTABLE_DYNAMIC;\n")); + (class_name ^ "::" ^ func.tcf_name ^ "(" ^ String.concat "," names ^ ");"); - let list_iteri func in_list = - let idx = ref 0 in - List.iter - (fun elem -> - func !idx elem; - idx := !idx + 1) - in_list + if return_type <> "void" then output_cpp "return null();"; + + output_cpp "}\n"; + | _ -> + abort "expected function type to be tfun" func.tcf_field.cf_pos in - let not_toString (field, args, _) = - field.cf_name <> "toString" || has_class_flag class_def CInterface + let script_name = class_name ^ "__scriptable" in + let has_funky_toString = + List.exists + (fun func -> func.tcf_name = "toString") + tcpp_class.tcl_static_functions || + List.exists + (fun func -> func.tcf_name = "toString" && List.length func.tcf_func.tf_args <> 0) + tcpp_class.tcl_functions in - let functions = - List.filter not_toString (all_virtual_functions class_def) + let super_string = + if has_funky_toString then class_name ^ "::super" else class_name in - list_iteri dump_script_field functions; - output_cpp "};\n\n"; - let sigs = Hashtbl.create 0 in + Printf.sprintf "class %s : public %s {\n" script_name class_name |> output_cpp; + Printf.sprintf "\ttypedef %s __ME;\n" script_name |> output_cpp; + Printf.sprintf "\ttypedef %s super;\n" class_name |> output_cpp; + Printf.sprintf "\ttypedef %s __superString;\n" super_string |> output_cpp; + Printf.sprintf "\tHX_DEFINE_SCRIPTABLE(HX_ARR_LIST%i)\n" (List.length constructor_var_list) |> output_cpp; + output_cpp "\tHX_DEFINE_SCRIPTABLE_DYNAMIC;\n"; + + (* + Functions are added in reverse order (oldest on right), then list is reversed because this is easier in ocaml + The order is important because cppia looks up functions by index + *) + let flatten_tcpp_class_functions = + let current_virtual_functions_rev cls base_functions = + let folder result elem = + if elem.tcf_is_overriding then + if List.exists (fun f -> f.tcf_name = elem.tcf_name) result then + result + else + elem :: result + else + elem :: result + in + + List.fold_left folder base_functions cls.tcl_functions + in - let static_functions = - List.filter (fun f -> not (is_data_member f)) reflect_static_fields - in - let all_script_functions = - List.map (fun (f, _, _) -> f) new_sctipt_functions @ static_functions + let rec flatten_tcpp_class_functions_rec cls = + let initial = + match cls.tcl_super with + | Some super -> flatten_tcpp_class_functions_rec super + | _ -> [] in + current_virtual_functions_rev cls initial + in + + flatten_tcpp_class_functions_rec tcpp_class |> List.rev in - if List.length all_script_functions > 0 then ( - List.iter - (fun (f, _, _) -> - let s = - generate_script_function false f ("__s_" ^ f.cf_name) - (keyword_remap f.cf_name) - in - Hashtbl.add sigs f.cf_name s) - new_sctipt_functions; + flatten_tcpp_class_functions + |> List.filter (fun f -> f.tcf_name <> "toString") + |> ExtList.List.iteri dump_script_func; + output_cpp "};\n\n"; - let dump_script_static f = - let s = - generate_script_function true f ("__s_" ^ f.cf_name) - (keyword_remap f.cf_name) - in - Hashtbl.add sigs f.cf_name s + if List.length tcpp_class.tcl_functions > 0 || List.length tcpp_class.tcl_static_functions > 0 then ( + + let dump_script is_static f acc = + let signature = generate_script_function is_static f.tcf_field ("__s_" ^ f.tcf_field.cf_name) f.tcf_name in + let superCall = if is_static then "0" else "__s_" ^ f.tcf_field.cf_name ^ "" in + let named = + Printf.sprintf + "\t::hx::ScriptNamedFunction(\"%s\", __s_%s, \"%s\", %s HXCPP_CPPIA_SUPER_ARG(%s))" + f.tcf_field.cf_name + f.tcf_field.cf_name + signature + (if is_static then "true" else "false") + superCall in + + named :: acc + in + + let sigs = + [ "\t::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) )" ] + |> List.fold_right (dump_script false) tcpp_class.tcl_functions + |> List.fold_right (dump_script true) tcpp_class.tcl_static_functions + |> String.concat ",\n" in - List.iter dump_script_static class_def.cl_ordered_statics; output_cpp "#ifndef HXCPP_CPPIA_SUPER_ARG\n"; output_cpp "#define HXCPP_CPPIA_SUPER_ARG(x)\n"; output_cpp "#endif\n"; - output_cpp - "static ::hx::ScriptNamedFunction __scriptableFunctions[] = {\n"; - let dump_func f isStaticFlag = - let s = try Hashtbl.find sigs f.cf_name with Not_found -> "v" in - output_cpp - (" ::hx::ScriptNamedFunction(\"" ^ f.cf_name ^ "\",__s_" ^ f.cf_name - ^ ",\"" ^ s ^ "\", " ^ isStaticFlag ^ " "); - let superCall = - if isStaticFlag = "true" || has_class_flag class_def CInterface then - "0" - else "__s_" ^ f.cf_name ^ "" - in - output_cpp ("HXCPP_CPPIA_SUPER_ARG(" ^ superCall ^ ")"); - output_cpp " ),\n" - in - List.iter (fun (f, _, _) -> dump_func f "false") new_sctipt_functions; - List.iter (fun f -> dump_func f "true") static_functions; - output_cpp - " ::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) ) };\n") + Printf.sprintf "static ::hx::ScriptNamedFunction __scriptableFunctions[] = {\n%s\n};\n\n" sigs |> output_cpp) else - output_cpp - "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n"; - - if newInteface then ( - output_cpp ("\n\n" ^ class_name ^ " " ^ class_name ^ "_scriptable = {\n"); - List.iter - (fun (f, args, return_type) -> - let cast = cpp_tfun_signature true args return_type in - output_cpp - ("\t" ^ cast ^ "&" ^ sctipt_name ^ "::" ^ keyword_remap f.cf_name - ^ ",\n")) - new_sctipt_functions; - output_cpp "};\n")); + output_cpp "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n"); let class_name_text = join_class_path class_path "." in (* Initialise static in boot function ... *) - if (not (has_class_flag class_def CInterface)) && not nativeGen then ( - (* Remap the specialised "extern" classes back to the generic names *) - output_cpp ("::hx::Class " ^ class_name ^ "::__mClass;\n\n"); - (if scriptable then - match class_def.cl_constructor with - | Some field -> - let signature = - generate_script_function false field "__script_construct_func" - "__construct" - in - output_cpp - ("::hx::ScriptFunction " ^ class_name - ^ "::__script_construct(__script_construct_func,\"" ^ signature - ^ "\");\n") - | _ -> - output_cpp - ("::hx::ScriptFunction " ^ class_name - ^ "::__script_construct(0,0);\n")); - - let reflective_statics = - List.filter (reflective class_def) implemented_fields - in - let sStaticFields = - if List.length reflective_statics > 0 then ( - output_cpp ("static ::String " ^ class_name ^ "_sStaticFields[] = {\n"); - List.iter dump_field_name reflective_statics; - output_cpp "\t::String(null())\n};\n\n"; - class_name ^ "_sStaticFields") - else "0 /* sStaticFields */" - in - - output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); - if not (has_class_flag class_def CAbstract) then ( - output_cpp ("\t" ^ class_name ^ " _hx_dummy;\n"); - output_cpp ("\t" ^ class_name ^ "::_hx_vtable = *(void **)&_hx_dummy;\n")); - output_cpp "\t::hx::Static(__mClass) = new ::hx::Class_obj();\n"; - output_cpp ("\t__mClass->mName = " ^ strq class_name_text ^ ";\n"); - output_cpp "\t__mClass->mSuper = &super::__SGetClass();\n"; - if not (has_class_flag class_def CAbstract) then ( - output_cpp "\t__mClass->mConstructEmpty = &__CreateEmpty;\n"; - output_cpp "\t__mClass->mConstructArgs = &__Create;\n"); - output_cpp - ("\t__mClass->mGetStaticField = &" - ^ - if has_get_static_field class_def then class_name ^ "::__GetStatic;\n" - else "::hx::Class_obj::GetNoStaticField;\n"); - output_cpp - ("\t__mClass->mSetStaticField = &" - ^ - if has_set_static_field class_def then class_name ^ "::__SetStatic;\n" - else "::hx::Class_obj::SetNoStaticField;\n"); - if hasMarkFunc then - output_cpp ("\t__mClass->mMarkFunc = " ^ class_name ^ "_sMarkStatics;\n"); - output_cpp - ("\t__mClass->mStatics = ::hx::Class_obj::dupFunctions(" ^ sStaticFields - ^ ");\n"); - output_cpp - ("\t__mClass->mMembers = ::hx::Class_obj::dupFunctions(" ^ sMemberFields - ^ ");\n"); - output_cpp ("\t__mClass->mCanCast = ::hx::TCanCast< " ^ class_name ^ " >;\n"); - if hasMarkFunc then - output_cpp - ("#ifdef HXCPP_VISIT_ALLOCS\n\t__mClass->mVisitFunc = " ^ class_name - ^ "_sVisitStatics;\n#endif\n"); - output_cpp - ("#ifdef HXCPP_SCRIPTABLE\n\t__mClass->mMemberStorageInfo = " ^ class_name - ^ "_sMemberStorageInfo;\n#endif\n"); - output_cpp - ("#ifdef HXCPP_SCRIPTABLE\n\t__mClass->mStaticStorageInfo = " ^ class_name - ^ "_sStaticStorageInfo;\n#endif\n"); - output_cpp "\t::hx::_hx_RegisterClass(__mClass->mName, __mClass);\n"; - if scriptable then - output_cpp - (" HX_SCRIPTABLE_REGISTER_CLASS(\"" ^ class_name_text ^ "\"," - ^ class_name ^ ");\n"); - Hashtbl.iter - (fun _ intf_def -> - output_cpp - ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," - ^ join_class_path_remap intf_def.cl_path "::" - ^ ");\n")) - native_implementations; - output_cpp "}\n\n") - else if not nativeGen then ( - output_cpp ("::hx::Class " ^ class_name ^ "::__mClass;\n\n"); - - output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); - - output_cpp "\t::hx::Static(__mClass) = new ::hx::Class_obj();\n"; - output_cpp ("\t__mClass->mName = " ^ strq class_name_text ^ ";\n"); - output_cpp "\t__mClass->mSuper = &super::__SGetClass();\n"; - if hasMarkFunc then - output_cpp ("\t__mClass->mMarkFunc = " ^ class_name ^ "_sMarkStatics;\n"); + (* Remap the specialised "extern" classes back to the generic names *) + output_cpp ("::hx::Class " ^ class_name ^ "::__mClass;\n\n"); + (if scriptable then + match class_def.cl_constructor with + | Some field -> + let signature = + generate_script_function false field "__script_construct_func" + "__construct" + in + output_cpp + ("::hx::ScriptFunction " ^ class_name + ^ "::__script_construct(__script_construct_func,\"" ^ signature + ^ "\");\n") + | _ -> + output_cpp + ("::hx::ScriptFunction " ^ class_name + ^ "::__script_construct(0,0);\n")); + + (match print_reflective_fields ctx.ctx_common class_def tcpp_class.tcl_static_variables tcpp_class.tcl_static_functions with + | Some str -> + Printf.sprintf "static ::String %s_sStaticFields[] = {\n%s\n};\n\n" class_name str |> output_cpp + | None -> + Printf.sprintf "static ::String* %s_sStaticFields = 0;\n\n" class_name |> output_cpp); + + output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); + if not (has_class_flag class_def CAbstract) then ( + output_cpp ("\t" ^ class_name ^ " _hx_dummy;\n"); + output_cpp ("\t" ^ class_name ^ "::_hx_vtable = *(void **)&_hx_dummy;\n")); + output_cpp "\t::hx::Static(__mClass) = new ::hx::Class_obj();\n"; + output_cpp ("\t__mClass->mName = " ^ strq class_name_text ^ ";\n"); + output_cpp "\t__mClass->mSuper = &super::__SGetClass();\n"; + if not (has_class_flag class_def CAbstract) then ( + output_cpp "\t__mClass->mConstructEmpty = &__CreateEmpty;\n"; + output_cpp "\t__mClass->mConstructArgs = &__Create;\n"); + output_cpp + ("\t__mClass->mGetStaticField = &" + ^ + if has_tcpp_class_flag tcpp_class StaticGet then class_name ^ "::__GetStatic;\n" + else "::hx::Class_obj::GetNoStaticField;\n"); + output_cpp + ("\t__mClass->mSetStaticField = &" + ^ + if has_tcpp_class_flag tcpp_class StaticSet then class_name ^ "::__SetStatic;\n" + else "::hx::Class_obj::SetNoStaticField;\n"); + if List.length tcpp_class.tcl_static_variables > 0 then + output_cpp ("\t__mClass->mMarkFunc = " ^ class_name ^ "_sMarkStatics;\n"); + Printf.sprintf + "\t__mClass->mStatics = ::hx::Class_obj::dupFunctions(%s_sStaticFields);\n" class_name |> output_cpp; + Printf.sprintf + "\t__mClass->mMembers = ::hx::Class_obj::dupFunctions(%s_sMemberFields);\n" class_name |> output_cpp; + output_cpp ("\t__mClass->mCanCast = ::hx::TCanCast< " ^ class_name ^ " >;\n"); + if List.length tcpp_class.tcl_static_variables > 0 then output_cpp - ("\t__mClass->mMembers = ::hx::Class_obj::dupFunctions(" ^ sMemberFields - ^ ");\n"); + ("#ifdef HXCPP_VISIT_ALLOCS\n\t__mClass->mVisitFunc = " ^ class_name + ^ "_sVisitStatics;\n#endif\n"); + output_cpp + ("#ifdef HXCPP_SCRIPTABLE\n\t__mClass->mMemberStorageInfo = " ^ class_name + ^ "_sMemberStorageInfo;\n#endif\n"); + output_cpp + ("#ifdef HXCPP_SCRIPTABLE\n\t__mClass->mStaticStorageInfo = " ^ class_name + ^ "_sStaticStorageInfo;\n#endif\n"); + output_cpp "\t::hx::_hx_RegisterClass(__mClass->mName, __mClass);\n"; + if scriptable then output_cpp - ("\t__mClass->mCanCast = ::hx::TIsInterface< (int)" - ^ cpp_class_hash class_def ^ " >;\n"); - if hasMarkFunc then - output_cpp - ("#ifdef HXCPP_VISIT_ALLOCS\n\t__mClass->mVisitFunc = " ^ class_name - ^ "_sVisitStatics;\n#endif\n"); - output_cpp "\t::hx::_hx_RegisterClass(__mClass->mName, __mClass);\n"; - if scriptable then + (" HX_SCRIPTABLE_REGISTER_CLASS(\"" ^ class_name_text ^ "\"," + ^ class_name ^ ");\n"); + List.iter + (fun intf_def -> output_cpp - (" HX_SCRIPTABLE_REGISTER_INTERFACE(\"" ^ class_name_text ^ "\"," - ^ class_name ^ ");\n"); - output_cpp "}\n\n"); - - if has_boot_field class_def then ( - output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); + ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," + ^ join_class_path_remap intf_def.if_class.cl_path "::" + ^ ");\n")) + tcpp_class.tcl_native_interfaces; + output_cpp "}\n\n"; - List.iter - (gen_field_init ctx class_def) - (List.filter should_implement_field class_def.cl_ordered_statics); - - output_cpp "}\n\n"); + gen_boot_field ctx output_cpp tcpp_class; end_namespace output_cpp class_path; - if - has_class_flag class_def CInterface - && Meta.has Meta.ObjcProtocol class_def.cl_meta - then ( - let full_class_name = - ("::" ^ join_class_path_remap class_path "::") ^ "_obj" - in - let protocol = - get_meta_string class_def.cl_meta Meta.ObjcProtocol |> Option.default "" - in - generate_protocol_delegate ctx class_def output_cpp; - output_cpp - ("id<" ^ protocol ^ "> " ^ full_class_name - ^ "::_hx_toProtocol(Dynamic inImplementation) {\n"); - output_cpp - ("\treturn [ [_hx_" ^ protocol - ^ "_delegate alloc] initWithImplementation:inImplementation.mPtr];\n"); - output_cpp "}\n\n"); - cpp_file#close diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index ca0e0781d3e..450ef183a8e 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -1,64 +1,70 @@ open Type open CppStrings +open CppTypeUtils +open CppAst open CppAstTools open CppSourceWriter open CppContext open CppGen -let generate baseCtx enum_def = - let common_ctx = baseCtx.ctx_common in - let class_path = enum_def.e_path in +let constructor_arg_count constructor = + match constructor.ef_type with + | TFun(args, _) -> List.length args + | _ -> 0 + +let gen_enum_constructor remap_class_name class_name output_cpp constructor = + match constructor.tef_field.ef_type with + | TFun (args, _) -> + Printf.sprintf "%s %s::%s(%s)\n" remap_class_name class_name constructor.tef_name (print_tfun_arg_list true args) |> output_cpp; + Printf.sprintf "{\n\treturn ::hx::CreateEnum<%s>(%s,%i,%i)" class_name constructor.tef_hash constructor.tef_field.ef_index (List.length args) |> output_cpp; + + args + |> List.mapi (fun i (arg, _, _) -> Printf.sprintf "->_hx_init(%i,%s)" i (keyword_remap arg)) + |> List.iter output_cpp; + + output_cpp ";\n}\n\n" + | _ -> + output_cpp ( remap_class_name ^ " " ^ class_name ^ "::" ^ constructor.tef_name ^ ";\n\n" ) + +let gen_static_reflection class_name output_cpp constructor = + let dyn = if constructor_arg_count constructor.tef_field > 0 then "_dyn()" else "" in + Printf.sprintf "\tif (inName==%s) { outValue = %s::%s%s; return true; }\n" constructor.tef_hash class_name constructor.tef_name dyn |> output_cpp + +let gen_dynamic_constructor class_name output_cpp constructor = + let count = constructor_arg_count constructor.tef_field in + if (count>0) then begin + Printf.sprintf "STATIC_HX_DEFINE_DYNAMIC_FUNC%i(%s, %s, return)\n\n" count class_name constructor.tef_name |> output_cpp; + end + +let generate base_ctx tcpp_enum = + let common_ctx = base_ctx.ctx_common in + let class_path = tcpp_enum.te_enum.e_path in let just_class_name = (snd class_path) in let class_name = just_class_name ^ "_obj" in let remap_class_name = ("::" ^ (join_class_path_remap class_path "::") ) in let cpp_file = new_placed_cpp_file common_ctx class_path in let output_cpp = (cpp_file#write) in - let debug = if (Meta.has Meta.NoDebug enum_def.e_meta) || ( Gctx.defined common_ctx Define.NoDebug) then 0 else 1 in + let debug = if (Meta.has Meta.NoDebug tcpp_enum.te_enum.e_meta) || ( Gctx.defined common_ctx Define.NoDebug) then 0 else 1 in - let ctx = file_context baseCtx cpp_file debug false in + let ctx = file_context base_ctx cpp_file debug false in let strq = strq ctx.ctx_common in - - let classId = try Hashtbl.find baseCtx.ctx_type_ids (class_text enum_def.e_path) with Not_found -> Int32.zero in - let classIdTxt = Printf.sprintf "0x%08lx" classId in + let classIdTxt = Printf.sprintf "0x%08lx" tcpp_enum.te_id in if (debug>1) then - print_endline ("Found enum definition:" ^ (join_class_path class_path "::" )); + print_endline ("Found enum definition:" ^ (join_class_path class_path "::" )); cpp_file#write_h "#include \n\n"; - let super_deps = create_super_dependencies common_ctx in - let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl enum_def) "*" super_deps (Hashtbl.create 0) false false false in + let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl tcpp_enum.te_enum) None ctx.ctx_super_deps PathMap.empty false false false in List.iter (add_include cpp_file) referenced; begin_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 (remap_class_name ^ " " ^ class_name ^ "::" ^ name ^ "(" ^ - (print_tfun_arg_list true args) ^")\n"); - - output_cpp ("{\n\treturn ::hx::CreateEnum< " ^ class_name ^ " >(" ^ (strq name) ^ "," ^ - (string_of_int constructor.ef_index) ^ "," ^ (string_of_int (List.length args)) ^ ")" ); - ExtList.List.iteri (fun i (arg,_,_) -> output_cpp ("->_hx_init(" ^ (string_of_int i) ^ "," ^ (keyword_remap arg) ^ ")")) args; - output_cpp ";\n}\n\n" - | _ -> - output_cpp ( remap_class_name ^ " " ^ class_name ^ "::" ^ name ^ ";\n\n" ) - ) enum_def.e_constrs; - - - let constructor_arg_count constructor = - (match constructor.ef_type with | TFun(args,_) -> List.length args | _ -> 0 ) - in + List.iter (gen_enum_constructor remap_class_name class_name output_cpp) tcpp_enum.te_constructors; output_cpp ("bool " ^ class_name ^ "::__GetStatic(const ::String &inName, ::Dynamic &outValue, ::hx::PropertyAccess inCallProp)\n{\n"); - PMap.iter (fun _ constructor -> - let name = constructor.ef_name in - let dyn = if constructor_arg_count constructor > 0 then "_dyn()" else "" in - output_cpp ("\tif (inName==" ^ strq name ^ ") { outValue = " ^ class_name ^ "::" ^ keyword_remap name ^ dyn ^ "; return true; }\n" ); - ) enum_def.e_constrs; + List.iter (gen_static_reflection class_name output_cpp) tcpp_enum.te_constructors; output_cpp ("\treturn super::__GetStatic(inName, outValue, inCallProp);\n}\n\n"); output_cpp ("HX_DEFINE_CREATE_ENUM(" ^ class_name ^ ")\n\n"); @@ -68,51 +74,35 @@ let generate baseCtx enum_def = output_cpp ("}\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 ("\tif (inName==" ^ (strq name) ^ ") return " ^ idx ^ ";\n") ) enum_def.e_constrs; + List.iter + (fun constructor -> Printf.sprintf "\tif (inName==%s) return %i;\n" constructor.tef_hash constructor.tef_field.ef_index |> output_cpp) + tcpp_enum.te_constructors; output_cpp ("\treturn super::__FindIndex(inName);\n"); output_cpp ("}\n\n"); (* 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; - + List.iter (gen_dynamic_constructor class_name output_cpp) tcpp_enum.te_constructors; 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 ("\tif (inName==" ^ (strq name) ^ ") return " ^ count ^ ";\n") ) enum_def.e_constrs; - output_cpp ("\treturn super::__FindArgCount(inName);\n"); - output_cpp ("}\n\n"); + List.iter + (fun constructor -> Printf.sprintf "\tif (inName==%s) return %i;\n" constructor.tef_hash (constructor_arg_count constructor.tef_field) |> output_cpp) + tcpp_enum.te_constructors; + + output_cpp ("\treturn super::__FindArgCount(inName);\n"); + output_cpp ("}\n\n"); (* Dynamic "Get" Field function - string version *) output_cpp ("::hx::Val " ^ class_name ^ "::__Field(const ::String &inName,::hx::PropertyAccess inCallProp)\n{\n"); - let dump_constructor_test _ constr = - output_cpp ("\tif (inName==" ^ (strq constr.ef_name) ^ ") return " ^ - (keyword_remap constr.ef_name) ); - if ( (constructor_arg_count constr) > 0 ) then output_cpp "_dyn()"; + let dump_constructor_test constructor = + output_cpp ("\tif (inName==" ^ constructor.tef_hash ^ ") return " ^ constructor.tef_name ); + if ( (constructor_arg_count constructor.tef_field) > 0 ) then output_cpp "_dyn()"; output_cpp (";\n") in - PMap.iter dump_constructor_test enum_def.e_constrs; + List.iter dump_constructor_test tcpp_enum.te_constructors; output_cpp ("\treturn super::__Field(inName,inCallProp);\n}\n\n"); output_cpp ("static ::String " ^ class_name ^ "_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 ("\t" ^ (strq name) ^ ",\n") ) sorted; + List.iter (fun constructor -> output_cpp ("\t" ^ constructor.tef_hash ^ ",\n") ) tcpp_enum.te_constructors; output_cpp "\t::String(null())\n};\n\n"; @@ -136,19 +126,21 @@ let generate baseCtx enum_def = output_cpp "}\n\n"; output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); - (match Texpr.build_metadata common_ctx.basic (TEnumDecl enum_def) with - | Some expr -> - let ctx = file_context ctx cpp_file 1 false in - gen_cpp_init ctx class_name "boot" "__mClass->__meta__ = " expr - | _ -> () ); - PMap.iter (fun _ constructor -> - let name = constructor.ef_name in - match constructor.ef_type with - | TFun (_,_) -> () + (match Texpr.build_metadata common_ctx.basic (TEnumDecl tcpp_enum.te_enum) with + | Some expr -> + let ctx = file_context ctx cpp_file 1 false in + gen_cpp_init ctx class_name "boot" "__mClass->__meta__ = " expr + | _ -> () ); + + List.iter + (fun constructor -> + match constructor.tef_field.ef_type with + | TFun (_,_) -> + () | _ -> - output_cpp ( (keyword_remap name) ^ " = ::hx::CreateConstEnum< " ^ class_name ^ " >(" ^ (strq name) ^ "," ^ - (string_of_int constructor.ef_index) ^ ");\n" ) - ) enum_def.e_constrs; + Printf.sprintf "%s = ::hx::CreateConstEnum<%s>(%s, %i);\n" constructor.tef_name class_name constructor.tef_hash constructor.tef_field.ef_index |> output_cpp) + tcpp_enum.te_constructors; + output_cpp ("}\n\n"); output_cpp "\n"; @@ -164,7 +156,7 @@ let generate baseCtx enum_def = List.iter2 (fun r f -> gen_forward_decl h_file r f) referenced flags; - output_h ( get_code enum_def.e_meta Meta.HeaderCode ); + output_h ( get_code tcpp_enum.te_enum.e_meta Meta.HeaderCode ); begin_namespace output_h class_path; @@ -183,19 +175,17 @@ let generate baseCtx enum_def = output_h ("\t\t::String __ToString() const { return " ^ (strq (just_class_name ^ ".") )^ " + _hx_tag; }\n"); output_h ("\t\tbool _hx_isInstanceOf(int inClassId);\n\n"); - - PMap.iter (fun _ constructor -> - let name = keyword_remap constructor.ef_name in - output_h ( "\t\tstatic " ^ remap_class_name ^ " " ^ name ); - match constructor.ef_type with + List.iter + (fun constructor -> + Printf.sprintf "\t\tstatic %s %s" remap_class_name constructor.tef_name |> output_h; + match constructor.tef_field.ef_type with | TFun (args,_) -> - output_h ( "(" ^ (print_tfun_arg_list true args) ^");\n"); - output_h ( "\t\tstatic ::Dynamic " ^ name ^ "_dyn();\n"); + Printf.sprintf "(%s);\n" (print_tfun_arg_list true args) |> output_h; + Printf.sprintf "\t\tstatic ::Dynamic %s_dyn();\n" constructor.tef_name |> output_h; | _ -> output_h ";\n"; - output_h ( "\t\tstatic inline " ^ remap_class_name ^ " " ^ name ^ - "_dyn() { return " ^name ^ "; }\n" ); - ) enum_def.e_constrs; + Printf.sprintf "\t\tstatic inline %s %s_dyn() { return %s; }\n" remap_class_name constructor.tef_name constructor.tef_name |> output_h;) + tcpp_enum.te_constructors; output_h "};\n\n"; diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml new file mode 100644 index 00000000000..55a156395ab --- /dev/null +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -0,0 +1,188 @@ +open Ast +open Type +open Error +open Common +open Globals +open CppStrings +open CppTypeUtils +open CppAst +open CppAstTools +open CppSourceWriter +open CppContext +open CppGen + +let attribs common_ctx = match Gctx.defined common_ctx Define.DllExport with + | true -> "HXCPP_EXTERN_CLASS_ATTRIBUTES" + | false -> "HXCPP_CLASS_ATTRIBUTES" + +let gen_native_function ctx interface func = + let output = ctx.ctx_output in + let gen_args = print_tfun_arg_list true in + let strq = strq ctx.ctx_common in + + Printf.sprintf "\t\tvirtual %s %s(%s)=0;\n" (type_to_string func.iff_return) func.iff_name (gen_args func.iff_args) |> output; + if reflective interface.if_class func.iff_field then + if Gctx.defined ctx.ctx_common Define.DynamicInterfaceClosures then + Printf.sprintf + "\t\tinline ::Dynamic %s_dyn() { return __Field( %s, ::hx::paccDynamic ); }\n" + func.iff_name + (strq func.iff_field.cf_name) |> output + else + Printf.sprintf "\t\tvirtual ::Dynamic %s_dyn()=0;\n" func.iff_name |> output + +let gen_function ctx interface func = + let output = ctx.ctx_output in + let argList = print_tfun_arg_list true func.iff_args in + let returnType = type_to_string func.iff_return in + let returnStr = if returnType = "void" then "" else "return " in + let commaArgList = if argList = "" then argList else "," ^ argList in + let cast = Printf.sprintf "::hx::interface_cast< ::%s_obj *>" (join_class_path_remap interface.if_class.cl_path "::") in + + Printf.sprintf "\t\t%s (::hx::Object :: *_hx_%s)(%s);\n" returnType func.iff_name argList |> output; + Printf.sprintf "\t\tstatic inline %s %s( ::Dynamic _hx_%s ){\n" returnType func.iff_name commaArgList |> output; + output "\t\t\t#ifdef HXCPP_CHECK_POINTER\n"; + output "\t\t\tif (::hx::IsNull(_hx_)) ::hx::NullReference(\"Object\", false);\n"; + output "\t\t\t#ifdef HXCPP_GC_CHECK_POINTER\n"; + output "\t\t\t\tGCCheckPointer(_hx_.mPtr);\n"; + output "\t\t\t#endif\n"; + output "\t\t\t#endif\n"; + Printf.sprintf + "\t\t\t%s( _hx_.mPtr->*( %s(_hx_.mPtr->_hx_getInterface(%s)))->_hx_%s )(%s);\n\t\t}\n" + returnStr cast interface.if_hash func.iff_name (print_arg_names func.iff_args) |> output + +let gen_includes h_file interface_def = + let add_class_includes cls = + match get_all_meta_string_path cls.cl_meta Meta.Include with + | [] -> + h_file#add_include cls.cl_path + | includes -> + List.iter (fun inc -> h_file#add_include (path_of_string inc)) includes in + + (* Include the real header file for the super class *) + match interface_def.cl_super with + | Some (cls, _) -> add_class_includes cls + | _ -> (); + + (* And any interfaces ... *) + interface_def.cl_implements + |> real_interfaces + |> List.iter (fun (cls, _) -> add_class_includes cls) + +let gen_forward_decls h_file tcpp_interface ctx common_ctx = + (* Only need to forward-declare classes that are mentioned in the header file (ie, not the implementation) *) + let header_referenced, header_flags = + CppReferences.find_referenced_types_flags ctx (TClassDecl tcpp_interface.if_class) None ctx.ctx_super_deps PathMap.empty true false tcpp_interface.if_scriptable + in + + List.iter2 + (fun r f -> gen_forward_decl h_file r f) + header_referenced header_flags + +let gen_header_includes interface_def output_h = + output_h "\n"; + output_h (get_class_code interface_def Meta.HeaderCode); + let includes = get_all_meta_string_path interface_def.cl_meta Meta.HeaderInclude in + let printer inc = output_h ("#include \"" ^ inc ^ "\"\n") in + List.iter printer includes + +let gen_body tcpp_interface ctx output_h iter = + if has_boot_field tcpp_interface.if_class then output_h "\t\tstatic void __boot();\n"; + + all_interface_functions tcpp_interface |> List.iter iter; + + match get_meta_string tcpp_interface.if_class.cl_meta Meta.ObjcProtocol with + | Some protocol -> + output_h ("\t\tstatic id<" ^ protocol ^ "> _hx_toProtocol(Dynamic inImplementation);\n") + | None -> + (); + + output_h (get_class_code tcpp_interface.if_class Meta.HeaderClassCode) + +let generate_native_interface base_ctx tcpp_interface = + let common_ctx = base_ctx.ctx_common in + let class_path = tcpp_interface.if_class.cl_path in + + let parent, super = + match tcpp_interface.if_class.cl_super with + | Some (klass, params) -> + let name = tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) in + ( "virtual " ^ name, name ) + | None -> + ("virtual ::hx::NativeInterface", "::hx::NativeInterface") + in + + let h_file = new_header_file common_ctx common_ctx.file class_path in + let ctx = file_context base_ctx h_file tcpp_interface.if_debug_level true in + let output_h = h_file#write in + let def_string = join_class_path class_path "_" in + + begin_header_file h_file#write_h def_string true; + + gen_includes h_file tcpp_interface.if_class; + gen_forward_decls h_file tcpp_interface ctx common_ctx; + gen_header_includes tcpp_interface.if_class output_h; + + begin_namespace output_h class_path; + output_h "\n\n"; + output_h (get_class_code tcpp_interface.if_class Meta.HeaderNamespaceCode); + + output_h ("class " ^ (attribs common_ctx) ^ " " ^ tcpp_interface.if_name ^ " : public " ^ parent); + + tcpp_interface.if_class.cl_implements + |> List.filter (fun (t, _) -> is_native_gen_class t) + |> List.iter (fun (c, _) -> output_h (" , public virtual " ^ join_class_path c.cl_path "::")); + + output_h "\n{\n\tpublic:\n"; + output_h ("\t\ttypedef " ^ super ^ " super;\n"); + output_h ("\t\ttypedef " ^ tcpp_interface.if_name ^ " OBJ_;\n"); + + CppGen.generate_native_constructor ctx output_h tcpp_interface.if_class true; + + gen_body tcpp_interface ctx output_h (gen_native_function ctx tcpp_interface); + + output_h "};\n\n"; + + end_namespace output_h class_path; + end_header_file output_h def_string; + + h_file#close + +let generate_managed_interface base_ctx tcpp_interface = + let common_ctx = base_ctx.ctx_common in + let class_path = tcpp_interface.if_class.cl_path in + + let super = + match tcpp_interface.if_class.cl_super with + | Some (klass, params) -> + tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) + | None -> + "::hx::Object" + in + let h_file = new_header_file common_ctx common_ctx.file class_path in + let ctx = file_context base_ctx h_file tcpp_interface.if_debug_level true in + let output_h = h_file#write in + let def_string = join_class_path class_path "_" in + + begin_header_file h_file#write_h def_string false; + + gen_includes h_file tcpp_interface.if_class; + gen_forward_decls h_file tcpp_interface ctx common_ctx; + gen_header_includes tcpp_interface.if_class output_h; + + begin_namespace output_h class_path; + output_h "\n\n"; + output_h (get_class_code tcpp_interface.if_class Meta.HeaderNamespaceCode); + + output_h ("class " ^ (attribs common_ctx) ^ " " ^ tcpp_interface.if_name ^ " {\n"); + output_h "\tpublic:\n"; + output_h ("\t\ttypedef " ^ super ^ " super;\n"); + output_h "\t\tHX_DO_INTERFACE_RTTI;\n\n"; + + gen_body tcpp_interface ctx output_h (gen_function ctx tcpp_interface); + + output_h "};\n\n"; + + end_namespace output_h class_path; + end_header_file output_h def_string; + + h_file#close \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml new file mode 100644 index 00000000000..b2d8a71f43d --- /dev/null +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -0,0 +1,266 @@ +open Ast +open Type +open Error +open Common +open Globals +open CppStrings +open CppTypeUtils +open CppAst +open CppAstTools +open CppSourceWriter +open CppContext +open CppGen + +let generate_protocol_delegate ctx protocol full_class_name functions output = + let name = "_hx_" ^ protocol ^ "_delegate" in + output ("@interface " ^ name ^ " : NSObject<" ^ protocol ^ "> {\n"); + output "\t::hx::Object *haxeObj;\n"; + output "}\n"; + output "@end\n\n"; + output ("@implementation " ^ name ^ "\n"); + output "- (id)initWithImplementation:( ::hx::Object *)inInplemnetation {\n"; + output " if (self = [super init]) {\n"; + output " self->haxeObj = inInplemnetation;\n"; + output " GCAddRoot(&self->haxeObj);\n"; + output " }\n"; + output " return self;\n"; + output "}\n"; + output "- (void)dealloc {\n"; + output " GCRemoveRoot(&self->haxeObj);\n"; + output " #ifndef OBJC_ARC\n"; + output " [super dealloc];\n"; + output " #endif\n"; + output "}\n\n"; + + let dump_delegate func = + let retStr = type_to_string func.iff_return in + let fieldName, argNames = + match get_meta_string func.iff_field.cf_meta Meta.ObjcProtocol with + | Some nativeName -> + let parts = ExtString.String.nsplit nativeName ":" in + (List.hd parts, parts) + | None -> (func.iff_field.cf_name, List.map (fun (n, _, _) -> n) func.iff_args) + in + output ("- (" ^ retStr ^ ") " ^ fieldName); + + let first = ref true in + (try + List.iter2 + (fun (name, _, argType) signature_name -> + if !first then + output (" :(" ^ type_to_string argType ^ ")" ^ name) + else + output + (" " ^ signature_name ^ ":(" ^ type_to_string argType ^ ")" + ^ name); + first := false) + func.iff_args argNames + with Invalid_argument _ -> + abort + (let argString = + String.concat "," (List.map (fun (name, _, _) -> name) func.iff_args) + in + "Invalid arg count in delegate in " ^ func.iff_field.cf_name ^ " '" + ^ func.iff_field.cf_name ^ "," ^ argString ^ "' != '" + ^ String.concat "," argNames ^ "'") + func.iff_field.cf_pos); + output " {\n"; + output "\t::hx::NativeAttach _hx_attach;\n"; + output + ((if retStr = "void" then "\t" else "\treturn ") + ^ full_class_name ^ "::" + ^ func.iff_name + ^ "(haxeObj"); + List.iter (fun (name, _, _) -> output ("," ^ name)) func.iff_args; + output ");\n}\n\n" + in + List.iter dump_delegate functions; + + output "@end\n\n" + +let generate_managed_interface base_ctx tcpp_interface = + let class_path = tcpp_interface.if_class.cl_path in + let cpp_file = new_placed_cpp_file base_ctx.ctx_common class_path in + let cpp_ctx = file_context base_ctx cpp_file tcpp_interface.if_debug_level false in + let ctx = cpp_ctx in + let output_cpp = cpp_file#write in + let strq = strq ctx.ctx_common in + + cpp_file#write_h "#include \n\n"; + + let all_referenced = + CppReferences.find_referenced_types ctx (TClassDecl tcpp_interface.if_class) ctx.ctx_super_deps + ctx.ctx_constructor_deps false false tcpp_interface.if_scriptable + in + List.iter (add_include cpp_file) all_referenced; + + if tcpp_interface.if_scriptable then cpp_file#write_h "#include \n"; + + cpp_file#write_h "\n"; + + output_cpp (get_class_code tcpp_interface.if_class Meta.CppFileCode); + let includes = get_all_meta_string_path tcpp_interface.if_class.cl_meta Meta.CppInclude in + let printer inc = output_cpp ("#include \"" ^ inc ^ "\"\n") in + List.iter printer includes; + + begin_namespace output_cpp class_path; + output_cpp "\n"; + + output_cpp (get_class_code tcpp_interface.if_class Meta.CppNamespaceCode); + + output_cpp "\n"; + + (* cl_interface *) + let var_folder cur acc = if (reflective tcpp_interface.if_class cur) then strq cur.cf_name :: acc else acc in + let fun_folder cur acc = if (reflective tcpp_interface.if_class cur.iff_field) then strq cur.iff_field.cf_name :: acc else acc in + let members = + [ "\t::String(null())" ] + |> List.fold_right var_folder tcpp_interface.if_variables + |> List.fold_right fun_folder tcpp_interface.if_functions + |> List.map (fun n -> Printf.sprintf "\t%s" n) + in + + let sMemberFields = + if List.length members > 1 then + let memberFields = tcpp_interface.if_name ^ "_sMemberFields" in + let concat = String.concat ",\n" members in + + Printf.sprintf "static ::String %s[] = {\n%s\n};\n\n" memberFields concat |> output_cpp; + + memberFields + else + "0 /* sMemberFields */" + in + + let all_functions = all_interface_functions tcpp_interface in + + if tcpp_interface.if_scriptable then ( + let dump_script_field idx func = + let args = print_tfun_arg_list true func.iff_args in + let return_type = type_to_string func.iff_return in + let ret = if return_type = "Void" || return_type = "void" then " " else "return " in + + output_cpp ("\t" ^ return_type ^ " " ^ func.iff_name ^ "( " ^ args ^ " ) {\n"); + output_cpp "\t\t::hx::CppiaCtx *__ctx = ::hx::CppiaCtx::getCurrent();\n"; + output_cpp "\t\t::hx::AutoStack __as(__ctx);\n"; + output_cpp "\t\t__ctx->pushObject(this);\n"; + List.iter + (fun (name, opt, t) -> + output_cpp + ("\t\t__ctx->push" ^ CppCppia.script_type t opt ^ "(" ^ name ^ ");\n")) + func.iff_args; + let interfaceSlot = string_of_int (func.iff_script_slot |> Option.map (fun v -> -v) |> Option.default 0) in + output_cpp + ("\t\t" ^ ret ^ "__ctx->run" + ^ CppCppia.script_type func.iff_return false + ^ "(__GetScriptVTable()[" ^ interfaceSlot ^ "]);\n"); + output_cpp "\t}\n"; + in + + let script_name = tcpp_interface.if_name ^ "__scriptable" in + + output_cpp ("class " ^ script_name ^ " : public ::hx::Object {\n"); + output_cpp "public:\n"; + + ExtList.List.iteri dump_script_field all_functions; + output_cpp "};\n\n"; + + let generate_script_function func = + let scriptName = ("__s_" ^ func.iff_field.cf_name) in + + output_cpp ("\nstatic void CPPIA_CALL " ^ scriptName ^ "(::hx::CppiaCtx *ctx) {\n"); + let ret = + match cpp_type_of func.iff_return with + | TCppScalar "bool" -> "b" + | _ -> CppCppia.script_signature func.iff_return false in + if ret <> "v" then + output_cpp ("ctx->return" ^ CppCppia.script_type func.iff_return false ^ "("); + + let signature = + output_cpp (tcpp_interface.if_name ^ "::" ^ func.iff_name ^ "(ctx->getThis()" ^ if List.length func.iff_args > 0 then "," else ""); + + let signature, _, _ = + List.fold_left + (fun (signature, sep, size) (_, opt, t) -> + output_cpp (sep ^ "ctx->get" ^ CppCppia.script_type t opt ^ "(" ^ size ^ ")"); + ( signature ^ CppCppia.script_signature t opt, ",", size ^ "+sizeof(" ^ CppCppia.script_size_type t opt ^ ")" )) + (ret, "", "sizeof(void*)") func.iff_args in + output_cpp ")"; + signature + in + + if ret <> "v" then output_cpp ")"; + output_cpp ";\n}\n"; + (signature, func) + in + + (match all_functions with + | [] -> + output_cpp "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n" + | _ -> + let sig_and_funcs = List.map generate_script_function all_functions in + + output_cpp "#ifndef HXCPP_CPPIA_SUPER_ARG\n"; + output_cpp "#define HXCPP_CPPIA_SUPER_ARG(x)\n"; + output_cpp "#endif\n"; + output_cpp "static ::hx::ScriptNamedFunction __scriptableFunctions[] = {\n"; + let dump_func (s, func) = + Printf.sprintf + "\t::hx::ScriptNamedFunction(\"%s\", __s_%s, \"%s\", false HXCPP_CPPIA_SUPER_ARG(0)),\n" + func.iff_field.cf_name + func.iff_field.cf_name + s |> output_cpp; + in + List.iter dump_func sig_and_funcs; + output_cpp "\t::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) ) };\n"); + + let mapper f = Printf.sprintf "\t%s&%s::%s" (cpp_tfun_signature true f.iff_args f.iff_return) script_name f.iff_name in + let strings = + all_functions + |> List.map mapper + |> String.concat ",\n" in + + Printf.sprintf "\n\n%s %s_scriptable = {\n%s\n};\n" tcpp_interface.if_name tcpp_interface.if_name strings |> output_cpp); + + let class_name_text = join_class_path class_path "." in + + output_cpp ("::hx::Class " ^ tcpp_interface.if_name ^ "::__mClass;\n\n"); + + output_cpp ("void " ^ tcpp_interface.if_name ^ "::__register()\n{\n"); + + output_cpp "\t::hx::Static(__mClass) = new ::hx::Class_obj();\n"; + output_cpp ("\t__mClass->mName = " ^ strq class_name_text ^ ";\n"); + output_cpp "\t__mClass->mSuper = &super::__SGetClass();\n"; + output_cpp ("\t__mClass->mMembers = ::hx::Class_obj::dupFunctions(" ^ sMemberFields ^ ");\n"); + output_cpp ("\t__mClass->mCanCast = ::hx::TIsInterface< (int)" ^ tcpp_interface.if_hash ^ " >;\n"); + output_cpp "\t::hx::_hx_RegisterClass(__mClass->mName, __mClass);\n"; + if tcpp_interface.if_scriptable then + output_cpp (" HX_SCRIPTABLE_REGISTER_INTERFACE(\"" ^ class_name_text ^ "\"," ^ tcpp_interface.if_name ^ ");\n"); + output_cpp "}\n\n"; + + if has_boot_field tcpp_interface.if_class then ( + output_cpp ("void " ^ tcpp_interface.if_name ^ "::__boot()\n{\n"); + + let dot_name = join_class_path tcpp_interface.if_class.cl_path "." in + + (match tcpp_interface.if_meta with + | Some expr -> gen_cpp_init ctx dot_name "boot" "__mClass->__meta__ = " expr + | None -> ()); + + (match tcpp_interface.if_rtti with + | Some expr -> gen_cpp_init ctx dot_name "boot" "__mClass->__rtti__ = " expr + | None -> ()); + + output_cpp "}\n\n"); + + end_namespace output_cpp class_path; + + if Meta.has Meta.ObjcProtocol tcpp_interface.if_class.cl_meta then ( + let full_class_name = ("::" ^ join_class_path_remap class_path "::") ^ "_obj" in + let protocol = get_meta_string tcpp_interface.if_class.cl_meta Meta.ObjcProtocol |> Option.default "" in + generate_protocol_delegate ctx full_class_name protocol all_functions output_cpp; + output_cpp ("id<" ^ protocol ^ "> " ^ full_class_name ^ "::_hx_toProtocol(Dynamic inImplementation) {\n"); + output_cpp ("\treturn [ [_hx_" ^ protocol ^ "_delegate alloc] initWithImplementation:inImplementation.mPtr];\n"); + output_cpp "}\n\n"); + + cpp_file#close \ No newline at end of file diff --git a/src/generators/cpp/gen/cppReferences.ml b/src/generators/cpp/gen/cppReferences.ml index d90d8f344d4..294a72febaa 100644 --- a/src/generators/cpp/gen/cppReferences.ml +++ b/src/generators/cpp/gen/cppReferences.ml @@ -1,4 +1,5 @@ open Type +open CppAst open CppStrings open CppTypeUtils open CppAstTools @@ -9,7 +10,37 @@ open CppContext These are used for "#include"ing the appropriate header files, or for building the dependencies in the Build.xml file *) -let find_referenced_types_flags ctx obj field_name super_deps constructor_deps header_only for_depends include_super_args = +let find_referenced_types_flags ctx obj filter super_deps constructor_deps header_only for_depends include_super_args = + let all_virtual_functions clazz = + let current_virtual_functions_rev clazz base_functions = + let folder result elem = + match follow elem.cf_type, elem.cf_kind with + | _, Method MethDynamic -> result + | TFun (args,return_type), Method _ -> + if (is_override elem ) then + if List.exists (fun (e,a,r) -> e.cf_name=elem.cf_name ) result then + result + else + (elem,args,return_type) :: result + else + (elem,args,return_type) :: result + | _,_ -> result + in + + List.fold_left folder base_functions clazz.cl_ordered_fields + in + + let rec all_virtual_functions_rec clazz = + let initial = + match clazz.cl_super with + | Some (def, _) -> all_virtual_functions_rec def + | _ -> [] in + current_virtual_functions_rev clazz initial + in + + all_virtual_functions_rec clazz + in + let types = ref PMap.empty in (if for_depends then let include_files = @@ -22,7 +53,7 @@ let find_referenced_types_flags ctx obj field_name super_deps constructor_deps h let rec add_type_flag isNative in_path = if not (PMap.mem in_path !types) then ( types := PMap.add in_path isNative !types; - try List.iter (add_type_flag isNative) (Hashtbl.find super_deps in_path) + try List.iter (add_type_flag isNative) (PathMap.find in_path super_deps) with Not_found -> ()) and add_type in_path = add_type_flag false in_path in let add_extern_type decl = @@ -113,7 +144,7 @@ let find_referenced_types_flags ctx obj field_name super_deps constructor_deps h | TNew (klass, params, _) -> ( visit_type (TInst (klass, params)); try - let construct_type = Hashtbl.find constructor_deps klass.cl_path in + let construct_type = PathMap.find klass.cl_path constructor_deps in visit_type construct_type.cf_type with Not_found -> ()) (* Must visit type too, Type.iter will visit the expressions ... *) @@ -133,7 +164,7 @@ let find_referenced_types_flags ctx obj field_name super_deps constructor_deps h | TInst (klass, params) -> ( try let construct_type = - Hashtbl.find constructor_deps klass.cl_path + PathMap.find klass.cl_path constructor_deps in visit_type construct_type.cf_type with Not_found -> ()) @@ -164,8 +195,11 @@ let find_referenced_types_flags ctx obj field_name super_deps constructor_deps h (match class_def.cl_constructor with Some expr -> [ expr ] | _ -> []) in let fields_and_constructor = - if field_name = "*" then fields_and_constructor - else List.filter (fun f -> f.cf_name = field_name) fields_and_constructor + match filter with + | Some field_name -> + List.filter (fun f -> f.cf_name = field_name) fields_and_constructor + | None -> + fields_and_constructor in List.iter visit_field fields_and_constructor; if include_super_args then @@ -223,7 +257,7 @@ let find_referenced_types_flags ctx obj field_name super_deps constructor_deps h let find_referenced_types ctx obj super_deps constructor_deps header_only for_depends include_super_args = let deps, _ = - find_referenced_types_flags ctx obj "*" super_deps constructor_deps + find_referenced_types_flags ctx obj None super_deps constructor_deps header_only for_depends include_super_args in deps diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index a1c902d8a3e..a63a2d073ad 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -17,6 +17,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) open Ast +open CppAst open Gctx open Type open Error @@ -176,21 +177,65 @@ let write_build_options common_ctx filename defines = writer#close let create_member_types common_ctx = - let result = Hashtbl.create 0 in - List.iter (fun object_def -> - (match object_def with - | TClassDecl class_def when not (has_class_flag class_def CInterface) -> - let rec add_override to_super = - let class_name = (join_class_path to_super.cl_path ".") in - List.iter (fun member -> Hashtbl.add result (class_name ^ "." ^ member.cf_name) "virtual " ) class_def.cl_ordered_fields; - match to_super.cl_super with - | Some super -> add_override (fst super) - | _ -> () - in - (match class_def.cl_super with Some super -> add_override (fst super) | _->()) - | _ -> () - ) ) common_ctx.types; - result + let folder acc object_def = + match object_def with + | TClassDecl class_def when not (has_class_flag class_def CInterface) -> + let rec add_override acc to_super = + let class_name = (join_class_path to_super.cl_path ".") in + let folder acc member = StringMap.add (class_name ^ "." ^ member.cf_name) "virtual " acc in + let acc = List.fold_left folder acc class_def.cl_ordered_fields in + match to_super.cl_super with + | Some (super, _) -> add_override acc super + | _ -> acc + in + (match class_def.cl_super with Some (super, _) -> add_override acc super | _ -> acc) + | _ -> acc + in + List.fold_left folder StringMap.empty common_ctx.types + +(* Builds inheritance tree, so header files can include parents defs. *) +let create_super_dependencies common_ctx = + let real_non_native_interfaces = + List.filter (function t, pl -> + (match (t, pl) with + | { cl_path = [ "cpp"; "rtti" ], _ }, [] -> false + | _ -> not (is_native_gen_class t))) + in + let folder acc object_def = + match object_def with + | TClassDecl class_def when not (has_class_flag class_def CExtern) -> + let initial = match class_def.cl_super with + | Some (cls, _) when not (has_class_flag cls CExtern) -> + [ cls.cl_path ] + | _ -> + [] in + + let deps = + class_def.cl_implements + |> real_non_native_interfaces + |> List.fold_left + (fun acc (cls, _) -> if has_class_flag cls CExtern then acc else cls.cl_path :: acc) + initial in + + PathMap.add class_def.cl_path deps acc + | TEnumDecl enum_def when not (has_enum_flag enum_def EnExtern) -> + PathMap.add enum_def.e_path [] acc + | _ -> + acc + in + List.fold_left folder PathMap.empty common_ctx.types + +let create_constructor_dependencies common_ctx = + List.fold_left + (fun acc object_def -> + match object_def with + | TClassDecl class_def when not (has_class_flag class_def CExtern) -> + (match class_def.cl_constructor with + | Some func -> PathMap.add class_def.cl_path func acc + | None -> acc) + | _ -> acc) + PathMap.empty + common_ctx.types let is_assign_op op = match op with @@ -198,107 +243,128 @@ let is_assign_op op = | OpAssignOp _ -> true | _ -> false -let generate_class_files ctx class_def = - (* create header and cpp files *) - let nativeGen = Meta.has Meta.NativeGen class_def.cl_meta in - if not (nativeGen && (has_class_flag class_def CInterface)) then - CppGenClassImplementation.generate ctx class_def; - CppGenClassHeader.generate ctx class_def - (* The common_ctx contains the haxe AST in the "types" field and the resources *) + +type gensrc_ctx = { + extern_src : string list; + build_xml : string; + boot_classes : path list; + init_classes : path list; + nonboot_classes : path list; + boot_enums : path list; + exe_classes : (path * path list * module_type) list; + decls : tcpp_decl list; + ids : CppAst.ObjectIds.t; + slots : CppAst.InterfaceSlots.t; +} + let generate_source ctx = let common_ctx = ctx.ctx_common in - let debug = ctx.ctx_debug_level in make_base_directory common_ctx.file; - let exe_classes = ref [] in - let boot_classes = ref [] in - let boot_enums = ref [] in - let nonboot_classes = ref [] in - let init_classes = ref [] in - let super_deps = CppGen.create_super_dependencies common_ctx in - let constructor_deps = CppGen.create_constructor_dependencies common_ctx in let main_deps = ref [] in - let extern_src = ref [] in - let jobs = ref [] in - let build_xml = ref "" in let scriptable = (Gctx.defined common_ctx Define.Scriptable) in - let existingIds = Hashtbl.create 0 in - List.iter (fun object_def -> - (* check if any @:objc class is referenced while '-D objc' is not defined - This will guard all code changes to this flag *) - (if not (Gctx.defined common_ctx Define.Objc) then match object_def with + let initial = { + extern_src = []; + build_xml = ""; + boot_classes = []; + init_classes = []; + nonboot_classes = []; + boot_enums = []; + exe_classes = []; + decls = []; + ids = ObjectIds.empty; + slots = InterfaceSlots.empty; + } in + + let folder acc cur = + (if not (Gctx.defined common_ctx Define.Objc) then + match cur with | TClassDecl class_def when Meta.has Meta.Objc class_def.cl_meta -> abort "In order to compile '@:objc' classes, please define '-D objc'" class_def.cl_pos | _ -> ()); - (match object_def with + + match cur with | TClassDecl class_def when is_extern_class class_def -> - build_xml := !build_xml ^ (CppGen.get_class_code class_def Meta.BuildXml); - let source = get_meta_string_path class_def.cl_meta Meta.SourceFile in - if (source<>"") then - extern_src := source :: !extern_src; + let acc_build_xml = acc.build_xml ^ (CppGen.get_class_code class_def Meta.BuildXml) in + let acc_extern_src = + match Ast.get_meta_string class_def.cl_meta Meta.SourceFile with + | Some source -> make_path_absolute source class_def.cl_pos :: acc.extern_src + | None -> acc.extern_src in + + { acc with build_xml = acc_build_xml; extern_src = acc_extern_src } + + | TClassDecl class_def when is_internal_class class_def.cl_path || Meta.has Meta.Macro class_def.cl_meta -> + acc + | 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 || (Meta.has Meta.Macro class_def.cl_meta)) then - ( if (debug>=4) then print_endline (" internal class " ^ name )) - else begin - let rec makeId class_name seed = - let id = gen_hash32 seed class_name in - (* reserve first 100 ids for runtime *) - if id < Int32.of_int 100 || Hashtbl.mem existingIds id then - makeId class_name (seed+100) - else begin - Hashtbl.add existingIds id true; - Hashtbl.add ctx.ctx_type_ids class_name id; - end in - makeId name 0; - - build_xml := !build_xml ^ (CppGen.get_class_code class_def Meta.BuildXml); - if (has_init_field class_def) then - init_classes := class_def.cl_path :: !init_classes; - if (has_boot_field class_def) then - boot_classes := class_def.cl_path :: !boot_classes - else if not (Meta.has Meta.NativeGen class_def.cl_meta) then - nonboot_classes := class_def.cl_path :: !nonboot_classes; - jobs := (fun () -> generate_class_files ctx class_def) :: !jobs; - let deps = CppReferences.find_referenced_types ctx (TClassDecl class_def) super_deps constructor_deps false true scriptable in - if not ((has_class_flag class_def CInterface) && (is_native_gen_class class_def)) then - exe_classes := (class_def.cl_path, deps, object_def) :: !exe_classes; - end - | TEnumDecl enum_def when has_enum_flag enum_def EnExtern -> () - | 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>1) then print_endline (" internal enum " ^ name )) - else begin - let rec makeId enum_name seed = - let id = gen_hash32 seed enum_name in - (* reserve first 100 ids for runtime *) - if id < Int32.of_int 100 || Hashtbl.mem existingIds id then - makeId enum_name (seed+100) - else begin - Hashtbl.add existingIds id true; - Hashtbl.add ctx.ctx_type_ids enum_name id; - end in - makeId name 0; - - if (has_enum_flag enum_def EnExtern) then - (if (debug>1) then print_endline ("external enum " ^ name )); - boot_enums := enum_def.e_path :: !boot_enums; - jobs := (fun () -> CppGenEnum.generate ctx enum_def) :: !jobs; - let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) super_deps (Hashtbl.create 0) false true false in - exe_classes := (enum_def.e_path, deps, object_def) :: !exe_classes; - end - | TTypeDecl _ | TAbstractDecl _ -> (* already done *) () - ); - ) common_ctx.types; - - List.iter (fun job -> job () ) !jobs; + let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in + let decl, slots, ids = + match has_class_flag class_def CInterface with + | true -> + let (slots, iface) = CppRetyper.tcpp_interface_from_tclass ctx acc.slots class_def in + if native_gen then (NativeInterface iface, slots, acc.ids) else (ManagedInterface iface, acc.slots, acc.ids) + | false -> + let (slots, ids, cls) = CppRetyper.tcpp_class_from_tclass ctx acc.ids acc.slots class_def [] in + if native_gen then (NativeClass cls, slots, ids) else (ManagedClass cls, slots, ids) in + + let acc_decls = decl :: acc.decls in + let acc_build_xml = acc.build_xml ^ (CppGen.get_class_code class_def Meta.BuildXml) in + let acc_init_classes = if has_init_field class_def then class_def.cl_path :: acc.init_classes else acc.init_classes in + let acc_boot_classes = if has_boot_field class_def then class_def.cl_path :: acc.boot_classes else acc.boot_classes in + let acc_nonboot_classes = if Meta.has Meta.NativeGen class_def.cl_meta then acc.nonboot_classes else class_def.cl_path :: acc.nonboot_classes in + let acc_exe_classes = + if (has_class_flag class_def CInterface) && (is_native_gen_class class_def) then + acc.exe_classes + else + let deps = CppReferences.find_referenced_types ctx (TClassDecl class_def) ctx.ctx_super_deps ctx.ctx_constructor_deps false true scriptable in + + (class_def.cl_path, deps, cur) :: acc.exe_classes in + + { acc with + build_xml = acc_build_xml; + decls = acc_decls; + init_classes = acc_init_classes; + boot_classes = acc_boot_classes; + nonboot_classes = acc_nonboot_classes; + exe_classes = acc_exe_classes; + ids = ids; + slots = slots + } + + | TEnumDecl enum_def when is_extern_enum enum_def || is_internal_class enum_def.e_path -> + acc + | TEnumDecl enum_def -> + let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps PathMap.empty false true false in + let ids, enum = CppRetyper.tcpp_enum_from_tenum ctx acc.ids enum_def in + let acc_decls = (Enum enum) :: acc.decls in + let acc_boot_enums = enum_def.e_path :: acc.boot_enums in + let acc_exe_classes = (enum_def.e_path, deps, cur) :: acc.exe_classes in + + { acc with decls = acc_decls; boot_enums = acc_boot_enums; exe_classes = acc_exe_classes; ids = ids } + | _ -> + acc + in + let srcctx = List.fold_left folder initial common_ctx.types in + + List.iter (fun tcpp_type -> + match tcpp_type with + | ManagedClass tcpp_class -> + CppGenClassHeader.generate_managed_header ctx tcpp_class; + CppGenClassImplementation.generate_managed_class ctx tcpp_class; + | NativeClass tcpp_class -> + CppGenClassHeader.generate_native_header ctx tcpp_class; + CppGenClassImplementation.generate_native_class ctx tcpp_class; + | ManagedInterface interface_def -> + CppGenInterfaceHeader.generate_managed_interface ctx interface_def; + CppGenInterfaceImplementation.generate_managed_interface ctx interface_def; + | NativeInterface interface_def -> + CppGenInterfaceHeader.generate_native_interface ctx interface_def + | Enum tcpp_enum -> + CppGenEnum.generate ctx tcpp_enum) srcctx.decls; (match common_ctx.main.main_expr with | None -> CppGen.generate_dummy_main common_ctx @@ -307,11 +373,11 @@ let generate_source ctx = cf_expr = Some e; } in let class_def = { null_class with cl_path = ([],"@Main"); cl_ordered_statics = [main_field] } in - main_deps := CppReferences.find_referenced_types ctx (TClassDecl class_def) super_deps constructor_deps false true false; - CppGen.generate_main ctx super_deps class_def + main_deps := CppReferences.find_referenced_types ctx (TClassDecl class_def) ctx.ctx_super_deps ctx.ctx_constructor_deps false true false; + CppGen.generate_main ctx ctx.ctx_super_deps class_def ); - CppGen.generate_boot ctx !boot_enums !boot_classes !nonboot_classes !init_classes; + CppGen.generate_boot ctx srcctx.boot_enums srcctx.boot_classes srcctx.nonboot_classes srcctx.init_classes srcctx.slots; CppGen.generate_files common_ctx ctx.ctx_file_info; @@ -351,7 +417,7 @@ let generate_source ctx = | TEnumDecl enum_def -> out ("enum " ^ (spath name) ^ "\n"); | _ -> () - ) !exe_classes; + ) srcctx.exe_classes; (* Output file info too *) List.iter ( fun file -> @@ -367,7 +433,7 @@ let generate_source ctx = | Some path -> (snd path) | _ -> "output" in - write_build_data common_ctx (common_ctx.file ^ "/Build.xml") !exe_classes !main_deps (!boot_enums@ !boot_classes) !build_xml !extern_src output_name; + write_build_data common_ctx (common_ctx.file ^ "/Build.xml") srcctx.exe_classes !main_deps (srcctx.boot_enums@ srcctx.boot_classes) srcctx.build_xml srcctx.extern_src output_name; write_build_options common_ctx (common_ctx.file ^ "/Options.txt") common_ctx.defines.Define.values; if ( not (Gctx.defined common_ctx Define.NoCompilation) ) then begin let t = Timer.timer ["generate";"cpp";"native compilation"] in @@ -391,10 +457,12 @@ let generate_source ctx = let generate common_ctx = let debug_level = if (Gctx.defined common_ctx Define.NoDebug) then 0 else 1 in + let super_deps = create_super_dependencies common_ctx in + let constructor_deps = create_constructor_dependencies common_ctx in if (Gctx.defined common_ctx Define.Cppia) then begin - let ctx = new_context common_ctx debug_level (ref PMap.empty) (Hashtbl.create 0) in + let ctx = new_context common_ctx debug_level (ref PMap.empty) StringMap.empty super_deps constructor_deps in CppCppia.generate_cppia ctx - end else begin - let ctx = new_context common_ctx debug_level (ref PMap.empty) (create_member_types common_ctx) in + end else begin + let ctx = new_context common_ctx debug_level (ref PMap.empty) (create_member_types common_ctx) super_deps constructor_deps in generate_source ctx end